diff --git a/LeanPool.lean b/LeanPool.lean index a2da06359d..a2a9291f87 100644 --- a/LeanPool.lean +++ b/LeanPool.lean @@ -4537,6 +4537,616 @@ public import LeanPool.MRiscX.Tactics.SpecificationTactics public import LeanPool.MRiscX.Tactics.SplitLastSeq public import LeanPool.MRiscX.Tactics.TacticUtil public import LeanPool.MRiscX.Util.BasicTheorems +public import LeanPool.MarkoffModP +public import LeanPool.MarkoffModP.BGS +public import LeanPool.MarkoffModP.BGS.Algebra.ClearedLinearFractionalSubstitution +public import LeanPool.MarkoffModP.BGS.Algebra.DifferentialWronskian +public import LeanPool.MarkoffModP.BGS.Algebra.KummerEigencharacterDescent +public import LeanPool.MarkoffModP.BGS.Algebra.RatFuncLinearFractionalEquiv +public import LeanPool.MarkoffModP.BGS.AlgebraicGeometry.ConstantOpenGlueData +public import LeanPool.MarkoffModP.BGS.AlgebraicGeometry.SpecRingEquiv +public import LeanPool.MarkoffModP.BGS.Combinatorics.DivisorExponentCoefficient +public import LeanPool.MarkoffModP.BGS.Combinatorics.DivisorExponentSpernerBridge +public import LeanPool.MarkoffModP.BGS.Combinatorics.ProductOfChainsGrid +public import LeanPool.MarkoffModP.BGS.Combinatorics.ProductOfChainsSperner +public import LeanPool.MarkoffModP.BGS.Combinatorics.SymmetricChainBasic +public import LeanPool.MarkoffModP.BGS.Combinatorics.SymmetricChainProduct +public import LeanPool.MarkoffModP.BGS.Combinatorics.SymmetricChainRectangle +public import LeanPool.MarkoffModP.BGS.CorvajaZannier +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.AbsoluteIrreducibilityBaseChange +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.AuxiliaryFamily +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.AuxiliaryFamilyIndexing +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.BivariateGauss +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.BivariateResultant +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.CompletionLinearDisjointness +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.DedekindAuxiliaryCaseI +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.DedekindAuxiliaryLocalCases +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.DedekindAuxiliaryWronskian +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.DedekindCanonicalDifferentScaling +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.DedekindDifferentDivisor +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.DedekindDifferentKaehler +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.DedekindLeadingTermCancellation +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.DedekindLocalDerivationExtension +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.DedekindLocalWronskian +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.DedekindLocalizationDerivationPreservation +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.DedekindLocalizationOrder +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.DedekindPerfectResidueCaseI +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.DedekindPlaceOrder +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.DedekindRamifiedDerivationScaling +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.ElementaryFiniteFieldBound +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.EndpointComposition +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionCanonicalAuxiliaryFinitePlace +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionCanonicalAuxiliaryFinitePlaceNormalized +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionCanonicalAuxiliaryInfinityPlace +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionCanonicalDifferentDivisor +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionCanonicalGcdBound +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionCanonicalGlobalGcdBound +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionCanonicalGlobalNormalized +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionCanonicalGlobalNormalizedAutomatic +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionCanonicalPlaceSum +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionCanonicalPlacewiseScaling +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionCanonicalWronskian +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionExceptionalPlaceBounds +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionExceptionalSupport +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionExhaustiveProductFormula +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionGcdOutsideHeight +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionOneSubGcdHeight +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionPolynomialHeight +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionPositiveDegreePower +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionPrincipalDivisor +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionProductFormula +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionResidueSurjectivity +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteFunctionFieldDegree +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FinitePlaceCompletion +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FrobeniusSubfield +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FrobeniusWronskian +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FunctionFieldProductFormula +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.GeneralCorvajaZannier +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.GlobalWronskianPlaceSum +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.GlobalWronskianSummation +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.GlobalWronskianWeightedPlaceSum +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.InfinityInertiaDegree +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.InfinityPlace +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.LaurentFrobeniusBasis +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.LaurentFrobeniusPowerBasis +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.LocalAuxiliaryCaseI +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.LocalAuxiliaryWronskian +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.LocalDerivative +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.LocalMonogenicity +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.LocalReciprocalDiscriminant +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.LocalWronskian +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.NumericalCorollary +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.NumericalOptimization +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.ParameterizedBound +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PerfectConstants +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveAuxiliaryFinitePlace +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveAuxiliaryFinitePlaceCases +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveAuxiliaryFinitePlacePrincipalDivisor +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveAuxiliaryIndependence +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveBidegreeBridge +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveBoundarySupport +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveCanonicalDegreeBound +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveCanonicalEulerBound +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveCanonicalGcdBound +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveCharacteristicCardinality +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveCoordinatePowerHeight +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveDiagonalStabilizer +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveDiscriminantBound +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveExhaustiveGcdEndpoint +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveFiniteDifferentBound +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveFunctionField +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveInfinityComplement +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveInfinityDifferentBound +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveInfinityDifferentDegree +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveLocalReciprocalDiscriminant +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveLogarithmicGauss +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurvePoweredHeightBounds +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurvePoweredImageDegreeBudget +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurvePropositionTwoAssembly +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurvePropositionTwoDegreeBridge +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurvePropositionTwoGeometric +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveRatFuncModel +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveSeparability +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveSharedOriginBoundary +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveSupportDeterminant +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveSupportRank +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PoweredCoordinateRelation +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PoweredCoordinates +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PoweredImageBaseChange +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PoweredImageCurve +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PoweredImageExactSupportIndexBound +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PoweredImageFrobeniusRelation +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PoweredImageFrobeniusRelationSwapped +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PoweredImageGaloisBound +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PoweredImageHeightFactor +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PoweredImageIndex +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PoweredImageIndexBound +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PropositionTwoDegreeMonotonicity +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.RatFuncExhaustiveProductFormula +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.SeparatingCoordinateNotFrobenius +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.TorsionBidegreeCount +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.TorsionExhaustiveGcdDivisorBound +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.TorsionGcdDivisorBound +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.TorsionPointNormalization +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.TorusCharacterKernelBound +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.TranscendentalPowerDegree +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.WronskianChangeParameter +public import LeanPool.MarkoffModP.BGS.Dynamics.FiniteForwardOrbit +public import LeanPool.MarkoffModP.BGS.Dynamics.StrictMeasureEscape +public import LeanPool.MarkoffModP.BGS.External.GeneralCurveTheorems +public import LeanPool.MarkoffModP.BGS.FiniteField.EllipticCharacterSum +public import LeanPool.MarkoffModP.BGS.FiniteField.HasseFrobenius +public import LeanPool.MarkoffModP.BGS.FiniteField.QuadraticCharacter +public import LeanPool.MarkoffModP.BGS.HasseWeil.AffinePointPlace +public import LeanPool.MarkoffModP.BGS.HasseWeil.CechRiemannLinearAlgebra +public import LeanPool.MarkoffModP.BGS.HasseWeil.ClosedPlaceEulerRecurrence +public import LeanPool.MarkoffModP.BGS.HasseWeil.ConstantExtensionClosedPlaceCount +public import LeanPool.MarkoffModP.BGS.HasseWeil.ConstantExtensionClosedPlaceSplittingFormula +public import LeanPool.MarkoffModP.BGS.HasseWeil.ConstantExtensionFinitePlaceBridge +public import LeanPool.MarkoffModP.BGS.HasseWeil.ConstantExtensionInfinityPlaceBridge +public import LeanPool.MarkoffModP.BGS.HasseWeil.ConstantExtensionInfinityPlaceDegreeTower +public import LeanPool.MarkoffModP.BGS.HasseWeil.ConstantExtensionInfinityPlaceSplittingMultiplicity +public import LeanPool.MarkoffModP.BGS.HasseWeil.ConstantExtensionPlaceSplittingMultiplicity +public import LeanPool.MarkoffModP.BGS.HasseWeil.ConstantExtensionRationalPlace +public import LeanPool.MarkoffModP.BGS.HasseWeil.ConstantFieldAutomorphism +public import LeanPool.MarkoffModP.BGS.HasseWeil.ConstantFieldFinitePlace +public import LeanPool.MarkoffModP.BGS.HasseWeil.ConstantFieldFinitePlaceDegree +public import LeanPool.MarkoffModP.BGS.HasseWeil.ConstantFieldInfinityBase +public import LeanPool.MarkoffModP.BGS.HasseWeil.ConstantFieldRatFuncCompatibility +public import LeanPool.MarkoffModP.BGS.HasseWeil.ConstantTensorResidue +public import LeanPool.MarkoffModP.BGS.HasseWeil.DVRLocalPoleOrder +public import LeanPool.MarkoffModP.BGS.HasseWeil.DedekindDifferentLocalTrace +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtension +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionAutomorphism +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionConstants +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionDifferentCoefficient +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionFiniteDifferent +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionFinitePlace +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionFinitePlaceCompatibility +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionFinitePlaceFrobeniusAverage +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionFrobeniusTwist +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionFrobeniusTwistBoundedError +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionFrobeniusTwistConstants +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionFrobeniusTwistDegree +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionFrobeniusTwistFinitePlaceAverage +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionFrobeniusTwistFinitePlaceBridge +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionFrobeniusTwistFinitePlaceUnramified +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionFrobeniusTwistGenus +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionFrobeniusTwistInfinityPlaceDescent +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionFrobeniusTwistInfinityPlaceEquivalence +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionFrobeniusTwistMultiplication +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionFrobeniusTwistRationalPlaceAverage +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionFrobeniusTwistRiemannLower +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionFrobeniusTwistStepanovUpper +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionGenusDegree +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionGenusInvariance +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionInfinityDifferent +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionInfinityNormalization +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionInfinityPlaceCompatibility +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionIntermediateFrobeniusTwistFinitePlaceAverage +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionIntermediateFrobeniusTwistHasseBound +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionIntermediateFrobeniusTwistRationalPlaceAverage +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionNormalClosureTower +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionQuotient +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionRationalPlaceCount +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionRegularity +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionTotalDifferentDegree +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionTower +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExtensionEvenDegreeStepanovBound +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExtensionPointCount +public import LeanPool.MarkoffModP.BGS.HasseWeil.FilteredDimension +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteBranchLocus +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionAffineIdealDegree +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionAffineIdealDivisor +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionCanonicalDifferentCanonicalityCriterion +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionCanonicalDifferentCotrace +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionCanonicalDifferentCotraceCanonicality +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionCanonicalDifferentGenusBound +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionCanonicalDifferentLocalMaximality +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionClosedPlaceAlgEquiv +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionCotraceLocalTraceImage +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionDivisibleErrorFromConstantBase +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionDivisorClassRecurrence +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionDivisorDegreeIndex +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionEffectiveDivisorSplit +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionGenusBound +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionHasseBoundFromEvenConstantExtensions +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionHasseWeil +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionIndexedZetaRationality +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionIndexedZetaRationalityAutomatic +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionLocalPoleQuotient +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionLocalPoleSpace +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionPlaceAlgEquiv +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionPlaceDegreeFiniteness +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionPlaceTower +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionPrincipalParts +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionRiemannEventualGrowth +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionRiemannLowerFromGenus +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionRiemannRoch +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionRiemannShiftedEventualGrowth +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionRiemannSpace +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionRiemannSpaceProjectivization +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionStandardZetaRationality +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionTotalDifferentEffectiveDivisor +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionZeroCounting +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionZetaDegreeExtensionIdentity +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionZetaDegreeIndexOne +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionZetaDegreeIndexOneAutomatic +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionZetaDegreeIndexOneFromAllCounts +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionZetaNumeratorNoncancellation +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionZetaSimplePole +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteFieldCompositum +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteFieldConstantExtensionNormalization +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteFieldConstantExtensionResidue +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteFieldDivisibleExtension +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteFieldInfinityDifferent +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteFieldPolynomialDifferent +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteFieldPolynomialNormalization +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteFieldSubfield +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteLinearIndependenceBound +public import LeanPool.MarkoffModP.BGS.HasseWeil.FinitePlaceApproximation +public import LeanPool.MarkoffModP.BGS.HasseWeil.FinitePlaceFrobeniusFiber +public import LeanPool.MarkoffModP.BGS.HasseWeil.FinitePlaceNormalizationTransport +public import LeanPool.MarkoffModP.BGS.HasseWeil.FinitePrincipalParts +public import LeanPool.MarkoffModP.BGS.HasseWeil.FinsuppWeightedFiber +public import LeanPool.MarkoffModP.BGS.HasseWeil.FixedPointAverage +public import LeanPool.MarkoffModP.BGS.HasseWeil.FormalZetaConstantExtensionIdentity +public import LeanPool.MarkoffModP.BGS.HasseWeil.FormalZetaDegreeIndexOne +public import LeanPool.MarkoffModP.BGS.HasseWeil.FormalZetaDegreeIndexOneIndexed +public import LeanPool.MarkoffModP.BGS.HasseWeil.FormalZetaEuler +public import LeanPool.MarkoffModP.BGS.HasseWeil.FormalZetaEulerDegree +public import LeanPool.MarkoffModP.BGS.HasseWeil.FormalZetaHasseBound +public import LeanPool.MarkoffModP.BGS.HasseWeil.FormalZetaRationality +public import LeanPool.MarkoffModP.BGS.HasseWeil.FormalZetaRationalityDegree +public import LeanPool.MarkoffModP.BGS.HasseWeil.FormalZetaTrace +public import LeanPool.MarkoffModP.BGS.HasseWeil.FormalZetaUniqueness +public import LeanPool.MarkoffModP.BGS.HasseWeil.FrobeniusPlaceCardinality +public import LeanPool.MarkoffModP.BGS.HasseWeil.FrobeniusRestriction +public import LeanPool.MarkoffModP.BGS.HasseWeil.FrobeniusTwistGroup +public import LeanPool.MarkoffModP.BGS.HasseWeil.FunctionFieldConstantExtension +public import LeanPool.MarkoffModP.BGS.HasseWeil.FunctionFieldConstantField +public import LeanPool.MarkoffModP.BGS.HasseWeil.FunctionFieldNormalClosure +public import LeanPool.MarkoffModP.BGS.HasseWeil.FunctionFieldNormalClosureConstantBase +public import LeanPool.MarkoffModP.BGS.HasseWeil.FunctionFieldNormalClosureConstants +public import LeanPool.MarkoffModP.BGS.HasseWeil.FunctionFieldNormalClosureOriginalCompositum +public import LeanPool.MarkoffModP.BGS.HasseWeil.FunctionFieldNormalClosureOriginalField +public import LeanPool.MarkoffModP.BGS.HasseWeil.FunctionFieldNormalClosureRatFuncBase +public import LeanPool.MarkoffModP.BGS.HasseWeil.FunctionFieldNormalClosureRatFuncEquiv +public import LeanPool.MarkoffModP.BGS.HasseWeil.GaloisAverage +public import LeanPool.MarkoffModP.BGS.HasseWeil.GaloisTowerFactorialDegree +public import LeanPool.MarkoffModP.BGS.HasseWeil.GeneralBivariateAffineHasseWeil +public import LeanPool.MarkoffModP.BGS.HasseWeil.GeneralFiniteExtensionRiemannLower +public import LeanPool.MarkoffModP.BGS.HasseWeil.GeneralSquareFieldStepanovCount +public import LeanPool.MarkoffModP.BGS.HasseWeil.GeneralSquareFieldStepanovCountAutomatic +public import LeanPool.MarkoffModP.BGS.HasseWeil.IdealMultiplicityMap +public import LeanPool.MarkoffModP.BGS.HasseWeil.LinearFunctionalGluing +public import LeanPool.MarkoffModP.BGS.HasseWeil.LocalPoleCumulativeQuotient +public import LeanPool.MarkoffModP.BGS.HasseWeil.LocalPoleFiltration +public import LeanPool.MarkoffModP.BGS.HasseWeil.OnePointBase +public import LeanPool.MarkoffModP.BGS.HasseWeil.OnePointDivisorSplit +public import LeanPool.MarkoffModP.BGS.HasseWeil.OnePointHeight +public import LeanPool.MarkoffModP.BGS.HasseWeil.OnePointIncrement +public import LeanPool.MarkoffModP.BGS.HasseWeil.OnePointLeadingCoefficient +public import LeanPool.MarkoffModP.BGS.HasseWeil.OnePointPoleSemigroup +public import LeanPool.MarkoffModP.BGS.HasseWeil.OnePointSectionSelection +public import LeanPool.MarkoffModP.BGS.HasseWeil.OnePointStepanovBasisGrid +public import LeanPool.MarkoffModP.BGS.HasseWeil.OnePointStepanovDegreeTwoAuxiliary +public import LeanPool.MarkoffModP.BGS.HasseWeil.OnePointStepanovGrid +public import LeanPool.MarkoffModP.BGS.HasseWeil.OnePointStrictLevels +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneAffineCountTransfer +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneAffineFiberBound +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneAffineHasseWeilFromEvenError +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneAffineHasseWeilFromZeta +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneAffineRationalPlaceComparison +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneConstantField +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneCoordinatePole +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneCoordinatePoleAtInfinity +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneCoordinateShear +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneCurveGenusBoundAutomatic +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneCurveGenusBoundFromCotrace +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneCurveGenusBoundFromCotraceDegree +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneFinitePlaceRiemannLower +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneFrobeniusDeflation +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneFrobeniusDegenerate +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneFrobeniusReduction +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneInfinityRiemannLower +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneMonomialSpace +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneOnePointRiemannLower +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneRationalPlaceAffineComparison +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneRegularPointCount +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneSingularPointBound +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneSmoothPointNormalization +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneSquareFieldStepanovCount +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneSquareFieldStepanovCountAutomatic +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneStepanovAuxiliary +public import LeanPool.MarkoffModP.BGS.HasseWeil.PoleDivisor +public import LeanPool.MarkoffModP.BGS.HasseWeil.PolynomialSpectral +public import LeanPool.MarkoffModP.BGS.HasseWeil.PolynomialTensorCancel +public import LeanPool.MarkoffModP.BGS.HasseWeil.PowerSum +public import LeanPool.MarkoffModP.BGS.HasseWeil.RatFuncCanonicalInfinityDivisor +public import LeanPool.MarkoffModP.BGS.HasseWeil.RatFuncConstantExtension +public import LeanPool.MarkoffModP.BGS.HasseWeil.RatFuncExactConstantExtension +public import LeanPool.MarkoffModP.BGS.HasseWeil.RatFuncInfinityLocalization +public import LeanPool.MarkoffModP.BGS.HasseWeil.RatFuncParameterPole +public import LeanPool.MarkoffModP.BGS.HasseWeil.RationalPlace +public import LeanPool.MarkoffModP.BGS.HasseWeil.RationalPlaceTower +public import LeanPool.MarkoffModP.BGS.HasseWeil.RiemannSpaceConstants +public import LeanPool.MarkoffModP.BGS.HasseWeil.RiemannSpaceEffectiveIncrement +public import LeanPool.MarkoffModP.BGS.HasseWeil.RiemannSpaceFinitePlaceIncrement +public import LeanPool.MarkoffModP.BGS.HasseWeil.RiemannSpaceInfinityPlaceIncrement +public import LeanPool.MarkoffModP.BGS.HasseWeil.SpectralFromAsymptotic +public import LeanPool.MarkoffModP.BGS.HasseWeil.SquareExtensionAffinePlaces +public import LeanPool.MarkoffModP.BGS.HasseWeil.SquareFieldResidue +public import LeanPool.MarkoffModP.BGS.HasseWeil.SquareFieldStepanovAuxiliary +public import LeanPool.MarkoffModP.BGS.HasseWeil.SquareFieldStepanovRestriction +public import LeanPool.MarkoffModP.BGS.HasseWeil.SquareFieldStepanovZeroCount +public import LeanPool.MarkoffModP.BGS.HasseWeil.StepanovLinearAlgebra +public import LeanPool.MarkoffModP.BGS.HasseWeil.StepanovParameters +public import LeanPool.MarkoffModP.BGS.HasseWeil.StepanovRestrictionMaps +public import LeanPool.MarkoffModP.BGS.HasseWeil.StepanovSquareVanishing +public import LeanPool.MarkoffModP.BGS.HasseWeil.TensorRestriction +public import LeanPool.MarkoffModP.BGS.HasseWeil.ZetaExtensionTrace +public import LeanPool.MarkoffModP.BGS.HasseWeil.ZetaNumeratorSpectral +public import LeanPool.MarkoffModP.BGS.HasseWeil.ZetaTrace +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.Asymptotics +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.CoarseEndgame +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.CoarseLinearTail +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.CoarseSupportSurjectivity +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.CoarseSupportTail +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.DivisibleOrbitTransitivity +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.ElementaryCounts +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.EulerSevenCoarseSupportFrontier +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.EulerSevenNonparabolicComplementFrontier +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.EulerSevenPairedMaximalDivisorMiddleGame +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.EulerSevenSplitCageCoarseLinearTail +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.EulerSevenSplitCageNonparabolicComplementFrontier +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.EulerSevenSplitCageSquareEnvelopeFrontier +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.EulerSevenSplitCageSquareEnvelopeSurjectivity +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.EvenSignBaseStableComplement +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.EvenSignComplementDivisibility +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.EvenSignOrbitDivisibility +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.ExactOrderComplementObstruction +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.ExactOrderEulerSevenComplementObstruction +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.ExactOrderPuncturedSmallOrderCount +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.ExactOrderRankinEnvelope +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.ExactOrderTraceBudget +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.ExceptionalPrimeCount +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.ExplicitPuncturedTransitivity +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.FixedPointFreeMaximalDivisorTraceCount +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.GiantOrbit +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.JointMaximalDivisorFrontier +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.MaximalDivisorLowOrderCount +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.MaximalDivisorMiddleGame +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.MaximalDivisorPuncturedTransitivity +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.MiddleGameThenEndgame +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.NonparabolicBadComponent +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.NonparabolicComplementFrontier +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.NonparabolicMaximalDivisorConcreteCount +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.NonparabolicPuncturedSmallOrderCount +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.NormalizationCount +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.NormalizedSmallOrderCount +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.OrbitDivisibility +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.PairedMaximalDivisorLowOrderCount +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.PairedMaximalDivisorMiddleGame +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.PairedMaximalDivisorTraceCount +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.PuncturedSmallOrderCount +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.RankinJointAntichainSperner +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.RankinJointAntichainWidth +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.RankinWidthEnvelope +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.ReductionSurjectivity +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.SplitCageEvenSignBase +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.SplitCageNonparabolicComplementFrontier +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.TransitivitySurjectivity +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.Unconditional +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.WeightedCoarseSupportSurjectivity +public import LeanPool.MarkoffModP.BGS.Markoff.Cage +public import LeanPool.MarkoffModP.BGS.Markoff.Cage.AxisEquivalence +public import LeanPool.MarkoffModP.BGS.Markoff.Cage.BiquadraticPrimitiveQuartic +public import LeanPool.MarkoffModP.BGS.Markoff.Cage.Connectivity +public import LeanPool.MarkoffModP.BGS.Markoff.Cage.EstimateFromPlane +public import LeanPool.MarkoffModP.BGS.Markoff.Cage.HasseWeilAssumption +public import LeanPool.MarkoffModP.BGS.Markoff.Cage.IncidenceGeometry +public import LeanPool.MarkoffModP.BGS.Markoff.Cage.PlaneCountComparison +public import LeanPool.MarkoffModP.BGS.Markoff.Cage.PlaneHasseWeil +public import LeanPool.MarkoffModP.BGS.Markoff.Cage.PlaneModels +public import LeanPool.MarkoffModP.BGS.Markoff.Cage.PowerCover +public import LeanPool.MarkoffModP.BGS.Markoff.Cage.PulledRadicand +public import LeanPool.MarkoffModP.BGS.Markoff.Cage.ShiftedTraceCurveIrreducibility +public import LeanPool.MarkoffModP.BGS.Markoff.Cage.SmallPrime +public import LeanPool.MarkoffModP.BGS.Markoff.Cage.WitnessEquations +public import LeanPool.MarkoffModP.BGS.Markoff.Core +public import LeanPool.MarkoffModP.BGS.Markoff.Core.Action +public import LeanPool.MarkoffModP.BGS.Markoff.Core.Basic +public import LeanPool.MarkoffModP.BGS.Markoff.Core.ConicParametrization +public import LeanPool.MarkoffModP.BGS.Markoff.Core.EvenSignAction +public import LeanPool.MarkoffModP.BGS.Markoff.Core.FiniteRotationEigenvalues +public import LeanPool.MarkoffModP.BGS.Markoff.Core.NatConnectivity +public import LeanPool.MarkoffModP.BGS.Markoff.Core.Normalization +public import LeanPool.MarkoffModP.BGS.Markoff.Core.NormalizedOrbit +public import LeanPool.MarkoffModP.BGS.Markoff.Core.ParabolicFibers +public import LeanPool.MarkoffModP.BGS.Markoff.Core.PuncturedNormalization +public import LeanPool.MarkoffModP.BGS.Markoff.Core.Rotation +public import LeanPool.MarkoffModP.BGS.Markoff.Core.RotationTorus +public import LeanPool.MarkoffModP.BGS.Markoff.Core.SemiringFunctor +public import LeanPool.MarkoffModP.BGS.Markoff.Core.Statements +public import LeanPool.MarkoffModP.BGS.Markoff.Core.TraceClassification +public import LeanPool.MarkoffModP.BGS.Markoff.Diophantine +public import LeanPool.MarkoffModP.BGS.Markoff.Diophantine.CoordinateCoprimeProduct +public import LeanPool.MarkoffModP.BGS.Markoff.Diophantine.CoordinateZeroPatternCounts +public import LeanPool.MarkoffModP.BGS.Markoff.Diophantine.LocalCounts +public import LeanPool.MarkoffModP.BGS.Markoff.Diophantine.PrimewiseCRT +public import LeanPool.MarkoffModP.BGS.Markoff.Endgame +public import LeanPool.MarkoffModP.BGS.Markoff.Endgame.LargeOrderToMaximal +public import LeanPool.MarkoffModP.BGS.Markoff.Endgame.Nonsplit +public import LeanPool.MarkoffModP.BGS.Markoff.Endgame.Nonsplit.CayleyParametrization +public import LeanPool.MarkoffModP.BGS.Markoff.Endgame.Nonsplit.DescendedIrreducibility +public import LeanPool.MarkoffModP.BGS.Markoff.Endgame.Nonsplit.DescendedTraceCurve +public import LeanPool.MarkoffModP.BGS.Markoff.Endgame.Nonsplit.HasseFromGeneral +public import LeanPool.MarkoffModP.BGS.Markoff.Endgame.Nonsplit.SeededCover +public import LeanPool.MarkoffModP.BGS.Markoff.Endgame.Parabolic +public import LeanPool.MarkoffModP.BGS.Markoff.Endgame.PowerCoverCounting +public import LeanPool.MarkoffModP.BGS.Markoff.Endgame.PrimitiveInclusionExclusion +public import LeanPool.MarkoffModP.BGS.Markoff.Endgame.PrimitiveOrbitWiring +public import LeanPool.MarkoffModP.BGS.Markoff.Endgame.PrimitiveTraceCount +public import LeanPool.MarkoffModP.BGS.Markoff.Endgame.WeilBoundAssumption +public import LeanPool.MarkoffModP.BGS.Markoff.Endgame.WeilFromGeneralHasse +public import LeanPool.MarkoffModP.BGS.Markoff.ExplicitEndgame +public import LeanPool.MarkoffModP.BGS.Markoff.ExplicitEstimates +public import LeanPool.MarkoffModP.BGS.Markoff.ExplicitNumericCertificates +public import LeanPool.MarkoffModP.BGS.Markoff.ExplicitNumerics +public import LeanPool.MarkoffModP.BGS.Markoff.Incidence +public import LeanPool.MarkoffModP.BGS.Markoff.Incidence.CoordinateRing +public import LeanPool.MarkoffModP.BGS.Markoff.Incidence.Counterexamples +public import LeanPool.MarkoffModP.BGS.Markoff.Incidence.Fibers +public import LeanPool.MarkoffModP.BGS.Markoff.Incidence.Geometry +public import LeanPool.MarkoffModP.BGS.Markoff.Incidence.NormalizedGraph +public import LeanPool.MarkoffModP.BGS.Markoff.Incidence.PointCount +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.CorvajaZannierEscape +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.CorvajaZannierFromGeneral +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.CorvajaZannierGeometry +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.CorvajaZannierSeparability +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.CorvajaZannierSourceBound +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.CorvajaZannierStep +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.CosetTraceEquation +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.Diagonalization +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.DivisorRange +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.EulerSevenPairedCorvajaZannierBound +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.EulerSevenPairedMaximalDivisorCorvajaZannierEscape +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.EulerSevenPairedMaximalDivisorCorvajaZannierStep +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.EulerSevenPairedMaximalDivisorOrderEscape +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.MaximalDivisorCorvajaZannierEscape +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.MaximalDivisorCorvajaZannierStep +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.MaximalDivisorNonparabolicOrderCover +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.MaximalDivisorOrderCover +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.MaximalDivisorOrderEscape +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.MoveWiring +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.NonparabolicUnionBound +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.OrderEscape +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.PairedCorvajaZannierBound +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.PairedMaximalDivisorCorvajaZannierEscape +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.PairedMaximalDivisorCorvajaZannierStep +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.PairedMaximalDivisorOrderEscape +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.ParabolicEscape +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.RightInversionPairing +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.RightSubgroups +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.TraceCurveWeights +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.TraceEquation +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.UnionBound +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.WeightedTraceBound +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.WeightedTraceEquation +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.WeightedTraceEulerSeven +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.WeightedTraceEulerSevenBound +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.WeightedTraceEulerSevenLargeBound +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.WeightedTraceEulerSevenPropositionTwo +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.WeightedTracePoweredImageIndexTwo +public import LeanPool.MarkoffModP.BGS.Markoff.Opening +public import LeanPool.MarkoffModP.BGS.Markoff.Opening.AlgebraicClosureTransport +public import LeanPool.MarkoffModP.BGS.Markoff.Opening.CompatibleRoots +public import LeanPool.MarkoffModP.BGS.Markoff.Opening.CyclotomicBound +public import LeanPool.MarkoffModP.BGS.Markoff.Opening.CyclotomicDefect +public import LeanPool.MarkoffModP.BGS.Markoff.Opening.CyclotomicNorm +public import LeanPool.MarkoffModP.BGS.Markoff.Opening.CyclotomicReduction +public import LeanPool.MarkoffModP.BGS.Markoff.Opening.EveryOrbitLarge +public import LeanPool.MarkoffModP.BGS.Markoff.Opening.FiniteOrbit +public import LeanPool.MarkoffModP.BGS.Markoff.Opening.OrbitCardBound +public import LeanPool.MarkoffModP.BGS.Markoff.Opening.OrderArithmetic +public import LeanPool.MarkoffModP.BGS.Markoff.Opening.ParabolicPeriodicity +public import LeanPool.MarkoffModP.BGS.Markoff.Opening.PeriodicSemisimple +public import LeanPool.MarkoffModP.BGS.Markoff.Opening.RotationOrbitCard +public import LeanPool.MarkoffModP.BGS.Markoff.Opening.TorsionTraces +public import LeanPool.MarkoffModP.BGS.Markoff.Opening.TraceOrderBound +public import LeanPool.MarkoffModP.BGS.Markoff.Opening.UnitCircle +public import LeanPool.MarkoffModP.BGS.Markoff.PreliminaryEndgame +public import LeanPool.MarkoffModP.BGS.Markoff.PreliminaryNumerics +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.AffineNormalization +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.BiprojectiveClosure +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.BiprojectiveScheme +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.Boundary +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.Characteristic +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.ChartLocalization +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.CommonKummerIndependence +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.CommonPrimeKummerTower +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.Geometry +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.IrreducibilityObstructions +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.Kummer +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.LaurentComparisonInjectivity +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.LaurentJacobian +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.LaurentNormalization +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.LaurentSmooth +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.Localization +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.NormalForm +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.OddCommonPrimeIndependence +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.OddCoprimeIrreducibility +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.PositiveCoprimeIrreducibility +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.ProjectiveChart +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.ProjectiveNormalizationCharts +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.ProjectiveNormalizationMorphism +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.ProjectivePointEstimate +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.SemanticNormalForm +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.SyntacticDivisionCriterion +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.SyntacticDivisionObstruction +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.SyntacticNormalForm +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.WeightedBidegree +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.WeightedEllipticModel +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.WeightedIrreducibility +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.WeightedNotSubtorus +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.WeightedOddCoprimeIrreducibility +public import LeanPool.MarkoffModP.BGS.NumberTheory.DivisorBound +public import LeanPool.MarkoffModP.BGS.NumberTheory.ExplicitDivisorBound +public import LeanPool.MarkoffModP.BGS.NumberTheory.JointMaximalDivisorCertificate +public import LeanPool.MarkoffModP.BGS.NumberTheory.JointMaximalDivisorCriterion +public import LeanPool.MarkoffModP.BGS.NumberTheory.JointNeighborDivisorBound +public import LeanPool.MarkoffModP.BGS.NumberTheory.MaximalDivisorBounds +public import LeanPool.MarkoffModP.BGS.NumberTheory.NonparabolicComplementCriterion +public import LeanPool.MarkoffModP.BGS.NumberTheory.OneSidedPrimitiveWitness +public import LeanPool.MarkoffModP.BGS.NumberTheory.PreliminaryDivisorBound +public import LeanPool.MarkoffModP.BGS.NumberTheory.PrimePowerFactorization +public import LeanPool.MarkoffModP.BGS.NumberTheory.RankinCanonicalProfile +public import LeanPool.MarkoffModP.BGS.NumberTheory.RankinCutoff1248Data +public import LeanPool.MarkoffModP.BGS.NumberTheory.RankinCutoff1248Profile +public import LeanPool.MarkoffModP.BGS.NumberTheory.RankinCutoff1248Skeleton +public import LeanPool.MarkoffModP.BGS.NumberTheory.RankinJointEnvelopeCertificate +public import LeanPool.MarkoffModP.BGS.NumberTheory.RankinJointEnvelopeCoverage +public import LeanPool.MarkoffModP.BGS.NumberTheory.RankinJointEnvelopeSummaryCoverage +public import LeanPool.MarkoffModP.BGS.NumberTheory.RankinPositionalCoverage +public import LeanPool.MarkoffModP.BGS.NumberTheory.RankinPositionalProfile +public import LeanPool.MarkoffModP.BGS.NumberTheory.RankinPositionalSupportBound +public import LeanPool.MarkoffModP.BGS.NumberTheory.RankinProfileCertificate +public import LeanPool.MarkoffModP.BGS.NumberTheory.RankinProfileMatching +public import LeanPool.MarkoffModP.BGS.NumberTheory.TruncatedOrderTotient +public import LeanPool.MarkoffModP.BGS.NumberTheory.TruncatedOrderTotientRankin +public import LeanPool.MarkoffModP.BGS.NumberTheory.TruncatedOrderTotientRankinFactorization +public import LeanPool.MarkoffModP.BGS.NumberTheory.WeightedDivisorMoment +public import LeanPool.MarkoffModP.BGS.NumberTheory.WeightedNeighborDivisorBound +public import LeanPool.MarkoffModP.Comparator.Solution +public import LeanPool.MarkoffModP.RiemannRoch.AdeleSpace.Basic +public import LeanPool.MarkoffModP.RiemannRoch.AdeleSpace.FilterChain +public import LeanPool.MarkoffModP.RiemannRoch.AxiomCheck +public import LeanPool.MarkoffModP.RiemannRoch.Basic +public import LeanPool.MarkoffModP.RiemannRoch.CoordinateFree.AdeleSpace +public import LeanPool.MarkoffModP.RiemannRoch.CoordinateFree.AlgEquiv +public import LeanPool.MarkoffModP.RiemannRoch.CoordinateFree.Divisor +public import LeanPool.MarkoffModP.RiemannRoch.CoordinateFree.RiemannRoch +public import LeanPool.MarkoffModP.RiemannRoch.CoordinateFree.WeilDifferential +public import LeanPool.MarkoffModP.RiemannRoch.Divisor +public import LeanPool.MarkoffModP.RiemannRoch.FunctionField.Divisor +public import LeanPool.MarkoffModP.RiemannRoch.Genus.AdeleQuotient +public import LeanPool.MarkoffModP.RiemannRoch.Genus.Basic +public import LeanPool.MarkoffModP.RiemannRoch.Genus.Polar +public import LeanPool.MarkoffModP.RiemannRoch.Genus.Ramification +public import LeanPool.MarkoffModP.RiemannRoch.LinearKneser +public import LeanPool.MarkoffModP.RiemannRoch.LocalResidue +public import LeanPool.MarkoffModP.RiemannRoch.Place +public import LeanPool.MarkoffModP.RiemannRoch.PlaceEquiv +public import LeanPool.MarkoffModP.RiemannRoch.RRspace.Basic +public import LeanPool.MarkoffModP.RiemannRoch.RiemannRochTheorem.Basic +public import LeanPool.MarkoffModP.RiemannRoch.RiemannRochTheorem.Corollaries +public import LeanPool.MarkoffModP.RiemannRoch.SeparableRelNorm +public import LeanPool.MarkoffModP.RiemannRoch.WeilDifferential +public import LeanPool.MarkoffModP.RiemannRoch.WeilDifferential.Basic public import LeanPool.MassFormula public import LeanPool.MassFormula.Convergence public import LeanPool.MassFormula.Defs diff --git a/LeanPool/MarkoffModP.lean b/LeanPool/MarkoffModP.lean new file mode 100644 index 0000000000..d03772f8be --- /dev/null +++ b/LeanPool/MarkoffModP.lean @@ -0,0 +1,628 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS +public import LeanPool.MarkoffModP.BGS.Algebra.ClearedLinearFractionalSubstitution +public import LeanPool.MarkoffModP.BGS.Algebra.DifferentialWronskian +public import LeanPool.MarkoffModP.BGS.Algebra.KummerEigencharacterDescent +public import LeanPool.MarkoffModP.BGS.Algebra.RatFuncLinearFractionalEquiv +public import LeanPool.MarkoffModP.BGS.AlgebraicGeometry.ConstantOpenGlueData +public import LeanPool.MarkoffModP.BGS.AlgebraicGeometry.SpecRingEquiv +public import LeanPool.MarkoffModP.BGS.Combinatorics.DivisorExponentCoefficient +public import LeanPool.MarkoffModP.BGS.Combinatorics.DivisorExponentSpernerBridge +public import LeanPool.MarkoffModP.BGS.Combinatorics.ProductOfChainsGrid +public import LeanPool.MarkoffModP.BGS.Combinatorics.ProductOfChainsSperner +public import LeanPool.MarkoffModP.BGS.Combinatorics.SymmetricChainBasic +public import LeanPool.MarkoffModP.BGS.Combinatorics.SymmetricChainProduct +public import LeanPool.MarkoffModP.BGS.Combinatorics.SymmetricChainRectangle +public import LeanPool.MarkoffModP.BGS.CorvajaZannier +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.AbsoluteIrreducibilityBaseChange +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.AuxiliaryFamily +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.AuxiliaryFamilyIndexing +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.BivariateGauss +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.BivariateResultant +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.CompletionLinearDisjointness +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.DedekindAuxiliaryCaseI +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.DedekindAuxiliaryLocalCases +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.DedekindAuxiliaryWronskian +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.DedekindCanonicalDifferentScaling +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.DedekindDifferentDivisor +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.DedekindDifferentKaehler +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.DedekindLeadingTermCancellation +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.DedekindLocalDerivationExtension +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.DedekindLocalWronskian +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.DedekindLocalizationDerivationPreservation +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.DedekindLocalizationOrder +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.DedekindPerfectResidueCaseI +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.DedekindPlaceOrder +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.DedekindRamifiedDerivationScaling +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.ElementaryFiniteFieldBound +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.EndpointComposition +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionCanonicalAuxiliaryFinitePlace +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionCanonicalAuxiliaryFinitePlaceNormalized +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionCanonicalAuxiliaryInfinityPlace +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionCanonicalDifferentDivisor +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionCanonicalGcdBound +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionCanonicalGlobalGcdBound +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionCanonicalGlobalNormalized +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionCanonicalGlobalNormalizedAutomatic +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionCanonicalPlaceSum +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionCanonicalPlacewiseScaling +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionCanonicalWronskian +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionExceptionalPlaceBounds +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionExceptionalSupport +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionExhaustiveProductFormula +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionGcdOutsideHeight +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionOneSubGcdHeight +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionPolynomialHeight +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionPositiveDegreePower +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionPrincipalDivisor +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionProductFormula +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionResidueSurjectivity +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteFunctionFieldDegree +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FinitePlaceCompletion +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FrobeniusSubfield +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FrobeniusWronskian +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FunctionFieldProductFormula +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.GeneralCorvajaZannier +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.GlobalWronskianPlaceSum +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.GlobalWronskianSummation +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.GlobalWronskianWeightedPlaceSum +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.InfinityInertiaDegree +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.InfinityPlace +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.LaurentFrobeniusBasis +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.LaurentFrobeniusPowerBasis +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.LocalAuxiliaryCaseI +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.LocalAuxiliaryWronskian +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.LocalDerivative +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.LocalMonogenicity +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.LocalReciprocalDiscriminant +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.LocalWronskian +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.NumericalCorollary +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.NumericalOptimization +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.ParameterizedBound +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PerfectConstants +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveAuxiliaryFinitePlace +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveAuxiliaryFinitePlaceCases +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveAuxiliaryFinitePlacePrincipalDivisor +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveAuxiliaryIndependence +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveBidegreeBridge +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveBoundarySupport +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveCanonicalDegreeBound +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveCanonicalEulerBound +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveCanonicalGcdBound +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveCharacteristicCardinality +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveCoordinatePowerHeight +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveDiagonalStabilizer +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveDiscriminantBound +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveExhaustiveGcdEndpoint +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveFiniteDifferentBound +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveFunctionField +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveInfinityComplement +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveInfinityDifferentBound +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveInfinityDifferentDegree +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveLocalReciprocalDiscriminant +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveLogarithmicGauss +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurvePoweredHeightBounds +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurvePoweredImageDegreeBudget +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurvePropositionTwoAssembly +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurvePropositionTwoDegreeBridge +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurvePropositionTwoGeometric +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveRatFuncModel +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveSeparability +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveSharedOriginBoundary +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveSupportDeterminant +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveSupportRank +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PoweredCoordinateRelation +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PoweredCoordinates +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PoweredImageBaseChange +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PoweredImageCurve +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PoweredImageExactSupportIndexBound +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PoweredImageFrobeniusRelation +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PoweredImageFrobeniusRelationSwapped +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PoweredImageGaloisBound +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PoweredImageHeightFactor +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PoweredImageIndex +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PoweredImageIndexBound +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PropositionTwoDegreeMonotonicity +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.RatFuncExhaustiveProductFormula +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.SeparatingCoordinateNotFrobenius +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.TorsionBidegreeCount +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.TorsionExhaustiveGcdDivisorBound +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.TorsionGcdDivisorBound +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.TorsionPointNormalization +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.TorusCharacterKernelBound +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.TranscendentalPowerDegree +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.WronskianChangeParameter +public import LeanPool.MarkoffModP.BGS.Dynamics.FiniteForwardOrbit +public import LeanPool.MarkoffModP.BGS.Dynamics.StrictMeasureEscape +public import LeanPool.MarkoffModP.BGS.External.GeneralCurveTheorems +public import LeanPool.MarkoffModP.BGS.FiniteField.EllipticCharacterSum +public import LeanPool.MarkoffModP.BGS.FiniteField.HasseFrobenius +public import LeanPool.MarkoffModP.BGS.FiniteField.QuadraticCharacter +public import LeanPool.MarkoffModP.BGS.HasseWeil.AffinePointPlace +public import LeanPool.MarkoffModP.BGS.HasseWeil.CechRiemannLinearAlgebra +public import LeanPool.MarkoffModP.BGS.HasseWeil.ClosedPlaceEulerRecurrence +public import LeanPool.MarkoffModP.BGS.HasseWeil.ConstantExtensionClosedPlaceCount +public import LeanPool.MarkoffModP.BGS.HasseWeil.ConstantExtensionClosedPlaceSplittingFormula +public import LeanPool.MarkoffModP.BGS.HasseWeil.ConstantExtensionFinitePlaceBridge +public import LeanPool.MarkoffModP.BGS.HasseWeil.ConstantExtensionInfinityPlaceBridge +public import LeanPool.MarkoffModP.BGS.HasseWeil.ConstantExtensionInfinityPlaceDegreeTower +public import LeanPool.MarkoffModP.BGS.HasseWeil.ConstantExtensionInfinityPlaceSplittingMultiplicity +public import LeanPool.MarkoffModP.BGS.HasseWeil.ConstantExtensionPlaceSplittingMultiplicity +public import LeanPool.MarkoffModP.BGS.HasseWeil.ConstantExtensionRationalPlace +public import LeanPool.MarkoffModP.BGS.HasseWeil.ConstantFieldAutomorphism +public import LeanPool.MarkoffModP.BGS.HasseWeil.ConstantFieldFinitePlace +public import LeanPool.MarkoffModP.BGS.HasseWeil.ConstantFieldFinitePlaceDegree +public import LeanPool.MarkoffModP.BGS.HasseWeil.ConstantFieldInfinityBase +public import LeanPool.MarkoffModP.BGS.HasseWeil.ConstantFieldRatFuncCompatibility +public import LeanPool.MarkoffModP.BGS.HasseWeil.ConstantTensorResidue +public import LeanPool.MarkoffModP.BGS.HasseWeil.DVRLocalPoleOrder +public import LeanPool.MarkoffModP.BGS.HasseWeil.DedekindDifferentLocalTrace +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtension +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionAutomorphism +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionConstants +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionDifferentCoefficient +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionFiniteDifferent +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionFinitePlace +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionFinitePlaceCompatibility +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionFinitePlaceFrobeniusAverage +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionFrobeniusTwist +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionFrobeniusTwistBoundedError +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionFrobeniusTwistConstants +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionFrobeniusTwistDegree +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionFrobeniusTwistFinitePlaceAverage +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionFrobeniusTwistFinitePlaceBridge +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionFrobeniusTwistFinitePlaceUnramified +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionFrobeniusTwistGenus +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionFrobeniusTwistInfinityPlaceDescent +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionFrobeniusTwistInfinityPlaceEquivalence +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionFrobeniusTwistMultiplication +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionFrobeniusTwistRationalPlaceAverage +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionFrobeniusTwistRiemannLower +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionFrobeniusTwistStepanovUpper +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionGenusDegree +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionGenusInvariance +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionInfinityDifferent +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionInfinityNormalization +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionInfinityPlaceCompatibility +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionIntermediateFrobeniusTwistFinitePlaceAverage +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionIntermediateFrobeniusTwistHasseBound +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionIntermediateFrobeniusTwistRationalPlaceAverage +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionNormalClosureTower +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionQuotient +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionRationalPlaceCount +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionRegularity +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionTotalDifferentDegree +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionTower +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExtensionEvenDegreeStepanovBound +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExtensionPointCount +public import LeanPool.MarkoffModP.BGS.HasseWeil.FilteredDimension +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteBranchLocus +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionAffineIdealDegree +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionAffineIdealDivisor +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionCanonicalDifferentCanonicalityCriterion +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionCanonicalDifferentCotrace +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionCanonicalDifferentCotraceCanonicality +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionCanonicalDifferentGenusBound +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionCanonicalDifferentLocalMaximality +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionClosedPlaceAlgEquiv +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionCotraceLocalTraceImage +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionDivisibleErrorFromConstantBase +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionDivisorClassRecurrence +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionDivisorDegreeIndex +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionEffectiveDivisorSplit +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionGenusBound +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionHasseBoundFromEvenConstantExtensions +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionHasseWeil +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionIndexedZetaRationality +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionIndexedZetaRationalityAutomatic +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionLocalPoleQuotient +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionLocalPoleSpace +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionPlaceAlgEquiv +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionPlaceDegreeFiniteness +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionPlaceTower +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionPrincipalParts +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionRiemannEventualGrowth +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionRiemannLowerFromGenus +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionRiemannRoch +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionRiemannShiftedEventualGrowth +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionRiemannSpace +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionRiemannSpaceProjectivization +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionStandardZetaRationality +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionTotalDifferentEffectiveDivisor +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionZeroCounting +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionZetaDegreeExtensionIdentity +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionZetaDegreeIndexOne +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionZetaDegreeIndexOneAutomatic +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionZetaDegreeIndexOneFromAllCounts +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionZetaNumeratorNoncancellation +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionZetaSimplePole +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteFieldCompositum +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteFieldConstantExtensionNormalization +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteFieldConstantExtensionResidue +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteFieldDivisibleExtension +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteFieldInfinityDifferent +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteFieldPolynomialDifferent +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteFieldPolynomialNormalization +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteFieldSubfield +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteLinearIndependenceBound +public import LeanPool.MarkoffModP.BGS.HasseWeil.FinitePlaceApproximation +public import LeanPool.MarkoffModP.BGS.HasseWeil.FinitePlaceFrobeniusFiber +public import LeanPool.MarkoffModP.BGS.HasseWeil.FinitePlaceNormalizationTransport +public import LeanPool.MarkoffModP.BGS.HasseWeil.FinitePrincipalParts +public import LeanPool.MarkoffModP.BGS.HasseWeil.FinsuppWeightedFiber +public import LeanPool.MarkoffModP.BGS.HasseWeil.FixedPointAverage +public import LeanPool.MarkoffModP.BGS.HasseWeil.FormalZetaConstantExtensionIdentity +public import LeanPool.MarkoffModP.BGS.HasseWeil.FormalZetaDegreeIndexOne +public import LeanPool.MarkoffModP.BGS.HasseWeil.FormalZetaDegreeIndexOneIndexed +public import LeanPool.MarkoffModP.BGS.HasseWeil.FormalZetaEuler +public import LeanPool.MarkoffModP.BGS.HasseWeil.FormalZetaEulerDegree +public import LeanPool.MarkoffModP.BGS.HasseWeil.FormalZetaHasseBound +public import LeanPool.MarkoffModP.BGS.HasseWeil.FormalZetaRationality +public import LeanPool.MarkoffModP.BGS.HasseWeil.FormalZetaRationalityDegree +public import LeanPool.MarkoffModP.BGS.HasseWeil.FormalZetaTrace +public import LeanPool.MarkoffModP.BGS.HasseWeil.FormalZetaUniqueness +public import LeanPool.MarkoffModP.BGS.HasseWeil.FrobeniusPlaceCardinality +public import LeanPool.MarkoffModP.BGS.HasseWeil.FrobeniusRestriction +public import LeanPool.MarkoffModP.BGS.HasseWeil.FrobeniusTwistGroup +public import LeanPool.MarkoffModP.BGS.HasseWeil.FunctionFieldConstantExtension +public import LeanPool.MarkoffModP.BGS.HasseWeil.FunctionFieldConstantField +public import LeanPool.MarkoffModP.BGS.HasseWeil.FunctionFieldNormalClosure +public import LeanPool.MarkoffModP.BGS.HasseWeil.FunctionFieldNormalClosureConstantBase +public import LeanPool.MarkoffModP.BGS.HasseWeil.FunctionFieldNormalClosureConstants +public import LeanPool.MarkoffModP.BGS.HasseWeil.FunctionFieldNormalClosureOriginalCompositum +public import LeanPool.MarkoffModP.BGS.HasseWeil.FunctionFieldNormalClosureOriginalField +public import LeanPool.MarkoffModP.BGS.HasseWeil.FunctionFieldNormalClosureRatFuncBase +public import LeanPool.MarkoffModP.BGS.HasseWeil.FunctionFieldNormalClosureRatFuncEquiv +public import LeanPool.MarkoffModP.BGS.HasseWeil.GaloisAverage +public import LeanPool.MarkoffModP.BGS.HasseWeil.GaloisTowerFactorialDegree +public import LeanPool.MarkoffModP.BGS.HasseWeil.GeneralBivariateAffineHasseWeil +public import LeanPool.MarkoffModP.BGS.HasseWeil.GeneralFiniteExtensionRiemannLower +public import LeanPool.MarkoffModP.BGS.HasseWeil.GeneralSquareFieldStepanovCount +public import LeanPool.MarkoffModP.BGS.HasseWeil.GeneralSquareFieldStepanovCountAutomatic +public import LeanPool.MarkoffModP.BGS.HasseWeil.IdealMultiplicityMap +public import LeanPool.MarkoffModP.BGS.HasseWeil.LinearFunctionalGluing +public import LeanPool.MarkoffModP.BGS.HasseWeil.LocalPoleCumulativeQuotient +public import LeanPool.MarkoffModP.BGS.HasseWeil.LocalPoleFiltration +public import LeanPool.MarkoffModP.BGS.HasseWeil.OnePointBase +public import LeanPool.MarkoffModP.BGS.HasseWeil.OnePointDivisorSplit +public import LeanPool.MarkoffModP.BGS.HasseWeil.OnePointHeight +public import LeanPool.MarkoffModP.BGS.HasseWeil.OnePointIncrement +public import LeanPool.MarkoffModP.BGS.HasseWeil.OnePointLeadingCoefficient +public import LeanPool.MarkoffModP.BGS.HasseWeil.OnePointPoleSemigroup +public import LeanPool.MarkoffModP.BGS.HasseWeil.OnePointSectionSelection +public import LeanPool.MarkoffModP.BGS.HasseWeil.OnePointStepanovBasisGrid +public import LeanPool.MarkoffModP.BGS.HasseWeil.OnePointStepanovDegreeTwoAuxiliary +public import LeanPool.MarkoffModP.BGS.HasseWeil.OnePointStepanovGrid +public import LeanPool.MarkoffModP.BGS.HasseWeil.OnePointStrictLevels +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneAffineCountTransfer +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneAffineFiberBound +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneAffineHasseWeilFromEvenError +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneAffineHasseWeilFromZeta +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneAffineRationalPlaceComparison +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneConstantField +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneCoordinatePole +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneCoordinatePoleAtInfinity +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneCoordinateShear +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneCurveGenusBoundAutomatic +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneCurveGenusBoundFromCotrace +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneCurveGenusBoundFromCotraceDegree +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneFinitePlaceRiemannLower +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneFrobeniusDeflation +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneFrobeniusDegenerate +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneFrobeniusReduction +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneInfinityRiemannLower +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneMonomialSpace +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneOnePointRiemannLower +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneRationalPlaceAffineComparison +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneRegularPointCount +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneSingularPointBound +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneSmoothPointNormalization +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneSquareFieldStepanovCount +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneSquareFieldStepanovCountAutomatic +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneStepanovAuxiliary +public import LeanPool.MarkoffModP.BGS.HasseWeil.PoleDivisor +public import LeanPool.MarkoffModP.BGS.HasseWeil.PolynomialSpectral +public import LeanPool.MarkoffModP.BGS.HasseWeil.PolynomialTensorCancel +public import LeanPool.MarkoffModP.BGS.HasseWeil.PowerSum +public import LeanPool.MarkoffModP.BGS.HasseWeil.RatFuncCanonicalInfinityDivisor +public import LeanPool.MarkoffModP.BGS.HasseWeil.RatFuncConstantExtension +public import LeanPool.MarkoffModP.BGS.HasseWeil.RatFuncExactConstantExtension +public import LeanPool.MarkoffModP.BGS.HasseWeil.RatFuncInfinityLocalization +public import LeanPool.MarkoffModP.BGS.HasseWeil.RatFuncParameterPole +public import LeanPool.MarkoffModP.BGS.HasseWeil.RationalPlace +public import LeanPool.MarkoffModP.BGS.HasseWeil.RationalPlaceTower +public import LeanPool.MarkoffModP.BGS.HasseWeil.RiemannSpaceConstants +public import LeanPool.MarkoffModP.BGS.HasseWeil.RiemannSpaceEffectiveIncrement +public import LeanPool.MarkoffModP.BGS.HasseWeil.RiemannSpaceFinitePlaceIncrement +public import LeanPool.MarkoffModP.BGS.HasseWeil.RiemannSpaceInfinityPlaceIncrement +public import LeanPool.MarkoffModP.BGS.HasseWeil.SpectralFromAsymptotic +public import LeanPool.MarkoffModP.BGS.HasseWeil.SquareExtensionAffinePlaces +public import LeanPool.MarkoffModP.BGS.HasseWeil.SquareFieldResidue +public import LeanPool.MarkoffModP.BGS.HasseWeil.SquareFieldStepanovAuxiliary +public import LeanPool.MarkoffModP.BGS.HasseWeil.SquareFieldStepanovRestriction +public import LeanPool.MarkoffModP.BGS.HasseWeil.SquareFieldStepanovZeroCount +public import LeanPool.MarkoffModP.BGS.HasseWeil.StepanovLinearAlgebra +public import LeanPool.MarkoffModP.BGS.HasseWeil.StepanovParameters +public import LeanPool.MarkoffModP.BGS.HasseWeil.StepanovRestrictionMaps +public import LeanPool.MarkoffModP.BGS.HasseWeil.StepanovSquareVanishing +public import LeanPool.MarkoffModP.BGS.HasseWeil.TensorRestriction +public import LeanPool.MarkoffModP.BGS.HasseWeil.ZetaExtensionTrace +public import LeanPool.MarkoffModP.BGS.HasseWeil.ZetaNumeratorSpectral +public import LeanPool.MarkoffModP.BGS.HasseWeil.ZetaTrace +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.Asymptotics +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.CoarseEndgame +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.CoarseLinearTail +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.CoarseSupportSurjectivity +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.CoarseSupportTail +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.DivisibleOrbitTransitivity +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.ElementaryCounts +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.EulerSevenCoarseSupportFrontier +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.EulerSevenNonparabolicComplementFrontier +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.EulerSevenPairedMaximalDivisorMiddleGame +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.EulerSevenSplitCageCoarseLinearTail +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.EulerSevenSplitCageNonparabolicComplementFrontier +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.EulerSevenSplitCageSquareEnvelopeFrontier +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.EulerSevenSplitCageSquareEnvelopeSurjectivity +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.EvenSignBaseStableComplement +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.EvenSignComplementDivisibility +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.EvenSignOrbitDivisibility +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.ExactOrderComplementObstruction +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.ExactOrderEulerSevenComplementObstruction +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.ExactOrderPuncturedSmallOrderCount +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.ExactOrderRankinEnvelope +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.ExactOrderTraceBudget +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.ExceptionalPrimeCount +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.ExplicitPuncturedTransitivity +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.FixedPointFreeMaximalDivisorTraceCount +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.GiantOrbit +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.JointMaximalDivisorFrontier +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.MaximalDivisorLowOrderCount +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.MaximalDivisorMiddleGame +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.MaximalDivisorPuncturedTransitivity +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.MiddleGameThenEndgame +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.NonparabolicBadComponent +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.NonparabolicComplementFrontier +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.NonparabolicMaximalDivisorConcreteCount +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.NonparabolicPuncturedSmallOrderCount +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.NormalizationCount +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.NormalizedSmallOrderCount +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.OrbitDivisibility +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.PairedMaximalDivisorLowOrderCount +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.PairedMaximalDivisorMiddleGame +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.PairedMaximalDivisorTraceCount +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.PuncturedSmallOrderCount +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.RankinJointAntichainSperner +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.RankinJointAntichainWidth +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.RankinWidthEnvelope +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.ReductionSurjectivity +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.SplitCageEvenSignBase +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.SplitCageNonparabolicComplementFrontier +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.TransitivitySurjectivity +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.Unconditional +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.WeightedCoarseSupportSurjectivity +public import LeanPool.MarkoffModP.BGS.Markoff.Cage +public import LeanPool.MarkoffModP.BGS.Markoff.Cage.AxisEquivalence +public import LeanPool.MarkoffModP.BGS.Markoff.Cage.BiquadraticPrimitiveQuartic +public import LeanPool.MarkoffModP.BGS.Markoff.Cage.Connectivity +public import LeanPool.MarkoffModP.BGS.Markoff.Cage.EstimateFromPlane +public import LeanPool.MarkoffModP.BGS.Markoff.Cage.HasseWeilAssumption +public import LeanPool.MarkoffModP.BGS.Markoff.Cage.IncidenceGeometry +public import LeanPool.MarkoffModP.BGS.Markoff.Cage.PlaneCountComparison +public import LeanPool.MarkoffModP.BGS.Markoff.Cage.PlaneHasseWeil +public import LeanPool.MarkoffModP.BGS.Markoff.Cage.PlaneModels +public import LeanPool.MarkoffModP.BGS.Markoff.Cage.PowerCover +public import LeanPool.MarkoffModP.BGS.Markoff.Cage.PulledRadicand +public import LeanPool.MarkoffModP.BGS.Markoff.Cage.ShiftedTraceCurveIrreducibility +public import LeanPool.MarkoffModP.BGS.Markoff.Cage.SmallPrime +public import LeanPool.MarkoffModP.BGS.Markoff.Cage.WitnessEquations +public import LeanPool.MarkoffModP.BGS.Markoff.Core +public import LeanPool.MarkoffModP.BGS.Markoff.Core.Action +public import LeanPool.MarkoffModP.BGS.Markoff.Core.Basic +public import LeanPool.MarkoffModP.BGS.Markoff.Core.ConicParametrization +public import LeanPool.MarkoffModP.BGS.Markoff.Core.EvenSignAction +public import LeanPool.MarkoffModP.BGS.Markoff.Core.FiniteRotationEigenvalues +public import LeanPool.MarkoffModP.BGS.Markoff.Core.NatConnectivity +public import LeanPool.MarkoffModP.BGS.Markoff.Core.Normalization +public import LeanPool.MarkoffModP.BGS.Markoff.Core.NormalizedOrbit +public import LeanPool.MarkoffModP.BGS.Markoff.Core.ParabolicFibers +public import LeanPool.MarkoffModP.BGS.Markoff.Core.PuncturedNormalization +public import LeanPool.MarkoffModP.BGS.Markoff.Core.Rotation +public import LeanPool.MarkoffModP.BGS.Markoff.Core.RotationTorus +public import LeanPool.MarkoffModP.BGS.Markoff.Core.SemiringFunctor +public import LeanPool.MarkoffModP.BGS.Markoff.Core.Statements +public import LeanPool.MarkoffModP.BGS.Markoff.Core.TraceClassification +public import LeanPool.MarkoffModP.BGS.Markoff.Diophantine +public import LeanPool.MarkoffModP.BGS.Markoff.Diophantine.CoordinateCoprimeProduct +public import LeanPool.MarkoffModP.BGS.Markoff.Diophantine.CoordinateZeroPatternCounts +public import LeanPool.MarkoffModP.BGS.Markoff.Diophantine.LocalCounts +public import LeanPool.MarkoffModP.BGS.Markoff.Diophantine.PrimewiseCRT +public import LeanPool.MarkoffModP.BGS.Markoff.Endgame +public import LeanPool.MarkoffModP.BGS.Markoff.Endgame.LargeOrderToMaximal +public import LeanPool.MarkoffModP.BGS.Markoff.Endgame.Nonsplit +public import LeanPool.MarkoffModP.BGS.Markoff.Endgame.Nonsplit.CayleyParametrization +public import LeanPool.MarkoffModP.BGS.Markoff.Endgame.Nonsplit.DescendedIrreducibility +public import LeanPool.MarkoffModP.BGS.Markoff.Endgame.Nonsplit.DescendedTraceCurve +public import LeanPool.MarkoffModP.BGS.Markoff.Endgame.Nonsplit.HasseFromGeneral +public import LeanPool.MarkoffModP.BGS.Markoff.Endgame.Nonsplit.SeededCover +public import LeanPool.MarkoffModP.BGS.Markoff.Endgame.Parabolic +public import LeanPool.MarkoffModP.BGS.Markoff.Endgame.PowerCoverCounting +public import LeanPool.MarkoffModP.BGS.Markoff.Endgame.PrimitiveInclusionExclusion +public import LeanPool.MarkoffModP.BGS.Markoff.Endgame.PrimitiveOrbitWiring +public import LeanPool.MarkoffModP.BGS.Markoff.Endgame.PrimitiveTraceCount +public import LeanPool.MarkoffModP.BGS.Markoff.Endgame.WeilBoundAssumption +public import LeanPool.MarkoffModP.BGS.Markoff.Endgame.WeilFromGeneralHasse +public import LeanPool.MarkoffModP.BGS.Markoff.ExplicitEndgame +public import LeanPool.MarkoffModP.BGS.Markoff.ExplicitEstimates +public import LeanPool.MarkoffModP.BGS.Markoff.ExplicitNumericCertificates +public import LeanPool.MarkoffModP.BGS.Markoff.ExplicitNumerics +public import LeanPool.MarkoffModP.BGS.Markoff.Incidence +public import LeanPool.MarkoffModP.BGS.Markoff.Incidence.CoordinateRing +public import LeanPool.MarkoffModP.BGS.Markoff.Incidence.Counterexamples +public import LeanPool.MarkoffModP.BGS.Markoff.Incidence.Fibers +public import LeanPool.MarkoffModP.BGS.Markoff.Incidence.Geometry +public import LeanPool.MarkoffModP.BGS.Markoff.Incidence.NormalizedGraph +public import LeanPool.MarkoffModP.BGS.Markoff.Incidence.PointCount +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.CorvajaZannierEscape +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.CorvajaZannierFromGeneral +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.CorvajaZannierGeometry +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.CorvajaZannierSeparability +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.CorvajaZannierSourceBound +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.CorvajaZannierStep +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.CosetTraceEquation +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.Diagonalization +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.DivisorRange +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.EulerSevenPairedCorvajaZannierBound +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.EulerSevenPairedMaximalDivisorCorvajaZannierEscape +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.EulerSevenPairedMaximalDivisorCorvajaZannierStep +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.EulerSevenPairedMaximalDivisorOrderEscape +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.MaximalDivisorCorvajaZannierEscape +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.MaximalDivisorCorvajaZannierStep +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.MaximalDivisorNonparabolicOrderCover +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.MaximalDivisorOrderCover +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.MaximalDivisorOrderEscape +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.MoveWiring +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.NonparabolicUnionBound +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.OrderEscape +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.PairedCorvajaZannierBound +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.PairedMaximalDivisorCorvajaZannierEscape +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.PairedMaximalDivisorCorvajaZannierStep +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.PairedMaximalDivisorOrderEscape +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.ParabolicEscape +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.RightInversionPairing +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.RightSubgroups +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.TraceCurveWeights +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.TraceEquation +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.UnionBound +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.WeightedTraceBound +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.WeightedTraceEquation +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.WeightedTraceEulerSeven +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.WeightedTraceEulerSevenBound +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.WeightedTraceEulerSevenLargeBound +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.WeightedTraceEulerSevenPropositionTwo +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.WeightedTracePoweredImageIndexTwo +public import LeanPool.MarkoffModP.BGS.Markoff.Opening +public import LeanPool.MarkoffModP.BGS.Markoff.Opening.AlgebraicClosureTransport +public import LeanPool.MarkoffModP.BGS.Markoff.Opening.CompatibleRoots +public import LeanPool.MarkoffModP.BGS.Markoff.Opening.CyclotomicBound +public import LeanPool.MarkoffModP.BGS.Markoff.Opening.CyclotomicDefect +public import LeanPool.MarkoffModP.BGS.Markoff.Opening.CyclotomicNorm +public import LeanPool.MarkoffModP.BGS.Markoff.Opening.CyclotomicReduction +public import LeanPool.MarkoffModP.BGS.Markoff.Opening.EveryOrbitLarge +public import LeanPool.MarkoffModP.BGS.Markoff.Opening.FiniteOrbit +public import LeanPool.MarkoffModP.BGS.Markoff.Opening.OrbitCardBound +public import LeanPool.MarkoffModP.BGS.Markoff.Opening.OrderArithmetic +public import LeanPool.MarkoffModP.BGS.Markoff.Opening.ParabolicPeriodicity +public import LeanPool.MarkoffModP.BGS.Markoff.Opening.PeriodicSemisimple +public import LeanPool.MarkoffModP.BGS.Markoff.Opening.RotationOrbitCard +public import LeanPool.MarkoffModP.BGS.Markoff.Opening.TorsionTraces +public import LeanPool.MarkoffModP.BGS.Markoff.Opening.TraceOrderBound +public import LeanPool.MarkoffModP.BGS.Markoff.Opening.UnitCircle +public import LeanPool.MarkoffModP.BGS.Markoff.PreliminaryEndgame +public import LeanPool.MarkoffModP.BGS.Markoff.PreliminaryNumerics +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.AffineNormalization +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.BiprojectiveClosure +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.BiprojectiveScheme +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.Boundary +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.Characteristic +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.ChartLocalization +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.CommonKummerIndependence +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.CommonPrimeKummerTower +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.Geometry +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.IrreducibilityObstructions +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.Kummer +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.LaurentComparisonInjectivity +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.LaurentJacobian +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.LaurentNormalization +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.LaurentSmooth +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.Localization +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.NormalForm +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.OddCommonPrimeIndependence +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.OddCoprimeIrreducibility +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.PositiveCoprimeIrreducibility +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.ProjectiveChart +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.ProjectiveNormalizationCharts +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.ProjectiveNormalizationMorphism +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.ProjectivePointEstimate +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.SemanticNormalForm +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.SyntacticDivisionCriterion +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.SyntacticDivisionObstruction +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.SyntacticNormalForm +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.WeightedBidegree +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.WeightedEllipticModel +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.WeightedIrreducibility +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.WeightedNotSubtorus +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.WeightedOddCoprimeIrreducibility +public import LeanPool.MarkoffModP.BGS.NumberTheory.DivisorBound +public import LeanPool.MarkoffModP.BGS.NumberTheory.ExplicitDivisorBound +public import LeanPool.MarkoffModP.BGS.NumberTheory.JointMaximalDivisorCertificate +public import LeanPool.MarkoffModP.BGS.NumberTheory.JointMaximalDivisorCriterion +public import LeanPool.MarkoffModP.BGS.NumberTheory.JointNeighborDivisorBound +public import LeanPool.MarkoffModP.BGS.NumberTheory.MaximalDivisorBounds +public import LeanPool.MarkoffModP.BGS.NumberTheory.NonparabolicComplementCriterion +public import LeanPool.MarkoffModP.BGS.NumberTheory.OneSidedPrimitiveWitness +public import LeanPool.MarkoffModP.BGS.NumberTheory.PreliminaryDivisorBound +public import LeanPool.MarkoffModP.BGS.NumberTheory.PrimePowerFactorization +public import LeanPool.MarkoffModP.BGS.NumberTheory.RankinCanonicalProfile +public import LeanPool.MarkoffModP.BGS.NumberTheory.RankinCutoff1248Data +public import LeanPool.MarkoffModP.BGS.NumberTheory.RankinCutoff1248Profile +public import LeanPool.MarkoffModP.BGS.NumberTheory.RankinCutoff1248Skeleton +public import LeanPool.MarkoffModP.BGS.NumberTheory.RankinJointEnvelopeCertificate +public import LeanPool.MarkoffModP.BGS.NumberTheory.RankinJointEnvelopeCoverage +public import LeanPool.MarkoffModP.BGS.NumberTheory.RankinJointEnvelopeSummaryCoverage +public import LeanPool.MarkoffModP.BGS.NumberTheory.RankinPositionalCoverage +public import LeanPool.MarkoffModP.BGS.NumberTheory.RankinPositionalProfile +public import LeanPool.MarkoffModP.BGS.NumberTheory.RankinPositionalSupportBound +public import LeanPool.MarkoffModP.BGS.NumberTheory.RankinProfileCertificate +public import LeanPool.MarkoffModP.BGS.NumberTheory.RankinProfileMatching +public import LeanPool.MarkoffModP.BGS.NumberTheory.TruncatedOrderTotient +public import LeanPool.MarkoffModP.BGS.NumberTheory.TruncatedOrderTotientRankin +public import LeanPool.MarkoffModP.BGS.NumberTheory.TruncatedOrderTotientRankinFactorization +public import LeanPool.MarkoffModP.BGS.NumberTheory.WeightedDivisorMoment +public import LeanPool.MarkoffModP.BGS.NumberTheory.WeightedNeighborDivisorBound +public import LeanPool.MarkoffModP.Comparator.Solution +public import LeanPool.MarkoffModP.RiemannRoch.AdeleSpace.Basic +public import LeanPool.MarkoffModP.RiemannRoch.AdeleSpace.FilterChain +public import LeanPool.MarkoffModP.RiemannRoch.AxiomCheck +public import LeanPool.MarkoffModP.RiemannRoch.Basic +public import LeanPool.MarkoffModP.RiemannRoch.CoordinateFree.AdeleSpace +public import LeanPool.MarkoffModP.RiemannRoch.CoordinateFree.AlgEquiv +public import LeanPool.MarkoffModP.RiemannRoch.CoordinateFree.Divisor +public import LeanPool.MarkoffModP.RiemannRoch.CoordinateFree.RiemannRoch +public import LeanPool.MarkoffModP.RiemannRoch.CoordinateFree.WeilDifferential +public import LeanPool.MarkoffModP.RiemannRoch.Divisor +public import LeanPool.MarkoffModP.RiemannRoch.FunctionField.Divisor +public import LeanPool.MarkoffModP.RiemannRoch.Genus.AdeleQuotient +public import LeanPool.MarkoffModP.RiemannRoch.Genus.Basic +public import LeanPool.MarkoffModP.RiemannRoch.Genus.Polar +public import LeanPool.MarkoffModP.RiemannRoch.Genus.Ramification +public import LeanPool.MarkoffModP.RiemannRoch.LinearKneser +public import LeanPool.MarkoffModP.RiemannRoch.LocalResidue +public import LeanPool.MarkoffModP.RiemannRoch.Place +public import LeanPool.MarkoffModP.RiemannRoch.PlaceEquiv +public import LeanPool.MarkoffModP.RiemannRoch.RRspace.Basic +public import LeanPool.MarkoffModP.RiemannRoch.RiemannRochTheorem.Basic +public import LeanPool.MarkoffModP.RiemannRoch.RiemannRochTheorem.Corollaries +public import LeanPool.MarkoffModP.RiemannRoch.SeparableRelNorm +public import LeanPool.MarkoffModP.RiemannRoch.WeilDifferential +public import LeanPool.MarkoffModP.RiemannRoch.WeilDifferential.Basic + +/-! +# Markoff mod p + +Source: url:https://github.com/yuma-mizuno/markoff-modp +Authors: Yuma Mizuno, Guanghao Li +Status: verified +Main declarations: `BGS.Markoff.reduction_surjective_of_explicitBound` +Tags: markoff-equation, strong-approximation, finite-fields +MSC: 11D25 +-/ diff --git a/LeanPool/MarkoffModP/BGS.lean b/LeanPool/MarkoffModP/BGS.lean new file mode 100644 index 0000000000..56adb27138 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS.lean @@ -0,0 +1,159 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.NumberTheory.DivisorBound +public import LeanPool.MarkoffModP.BGS.NumberTheory.OneSidedPrimitiveWitness +public import LeanPool.MarkoffModP.BGS.Algebra.KummerEigencharacterDescent +public import LeanPool.MarkoffModP.BGS.Algebra.DifferentialWronskian +public import LeanPool.MarkoffModP.BGS.Algebra.RatFuncLinearFractionalEquiv +public import LeanPool.MarkoffModP.BGS.Algebra.ClearedLinearFractionalSubstitution +public import LeanPool.MarkoffModP.BGS.FiniteField.HasseFrobenius +public import LeanPool.MarkoffModP.BGS.Dynamics.StrictMeasureEscape +public import LeanPool.MarkoffModP.BGS.External.GeneralCurveTheorems +public import LeanPool.MarkoffModP.RiemannRoch.CoordinateFree.AlgEquiv +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneSquareFieldStepanovCountAutomatic +public import LeanPool.MarkoffModP.BGS.HasseWeil.GeneralSquareFieldStepanovCount +public import LeanPool.MarkoffModP.BGS.HasseWeil.RatFuncParameterPole +public import LeanPool.MarkoffModP.BGS.HasseWeil.GeneralFiniteExtensionRiemannLower +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionRiemannLowerFromGenus +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionRiemannEventualGrowth +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionRiemannShiftedEventualGrowth +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionRiemannSpaceProjectivization +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionPlaceDegreeFiniteness +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionAffineIdealDegree +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionAffineIdealDivisor +public import LeanPool.MarkoffModP.BGS.HasseWeil.GeneralSquareFieldStepanovCountAutomatic +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExtensionEvenDegreeStepanovBound +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneCoordinateShear +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneFrobeniusDeflation +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneFrobeniusDegenerate +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneFrobeniusReduction +public import LeanPool.MarkoffModP.BGS.HasseWeil.FormalZetaHasseBound +public import LeanPool.MarkoffModP.BGS.HasseWeil.FormalZetaRationality +public import LeanPool.MarkoffModP.BGS.HasseWeil.FormalZetaRationalityDegree +public import LeanPool.MarkoffModP.BGS.HasseWeil.FormalZetaUniqueness +public import LeanPool.MarkoffModP.BGS.HasseWeil.FormalZetaEuler +public import LeanPool.MarkoffModP.BGS.HasseWeil.FormalZetaEulerDegree +public import LeanPool.MarkoffModP.BGS.HasseWeil.FormalZetaDegreeIndexOne +public import LeanPool.MarkoffModP.BGS.HasseWeil.FormalZetaDegreeIndexOneIndexed +public import LeanPool.MarkoffModP.BGS.HasseWeil.FormalZetaConstantExtensionIdentity +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionZetaDegreeExtensionIdentity +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionDivisorDegreeIndex +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionEffectiveDivisorSplit +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionDivisorClassRecurrence +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionRiemannRoch +public import LeanPool.MarkoffModP.BGS.HasseWeil.RatFuncCanonicalInfinityDivisor +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionCanonicalDifferentGenusBound +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionCanonicalDifferentCanonicalityCriterion +public import LeanPool.MarkoffModP.BGS.HasseWeil.DedekindDifferentLocalTrace +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionCanonicalDifferentCotrace +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionCotraceLocalTraceImage +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionCanonicalDifferentCotraceCanonicality +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionCanonicalDifferentLocalMaximality +public import LeanPool.MarkoffModP.BGS.HasseWeil.LinearFunctionalGluing +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionGenusBound +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneCurveGenusBoundFromCotraceDegree +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneCurveGenusBoundFromCotrace +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneCurveGenusBoundAutomatic +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneAffineFiberBound +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneAffineRationalPlaceComparison +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneRationalPlaceAffineComparison +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneAffineCountTransfer +public import LeanPool.MarkoffModP.BGS.HasseWeil.ClosedPlaceEulerRecurrence +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionIndexedZetaRationality +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionIndexedZetaRationalityAutomatic +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionZetaSimplePole +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionZetaNumeratorNoncancellation +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionZetaDegreeIndexOne +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionZetaDegreeIndexOneFromAllCounts +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionZetaDegreeIndexOneAutomatic +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionStandardZetaRationality +public import LeanPool.MarkoffModP.BGS.HasseWeil.ConstantExtensionClosedPlaceCount +public import LeanPool.MarkoffModP.BGS.HasseWeil.ConstantExtensionPlaceSplittingMultiplicity +public import LeanPool.MarkoffModP.BGS.HasseWeil.ConstantExtensionInfinityPlaceDegreeTower +public import LeanPool.MarkoffModP.BGS.HasseWeil.ConstantExtensionClosedPlaceSplittingFormula +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionPlaceTower +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteBranchLocus +public import LeanPool.MarkoffModP.BGS.HasseWeil.RationalPlace +public import LeanPool.MarkoffModP.BGS.HasseWeil.RationalPlaceTower +public import LeanPool.MarkoffModP.BGS.HasseWeil.RatFuncConstantExtension +public import LeanPool.MarkoffModP.BGS.HasseWeil.FunctionFieldConstantExtension +public import LeanPool.MarkoffModP.BGS.HasseWeil.ConstantFieldAutomorphism +public import LeanPool.MarkoffModP.BGS.HasseWeil.ConstantFieldRatFuncCompatibility +public import LeanPool.MarkoffModP.BGS.HasseWeil.ConstantFieldFinitePlace +public import LeanPool.MarkoffModP.BGS.HasseWeil.ConstantFieldFinitePlaceDegree +public import LeanPool.MarkoffModP.BGS.HasseWeil.ConstantFieldInfinityBase +public import LeanPool.MarkoffModP.BGS.HasseWeil.FunctionFieldNormalClosure +public import LeanPool.MarkoffModP.BGS.HasseWeil.FunctionFieldConstantField +public import LeanPool.MarkoffModP.BGS.HasseWeil.FunctionFieldNormalClosureConstants +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtension +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionAutomorphism +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionConstants +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionQuotient +public import LeanPool.MarkoffModP.BGS.HasseWeil.FrobeniusTwistGroup +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionFrobeniusTwist +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionFrobeniusTwistConstants +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionFrobeniusTwistRiemannLower +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionFrobeniusTwistDegree +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionFrobeniusTwistMultiplication +public import LeanPool.MarkoffModP.BGS.HasseWeil.FunctionFieldNormalClosureConstantBase +public import LeanPool.MarkoffModP.BGS.HasseWeil.FunctionFieldNormalClosureRatFuncBase +public import LeanPool.MarkoffModP.BGS.HasseWeil.FunctionFieldNormalClosureRatFuncEquiv +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteFieldSubfield +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteFieldCompositum +public import LeanPool.MarkoffModP.BGS.HasseWeil.PolynomialTensorCancel +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteFieldPolynomialNormalization +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteFieldPolynomialDifferent +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteFieldInfinityDifferent +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionInfinityDifferent +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionFiniteDifferent +public import LeanPool.MarkoffModP.BGS.HasseWeil.FinsuppWeightedFiber +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionTotalDifferentEffectiveDivisor +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionTotalDifferentDegree +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionGenusInvariance +public import LeanPool.MarkoffModP.BGS.HasseWeil.IdealMultiplicityMap +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionGenusDegree +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteFieldConstantExtensionNormalization +public import LeanPool.MarkoffModP.BGS.HasseWeil.ConstantTensorResidue +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteFieldConstantExtensionResidue +public import LeanPool.MarkoffModP.BGS.HasseWeil.FinitePlaceNormalizationTransport +public import LeanPool.MarkoffModP.BGS.HasseWeil.RatFuncExactConstantExtension +public import LeanPool.MarkoffModP.BGS.HasseWeil.ConstantExtensionFinitePlaceBridge +public import LeanPool.MarkoffModP.BGS.HasseWeil.ConstantExtensionRationalPlace +public import LeanPool.MarkoffModP.BGS.HasseWeil.RatFuncInfinityLocalization +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionInfinityNormalization +public import LeanPool.MarkoffModP.BGS.HasseWeil.ConstantExtensionInfinityPlaceBridge +public import LeanPool.MarkoffModP.BGS.HasseWeil.FinitePlaceFrobeniusFiber +public import LeanPool.MarkoffModP.BGS.HasseWeil.FrobeniusPlaceCardinality +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionFinitePlace +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionFinitePlaceCompatibility +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionFinitePlaceFrobeniusAverage +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionFrobeniusTwistFinitePlaceAverage +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionFrobeniusTwistRationalPlaceAverage +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionFrobeniusTwistFinitePlaceBridge +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionFrobeniusTwistFinitePlaceUnramified +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionFrobeniusTwistInfinityPlaceDescent +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionFrobeniusTwistInfinityPlaceEquivalence +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionHasseBoundFromEvenConstantExtensions +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneAffineHasseWeilFromZeta +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneAffineHasseWeilFromEvenError +public import LeanPool.MarkoffModP.BGS.HasseWeil.GeneralBivariateAffineHasseWeil +public import LeanPool.MarkoffModP.BGS.CorvajaZannier +public import LeanPool.MarkoffModP.BGS.Markoff.Core +public import LeanPool.MarkoffModP.BGS.Markoff.Opening +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve +public import LeanPool.MarkoffModP.BGS.Markoff.Endgame +public import LeanPool.MarkoffModP.BGS.Markoff.Cage +public import LeanPool.MarkoffModP.BGS.Markoff.Incidence +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly +public import LeanPool.MarkoffModP.BGS.Markoff.Diophantine +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.RankinWidthEnvelope +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.RankinJointAntichainWidth +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.RankinJointAntichainSperner +public import LeanPool.MarkoffModP.BGS.NumberTheory.RankinCutoff1248Profile diff --git a/LeanPool/MarkoffModP/BGS/Algebra/ClearedLinearFractionalSubstitution.lean b/LeanPool/MarkoffModP/BGS/Algebra/ClearedLinearFractionalSubstitution.lean new file mode 100644 index 0000000000..51fd94ca58 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Algebra/ClearedLinearFractionalSubstitution.lean @@ -0,0 +1,233 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Algebra.RatFuncLinearFractionalEquiv + +/-! +# Cleared linear-fractional substitution + +For a polynomial `f` of degree `n`, this file studies the polynomial obtained from +`f ((a * X + b) / (c * X + d))` by multiplying by `(c * X + d) ^ n`. + +The degree assumption in the irreducibility theorem is essential: inversion sends the +linear polynomial `X` to the unit polynomial `1` after clearing its denominator. +-/ + +@[expose] public section + +namespace BGS + +open Polynomial +open IntermediateField + +noncomputable section + +variable {K : Type*} [Field K] + +/-- The denominator-cleared substitution +`(cX+d)^deg(f) f((aX+b)/(cX+d))`, written without division. -/ +def clearedLinearFractionalSubstitution (f : K[X]) (a b c d : K) : K[X] := + f.support.sum fun i ↦ C (f.coeff i) * (C a * X + C b) ^ i * + (C c * X + C d) ^ (f.natDegree - i) + +private theorem linearPolynomial_natDegree_le_one (u v : K) : + (C u * X + C v).natDegree ≤ 1 := by + calc + (C u * X + C v).natDegree ≤ max (C u * X).natDegree (C v).natDegree := + natDegree_add_le _ _ + _ ≤ 1 := max_le (natDegree_mul_le.trans (by simp)) (by simp) + +private theorem clearedLinearFractionalSummand_natDegree_le + (f : K[X]) (a b c d : K) {i : ℕ} (hi : i ≤ f.natDegree) : + (C (f.coeff i) * (C a * X + C b) ^ i * + (C c * X + C d) ^ (f.natDegree - i)).natDegree ≤ f.natDegree := by + have outerProductDegree : + (C (f.coeff i) * (C a * X + C b) ^ i * + (C c * X + C d) ^ (f.natDegree - i)).natDegree ≤ + (C (f.coeff i) * (C a * X + C b) ^ i).natDegree + + ((C c * X + C d) ^ (f.natDegree - i)).natDegree := + natDegree_mul_le + have innerProductDegree : + (C (f.coeff i) * (C a * X + C b) ^ i).natDegree ≤ + (C (f.coeff i)).natDegree + ((C a * X + C b) ^ i).natDegree := + natDegree_mul_le + calc + _ ≤ ((C (f.coeff i)).natDegree + ((C a * X + C b) ^ i).natDegree) + + ((C c * X + C d) ^ (f.natDegree - i)).natDegree := + outerProductDegree.trans (add_le_add innerProductDegree (le_refl _)) + _ ≤ (0 + i) + (f.natDegree - i) := by + apply add_le_add + · apply add_le_add + · simp + · exact natDegree_pow_le.trans <| + (Nat.mul_le_mul_left i (linearPolynomial_natDegree_le_one a b)).trans (by simp) + · exact natDegree_pow_le.trans <| + (Nat.mul_le_mul_left (f.natDegree - i) + (linearPolynomial_natDegree_le_one c d)).trans (by simp) + _ = f.natDegree := by omega + +theorem natDegree_clearedLinearFractionalSubstitution_le + (f : K[X]) (a b c d : K) : + (clearedLinearFractionalSubstitution f a b c d).natDegree ≤ f.natDegree := by + exact natDegree_sum_le_of_forall_le f.support _ fun i hi ↦ + clearedLinearFractionalSummand_natDegree_le f a b c d + (le_natDegree_of_ne_zero (mem_support_iff.mp hi)) + +theorem aeval_clearedLinearFractionalSubstitution + {L : Type*} [Field L] [Algebra K L] (f : K[X]) (a b c d : K) (x y : L) + (hrelation : + algebraMap K L a * x + algebraMap K L b = + y * (algebraMap K L c * x + algebraMap K L d)) : + aeval x (clearedLinearFractionalSubstitution f a b c d) = + (algebraMap K L c * x + algebraMap K L d) ^ f.natDegree * aeval y f := by + rw [clearedLinearFractionalSubstitution, map_sum] + simp only [map_mul, map_pow, aeval_def, eval₂_add, eval₂_mul, eval₂_C, eval₂_X] + calc + ∑ i ∈ f.support, + algebraMap K L (f.coeff i) * + (algebraMap K L a * x + algebraMap K L b) ^ i * + (algebraMap K L c * x + algebraMap K L d) ^ (f.natDegree - i) = + (algebraMap K L c * x + algebraMap K L d) ^ f.natDegree * + ∑ i ∈ f.support, algebraMap K L (f.coeff i) * y ^ i := by + rw [Finset.mul_sum] + apply Finset.sum_congr rfl + intro i hi + have hiDegree : i ≤ f.natDegree := + le_natDegree_of_ne_zero (mem_support_iff.mp hi) + rw [hrelation, mul_pow] + have hpow : + (algebraMap K L c * x + algebraMap K L d) ^ i * + (algebraMap K L c * x + algebraMap K L d) ^ (f.natDegree - i) = + (algebraMap K L c * x + algebraMap K L d) ^ f.natDegree := by + rw [← pow_add, Nat.add_sub_of_le hiDegree] + rw [← hpow] + ring + _ = (algebraMap K L c * x + algebraMap K L d) ^ f.natDegree * aeval y f := by + rw [aeval_def, eval₂_eq_sum, sum_def] + +/-- An invertible linear-fractional change of variable preserves irreducibility after +clearing denominators at the degree of the polynomial. Degree at least two is necessary: +for the inversion matrix, the cleared transform of `X` is `1`. -/ +theorem irreducible_clearedLinearFractionalSubstitution + {f : K[X]} (hf : Irreducible f) (hfDegree : 2 ≤ f.natDegree) + {a b c d : K} (hdet : a * d - b * c ≠ 0) : + Irreducible (clearedLinearFractionalSubstitution f a b c d) := by + let : Fact (Irreducible f) := ⟨hf⟩ + let E := AdjoinRoot f + let : FiniteDimensional K E := by + change FiniteDimensional K (AdjoinRoot f) + exact (AdjoinRoot.powerBasis hf.ne_zero).finite + let α : E := AdjoinRoot.root f + have hfDegreeNeOne : f.natDegree ≠ 1 := by omega + have hroot : aeval α f = 0 := by + change eval₂ (algebraMap K E) (AdjoinRoot.root f) f = 0 + exact AdjoinRoot.eval₂_root f + have hinverseDenominator : + algebraMap K E a - algebraMap K E c * α ≠ 0 := by + by_cases hc : c = 0 + · have ha : a ≠ 0 := by + intro ha + apply hdet + simp [ha, hc] + simp [hc, ha] + · intro hzero + have hcMap : algebraMap K E c ≠ 0 := by + simpa using (algebraMap K E).injective.ne hc + have hα : α = algebraMap K E (a / c) := by + rw [map_div₀ (algebraMap K E) a c] + apply (eq_div_iff hcMap).2 + have := sub_eq_zero.mp hzero + rw [mul_comm] + exact this.symm + exact hf.aeval_ne_zero_of_natDegree_ne_one hfDegreeNeOne + ⟨a / c, hα.symm⟩ hroot + let β : E := + (algebraMap K E d * α - algebraMap K E b) / + (algebraMap K E a - algebraMap K E c * α) + have hforwardDenominatorFormula : + algebraMap K E c * β + algebraMap K E d = + algebraMap K E (a * d - b * c) / + (algebraMap K E a - algebraMap K E c * α) := by + dsimp [β] + apply (eq_div_iff hinverseDenominator).2 + rw [add_mul, mul_assoc, div_mul_cancel₀ _ hinverseDenominator] + simp only [map_sub, map_mul] + ring + have hforwardDenominator : + algebraMap K E c * β + algebraMap K E d ≠ 0 := by + rw [hforwardDenominatorFormula] + exact div_ne_zero (by simpa using (algebraMap K E).injective.ne hdet) + hinverseDenominator + have hforwardNumeratorFormula : + algebraMap K E a * β + algebraMap K E b = + α * algebraMap K E (a * d - b * c) / + (algebraMap K E a - algebraMap K E c * α) := by + dsimp [β] + apply (eq_div_iff hinverseDenominator).2 + rw [add_mul, mul_assoc, div_mul_cancel₀ _ hinverseDenominator] + simp only [map_sub, map_mul] + ring + have hlinearFractionalRelation : + algebraMap K E a * β + algebraMap K E b = + α * (algebraMap K E c * β + algebraMap K E d) := by + rw [hforwardNumeratorFormula, hforwardDenominatorFormula] + ring + have hαFormula : + α = (algebraMap K E a * β + algebraMap K E b) / + (algebraMap K E c * β + algebraMap K E d) := by + apply (eq_div_iff hforwardDenominator).2 + exact hlinearFractionalRelation.symm + have hβGenerates : K⟮β⟯ = (⊤ : IntermediateField K E) := by + apply top_unique + rw [← IntermediateField.adjoin_root_eq_top f] + apply IntermediateField.adjoin_simple_le_iff.mpr + change α ∈ K⟮β⟯ + rw [hαFormula] + exact div_mem + (add_mem (mul_mem (IntermediateField.algebraMap_mem _ a) + (IntermediateField.mem_adjoin_simple_self K β)) + (IntermediateField.algebraMap_mem _ b)) + (add_mem (mul_mem (IntermediateField.algebraMap_mem _ c) + (IntermediateField.mem_adjoin_simple_self K β)) + (IntermediateField.algebraMap_mem _ d)) + have hminpolyDegree : (minpoly K β).natDegree = f.natDegree := by + have hprimitive := (Field.primitive_element_iff_minpoly_natDegree_eq K β).mp hβGenerates + exact hprimitive.trans (AdjoinRoot.powerBasis hf.ne_zero).finrank + have htransformedRoot : + aeval β (clearedLinearFractionalSubstitution f a b c d) = 0 := by + rw [aeval_clearedLinearFractionalSubstitution f a b c d β α + hlinearFractionalRelation, hroot, mul_zero] + have hminpolyDvd : minpoly K β ∣ clearedLinearFractionalSubstitution f a b c d := + minpoly.dvd K β htransformedRoot + have htransformedNonzero : clearedLinearFractionalSubstitution f a b c d ≠ 0 := by + intro hzero + let q := Algebra.ratFuncLinearFractionalValue a b c d + have hden := Algebra.ratFuncLinearFractional_denominator_ne_zero hdet + have hrelation : + RatFunc.C a * RatFunc.X + RatFunc.C b = + q * (RatFunc.C c * RatFunc.X + RatFunc.C d) := by + dsimp [q, Algebra.ratFuncLinearFractionalValue] + exact (div_mul_cancel₀ _ hden).symm + have heval := aeval_clearedLinearFractionalSubstitution f a b c d RatFunc.X q hrelation + rw [hzero, map_zero] at heval + have hqTranscendental : Transcendental K q := + Algebra.ratFuncLinearFractionalValue_transcendental hdet + have hfAtQ : aeval q f ≠ 0 := by + intro hqRoot + exact hf.ne_zero ((transcendental_iff.mp hqTranscendental) f hqRoot) + exact (mul_ne_zero (pow_ne_zero _ hden) hfAtQ) heval.symm + have hassociated : + Associated (minpoly K β) (clearedLinearFractionalSubstitution f a b c d) := by + apply associated_of_dvd_of_natDegree_le hminpolyDvd htransformedNonzero + · rw [hminpolyDegree] + exact natDegree_clearedLinearFractionalSubstitution_le f a b c d + exact hassociated.irreducible_iff.mp (minpoly.irreducible (Algebra.IsIntegral.isIntegral β)) + +end + +end BGS diff --git a/LeanPool/MarkoffModP/BGS/Algebra/DifferentialWronskian.lean b/LeanPool/MarkoffModP/BGS/Algebra/DifferentialWronskian.lean new file mode 100644 index 0000000000..8f1e6db632 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Algebra/DifferentialWronskian.lean @@ -0,0 +1,169 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import Mathlib.RingTheory.Derivation.Basic +public import Mathlib.LinearAlgebra.Matrix.ToLinearEquiv +public import Mathlib.LinearAlgebra.Finsupp.LinearCombination +public import Mathlib.Tactic.LinearCombination + +/-! +# Ordinary Wronskians over differential fields + +Corvaja--Zannier's positive-characteristic argument uses an ordinary Wronskian over the +subfield of constants of a derivation. This file proves the required algebraic criterion: +a finite family is linearly independent over the exact constant field if and only if its +Wronskian determinant is nonzero. + +The reverse implication is the difficult direction. Its proof normalizes a nonzero kernel +vector, differentiates the resulting row relations, deletes the normalized coordinate, and +applies induction to the smaller Wronskian. +-/ + +@[expose] public section + +namespace BGS.Algebra + +noncomputable section + +open scoped Matrix + +variable {C L : Type*} [Field C] [Field L] [Algebra C L] + +/-- The ordinary Wronskian matrix of a finite family with respect to a derivation. -/ +def derivationWronskian (D : Derivation C L L) {n : ℕ} (f : Fin n → L) : + Matrix (Fin n) (Fin n) L := + fun i j ↦ (D.toLinearMap ^ (i : ℕ)) (f j) + +private lemma derivation_iterate_succ (D : Derivation C L L) (n : ℕ) (x : L) : + D ((D.toLinearMap ^ n) x) = (D.toLinearMap ^ (n + 1)) x := by + rw [pow_succ', Module.End.mul_apply] + rfl + +/-- If every element killed by `D` comes from `C`, then a family linearly independent over +`C` has nonzero ordinary Wronskian. -/ +theorem derivationWronskian_det_ne_zero_of_linearIndependent + (D : Derivation C L L) + (constants : ∀ x : L, D x = 0 → ∃ c : C, algebraMap C L c = x) : + ∀ (n : ℕ) (f : Fin n → L), LinearIndependent C f → + (derivationWronskian D f).det ≠ 0 := by + intro n + induction n with + | zero => + intro f hf + simp + | succ n ih => + intro f hf hdet + let W : Matrix (Fin (n + 1)) (Fin (n + 1)) L := derivationWronskian D f + have hWdet : W.det = 0 := by simpa [W] using hdet + obtain ⟨a, ha_ne, haW⟩ := Matrix.exists_mulVec_eq_zero_iff.mpr hWdet + obtain ⟨k, hak⟩ : ∃ k, a k ≠ 0 := by + simpa [Function.ne_iff] using ha_ne + let c : Fin (n + 1) → L := fun j ↦ (a k)⁻¹ * a j + have hck : c k = 1 := by simp [c, hak] + have hcW : W *ᵥ c = 0 := by + funext i + simp only [Matrix.mulVec, dotProduct, Pi.zero_apply] + calc + ∑ j, W i j * c j = (a k)⁻¹ * ∑ j, W i j * a j := by + simp only [c] + rw [Finset.mul_sum] + apply Finset.sum_congr rfl + intro j hj + ring + _ = 0 := by + rw [show ∑ j, W i j * a j = 0 by + simpa [Matrix.mulVec, dotProduct] using congr_fun haW i, mul_zero] + have hc_relation (i : Fin (n + 1)) : + ∑ j, (D.toLinearMap ^ (i : ℕ)) (f j) * c j = 0 := by + simpa [W, derivationWronskian, Matrix.mulVec, dotProduct] using congr_fun hcW i + have hDck : D (c k) = 0 := by simp [hck] + let g : Fin n → L := fun j ↦ f (k.succAbove j) + have hg : LinearIndependent C g := + hf.comp k.succAbove k.succAbove_right_injective + have hWgdet : (derivationWronskian D g).det ≠ 0 := ih g hg + let b : Fin n → L := fun j ↦ D (c (k.succAbove j)) + have hfull (i : Fin n) : + ∑ j : Fin (n + 1), + (D.toLinearMap ^ (i : ℕ)) (f j) * D (c j) = 0 := by + have hderiv := congrArg D (hc_relation i.castSucc) + have hnext := hc_relation i.succ + simp only [map_zero, map_sum, D.leibniz, smul_eq_mul, + derivation_iterate_succ] at hderiv + have hindex (j : Fin (n + 1)) : + (D.toLinearMap ^ (((i.castSucc : Fin (n + 1)) : ℕ) + 1)) (f j) = + (D.toLinearMap ^ ((i.succ : Fin (n + 1)) : ℕ)) (f j) := by + simp + simp_rw [hindex] at hderiv + have hnext' : + ∑ j : Fin (n + 1), + c j * (D.toLinearMap ^ ((i.succ : Fin (n + 1)) : ℕ)) (f j) = 0 := by + simpa [mul_comm] using hnext + rw [Finset.sum_add_distrib] at hderiv + have hderiv' : + (∑ j : Fin (n + 1), (D.toLinearMap ^ (i : ℕ)) (f j) * D (c j)) + + ∑ j : Fin (n + 1), + c j * (D.toLinearMap ^ ((i.succ : Fin (n + 1)) : ℕ)) (f j) = 0 := by + simpa using hderiv + linear_combination hderiv' - hnext' + have hWgb : derivationWronskian D g *ᵥ b = 0 := by + funext i + simp only [Matrix.mulVec, dotProduct, Pi.zero_apply, b, g, + derivationWronskian] + have hi := hfull i + rw [Fin.sum_univ_succAbove (fun j : Fin (n + 1) ↦ + (D.toLinearMap ^ (i : ℕ)) (f j) * D (c j)) k] at hi + simpa [hDck] using hi + have hbzero : b = 0 := Matrix.eq_zero_of_mulVec_eq_zero hWgdet hWgb + have hDc (j : Fin (n + 1)) : D (c j) = 0 := by + by_cases hj : j = k + · simpa [hj] using hDck + · obtain ⟨r, hr⟩ := Fin.exists_succAbove_eq hj + have := congr_fun hbzero r + simpa [b, hr] using this + choose coeff hcoeff using fun j ↦ constants (c j) (hDc j) + have hcoeff_relation : ∑ j, coeff j • f j = 0 := by + have hzero := hc_relation 0 + simpa [hcoeff, Algebra.smul_def, mul_comm] using hzero + have hcoeff_zero : ∀ j, coeff j = 0 := + (Fintype.linearIndependent_iff.mp hf) coeff hcoeff_relation + have : (1 : L) = 0 := by + rw [← hck, ← hcoeff k, hcoeff_zero k, map_zero] + exact one_ne_zero this + +/-- A nonzero Wronskian determinant implies linear independence over the derivation's +scalar field. -/ +theorem linearIndependent_of_derivationWronskian_det_ne_zero + (D : Derivation C L L) {n : ℕ} (f : Fin n → L) + (hdet : (derivationWronskian D f).det ≠ 0) : + LinearIndependent C f := by + let W := derivationWronskian D f + have hcols : LinearIndependent L W.col := + Matrix.linearIndependent_cols_of_det_ne_zero hdet + rw [Fintype.linearIndependent_iff] + intro g hg j + let gL : Fin n → L := fun i ↦ algebraMap C L (g i) + have hcomb : ∑ i, gL i • W.col i = 0 := by + funext r + have hrow := congrArg (fun x ↦ (D.toLinearMap ^ (r : ℕ)) x) hg + simp only [map_sum, LinearMap.map_smul] at hrow + simpa [W, gL, derivationWronskian, Algebra.smul_def] using hrow + have hgj : gL j = 0 := Fintype.linearIndependent_iff.mp hcols gL hcomb j + exact (algebraMap C L).injective (by simpa [gL] using hgj) + +/-- The ordinary Wronskian criterion when `C` is exactly the field of constants of `D`. -/ +theorem derivationWronskian_det_ne_zero_iff_linearIndependent + (D : Derivation C L L) + (constants : ∀ x : L, D x = 0 → ∃ c : C, algebraMap C L c = x) + {n : ℕ} (f : Fin n → L) : + (derivationWronskian D f).det ≠ 0 ↔ LinearIndependent C f := by + exact ⟨linearIndependent_of_derivationWronskian_det_ne_zero D f, + derivationWronskian_det_ne_zero_of_linearIndependent D constants n f⟩ + +end + +end BGS.Algebra diff --git a/LeanPool/MarkoffModP/BGS/Algebra/KummerEigencharacterDescent.lean b/LeanPool/MarkoffModP/BGS/Algebra/KummerEigencharacterDescent.lean new file mode 100644 index 0000000000..7d678f5fab --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Algebra/KummerEigencharacterDescent.lean @@ -0,0 +1,171 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import Mathlib.FieldTheory.KummerExtension + +/-! +# Eigencharacter descent in a cyclic Kummer extension + +If a prime power of an element in `F(eta)`, with `eta ^ e = v`, lies in the base field and the +base contains a primitive `e`-th root of unity, the element has only one Kummer character. The +proof constructs the root-scaling automorphism and compares coefficients in the canonical power +basis. This is the generic descent needed before applying trace-curve Kummer-class independence +at primes dividing both cover exponents. +-/ + +@[expose] public section + +open Polynomial AdjoinRoot + +noncomputable section + +universe u + +namespace BGS.Algebra + +variable {F : Type u} [Field F] + +lemma kummerPowerBasis_eigenvector_eq_rootMonomial + {e : ℕ} (he : 0 < e) {v ζ : F} + (hζ : IsPrimitiveRoot ζ e) + (T : AdjoinRoot (X ^ e - C v) →ₐ[F] AdjoinRoot (X ^ e - C v)) + (hTroot : T (AdjoinRoot.root (X ^ e - C v)) = + algebraMap F (AdjoinRoot (X ^ e - C v)) ζ * + AdjoinRoot.root (X ^ e - C v)) + (k : Fin (X ^ e - C v).natDegree) (z : AdjoinRoot (X ^ e - C v)) + (hz : T z = algebraMap F (AdjoinRoot (X ^ e - C v)) (ζ ^ (k : ℕ)) * z) : + ∃ c : F, z = algebraMap F (AdjoinRoot (X ^ e - C v)) c * + AdjoinRoot.root (X ^ e - C v) ^ (k : ℕ) := by + let hmonic := monic_X_pow_sub_C v he.ne' + let b := AdjoinRoot.powerBasisAux' hmonic + have hpb (j : Fin (X ^ e - C v).natDegree) : b j = + AdjoinRoot.root (X ^ e - C v) ^ (j : ℕ) := by + change (AdjoinRoot.powerBasis' hmonic).basis j = _ + exact (AdjoinRoot.powerBasis' hmonic).basis_eq_pow j + have hTbasis (j : Fin (X ^ e - C v).natDegree) : + T (b j) = (ζ ^ (j : ℕ)) • b j := by + rw [hpb, map_pow, hTroot, mul_pow, ← map_pow] + simp only [Algebra.smul_def] + have hTcoord (j : Fin (X ^ e - C v).natDegree) : + b.repr (T z) j = ζ ^ (j : ℕ) * b.repr z j := by + conv_lhs => rw [← b.sum_repr z] + simp only [map_sum, map_smul, hTbasis, smul_smul] + classical + rw [Finset.sum_apply'] + change (∑ c, (((b.repr z c * ζ ^ (c : ℕ)) • b.repr (b c)) j)) = _ + rw [Finset.sum_eq_single j] + · simp [mul_comm] + · intro c _ hc + simp [hc] + · simp + have hzcoord (j : Fin (X ^ e - C v).natDegree) : + ζ ^ (j : ℕ) * b.repr z j = + ζ ^ (k : ℕ) * b.repr z j := by + have h := congrArg (fun w ↦ b.repr w j) hz + rw [hTcoord] at h + rw [← Algebra.smul_def] at h + rw [map_smul] at h + simpa using h + let c := b.repr z k + refine ⟨c, ?_⟩ + rw [← hpb] + apply b.repr.injective + ext j + rw [← Algebra.smul_def] + rw [map_smul] + simp only [Finsupp.smul_apply, b.repr_self_apply] + by_cases hjk : j = k + · subst k + simp [c] + · have hpowers : ζ ^ (j : ℕ) ≠ ζ ^ (k : ℕ) := by + intro hp + apply hjk + apply Fin.ext + apply hζ.pow_inj + · exact lt_of_lt_of_eq j.isLt natDegree_X_pow_sub_C + · exact lt_of_lt_of_eq k.isLt natDegree_X_pow_sub_C + · exact hp + have hcoeff : b.repr z j = 0 := by + have hmul : (ζ ^ (j : ℕ) - ζ ^ (k : ℕ)) * b.repr z j = 0 := by + rw [sub_mul, hzcoord j, sub_self] + exact (mul_eq_zero.mp hmul).resolve_left (sub_ne_zero.mpr hpowers) + rw [hcoeff] + simp [Ne.symm hjk] + +/-- If a prime power of an element of a Kummer extension lies in the base field, then the +element occupies one residue character. The exponent `k` satisfies the exact invariance +condition `e ∣ q*k`; no coprimality between `q` and `e` is assumed. -/ +theorem exists_rootMonomial_of_primePower_mem_base + {e q : ℕ} (he : 0 < e) {v ζ a : F} + (hζ : IsPrimitiveRoot ζ e) + (hirr : Irreducible (X ^ e - C v)) + (hq : q.Prime) (hqe : q ∣ e) + (z : AdjoinRoot (X ^ e - C v)) + (hzq : z ^ q = algebraMap F (AdjoinRoot (X ^ e - C v)) a) : + ∃ k < e, e ∣ q * k ∧ ∃ c : F, + z = algebraMap F (AdjoinRoot (X ^ e - C v)) c * + AdjoinRoot.root (X ^ e - C v) ^ k := by + let : Fact (Irreducible (X ^ e - C v)) := ⟨hirr⟩ + let : NeZero e := ⟨he.ne'⟩ + let ζe : rootsOfUnity e F := rootsOfUnity.mkOfPowEq ζ hζ.pow_eq_one + let T : AdjoinRoot (X ^ e - C v) →ₐ[F] AdjoinRoot (X ^ e - C v) := + autAdjoinRootXPowSubCHom e v ζe + have hTroot : T (AdjoinRoot.root (X ^ e - C v)) = + algebraMap F (AdjoinRoot (X ^ e - C v)) ζ * + AdjoinRoot.root (X ^ e - C v) := by + dsimp [T, autAdjoinRootXPowSubCHom] + simp [ζe, rootsOfUnity.mkOfPowEq, Algebra.smul_def] + by_cases hz : z = 0 + · refine ⟨0, he, by simp, 0, ?_⟩ + simp [hz] + let s := e / q + have hspos : 0 < s := by + exact Nat.div_pos (Nat.le_of_dvd he hqe) hq.pos + have hfactor : e = s * q := by + exact (Nat.div_mul_cancel hqe).symm + have hζqF : IsPrimitiveRoot (ζ ^ s) q := hζ.pow he hfactor + have hζqL : IsPrimitiveRoot + (algebraMap F (AdjoinRoot (X ^ e - C v)) (ζ ^ s)) q := + hζqF.map_of_injective (algebraMap F (AdjoinRoot (X ^ e - C v))).injective + have hTpow : (T z) ^ q = z ^ q := by + calc + (T z) ^ q = T (z ^ q) := by rw [map_pow] + _ = T (algebraMap F (AdjoinRoot (X ^ e - C v)) a) := by rw [hzq] + _ = algebraMap F (AdjoinRoot (X ^ e - C v)) a := T.commutes a + _ = z ^ q := hzq.symm + have hratioPow : (T z / z) ^ q = 1 := by + rw [div_pow, hTpow, div_self (pow_ne_zero q hz)] + let : NeZero q := ⟨hq.ne_zero⟩ + obtain ⟨m, hm, hmratio⟩ := hζqL.eq_pow_of_pow_eq_one hratioPow + have hTz : T z = + algebraMap F (AdjoinRoot (X ^ e - C v)) (ζ ^ (s * m)) * z := by + calc + T z = (T z / z) * z := (div_mul_cancel₀ (T z) hz).symm + _ = (algebraMap F (AdjoinRoot (X ^ e - C v)) (ζ ^ s)) ^ m * z := by + rw [hmratio] + _ = algebraMap F (AdjoinRoot (X ^ e - C v)) ((ζ ^ s) ^ m) * z := by + simp only [map_pow] + _ = algebraMap F (AdjoinRoot (X ^ e - C v)) (ζ ^ (s * m)) * z := by + rw [pow_mul] + have hkmLt : s * m < e := by + calc + s * m < s * q := (Nat.mul_lt_mul_left hspos).2 hm + _ = e := hfactor.symm + have hdeg : (X ^ e - C v).natDegree = e := natDegree_X_pow_sub_C + let kfin : Fin (X ^ e - C v).natDegree := ⟨s * m, by simpa [hdeg] using hkmLt⟩ + have hTzFin : T z = + algebraMap F (AdjoinRoot (X ^ e - C v)) (ζ ^ (kfin : ℕ)) * z := hTz + obtain ⟨c, hc⟩ := kummerPowerBasis_eigenvector_eq_rootMonomial + he hζ T hTroot kfin z hTzFin + refine ⟨s * m, hkmLt, ?_, c, hc⟩ + refine ⟨m, ?_⟩ + calc + q * (s * m) = (s * q) * m := by ac_rfl + _ = e * m := by rw [← hfactor] + +end BGS.Algebra diff --git a/LeanPool/MarkoffModP/BGS/Algebra/RatFuncLinearFractionalEquiv.lean b/LeanPool/MarkoffModP/BGS/Algebra/RatFuncLinearFractionalEquiv.lean new file mode 100644 index 0000000000..e78e4ffd93 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Algebra/RatFuncLinearFractionalEquiv.lean @@ -0,0 +1,183 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import Mathlib.FieldTheory.RatFunc.IntermediateField + +/-! +# Linear-fractional automorphisms of a rational function field + +An invertible matrix `((a, b), (c, d))` acts on `K(X)` by sending +`X` to `(aX+b)/(cX+d)`. This file constructs that action as a `K`-algebra +equivalence and records its action on `X` and on embedded polynomials. +-/ + +@[expose] public section + +namespace BGS.Algebra + +open IntermediateField Polynomial + +noncomputable section + +variable {K : Type*} [Field K] + +/-- The value of the linear-fractional substitution associated to +`((a, b), (c, d))` at the rational-function variable. -/ +def ratFuncLinearFractionalValue (a b c d : K) : RatFunc K := + (RatFunc.C a * RatFunc.X + RatFunc.C b) / + (RatFunc.C c * RatFunc.X + RatFunc.C d) + +private lemma linearPolynomial_ne_zero_of_determinant_ne_zero + {a b c d : K} (hdet : a * d - b * c ≠ 0) : + (C c * X + C d : K[X]) ≠ 0 := by + intro h + have hc : c = 0 := by + have hcoeff := congrArg (fun f : K[X] => f.coeff 1) h + simpa using hcoeff + have hd : d = 0 := by + have hcoeff := congrArg (fun f : K[X] => f.coeff 0) h + simpa using hcoeff + apply hdet + simp [hc, hd] + +lemma ratFuncLinearFractional_denominator_ne_zero + {a b c d : K} (hdet : a * d - b * c ≠ 0) : + RatFunc.C c * RatFunc.X + RatFunc.C d ≠ 0 := by + simpa only [map_add, map_mul, RatFunc.algebraMap_X, RatFunc.algebraMap_C] using + RatFunc.algebraMap_ne_zero + (linearPolynomial_ne_zero_of_determinant_ne_zero hdet) + +lemma ratFuncLinearFractionalValue_not_constant + {a b c d : K} (hdet : a * d - b * c ≠ 0) : + ¬ ∃ k : K, ratFuncLinearFractionalValue a b c d = RatFunc.C k := by + rintro ⟨k, hk⟩ + have hden := ratFuncLinearFractional_denominator_ne_zero hdet + have hcross : + RatFunc.C a * RatFunc.X + RatFunc.C b = + RatFunc.C k * (RatFunc.C c * RatFunc.X + RatFunc.C d) := + (div_eq_iff hden).mp hk + have hpoly : + (C a * X + C b : K[X]) = C k * (C c * X + C d) := by + apply RatFunc.algebraMap_injective K + simpa only [map_add, map_mul, RatFunc.algebraMap_X, RatFunc.algebraMap_C] using hcross + have ha : a = k * c := by + have hcoeff := congrArg (fun f : K[X] => f.coeff 1) hpoly + simpa using hcoeff + have hb : b = k * d := by + have hcoeff := congrArg (fun f : K[X] => f.coeff 0) hpoly + simpa using hcoeff + apply hdet + rw [ha, hb] + ring + +lemma ratFuncLinearFractionalValue_transcendental + {a b c d : K} (hdet : a * d - b * c ≠ 0) : + Transcendental K (ratFuncLinearFractionalValue a b c d) := + RatFunc.transcendental_of_ne_C _ + (ratFuncLinearFractionalValue_not_constant hdet) + +lemma ratFuncLinearFractionalValue_inverse_formula + {a b c d : K} (hdet : a * d - b * c ≠ 0) : + RatFunc.X = + (RatFunc.C d * ratFuncLinearFractionalValue a b c d - RatFunc.C b) / + (RatFunc.C a - RatFunc.C c * ratFuncLinearFractionalValue a b c d) := by + have hden := ratFuncLinearFractional_denominator_ne_zero hdet + have hdetRat : RatFunc.C (a * d - b * c) ≠ (0 : RatFunc K) := by + simpa using RatFunc.C_injective.ne hdet + have hvalue_mul_denominator : + ratFuncLinearFractionalValue a b c d * + (RatFunc.C c * RatFunc.X + RatFunc.C d) = + RatFunc.C a * RatFunc.X + RatFunc.C b := by + rw [ratFuncLinearFractionalValue] + exact div_mul_cancel₀ _ hden + have hinverseNumerator : + RatFunc.C d * ratFuncLinearFractionalValue a b c d - RatFunc.C b = + RatFunc.C (a * d - b * c) * RatFunc.X / + (RatFunc.C c * RatFunc.X + RatFunc.C d) := by + apply (eq_div_iff hden).2 + calc + (RatFunc.C d * ratFuncLinearFractionalValue a b c d - RatFunc.C b) * + (RatFunc.C c * RatFunc.X + RatFunc.C d) = + RatFunc.C d * + (ratFuncLinearFractionalValue a b c d * + (RatFunc.C c * RatFunc.X + RatFunc.C d)) - + RatFunc.C b * (RatFunc.C c * RatFunc.X + RatFunc.C d) := by ring + _ = RatFunc.C (a * d - b * c) * RatFunc.X := by + rw [hvalue_mul_denominator] + simp only [map_sub, map_mul] + ring + have hinverseDenominator : + RatFunc.C a - RatFunc.C c * ratFuncLinearFractionalValue a b c d = + RatFunc.C (a * d - b * c) / + (RatFunc.C c * RatFunc.X + RatFunc.C d) := by + apply (eq_div_iff hden).2 + calc + (RatFunc.C a - RatFunc.C c * ratFuncLinearFractionalValue a b c d) * + (RatFunc.C c * RatFunc.X + RatFunc.C d) = + RatFunc.C a * (RatFunc.C c * RatFunc.X + RatFunc.C d) - + RatFunc.C c * + (ratFuncLinearFractionalValue a b c d * + (RatFunc.C c * RatFunc.X + RatFunc.C d)) := by ring + _ = RatFunc.C (a * d - b * c) := by + rw [hvalue_mul_denominator] + simp only [map_sub, map_mul] + ring + rw [hinverseNumerator, hinverseDenominator] + rw [div_div_div_cancel_right₀ hden] + field_simp [hdetRat] + +lemma adjoin_ratFuncLinearFractionalValue_eq_top + {a b c d : K} (hdet : a * d - b * c ≠ 0) : + K⟮ratFuncLinearFractionalValue a b c d⟯ = + (⊤ : IntermediateField K (RatFunc K)) := by + apply top_unique + rw [← RatFunc.adjoin_X] + apply IntermediateField.adjoin_simple_le_iff.mpr + rw [ratFuncLinearFractionalValue_inverse_formula hdet] + exact div_mem + (sub_mem + (mul_mem (IntermediateField.algebraMap_mem _ d) + (IntermediateField.mem_adjoin_simple_self K + (ratFuncLinearFractionalValue a b c d))) + (IntermediateField.algebraMap_mem _ b)) + (sub_mem + (IntermediateField.algebraMap_mem _ a) + (mul_mem (IntermediateField.algebraMap_mem _ c) + (IntermediateField.mem_adjoin_simple_self K + (ratFuncLinearFractionalValue a b c d)))) + +/-- The `K`-algebra automorphism of `K(X)` induced by the invertible matrix +`((a, b), (c, d))`. -/ +def ratFuncLinearFractionalEquiv + (a b c d : K) (hdet : a * d - b * c ≠ 0) : + RatFunc K ≃ₐ[K] RatFunc K := + (RatFunc.algEquivOfTranscendental + (ratFuncLinearFractionalValue a b c d) + (ratFuncLinearFractionalValue_transcendental hdet)).trans + ((IntermediateField.equivOfEq + (adjoin_ratFuncLinearFractionalValue_eq_top hdet)).trans + IntermediateField.topEquiv) + +@[simp] +theorem ratFuncLinearFractionalEquiv_apply_X + (a b c d : K) (hdet : a * d - b * c ≠ 0) : + ratFuncLinearFractionalEquiv a b c d hdet RatFunc.X = + ratFuncLinearFractionalValue a b c d := by + simp [ratFuncLinearFractionalEquiv] + +@[simp] +theorem ratFuncLinearFractionalEquiv_apply_algebraMap + (a b c d : K) (hdet : a * d - b * c ≠ 0) (f : K[X]) : + ratFuncLinearFractionalEquiv a b c d hdet + (algebraMap K[X] (RatFunc K) f) = + Polynomial.aeval (ratFuncLinearFractionalValue a b c d) f := by + simp [ratFuncLinearFractionalEquiv] + +end + +end BGS.Algebra diff --git a/LeanPool/MarkoffModP/BGS/AlgebraicGeometry/ConstantOpenGlueData.lean b/LeanPool/MarkoffModP/BGS/AlgebraicGeometry/ConstantOpenGlueData.lean new file mode 100644 index 0000000000..5de1bae33c --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/AlgebraicGeometry/ConstantOpenGlueData.lean @@ -0,0 +1,178 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import Mathlib.AlgebraicGeometry.Gluing +public import Mathlib.CategoryTheory.Limits.Shapes.Pullback.Mono + +/-! +# Gluing schemes along one common open per chart + +This file packages a frequent special case of `Scheme.GlueData`: every off-diagonal overlap in a +chart is the same open subscheme. The triple-overlap pullbacks are therefore self-pullbacks of an +open immersion. Their projections are isomorphisms because open immersions are monomorphisms, +which makes the required pullback-level cocycle explicit. +-/ + +@[expose] public section + +open CategoryTheory CategoryTheory.Limits + +namespace BGS + +noncomputable section + +universe v + +variable {J : Type v} + +/-- The off-diagonal `GlueData'` for charts that all use one fixed open subscheme per chart. + +The transition maps are required to compose strictly. This is the exact input needed to construct +the pullback transition `t'`; no gluing conclusion is assumed as a structure field. -/ +def constantOpenGlueDataAux + (U V : J → AlgebraicGeometry.Scheme.{v}) + (f : ∀ i, V i ⟶ U i) + [∀ i, AlgebraicGeometry.IsOpenImmersion (f i)] + (t : ∀ i j, V i ⟶ V j) + (t_id : ∀ i, t i i = 𝟙 _) + (t_comp : ∀ i j k, t i j ≫ t j k = t i k) : + CategoryTheory.GlueData' AlgebraicGeometry.Scheme.{v} where + J := J + U := U + V i _ _ := V i + f i _ _ := f i + f_mono := by intros; infer_instance + f_hasPullback := by intros; infer_instance + t i j _ := t i j + t' i j _ _ _ _ := by + let : IsIso (pullback.fst (f j) (f j)) := isIso_fst_of_mono (f j) + exact pullback.fst (f i) (f i) ≫ t i j ≫ inv (pullback.fst (f j) (f j)) + t_fac i j k _ _ _ := by + rw [← fst_eq_snd_of_mono_eq (f j)] + simp + t_inv i j _ := by + rw [t_comp, t_id] + cocycle i j k _ _ _ := by + have hcycle : t i j ≫ (t j k ≫ t k i) = 𝟙 _ := by + rw [← Category.assoc, t_comp i j k, t_comp i k i, t_id] + simpa [Category.assoc] using congrArg + (fun g : V i ⟶ V i ↦ + pullback.fst (f i) (f i) ≫ g ≫ inv (pullback.fst (f i) (f i))) hcycle + +/-- Glue schemes when every chart has one common overlap and the transition maps compose +strictly. -/ +def constantOpenGlueData + (U V : J → AlgebraicGeometry.Scheme.{v}) + (f : ∀ i, V i ⟶ U i) + [∀ i, AlgebraicGeometry.IsOpenImmersion (f i)] + (t : ∀ i j, V i ⟶ V j) + (t_id : ∀ i, t i i = 𝟙 _) + (t_comp : ∀ i j k, t i j ≫ t j k = t i k) : + AlgebraicGeometry.Scheme.GlueData where + toGlueData := CategoryTheory.GlueData.ofGlueData' + (constantOpenGlueDataAux U V f t t_id t_comp) + f_open i j := by + change J at i j + have hf : AlgebraicGeometry.IsOpenImmersion (f i) := inferInstance + dsimp [CategoryTheory.GlueData.ofGlueData', CategoryTheory.GlueData'.f', + constantOpenGlueDataAux] + split_ifs with hij + · infer_instance + · change AlgebraicGeometry.IsOpenImmersion (eqToHom _ ≫ f i) + refine @AlgebraicGeometry.IsOpenImmersion.comp _ (V i) (U i) + (eqToHom _) (f i) ?_ hf + refine @AlgebraicGeometry.IsOpenImmersion.of_isIso _ _ (eqToHom _) ?_ + exact (eqToIso (ite_eq_right hij)).isIso_hom + +/-- Glue schemes whose overlap in each chart is identified with one common scheme. The transition +from chart `i` to chart `j` is induced by passing through the common target, so identity and +composition are consequences of the isomorphism laws. -/ +def constantOpenGlueDataOfCommonTarget + (U V : J → AlgebraicGeometry.Scheme.{v}) + (f : ∀ i, V i ⟶ U i) + [∀ i, AlgebraicGeometry.IsOpenImmersion (f i)] + (W : AlgebraicGeometry.Scheme.{v}) + (s : ∀ i, V i ≅ W) : + AlgebraicGeometry.Scheme.GlueData := + constantOpenGlueData U V f + (fun i j ↦ (s i).hom ≫ (s j).inv) + (fun i ↦ Iso.hom_inv_id (s i)) + (fun i j k ↦ by simp) + +/-- A compatible family of chart morphisms and a morphism of their common overlaps descends to a +morphism between the glued schemes. The square `h` is the substantive input: it states that each +chart morphism restricts to the specified common-overlap morphism. -/ +def constantOpenGlueDataOfCommonTargetMap + (U V U' V' : J → AlgebraicGeometry.Scheme.{v}) + (f : ∀ i, V i ⟶ U i) [∀ i, AlgebraicGeometry.IsOpenImmersion (f i)] + (f' : ∀ i, V' i ⟶ U' i) [∀ i, AlgebraicGeometry.IsOpenImmersion (f' i)] + (W W' : AlgebraicGeometry.Scheme.{v}) + (s : ∀ i, V i ≅ W) (s' : ∀ i, V' i ≅ W') + (g : ∀ i, U i ⟶ U' i) (q : W ⟶ W') + (h : ∀ i, f i ≫ g i = (s i).hom ≫ q ≫ (s' i).inv ≫ f' i) : + (constantOpenGlueDataOfCommonTarget U V f W s).glued ⟶ + (constantOpenGlueDataOfCommonTarget U' V' f' W' s').glued := by + let D := constantOpenGlueDataOfCommonTarget U V f W s + let E := constantOpenGlueDataOfCommonTarget U' V' f' W' s' + let inc : ∀ i : J, U' i ⟶ E.glued := fun i ↦ E.ι i + have inc_transition (i j : J) (hij : i ≠ j) : + (s' i).hom ≫ (s' j).inv ≫ f' j ≫ inc j = f' i ≫ inc i := by + have hc := E.glue_condition i j + dsimp only [E, constantOpenGlueDataOfCommonTarget, constantOpenGlueData, + CategoryTheory.GlueData.ofGlueData', CategoryTheory.GlueData'.f', + constantOpenGlueDataAux] at hc + simp only [dite_eq_right hij, dite_eq_right (Ne.symm hij)] at hc + simp at hc + exact (cancel_epi _).mp hc + fapply Multicoequalizer.desc + · exact fun i ↦ g i ≫ inc i + · rintro ⟨i, j⟩ + simp only [CategoryTheory.GlueData.diagram_fst, CategoryTheory.GlueData.diagram_snd] + change D.f i j ≫ g i ≫ inc i = + (D.t i j ≫ D.f j i) ≫ g j ≫ inc j + change J at i j + by_cases hij : i = j + · subst j + erw [D.t_id] + simp + · dsimp only [D, constantOpenGlueDataOfCommonTarget, constantOpenGlueData, + CategoryTheory.GlueData.ofGlueData', CategoryTheory.GlueData'.f', + constantOpenGlueDataAux] + simp only [dite_eq_right hij, dite_eq_right (Ne.symm hij)] + simp + congr 1 + simp only [← Category.assoc] + rw [h i] + rw [Category.assoc ((s i).hom ≫ (s j).inv) (f j) (g j)] + rw [h j] + simp only [Category.assoc, Iso.inv_hom_id_assoc] + rw [← inc_transition i j hij] + simp + +/-- The descended morphism restricts to the prescribed morphism on every chart. -/ +@[reassoc] +theorem constantOpenGlueDataOfCommonTargetMap_chart + (U V U' V' : J → AlgebraicGeometry.Scheme.{v}) + (f : ∀ i, V i ⟶ U i) [∀ i, AlgebraicGeometry.IsOpenImmersion (f i)] + (f' : ∀ i, V' i ⟶ U' i) [∀ i, AlgebraicGeometry.IsOpenImmersion (f' i)] + (W W' : AlgebraicGeometry.Scheme.{v}) + (s : ∀ i, V i ≅ W) (s' : ∀ i, V' i ≅ W') + (g : ∀ i, U i ⟶ U' i) (q : W ⟶ W') + (h : ∀ i, f i ≫ g i = (s i).hom ≫ q ≫ (s' i).inv ≫ f' i) + (i : J) : + (constantOpenGlueDataOfCommonTarget U V f W s).ι i ≫ + constantOpenGlueDataOfCommonTargetMap U V U' V' f f' W W' s s' g q h = + g i ≫ (constantOpenGlueDataOfCommonTarget U' V' f' W' s').ι i := by + dsimp [constantOpenGlueDataOfCommonTargetMap] + unfold AlgebraicGeometry.Scheme.GlueData.ι + exact Multicoequalizer.π_desc + (constantOpenGlueDataOfCommonTarget U V f W s).toGlueData.diagram _ _ _ i + +end + +end BGS diff --git a/LeanPool/MarkoffModP/BGS/AlgebraicGeometry/SpecRingEquiv.lean b/LeanPool/MarkoffModP/BGS/AlgebraicGeometry/SpecRingEquiv.lean new file mode 100644 index 0000000000..569b1148f6 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/AlgebraicGeometry/SpecRingEquiv.lean @@ -0,0 +1,74 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import Mathlib.AlgebraicGeometry.GammaSpecAdjunction + +/-! +# Concrete `Spec` isomorphisms from ring equivalences + +The concrete constructor `AlgebraicGeometry.Spec` and the functor `Scheme.Spec` have propositionally +equivalent objects, but mixing them introduces equality transports in later compositions. This +module keeps affine scheme isomorphisms in the concrete `Spec` presentation used by the project. +-/ + +@[expose] public section + +namespace BGS + +open CategoryTheory +open AlgebraicGeometry + +noncomputable section + +universe u + +variable {R S : Type u} [CommRing R] [CommRing S] + +/-- A ring equivalence induces the contravariant isomorphism of its concrete affine spectra. -/ +def specIsoOfRingEquiv (e : R ≃+* S) : + Spec (CommRingCat.of S) ≅ Spec (CommRingCat.of R) where + hom := Spec.map (CommRingCat.ofHom e.toRingHom) + inv := Spec.map (CommRingCat.ofHom e.symm.toRingHom) + hom_inv_id := by + rw [← Spec.map_comp, ← CommRingCat.ofHom_comp] + simp + inv_hom_id := by + rw [← Spec.map_comp, ← CommRingCat.ofHom_comp] + simp + +/-- Transport an equality between a two-step and a three-step ring map to the corresponding +contravariant equality of concrete affine-spectrum morphisms. -/ +theorem specMap_two_eq_three_of_comp_eq + {A B C B' C' : Type u} + [CommRing A] [CommRing B] [CommRing C] [CommRing B'] [CommRing C'] + (f : A →+* B) (g : B →+* C) + (f' : A →+* B') (g' : B' →+* C') (h' : C' →+* C) + (h : g.comp f = h'.comp (g'.comp f')) : + Spec.map (CommRingCat.ofHom g) ≫ Spec.map (CommRingCat.ofHom f) = + Spec.map (CommRingCat.ofHom h') ≫ Spec.map (CommRingCat.ofHom g') ≫ + Spec.map (CommRingCat.ofHom f') := by + rw [← Spec.map_comp, ← Spec.map_comp, ← Spec.map_comp] + rw [← CommRingCat.ofHom_comp, ← CommRingCat.ofHom_comp, + ← CommRingCat.ofHom_comp] + rw [h] + +/-- Contravariant `Spec` transports an equality between two two-step ring maps. -/ +theorem specMap_two_eq_two_of_comp_eq + {A B C B' : Type u} + [CommRing A] [CommRing B] [CommRing C] [CommRing B'] + (f : A →+* B) (g : B →+* C) (f' : A →+* B') (g' : B' →+* C) + (h : g.comp f = g'.comp f') : + Spec.map (CommRingCat.ofHom g) ≫ Spec.map (CommRingCat.ofHom f) = + Spec.map (CommRingCat.ofHom g') ≫ Spec.map (CommRingCat.ofHom f') := by + rw [← Spec.map_comp, ← Spec.map_comp] + rw [← CommRingCat.ofHom_comp, ← CommRingCat.ofHom_comp] + rw [h] + +end + +end BGS diff --git a/LeanPool/MarkoffModP/BGS/Combinatorics/DivisorExponentCoefficient.lean b/LeanPool/MarkoffModP/BGS/Combinatorics/DivisorExponentCoefficient.lean new file mode 100644 index 0000000000..43baecd263 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Combinatorics/DivisorExponentCoefficient.lean @@ -0,0 +1,145 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Combinatorics.ProductOfChainsSperner + +/-! +# Cardinality semantics of divisor-rank coefficients + +This identifies the executable coefficient recurrence used by factorization +payloads with the actual rank layers of the divisor exponent box. +-/ + +@[expose] public section + +namespace BGS.NumberTheory + +/-- One rank layer in a divisor exponent box. -/ +abbrev DivisorExponentLayer + (factors : List PrimePowerFactor) (rank : ℕ) := + {exponentVector : DivisorExponentBox factors // + divisorExponentRank factors exponentVector = rank} + +private def divisorExponentLayerConsEquiv + (factor : PrimePowerFactor) (factors : List PrimePowerFactor) + (rank : ℕ) : + DivisorExponentLayer (factor :: factors) rank ≃ + Σ exponent : Fin (min factor.exponent rank + 1), + DivisorExponentLayer factors (rank - exponent) where + toFun exponentVector := by + have hexponentLeRank : + (exponentVector.1.2 : ℕ) ≤ rank := by + have hrank := exponentVector.2 + simp only [divisorExponentRank] at hrank + omega + have hexponentLeFactor : + (exponentVector.1.2 : ℕ) ≤ factor.exponent := + Nat.le_of_lt_succ exponentVector.1.2.isLt + let exponent : Fin (min factor.exponent rank + 1) := + ⟨exponentVector.1.2, Nat.lt_succ_iff.mpr + (le_min hexponentLeFactor hexponentLeRank)⟩ + have htail : + divisorExponentRank factors exponentVector.1.1 = + rank - exponent := by + have hrank := exponentVector.2 + simp only [divisorExponentRank] at hrank + dsimp [exponent] + omega + exact ⟨exponent, ⟨exponentVector.1.1, htail⟩⟩ + invFun point := by + have hexponentLeRank : + (point.1 : ℕ) ≤ rank := + (Nat.le_of_lt_succ point.1.isLt).trans (min_le_right _ _) + let exponent : Fin (factor.exponent + 1) := + ⟨point.1, Nat.lt_succ_iff.mpr + ((Nat.le_of_lt_succ point.1.isLt).trans + (min_le_left _ _))⟩ + have hrank : + divisorExponentRank factors point.2.1 + exponent = rank := by + have htail := point.2.2 + dsimp [exponent] + omega + exact ⟨(point.2.1, exponent), by + simp only [divisorExponentRank] + exact hrank⟩ + left_inv := by + intro exponentVector + apply Subtype.ext + apply Prod.ext + · rfl + · apply Fin.ext + rfl + right_inv := by + rintro ⟨exponent, tail⟩ + apply Sigma.ext + · apply Fin.ext + rfl + · apply heq_of_eq + apply Subtype.ext + rfl + +/-- The executable recurrence is exactly the cardinality of the corresponding +rank layer of the exponent box. -/ +theorem divisorExponentLayer_card_eq_divisorRankCoefficient + (factors : List PrimePowerFactor) (rank : ℕ) : + Fintype.card (DivisorExponentLayer factors rank) = + divisorRankCoefficient factors rank := by + induction factors generalizing rank with + | nil => + cases rank with + | zero => + let : Unique (DivisorExponentLayer [] 0) := + ⟨⟨PUnit.unit, rfl⟩, fun x ↦ Subtype.ext (Subsingleton.elim (α := PUnit) _ _)⟩ + exact Fintype.card_unique + | succ rank => + change Fintype.card {v : PUnit // 0 = rank + 1} = 0 + exact Fintype.card_eq_zero_iff.mpr ⟨fun x ↦ Nat.noConfusion x.property⟩ + | cons factor factors ih => + calc + Fintype.card + (DivisorExponentLayer (factor :: factors) rank) = + Fintype.card + (Σ exponent : + Fin (min factor.exponent rank + 1), + DivisorExponentLayer factors (rank - exponent)) := + Fintype.card_congr + (divisorExponentLayerConsEquiv factor factors rank) + _ = ∑ exponent : + Fin (min factor.exponent rank + 1), + Fintype.card + (DivisorExponentLayer factors (rank - exponent)) := + Fintype.card_sigma + _ = ∑ exponent : + Fin (min factor.exponent rank + 1), + divisorRankCoefficient factors (rank - exponent) := by + apply Finset.sum_congr rfl + intro exponent hexponent + exact ih _ + _ = ∑ exponent ∈ + Finset.range (min factor.exponent rank + 1), + divisorRankCoefficient factors (rank - exponent) := by + exact + Fin.sum_univ_eq_sum_range + (fun exponent ↦ + divisorRankCoefficient factors (rank - exponent)) + (min factor.exponent rank + 1) + _ = divisorRankCoefficient (factor :: factors) rank := by + rfl + +theorem centralDivisorRankCoefficient_eq_layer_card + (factors : List PrimePowerFactor) : + centralDivisorRankCoefficient factors = + Fintype.card + (DivisorExponentLayer factors + (primePowerTotalExponent factors / 2)) := by + rw [centralDivisorRankCoefficient] + exact + (divisorExponentLayer_card_eq_divisorRankCoefficient factors + (primePowerTotalExponent factors / 2)).symm + +end BGS.NumberTheory diff --git a/LeanPool/MarkoffModP/BGS/Combinatorics/DivisorExponentSpernerBridge.lean b/LeanPool/MarkoffModP/BGS/Combinatorics/DivisorExponentSpernerBridge.lean new file mode 100644 index 0000000000..461781ea89 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Combinatorics/DivisorExponentSpernerBridge.lean @@ -0,0 +1,40 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Combinatorics.DivisorExponentCoefficient + +/-! +# The divisor-antichain central-coefficient bound + +This is the semantic bridge missing from a purely executable factorization +payload: the recomputed central coefficient really bounds every antichain in +the represented divisor exponent lattice. +-/ + +@[expose] public section + +namespace BGS.NumberTheory + +open BGS.Combinatorics + +theorem divisorExponentAntichain_card_le_centralDivisorRankCoefficient + (factors : List PrimePowerFactor) + (antichain : Finset (DivisorExponentBox factors)) + (hantichain : + IsAntichain (· ≤ ·) (antichain : Set (DivisorExponentBox factors))) : + antichain.card ≤ centralDivisorRankCoefficient factors := by + let := divisorExponentBoxFintype factors + let := divisorExponentBoxPartialOrder factors + have hcentral := + (divisorExponentBoxDecomposition factors).antichain_card_le_central_rank + antichain hantichain + rw [divisorExponentTotal_eq_primePowerTotalExponent] at hcentral + rw [centralDivisorRankCoefficient_eq_layer_card] + exact hcentral + +end BGS.NumberTheory diff --git a/LeanPool/MarkoffModP/BGS/Combinatorics/ProductOfChainsGrid.lean b/LeanPool/MarkoffModP/BGS/Combinatorics/ProductOfChainsGrid.lean new file mode 100644 index 0000000000..c014f3a6b1 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Combinatorics/ProductOfChainsGrid.lean @@ -0,0 +1,238 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import Mathlib.Tactic + +/-! +# Symmetric chains in a rectangle + +This is the explicit de Bruijn--Tengbergen--Kruyswijk rectangle decomposition +used in the product-of-chains proof. A point `(x,y)` in +`[0,m] × [0,n]` is encoded by a chain key and a position on that chain. +The decoder is inverse to the encoder, preserves rank, and is monotone along +each chain. +-/ + +@[expose] public section + +namespace BGS.Combinatorics + +/-- Key of the L-shaped symmetric chain containing `(x,y)`. -/ +def gridKey (m n x y : ℕ) : ℕ := + if m ≤ n then min y (m - x) else min x (n - y) + +/-- Position of `(x,y)` along its rectangle chain. -/ +def gridPosition (m n x y : ℕ) : ℕ := + x + y - gridKey m n x y + +/-- First coordinate of the point at position `t` on chain `k`. -/ +def gridDecodeX (m n k t : ℕ) : ℕ := + if m ≤ n then + if t ≤ m - k then t else m - k + else + if t ≤ n - k then k else t + 2 * k - n + +/-- Second coordinate of the point at position `t` on chain `k`. -/ +def gridDecodeY (m n k t : ℕ) : ℕ := + if m ≤ n then + if t ≤ m - k then k else t + 2 * k - m + else + if t ≤ n - k then t else n - k + +theorem gridKey_le_min + {m n x y : ℕ} (hx : x ≤ m) (hy : y ≤ n) : + gridKey m n x y ≤ min m n := by + by_cases hmn : m ≤ n + · rw [gridKey, ite_eq_left hmn] + apply le_min + · exact (min_le_right _ _).trans (Nat.sub_le _ _) + · exact (min_le_left _ _).trans hy + · rw [gridKey, ite_eq_right hmn] + apply le_min + · exact (min_le_left _ _).trans hx + · exact (min_le_right _ _).trans (Nat.sub_le _ _) + +theorem gridPosition_le + {m n x y : ℕ} (hx : x ≤ m) (hy : y ≤ n) : + gridPosition m n x y ≤ + m + n - 2 * gridKey m n x y := by + by_cases hmn : m ≤ n + · by_cases hshort : y ≤ m - x + · simp [gridPosition, gridKey, hmn, min_eq_left hshort] + omega + · have hreverse : m - x ≤ y := Nat.le_of_not_ge hshort + simp [gridPosition, gridKey, hmn, min_eq_right hreverse] + omega + · have hnm : n ≤ m := Nat.le_of_not_ge hmn + by_cases hshort : x ≤ n - y + · simp [gridPosition, gridKey, hmn, min_eq_left hshort] + omega + · have hreverse : n - y ≤ x := Nat.le_of_not_ge hshort + simp [gridPosition, gridKey, hmn, min_eq_right hreverse] + omega + +theorem gridDecodeX_le + {m n k t : ℕ} (hk : k ≤ min m n) + (ht : t ≤ m + n - 2 * k) : + gridDecodeX m n k t ≤ m := by + have hkm : k ≤ m := hk.trans (min_le_left _ _) + have hkn : k ≤ n := hk.trans (min_le_right _ _) + by_cases hmn : m ≤ n + · by_cases hpos : t ≤ m - k + · simp [gridDecodeX, hmn, hpos] + omega + · simp [gridDecodeX, hmn, hpos] + · by_cases hpos : t ≤ n - k + · simp [gridDecodeX, hmn, hpos] + omega + · simp [gridDecodeX, hmn, hpos] + omega + +theorem gridDecodeY_le + {m n k t : ℕ} (hk : k ≤ min m n) + (ht : t ≤ m + n - 2 * k) : + gridDecodeY m n k t ≤ n := by + have hkm : k ≤ m := hk.trans (min_le_left _ _) + have hkn : k ≤ n := hk.trans (min_le_right _ _) + by_cases hmn : m ≤ n + · by_cases hpos : t ≤ m - k + · simp [gridDecodeY, hmn, hpos] + omega + · simp [gridDecodeY, hmn, hpos] + omega + · by_cases hpos : t ≤ n - k + · simp [gridDecodeY, hmn, hpos] + omega + · simp [gridDecodeY, hmn, hpos] + +theorem gridKey_decode + {m n k t : ℕ} (hk : k ≤ min m n) + (_ht : t ≤ m + n - 2 * k) : + gridKey m n (gridDecodeX m n k t) + (gridDecodeY m n k t) = k := by + have hkm : k ≤ m := hk.trans (min_le_left _ _) + have hkn : k ≤ n := hk.trans (min_le_right _ _) + by_cases hmn : m ≤ n + · by_cases hpos : t ≤ m - k + · have hkSub : k ≤ m - t := by omega + simp [gridKey, gridDecodeX, gridDecodeY, hmn, hpos, + min_eq_left hkSub] + · have hkY : k ≤ t + 2 * k - m := by omega + simp [gridKey, gridDecodeX, gridDecodeY, hmn, hpos, + Nat.sub_sub_self hkm, min_eq_right hkY] + · by_cases hpos : t ≤ n - k + · have hkSub : k ≤ n - t := by omega + simp [gridKey, gridDecodeX, gridDecodeY, hmn, hpos, + min_eq_left hkSub] + · have hkX : k ≤ t + 2 * k - n := by omega + simp [gridKey, gridDecodeX, gridDecodeY, hmn, hpos, + Nat.sub_sub_self hkn, min_eq_right hkX] + +theorem gridDecode_rank + {m n k t : ℕ} (hk : k ≤ min m n) + (_ht : t ≤ m + n - 2 * k) : + gridDecodeX m n k t + gridDecodeY m n k t = k + t := by + have hkm : k ≤ m := hk.trans (min_le_left _ _) + have hkn : k ≤ n := hk.trans (min_le_right _ _) + by_cases hmn : m ≤ n + · by_cases hpos : t ≤ m - k + · simp [gridDecodeX, gridDecodeY, hmn, hpos] + omega + · simp [gridDecodeX, gridDecodeY, hmn, hpos] + omega + · by_cases hpos : t ≤ n - k + · simp [gridDecodeX, gridDecodeY, hmn, hpos] + · simp [gridDecodeX, gridDecodeY, hmn, hpos] + omega + +theorem gridPosition_decode + {m n k t : ℕ} (hk : k ≤ min m n) + (ht : t ≤ m + n - 2 * k) : + gridPosition m n (gridDecodeX m n k t) + (gridDecodeY m n k t) = t := by + rw [gridPosition, gridKey_decode hk ht, gridDecode_rank hk ht] + omega + +theorem gridDecode_encode_x + {m n x y : ℕ} (hx : x ≤ m) (hy : y ≤ n) : + gridDecodeX m n (gridKey m n x y) + (gridPosition m n x y) = x := by + by_cases hmn : m ≤ n + · by_cases hshort : y ≤ m - x + · have hdecode : x ≤ m - y := by omega + simp [gridDecodeX, gridPosition, gridKey, hmn, + min_eq_left hshort, hdecode] + · have hreverse : m - x ≤ y := Nat.le_of_not_ge hshort + have hdecode : + ¬x + y - (m - x) ≤ m - (m - x) := by + rw [Nat.sub_sub_self hx] + omega + simp [gridDecodeX, gridPosition, gridKey, hmn, hshort, + min_eq_right hreverse, Nat.sub_sub_self hx] + · by_cases hshort : x ≤ n - y + · have hdecode : y ≤ n - x := by omega + simp [gridDecodeX, gridPosition, gridKey, hmn, + min_eq_left hshort, hdecode] + · have hreverse : n - y ≤ x := Nat.le_of_not_ge hshort + have hdecode : + ¬x + y - (n - y) ≤ n - (n - y) := by + rw [Nat.sub_sub_self hy] + omega + have hsum : ¬x + y ≤ y + (n - y) := by omega + simp [gridDecodeX, gridPosition, gridKey, hmn, + min_eq_right hreverse, hsum, Nat.sub_sub_self hy] + omega + +theorem gridDecode_encode_y + {m n x y : ℕ} (hx : x ≤ m) (hy : y ≤ n) : + gridDecodeY m n (gridKey m n x y) + (gridPosition m n x y) = y := by + by_cases hmn : m ≤ n + · by_cases hshort : y ≤ m - x + · have hdecode : x ≤ m - y := by omega + simp [gridDecodeY, gridPosition, gridKey, hmn, + min_eq_left hshort, hdecode] + · have hreverse : m - x ≤ y := Nat.le_of_not_ge hshort + have hdecode : + ¬x + y - (m - x) ≤ m - (m - x) := by + rw [Nat.sub_sub_self hx] + omega + simp [gridDecodeY, gridPosition, gridKey, hmn, hshort, + min_eq_right hreverse, Nat.sub_sub_self hx] + omega + · by_cases hshort : x ≤ n - y + · have hdecode : y ≤ n - x := by omega + simp [gridDecodeY, gridPosition, gridKey, hmn, + min_eq_left hshort, hdecode] + · have hreverse : n - y ≤ x := Nat.le_of_not_ge hshort + have hdecode : + ¬x + y - (n - y) ≤ n - (n - y) := by + rw [Nat.sub_sub_self hy] + omega + simp [gridDecodeY, gridPosition, gridKey, hmn, + min_eq_right hreverse, Nat.sub_sub_self hy] + omega + +theorem gridDecode_mono + {m n k t₁ t₂ : ℕ} (_hk : k ≤ min m n) + (_ht₁ : t₁ ≤ m + n - 2 * k) + (_ht₂ : t₂ ≤ m + n - 2 * k) + (h : t₁ ≤ t₂) : + gridDecodeX m n k t₁ ≤ gridDecodeX m n k t₂ ∧ + gridDecodeY m n k t₁ ≤ gridDecodeY m n k t₂ := by + by_cases hmn : m ≤ n + · by_cases hpos₁ : t₁ ≤ m - k <;> + by_cases hpos₂ : t₂ ≤ m - k <;> + simp [gridDecodeX, gridDecodeY, hmn, hpos₁, hpos₂] <;> + omega + · by_cases hpos₁ : t₁ ≤ n - k <;> + by_cases hpos₂ : t₂ ≤ n - k <;> + simp [gridDecodeX, gridDecodeY, hmn, hpos₁, hpos₂] <;> + omega + +end BGS.Combinatorics diff --git a/LeanPool/MarkoffModP/BGS/Combinatorics/ProductOfChainsSperner.lean b/LeanPool/MarkoffModP/BGS/Combinatorics/ProductOfChainsSperner.lean new file mode 100644 index 0000000000..b8583c3931 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Combinatorics/ProductOfChainsSperner.lean @@ -0,0 +1,92 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Combinatorics.SymmetricChainProduct +public import LeanPool.MarkoffModP.BGS.NumberTheory.PrimePowerFactorization + +/-! +# Sperner bounds for divisor exponent boxes + +The divisor lattice attached to prime-power exponents is a product of finite +chains. The explicit symmetric-chain product construction therefore bounds +every antichain by the central coefficient of +`∏ (1 + X + ... + X^e)`. +-/ + +@[expose] public section + +namespace BGS.NumberTheory + +open BGS.Combinatorics + +/-- Exponent vectors, ordered tail-first to match the product constructor. -/ +def DivisorExponentBox : List PrimePowerFactor → Type + | [] => PUnit + | factor :: factors => + DivisorExponentBox factors × Fin (factor.exponent + 1) + +instance divisorExponentBoxFintype : + ∀ factors : List PrimePowerFactor, Fintype (DivisorExponentBox factors) + | [] => by + change Fintype PUnit + infer_instance + | _ :: factors => by + letI := divisorExponentBoxFintype factors + unfold DivisorExponentBox + infer_instance + +instance divisorExponentBoxPartialOrder : + ∀ factors : List PrimePowerFactor, + PartialOrder (DivisorExponentBox factors) + | [] => by + change PartialOrder PUnit + infer_instance + | _ :: factors => by + letI := divisorExponentBoxPartialOrder factors + unfold DivisorExponentBox + infer_instance + +/-- Sum of the chosen prime-power exponents. -/ +def divisorExponentRank : + ∀ factors : List PrimePowerFactor, DivisorExponentBox factors → ℕ + | [], _ => 0 + | _ :: factors, exponentVector => + divisorExponentRank factors exponentVector.1 + exponentVector.2 + +/-- Top rank in the tail-first recursion used by the decomposition. -/ +def divisorExponentTotal : List PrimePowerFactor → ℕ + | [] => 0 + | factor :: factors => + divisorExponentTotal factors + factor.exponent + +theorem divisorExponentTotal_eq_primePowerTotalExponent + (factors : List PrimePowerFactor) : + divisorExponentTotal factors = primePowerTotalExponent factors := by + induction factors with + | nil => rfl + | cons factor factors ih => + simp only [divisorExponentTotal, primePowerTotalExponent, ih] + omega + +/-- Explicit symmetric-chain decomposition of every divisor exponent box. -/ +def divisorExponentBoxDecomposition : + ∀ factors : List PrimePowerFactor, + SymmetricChainDecomposition + (DivisorExponentBox factors) + (divisorExponentRank factors) + (divisorExponentTotal factors) + | [] => by + change SymmetricChainDecomposition PUnit (fun _ ↦ 0) 0 + exact SymmetricChainDecomposition.punit + | factor :: factors => by + letI := divisorExponentBoxPartialOrder factors + exact + (divisorExponentBoxDecomposition factors).productWithChain + factor.exponent + +end BGS.NumberTheory diff --git a/LeanPool/MarkoffModP/BGS/Combinatorics/SymmetricChainBasic.lean b/LeanPool/MarkoffModP/BGS/Combinatorics/SymmetricChainBasic.lean new file mode 100644 index 0000000000..f059c265eb --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Combinatorics/SymmetricChainBasic.lean @@ -0,0 +1,160 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import Mathlib.Data.Fintype.Card +public import Mathlib.Order.Antichain +public import Mathlib.Tactic + +/-! +# Finite symmetric-chain decompositions + +The structure below packages an explicit partition into monotone chains. +Each chain is indexed by a finite key type, starts at a declared rank, and +has a declared length symmetric about `total / 2`. + +The main abstract consequence is the Sperner injection: an antichain meets +each chain at most once, so mapping every point to the central point of its +chain injects the antichain into the central rank. +-/ + +@[expose] public section + +namespace BGS.Combinatorics + +/-- An explicit symmetric-chain decomposition of a ranked partial order. -/ +structure SymmetricChainDecomposition + (P : Type*) [PartialOrder P] (rank : P → ℕ) (total : ℕ) where + Key : Type + [keyFintype : Fintype Key] + start : Key → ℕ + length : Key → ℕ + equiv : P ≃ Σ key : Key, Fin (length key + 1) + rank_decode : + ∀ point : Σ key : Key, Fin (length key + 1), + rank (equiv.symm point) = start point.1 + point.2 + decode_mono : + ∀ (key : Key) (i j : Fin (length key + 1)), + i ≤ j → + equiv.symm ⟨key, i⟩ ≤ equiv.symm ⟨key, j⟩ + symmetric : ∀ key : Key, 2 * start key + length key = total + +namespace SymmetricChainDecomposition + +variable {P : Type*} [PartialOrder P] {rank : P → ℕ} {total : ℕ} + +/-- The first component of the chain code of a point. -/ +def key (decomposition : SymmetricChainDecomposition P rank total) + (x : P) : decomposition.Key := + (decomposition.equiv x).1 + +/-- The position component of the chain code of a point. -/ +def position (decomposition : SymmetricChainDecomposition P rank total) + (x : P) : Fin (decomposition.length (decomposition.key x) + 1) := + (decomposition.equiv x).2 + +theorem start_le_half + (decomposition : SymmetricChainDecomposition P rank total) + (key : decomposition.Key) : + decomposition.start key ≤ total / 2 := by + have hsymmetric := decomposition.symmetric key + omega + +theorem half_sub_start_le_length + (decomposition : SymmetricChainDecomposition P rank total) + (key : decomposition.Key) : + total / 2 - decomposition.start key ≤ decomposition.length key := by + have hsymmetric := decomposition.symmetric key + omega + +/-- The unique point of a symmetric chain in the central rank. -/ +def center + (decomposition : SymmetricChainDecomposition P rank total) + (key : decomposition.Key) : P := + decomposition.equiv.symm + ⟨key, + ⟨total / 2 - decomposition.start key, + Nat.lt_succ_iff.mpr + (decomposition.half_sub_start_le_length key)⟩⟩ + +theorem rank_center + (decomposition : SymmetricChainDecomposition P rank total) + (key : decomposition.Key) : + rank (decomposition.center key) = total / 2 := by + rw [center, decomposition.rank_decode] + exact Nat.add_sub_of_le (decomposition.start_le_half key) + +private theorem key_injective_on_antichain + [Fintype P] + (decomposition : SymmetricChainDecomposition P rank total) + (antichain : Finset P) + (hantichain : IsAntichain (· ≤ ·) (antichain : Set P)) : + Function.Injective + (fun x : ↥antichain ↦ decomposition.key x.1) := by + intro x y hkey + apply Subtype.ext + rcases hxcode : decomposition.equiv x.1 with ⟨kx, ix⟩ + rcases hycode : decomposition.equiv y.1 with ⟨ky, iy⟩ + have hkey' : kx = ky := by + simpa [key, hxcode, hycode] using hkey + subst ky + rcases le_total ix iy with hxy | hyx + · have hle : x.1 ≤ y.1 := by + have hdecode := + decomposition.decode_mono kx ix iy hxy + have hxback : decomposition.equiv.symm ⟨kx, ix⟩ = x.1 := by + apply decomposition.equiv.injective + simp [hxcode] + have hyback : decomposition.equiv.symm ⟨kx, iy⟩ = y.1 := by + apply decomposition.equiv.injective + simp [hycode] + simpa [hxback, hyback] using hdecode + by_contra hne + exact + (hantichain (by simp) + (by simp) hne) hle + · have hle : y.1 ≤ x.1 := by + have hdecode := + decomposition.decode_mono kx iy ix hyx + have hxback : decomposition.equiv.symm ⟨kx, ix⟩ = x.1 := by + apply decomposition.equiv.injective + simp [hxcode] + have hyback : decomposition.equiv.symm ⟨kx, iy⟩ = y.1 := by + apply decomposition.equiv.injective + simp [hycode] + simpa [hxback, hyback] using hdecode + by_contra hne + exact + (hantichain (by simp) + (by simp) (Ne.symm hne)) hle + +/-- Every antichain injects into the central rank of a finite ranked poset +equipped with an explicit symmetric-chain decomposition. -/ +theorem antichain_card_le_central_rank + [Fintype P] + (decomposition : SymmetricChainDecomposition P rank total) + (antichain : Finset P) + (hantichain : IsAntichain (· ≤ ·) (antichain : Set P)) : + antichain.card ≤ + Fintype.card {x : P // rank x = total / 2} := by + classical + let centerMap : ↥antichain → {x : P // rank x = total / 2} := + fun x ↦ + ⟨decomposition.center (decomposition.key x.1), + decomposition.rank_center (decomposition.key x.1)⟩ + have hkeyInjective := + decomposition.key_injective_on_antichain antichain hantichain + have hcenterInjective : Function.Injective centerMap := by + intro x y hcenter + apply hkeyInjective + have hcode := congrArg decomposition.equiv (congrArg Subtype.val hcenter) + simpa [centerMap, center] using congrArg Sigma.fst hcode + simpa using Fintype.card_le_of_injective centerMap hcenterInjective + +end SymmetricChainDecomposition + +end BGS.Combinatorics diff --git a/LeanPool/MarkoffModP/BGS/Combinatorics/SymmetricChainProduct.lean b/LeanPool/MarkoffModP/BGS/Combinatorics/SymmetricChainProduct.lean new file mode 100644 index 0000000000..5144b33142 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Combinatorics/SymmetricChainProduct.lean @@ -0,0 +1,190 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Combinatorics.SymmetricChainBasic +public import LeanPool.MarkoffModP.BGS.Combinatorics.SymmetricChainRectangle + +/-! +# Products of symmetric-chain decompositions + +The product with one more finite chain is obtained by composing four standard +equivalences: the old chain code, sigma-product distribution, the explicit +rectangle decomposition on each old chain, and sigma associativity. +-/ + +@[expose] public section + +namespace BGS.Combinatorics + +namespace SymmetricChainDecomposition + +variable {P : Type*} [PartialOrder P] {rank : P → ℕ} {total : ℕ} + +abbrev productKey + (decomposition : SymmetricChainDecomposition P rank total) + (a : ℕ) : Type := + Σ key : decomposition.Key, + gridChainKey (decomposition.length key) a + +instance productKeyFintype + (decomposition : SymmetricChainDecomposition P rank total) + (a : ℕ) : + Fintype (decomposition.productKey a) := by + letI : Fintype decomposition.Key := decomposition.keyFintype + unfold productKey + infer_instance + +abbrev productLength + (decomposition : SymmetricChainDecomposition P rank total) + (a : ℕ) (key : decomposition.productKey a) : ℕ := + gridChainLength (decomposition.length key.1) a key.2 + +def productStart + (decomposition : SymmetricChainDecomposition P rank total) + (key : decomposition.productKey a) : ℕ := + decomposition.start key.1 + key.2 + +/-- Reindex a product with a finite chain by its rectangular symmetric chains. -/ +def productEquiv + (decomposition : SymmetricChainDecomposition P rank total) + (a : ℕ) : + P × Fin (a + 1) ≃ + Σ key : decomposition.productKey a, + Fin (decomposition.productLength a key + 1) := + (((Equiv.prodCongr decomposition.equiv (Equiv.refl (Fin (a + 1)))).trans + (Equiv.sigmaProdDistrib + (fun key : decomposition.Key ↦ + Fin (decomposition.length key + 1)) + (Fin (a + 1)))).trans + (Equiv.sigmaCongrRight + (fun key : decomposition.Key ↦ + gridChainEquiv (decomposition.length key) a))).trans + (Equiv.sigmaAssoc + (fun (key : decomposition.Key) + (rectangleKey : + gridChainKey (decomposition.length key) a) ↦ + Fin (gridChainLength + (decomposition.length key) a rectangleKey + 1))).symm + +def productWithChain + (decomposition : SymmetricChainDecomposition P rank total) + (a : ℕ) : + SymmetricChainDecomposition + (P × Fin (a + 1)) + (fun x ↦ rank x.1 + x.2) + (total + a) where + Key := decomposition.productKey a + start := decomposition.productStart + length := decomposition.productLength a + equiv := decomposition.productEquiv a + rank_decode := by + rintro ⟨⟨key, rectangleKey⟩, rectanglePosition⟩ + have hkey : + (rectangleKey : ℕ) ≤ min (decomposition.length key) a := + Nat.le_of_lt_succ rectangleKey.isLt + have hposition : + (rectanglePosition : ℕ) ≤ + decomposition.length key + a - 2 * rectangleKey := + Nat.le_of_lt_succ rectanglePosition.isLt + let oldPosition : Fin (decomposition.length key + 1) := + ⟨gridDecodeX (decomposition.length key) a + rectangleKey rectanglePosition, + Nat.lt_succ_iff.mpr + (gridDecodeX_le hkey hposition)⟩ + let newPosition : Fin (a + 1) := + ⟨gridDecodeY (decomposition.length key) a + rectangleKey rectanglePosition, + Nat.lt_succ_iff.mpr + (gridDecodeY_le hkey hposition)⟩ + have holdRank := + decomposition.rank_decode ⟨key, oldPosition⟩ + have hgrid := gridDecode_rank hkey hposition + change + rank (decomposition.equiv.symm ⟨key, oldPosition⟩) + + newPosition = + decomposition.start key + rectangleKey + rectanglePosition + rw [holdRank] + dsimp [oldPosition, newPosition] + omega + decode_mono := by + intro productKey i j hij + rcases productKey with ⟨key, rectangleKey⟩ + have hkey : + (rectangleKey : ℕ) ≤ min (decomposition.length key) a := + Nat.le_of_lt_succ rectangleKey.isLt + have hi : + (i : ℕ) ≤ decomposition.length key + a - 2 * rectangleKey := + Nat.le_of_lt_succ i.isLt + have hj : + (j : ℕ) ≤ decomposition.length key + a - 2 * rectangleKey := + Nat.le_of_lt_succ j.isLt + have hgrid := gridDecode_mono hkey hi hj hij + change + (decomposition.equiv.symm + ⟨key, + ⟨gridDecodeX (decomposition.length key) a rectangleKey i, + Nat.lt_succ_iff.mpr (gridDecodeX_le hkey hi)⟩⟩, + (⟨gridDecodeY (decomposition.length key) a rectangleKey i, + Nat.lt_succ_iff.mpr (gridDecodeY_le hkey hi)⟩ : Fin (a + 1))) ≤ + (decomposition.equiv.symm + ⟨key, + ⟨gridDecodeX (decomposition.length key) a rectangleKey j, + Nat.lt_succ_iff.mpr (gridDecodeX_le hkey hj)⟩⟩, + (⟨gridDecodeY (decomposition.length key) a rectangleKey j, + Nat.lt_succ_iff.mpr (gridDecodeY_le hkey hj)⟩ : Fin (a + 1))) + constructor + · exact decomposition.decode_mono key + ⟨gridDecodeX (decomposition.length key) a rectangleKey i, + Nat.lt_succ_iff.mpr (gridDecodeX_le hkey hi)⟩ + ⟨gridDecodeX (decomposition.length key) a rectangleKey j, + Nat.lt_succ_iff.mpr (gridDecodeX_le hkey hj)⟩ + hgrid.1 + · exact hgrid.2 + symmetric := by + rintro ⟨key, rectangleKey⟩ + have hkey : + (rectangleKey : ℕ) ≤ min (decomposition.length key) a := + Nat.le_of_lt_succ rectangleKey.isLt + have hleft : (rectangleKey : ℕ) ≤ decomposition.length key := + hkey.trans (min_le_left _ _) + have hright : (rectangleKey : ℕ) ≤ a := + hkey.trans (min_le_right _ _) + have hold := decomposition.symmetric key + dsimp [productStart, productLength, gridChainLength] + omega + +def punit : + SymmetricChainDecomposition PUnit (fun _ ↦ 0) 0 where + Key := PUnit + start := fun _ ↦ 0 + length := fun _ ↦ 0 + equiv := + { toFun := fun _ ↦ ⟨PUnit.unit, ⟨0, by omega⟩⟩ + invFun := fun _ ↦ PUnit.unit + left_inv := by intro x; cases x; rfl + right_inv := by + rintro ⟨key, position⟩ + cases key + apply Sigma.ext + · rfl + · apply heq_of_eq + apply Fin.ext + omega } + rank_decode := by + rintro ⟨key, position⟩ + simp + decode_mono := by + intro key i j hij + trivial + symmetric := by + intro key + rfl + +end SymmetricChainDecomposition + +end BGS.Combinatorics diff --git a/LeanPool/MarkoffModP/BGS/Combinatorics/SymmetricChainRectangle.lean b/LeanPool/MarkoffModP/BGS/Combinatorics/SymmetricChainRectangle.lean new file mode 100644 index 0000000000..74b33f2103 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Combinatorics/SymmetricChainRectangle.lean @@ -0,0 +1,99 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Combinatorics.ProductOfChainsGrid + +/-! +# The rectangle symmetric-chain equivalence + +This packages the explicit rectangle codec as an equivalence. Keeping this +finite, self-contained transport boundary separate lets product decompositions +be assembled from standard equivalence combinators. +-/ + +@[expose] public section + +namespace BGS.Combinatorics + +abbrev gridChainKey (m n : ℕ) := + Fin (min m n + 1) + +abbrev gridChainLength (m n : ℕ) (key : gridChainKey m n) := + m + n - 2 * key + +/-- Encode a point of a finite rectangle by its symmetric chain and position. -/ +def gridChainEncode (m n : ℕ) + (point : Fin (m + 1) × Fin (n + 1)) : + Σ key : gridChainKey m n, Fin (gridChainLength m n key + 1) := by + have hx : (point.1 : ℕ) ≤ m := + Nat.le_of_lt_succ point.1.isLt + have hy : (point.2 : ℕ) ≤ n := + Nat.le_of_lt_succ point.2.isLt + let key := gridKey m n point.1 point.2 + let position := gridPosition m n point.1 point.2 + exact + ⟨⟨key, Nat.lt_succ_iff.mpr (gridKey_le_min hx hy)⟩, + ⟨position, Nat.lt_succ_iff.mpr (gridPosition_le hx hy)⟩⟩ + +/-- Recover a point of a finite rectangle from its symmetric chain and position. -/ +def gridChainDecode (m n : ℕ) + (point : + Σ key : gridChainKey m n, Fin (gridChainLength m n key + 1)) : + Fin (m + 1) × Fin (n + 1) := by + have hkey : (point.1 : ℕ) ≤ min m n := + Nat.le_of_lt_succ point.1.isLt + have hposition : + (point.2 : ℕ) ≤ m + n - 2 * point.1 := + Nat.le_of_lt_succ point.2.isLt + exact + (⟨gridDecodeX m n point.1 point.2, + Nat.lt_succ_iff.mpr (gridDecodeX_le hkey hposition)⟩, + ⟨gridDecodeY m n point.1 point.2, + Nat.lt_succ_iff.mpr (gridDecodeY_le hkey hposition)⟩) + +private theorem gridChainDecode_encode (m n : ℕ) + (point : Fin (m + 1) × Fin (n + 1)) : + gridChainDecode m n (gridChainEncode m n point) = point := by + have hx : (point.1 : ℕ) ≤ m := + Nat.le_of_lt_succ point.1.isLt + have hy : (point.2 : ℕ) ≤ n := + Nat.le_of_lt_succ point.2.isLt + apply Prod.ext + · apply Fin.ext + exact gridDecode_encode_x hx hy + · apply Fin.ext + exact gridDecode_encode_y hx hy + +private theorem gridChainEncode_decode (m n : ℕ) + (point : + Σ key : gridChainKey m n, Fin (gridChainLength m n key + 1)) : + gridChainEncode m n (gridChainDecode m n point) = point := by + rcases point with ⟨key, position⟩ + have hkey : (key : ℕ) ≤ min m n := + Nat.le_of_lt_succ key.isLt + have hposition : (position : ℕ) ≤ m + n - 2 * key := + Nat.le_of_lt_succ position.isLt + have hencodedKey : + (gridChainEncode m n (gridChainDecode m n ⟨key, position⟩)).1 = key := by + apply Fin.ext + exact gridKey_decode hkey hposition + refine Sigma.ext hencodedKey ?_ + apply (Fin.heq_ext_iff + (congrArg (fun k ↦ gridChainLength m n k + 1) hencodedKey)).2 + exact gridPosition_decode hkey hposition + +/-- The explicit symmetric-chain decomposition of a rectangle. -/ +def gridChainEquiv (m n : ℕ) : + Fin (m + 1) × Fin (n + 1) ≃ + Σ key : gridChainKey m n, Fin (gridChainLength m n key + 1) where + toFun := gridChainEncode m n + invFun := gridChainDecode m n + left_inv := by exact gridChainDecode_encode m n + right_inv := by exact gridChainEncode_decode m n + +end BGS.Combinatorics diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier.lean new file mode 100644 index 0000000000..00d1d45345 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier.lean @@ -0,0 +1,99 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.AuxiliaryFamily +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.AbsoluteIrreducibilityBaseChange +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.BivariateResultant +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.BivariateGauss +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FrobeniusSubfield +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteFunctionFieldDegree +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionProductFormula +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.DedekindPlaceOrder +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.DedekindLeadingTermCancellation +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.DedekindLocalWronskian +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.DedekindAuxiliaryWronskian +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.DedekindAuxiliaryLocalCases +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.DedekindAuxiliaryCaseI +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.DedekindPerfectResidueCaseI +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.DedekindLocalDerivationExtension +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.DedekindDifferentDivisor +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.DedekindCanonicalDifferentScaling +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.DedekindLocalizationDerivationPreservation +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionCanonicalWronskian +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionCanonicalGlobalGcdBound +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionCanonicalGlobalNormalized +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionCanonicalGlobalNormalizedAutomatic +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.InfinityPlace +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.InfinityInertiaDegree +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionExhaustiveProductFormula +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionPrincipalDivisor +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionPositiveDegreePower +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionExceptionalSupport +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionExceptionalPlaceBounds +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionResidueSurjectivity +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionPolynomialHeight +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FinitePlaceCompletion +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.ElementaryFiniteFieldBound +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FrobeniusWronskian +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FunctionFieldProductFormula +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.RatFuncExhaustiveProductFormula +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.LaurentFrobeniusBasis +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.LaurentFrobeniusPowerBasis +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.CompletionLinearDisjointness +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.LocalDerivative +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.LocalWronskian +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.LocalAuxiliaryWronskian +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.LocalAuxiliaryCaseI +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PerfectConstants +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveFunctionField +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveBidegreeBridge +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveDiscriminantBound +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveInfinityDifferentDegree +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveInfinityComplement +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.LocalReciprocalDiscriminant +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveLocalReciprocalDiscriminant +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveAuxiliaryFinitePlace +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveAuxiliaryFinitePlaceCases +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveAuxiliaryFinitePlacePrincipalDivisor +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionCanonicalAuxiliaryFinitePlace +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionCanonicalAuxiliaryFinitePlaceNormalized +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionCanonicalPlacewiseScaling +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveRatFuncModel +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveCoordinatePowerHeight +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurvePoweredHeightBounds +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveCanonicalEulerBound +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveCharacteristicCardinality +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveSeparability +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.SeparatingCoordinateNotFrobenius +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveAuxiliaryIndependence +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PoweredCoordinates +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PoweredCoordinateRelation +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PoweredImageCurve +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.TranscendentalPowerDegree +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurvePoweredImageDegreeBudget +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurvePropositionTwoAssembly +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurvePropositionTwoGeometric +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PoweredImageFrobeniusRelation +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PoweredImageFrobeniusRelationSwapped +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PoweredImageBaseChange +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.TorusCharacterKernelBound +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveDiagonalStabilizer +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.TorsionPointNormalization +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.TorsionGcdDivisorBound +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.TorsionExhaustiveGcdDivisorBound +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveExhaustiveGcdEndpoint +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.TorsionBidegreeCount +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.WronskianChangeParameter +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.NumericalOptimization +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.ParameterizedBound +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.NumericalCorollary +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.GlobalWronskianSummation +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.GlobalWronskianPlaceSum +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.GlobalWronskianWeightedPlaceSum +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.EndpointComposition +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.GeneralCorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/AbsoluteIrreducibilityBaseChange.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/AbsoluteIrreducibilityBaseChange.lean new file mode 100644 index 0000000000..2c7b6862ec --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/AbsoluteIrreducibilityBaseChange.lean @@ -0,0 +1,289 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PerfectConstants +public import Mathlib.Algebra.MvPolynomial.Nilpotent +public import Mathlib.FieldTheory.IsAlgClosed.AlgebraicClosure +public import Mathlib.RingTheory.Nullstellensatz + +/-! +# Base change of absolutely irreducible multivariate polynomials + +An irreducible multivariate polynomial over an algebraic closure remains +irreducible after extending its original coefficient field to an arbitrary +field. The proof is a direct Nullstellensatz descent. Given a hypothetical +factorization over the target field, introduce one variable for each of its +finitely many coefficients and two additional variables for inverses of +chosen nonconstant coefficients. A closed point of a maximal ideal over the +kernel specializes the factorization to the algebraically closed field, while +the inverse relations ensure that both specialized factors remain nonunits. + +The final theorem supplies the exact constant-field base-change step used in +Corvaja--Zannier's auxiliary-family argument. +-/ + +@[expose] public section + +open scoped BigOperators + +noncomputable section + +namespace BGS.CorvajaZannier + +open MvPolynomial + +variable {K E F σ : Type*} [Field K] [Field E] [Field F] + [Algebra K E] [IsAlgClosed E] + +private theorem exists_nonconstant_coeff_of_nonzero_nonunit + (g : MvPolynomial σ F) (hg0 : g ≠ 0) (hgu : ¬ IsUnit g) : + ∃ m, m ≠ 0 ∧ g.coeff m ≠ 0 := by + classical + by_contra h + have h : ∀ m, m ≠ 0 → g.coeff m = 0 := by + intro m hm + by_contra hcoeff + exact h ⟨m, hm, hcoeff⟩ + have heq : g = MvPolynomial.C (g.coeff 0) := by + ext m + by_cases hm : m = 0 + · subst m + simp + · simpa [MvPolynomial.coeff_C, Ne.symm hm] using h m hm + have hc : g.coeff 0 ≠ 0 := by + intro hc + apply hg0 + rw [heq, hc] + simp + apply hgu + rw [heq] + exact (isUnit_iff_ne_zero.mpr hc).map MvPolynomial.C + +/-- If a multivariate polynomial is irreducible after extension to an +algebraically closed field, it remains irreducible after any other injective +field extension of its original coefficient field. -/ +theorem irreducible_map_of_irreducible_map_isAlgClosed + (iF : K →+* F) (f : MvPolynomial σ K) + (hE : Irreducible (MvPolynomial.map (algebraMap K E) f)) : + Irreducible (MvPolynomial.map iF f) := by + refine ⟨?_, ?_⟩ + · intro hu + have huE : IsUnit (MvPolynomial.map (algebraMap K E) f) := by + rw [MvPolynomial.isUnit_iff] + constructor + · have h0 := (MvPolynomial.isUnit_iff.mp hu).1 + rw [MvPolynomial.coeff_map] at h0 ⊢ + rw [isUnit_iff_ne_zero] at h0 ⊢ + intro hcE + have hc : f.coeff 0 = 0 := + (algebraMap K E).injective (by simpa using hcE) + exact h0 (by simp [hc]) + · intro m hm + have hmF := (MvPolynomial.isUnit_iff.mp hu).2 m hm + simp only [MvPolynomial.coeff_map, isNilpotent_iff_eq_zero] at hmF ⊢ + have hc : f.coeff m = 0 := iF.injective (by simpa using hmF) + simp [hc] + exact hE.not_isUnit huE + · intro g h hfac + classical + by_contra hnot + have hnot : ¬ IsUnit g ∧ ¬ IsUnit h := not_or.mp hnot + have hf0 : f ≠ 0 := by + intro hf + exact hE.ne_zero (by simp [hf]) + have hmap0 : MvPolynomial.map iF f ≠ 0 := by + intro hm + apply hf0 + apply MvPolynomial.map_injective iF iF.injective + simpa using hm + have hg0 : g ≠ 0 := by + intro hg + rw [hg, zero_mul] at hfac + exact hmap0 hfac + have hh0 : h ≠ 0 := by + intro hh + rw [hh, mul_zero] at hfac + exact hmap0 hfac + obtain ⟨mg, hmg0, hmg⟩ := + exists_nonconstant_coeff_of_nonzero_nonunit g hg0 hnot.1 + obtain ⟨mh, hmh0, hmh⟩ := + exists_nonconstant_coeff_of_nonzero_nonunit h hh0 hnot.2 + let V := Sum (Sum {m // m ∈ g.support} {m // m ∈ h.support}) (Fin 2) + let invG : V := Sum.inr 0 + let invH : V := Sum.inr 1 + let gVar : (σ →₀ ℕ) → V := fun m => + if hm : m ∈ g.support then Sum.inl (Sum.inl ⟨m, hm⟩) else invG + let hVar : (σ →₀ ℕ) → V := fun m => + if hm : m ∈ h.support then Sum.inl (Sum.inr ⟨m, hm⟩) else invH + let val : V → F := fun v => + match v with + | Sum.inl (Sum.inl m) => g.coeff m.1 + | Sum.inl (Sum.inr m) => h.coeff m.1 + | Sum.inr j => if j = 0 then (g.coeff mg)⁻¹ else (h.coeff mh)⁻¹ + let ψ : MvPolynomial V K →+* F := MvPolynomial.eval₂Hom iF val + let G : MvPolynomial σ (MvPolynomial V K) := + g.support.sum fun m => MvPolynomial.monomial m (MvPolynomial.X (gVar m)) + let H : MvPolynomial σ (MvPolynomial V K) := + h.support.sum fun m => MvPolynomial.monomial m (MvPolynomial.X (hVar m)) + have hmapG : MvPolynomial.map ψ G = g := by + rw [g.as_sum] + simp only [G, map_sum, map_monomial] + apply Finset.sum_congr rfl + intro m hm + have hm0 : g.coeff m ≠ 0 := by + simpa [MvPolynomial.mem_support_iff] using hm + simp [ψ, val, gVar, hm0] + have hmapH : MvPolynomial.map ψ H = h := by + rw [h.as_sum] + simp only [H, map_sum, map_monomial] + apply Finset.sum_congr rfl + intro m hm + have hm0 : h.coeff m ≠ 0 := by + simpa [MvPolynomial.mem_support_iff] using hm + simp [ψ, val, hVar, hm0] + let fA : MvPolynomial σ (MvPolynomial V K) := + MvPolynomial.map MvPolynomial.C f + have hmapfA : MvPolynomial.map ψ fA = MvPolynomial.map iF f := by + calc + MvPolynomial.map ψ fA = + MvPolynomial.map (ψ.comp MvPolynomial.C) f := by + simp only [fA, MvPolynomial.map_map] + _ = MvPolynomial.map iF f := by + have hcomp : ψ.comp MvPolynomial.C = iF := by + ext c + simp [ψ] + rw [hcomp] + let D : MvPolynomial σ (MvPolynomial V K) := G * H - fA + have hcoeffD (m : σ →₀ ℕ) : D.coeff m ∈ RingHom.ker ψ := by + change ψ (D.coeff m) = 0 + rw [← MvPolynomial.coeff_map] + simp only [D, map_sub, map_mul, hmapG, hmapH, hmapfA, hfac] + simp + let P : Ideal (MvPolynomial V K) := RingHom.ker ψ + have hPprime : P.IsPrime := RingHom.ker_isPrime ψ + obtain ⟨M, hMmax, hPM⟩ := Ideal.exists_le_maximal P hPprime.ne_top + let : Finite V := by infer_instance + obtain ⟨x, hx⟩ := + MvPolynomial.eq_vanishingIdeal_singleton_of_isMaximal E hMmax + let θ : MvPolynomial V K →+* E := + MvPolynomial.eval₂Hom (algebraMap K E) x + have hker_specialize {q : MvPolynomial V K} (hq : q ∈ RingHom.ker ψ) : + θ q = 0 := by + have hqM : q ∈ M := hPM hq + rw [hx] at hqM + simpa [θ, MvPolynomial.aeval_def] using hqM x rfl + let gE : MvPolynomial σ E := MvPolynomial.map θ G + let hE' : MvPolynomial σ E := MvPolynomial.map θ H + have hfactorE : MvPolynomial.map (algebraMap K E) f = gE * hE' := by + have hDzero : MvPolynomial.map θ D = 0 := by + ext m + rw [MvPolynomial.coeff_map] + simp only [AddMonoidAlgebra.coeff_zero, Finsupp.coe_zero, Pi.zero_apply] + exact hker_specialize (hcoeffD m) + simp only [D, map_sub, map_mul] at hDzero + have hmapfAE : MvPolynomial.map θ fA = + MvPolynomial.map (algebraMap K E) f := by + calc + MvPolynomial.map θ fA = + MvPolynomial.map (θ.comp MvPolynomial.C) f := by + simp only [fA, MvPolynomial.map_map] + _ = MvPolynomial.map (algebraMap K E) f := by + have hcomp : θ.comp MvPolynomial.C = algebraMap K E := by + ext c + simp [θ] + rw [hcomp] + rw [hmapfAE] at hDzero + exact sub_eq_zero.mp hDzero |>.symm + have hgCoeff : gE.coeff mg ≠ 0 := by + have hmgMem : mg ∈ g.support := + MvPolynomial.mem_support_iff.mpr hmg + let qG : MvPolynomial V K := + MvPolynomial.X (gVar mg) * MvPolynomial.X invG - 1 + have hqG : qG ∈ RingHom.ker ψ := by + change ψ qG = 0 + dsimp only [qG] + rw [map_sub, map_mul, map_one] + simp [ψ, val, gVar, invG, hmg] + have hqGE := hker_specialize hqG + have hxG : x (gVar mg) ≠ 0 := by + have hprod : x (gVar mg) * x invG = 1 := by + apply sub_eq_zero.mp + change θ (MvPolynomial.X (gVar mg) * MvPolynomial.X invG - 1) = 0 at hqGE + rw [map_sub, map_mul, map_one] at hqGE + simpa only [θ, MvPolynomial.eval₂Hom_X'] using hqGE + exact left_ne_zero_of_mul_eq_one hprod + have hcoeffFormula : gE.coeff mg = x (gVar mg) := by + simp [gE, G, + MvPolynomial.coeff_monomial, hmgMem, θ] + rw [hcoeffFormula] + exact hxG + have hhCoeff : hE'.coeff mh ≠ 0 := by + have hmhMem : mh ∈ h.support := + MvPolynomial.mem_support_iff.mpr hmh + let qH : MvPolynomial V K := + MvPolynomial.X (hVar mh) * MvPolynomial.X invH - 1 + have hqH : qH ∈ RingHom.ker ψ := by + change ψ qH = 0 + dsimp only [qH] + rw [map_sub, map_mul, map_one] + simp [ψ, val, hVar, invH, hmh] + have hqHE := hker_specialize hqH + have hxH : x (hVar mh) ≠ 0 := by + have hprod : x (hVar mh) * x invH = 1 := by + apply sub_eq_zero.mp + change θ (MvPolynomial.X (hVar mh) * MvPolynomial.X invH - 1) = 0 at hqHE + rw [map_sub, map_mul, map_one] at hqHE + simpa only [θ, MvPolynomial.eval₂Hom_X'] using hqHE + exact left_ne_zero_of_mul_eq_one hprod + have hcoeffFormula : hE'.coeff mh = x (hVar mh) := by + simp [hE', H, + MvPolynomial.coeff_monomial, hmhMem, θ] + rw [hcoeffFormula] + exact hxH + have hgENonunit : ¬ IsUnit gE := by + intro hu + have := (MvPolynomial.isUnit_iff.mp hu).2 mg hmg0 + simp only [isNilpotent_iff_eq_zero] at this + exact hgCoeff this + have hhENonunit : ¬ IsUnit hE' := by + intro hu + have := (MvPolynomial.isUnit_iff.mp hu).2 mh hmh0 + simp only [isNilpotent_iff_eq_zero] at this + exact hhCoeff this + exact hE.isUnit_or_isUnit hfactorE |>.elim hgENonunit hhENonunit + +/-- Absolute irreducibility, stated using `AlgebraicClosure K`, implies +irreducibility after an arbitrary field-valued coefficient embedding. -/ +theorem irreducible_map_of_irreducible_map_algebraicClosure + {K F σ : Type*} [Field K] [Field F] + (iF : K →+* F) (f : MvPolynomial σ K) + (habsolute : Irreducible + (MvPolynomial.map (algebraMap K (AlgebraicClosure K)) f)) : + Irreducible (MvPolynomial.map iF f) := + irreducible_map_of_irreducible_map_isAlgClosed + (E := AlgebraicClosure K) iF f habsolute + +variable {K L : Type*} [Field K] [Field L] {p : ℕ} + [Fact p.Prime] [CharP K p] [CharP L p] [PerfectField K] [Algebra K L] + +/-- The exact base-change bridge needed by the plane-curve auxiliary-family +theorem: absolute irreducibility over `K` implies irreducibility after +extension of constants to the Frobenius subfield `L^p`. -/ +theorem irreducible_map_perfectConstantsToFrobeniusSubfield + (f : MvPolynomial (Fin 2) K) + (habsolute : Irreducible + (MvPolynomial.map (algebraMap K (AlgebraicClosure K)) f)) : + Irreducible + (MvPolynomial.map + (perfectConstantsToFrobeniusSubfield + (K := K) (L := L) (p := p)) f) := + irreducible_map_of_irreducible_map_algebraicClosure + (perfectConstantsToFrobeniusSubfield + (K := K) (L := L) (p := p)) f habsolute + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/AuxiliaryFamily.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/AuxiliaryFamily.lean new file mode 100644 index 0000000000..1fa8cd749b --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/AuxiliaryFamily.lean @@ -0,0 +1,327 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import Mathlib.Algebra.Algebra.Basic +public import Mathlib.Algebra.Polynomial.OfFn +public import Mathlib.Algebra.Polynomial.Eval.Degree +public import Mathlib.LinearAlgebra.LinearIndependent.Defs +public import Mathlib.Tactic.FieldSimp + +/-! +# The Corvaja--Zannier auxiliary family + +The proof of Corvaja--Zannier's Proposition 2 considers the family + +`u ^ i * (1 - u) / (1 - v)` for `0 ≤ i < k`, together with +`u ^ r * v ^ s` for `0 ≤ r ≤ k` and `0 ≤ s < h`. + +This file formalizes the purely algebraic first half of their linear- +independence argument. Any dependence of that family produces a nonzero +bivariate polynomial of the exact source form + +`P₁(U) * (1 - U) + P₂(U, V) * (1 - V)` + +which vanishes at `(u, v)`. Bivariate polynomials are represented as +polynomials in `V` whose coefficients are polynomials in `U`. Excluding the +resulting relation by a resultant and degree argument is deliberately left as +the next boundary; it is not assumed here through a typeclass or an axiom. + +Source provenance: published pages 1933--1934; checked semantic reconstruction +`Papers/CorvajaZannier2013/CorvajaZannier2013.tex`, lines 518--570. The +dependence-to-relation step formalized here is lines 518--545. +-/ + +@[expose] public section + +namespace BGS.CorvajaZannier + +noncomputable section + +open scoped BigOperators + +variable {C L : Type*} [Field C] [Field L] [Algebra C L] + +/-- The exact auxiliary family used in Corvaja--Zannier's Proposition 2. + +The left summand indexes `u ^ i * (1 - u) / (1 - v)` for `i < k`; the right +summand indexes the rectangular family `u ^ r * v ^ s` for `r ≤ k`, `s < h`. +-/ +def auxiliaryFamily (u v : L) (h k : ℕ) : + Sum (Fin k) (Fin (k + 1) × Fin h) → L + | Sum.inl i => u ^ (i : ℕ) * ((1 - u) / (1 - v)) + | Sum.inr rs => u ^ (rs.1 : ℕ) * v ^ (rs.2 : ℕ) + +/-- The polynomial `Σ i, c i * U ^ i`. -/ +noncomputable def auxiliaryPowerPolynomial {k : ℕ} + (c : Fin k → C) : Polynomial C := by + classical + exact Polynomial.ofFn k c + +/-- The bivariate polynomial `Σ (r,s), d (r,s) * U ^ r * V ^ s`, represented +as a polynomial in `V` over `C[U]`. -/ +noncomputable def auxiliaryGridPolynomial {h k : ℕ} + (d : Fin (k + 1) × Fin h → C) : Polynomial (Polynomial C) := by + classical + exact Polynomial.ofFn h fun s => + Polynomial.ofFn (k + 1) fun r => d (r, s) + +/-- The bivariate relation obtained after clearing the denominator `1 - v` +from a dependence of the auxiliary family. -/ +def auxiliaryRelationPolynomial {h k : ℕ} + (c : Fin k → C) (d : Fin (k + 1) × Fin h → C) : + Polynomial (Polynomial C) := + Polynomial.C + (auxiliaryPowerPolynomial c * (1 - Polynomial.X)) + + auxiliaryGridPolynomial d * (1 - Polynomial.X) + +/-- Evaluate a bivariate polynomial, represented as a polynomial in `V` over +`C[U]`, at `(u, v)`. -/ +def evalBivariate (u v : L) (P : Polynomial (Polynomial C)) : L := + P.eval₂ (Polynomial.eval₂RingHom (algebraMap C L) u) v + +private theorem one_sub_X_ne_zero (R : Type*) [Ring R] [Nontrivial R] : + (1 - Polynomial.X : Polynomial R) ≠ 0 := by + intro h + have hatZero := congrArg (fun P : Polynomial R => P.eval 0) h + simp at hatZero + +@[simp] +theorem evalBivariate_auxiliaryPowerPolynomial + {k : ℕ} (u : L) (c : Fin k → C) : + (auxiliaryPowerPolynomial c).eval₂ (algebraMap C L) u = + ∑ i, algebraMap C L (c i) * u ^ (i : ℕ) := by + classical + change (Polynomial.eval₂RingHom (algebraMap C L) u) + (auxiliaryPowerPolynomial c) = _ + rw [auxiliaryPowerPolynomial, Polynomial.ofFn_eq_sum_monomial, map_sum] + simp only [Polynomial.coe_eval₂RingHom, Polynomial.eval₂_monomial] + +@[simp] +theorem evalBivariate_auxiliaryGridPolynomial + {h k : ℕ} (u v : L) (d : Fin (k + 1) × Fin h → C) : + evalBivariate u v (auxiliaryGridPolynomial d) = + ∑ rs, algebraMap C L (d rs) * + (u ^ (rs.1 : ℕ) * v ^ (rs.2 : ℕ)) := by + classical + change (Polynomial.eval₂RingHom + (Polynomial.eval₂RingHom (algebraMap C L) u) v) + (auxiliaryGridPolynomial d) = _ + rw [Fintype.sum_prod_type_right' + (fun (r : Fin (k + 1)) (s : Fin h) => algebraMap C L (d (r, s)) * + (u ^ (r : ℕ) * v ^ (s : ℕ)))] + rw [auxiliaryGridPolynomial, Polynomial.ofFn_eq_sum_monomial, map_sum] + apply Finset.sum_congr rfl + intro s _ + simp only [Polynomial.coe_eval₂RingHom, Polynomial.eval₂_monomial] + rw [Polynomial.ofFn_eq_sum_monomial] + change (Polynomial.eval₂RingHom (algebraMap C L) u) + (∑ r : Fin (k + 1), Polynomial.monomial (r : ℕ) (d (r, s))) * + v ^ (s : ℕ) = _ + rw [map_sum] + simp only [Polynomial.coe_eval₂RingHom, Polynomial.eval₂_monomial, + Finset.sum_mul] + apply Finset.sum_congr rfl + intro r _ + ring + +@[simp] +theorem evalBivariate_auxiliaryRelationPolynomial + {h k : ℕ} (u v : L) (c : Fin k → C) + (d : Fin (k + 1) × Fin h → C) : + evalBivariate u v (auxiliaryRelationPolynomial c d) = + (∑ i, algebraMap C L (c i) * u ^ (i : ℕ)) * (1 - u) + + (∑ rs, algebraMap C L (d rs) * + (u ^ (rs.1 : ℕ) * v ^ (rs.2 : ℕ))) * (1 - v) := by + unfold evalBivariate auxiliaryRelationPolynomial + simp only [Polynomial.eval₂_add, Polynomial.eval₂_C, + Polynomial.eval₂_mul, Polynomial.eval₂_sub, Polynomial.eval₂_one, + Polynomial.eval₂_X, Polynomial.coe_eval₂RingHom] + rw [evalBivariate_auxiliaryPowerPolynomial] + change _ + evalBivariate u v (auxiliaryGridPolynomial d) * (1 - v) = _ + rw [evalBivariate_auxiliaryGridPolynomial] + +/-- The first coefficient polynomial has degree strictly less than `k`, as in +the source's bound `deg P₁ ≤ k - 1`. -/ +theorem auxiliaryPowerPolynomial_natDegree_lt + {k : ℕ} (hk : 0 < k) (c : Fin k → C) : + (auxiliaryPowerPolynomial c).natDegree < k := by + classical + simpa [auxiliaryPowerPolynomial] using + Polynomial.ofFn_natDegree_lt (Nat.one_le_iff_ne_zero.mpr hk.ne') c + +/-- The rectangular polynomial has degree strictly less than `h` in its outer +variable `V`, as in the source's bound `deg_V P₂ ≤ h - 1`. -/ +theorem auxiliaryGridPolynomial_natDegree_lt + {h k : ℕ} (hh : 0 < h) (d : Fin (k + 1) × Fin h → C) : + (auxiliaryGridPolynomial d).natDegree < h := by + classical + simpa [auxiliaryGridPolynomial] using + Polynomial.ofFn_natDegree_lt (Nat.one_le_iff_ne_zero.mpr hh.ne') + (fun s : Fin h => Polynomial.ofFn (k + 1) fun r => d (r, s)) + +/-- Every coefficient of the rectangular polynomial, viewed as a polynomial +in `V`, has degree at most `k` in `U`. -/ +theorem auxiliaryGridPolynomial_coeff_natDegree_le + {h k : ℕ} (d : Fin (k + 1) × Fin h → C) (s : ℕ) : + ((auxiliaryGridPolynomial d).coeff s).natDegree ≤ k := by + classical + by_cases hs : s < h + · have hcoeff : + (auxiliaryGridPolynomial d).coeff s = + Polynomial.ofFn (k + 1) (fun r => d (r, ⟨s, hs⟩)) := by + simp [auxiliaryGridPolynomial, hs] + rw [hcoeff] + have hdegree := Polynomial.ofFn_natDegree_lt + (n := k + 1) (by omega : 1 ≤ k + 1) + (fun r : Fin (k + 1) => d (r, ⟨s, hs⟩)) + omega + · have hge : h ≤ s := Nat.le_of_not_gt hs + have hcoeff : (auxiliaryGridPolynomial d).coeff s = 0 := by + simp [auxiliaryGridPolynomial, + Polynomial.ofFn_coeff_eq_zero_of_ge, hge] + rw [hcoeff, Polynomial.natDegree_zero] + exact Nat.zero_le k + +/-- The power polynomial is zero exactly when all of its coefficients are +zero. -/ +theorem auxiliaryPowerPolynomial_eq_zero_iff + {k : ℕ} (c : Fin k → C) : + auxiliaryPowerPolynomial c = 0 ↔ ∀ i, c i = 0 := by + classical + constructor + · intro hc i + have hcoeff := congrArg (fun P : Polynomial C => P.coeff (i : ℕ)) hc + simpa [auxiliaryPowerPolynomial] using hcoeff + · intro hc + have hc' : c = 0 := funext hc + change Polynomial.ofFn k c = 0 + rw [hc'] + exact Polynomial.ofFn_zero k + +/-- The grid polynomial is zero exactly when all of its coefficients are +zero. -/ +theorem auxiliaryGridPolynomial_eq_zero_iff + {h k : ℕ} (d : Fin (k + 1) × Fin h → C) : + auxiliaryGridPolynomial d = 0 ↔ ∀ rs, d rs = 0 := by + classical + constructor + · intro hd rs + have hcoeff := congrArg + (fun P : Polynomial (Polynomial C) => + (P.coeff (rs.2 : ℕ)).coeff (rs.1 : ℕ)) hd + simp only [auxiliaryGridPolynomial, + Polynomial.ofFn_coeff_eq_val_of_lt _ rs.2.isLt] at hcoeff + rw [Polynomial.ofFn_coeff_eq_val_of_lt _ rs.1.isLt] at hcoeff + exact hcoeff + · intro hd + change Polynomial.ofFn h + (fun s => Polynomial.ofFn (k + 1) fun r => d (r, s)) = 0 + have hinner : + (fun s : Fin h => Polynomial.ofFn (k + 1) fun r => d (r, s)) = 0 := by + funext s + apply Polynomial.ext + intro n + by_cases hn : n < k + 1 + · simpa [hn] using hd (⟨n, hn⟩, s) + · simp [Polynomial.ofFn_coeff_eq_zero_of_ge, Nat.le_of_not_gt hn] + rw [hinner] + exact Polynomial.ofFn_zero h + +/-- The source's relation polynomial is identically zero only for the trivial +pair of coefficient families. This is the formal version of evaluating at +`V = 1` first and then using that both polynomial rings are domains. -/ +theorem auxiliaryRelationPolynomial_eq_zero_iff + {h k : ℕ} (c : Fin k → C) (d : Fin (k + 1) × Fin h → C) : + auxiliaryRelationPolynomial c d = 0 ↔ + (∀ i, c i = 0) ∧ ∀ rs, d rs = 0 := by + constructor + · intro hrel + have hatOne := congrArg + (fun P : Polynomial (Polynomial C) => P.eval 1) hrel + have hpowerMul : + auxiliaryPowerPolynomial c * (1 - Polynomial.X) = 0 := by + simpa [auxiliaryRelationPolynomial] using hatOne + have hpower : auxiliaryPowerPolynomial c = 0 := + (mul_eq_zero.mp hpowerMul).resolve_right (one_sub_X_ne_zero C) + have hgridMul : auxiliaryGridPolynomial d * (1 - Polynomial.X) = 0 := by + simpa [auxiliaryRelationPolynomial, hpower] using hrel + have hgrid : auxiliaryGridPolynomial d = 0 := + (mul_eq_zero.mp hgridMul).resolve_right (one_sub_X_ne_zero (Polynomial C)) + exact ⟨(auxiliaryPowerPolynomial_eq_zero_iff c).mp hpower, + (auxiliaryGridPolynomial_eq_zero_iff d).mp hgrid⟩ + · rintro ⟨hc, hd⟩ + simp only [auxiliaryRelationPolynomial] + rw [(auxiliaryPowerPolynomial_eq_zero_iff c).mpr hc, + (auxiliaryGridPolynomial_eq_zero_iff d).mpr hd] + simp + +/-- A dependence of the Corvaja--Zannier auxiliary family produces a nonzero +bivariate relation of the exact source form which vanishes at `(u, v)`. + +This is the algebraic input to the subsequent resultant argument. -/ +theorem exists_nonzero_auxiliaryRelationPolynomial_of_not_linearIndependent + {h k : ℕ} (u v : L) (hv : v ≠ 1) + (hdep : ¬ LinearIndependent C (auxiliaryFamily u v h k)) : + ∃ (c : Fin k → C) (d : Fin (k + 1) × Fin h → C), + auxiliaryRelationPolynomial c d ≠ 0 ∧ + evalBivariate u v (auxiliaryRelationPolynomial c d) = 0 := by + rw [Fintype.not_linearIndependent_iff] at hdep + obtain ⟨g, hg, i, hi⟩ := hdep + let c : Fin k → C := fun j => g (Sum.inl j) + let d : Fin (k + 1) × Fin h → C := fun rs => g (Sum.inr rs) + refine ⟨c, d, ?_, ?_⟩ + · intro hzero + have hcoeffs := (auxiliaryRelationPolynomial_eq_zero_iff c d).mp hzero + cases i with + | inl j => exact hi (by simpa [c] using hcoeffs.1 j) + | inr rs => exact hi (by simpa [d] using hcoeffs.2 rs) + · have hden : 1 - v ≠ 0 := sub_ne_zero.mpr hv.symm + have hcleared := congrArg (fun x : L => x * (1 - v)) hg + simp only [Fintype.sum_sum_type, auxiliaryFamily, Algebra.smul_def] at hcleared + rw [add_mul, Finset.sum_mul, Finset.sum_mul] at hcleared + field_simp [hden] at hcleared + simpa [c, d, div_mul_eq_mul_div, hden, mul_assoc, mul_left_comm, mul_comm, + Finset.mul_sum] using hcleared + +/-- The dependence-to-relation implication together with all three degree +bounds used by the source's resultant estimate. -/ +theorem exists_nonzero_bounded_auxiliaryRelationPolynomial_of_not_linearIndependent + {h k : ℕ} (u v : L) (hh : 0 < h) (hk : 0 < k) (hv : v ≠ 1) + (hdep : ¬ LinearIndependent C (auxiliaryFamily u v h k)) : + ∃ (c : Fin k → C) (d : Fin (k + 1) × Fin h → C), + auxiliaryRelationPolynomial c d ≠ 0 ∧ + evalBivariate u v (auxiliaryRelationPolynomial c d) = 0 ∧ + (auxiliaryPowerPolynomial c).natDegree < k ∧ + (auxiliaryGridPolynomial d).natDegree < h ∧ + ∀ s, ((auxiliaryGridPolynomial d).coeff s).natDegree ≤ k := by + obtain ⟨c, d, hnonzero, heval⟩ := + exists_nonzero_auxiliaryRelationPolynomial_of_not_linearIndependent + u v hv hdep + exact ⟨c, d, hnonzero, heval, + auxiliaryPowerPolynomial_natDegree_lt hk c, + auxiliaryGridPolynomial_natDegree_lt hh d, + auxiliaryGridPolynomial_coeff_natDegree_le d⟩ + +/-- If the resultant step excludes every nonzero relation polynomial of the +source form, then the auxiliary family is linearly independent. -/ +theorem auxiliaryFamily_linearIndependent_of_no_relation + {h k : ℕ} (u v : L) (hv : v ≠ 1) + (hNoRelation : + ∀ (c : Fin k → C) (d : Fin (k + 1) × Fin h → C), + auxiliaryRelationPolynomial c d ≠ 0 → + evalBivariate u v (auxiliaryRelationPolynomial c d) ≠ 0) : + LinearIndependent C (auxiliaryFamily u v h k) := by + by_contra hdep + obtain ⟨c, d, hnonzero, heval⟩ := + exists_nonzero_auxiliaryRelationPolynomial_of_not_linearIndependent + u v hv hdep + exact hNoRelation c d hnonzero heval + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/AuxiliaryFamilyIndexing.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/AuxiliaryFamilyIndexing.lean new file mode 100644 index 0000000000..ad93d6efc8 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/AuxiliaryFamilyIndexing.lean @@ -0,0 +1,128 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.DedekindLocalWronskian +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FrobeniusWronskian +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.AuxiliaryFamily +public import Mathlib.Tactic + +/-! +# Indexing the auxiliary Wronskian family + +Enumerate the auxiliary family and its derivative orders, then transport determinant +nonvanishing through that indexing. +-/ + +@[expose] public section + +namespace BGS.CorvajaZannier + +noncomputable section + +open scoped BigOperators + +/-- The source auxiliary family has exactly `h*k+h+k` members. -/ +theorem auxiliaryFamily_index_card (h k : ℕ) : + Fintype.card (Sum (Fin k) (Fin (k + 1) × Fin h)) = + h * k + h + k := by + simp only [Fintype.card_sum, Fintype.card_fin, Fintype.card_prod] + ring + +/-- A fixed enumeration of the auxiliary family by consecutive derivative +orders. -/ +def auxiliaryFamilyIndexEquiv (h k : ℕ) : + Sum (Fin k) (Fin (k + 1) × Fin h) ≃ Fin (h * k + h + k) := + Fintype.equivFinOfCardEq (auxiliaryFamily_index_card h k) + +/-- The derivative order assigned to an auxiliary-family row. -/ +def auxiliaryFamilyDerivativeOrder (h k : ℕ) : + Sum (Fin k) (Fin (k + 1) × Fin h) → ℕ := + fun i => (auxiliaryFamilyIndexEquiv h k i : ℕ) + +theorem auxiliaryFamilyDerivativeOrder_injective (h k : ℕ) : + Function.Injective (auxiliaryFamilyDerivativeOrder h k) := by + intro i j hij + apply (auxiliaryFamilyIndexEquiv h k).injective + exact Fin.ext hij + +theorem auxiliaryFamilyDerivativeOrder_le_pred + (h k : ℕ) (hn : 0 < h * k + h + k) + (i : Sum (Fin k) (Fin (k + 1) × Fin h)) : + auxiliaryFamilyDerivativeOrder h k i ≤ h * k + h + k - 1 := by + have hi := (auxiliaryFamilyIndexEquiv h k i).isLt + change (auxiliaryFamilyIndexEquiv h k i : ℕ) ≤ h * k + h + k - 1 + omega + +theorem auxiliaryFamilyDerivativeOrder_sum (h k : ℕ) : + (∑ i, auxiliaryFamilyDerivativeOrder h k i) = + (h * k + h + k).choose 2 := by + let n := h * k + h + k + let e := auxiliaryFamilyIndexEquiv h k + calc + (∑ i, auxiliaryFamilyDerivativeOrder h k i) = + ∑ j : Fin n, (j : ℕ) := by + simpa only [auxiliaryFamilyDerivativeOrder, e, n] using + (Equiv.sum_comp e (fun j : Fin n => (j : ℕ))) + _ = ∑ j ∈ Finset.range n, j := by + simpa using (Fin.sum_univ_eq_sum_range (fun j : ℕ => j) n) + _ = n * (n - 1) / 2 := Finset.sum_range_id n + _ = n.choose 2 := by rw [Nat.choose_two_right] + +theorem auxiliaryFamily_k_le_card (h k : ℕ) : + k ≤ h * k + h + k := by omega + +section IndexedWronskian + +variable {C L : Type*} [Field C] [Field L] [Algebra C L] + +/-- Reindexing both rows and columns identifies the indexed consecutive-order +Wronskian with the ordinary `Fin n` Wronskian. -/ +theorem indexedAuxiliaryWronskian_det_eq_derivationWronskian_det + (D : Derivation C L L) (h k : ℕ) + (f : Sum (Fin k) (Fin (k + 1) × Fin h) → L) : + (indexedDedekindLocalWronskian D + (auxiliaryFamilyDerivativeOrder h k) f).det = + (BGS.Algebra.derivationWronskian D + (fun j : Fin (h * k + h + k) => + f ((auxiliaryFamilyIndexEquiv h k).symm j))).det := by + let e := auxiliaryFamilyIndexEquiv h k + let g : Fin (h * k + h + k) → L := fun j => f (e.symm j) + have hmatrix : + indexedDedekindLocalWronskian D + (auxiliaryFamilyDerivativeOrder h k) f = + Matrix.reindex e.symm e.symm + (BGS.Algebra.derivationWronskian D g) := by + ext i j + simp only [indexedDedekindLocalWronskian, auxiliaryFamilyDerivativeOrder, Matrix.reindex_apply, + Matrix.submatrix, Algebra.derivationWronskian, Equiv.symm_symm, Equiv.symm_apply_apply, + Matrix.of_apply, e, g] + exact (Module.End.pow_apply D.toLinearMap _ (f j)).symm + rw [hmatrix, Matrix.det_reindex_self] + +/-- Exact constants and linear independence make the indexed global +Wronskian nonzero. -/ +theorem indexedAuxiliaryWronskian_det_ne_zero_of_linearIndependent + (D : Derivation C L L) + (hconstants : ∀ x : L, D x = 0 → + ∃ c : C, algebraMap C L c = x) + (h k : ℕ) (f : Sum (Fin k) (Fin (k + 1) × Fin h) → L) + (hLI : LinearIndependent C f) : + (indexedDedekindLocalWronskian D + (auxiliaryFamilyDerivativeOrder h k) f).det ≠ 0 := by + let e := auxiliaryFamilyIndexEquiv h k + let g : Fin (h * k + h + k) → L := fun j => f (e.symm j) + have hLIg : LinearIndependent C g := hLI.comp e.symm e.symm.injective + rw [indexedAuxiliaryWronskian_det_eq_derivationWronskian_det] + exact BGS.Algebra.derivationWronskian_det_ne_zero_of_linearIndependent + D hconstants _ g hLIg + +end IndexedWronskian + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/BivariateGauss.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/BivariateGauss.lean new file mode 100644 index 0000000000..fdb4e724fd --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/BivariateGauss.lean @@ -0,0 +1,203 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.BivariateResultant +public import Mathlib.RingTheory.Polynomial.GaussLemma + +/-! +# Gauss descent for the Corvaja--Zannier bivariate resultant + +When the resultant in the first variable vanishes, Corvaja and Zannier first +obtain divisibility over the rational-function coefficient field and then use +Gauss' lemma to descend that divisibility to the bivariate polynomial ring. +This descent is what permits reading off *both* coordinate degrees, rather +than only the degree in the eliminated variable. +-/ + +@[expose] public section + +namespace BGS.CorvajaZannier + +noncomputable section + +variable {C : Type*} [Field C] + +/-- The project-local transpose is the standard bivariate variable swap. -/ +theorem transposeBivariate_eq_bivariateSwap : + transposeBivariate (C := C) = + (Polynomial.Bivariate.swap (R := C)).toRingHom := by + ext <;> simp [transposeBivariate, Polynomial.Bivariate.swap_apply] + +/-- Swapping the two variables twice is the identity. -/ +@[simp] +theorem transposeBivariate_transposeBivariate + (P : Polynomial (Polynomial C)) : + transposeBivariate (transposeBivariate P) = P := by + rw [transposeBivariate_eq_bivariateSwap] + change Polynomial.Bivariate.swap + (Polynomial.Bivariate.swap P) = P + exact Polynomial.Bivariate.swap_swap_apply P + +/-- Swapping the variables is injective. -/ +theorem transposeBivariate_injective : + Function.Injective (transposeBivariate (C := C)) := by + intro P Q h + simpa only [transposeBivariate_transposeBivariate] using + congrArg transposeBivariate h + +/-- The ordinary (actual-degree) resultant vanishes in the common-zero branch +once its degree is smaller than the minimal-polynomial degree of `v`. + +Using the ordinary resultant here is essential: a Sylvester determinant +padded to an upper degree bound can vanish for the purely formal reason that +one polynomial has smaller actual degree, and therefore cannot support the +subsequent Gauss descent. -/ +theorem resultant_auxiliaryRelation_default_eq_zero_of_common_zero + {L : Type*} [Field L] [Algebra C L] + (f : Polynomial (Polynomial C)) (a b h k q : ℕ) + (ha : 0 < a) (hh : 0 < h) (hk : 0 < k) + (c : Fin k → C) (d : Fin (k + 1) × Fin h → C) + (hfDegree : f.natDegree = a) + (hfCoeffDegree : ∀ i, (f.coeff i).natDegree ≤ b) + (u v : L) (hminpoly : (minpoly C v).natDegree = q) + (hfZero : evalBivariate v u f = 0) + (hauxZero : + evalBivariate u v (auxiliaryRelationPolynomial c d) = 0) + (hsize : a * h + k * b < q) : + Polynomial.resultant f + (transposeBivariate (auxiliaryRelationPolynomial c d)) = 0 := by + apply eq_zero_of_natDegree_lt_minpoly_of_eval₂_eq_zero v + · rw [hminpoly] + exact (natDegree_resultant_auxiliaryRelation_default_le + f a b h k hh hk c d hfDegree.le hfCoeffDegree).trans_lt hsize + · have hfNatDegreeNonzero : f.natDegree ≠ 0 := + hfDegree.trans_ne ha.ne' + have hauxAtCommonZero : + evalBivariate v u + (transposeBivariate (auxiliaryRelationPolynomial c d)) = 0 := by + rw [evalBivariate_transposeBivariate] + exact hauxZero + exact eval₂_resultant_eq_zero_of_common_zero f + (transposeBivariate (auxiliaryRelationPolynomial c d)) + f.natDegree + (transposeBivariate (auxiliaryRelationPolynomial c d)).natDegree + (le_refl _) (le_refl _) (Or.inl hfNatDegreeNonzero) u v + hfZero hauxAtCommonZero + +/-- Source-faithful Gauss descent: zero resultant gives divisibility already +in `C[V][U]`, not merely after passing to `C(V)[U]`. + +The nonconstant hypothesis is exactly what makes the irreducible polynomial +primitive over `C[V]`; Gauss' lemma then descends the divisibility obtained +over `Frac(C[V])`. -/ +theorem dvd_of_irreducible_of_resultant_eq_zero_via_gauss + {f g : Polynomial (Polynomial C)} + (hf : Irreducible f) (hfNonconstant : f.natDegree ≠ 0) + (hresultant : Polynomial.resultant f g = 0) : + f ∣ g := by + let K := FractionRing (Polynomial C) + let φ : Polynomial C →+* K := algebraMap (Polynomial C) K + have hφ : Function.Injective φ := IsFractionRing.injective _ _ + have hprimitive : f.IsPrimitive := hf.isPrimitive hfNonconstant + have hfMap : Irreducible (f.map φ) := by + exact hprimitive.irreducible_iff_irreducible_map_fraction_map.mp hf + have hdvdMap : f.map φ ∣ g.map φ := + map_dvd_of_resultant_eq_zero f g φ hφ hfMap hresultant + exact hprimitive.dvd_of_fraction_map_dvd_fraction_map hdvdMap + +/-- Gauss descent followed by variable swapping bounds both bidegrees of a +nonzero multiple. -/ +theorem bidegree_le_of_irreducible_of_resultant_eq_zero + {f g : Polynomial (Polynomial C)} + (hf : Irreducible f) (hfNonconstant : f.natDegree ≠ 0) + (hg : g ≠ 0) (hresultant : Polynomial.resultant f g = 0) : + f.natDegree ≤ g.natDegree ∧ + (transposeBivariate f).natDegree ≤ + (transposeBivariate g).natDegree := by + have hdvd : f ∣ g := + dvd_of_irreducible_of_resultant_eq_zero_via_gauss + hf hfNonconstant hresultant + refine ⟨Polynomial.natDegree_le_of_dvd hdvd hg, ?_⟩ + have hdvdTranspose : transposeBivariate f ∣ transposeBivariate g := + map_dvd transposeBivariate hdvd + have hgTranspose : transposeBivariate g ≠ 0 := + fun hzero => hg (transposeBivariate_injective (by simpa using hzero)) + exact Polynomial.natDegree_le_of_dvd hdvdTranspose hgTranspose + +/-- The exact degree conclusion in the zero-resultant branch of the +Corvaja--Zannier auxiliary-family argument. + +Here `f` is oriented as a polynomial in `U` with coefficients in `C[V]`. +Thus `f.natDegree = a`, while the degree of its variable swap is `b`. The +auxiliary relation is constructed in the source orientation and swapped for +the resultant. -/ +theorem auxiliaryRelation_bidegree_bounds_of_resultant_eq_zero + (f : Polynomial (Polynomial C)) (a b h k : ℕ) + (ha : 0 < a) (hh : 0 < h) (hk : 0 < k) + (c : Fin k → C) (d : Fin (k + 1) × Fin h → C) + (hf : Irreducible f) + (hfDegreeU : f.natDegree = a) + (hfDegreeV : (transposeBivariate f).natDegree = b) + (hauxNonzero : auxiliaryRelationPolynomial c d ≠ 0) + (hresultant : Polynomial.resultant f + (transposeBivariate (auxiliaryRelationPolynomial c d)) = 0) : + a ≤ k ∧ b ≤ h := by + have hauxTransposeNonzero : + transposeBivariate (auxiliaryRelationPolynomial c d) ≠ 0 := by + intro hzero + exact hauxNonzero (transposeBivariate_injective (by simpa using hzero)) + have hdegrees := bidegree_le_of_irreducible_of_resultant_eq_zero + hf (hfDegreeU.trans_ne ha.ne') hauxTransposeNonzero hresultant + constructor + · rw [← hfDegreeU] + exact hdegrees.1.trans + (transpose_auxiliaryRelationPolynomial_natDegree_le hk c d) + · rw [← hfDegreeV] + exact hdegrees.2.trans (by + simpa only [transposeBivariate_transposeBivariate] using + auxiliaryRelationPolynomial_natDegree_le hh c d) + +/-- Corvaja--Zannier Proposition 1, through its complete algebraic resultant +branch. If the defining relation has bidegree `(a,b)`, its ordinary +resultant with any nonzero auxiliary relation would force `a ≤ k` and +`b ≤ h`. Excluding that degree alternative therefore makes the exact +auxiliary family linearly independent. + +The assumptions expose the two genuinely external inputs to this algebraic +step: iterated-polynomial irreducibility of the defining equation and the +minimal-polynomial degree `q` of `v` over the coefficient field. -/ +theorem auxiliaryFamily_linearIndependent_of_irreducible_bidegree + {L : Type*} [Field L] [Algebra C L] + (f : Polynomial (Polynomial C)) (a b h k q : ℕ) + (ha : 0 < a) (hh : 0 < h) (hk : 0 < k) + (hf : Irreducible f) + (hfDegreeU : f.natDegree = a) + (hfDegreeV : (transposeBivariate f).natDegree = b) + (hfCoeffDegree : ∀ i, (f.coeff i).natDegree ≤ b) + (u v : L) (hv : v ≠ 1) + (hminpoly : (minpoly C v).natDegree = q) + (hfZero : evalBivariate v u f = 0) + (hsize : a * h + b * k < q) + (hdegreeAlternativeExcluded : ¬ (a ≤ k ∧ b ≤ h)) : + LinearIndependent C (auxiliaryFamily u v h k) := by + apply auxiliaryFamily_linearIndependent_of_no_relation u v hv + intro c d hauxNonzero hauxZero + have hresultant : Polynomial.resultant f + (transposeBivariate (auxiliaryRelationPolynomial c d)) = 0 := + resultant_auxiliaryRelation_default_eq_zero_of_common_zero + f a b h k q ha hh hk c d hfDegreeU hfCoeffDegree u v hminpoly + hfZero hauxZero (by simpa [Nat.mul_comm] using hsize) + have hbidegrees : a ≤ k ∧ b ≤ h := + auxiliaryRelation_bidegree_bounds_of_resultant_eq_zero + f a b h k ha hh hk c d hf hfDegreeU hfDegreeV hauxNonzero + hresultant + exact hdegreeAlternativeExcluded hbidegrees + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/BivariateResultant.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/BivariateResultant.lean new file mode 100644 index 0000000000..ab3849b42d --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/BivariateResultant.lean @@ -0,0 +1,518 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.AuxiliaryFamily +public import Mathlib.Algebra.Polynomial.BigOperators +public import Mathlib.Algebra.Polynomial.Bivariate +public import Mathlib.FieldTheory.Minpoly.Field +public import Mathlib.RingTheory.Polynomial.Resultant.Basic + +/-! +# Degree bounds for bivariate resultants + +Corvaja--Zannier eliminate the first variable from a defining polynomial +`f(U,V)` and an auxiliary relation `P(U,V)`. They use the Sylvester +determinant estimate + +`deg_V Res_U(f, P) ≤ deg_U(f) * deg_V(P) + deg_U(P) * deg_V(f)`. + +Here bivariate polynomials are represented as polynomials in `U` whose +coefficients lie in `C[V]`. The proof records the sharper columnwise degree +bound for determinants: each determinant term uses exactly one entry from +every Sylvester column, so the coefficient bounds add with the correct +multiplicities. +-/ + +@[expose] public section + +namespace BGS.CorvajaZannier + +noncomputable section + +open scoped BigOperators + +variable {C : Type*} [Field C] + +/-- Exchange the two variables of an iterated bivariate polynomial. Both the +source and target have Lean type `C[U][V]`; the target is interpreted as +`C[V][U]`. -/ +def transposeBivariate : + Polynomial (Polynomial C) →+* Polynomial (Polynomial C) := + Polynomial.eval₂RingHom + (Polynomial.mapRingHom (Polynomial.C : C →+* Polynomial C)) + (Polynomial.C Polynomial.X) + +@[simp] +theorem transposeBivariate_C (p : Polynomial C) : + transposeBivariate (Polynomial.C p) = p.map Polynomial.C := by + simp [transposeBivariate] + +@[simp] +theorem transposeBivariate_X : + transposeBivariate (Polynomial.X : Polynomial (Polynomial C)) = + Polynomial.C Polynomial.X := by + simp [transposeBivariate] + +private theorem evalBivariate_add + {L : Type*} [Field L] [Algebra C L] + (u v : L) (P Q : Polynomial (Polynomial C)) : + evalBivariate u v (P + Q) = + evalBivariate u v P + evalBivariate u v Q := by + unfold evalBivariate + exact Polynomial.eval₂_add + (Polynomial.eval₂RingHom (algebraMap C L) u) v + +private theorem evalBivariate_mul + {L : Type*} [Field L] [Algebra C L] + (u v : L) (P Q : Polynomial (Polynomial C)) : + evalBivariate u v (P * Q) = + evalBivariate u v P * evalBivariate u v Q := by + unfold evalBivariate + exact Polynomial.eval₂_mul + (Polynomial.eval₂RingHom (algebraMap C L) u) v + +@[simp] +theorem evalBivariate_map_C + {L : Type*} [Field L] [Algebra C L] + (u v : L) (p : Polynomial C) : + evalBivariate v u (p.map Polynomial.C) = + p.eval₂ (algebraMap C L) u := by + unfold evalBivariate + rw [Polynomial.eval₂_map] + congr 1 + exact Polynomial.eval₂RingHom_comp_C (algebraMap C L) v + +@[simp] +theorem evalBivariate_C_X_pow + {L : Type*} [Field L] [Algebra C L] + (u v : L) (n : ℕ) : + evalBivariate v u + ((Polynomial.C Polynomial.X : Polynomial (Polynomial C)) ^ n) = v ^ n := by + unfold evalBivariate + rw [Polynomial.eval₂_pow, Polynomial.eval₂_C] + change (Polynomial.eval₂ (algebraMap C L) v Polynomial.X) ^ n = v ^ n + rw [Polynomial.eval₂_X] + +/-- Swapping variables and then evaluating at the swapped point preserves the +value of a bivariate polynomial. -/ +theorem evalBivariate_transposeBivariate + {L : Type*} [Field L] [Algebra C L] + (u v : L) (P : Polynomial (Polynomial C)) : + evalBivariate v u (transposeBivariate P) = evalBivariate u v P := by + induction P using Polynomial.induction_on' with + | add P Q hP hQ => + rw [map_add, evalBivariate_add, evalBivariate_add, hP, hQ] + | monomial n p => + rw [show transposeBivariate (Polynomial.monomial n p) = + p.map Polynomial.C * + (Polynomial.C Polynomial.X : Polynomial (Polynomial C)) ^ n by + simp [transposeBivariate, Polynomial.eval₂_monomial]] + rw [evalBivariate_mul, evalBivariate_map_C, evalBivariate_C_X_pow] + unfold evalBivariate + rw [Polynomial.eval₂_monomial] + rfl + +/-- A coefficientwise degree bound becomes an outer degree bound after +transposing the variables. -/ +theorem transposeBivariate_natDegree_le + (P : Polynomial (Polynomial C)) (k : ℕ) + (hcoeff : ∀ s, (P.coeff s).natDegree ≤ k) : + (transposeBivariate P).natDegree ≤ k := by + classical + change (P.eval₂ + (Polynomial.mapRingHom (Polynomial.C : C →+* Polynomial C)) + (Polynomial.C Polynomial.X)).natDegree ≤ k + rw [Polynomial.eval₂_eq_sum, Polynomial.sum_def] + apply Polynomial.natDegree_sum_le_of_forall_le + intro s _ + calc + ((P.coeff s).map Polynomial.C * + (Polynomial.C Polynomial.X : Polynomial (Polynomial C)) ^ s).natDegree + ≤ ((P.coeff s).map Polynomial.C).natDegree + + ((Polynomial.C Polynomial.X : Polynomial (Polynomial C)) ^ s).natDegree := + Polynomial.natDegree_mul_le + _ ≤ k + 0 := by + exact Nat.add_le_add + (Polynomial.natDegree_map_le.trans (hcoeff s)) (by simp) + _ = k := Nat.add_zero k + +/-- An outer degree bound becomes a coefficientwise degree bound after +transposing the variables. -/ +theorem transposeBivariate_coeff_natDegree_le + (P : Polynomial (Polynomial C)) (h : ℕ) + (hdegree : P.natDegree ≤ h) (r : ℕ) : + ((transposeBivariate P).coeff r).natDegree ≤ h := by + classical + change ((P.eval₂ + (Polynomial.mapRingHom (Polynomial.C : C →+* Polynomial C)) + (Polynomial.C Polynomial.X)).coeff r).natDegree ≤ h + rw [Polynomial.eval₂_eq_sum, Polynomial.sum_def, + Polynomial.finsetSum_coeff] + apply Polynomial.natDegree_sum_le_of_forall_le + intro s hs + rw [show (Polynomial.C Polynomial.X : Polynomial (Polynomial C)) ^ s = + Polynomial.C (Polynomial.X ^ s) by simp] + rw [Polynomial.coeff_mul_C, Polynomial.coe_mapRingHom, + Polynomial.coeff_map] + exact (Polynomial.natDegree_C_mul_X_pow_le _ s).trans + ((Polynomial.le_natDegree_of_mem_supp s hs).trans hdegree) + +private theorem auxiliaryPowerPolynomial_mul_one_sub_X_natDegree_le + {k : ℕ} (hk : 0 < k) (c : Fin k → C) : + (auxiliaryPowerPolynomial c * (1 - Polynomial.X)).natDegree ≤ k := by + have hfactor : + (1 - Polynomial.X : Polynomial C).natDegree ≤ 1 := by + exact (Polynomial.natDegree_sub_le _ _).trans (by simp) + calc + (auxiliaryPowerPolynomial c * (1 - Polynomial.X)).natDegree + ≤ (auxiliaryPowerPolynomial c).natDegree + + (1 - Polynomial.X : Polynomial C).natDegree := + Polynomial.natDegree_mul_le + _ ≤ (auxiliaryPowerPolynomial c).natDegree + 1 := + Nat.add_le_add_left hfactor _ + _ ≤ k := by + have := auxiliaryPowerPolynomial_natDegree_lt hk c + omega + +/-- The source-oriented auxiliary relation has degree at most `h` in its +outer variable `V`. -/ +theorem auxiliaryRelationPolynomial_natDegree_le + {h k : ℕ} (hh : 0 < h) (c : Fin k → C) + (d : Fin (k + 1) × Fin h → C) : + (auxiliaryRelationPolynomial c d).natDegree ≤ h := by + have hfactor : + (1 - Polynomial.X : Polynomial (Polynomial C)).natDegree ≤ 1 := by + exact (Polynomial.natDegree_sub_le _ _).trans (by simp) + have hgrid : (auxiliaryGridPolynomial d).natDegree + 1 ≤ h := by + have := auxiliaryGridPolynomial_natDegree_lt hh d + omega + have hconstant : + (Polynomial.C + (auxiliaryPowerPolynomial c * (1 - Polynomial.X)) : + Polynomial (Polynomial C)).natDegree ≤ h := by + rw [Polynomial.natDegree_C] + exact Nat.zero_le h + unfold auxiliaryRelationPolynomial + apply Polynomial.natDegree_add_le_of_degree_le + · simpa only [map_mul, map_sub, map_one, Polynomial.map_X] using hconstant + · calc + (auxiliaryGridPolynomial d * (1 - Polynomial.X)).natDegree + ≤ (auxiliaryGridPolynomial d).natDegree + + (1 - Polynomial.X : Polynomial (Polynomial C)).natDegree := + Polynomial.natDegree_mul_le + _ ≤ (auxiliaryGridPolynomial d).natDegree + 1 := + Nat.add_le_add_left hfactor _ + _ ≤ h := hgrid + +/-- Every `V`-coefficient of the source-oriented auxiliary relation has +`U`-degree at most `k`. -/ +theorem auxiliaryRelationPolynomial_coeff_natDegree_le + {h k : ℕ} (hk : 0 < k) (c : Fin k → C) + (d : Fin (k + 1) × Fin h → C) (s : ℕ) : + ((auxiliaryRelationPolynomial c d).coeff s).natDegree ≤ k := by + let A : Polynomial C := auxiliaryPowerPolynomial c * (1 - Polynomial.X) + let G : Polynomial (Polynomial C) := auxiliaryGridPolynomial d + have hA : A.natDegree ≤ k := + auxiliaryPowerPolynomial_mul_one_sub_X_natDegree_le hk c + have hG (i : ℕ) : (G.coeff i).natDegree ≤ k := + auxiliaryGridPolynomial_coeff_natDegree_le d i + have hrewrite : auxiliaryRelationPolynomial c d = + Polynomial.C A + G - G * Polynomial.X := by + simp only [auxiliaryRelationPolynomial, A, G] + ring + rw [hrewrite] + cases s with + | zero => + simp only [Polynomial.coeff_sub, Polynomial.coeff_add, + Polynomial.coeff_C_zero, Polynomial.coeff_mul_X_zero, sub_zero] + exact Polynomial.natDegree_add_le_of_degree_le hA (hG 0) + | succ s => + simp only [Polynomial.coeff_sub, Polynomial.coeff_add, + Polynomial.coeff_C, ite_eq_right (Nat.succ_ne_zero s), zero_add, + Polynomial.coeff_mul_X] + simpa using Polynomial.natDegree_sub_le_of_le (hG (s + 1)) (hG s) + +/-- In the `U`-oriented representation required by `Res_U`, the auxiliary +relation has `U`-degree at most `k`. -/ +theorem transpose_auxiliaryRelationPolynomial_natDegree_le + {h k : ℕ} (hk : 0 < k) (c : Fin k → C) + (d : Fin (k + 1) × Fin h → C) : + (transposeBivariate (auxiliaryRelationPolynomial c d)).natDegree ≤ k := + transposeBivariate_natDegree_le _ k + (auxiliaryRelationPolynomial_coeff_natDegree_le hk c d) + +/-- In the `U`-oriented representation required by `Res_U`, every coefficient +has `V`-degree at most `h`. -/ +theorem transpose_auxiliaryRelationPolynomial_coeff_natDegree_le + {h k : ℕ} (hh : 0 < h) (c : Fin k → C) + (d : Fin (k + 1) × Fin h → C) (r : ℕ) : + ((transposeBivariate (auxiliaryRelationPolynomial c d)).coeff r).natDegree ≤ h := + transposeBivariate_coeff_natDegree_le _ h + (auxiliaryRelationPolynomial_natDegree_le hh c d) r + +/-- A determinant over `C[V]` has degree at most the sum of columnwise degree +bounds. -/ +theorem Matrix.natDegree_det_le_sum_columnDegree + {n : Type*} [Fintype n] [DecidableEq n] + (M : Matrix n n (Polynomial C)) (columnDegree : n → ℕ) + (hM : ∀ i j, (M i j).natDegree ≤ columnDegree j) : + M.det.natDegree ≤ ∑ j, columnDegree j := by + classical + rw [Matrix.det_apply'] + apply Polynomial.natDegree_sum_le_of_forall_le + intro σ _ + calc + (Equiv.Perm.sign σ * ∏ i, M (σ i) i).natDegree + ≤ (∏ i, M (σ i) i).natDegree := by + exact Polynomial.natDegree_C_mul_le _ _ + _ ≤ ∑ i, (M (σ i) i).natDegree := by + simpa using Polynomial.natDegree_prod_le Finset.univ (fun i => M (σ i) i) + _ ≤ ∑ i, columnDegree i := by + exact Finset.sum_le_sum fun i _ => hM (σ i) i + +/-- The exact coefficient-degree estimate for a resultant over `C[V]`. + +`f` has `U`-degree bounded by `m` and every `V`-coefficient degree bounded by +`df`; `g` has the analogous bounds `n` and `dg`. -/ +theorem natDegree_resultant_le + (f g : Polynomial (Polynomial C)) (m n df dg : ℕ) + (hf : ∀ i, (f.coeff i).natDegree ≤ df) + (hg : ∀ i, (g.coeff i).natDegree ≤ dg) : + (Polynomial.resultant f g m n).natDegree ≤ m * dg + n * df := by + rw [Polynomial.resultant] + let columnDegree : Fin (m + n) → ℕ := fun j => + j.addCases (fun _ => dg) (fun _ => df) + have hcolumns : ∀ i j, + ((Polynomial.sylvester f g m n) i j).natDegree ≤ columnDegree j := by + intro i j + induction j using Fin.addCases with + | left j => + simp only [Polynomial.sylvester, Matrix.of_apply, Fin.addCases_left, + columnDegree] + split_ifs + · exact hg _ + · simp + | right j => + simp only [Polynomial.sylvester, Matrix.of_apply, Fin.addCases_right, + columnDegree] + split_ifs + · exact hf _ + · simp + calc + (Polynomial.sylvester f g m n).det.natDegree + ≤ ∑ j, columnDegree j := + Matrix.natDegree_det_le_sum_columnDegree + (Polynomial.sylvester f g m n) columnDegree hcolumns + _ = m * dg + n * df := by + simp [columnDegree, Fin.sum_univ_add] + +/-- The source-faithful version using the ordinary resultant at the actual +degrees, while bounding those degrees by `m` and `n`. -/ +theorem natDegree_resultant_le_of_degree_le + (f g : Polynomial (Polynomial C)) (m n df dg : ℕ) + (hfDegree : f.natDegree ≤ m) (hgDegree : g.natDegree ≤ n) + (hf : ∀ i, (f.coeff i).natDegree ≤ df) + (hg : ∀ i, (g.coeff i).natDegree ≤ dg) : + (Polynomial.resultant f g).natDegree ≤ m * dg + n * df := by + calc + (Polynomial.resultant f g).natDegree + ≤ f.natDegree * dg + g.natDegree * df := + natDegree_resultant_le f g f.natDegree g.natDegree df dg hf hg + _ ≤ m * dg + n * df := by + exact Nat.add_le_add + (Nat.mul_le_mul_right dg hfDegree) + (Nat.mul_le_mul_right df hgDegree) + +/-- The exact Corvaja--Zannier resultant degree bound for the transposed +auxiliary relation. -/ +theorem natDegree_resultant_auxiliaryRelation_le + (f : Polynomial (Polynomial C)) (a b h k : ℕ) (hh : 0 < h) + (c : Fin k → C) (d : Fin (k + 1) × Fin h → C) + (hf : ∀ i, (f.coeff i).natDegree ≤ b) : + (Polynomial.resultant f + (transposeBivariate (auxiliaryRelationPolynomial c d)) a k).natDegree + ≤ a * h + k * b := + natDegree_resultant_le f + (transposeBivariate (auxiliaryRelationPolynomial c d)) a k b h hf + (transpose_auxiliaryRelationPolynomial_coeff_natDegree_le hh c d) + +/-- The ordinary-resultant degree bound for the transposed auxiliary relation. +This is the version used by the subsequent irreducibility/divisibility +argument. -/ +theorem natDegree_resultant_auxiliaryRelation_default_le + (f : Polynomial (Polynomial C)) (a b h k : ℕ) + (hh : 0 < h) (hk : 0 < k) + (c : Fin k → C) (d : Fin (k + 1) × Fin h → C) + (hfDegree : f.natDegree ≤ a) + (hf : ∀ i, (f.coeff i).natDegree ≤ b) : + (Polynomial.resultant f + (transposeBivariate (auxiliaryRelationPolynomial c d))).natDegree + ≤ a * h + k * b := + natDegree_resultant_le_of_degree_le f + (transposeBivariate (auxiliaryRelationPolynomial c d)) a k b h + hfDegree (transpose_auxiliaryRelationPolynomial_natDegree_le hk c d) hf + (transpose_auxiliaryRelationPolynomial_coeff_natDegree_le hh c d) + +/-- Two polynomials of the prescribed degree bounds with a common root have +zero explicit-degree resultant. -/ +theorem resultant_eq_zero_of_common_root + {K : Type*} [Field K] (f g : Polynomial K) (m n : ℕ) + (hf : f.natDegree ≤ m) (hg : g.natDegree ≤ n) + (hmn : m ≠ 0 ∨ n ≠ 0) (x : K) + (hfx : f.eval x = 0) (hgx : g.eval x = 0) : + Polynomial.resultant f g m n = 0 := by + obtain ⟨p, q, _, _, hbezout⟩ := + Polynomial.exists_mul_add_mul_eq_C_resultant f g hf hg hmn + have heval := congrArg (Polynomial.eval x) hbezout + simpa [hfx, hgx] using heval.symm + +/-- If two bivariate polynomials vanish at `(u,v)`, their resultant in `U` +vanishes at `v`. -/ +theorem eval₂_resultant_eq_zero_of_common_zero + {L : Type*} [Field L] [Algebra C L] + (f g : Polynomial (Polynomial C)) (m n : ℕ) + (hf : f.natDegree ≤ m) (hg : g.natDegree ≤ n) + (hmn : m ≠ 0 ∨ n ≠ 0) (u v : L) + (hfu : evalBivariate v u f = 0) + (hgu : evalBivariate v u g = 0) : + (Polynomial.resultant f g m n).eval₂ (algebraMap C L) v = 0 := by + let ev : Polynomial C →+* L := + Polynomial.eval₂RingHom (algebraMap C L) v + have hfmap : (f.map ev).natDegree ≤ m := + Polynomial.natDegree_map_le.trans hf + have hgmap : (g.map ev).natDegree ≤ n := + Polynomial.natDegree_map_le.trans hg + have hfeval : (f.map ev).eval u = 0 := by + simpa [ev, evalBivariate, Polynomial.eval_map] using hfu + have hgeval : (g.map ev).eval u = 0 := by + simpa [ev, evalBivariate, Polynomial.eval_map] using hgu + have hmapped : Polynomial.resultant (f.map ev) (g.map ev) m n = 0 := + resultant_eq_zero_of_common_root + (f.map ev) (g.map ev) m n hfmap hgmap hmn u hfeval hgeval + rw [Polynomial.resultant_map_map] at hmapped + exact hmapped + +/-- The common-zero implication specialized to the Corvaja--Zannier +auxiliary relation. -/ +theorem eval₂_resultant_auxiliaryRelation_eq_zero_of_common_zero + {L : Type*} [Field L] [Algebra C L] + (f : Polynomial (Polynomial C)) (a h k : ℕ) + (ha : 0 < a) (hk : 0 < k) + (c : Fin k → C) (d : Fin (k + 1) × Fin h → C) + (hfDegree : f.natDegree ≤ a) (u v : L) + (hfZero : evalBivariate v u f = 0) + (hauxZero : + evalBivariate u v (auxiliaryRelationPolynomial c d) = 0) : + (Polynomial.resultant f + (transposeBivariate (auxiliaryRelationPolynomial c d)) a k).eval₂ + (algebraMap C L) v = 0 := by + apply eval₂_resultant_eq_zero_of_common_zero f + (transposeBivariate (auxiliaryRelationPolynomial c d)) a k + hfDegree (transpose_auxiliaryRelationPolynomial_natDegree_le hk c d) + (Or.inl ha.ne') u v hfZero + rw [evalBivariate_transposeBivariate] + exact hauxZero + +/-- A nonzero polynomial vanishing at an algebraic element has degree at least +the degree of that element's minimal polynomial. -/ +theorem minpoly_natDegree_le_of_eval₂_eq_zero + {L : Type*} [Field L] [Algebra C L] + (y : L) (P : Polynomial C) (hP : P ≠ 0) + (hzero : P.eval₂ (algebraMap C L) y = 0) : + (minpoly C y).natDegree ≤ P.natDegree := by + apply Polynomial.natDegree_le_of_dvd (minpoly.dvd C y ?_) hP + simpa [Polynomial.aeval_def] using hzero + +/-- A polynomial whose degree is strictly smaller than the minimal-polynomial +degree cannot vanish at the element unless it is zero. -/ +theorem eq_zero_of_natDegree_lt_minpoly_of_eval₂_eq_zero + {L : Type*} [Field L] [Algebra C L] + (y : L) (P : Polynomial C) + (hdegree : P.natDegree < (minpoly C y).natDegree) + (hzero : P.eval₂ (algebraMap C L) y = 0) : P = 0 := by + by_contra hP + exact (not_lt_of_ge (minpoly_natDegree_le_of_eval₂_eq_zero y P hP hzero)) + hdegree + +/-- The complete nonzero-resultant contradiction in the +Corvaja--Zannier auxiliary-family argument. Under `a*h + k*b < q` and +minimal-polynomial degree `q`, the resultant must vanish identically. -/ +theorem resultant_auxiliaryRelation_eq_zero_of_common_zero + {L : Type*} [Field L] [Algebra C L] + (f : Polynomial (Polynomial C)) (a b h k q : ℕ) + (ha : 0 < a) (hh : 0 < h) (hk : 0 < k) + (c : Fin k → C) (d : Fin (k + 1) × Fin h → C) + (hfDegree : f.natDegree ≤ a) + (hfCoeffDegree : ∀ i, (f.coeff i).natDegree ≤ b) + (u v : L) (hminpoly : (minpoly C v).natDegree = q) + (hfZero : evalBivariate v u f = 0) + (hauxZero : + evalBivariate u v (auxiliaryRelationPolynomial c d) = 0) + (hsize : a * h + k * b < q) : + Polynomial.resultant f + (transposeBivariate (auxiliaryRelationPolynomial c d)) a k = 0 := by + apply eq_zero_of_natDegree_lt_minpoly_of_eval₂_eq_zero v + · rw [hminpoly] + exact (natDegree_resultant_auxiliaryRelation_le + f a b h k hh c d hfCoeffDegree).trans_lt hsize + · exact eval₂_resultant_auxiliaryRelation_eq_zero_of_common_zero + f a h k ha hk c d hfDegree u v hfZero hauxZero + +/-- Over a field, an irreducible polynomial divides any nonzero polynomial +with which it has zero resultant. -/ +theorem irreducible_dvd_of_resultant_eq_zero + {K : Type*} [Field K] {f g : Polynomial K} + (hf : Irreducible f) + (hresultant : Polynomial.resultant f g = 0) : f ∣ g := by + have hnotCoprime : ¬ IsCoprime f g := + (Polynomial.resultant_eq_zero_iff.mp hresultant).2 + exact (hf.dvd_iff_not_isCoprime).mpr hnotCoprime + +/-- The zero-resultant divisibility branch after embedding the coefficient +ring into a field (in the application, `C[V] → C(V)`). -/ +theorem map_dvd_of_resultant_eq_zero + {R K : Type*} [CommRing R] [Field K] + (f g : Polynomial R) (phi : R →+* K) (hphi : Function.Injective phi) + (hf : Irreducible (f.map phi)) + (hresultant : Polynomial.resultant f g = 0) : + f.map phi ∣ g.map phi := by + have hfgDegree : (f.map phi).natDegree = f.natDegree := + Polynomial.natDegree_map_eq_of_injective hphi f + have hggDegree : (g.map phi).natDegree = g.natDegree := + Polynomial.natDegree_map_eq_of_injective hphi g + have hresultantMappedExplicit : + Polynomial.resultant (f.map phi) (g.map phi) + f.natDegree g.natDegree = 0 := by + rw [Polynomial.resultant_map_map, hresultant, map_zero] + have hresultantMapped : + Polynomial.resultant (f.map phi) (g.map phi) = 0 := by + simpa only [hfgDegree, hggDegree] using hresultantMappedExplicit + exact irreducible_dvd_of_resultant_eq_zero hf hresultantMapped + +/-- The zero-resultant branch already forces the defining polynomial's +degree in the eliminated variable to be no larger than that of the auxiliary +relation after any injective coefficient-field embedding. -/ +theorem natDegree_le_of_map_irreducible_of_resultant_eq_zero + {R K : Type*} [CommRing R] [Field K] + (f g : Polynomial R) (phi : R →+* K) (hphi : Function.Injective phi) + (hf : Irreducible (f.map phi)) (hg : g ≠ 0) + (hresultant : Polynomial.resultant f g = 0) : + f.natDegree ≤ g.natDegree := by + have hdvd := map_dvd_of_resultant_eq_zero f g phi hphi hf hresultant + have hgmapped : g.map phi ≠ 0 := by + intro hzero + apply hg + apply Polynomial.map_injective phi hphi + simpa using hzero + rw [← Polynomial.natDegree_map_eq_of_injective hphi f, + ← Polynomial.natDegree_map_eq_of_injective hphi g] + exact Polynomial.natDegree_le_of_dvd hdvd hgmapped + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/CompletionLinearDisjointness.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/CompletionLinearDisjointness.lean new file mode 100644 index 0000000000..a8883f78eb --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/CompletionLinearDisjointness.lean @@ -0,0 +1,149 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.LaurentFrobeniusBasis +public import Mathlib.FieldTheory.LinearDisjoint + +/-! +# The completion linear-disjointness bridge + +This file isolates the abstract algebraic content of Corvaja--Zannier's +completion argument. Suppose that `L / F` has a basis +`1, z, ..., z^(q - 1)`, that `L` is embedded in a Laurent-series field, and +that the completed field over `F` has the same carrier as the exponent- +dilation subfield `K((z^q))`. The residue classes of exponents modulo `q` +then show that the basis remains linearly independent over the completed +field. Hence the completed field and `L` are linearly disjoint over `F`, and +their intersection in the ambient Laurent-series field is exactly the image +of `F`. + +The hypotheses below deliberately expose both compatibility conditions that +must come from curve geometry: + +* `hcompletion` identifies the chosen completed field, as a subfield of the + ambient Laurent-series field, with the exponent-dilation subfield; +* `hbasis` says that the ambient images of the chosen `F`-basis of `L` really + are `1, z, ..., z^(q - 1)`. + +No assertion here constructs a completion map or proves these compatibility +conditions for a plane curve. +-/ + +@[expose] public section + +open HahnSeries +open Module + +noncomputable section + +namespace BGS.CorvajaZannier + +section AbstractBasisBridge + +universe u v w + +variable {F : Type u} {L : Type v} {E : Type w} + [Field F] [Field L] [Field E] + [Algebra F L] [Algebra F E] [Algebra L E] [IsScalarTower F L E] + +/-- A basis of `L / F` which remains linearly independent over an ambient +intermediate field proves linear disjointness and identifies the intersection +with the embedded base field. + +This is the abstract linear-algebra boundary used by the Laurent-series +specialization below. -/ +theorem linearDisjoint_and_inf_eq_bot_of_basis_ambient_linearIndependent + (C : IntermediateField F E) {ι : Type*} (b : Basis ι F L) + (hlinear : LinearIndependent C (fun i => algebraMap L E (b i))) : + C.LinearDisjoint L ∧ + C ⊓ (IsScalarTower.toAlgHom F L E).fieldRange = ⊥ := by + have hdisjoint : C.LinearDisjoint L := + IntermediateField.LinearDisjoint.of_basis_right' b (by + change LinearIndependent C (fun i => algebraMap L E (b i)) + exact hlinear) + have hdisjointRange : + C.LinearDisjoint (IsScalarTower.toAlgHom F L E).fieldRange := by + rw [IntermediateField.linearDisjoint_iff', AlgHom.fieldRange_toSubalgebra] + exact hdisjoint + exact ⟨hdisjoint, hdisjointRange.inf_eq_bot⟩ + +end AbstractBasisBridge + +section LaurentCompletion + +universe u v w + +variable {K : Type u} {F : Type v} {L : Type w} + [Field K] [Field F] [Field L] + [Algebra F L] + [Algebra F (LaurentSeries K)] + [Algebra L (LaurentSeries K)] + [IsScalarTower F L (LaurentSeries K)] + +private def sameCarrierRingEquiv + (C : IntermediateField F (LaurentSeries K)) + (D : IntermediateField K (LaurentSeries K)) + (hcarrier : ∀ x : LaurentSeries K, x ∈ C ↔ x ∈ D) : C ≃+* D where + toFun x := ⟨x, (hcarrier x).mp x.property⟩ + invFun x := ⟨x, (hcarrier x).mpr x.property⟩ + left_inv _ := Subtype.ext rfl + right_inv _ := Subtype.ext rfl + map_mul' := fun _ _ => rfl + map_add' := fun _ _ => rfl + +/-- **Completion form of Corvaja--Zannier's Lemma 2.** + +Let `C` be the completed exponent-dilation field inside `K((z))`, represented +as an intermediate field over `F`. If `L / F` has a `Fin q`-indexed basis +whose ambient images are `1, z, ..., z^(q - 1)`, then `C` and `L` are linearly +disjoint over `F`. Their intersection inside `K((z))` is the bottom +intermediate field, i.e. the image of `F`. + +The carrier equality is stated elementwise because `C` and +`laurentExponentSubfield K hq` have different declared base fields even +though they are subfields of the same Laurent-series field. -/ +theorem laurentExponentCompletion_linearDisjoint_and_inf_eq_bot + {q : ℕ} (hq : 0 < q) + (C : IntermediateField F (LaurentSeries K)) + (hcompletion : ∀ x : LaurentSeries K, + x ∈ C ↔ x ∈ laurentExponentSubfield K hq) + (b : Basis (Fin q) F L) + (hbasis : ∀ i : Fin q, + algebraMap L (LaurentSeries K) (b i) = + laurentParameter K ^ (i : ℕ)) : + C.LinearDisjoint L ∧ + C ⊓ (IsScalarTower.toAlgHom F L (LaurentSeries K)).fieldRange = ⊥ := by + let D : IntermediateField K (LaurentSeries K) := + laurentExponentSubfield K hq + let e : C ≃+* D := sameCarrierRingEquiv C D hcompletion + have he_val (c : C) : ((e c : D) : LaurentSeries K) = (c : LaurentSeries K) := rfl + have hpowersD : LinearIndependent D + (fun i : Fin q => laurentParameter K ^ (i : ℕ)) := by + simpa only [D] using linearIndependent_laurentParameter_pow K hq + have hpowersC : LinearIndependent C + (fun i : Fin q => laurentParameter K ^ (i : ℕ)) := by + refine hpowersD.map_of_injective_injective + (fun c : C => e c) (AddMonoidHom.id (LaurentSeries K)) ?_ ?_ ?_ + · intro c hc + exact e.injective (by simpa using hc) + · intro x hx + exact hx + · intro c x + change ((e c : D) : LaurentSeries K) * x = (c : LaurentSeries K) * x + rw [he_val] + have hbasisLinear : LinearIndependent C + (fun i : Fin q => algebraMap L (LaurentSeries K) (b i)) := by + rw [show (fun i : Fin q => algebraMap L (LaurentSeries K) (b i)) = + (fun i : Fin q => laurentParameter K ^ (i : ℕ)) from funext hbasis] + exact hpowersC + exact linearDisjoint_and_inf_eq_bot_of_basis_ambient_linearIndependent + C b hbasisLinear + +end LaurentCompletion + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/DedekindAuxiliaryCaseI.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/DedekindAuxiliaryCaseI.lean new file mode 100644 index 0000000000..3ef60faae8 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/DedekindAuxiliaryCaseI.lean @@ -0,0 +1,934 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.DedekindAuxiliaryWronskian +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.DedekindLeadingTermCancellation +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.LocalAuxiliaryCaseI +public import Mathlib.LinearAlgebra.Matrix.Transvection + +/-! +# Corvaja--Zannier case (i) at a Dedekind DVR place + +This file transports the repeated-leading-term cancellation argument of +Corvaja--Zannier's local case (i) from Laurent series to the fraction field of +a discrete valuation ring. Constants are assumed to surject onto the residue +field. This is precisely the input needed to cancel equal-order leading +terms; no coefficient field or completion is chosen. + +The Wronskian estimate only assumes that the derivation preserves the DVR. +In particular, a column of nonnegative order and every one of its iterated +derivatives remain regular. Combining this with determinant-one elimination +gives the source bound `q * ord(rho)` for the full auxiliary family. + +Source provenance: published pages 1935--1936; checked semantic reconstruction +`Papers/CorvajaZannier2013/CorvajaZannier2013.tex`, lines 640--685. +-/ + +@[expose] public section + +namespace BGS.CorvajaZannier + +noncomputable section + +open scoped Matrix BigOperators +open IsDedekindDomain Multiplicative WithZero + +variable {C R L : Type*} [Field C] [CommRing R] [IsDedekindDomain R] + [IsDiscreteValuationRing R] [Field L] [Algebra C R] [Algebra R L] + [Algebra C L] [IsScalarTower C R L] [IsFractionRing R L] + +/-- The depth of the pole of `x` at `v`; zero has pole depth zero. -/ +def dedekindPoleDepth (v : HeightOneSpectrum R) (x : L) : ℕ := + by + classical + exact if x = 0 then 0 else Int.toNat (-finitePlaceOrder v x) + +/-- A terminating measure for repeated leading-term cancellation. -/ +def dedekindPoleWeight {k : ℕ} (v : HeightOneSpectrum R) (f : Fin k → L) : ℕ := + ∑ i, dedekindPoleDepth v (f i) + +omit [IsDiscreteValuationRing R] in +@[simp] +theorem dedekindPoleDepth_zero (v : HeightOneSpectrum R) : + dedekindPoleDepth (L := L) v 0 = 0 := by + simp [dedekindPoleDepth] + +/-- All negative finite-place orders in a family are pairwise distinct. -/ +def NegativeFinitePlaceOrdersPairwiseDistinct {ι : Type*} + (v : HeightOneSpectrum R) (f : ι → L) : Prop := + ∀ ⦃i j : ι⦄, finitePlaceOrderTop v (f i) < 0 → + finitePlaceOrderTop v (f j) < 0 → + finitePlaceOrderTop v (f i) = finitePlaceOrderTop v (f j) → i = j + +omit [IsDiscreteValuationRing R] in +@[simp] +theorem dedekindPoleDepth_pos_iff (v : HeightOneSpectrum R) (x : L) : + 0 < dedekindPoleDepth v x ↔ finitePlaceOrderTop v x < 0 := by + by_cases hx : x = 0 + · subst x + simp [dedekindPoleDepth] + · rw [finitePlaceOrderTop_eq_coe v x hx] + simp [dedekindPoleDepth, hx] + +omit [IsDiscreteValuationRing R] in +@[simp] +theorem dedekindPoleDepth_eq_zero_iff (v : HeightOneSpectrum R) (x : L) : + dedekindPoleDepth v x = 0 ↔ 0 ≤ finitePlaceOrderTop v x := by + by_cases hx : x = 0 + · subst x + simp [dedekindPoleDepth] + · rw [finitePlaceOrderTop_eq_coe v x hx] + simp [dedekindPoleDepth, hx, Int.toNat_eq_zero] + +/-- Equal negative orders have a constant cancellation which strictly lowers +the pole-depth measure. -/ +theorem exists_constant_dedekindPoleDepth_sub_mul_lt + (v : HeightOneSpectrum R) + (hresidue : Function.Surjective + (algebraMap C v.asIdeal.ResidueField)) + (x y : L) + (hxneg : finitePlaceOrderTop v x < 0) + (hyneg : finitePlaceOrderTop v y < 0) + (horder : finitePlaceOrderTop v x = finitePlaceOrderTop v y) : + ∃ c : C, + dedekindPoleDepth v (x - algebraMap C L c * y) < + dedekindPoleDepth v x ∧ + finitePlaceOrderTop v x < + finitePlaceOrderTop v (x - algebraMap C L c * y) := by + have hx : x ≠ 0 := by + intro h + subst x + simp at hxneg + have hy : y ≠ 0 := by + intro h + subst y + simp at hyneg + have horder' : finitePlaceOrder v x = finitePlaceOrder v y := by + rw [finitePlaceOrderTop_eq_coe v x hx, + finitePlaceOrderTop_eq_coe v y hy] at horder + exact_mod_cast horder + obtain ⟨c, hz | hlt⟩ := + exists_constant_finitePlaceOrder_sub_mul_eq_zero_or_lt + v hresidue x y hx hy horder' + · refine ⟨c, ?_, ?_⟩ + · rw [hz] + have hxdepth : 0 < dedekindPoleDepth v x := + (dedekindPoleDepth_pos_iff v x).2 hxneg + simpa only [dedekindPoleDepth_zero] using hxdepth + · rw [hz, finitePlaceOrderTop_eq_coe v x hx] + simp + · by_cases hz : x - algebraMap C L c * y = 0 + · refine ⟨c, ?_, ?_⟩ + · rw [hz] + have hxdepth : 0 < dedekindPoleDepth v x := + (dedekindPoleDepth_pos_iff v x).2 hxneg + simpa only [dedekindPoleDepth_zero] using hxdepth + · rw [hz, finitePlaceOrderTop_eq_coe v x hx] + simp + · refine ⟨c, ?_, ?_⟩ + · simp only [dedekindPoleDepth, hx, hz, ite_false] + have hxorderneg : finitePlaceOrder v x < 0 := by + rw [finitePlaceOrderTop_eq_coe v x hx] at hxneg + exact_mod_cast hxneg + omega + · rw [finitePlaceOrderTop_eq_coe v x hx, + finitePlaceOrderTop_eq_coe v _ hz] + exact_mod_cast hlt + +private theorem indexedDedekindLocalColumnCombination_transvection_same + {k : ℕ} (f : Fin k → L) (i j : Fin k) (c : C) : + indexedDedekindLocalColumnCombination f (Matrix.transvection j i c) i = + f i + c • f j := by + classical + simp [indexedDedekindLocalColumnCombination, Matrix.transvection, + Matrix.single, Matrix.one_apply, add_smul, Finset.sum_add_distrib] + +private theorem indexedDedekindLocalColumnCombination_transvection_ne + {k : ℕ} (f : Fin k → L) (i j b : Fin k) (c : C) (hb : b ≠ i) : + indexedDedekindLocalColumnCombination f (Matrix.transvection j i c) b = + f b := by + classical + have hib : i ≠ b := Ne.symm hb + simp [indexedDedekindLocalColumnCombination, Matrix.transvection, + Matrix.single, Matrix.one_apply, hib] + +private theorem exists_dedekindPoleWeight_transvection_lt + {k : ℕ} (v : HeightOneSpectrum R) + (hresidue : Function.Surjective + (algebraMap C v.asIdeal.ResidueField)) + (f : Fin k → L) (i j : Fin k) + (hi : finitePlaceOrderTop v (f i) < 0) + (hj : finitePlaceOrderTop v (f j) < 0) + (horder : finitePlaceOrderTop v (f i) = finitePlaceOrderTop v (f j)) : + ∃ c : C, + dedekindPoleWeight v + (indexedDedekindLocalColumnCombination f + (Matrix.transvection j i (-c))) < + dedekindPoleWeight v f ∧ + finitePlaceOrderTop v (f i) < + finitePlaceOrderTop v (f i - algebraMap C L c * f j) := by + obtain ⟨c, hstrict, hraise⟩ := + exists_constant_dedekindPoleDepth_sub_mul_lt + v hresidue (f i) (f j) hi hj horder + refine ⟨c, ?_, hraise⟩ + unfold dedekindPoleWeight + apply Finset.sum_lt_sum + · intro b _ + by_cases hb : b = i + · subst b + rw [indexedDedekindLocalColumnCombination_transvection_same] + simpa only [Algebra.smul_def, map_neg, sub_eq_add_neg, neg_mul] using hstrict.le + · rw [indexedDedekindLocalColumnCombination_transvection_ne f i j b (-c) hb] + · refine ⟨i, Finset.mem_univ _, ?_⟩ + rw [indexedDedekindLocalColumnCombination_transvection_same] + simpa only [Algebra.smul_def, map_neg, sub_eq_add_neg, neg_mul] using hstrict + +/-- Successive constant column combinations compose by matrix +multiplication. -/ +theorem indexedDedekindLocalColumnCombination_mul {k : ℕ} + (f : Fin k → L) (A B : Matrix (Fin k) (Fin k) C) : + indexedDedekindLocalColumnCombination + (indexedDedekindLocalColumnCombination f A) B = + indexedDedekindLocalColumnCombination f (A * B) := by + classical + funext b + simp only [indexedDedekindLocalColumnCombination, Matrix.mul_apply] + simp_rw [Finset.smul_sum, smul_smul] + rw [Finset.sum_comm] + apply Finset.sum_congr rfl + intro i _ + rw [Finset.sum_smul] + apply Finset.sum_congr rfl + intro j _ + rw [mul_comm (B j b) (A i j)] + +private theorem indexedDedekindLocalColumnCombination_one {k : ℕ} + (f : Fin k → L) : + indexedDedekindLocalColumnCombination f + (1 : Matrix (Fin k) (Fin k) C) = f := by + classical + funext i + simp [indexedDedekindLocalColumnCombination, Matrix.one_apply] + +/-- Repeated equal negative orders can be eliminated by a determinant-one +constant matrix, while preserving a common lower order bound. -/ +theorem exists_det_one_dedekindColumnMatrix_negativeOrdersPairwiseDistinct + {k : ℕ} (v : HeightOneSpectrum R) + (hresidue : Function.Surjective + (algebraMap C v.asIdeal.ResidueField)) + (a : ℤ) (f : Fin k → L) + (hf : ∀ i, (a : WithTop ℤ) ≤ finitePlaceOrderTop v (f i)) : + ∃ A : Matrix (Fin k) (Fin k) C, + A.det = 1 ∧ + NegativeFinitePlaceOrdersPairwiseDistinct v + (indexedDedekindLocalColumnCombination f A) ∧ + ∀ i, (a : WithTop ℤ) ≤ finitePlaceOrderTop v + (indexedDedekindLocalColumnCombination f A i) := by + induction hN : dedekindPoleWeight v f using Nat.strong_induction_on + generalizing f with + | h N ih => + by_cases hdistinct : NegativeFinitePlaceOrdersPairwiseDistinct v f + · refine ⟨(1 : Matrix (Fin k) (Fin k) C), Matrix.det_one, ?_, ?_⟩ + · simpa [indexedDedekindLocalColumnCombination_one] + · simpa [indexedDedekindLocalColumnCombination_one] using hf + · have hdup : ∃ i j : Fin k, + finitePlaceOrderTop v (f i) < 0 ∧ + finitePlaceOrderTop v (f j) < 0 ∧ + finitePlaceOrderTop v (f i) = finitePlaceOrderTop v (f j) ∧ + i ≠ j := by + simp only [NegativeFinitePlaceOrdersPairwiseDistinct] at hdistinct + push Not at hdistinct + obtain ⟨i, j, hi, hj, ho, hij⟩ := hdistinct + exact ⟨i, j, hi, hj, ho, hij⟩ + obtain ⟨i, j, hi, hj, horder, hij⟩ := hdup + obtain ⟨c, hweight', hraise⟩ := + exists_dedekindPoleWeight_transvection_lt + v hresidue f i j hi hj horder + let T : Matrix (Fin k) (Fin k) C := Matrix.transvection j i (-c) + let g := indexedDedekindLocalColumnCombination f T + have hweight : dedekindPoleWeight v g < N := by + rw [← hN] + exact hweight' + have hgi : g i = f i - algebraMap C L c * f j := by + change indexedDedekindLocalColumnCombination f + (Matrix.transvection j i (-c)) i = _ + rw [indexedDedekindLocalColumnCombination_transvection_same] + simp only [Algebra.smul_def, map_neg, neg_mul, sub_eq_add_neg] + have hg : ∀ b, (a : WithTop ℤ) ≤ finitePlaceOrderTop v (g b) := by + intro b + by_cases hb : b = i + · subst b + rw [hgi] + exact (hf i).trans hraise.le + · change (a : WithTop ℤ) ≤ finitePlaceOrderTop v + (indexedDedekindLocalColumnCombination f + (Matrix.transvection j i (-c)) b) + rw [indexedDedekindLocalColumnCombination_transvection_ne f i j b (-c) hb] + exact hf b + obtain ⟨B, hBdet, hBdistinct, hBlower⟩ := ih _ hweight g hg rfl + refine ⟨T * B, ?_, ?_, ?_⟩ + · rw [Matrix.det_mul, hBdet, mul_one] + exact Matrix.det_transvection_of_ne j i (Ne.symm hij) (-c) + · rw [← indexedDedekindLocalColumnCombination_mul] + exact hBdistinct + · rw [← indexedDedekindLocalColumnCombination_mul] + exact hBlower + +omit [Algebra C R] [IsScalarTower C R L] in +/-- A DVR-preserving derivation and all of its iterates preserve the +nonnegative-order part of the fraction field. -/ +theorem finitePlaceOrderTop_derivation_iterate_nonnegative_of_nonnegative + (v : HeightOneSpectrum R) (D : Derivation C L L) + (hDIntegral : ∀ r : R, ∃ s : R, + D (algebraMap R L r) = algebraMap R L s) + (m : ℕ) (x : L) (hx : (0 : WithTop ℤ) ≤ finitePlaceOrderTop v x) : + (0 : WithTop ℤ) ≤ + finitePlaceOrderTop v (((D : L → L)^[m]) x) := by + by_cases hx0 : x = 0 + · subst x + simp + obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible R + have hπIdeal : v.asIdeal = Ideal.span {π} := by + calc + v.asIdeal = IsLocalRing.maximalIdeal R := + IsLocalRing.eq_maximalIdeal v.isMaximal + _ = Ideal.span {π} := + (IsDiscreteValuationRing.irreducible_iff_uniformizer π).mp hπ + obtain ⟨n, u, hxu⟩ := + IsDiscreteValuationRing.exists_units_eq_smul_zpow_of_irreducible + (K := L) hπ hx0 + have hxrepr : + x = algebraMap R L (u : R) * (algebraMap R L π) ^ n := by + simpa [Units.smul_def, Algebra.smul_def] using hxu + have hxOrder : finitePlaceOrder v x = n := by + rw [hxrepr] + exact finitePlaceOrder_unit_mul_uniformizer_zpow + v π hπ hπIdeal u n + have hn : 0 ≤ n := by + rw [finitePlaceOrderTop_eq_coe v x hx0, hxOrder] at hx + exact_mod_cast hx + let x0 : R := (u : R) * π ^ n.toNat + have hxMap : x = algebraMap R L x0 := by + rw [hxrepr] + change algebraMap R L (u : R) * (algebraMap R L π) ^ n = + algebraMap R L ((u : R) * π ^ n.toNat) + rw [map_mul, map_pow] + congr 1 + calc + (algebraMap R L π) ^ n = + (algebraMap R L π) ^ (n.toNat : ℤ) := by + rw [Int.toNat_of_nonneg hn] + _ = (algebraMap R L π) ^ n.toNat := zpow_natCast _ _ + have hiter : ∀ r : ℕ, ∃ s : R, + ((D : L → L)^[r]) x = algebraMap R L s := by + intro r + induction r with + | zero => exact ⟨x0, by simpa using hxMap⟩ + | succ r ih => + rw [Function.iterate_succ_apply'] + obtain ⟨s, hs⟩ := ih + rw [hs] + exact hDIntegral s + obtain ⟨s, hs⟩ := hiter m + rw [hs] + exact finitePlaceOrderTop_algebraMap_nonnegative (L := L) v s + +private theorem dedekindCaseI_coe_sum_int_finset + {ι : Type*} [DecidableEq ι] (s : Finset ι) (g : ι → ℤ) : + (((∑ i ∈ s, g i : ℤ) : ℤ) : WithTop ℤ) = + ∑ i ∈ s, ((g i : ℤ) : WithTop ℤ) := by + induction s using Finset.induction_on with + | empty => simp + | @insert a s ha ih => simp [ha, ih, WithTop.coe_add] + +omit [Algebra C R] [IsScalarTower C R L] in +/-- In a DVR-preserving Wronskian, only the pole columns pay a derivative +order cost. -/ +theorem finitePlaceOrderTop_indexedDedekindLocalWronskian_det_lower_bound_of_poles + {ι : Type*} [Fintype ι] [DecidableEq ι] + (v : HeightOneSpectrum R) (D : Derivation C L L) + (hDIntegral : ∀ r : R, ∃ s : R, + D (algebraMap R L r) = algebraMap R L s) + (epsilonOrder : ι → ℕ) (g : ι → L) (poles : Finset ι) + (E : ℤ) + (hpole : ∀ i ∈ poles, finitePlaceOrderTop v (g i) < 0) + (hregular : ∀ i ∉ poles, (0 : WithTop ℤ) ≤ finitePlaceOrderTop v (g i)) + (hselected : ∀ σ : Equiv.Perm ι, + (∑ i ∈ poles, (epsilonOrder (σ i) : ℤ)) ≤ E) : + (((∑ i ∈ poles, finitePlaceOrder v (g i)) - E : ℤ) : WithTop ℤ) ≤ + finitePlaceOrderTop v + (indexedDedekindLocalWronskian D epsilonOrder g).det := by + obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible R + have hπIdeal : v.asIdeal = Ideal.span {π} := by + calc + v.asIdeal = IsLocalRing.maximalIdeal R := + IsLocalRing.eq_maximalIdeal v.isMaximal + _ = Ideal.span {π} := + (IsDiscreteValuationRing.irreducible_iff_uniformizer π).mp hπ + rw [Matrix.det_apply'] + apply le_finitePlaceOrderTop_finset_sum_of_forall + intro σ _ + let term : L := + ((Equiv.Perm.sign σ : ℤ) : L) * + ∏ i, indexedDedekindLocalWronskian D epsilonOrder g (σ i) i + change + (((∑ i ∈ poles, finitePlaceOrder v (g i)) - E : ℤ) : WithTop ℤ) ≤ + finitePlaceOrderTop v term + calc + (((∑ i ∈ poles, finitePlaceOrder v (g i)) - E : ℤ) : WithTop ℤ) ≤ + (((∑ i ∈ poles, + (finitePlaceOrder v (g i) - (epsilonOrder (σ i) : ℤ)) : ℤ)) : + WithTop ℤ) := by + rw [Finset.sum_sub_distrib] + exact_mod_cast sub_le_sub_left (hselected σ) _ + _ = ∑ i, if i ∈ poles then + (((finitePlaceOrder v (g i) - + (epsilonOrder (σ i) : ℤ) : ℤ)) : WithTop ℤ) + else 0 := by + rw [Finset.sum_ite_mem_eq] + exact dedekindCaseI_coe_sum_int_finset poles + (fun i => finitePlaceOrder v (g i) - (epsilonOrder (σ i) : ℤ)) + _ ≤ ∑ i, finitePlaceOrderTop v + (((D : L → L)^[epsilonOrder (σ i)]) (g i)) := by + gcongr with i + by_cases hi : i ∈ poles + · simp only [hi, ite_true] + have hgi : g i ≠ 0 := by + intro hz + have hneg := hpole i hi + rw [hz] at hneg + simp at hneg + have hbound := + finitePlaceOrderTop_derivation_iterate_ge_sub_nat_of_preserves + v π hπ hπIdeal D hDIntegral (epsilonOrder (σ i)) (g i) + rw [finitePlaceOrderTop_eq_coe v (g i) hgi] at hbound + simpa only [← WithTop.coe_add, sub_eq_add_neg] using hbound + · simp only [hi, ite_false] + exact finitePlaceOrderTop_derivation_iterate_nonnegative_of_nonnegative + v D hDIntegral (epsilonOrder (σ i)) (g i) (hregular i hi) + _ = finitePlaceOrderTop v + (∏ i, indexedDedekindLocalWronskian D epsilonOrder g (σ i) i) := by + rw [finitePlaceOrderTop_finset_prod] + rfl + _ ≤ finitePlaceOrderTop v term := by + exact finitePlaceOrderTop_le_intCast_mul v + (Equiv.Perm.sign σ : ℤ) + (∏ i, indexedDedekindLocalWronskian D epsilonOrder g (σ i) i) + +private theorem dedekindCaseI_sum_range_int_mul_two (r : ℕ) : + (∑ n ∈ Finset.range r, (n : ℤ)) * 2 = + (r : ℤ) * (r - 1 : ℕ) := by + have h := congrArg (fun n : ℕ => (n : ℤ)) + (Finset.sum_range_id_mul_two r) + push_cast at h + exact h + +private theorem dedekindCaseI_int_natCast_mul_pred (r : ℕ) : + (r : ℤ) * (r - 1 : ℕ) = (r : ℤ) * ((r : ℤ) - 1) := by + cases r <;> simp + +omit [Algebra C R] [IsScalarTower C R L] in +/-- The exact intermediate case-(i) estimate at a Dedekind DVR place. -/ +theorem finitePlaceOrderTop_indexedDedekindLocalWronskian_caseI_epsilon_plus_one_lower_bound + {ι : Type*} [Fintype ι] [DecidableEq ι] + (v : HeightOneSpectrum R) (D : Derivation C L L) + (hDIntegral : ∀ r : R, ∃ s : R, + D (algebraMap R L r) = algebraMap R L s) + (epsilonOrder : ι → ℕ) (g : ι → L) + (rhoOrder : ℤ) (epsilon : ℕ) + (hgdistinct : NegativeFinitePlaceOrdersPairwiseDistinct v g) + (hglower : ∀ i, (rhoOrder : WithTop ℤ) ≤ finitePlaceOrderTop v (g i)) + (hepsilonInjective : Function.Injective epsilonOrder) + (hepsilonMax : ∀ i, epsilonOrder i ≤ epsilon) + (hcardRho : rhoOrder ≤ + -((Finset.univ.filter fun i => finitePlaceOrderTop v (g i) < 0).card : ℤ)) + (hcardEpsilon : + (Finset.univ.filter fun i => finitePlaceOrderTop v (g i) < 0).card ≤ + epsilon + 1) : + ((rhoOrder * (epsilon + 1 : ℕ) : ℤ) : WithTop ℤ) ≤ + finitePlaceOrderTop v + (indexedDedekindLocalWronskian D epsilonOrder g).det := by + let poles : Finset ι := + Finset.univ.filter fun i => finitePlaceOrderTop v (g i) < 0 + let E : ℤ := ∑ n ∈ Finset.range poles.card, ((epsilon : ℤ) - n) + have hpole : ∀ i ∈ poles, finitePlaceOrderTop v (g i) < 0 := by + intro i hi + simpa [poles] using hi + have hpoleNe : ∀ i ∈ poles, g i ≠ 0 := by + intro i hi hz + have hneg := hpole i hi + rw [hz] at hneg + simp at hneg + have horderInj : + Set.InjOn (fun i => finitePlaceOrder v (g i)) (poles : Set ι) := by + intro i hi j hj hij + apply hgdistinct (hpole i hi) (hpole j hj) + rw [finitePlaceOrderTop_eq_coe v (g i) (hpoleNe i hi), + finitePlaceOrderTop_eq_coe v (g j) (hpoleNe j hj)] + exact_mod_cast hij + have hpoleLower : + (∑ n ∈ Finset.range poles.card, (rhoOrder + n : ℤ)) ≤ + ∑ i ∈ poles, finitePlaceOrder v (g i) := + sum_range_add_le_sum_of_injOn poles + (fun i => finitePlaceOrder v (g i)) rhoOrder horderInj (by + intro i hi + have h := hglower i + rw [finitePlaceOrderTop_eq_coe v (g i) (hpoleNe i hi)] at h + exact_mod_cast h) + have hselected : ∀ σ : Equiv.Perm ι, + (∑ i ∈ poles, (epsilonOrder (σ i) : ℤ)) ≤ E := by + intro σ + apply sum_le_sum_range_sub_of_injOn poles + (fun i => epsilonOrder (σ i)) epsilon + · intro i hi j hj hij + exact σ.injective (hepsilonInjective hij) + · intro i _ + exact hepsilonMax (σ i) + have hregular : ∀ i ∉ poles, + (0 : WithTop ℤ) ≤ finitePlaceOrderTop v (g i) := by + intro i hi + simp only [poles, Finset.mem_filter, Finset.mem_univ, true_and] at hi + exact le_of_not_gt hi + have hW := + finitePlaceOrderTop_indexedDedekindLocalWronskian_det_lower_bound_of_poles + v D hDIntegral epsilonOrder g poles E hpole hregular hselected + apply le_trans ?_ hW + norm_cast + have hcardRho' : rhoOrder ≤ -(poles.card : ℤ) := by + simpa [poles] using hcardRho + have hcardEpsilon' : poles.card ≤ epsilon + 1 := by + simpa [poles] using hcardEpsilon + let S : ℤ := ∑ n ∈ Finset.range poles.card, (n : ℤ) + have htri : S * 2 = (poles.card : ℤ) * (poles.card - 1 : ℕ) := by + exact dedekindCaseI_sum_range_int_mul_two poles.card + have htri' : S * 2 = + (poles.card : ℤ) * ((poles.card : ℤ) - 1) := + htri.trans (dedekindCaseI_int_natCast_mul_pred poles.card) + have hpoleRange : + (∑ n ∈ Finset.range poles.card, (rhoOrder + n : ℤ)) = + (poles.card : ℤ) * rhoOrder + S := by + rw [Finset.sum_add_distrib] + simp [S, mul_comm] + have hcostRange : E = + (poles.card : ℤ) * epsilon - S := by + change (∑ n ∈ Finset.range poles.card, ((epsilon : ℤ) - n)) = _ + rw [Finset.sum_sub_distrib] + simp [S, mul_comm] + have hgapEpsilon : + 0 ≤ (epsilon + 1 : ℤ) - (poles.card : ℤ) := by + have hcast : (poles.card : ℤ) ≤ (epsilon + 1 : ℕ) := by + exact_mod_cast hcardEpsilon' + omega + have hgapRho : 0 ≤ -rhoOrder - (poles.card : ℤ) := by omega + have hgapProduct : + 0 ≤ ((epsilon + 1 : ℤ) - (poles.card : ℤ)) * + (-rhoOrder - (poles.card : ℤ)) := + mul_nonneg hgapEpsilon hgapRho + calc + rhoOrder * (epsilon + 1 : ℕ) ≤ + (∑ n ∈ Finset.range poles.card, (rhoOrder + n : ℤ)) - E := by + rw [hpoleRange, hcostRange] + push_cast + nlinarith + _ ≤ (∑ i ∈ poles, finitePlaceOrder v (g i)) - E := + sub_le_sub_right hpoleLower E + +omit [Algebra C R] [IsScalarTower C R L] in +/-- Source case (i), in the final `q * rhoOrder` form, at a Dedekind DVR +place. -/ +theorem finitePlaceOrderTop_indexedDedekindLocalWronskian_caseI_q_lower_bound + {ι : Type*} [Fintype ι] [DecidableEq ι] + (v : HeightOneSpectrum R) (D : Derivation C L L) + (hDIntegral : ∀ r : R, ∃ s : R, + D (algebraMap R L r) = algebraMap R L s) + (epsilonOrder : ι → ℕ) (g : ι → L) + (rhoOrder : ℤ) (epsilon q : ℕ) + (hgdistinct : NegativeFinitePlaceOrdersPairwiseDistinct v g) + (hglower : ∀ i, (rhoOrder : WithTop ℤ) ≤ finitePlaceOrderTop v (g i)) + (hepsilonInjective : Function.Injective epsilonOrder) + (hepsilonMax : ∀ i, epsilonOrder i ≤ epsilon) + (hcardRho : rhoOrder ≤ + -((Finset.univ.filter fun i => finitePlaceOrderTop v (g i) < 0).card : ℤ)) + (hcardEpsilon : + (Finset.univ.filter fun i => finitePlaceOrderTop v (g i) < 0).card ≤ + epsilon + 1) + (hrho : rhoOrder ≤ 0) (hepsilonQ : epsilon + 1 ≤ q) : + (((q : ℤ) * rhoOrder : ℤ) : WithTop ℤ) ≤ + finitePlaceOrderTop v + (indexedDedekindLocalWronskian D epsilonOrder g).det := by + apply le_trans ?_ + (finitePlaceOrderTop_indexedDedekindLocalWronskian_caseI_epsilon_plus_one_lower_bound + v D hDIntegral epsilonOrder g rhoOrder epsilon hgdistinct hglower + hepsilonInjective hepsilonMax hcardRho hcardEpsilon) + norm_cast + have hepsilonQ' : (epsilon + 1 : ℤ) ≤ q := by + exact_mod_cast hepsilonQ + calc + (q : ℤ) * rhoOrder ≤ (epsilon + 1 : ℤ) * rhoOrder := + mul_le_mul_of_nonpos_right hepsilonQ' hrho + _ = rhoOrder * (epsilon + 1 : ℕ) := by push_cast; ring + +omit [IsDiscreteValuationRing R] in +/-- Pairwise-distinct negative finite-place orders bounded below by a +nonpositive integer are no more numerous than its pole depth. -/ +theorem card_negativeFinitePlaceOrders_le_neg + {ι : Type*} [Fintype ι] [DecidableEq ι] + (v : HeightOneSpectrum R) (g : ι → L) (a : ℤ) (ha : a ≤ 0) + (hgdistinct : NegativeFinitePlaceOrdersPairwiseDistinct v g) + (hglower : ∀ i, (a : WithTop ℤ) ≤ finitePlaceOrderTop v (g i)) : + a ≤ -((Finset.univ.filter fun i => + finitePlaceOrderTop v (g i) < 0).card : ℤ) := by + let poles : Finset ι := + Finset.univ.filter fun i => finitePlaceOrderTop v (g i) < 0 + have hpole : ∀ i ∈ poles, finitePlaceOrderTop v (g i) < 0 := by + intro i hi + simpa [poles] using hi + have hpoleNe : ∀ i ∈ poles, g i ≠ 0 := by + intro i hi hz + have hneg := hpole i hi + rw [hz] at hneg + simp at hneg + let w : ι → ℤ := fun i => finitePlaceOrder v (g i) + have hinj : Set.InjOn w (poles : Set ι) := by + intro i hi j hj hij + apply hgdistinct (hpole i hi) (hpole j hj) + rw [finitePlaceOrderTop_eq_coe v (g i) (hpoleNe i hi), + finitePlaceOrderTop_eq_coe v (g j) (hpoleNe j hj)] + exact_mod_cast hij + have hsubset : poles.image w ⊆ Finset.Ico a 0 := by + intro x hx + rw [Finset.mem_image] at hx + obtain ⟨i, hi, rfl⟩ := hx + rw [Finset.mem_Ico] + constructor + · have h := hglower i + rw [finitePlaceOrderTop_eq_coe v (g i) (hpoleNe i hi)] at h + exact_mod_cast h + · have h := hpole i hi + rw [finitePlaceOrderTop_eq_coe v (g i) (hpoleNe i hi)] at h + exact_mod_cast h + have hcard := Finset.card_le_card hsubset + rw [Finset.card_image_iff.mpr hinj, Int.card_Ico] at hcard + have hcard' : poles.card ≤ Int.toNat (-a) := by simpa using hcard + have hcast : (poles.card : ℤ) ≤ Int.toNat (-a) := by + exact_mod_cast hcard' + have htoNat : (Int.toNat (-a) : ℤ) = -a := by + rw [Int.toNat_of_nonneg] + omega + rw [htoNat] at hcast + simpa [poles] using (show a ≤ -(poles.card : ℤ) by omega) + +/-- Complete local case (i) for an arbitrary `Fin k` fraction-field family. -/ +theorem exists_dedekindCaseI_columnMatrix_and_q_wronskian_bound + {k : ℕ} (v : HeightOneSpectrum R) + (hresidue : Function.Surjective + (algebraMap C v.asIdeal.ResidueField)) + (D : Derivation C L L) + (hDIntegral : ∀ r : R, ∃ s : R, + D (algebraMap R L r) = algebraMap R L s) + (epsilonOrder : Fin k → ℕ) (f : Fin k → L) + (a : ℤ) (epsilon q : ℕ) + (ha : a ≤ 0) + (hf : ∀ i, (a : WithTop ℤ) ≤ finitePlaceOrderTop v (f i)) + (hepsilonInjective : Function.Injective epsilonOrder) + (hepsilonMax : ∀ i, epsilonOrder i ≤ epsilon) + (hk : k ≤ epsilon + 1) (hepsilonQ : epsilon + 1 ≤ q) : + ∃ A : Matrix (Fin k) (Fin k) C, + A.det = 1 ∧ + (indexedDedekindLocalWronskian D epsilonOrder + (indexedDedekindLocalColumnCombination f A)).det = + (indexedDedekindLocalWronskian D epsilonOrder f).det ∧ + (((q : ℤ) * a : ℤ) : WithTop ℤ) ≤ + finitePlaceOrderTop v + (indexedDedekindLocalWronskian D epsilonOrder f).det := by + obtain ⟨A, hAdet, hdistinct, hlower⟩ := + exists_det_one_dedekindColumnMatrix_negativeOrdersPairwiseDistinct + v hresidue a f hf + let g := indexedDedekindLocalColumnCombination f A + have hdet : + (indexedDedekindLocalWronskian D epsilonOrder g).det = + (indexedDedekindLocalWronskian D epsilonOrder f).det := by + exact indexedDedekindLocalWronskian_det_columnCombination_of_det_eq_one + D epsilonOrder f A hAdet + have hcardRho : + a ≤ -((Finset.univ.filter fun i => + finitePlaceOrderTop v (g i) < 0).card : ℤ) := + card_negativeFinitePlaceOrders_le_neg v g a ha hdistinct hlower + have hcardEpsilon : + (Finset.univ.filter fun i => finitePlaceOrderTop v (g i) < 0).card ≤ + epsilon + 1 := by + calc + (Finset.univ.filter fun i => finitePlaceOrderTop v (g i) < 0).card ≤ + (Finset.univ : Finset (Fin k)).card := Finset.card_filter_le _ _ + _ = k := Fintype.card_fin k + _ ≤ epsilon + 1 := hk + have hbound := + finitePlaceOrderTop_indexedDedekindLocalWronskian_caseI_q_lower_bound + v D hDIntegral epsilonOrder g a epsilon q hdistinct hlower + hepsilonInjective hepsilonMax hcardRho hcardEpsilon ha hepsilonQ + refine ⟨A, hAdet, hdet, ?_⟩ + rw [← hdet] + exact hbound + +/-- Extend a first-block operation by the identity on the grid columns. -/ +def dedekindCaseIColumnMatrix (h k : ℕ) + (A : Matrix (Fin k) (Fin k) C) : + Matrix (Sum (Fin k) (Fin (k + 1) × Fin h)) + (Sum (Fin k) (Fin (k + 1) × Fin h)) C := + Matrix.fromBlocks A 0 0 1 + +theorem dedekindCaseIColumnMatrix_det (h k : ℕ) + (A : Matrix (Fin k) (Fin k) C) : + (dedekindCaseIColumnMatrix h k A).det = A.det := by + rw [dedekindCaseIColumnMatrix, Matrix.det_fromBlocks_zero₁₂] + simp + +theorem indexedDedekindLocalColumnCombination_dedekindCaseIColumnMatrix_inl + (h k : ℕ) + (f : Sum (Fin k) (Fin (k + 1) × Fin h) → L) + (A : Matrix (Fin k) (Fin k) C) (i : Fin k) : + indexedDedekindLocalColumnCombination f + (dedekindCaseIColumnMatrix h k A) (Sum.inl i) = + indexedDedekindLocalColumnCombination (fun j => f (Sum.inl j)) A i := by + classical + rw [indexedDedekindLocalColumnCombination, Fintype.sum_sum_type] + simp [dedekindCaseIColumnMatrix, indexedDedekindLocalColumnCombination] + +theorem indexedDedekindLocalColumnCombination_dedekindCaseIColumnMatrix_inr + (h k : ℕ) + (f : Sum (Fin k) (Fin (k + 1) × Fin h) → L) + (A : Matrix (Fin k) (Fin k) C) (rs : Fin (k + 1) × Fin h) : + indexedDedekindLocalColumnCombination f + (dedekindCaseIColumnMatrix h k A) (Sum.inr rs) = + f (Sum.inr rs) := by + classical + rw [indexedDedekindLocalColumnCombination, Fintype.sum_sum_type] + simp [dedekindCaseIColumnMatrix, Matrix.one_apply] + +/-- The full Dedekind-local auxiliary family after eliminating repeated +orders in its first block. -/ +def dedekindCaseITransformedLocalAuxiliaryFamily + (u w rho : L) (h k : ℕ) (A : Matrix (Fin k) (Fin k) C) : + Sum (Fin k) (Fin (k + 1) × Fin h) → L := + indexedDedekindLocalColumnCombination + (dedekindLocalAuxiliaryFamily u w rho h k) + (dedekindCaseIColumnMatrix h k A) + +@[simp] +theorem dedekindCaseITransformedLocalAuxiliaryFamily_inl + (u w rho : L) (h k : ℕ) (A : Matrix (Fin k) (Fin k) C) (i : Fin k) : + dedekindCaseITransformedLocalAuxiliaryFamily u w rho h k A (Sum.inl i) = + indexedDedekindLocalColumnCombination + (fun j => dedekindLocalAuxiliaryFamily u w rho h k (Sum.inl j)) A i := + indexedDedekindLocalColumnCombination_dedekindCaseIColumnMatrix_inl + h k (dedekindLocalAuxiliaryFamily u w rho h k) A i + +@[simp] +theorem dedekindCaseITransformedLocalAuxiliaryFamily_inr + (u w rho : L) (h k : ℕ) (A : Matrix (Fin k) (Fin k) C) + (rs : Fin (k + 1) × Fin h) : + dedekindCaseITransformedLocalAuxiliaryFamily u w rho h k A (Sum.inr rs) = + dedekindLocalAuxiliaryFamily u w rho h k (Sum.inr rs) := + indexedDedekindLocalColumnCombination_dedekindCaseIColumnMatrix_inr + h k (dedekindLocalAuxiliaryFamily u w rho h k) A rs + +/-- Source-facing case-(i) elimination for the full auxiliary family. The +ratio block starts at the common negative order of `rho`, while the grid +columns are assumed regular. -/ +theorem exists_dedekindLocalAuxiliaryFamily_caseI_columnMatrix + (v : HeightOneSpectrum R) + (hresidue : Function.Surjective + (algebraMap C v.asIdeal.ResidueField)) + (u w rho : L) (h k : ℕ) + (hrhoNe : rho ≠ 0) + (huOrder : finitePlaceOrderTop v u = 0) + (hrhoOrder : finitePlaceOrder v rho < 0) + (hgridRegular : ∀ rs : Fin (k + 1) × Fin h, + (0 : WithTop ℤ) ≤ finitePlaceOrderTop v + (u ^ (rs.1 : ℕ) * w ^ (rs.2 : ℕ))) : + ∃ A : Matrix (Fin k) (Fin k) C, + A.det = 1 ∧ + NegativeFinitePlaceOrdersPairwiseDistinct v + (dedekindCaseITransformedLocalAuxiliaryFamily u w rho h k A) ∧ + (∀ i, (finitePlaceOrder v rho : WithTop ℤ) ≤ + finitePlaceOrderTop v + (dedekindCaseITransformedLocalAuxiliaryFamily u w rho h k A i)) ∧ + (∀ rs, dedekindCaseITransformedLocalAuxiliaryFamily + u w rho h k A (Sum.inr rs) = + dedekindLocalAuxiliaryFamily u w rho h k (Sum.inr rs)) := by + let first : Fin k → L := + fun i => dedekindLocalAuxiliaryFamily u w rho h k (Sum.inl i) + have hfirstOrder : ∀ i, + finitePlaceOrderTop v (first i) = + (finitePlaceOrder v rho : WithTop ℤ) := by + intro i + simp only [first, dedekindLocalAuxiliaryFamily] + rw [finitePlaceOrderTop_mul, finitePlaceOrderTop_pow, huOrder, + finitePlaceOrderTop_eq_coe v rho hrhoNe] + simp + have hfirstLower : ∀ i, (finitePlaceOrder v rho : WithTop ℤ) ≤ + finitePlaceOrderTop v (first i) := by + intro i + rw [hfirstOrder i] + obtain ⟨A, hAdet, hdistinct, hlower⟩ := + exists_det_one_dedekindColumnMatrix_negativeOrdersPairwiseDistinct + v hresidue (finitePlaceOrder v rho) first hfirstLower + refine ⟨A, hAdet, ?_, ?_, ?_⟩ + · intro x y hx hy hxy + cases x with + | inl i => + cases y with + | inl j => + apply congrArg Sum.inl + apply hdistinct + · simpa [first] using hx + · simpa [first] using hy + · simpa [first] using hxy + | inr rs => + rw [dedekindCaseITransformedLocalAuxiliaryFamily_inr] at hy + exact (not_lt_of_ge (hgridRegular rs)) hy |>.elim + | inr rs => + rw [dedekindCaseITransformedLocalAuxiliaryFamily_inr] at hx + exact (not_lt_of_ge (hgridRegular rs)) hx |>.elim + · intro i + cases i with + | inl j => simpa [first] using hlower j + | inr rs => + rw [dedekindCaseITransformedLocalAuxiliaryFamily_inr] + exact (show (finitePlaceOrder v rho : WithTop ℤ) ≤ 0 by + exact_mod_cast hrhoOrder.le) |>.trans (hgridRegular rs) + · intro rs + exact dedekindCaseITransformedLocalAuxiliaryFamily_inr + u w rho h k A rs + +/-- Full Dedekind-DVR case (i): determinant-one repeated cancellation on the +first block preserves the original Wronskian and proves the exact +`q * ord(rho)` lower bound. -/ +theorem exists_dedekindLocalAuxiliaryFamily_caseI_q_wronskian_bound + (v : HeightOneSpectrum R) + (hresidue : Function.Surjective + (algebraMap C v.asIdeal.ResidueField)) + (D : Derivation C L L) + (hDIntegral : ∀ r : R, ∃ s : R, + D (algebraMap R L r) = algebraMap R L s) + (u w rho : L) (h k : ℕ) + (epsilonOrder : Sum (Fin k) (Fin (k + 1) × Fin h) → ℕ) + (epsilon q : ℕ) + (hrhoNe : rho ≠ 0) + (huOrder : finitePlaceOrderTop v u = 0) + (hrhoOrder : finitePlaceOrder v rho < 0) + (hgridRegular : ∀ rs : Fin (k + 1) × Fin h, + (0 : WithTop ℤ) ≤ finitePlaceOrderTop v + (u ^ (rs.1 : ℕ) * w ^ (rs.2 : ℕ))) + (hepsilonInjective : Function.Injective epsilonOrder) + (hepsilonMax : ∀ i, epsilonOrder i ≤ epsilon) + (hk : k ≤ epsilon + 1) (hepsilonQ : epsilon + 1 ≤ q) : + ∃ A : Matrix (Fin k) (Fin k) C, + A.det = 1 ∧ + (indexedDedekindLocalWronskian D epsilonOrder + (dedekindCaseITransformedLocalAuxiliaryFamily u w rho h k A)).det = + (indexedDedekindLocalWronskian D epsilonOrder + (dedekindLocalAuxiliaryFamily u w rho h k)).det ∧ + (((q : ℤ) * finitePlaceOrder v rho : ℤ) : WithTop ℤ) ≤ + finitePlaceOrderTop v + (indexedDedekindLocalWronskian D epsilonOrder + (dedekindLocalAuxiliaryFamily u w rho h k)).det := by + obtain ⟨A, hAdet, hdistinct, hlower, hgrid⟩ := + exists_dedekindLocalAuxiliaryFamily_caseI_columnMatrix + v hresidue u w rho h k hrhoNe huOrder hrhoOrder hgridRegular + let f := dedekindLocalAuxiliaryFamily u w rho h k + let B := dedekindCaseIColumnMatrix h k A + let g := dedekindCaseITransformedLocalAuxiliaryFamily u w rho h k A + have hBdet : B.det = 1 := by + rw [dedekindCaseIColumnMatrix_det, hAdet] + have hdet : + (indexedDedekindLocalWronskian D epsilonOrder g).det = + (indexedDedekindLocalWronskian D epsilonOrder f).det := by + exact indexedDedekindLocalWronskian_det_columnCombination_of_det_eq_one + D epsilonOrder f B hBdet + have hcardRho : + finitePlaceOrder v rho ≤ -((Finset.univ.filter fun i => + finitePlaceOrderTop v (g i) < 0).card : ℤ) := + card_negativeFinitePlaceOrders_le_neg v g (finitePlaceOrder v rho) + hrhoOrder.le hdistinct hlower + let firstPoles : Finset (Fin k) := Finset.univ.filter fun i => + finitePlaceOrderTop v (g (Sum.inl i)) < 0 + have hpoles : + (Finset.univ.filter fun i => finitePlaceOrderTop v (g i) < 0) = + firstPoles.map ⟨Sum.inl, Sum.inl_injective⟩ := by + ext x + cases x with + | inl i => simp [firstPoles] + | inr rs => + have hregg : (0 : WithTop ℤ) ≤ + finitePlaceOrderTop v (g (Sum.inr rs)) := by + change (0 : WithTop ℤ) ≤ finitePlaceOrderTop v + (dedekindCaseITransformedLocalAuxiliaryFamily + u w rho h k A (Sum.inr rs)) + rw [hgrid rs] + simpa [dedekindLocalAuxiliaryFamily] using hgridRegular rs + have hrs : ¬ finitePlaceOrderTop v (g (Sum.inr rs)) < 0 := + not_lt_of_ge hregg + simp [firstPoles, hrs] + have hcardEpsilon : + (Finset.univ.filter fun i => finitePlaceOrderTop v (g i) < 0).card ≤ + epsilon + 1 := by + rw [hpoles, Finset.card_map] + exact (Finset.card_filter_le _ _).trans (by simpa using hk) + have hbound := + finitePlaceOrderTop_indexedDedekindLocalWronskian_caseI_q_lower_bound + v D hDIntegral epsilonOrder g (finitePlaceOrder v rho) epsilon q + hdistinct hlower hepsilonInjective hepsilonMax hcardRho hcardEpsilon + hrhoOrder.le hepsilonQ + refine ⟨A, hAdet, hdet, ?_⟩ + rw [← hdet] + exact hbound + +/-- The same endpoint for the source `auxiliaryFamily`, specialized to +`rho = (1-u)/(1-w)`. -/ +theorem exists_dedekindAuxiliaryFamily_caseI_q_wronskian_bound + (v : HeightOneSpectrum R) + (hresidue : Function.Surjective + (algebraMap C v.asIdeal.ResidueField)) + (D : Derivation C L L) + (hDIntegral : ∀ r : R, ∃ s : R, + D (algebraMap R L r) = algebraMap R L s) + (u w : L) (h k : ℕ) + (epsilonOrder : Sum (Fin k) (Fin (k + 1) × Fin h) → ℕ) + (epsilon q : ℕ) + (hrhoNe : (1 - u) / (1 - w) ≠ 0) + (huOrder : finitePlaceOrderTop v u = 0) + (hrhoOrder : finitePlaceOrder v ((1 - u) / (1 - w)) < 0) + (hgridRegular : ∀ rs : Fin (k + 1) × Fin h, + (0 : WithTop ℤ) ≤ finitePlaceOrderTop v + (u ^ (rs.1 : ℕ) * w ^ (rs.2 : ℕ))) + (hepsilonInjective : Function.Injective epsilonOrder) + (hepsilonMax : ∀ i, epsilonOrder i ≤ epsilon) + (hk : k ≤ epsilon + 1) (hepsilonQ : epsilon + 1 ≤ q) : + ∃ A : Matrix (Fin k) (Fin k) C, + A.det = 1 ∧ + (indexedDedekindLocalWronskian D epsilonOrder + (indexedDedekindLocalColumnCombination (auxiliaryFamily u w h k) + (dedekindCaseIColumnMatrix h k A))).det = + (indexedDedekindLocalWronskian D epsilonOrder + (auxiliaryFamily u w h k)).det ∧ + (((q : ℤ) * finitePlaceOrder v ((1 - u) / (1 - w)) : ℤ) : + WithTop ℤ) ≤ + finitePlaceOrderTop v + (indexedDedekindLocalWronskian D epsilonOrder + (auxiliaryFamily u w h k)).det := by + simpa only [dedekindCaseITransformedLocalAuxiliaryFamily, + dedekindLocalAuxiliaryFamily_div_eq_auxiliaryFamily] using + (exists_dedekindLocalAuxiliaryFamily_caseI_q_wronskian_bound + v hresidue D hDIntegral u w ((1 - u) / (1 - w)) h k epsilonOrder + epsilon q hrhoNe huOrder hrhoOrder hgridRegular hepsilonInjective + hepsilonMax hk hepsilonQ) + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/DedekindAuxiliaryLocalCases.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/DedekindAuxiliaryLocalCases.lean new file mode 100644 index 0000000000..94f2e8690f --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/DedekindAuxiliaryLocalCases.lean @@ -0,0 +1,92 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.DedekindAuxiliaryWronskian + +/-! +# Uniformizer-free Dedekind auxiliary cases + +This module packages Corvaja--Zannier local cases (iii) and (iv) using only a +DVR-preserving derivation. The uniformizer needed by the determinant estimate +is chosen internally. In particular, callers do not need an algebra map from +the derivation's constant field into the local DVR. +-/ + +@[expose] public section + +namespace BGS.CorvajaZannier + +noncomputable section + +open scoped BigOperators +open IsDedekindDomain + +variable {C R L : Type*} [Field C] [CommRing R] [IsDedekindDomain R] + [IsDiscreteValuationRing R] [Field L] [Algebra R L] [Algebra C L] + [IsFractionRing R L] + +/-- Uniformizer-free form of source case (iii). -/ +theorem finitePlaceOrderTop_auxiliaryFamily_caseIII_source_lower_bound_of_preserves + (vPlace : HeightOneSpectrum R) + (D : Derivation C L L) + (hDIntegral : ∀ r : R, ∃ s : R, + D (algebraMap R L r) = algebraMap R L s) + (h k : ℕ) (epsilon : Sum (Fin k) (Fin (k + 1) × Fin h) → ℕ) + (u v : L) (hu : u ≠ 0) (hv : v ≠ 0) + (hu1 : u ≠ 1) (hv1 : v ≠ 1) : + (((k * (k - 1) / 2 : ℕ) • finitePlaceOrder vPlace u + + (h * k) • finitePlaceOrder vPlace v + + k • finitePlaceOrder vPlace ((1 - u) / (1 - v)) + + ∑ rs : Fin (k + 1) × Fin h, + finitePlaceOrder vPlace + (u ^ (rs.1 : ℕ) * v ^ (rs.2 : ℕ)) - + ∑ i, (epsilon i : ℤ) : ℤ) : WithTop ℤ) ≤ + finitePlaceOrderTop vPlace + (indexedDedekindLocalWronskian D epsilon + (auxiliaryFamily u v h k)).det := by + obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible R + have hπIdeal : vPlace.asIdeal = Ideal.span {π} := by + calc + vPlace.asIdeal = IsLocalRing.maximalIdeal R := + IsLocalRing.eq_maximalIdeal vPlace.isMaximal + _ = Ideal.span {π} := + (IsDiscreteValuationRing.irreducible_iff_uniformizer π).mp hπ + exact finitePlaceOrderTop_auxiliaryFamily_caseIII_source_lower_bound + vPlace π hπ hπIdeal D hDIntegral h k epsilon u v hu hv hu1 hv1 + +/-- Uniformizer-free form of source case (iv). -/ +theorem finitePlaceOrderTop_auxiliaryFamily_caseIV_source_lower_bound_of_preserves + (vPlace : HeightOneSpectrum R) + (D : Derivation C L L) + (hDIntegral : ∀ r : R, ∃ s : R, + D (algebraMap R L r) = algebraMap R L s) + (h k : ℕ) (epsilon : Sum (Fin k) (Fin (k + 1) × Fin h) → ℕ) + (u v : L) (hu : u ≠ 0) (hv : v ≠ 0) + (hu1 : u ≠ 1) (hv1 : v ≠ 1) : + (((k * (k - 1) / 2 : ℕ) • finitePlaceOrder vPlace u + + k • finitePlaceOrder vPlace ((1 - u) / (1 - v)) + + ∑ rs : Fin (k + 1) × Fin h, + finitePlaceOrder vPlace + (u ^ (rs.1 : ℕ) * v ^ (rs.2 : ℕ)) - + ∑ i, (epsilon i : ℤ) : ℤ) : WithTop ℤ) ≤ + finitePlaceOrderTop vPlace + (indexedDedekindLocalWronskian D epsilon + (auxiliaryFamily u v h k)).det := by + obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible R + have hπIdeal : vPlace.asIdeal = Ideal.span {π} := by + calc + vPlace.asIdeal = IsLocalRing.maximalIdeal R := + IsLocalRing.eq_maximalIdeal vPlace.isMaximal + _ = Ideal.span {π} := + (IsDiscreteValuationRing.irreducible_iff_uniformizer π).mp hπ + exact finitePlaceOrderTop_auxiliaryFamily_caseIV_source_lower_bound + vPlace π hπ hπIdeal D hDIntegral h k epsilon u v hu hv hu1 hv1 + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/DedekindAuxiliaryWronskian.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/DedekindAuxiliaryWronskian.lean new file mode 100644 index 0000000000..9d3dc18c9e --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/DedekindAuxiliaryWronskian.lean @@ -0,0 +1,432 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.DedekindLocalWronskian +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.LocalAuxiliaryWronskian + +/-! +# Auxiliary-family Wronskian estimates at a Dedekind place + +This file transports the algebraic local cases (ii)--(iv) in +Corvaja--Zannier's Proposition 2 from Laurent series to an arbitrary +height-one DVR place. The derivation is only required to preserve the DVR; +no choice of a normalized local parameter is used. + +The case-(iii) column operation is exactly the lower-unitriangular matrix +`caseIIIColumnMatrix`. Consequently the resulting estimates retain the +source terms: the triangular `u` contribution, the `h * k` contribution of +`v`, the `k` copies of the ratio `rho`, the full grid sum, and the loss given +by the sum of the selected derivative orders. + +Source provenance: published pages 1935--1936; checked semantic reconstruction +`Papers/CorvajaZannier2013/CorvajaZannier2013.tex`, lines 636--732. +-/ + +@[expose] public section + +namespace BGS.CorvajaZannier + +noncomputable section + +open scoped Matrix BigOperators +open IsDedekindDomain Multiplicative WithZero + +variable {C R L : Type*} [Field C] [CommRing R] [IsDedekindDomain R] + [IsDiscreteValuationRing R] [Field L] [Algebra C R] [Algebra R L] + [Algebra C L] [IsScalarTower C R L] [IsFractionRing R L] + +/-- The auxiliary family with the ratio column written using an explicit +parameter `rho`. -/ +def dedekindLocalAuxiliaryFamily (u v rho : L) (h k : ℕ) : + Sum (Fin k) (Fin (k + 1) × Fin h) → L + | Sum.inl i => u ^ (i : ℕ) * rho + | Sum.inr rs => u ^ (rs.1 : ℕ) * v ^ (rs.2 : ℕ) + +@[simp] +theorem dedekindLocalAuxiliaryFamily_div_eq_auxiliaryFamily + (u v : L) (h k : ℕ) : + dedekindLocalAuxiliaryFamily u v ((1 - u) / (1 - v)) h k = + auxiliaryFamily u v h k := by + rfl + +/-- The case-(iii) family after replacing each first-block column +`u ^ i * rho` by `u ^ i * v ^ h * rho`. -/ +def dedekindCaseIIIImprovedAuxiliaryFamily (u v rho : L) (h k : ℕ) : + Sum (Fin k) (Fin (k + 1) × Fin h) → L + | Sum.inl i => u ^ (i : ℕ) * v ^ h * rho + | Sum.inr rs => u ^ (rs.1 : ℕ) * v ^ (rs.2 : ℕ) + +private theorem dedekind_caseIII_geometricSeries_column_identity + (u v rho : L) (h j : ℕ) (hrho : (1 - v) * rho = 1 - u) : + u ^ j * rho - u ^ j * (1 - u) * (∑ s ∈ Finset.range h, v ^ s) = + u ^ j * v ^ h * rho := by + rw [← hrho] + calc + u ^ j * rho - u ^ j * ((1 - v) * rho) * + (∑ s ∈ Finset.range h, v ^ s) = + u ^ j * rho - u ^ j * rho * + ((1 - v) * ∑ s ∈ Finset.range h, v ^ s) := by ring + _ = u ^ j * rho - u ^ j * rho * (1 - v ^ h) := by + rw [mul_neg_geom_sum] + _ = u ^ j * v ^ h * rho := by ring + +private theorem dedekind_caseIIIGridCorrection_sum_smul + (u v : L) (h k : ℕ) (i : Fin k) : + (∑ rs : Fin (k + 1) × Fin h, + caseIIIGridCorrection (K := C) h k rs i • + (u ^ (rs.1 : ℕ) * v ^ (rs.2 : ℕ))) = + -(u ^ (i : ℕ) * ∑ s : Fin h, v ^ (s : ℕ)) + + u ^ (i.succ : ℕ) * ∑ s : Fin h, v ^ (s : ℕ) := by + rw [Fintype.sum_prod_type_right] + rw [Finset.mul_sum, Finset.mul_sum, ← Finset.sum_neg_distrib, + ← Finset.sum_add_distrib] + apply Finset.sum_congr rfl + intro s _ + have hne : i.castSucc ≠ i.succ := i.castSucc_lt_succ.ne + simp only [caseIIIGridCorrection] + calc + (∑ r : Fin (k + 1), + (if r = i.castSucc then (-1 : C) + else if r = i.succ then 1 else 0) • + (u ^ (r : ℕ) * v ^ (s : ℕ))) = + (∑ r : Fin (k + 1), + if r = i.castSucc then -(u ^ (r : ℕ) * v ^ (s : ℕ)) else 0) + + ∑ r : Fin (k + 1), + if r = i.succ then u ^ (r : ℕ) * v ^ (s : ℕ) else 0 := by + rw [← Finset.sum_add_distrib] + apply Finset.sum_congr rfl + intro r _ + by_cases hr0 : r = i.castSucc + · simp [hr0, hne] + · by_cases hr1 : r = i.succ + · simp [hr1, hne.symm] + · simp [hr0, hr1] + _ = -(u ^ (i : ℕ) * v ^ (s : ℕ)) + + u ^ (i.succ : ℕ) * v ^ (s : ℕ) := by + rw [Fintype.sum_ite_eq', Fintype.sum_ite_eq'] + simp + +/-- The determinant-one source column operation performs the case-(iii) +replacement over an arbitrary fraction field. -/ +theorem indexedDedekindLocalColumnCombination_caseIIIColumnMatrix + (u v rho : L) (h k : ℕ) (hrho : (1 - v) * rho = 1 - u) : + indexedDedekindLocalColumnCombination + (dedekindLocalAuxiliaryFamily u v rho h k) + (caseIIIColumnMatrix (K := C) h k) = + dedekindCaseIIIImprovedAuxiliaryFamily u v rho h k := by + classical + funext j + cases j with + | inl i => + rw [indexedDedekindLocalColumnCombination, Fintype.sum_sum_type] + simp only [caseIIIColumnMatrix, Matrix.fromBlocks_apply₁₁, + Matrix.fromBlocks_apply₂₁, dedekindLocalAuxiliaryFamily, + dedekindCaseIIIImprovedAuxiliaryFamily] + have hleft : + (∑ x : Fin k, (1 : Matrix (Fin k) (Fin k) C) x i • + (u ^ (x : ℕ) * rho)) = u ^ (i : ℕ) * rho := by + simp [Matrix.one_apply] + rw [hleft, dedekind_caseIIIGridCorrection_sum_smul] + rw [Fin.sum_univ_eq_sum_range] + simp only [Fin.val_succ, pow_succ] + convert dedekind_caseIII_geometricSeries_column_identity + u v rho h (i : ℕ) hrho using 1 + all_goals ring + | inr rs => + rw [indexedDedekindLocalColumnCombination, Fintype.sum_sum_type] + simp [caseIIIColumnMatrix, dedekindLocalAuxiliaryFamily, + dedekindCaseIIIImprovedAuxiliaryFamily, Matrix.one_apply] + +omit [IsDiscreteValuationRing R] [Algebra C R] [IsScalarTower C R L] in +/-- Case (ii): if `u`, `v`, and the ratio are all represented by elements of +the DVR, then the auxiliary Wronskian is regular. -/ +theorem finitePlaceOrderTop_auxiliaryFamily_caseII_nonnegative_of_integral + (vPlace : HeightOneSpectrum R) (D : Derivation C L L) + (hDIntegral : ∀ r : R, ∃ s : R, + D (algebraMap R L r) = algebraMap R L s) + (h k : ℕ) (epsilon : Sum (Fin k) (Fin (k + 1) × Fin h) → ℕ) + (u v : L) + (huIntegral : ∃ u0 : R, u = algebraMap R L u0) + (hvIntegral : ∃ v0 : R, v = algebraMap R L v0) + (hratioIntegral : ∃ rho0 : R, + (1 - u) / (1 - v) = algebraMap R L rho0) : + (0 : WithTop ℤ) ≤ finitePlaceOrderTop vPlace + (indexedDedekindLocalWronskian D epsilon + (auxiliaryFamily u v h k)).det := by + apply finitePlaceOrderTop_indexedDedekindLocalWronskian_det_nonnegative_of_integral + vPlace D hDIntegral epsilon (auxiliaryFamily u v h k) + intro j + obtain ⟨u0, hu⟩ := huIntegral + obtain ⟨v0, hv⟩ := hvIntegral + obtain ⟨rho0, hrho⟩ := hratioIntegral + cases j with + | inl i => + refine ⟨u0 ^ (i : ℕ) * rho0, ?_⟩ + change u ^ (i : ℕ) * ((1 - u) / (1 - v)) = + algebraMap R L (u0 ^ (i : ℕ) * rho0) + rw [hrho, hu, map_mul, map_pow] + | inr rs => + refine ⟨u0 ^ (rs.1 : ℕ) * v0 ^ (rs.2 : ℕ), ?_⟩ + change u ^ (rs.1 : ℕ) * v ^ (rs.2 : ℕ) = + algebraMap R L (u0 ^ (rs.1 : ℕ) * v0 ^ (rs.2 : ℕ)) + rw [hu, hv, map_mul, map_pow, map_pow] + +omit [IsDiscreteValuationRing R] in +private theorem dedekind_finitePlaceOrder_mul + (vPlace : HeightOneSpectrum R) (x y : L) (hx : x ≠ 0) (hy : y ≠ 0) : + finitePlaceOrder vPlace (x * y) = + finitePlaceOrder vPlace x + finitePlaceOrder vPlace y := by + have h := finitePlaceOrderTop_mul vPlace x y + rw [finitePlaceOrderTop_eq_coe vPlace (x * y) (mul_ne_zero hx hy), + finitePlaceOrderTop_eq_coe vPlace x hx, + finitePlaceOrderTop_eq_coe vPlace y hy] at h + exact_mod_cast h + +omit [IsDiscreteValuationRing R] in +private theorem dedekind_finitePlaceOrder_pow + (vPlace : HeightOneSpectrum R) (x : L) (hx : x ≠ 0) (n : ℕ) : + finitePlaceOrder vPlace (x ^ n) = n • finitePlaceOrder vPlace x := by + have h := finitePlaceOrderTop_pow vPlace x n + rw [finitePlaceOrderTop_eq_coe vPlace (x ^ n) (pow_ne_zero n hx), + finitePlaceOrderTop_eq_coe vPlace x hx] at h + exact_mod_cast h + +omit [IsDiscreteValuationRing R] in +private theorem dedekind_finitePlaceOrder_caseIIIImproved_inl + (vPlace : HeightOneSpectrum R) (u v rho : L) (h k : ℕ) (i : Fin k) + (hu : u ≠ 0) (hv : v ≠ 0) (hrho : rho ≠ 0) : + finitePlaceOrder vPlace + (dedekindCaseIIIImprovedAuxiliaryFamily u v rho h k (Sum.inl i)) = + (i : ℕ) • finitePlaceOrder vPlace u + + h • finitePlaceOrder vPlace v + finitePlaceOrder vPlace rho := by + simp only [dedekindCaseIIIImprovedAuxiliaryFamily] + rw [dedekind_finitePlaceOrder_mul vPlace + (u ^ (i : ℕ) * v ^ h) rho + (mul_ne_zero (pow_ne_zero _ hu) (pow_ne_zero _ hv)) hrho, + dedekind_finitePlaceOrder_mul vPlace (u ^ (i : ℕ)) (v ^ h) + (pow_ne_zero _ hu) (pow_ne_zero _ hv), + dedekind_finitePlaceOrder_pow vPlace u hu, + dedekind_finitePlaceOrder_pow vPlace v hv] + +omit [IsDiscreteValuationRing R] in +private theorem dedekind_finitePlaceOrder_localAuxiliary_inl + (vPlace : HeightOneSpectrum R) (u v rho : L) (h k : ℕ) (i : Fin k) + (hu : u ≠ 0) (hrho : rho ≠ 0) : + finitePlaceOrder vPlace + (dedekindLocalAuxiliaryFamily u v rho h k (Sum.inl i)) = + (i : ℕ) • finitePlaceOrder vPlace u + finitePlaceOrder vPlace rho := by + simp only [dedekindLocalAuxiliaryFamily] + rw [dedekind_finitePlaceOrder_mul vPlace (u ^ (i : ℕ)) rho + (pow_ne_zero _ hu) hrho, + dedekind_finitePlaceOrder_pow vPlace u hu] + +private theorem dedekind_sum_fin_cast_int (k : ℕ) : + (∑ i : Fin k, (i : ℤ)) = (k * (k - 1) / 2 : ℕ) := by + rw [Fin.sum_univ_eq_sum_range, ← Nat.cast_sum, Finset.sum_range_id] + +omit [IsDiscreteValuationRing R] in +private theorem dedekind_sum_caseIIIImproved_inl_orders + (vPlace : HeightOneSpectrum R) (u v rho : L) (h k : ℕ) + (hu : u ≠ 0) (hv : v ≠ 0) (hrho : rho ≠ 0) : + (∑ i : Fin k, finitePlaceOrder vPlace + (dedekindCaseIIIImprovedAuxiliaryFamily u v rho h k (Sum.inl i))) = + (k * (k - 1) / 2 : ℕ) • finitePlaceOrder vPlace u + + (h * k) • finitePlaceOrder vPlace v + + k • finitePlaceOrder vPlace rho := by + simp_rw [dedekind_finitePlaceOrder_caseIIIImproved_inl + vPlace u v rho h k _ hu hv hrho] + simp only [Finset.sum_add_distrib, Finset.sum_const, + Finset.card_univ, Fintype.card_fin] + simp_rw [nsmul_eq_mul] + rw [← Finset.sum_mul, dedekind_sum_fin_cast_int] + simp only [Nat.cast_mul] + ring + +omit [IsDiscreteValuationRing R] in +private theorem dedekind_sum_localAuxiliary_inl_orders + (vPlace : HeightOneSpectrum R) (u v rho : L) (h k : ℕ) + (hu : u ≠ 0) (hrho : rho ≠ 0) : + (∑ i : Fin k, finitePlaceOrder vPlace + (dedekindLocalAuxiliaryFamily u v rho h k (Sum.inl i))) = + (k * (k - 1) / 2 : ℕ) • finitePlaceOrder vPlace u + + k • finitePlaceOrder vPlace rho := by + simp_rw [dedekind_finitePlaceOrder_localAuxiliary_inl + vPlace u v rho h k _ hu hrho] + simp only [Finset.sum_add_distrib, Finset.sum_const, + Finset.card_univ, Fintype.card_fin] + simp_rw [nsmul_eq_mul] + rw [← Finset.sum_mul, dedekind_sum_fin_cast_int] + +private theorem dedekind_coe_sum_int + {ι : Type*} [Fintype ι] (g : ι → ℤ) : + (((∑ i, g i : ℤ) : ℤ) : WithTop ℤ) = + ∑ i, ((g i : ℤ) : WithTop ℤ) := by + classical + induction (Finset.univ : Finset ι) using Finset.induction_on with + | empty => simp + | @insert a s ha ih => simp [ha, ih, WithTop.coe_add] + +omit [Algebra C R] [IsScalarTower C R L] in +/-- Case (iii) at a Dedekind DVR place, in the displayed source form. The +grid contribution is retained as the exact sum that cancels under the global +product formula. -/ +theorem finitePlaceOrderTop_indexedDedekindLocalWronskian_caseIII_source_lower_bound + (vPlace : HeightOneSpectrum R) (pi : R) (hpi : Irreducible pi) + (hpiIdeal : vPlace.asIdeal = Ideal.span {pi}) + (D : Derivation C L L) + (hDIntegral : ∀ r : R, ∃ s : R, + D (algebraMap R L r) = algebraMap R L s) + (h k : ℕ) (epsilon : Sum (Fin k) (Fin (k + 1) × Fin h) → ℕ) + (u v rho : L) (hrhoIdentity : (1 - v) * rho = 1 - u) + (hu : u ≠ 0) (hv : v ≠ 0) (hrho : rho ≠ 0) : + (((k * (k - 1) / 2 : ℕ) • finitePlaceOrder vPlace u + + (h * k) • finitePlaceOrder vPlace v + + k • finitePlaceOrder vPlace rho + + ∑ rs : Fin (k + 1) × Fin h, + finitePlaceOrder vPlace + (u ^ (rs.1 : ℕ) * v ^ (rs.2 : ℕ)) - + ∑ i, (epsilon i : ℤ) : ℤ) : WithTop ℤ) ≤ + finitePlaceOrderTop vPlace + (indexedDedekindLocalWronskian D epsilon + (dedekindLocalAuxiliaryFamily u v rho h k)).det := by + have hbound := + finitePlaceOrderTop_indexedDedekindLocalWronskian_det_lower_bound_of_preserves + vPlace pi hpi hpiIdeal D hDIntegral epsilon + (dedekindCaseIIIImprovedAuxiliaryFamily u v rho h k) + have hdet : + (indexedDedekindLocalWronskian D epsilon + (dedekindCaseIIIImprovedAuxiliaryFamily u v rho h k)).det = + (indexedDedekindLocalWronskian D epsilon + (dedekindLocalAuxiliaryFamily u v rho h k)).det := by + rw [← indexedDedekindLocalColumnCombination_caseIIIColumnMatrix (C := C) + u v rho h k hrhoIdentity] + exact indexedDedekindLocalWronskian_det_columnCombination_of_det_eq_one + D epsilon (dedekindLocalAuxiliaryFamily u v rho h k) + (caseIIIColumnMatrix (K := C) h k) (caseIIIColumnMatrix_det h k) + rw [hdet] at hbound + rw [Fintype.sum_sum_type] at hbound + simp only [dedekindCaseIIIImprovedAuxiliaryFamily] at hbound + simp_rw [finitePlaceOrderTop_eq_coe vPlace _ + (mul_ne_zero (mul_ne_zero (pow_ne_zero _ hu) (pow_ne_zero _ hv)) hrho)] + at hbound + simp_rw [finitePlaceOrderTop_eq_coe vPlace _ + (mul_ne_zero (pow_ne_zero _ hu) (pow_ne_zero _ hv))] at hbound + rw [← dedekind_coe_sum_int, ← dedekind_coe_sum_int] at hbound + have hfirst : + (∑ i : Fin k, finitePlaceOrder vPlace (u ^ (i : ℕ) * v ^ h * rho)) = + (k * (k - 1) / 2 : ℕ) • finitePlaceOrder vPlace u + + (h * k) • finitePlaceOrder vPlace v + + k • finitePlaceOrder vPlace rho := by + simpa only [dedekindCaseIIIImprovedAuxiliaryFamily] using + dedekind_sum_caseIIIImproved_inl_orders + vPlace u v rho h k hu hv hrho + rw [hfirst] at hbound + exact_mod_cast hbound + +omit [Algebra C R] [IsScalarTower C R L] in +/-- Case (iv) at a Dedekind DVR place, in the displayed source form. -/ +theorem finitePlaceOrderTop_indexedDedekindLocalWronskian_caseIV_source_lower_bound + (vPlace : HeightOneSpectrum R) (pi : R) (hpi : Irreducible pi) + (hpiIdeal : vPlace.asIdeal = Ideal.span {pi}) + (D : Derivation C L L) + (hDIntegral : ∀ r : R, ∃ s : R, + D (algebraMap R L r) = algebraMap R L s) + (h k : ℕ) (epsilon : Sum (Fin k) (Fin (k + 1) × Fin h) → ℕ) + (u v rho : L) (hu : u ≠ 0) (hv : v ≠ 0) (hrho : rho ≠ 0) : + (((k * (k - 1) / 2 : ℕ) • finitePlaceOrder vPlace u + + k • finitePlaceOrder vPlace rho + + ∑ rs : Fin (k + 1) × Fin h, + finitePlaceOrder vPlace + (u ^ (rs.1 : ℕ) * v ^ (rs.2 : ℕ)) - + ∑ i, (epsilon i : ℤ) : ℤ) : WithTop ℤ) ≤ + finitePlaceOrderTop vPlace + (indexedDedekindLocalWronskian D epsilon + (dedekindLocalAuxiliaryFamily u v rho h k)).det := by + have hbound := + finitePlaceOrderTop_indexedDedekindLocalWronskian_det_lower_bound_of_preserves + vPlace pi hpi hpiIdeal D hDIntegral epsilon + (dedekindLocalAuxiliaryFamily u v rho h k) + rw [Fintype.sum_sum_type] at hbound + simp only [dedekindLocalAuxiliaryFamily] at hbound + simp_rw [finitePlaceOrderTop_eq_coe vPlace _ + (mul_ne_zero (pow_ne_zero _ hu) hrho)] at hbound + simp_rw [finitePlaceOrderTop_eq_coe vPlace _ + (mul_ne_zero (pow_ne_zero _ hu) (pow_ne_zero _ hv))] at hbound + rw [← dedekind_coe_sum_int, ← dedekind_coe_sum_int] at hbound + have hfirst : + (∑ i : Fin k, finitePlaceOrder vPlace (u ^ (i : ℕ) * rho)) = + (k * (k - 1) / 2 : ℕ) • finitePlaceOrder vPlace u + + k • finitePlaceOrder vPlace rho := by + simpa only [dedekindLocalAuxiliaryFamily] using + dedekind_sum_localAuxiliary_inl_orders + vPlace u v rho h k hu hrho + rw [hfirst] at hbound + exact_mod_cast hbound + +omit [Algebra C R] [IsScalarTower C R L] in +/-- Case (iii) connected to the exact Corvaja--Zannier auxiliary family. -/ +theorem finitePlaceOrderTop_auxiliaryFamily_caseIII_source_lower_bound + (vPlace : HeightOneSpectrum R) (pi : R) (hpi : Irreducible pi) + (hpiIdeal : vPlace.asIdeal = Ideal.span {pi}) + (D : Derivation C L L) + (hDIntegral : ∀ r : R, ∃ s : R, + D (algebraMap R L r) = algebraMap R L s) + (h k : ℕ) (epsilon : Sum (Fin k) (Fin (k + 1) × Fin h) → ℕ) + (u v : L) (hu : u ≠ 0) (hv : v ≠ 0) + (hu1 : u ≠ 1) (hv1 : v ≠ 1) : + (((k * (k - 1) / 2 : ℕ) • finitePlaceOrder vPlace u + + (h * k) • finitePlaceOrder vPlace v + + k • finitePlaceOrder vPlace ((1 - u) / (1 - v)) + + ∑ rs : Fin (k + 1) × Fin h, + finitePlaceOrder vPlace + (u ^ (rs.1 : ℕ) * v ^ (rs.2 : ℕ)) - + ∑ i, (epsilon i : ℤ) : ℤ) : WithTop ℤ) ≤ + finitePlaceOrderTop vPlace + (indexedDedekindLocalWronskian D epsilon + (auxiliaryFamily u v h k)).det := by + have hden : 1 - v ≠ 0 := sub_ne_zero.mpr hv1.symm + have hnum : 1 - u ≠ 0 := sub_ne_zero.mpr hu1.symm + have hratio : (1 - u) / (1 - v) ≠ 0 := div_ne_zero hnum hden + have hclear : (1 - v) * ((1 - u) / (1 - v)) = 1 - u := by + field_simp + simpa only [dedekindLocalAuxiliaryFamily_div_eq_auxiliaryFamily] using + finitePlaceOrderTop_indexedDedekindLocalWronskian_caseIII_source_lower_bound + vPlace pi hpi hpiIdeal D hDIntegral h k epsilon u v + ((1 - u) / (1 - v)) hclear hu hv hratio + +omit [Algebra C R] [IsScalarTower C R L] in +/-- Case (iv) connected to the exact Corvaja--Zannier auxiliary family. -/ +theorem finitePlaceOrderTop_auxiliaryFamily_caseIV_source_lower_bound + (vPlace : HeightOneSpectrum R) (pi : R) (hpi : Irreducible pi) + (hpiIdeal : vPlace.asIdeal = Ideal.span {pi}) + (D : Derivation C L L) + (hDIntegral : ∀ r : R, ∃ s : R, + D (algebraMap R L r) = algebraMap R L s) + (h k : ℕ) (epsilon : Sum (Fin k) (Fin (k + 1) × Fin h) → ℕ) + (u v : L) (hu : u ≠ 0) (hv : v ≠ 0) + (hu1 : u ≠ 1) (hv1 : v ≠ 1) : + (((k * (k - 1) / 2 : ℕ) • finitePlaceOrder vPlace u + + k • finitePlaceOrder vPlace ((1 - u) / (1 - v)) + + ∑ rs : Fin (k + 1) × Fin h, + finitePlaceOrder vPlace + (u ^ (rs.1 : ℕ) * v ^ (rs.2 : ℕ)) - + ∑ i, (epsilon i : ℤ) : ℤ) : WithTop ℤ) ≤ + finitePlaceOrderTop vPlace + (indexedDedekindLocalWronskian D epsilon + (auxiliaryFamily u v h k)).det := by + have hden : 1 - v ≠ 0 := sub_ne_zero.mpr hv1.symm + have hnum : 1 - u ≠ 0 := sub_ne_zero.mpr hu1.symm + have hratio : (1 - u) / (1 - v) ≠ 0 := div_ne_zero hnum hden + simpa only [dedekindLocalAuxiliaryFamily_div_eq_auxiliaryFamily] using + finitePlaceOrderTop_indexedDedekindLocalWronskian_caseIV_source_lower_bound + vPlace pi hpi hpiIdeal D hDIntegral h k epsilon u v + ((1 - u) / (1 - v)) hu hv hratio + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/DedekindCanonicalDifferentScaling.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/DedekindCanonicalDifferentScaling.lean new file mode 100644 index 0000000000..6a77c95cd3 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/DedekindCanonicalDifferentScaling.lean @@ -0,0 +1,203 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.DedekindDifferentKaehler +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.DedekindRamifiedDerivationScaling + +/-! +# Canonical different scalings at Dedekind places + +This file removes the explicit comparison hypothesis between the trace +different and the Kähler differentials from the finite- and infinite-place +derivation-scaling certificates. + +The different need not be principal globally. At a prescribed height-one +place `v`, Dedekind approximation supplies a global element `δ` in the +different whose principal ideal has exactly the same `v`-multiplicity. Thus +`δ` is a generator after localization at `v`. The theorem that the different +annihilates relative Kähler differentials then makes `δ` a derivation-clearing +factor. No local power basis or finiteness assertion for a map between two +independently localized rings is used. +-/ + +@[expose] public section + +attribute [local instance] FractionRing.liftAlgebra + FractionRing.isScalarTower_liftAlgebra + +open IsDedekindDomain + +namespace BGS.CorvajaZannier + +noncomputable section + +/-- Every nonzero ideal in a Dedekind domain admits, at a prescribed height-one +place, a global element which generates that ideal after localization. -/ +theorem exists_element_locally_generating_ideal + {R : Type*} [CommRing R] [IsDedekindDomain R] + (I : Ideal R) (hI : I ≠ ⊥) (v : HeightOneSpectrum R) : + ∃ a : R, a ≠ 0 ∧ a ∈ I ∧ + multiplicity v.asIdeal (Ideal.span {a}) = + multiplicity v.asIdeal I := by + have hprod : v.asIdeal * I ≠ ⊥ := mul_ne_zero v.ne_bot hI + obtain ⟨a, ha⟩ := IsDedekindDomain.exists_sup_span_eq + (I := v.asIdeal * I) (J := I) Ideal.mul_le_right hprod + have ha0 : a ≠ 0 := by + intro ha_zero + have hprod_eq : v.asIdeal * I = I := by + simpa [ha_zero] using ha + have hmult := congrArg (multiplicity v.asIdeal) hprod_eq + rw [multiplicity_mul v.prime + (FiniteMultiplicity.of_prime_left v.prime hprod), + multiplicity_self (FiniteMultiplicity.of_prime_left v.prime v.ne_bot)] at hmult + omega + have hspan0 : Ideal.span {a} ≠ ⊥ := by + simpa [Ideal.span_singleton_eq_bot] using ha0 + have ha_mem : a ∈ I := by + rw [← Ideal.span_singleton_le_iff_mem] + rw [← ha] + exact le_sup_right + have hsup := v.multiplicity_sup hprod hspan0 + rw [ha, multiplicity_mul v.prime + (FiniteMultiplicity.of_prime_left v.prime hprod), + multiplicity_self (FiniteMultiplicity.of_prime_left v.prime v.ne_bot)] at hsup + have hmult : multiplicity v.asIdeal (Ideal.span {a}) = + multiplicity v.asIdeal I := by + by_cases hle : multiplicity v.asIdeal (Ideal.span {a}) ≤ + 1 + multiplicity v.asIdeal I + · rw [min_eq_right hle] at hsup + exact hsup.symm + · have hle' : 1 + multiplicity v.asIdeal I ≤ + multiplicity v.asIdeal (Ideal.span {a}) := by omega + rw [min_eq_left hle'] at hsup + omega + exact ⟨a, ha0, ha_mem, hmult⟩ + +/-- At every height-one place, a global element locally generates the +different and clears the obstruction to preserving the integral closure. -/ +theorem exists_finitePlace_different_localGenerator_scaling_certificate + {C S T U F : Type*} + [CommRing C] [CommRing S] [CommRing T] [CommRing U] + [Algebra C S] [Algebra C T] [Algebra S T] + [Algebra C U] [Algebra S U] [Algebra T U] + [IsScalarTower C S T] [IsScalarTower C S U] + [IsScalarTower C T U] [IsScalarTower S T U] + [IsDomain S] [IsIntegrallyClosed S] [IsDedekindDomain T] + [Module.IsTorsionFree S T] [Module.Finite S T] [Module.Free S T] + [Algebra.IsSeparable (FractionRing S) (FractionRing T)] + [Field F] [Algebra T F] [IsFractionRing T F] + (v : HeightOneSpectrum T) + (D : Derivation C S S) (E : Derivation C U U) + (hE : ∀ s : S, E (algebraMap S U s) = algebraMap S U (D s)) : + ∃ δ : T, + δ ≠ 0 ∧ + δ ∈ differentIdeal S T ∧ + multiplicity v.asIdeal (Ideal.span {δ}) = + multiplicity v.asIdeal (differentIdeal S T) ∧ + finitePlaceOrder v (algebraMap T F δ) = + (multiplicity v.asIdeal (differentIdeal S T) : ℤ) ∧ + δ ∈ kaehlerDifferentialAnnihilator S T ∧ + ∀ t : T, ∃ t' : T, + algebraMap T U δ * E (algebraMap T U t) = algebraMap T U t' := by + have hDifferent : differentIdeal S T ≠ ⊥ := + differentIdeal_ne_bot (A := S) (B := T) + obtain ⟨δ, hδ, hδmem, hδmult⟩ := + exists_element_locally_generating_ideal (differentIdeal S T) hDifferent v + have hDifferentKaehler : + differentIdeal S T ≤ kaehlerDifferentialAnnihilator S T := by + simpa [kaehlerDifferentialAnnihilator] using + (differentIdeal_le_kaehlerDifferentialAnnihilator (A := S) (B := T)) + have hδann : δ ∈ kaehlerDifferentialAnnihilator S T := + hDifferentKaehler hδmem + have hδorder : + finitePlaceOrder v (algebraMap T F δ) = + (multiplicity v.asIdeal (differentIdeal S T) : ℤ) := by + rw [finitePlaceOrder_algebraMap_eq_multiplicity v δ hδ, hδmult] + exact ⟨δ, hδ, hδmem, hδmult, hδorder, hδann, + scaled_ambientDerivation_preserves_of_mem_kaehlerDifferentialAnnihilator + D E hE δ hδann⟩ + +/-- At a place over the pole of the reciprocal parameter `s`, the scalar +`-δ/s²` has order equal to the different multiplicity minus twice the +ramification index and makes the reparameterized derivation integral. -/ +theorem exists_infinity_different_localGenerator_scaling_certificate + {C S T L : Type*} + [CommRing C] [CommRing S] [CommRing T] [Field L] + [Algebra C S] [Algebra C T] [Algebra S T] + [Algebra C L] [Algebra S L] [Algebra T L] + [IsScalarTower C S T] [IsScalarTower C S L] + [IsScalarTower C T L] [IsScalarTower S T L] + [IsDomain S] [IsIntegrallyClosed S] [IsDedekindDomain T] + [Module.IsTorsionFree S T] [Module.Finite S T] [Module.Free S T] + [Algebra.IsSeparable (FractionRing S) (FractionRing T)] + [IsFractionRing T L] + (p : HeightOneSpectrum S) (v : HeightOneSpectrum T) + [v.asIdeal.LiesOver p.asIdeal] + (s : S) (hs : s ≠ 0) (hspan : p.asIdeal = Ideal.span {s}) + (Ds : Derivation C S S) (Es DX : Derivation C L L) + (hEs : ∀ r : S, Es (algebraMap S L r) = algebraMap S L (Ds r)) + (hDX : DX = (-(algebraMap S L s) ^ 2) • Es) : + ∃ δ : T, + δ ≠ 0 ∧ + δ ∈ differentIdeal S T ∧ + multiplicity v.asIdeal (Ideal.span {δ}) = + multiplicity v.asIdeal (differentIdeal S T) ∧ + let c : L := -(algebraMap T L δ) / (algebraMap S L s) ^ 2 + finitePlaceOrder v c = + (multiplicity v.asIdeal (differentIdeal S T) : ℤ) - + 2 * (v.asIdeal.ramificationIdx S : ℤ) ∧ + ∀ t : T, ∃ t' : T, + c * DX (algebraMap T L t) = algebraMap T L t' := by + obtain ⟨δ, hδ, hδmem, hδmult, hδorder, _hδann, hδpreserves⟩ := + exists_finitePlace_different_localGenerator_scaling_certificate + (U := L) (F := L) v Ds Es hEs + refine ⟨δ, hδ, hδmem, hδmult, ?_, ?_⟩ + · have hsT : algebraMap S T s ≠ 0 := by + simpa using (FaithfulSMul.algebraMap_injective S T).ne hs + have hsL : algebraMap S L s ≠ 0 := by + rw [IsScalarTower.algebraMap_apply S T L] + simpa using (IsFractionRing.injective T L).ne hsT + have hδL : algebraMap T L δ ≠ 0 := by + simpa using (IsFractionRing.injective T L).ne hδ + have hsOrder : + finitePlaceOrder v (algebraMap S L s) = + (v.asIdeal.ramificationIdx S : ℤ) := by + simpa only [IsScalarTower.algebraMap_apply S T L] using + finitePlaceOrder_algebraMap_uniformizer_eq_ramificationIdx + (F := L) p v s hs hspan + rw [div_eq_mul_inv, + finitePlaceOrder_mul_eq_add v + (-(algebraMap T L δ)) (((algebraMap S L s) ^ 2)⁻¹) + (neg_ne_zero.mpr hδL) (inv_ne_zero (pow_ne_zero 2 hsL)), + finitePlaceOrder_neg_eq v (algebraMap T L δ) hδL, + finitePlaceOrder_inv_eq_neg' v ((algebraMap S L s) ^ 2) + (pow_ne_zero 2 hsL)] + have hsSquareOrder := finitePlaceOrder_mul_eq_add v + (algebraMap S L s) (algebraMap S L s) hsL hsL + rw [← pow_two] at hsSquareOrder + rw [hδorder, hsSquareOrder, hsOrder] + ring + · intro t + obtain ⟨t', ht'⟩ := hδpreserves t + refine ⟨t', ?_⟩ + have hsT : algebraMap S T s ≠ 0 := by + simpa using (FaithfulSMul.algebraMap_injective S T).ne hs + have hsL : algebraMap S L s ≠ 0 := by + rw [IsScalarTower.algebraMap_apply S T L] + simpa using (IsFractionRing.injective T L).ne hsT + rw [hDX, Derivation.smul_apply, Algebra.smul_def] + calc + (-(algebraMap T L δ) / (algebraMap S L s) ^ 2) * + (-(algebraMap S L s) ^ 2 * Es (algebraMap T L t)) = + algebraMap T L δ * Es (algebraMap T L t) := by + field_simp + _ = algebraMap T L t' := ht' + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/DedekindDifferentDivisor.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/DedekindDifferentDivisor.lean new file mode 100644 index 0000000000..537ad20717 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/DedekindDifferentDivisor.lean @@ -0,0 +1,323 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.DedekindLocalDerivationExtension +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.DedekindPlaceOrder +public import Mathlib.RingTheory.Discriminant +public import Mathlib.Data.Finsupp.Order + +/-! +# The different divisor and the primitive-element derivative + +For a finite separable extension represented by an integral primitive element, +the different ideal divides the principal ideal generated by the derivative of +the integral minimal polynomial. This file packages that fact at four levels: + +* effective finitely supported divisors of nonzero Dedekind ideals; +* coefficientwise and arbitrary nonnegative weighted bounds for the different; +* the corresponding local finite-place order inequality; and +* the field norm identity relating the derivative to the power-basis + discriminant. + +Thus all ramified finite-place contributions represented by the different are +controlled by one principal divisor. No canonical-divisor or genus estimate is +assumed here. +-/ + +@[expose] public section + +open scoped nonZeroDivisors +open IsDedekindDomain Polynomial + +namespace BGS.CorvajaZannier + +noncomputable section + +attribute [local instance] FractionRing.liftAlgebra + FractionRing.isScalarTower_liftAlgebra + +section IdealDivisor + +variable {R : Type*} [CommRing R] [IsDedekindDomain R] + +/-- The effective divisor associated to a nonzero integral ideal of a Dedekind domain. -/ +def idealMultiplicityDivisor (I : Ideal R) (hI : I ≠ ⊥) : + HeightOneSpectrum R →₀ Nat := + let h := Ideal.finite_factors hI + Finsupp.mk h.toFinset (fun v => multiplicity v.asIdeal I) (fun v => by + rw [h.mem_toFinset, Set.mem_ofPred_eq] + simpa [Nat.pos_iff_ne_zero] using + (dvd_iff_multiplicity_pos (FiniteMultiplicity.of_prime_left v.prime hI)).symm) + +@[simp] +theorem idealMultiplicityDivisor_apply (I : Ideal R) (hI : I ≠ ⊥) + (v : HeightOneSpectrum R) : + idealMultiplicityDivisor I hI v = multiplicity v.asIdeal I := by + simp [idealMultiplicityDivisor] + +theorem idealMultiplicityDivisor_mono + {I J : Ideal R} (hI : I ≠ ⊥) (hJ : J ≠ ⊥) (h : J <= I) : + idealMultiplicityDivisor I hI <= idealMultiplicityDivisor J hJ := by + intro v + simp only [idealMultiplicityDivisor_apply] + exact v.multiplicity_le_of_ideal_ge h hJ + +theorem idealMultiplicityDivisor_weightedSum_mono + {I J : Ideal R} (hI : I ≠ ⊥) (hJ : J ≠ ⊥) (h : J <= I) + (weight : HeightOneSpectrum R -> Nat) : + (idealMultiplicityDivisor I hI).sum (fun v e => e * weight v) <= + (idealMultiplicityDivisor J hJ).sum (fun v e => e * weight v) := by + classical + apply Finsupp.sum_le_sum_index (idealMultiplicityDivisor_mono hI hJ h) + · intro v _ a b hab + exact Nat.mul_le_mul_right (weight v) hab + · simp + +end IdealDivisor + +section DifferentDivisor + +variable (A B : Type*) [CommRing A] [CommRing B] + [IsDomain A] [IsDedekindDomain B] [Algebra A B] + [Module.IsTorsionFree A B] + +/-- The effective different divisor of a finite separable Dedekind extension. -/ +def differentMultiplicityDivisor (hDifferent : differentIdeal A B ≠ ⊥) : + HeightOneSpectrum B →₀ Nat := + idealMultiplicityDivisor (differentIdeal A B) hDifferent + +@[simp] +theorem differentMultiplicityDivisor_apply + (hDifferent : differentIdeal A B ≠ ⊥) (v : HeightOneSpectrum B) : + differentMultiplicityDivisor A B hDifferent v = + multiplicity v.asIdeal (differentIdeal A B) := by + simp [differentMultiplicityDivisor] + +end DifferentDivisor + +section PrimitiveDifferent + +variable {A K L B : Type*} + [CommRing A] [Field K] [CommRing B] [Field L] + [Algebra A K] [Algebra B L] [Algebra A B] [Algebra K L] [Algebra A L] + [IsScalarTower A K L] [IsScalarTower A B L] + [IsDomain A] [IsFractionRing A K] [FiniteDimensional K L] + [Algebra.IsSeparable K L] [IsIntegralClosure B A L] + [IsIntegrallyClosed A] [IsDedekindDomain B] + [Module.IsTorsionFree A B] + +include K L in +omit [FiniteDimensional K L] [Module.IsTorsionFree A B] in +/-- In a separable function-field extension, the integral minimal-polynomial +derivative of every integral element is nonzero. -/ +theorem minpolyDerivative_ne_zero (x : B) : + aeval x (derivative (minpoly A x)) ≠ 0 := by + have hne : + aeval (algebraMap B L x) + (derivative (minpoly K (algebraMap B L x))) ≠ 0 := + (Algebra.IsSeparable.isSeparable _ _).aeval_derivative_ne_zero + (minpoly.aeval K (algebraMap B L x)) + have hmap : algebraMap B L (aeval x (derivative (minpoly A x))) ≠ 0 := by + rwa [minpoly.isIntegrallyClosed_eq_field_fractions K L + (IsIntegralClosure.isIntegral A L x), derivative_map, + aeval_map_algebraMap, aeval_algebraMap_apply] at hne + exact fun hzero => hmap (by simp [hzero]) + +include K L in +omit [FiniteDimensional K L] [Module.IsTorsionFree A B] in +theorem minpolyDerivative_span_ne_bot (x : B) : + Ideal.span {aeval x (derivative (minpoly A x))} ≠ ⊥ := by + rw [ne_eq, Ideal.span_singleton_eq_bot] + exact minpolyDerivative_ne_zero (A := A) (K := K) (L := L) x + +/-- A separable primitive element supplies a nonzero element of the different, +so the different ideal itself is nonzero. -/ +theorem differentIdeal_ne_bot_of_primitiveElement + (x : B) (hx : Algebra.adjoin K {algebraMap B L x} = ⊤) : + differentIdeal A B ≠ ⊥ := by + intro hDifferent + have hmem := aeval_derivative_mem_differentIdeal A K L x hx + rw [hDifferent, Ideal.mem_bot] at hmem + exact minpolyDerivative_ne_zero (A := A) (K := K) (L := L) x hmem + +/-- The different divides the principal ideal generated by the derivative of a +primitive element's integral minimal polynomial. -/ +theorem differentIdeal_dvd_minpolyDerivativeSpan + (x : B) (hx : Algebra.adjoin K {algebraMap B L x} = ⊤) : + differentIdeal A B ∣ + Ideal.span {aeval x (derivative (minpoly A x))} := by + rw [Ideal.dvd_iff_le, Ideal.span_singleton_le_iff_mem] + exact aeval_derivative_mem_differentIdeal A K L x hx + +/-- At every finite prime, the different exponent is bounded by the order of +the primitive element's minimal-polynomial derivative. -/ +theorem differentIdeal_multiplicity_le_minpolyDerivativeSpan + (x : B) (hx : Algebra.adjoin K {algebraMap B L x} = ⊤) + (v : HeightOneSpectrum B) : + multiplicity v.asIdeal (differentIdeal A B) <= + multiplicity v.asIdeal + (Ideal.span {aeval x (derivative (minpoly A x))}) := by + apply v.multiplicity_le_of_ideal_ge + · exact Ideal.dvd_iff_le.mp (differentIdeal_dvd_minpolyDerivativeSpan x hx) + · exact minpolyDerivative_span_ne_bot (A := A) (K := K) (L := L) x + +theorem differentPrime_dvd_minpolyDerivativeSpan + (x : B) (hx : Algebra.adjoin K {algebraMap B L x} = ⊤) + (v : HeightOneSpectrum B) + (hv : v.asIdeal ∣ differentIdeal A B) : + v.asIdeal ∣ Ideal.span {aeval x (derivative (minpoly A x))} := + hv.trans (differentIdeal_dvd_minpolyDerivativeSpan x hx) + +end PrimitiveDifferent + +section DifferentFinsuppBound + +variable {A K L B : Type*} + [CommRing A] [Field K] [CommRing B] [Field L] + [Algebra A K] [Algebra B L] [Algebra A B] [Algebra K L] [Algebra A L] + [IsScalarTower A K L] [IsScalarTower A B L] + [IsDomain A] [IsIntegrallyClosed A] [IsDedekindDomain B] + [IsFractionRing A K] [FiniteDimensional K L] + [Algebra.IsSeparable K L] [IsIntegralClosure B A L] + [Module.IsTorsionFree A B] + +theorem differentMultiplicityDivisor_le_minpolyDerivativeDivisor + (x : B) (hx : Algebra.adjoin K {algebraMap B L x} = ⊤) : + differentMultiplicityDivisor A B + (differentIdeal_ne_bot_of_primitiveElement + (A := A) (K := K) (L := L) (B := B) x hx) <= + idealMultiplicityDivisor + (Ideal.span {aeval x (derivative (minpoly A x))}) + (minpolyDerivative_span_ne_bot + (A := A) (K := K) (L := L) (B := B) x) := by + intro v + simp only [differentMultiplicityDivisor_apply, + idealMultiplicityDivisor_apply] + exact differentIdeal_multiplicity_le_minpolyDerivativeSpan + (A := A) (K := K) (L := L) (B := B) x hx v + +theorem differentMultiplicityWeightedSum_le_minpolyDerivative + (x : B) (hx : Algebra.adjoin K {algebraMap B L x} = ⊤) + (weight : HeightOneSpectrum B -> Nat) : + (differentMultiplicityDivisor A B + (differentIdeal_ne_bot_of_primitiveElement + (A := A) (K := K) (L := L) (B := B) x hx)).sum + (fun v e => e * weight v) <= + (idealMultiplicityDivisor + (Ideal.span {aeval x (derivative (minpoly A x))}) + (minpolyDerivative_span_ne_bot + (A := A) (K := K) (L := L) (B := B) x)).sum + (fun v e => e * weight v) := by + classical + apply Finsupp.sum_le_sum_index + (differentMultiplicityDivisor_le_minpolyDerivativeDivisor + (A := A) (K := K) (L := L) (B := B) x hx) + · intro v _ a b hab + exact Nat.mul_le_mul_right (weight v) hab + · simp + +theorem finite_differentPrimes_of_primitiveElement + (x : B) (hx : Algebra.adjoin K {algebraMap B L x} = ⊤) : + {v : HeightOneSpectrum B | + v.asIdeal ∣ differentIdeal A B}.Finite := by + apply Set.Finite.subset + (Ideal.finite_factors (minpolyDerivative_span_ne_bot + (A := A) (K := K) (L := L) (B := B) x)) + intro v hv + exact differentPrime_dvd_minpolyDerivativeSpan + (A := A) (K := K) (L := L) (B := B) x hx v hv + +end DifferentFinsuppBound + +section LocalOrder + +variable {R F : Type*} [CommRing R] [IsDedekindDomain R] + [Field F] [Algebra R F] [IsFractionRing R F] + +theorem finitePlaceOrder_algebraMap_eq_multiplicity + (v : HeightOneSpectrum R) (a : R) (ha : a ≠ 0) : + finitePlaceOrder v (algebraMap R F a) = + (multiplicity v.asIdeal (Ideal.span {a}) : Int) := by + have hmap : algebraMap R F a ≠ 0 := by + intro hzero + apply ha + apply IsFractionRing.injective R F + simpa using hzero + have hvaluation := + valuation_eq_exp_neg_finitePlaceOrder v (algebraMap R F a) hmap + rw [HeightOneSpectrum.valuation_of_algebraMap, + v.intValuation_eq_exp_neg_multiplicity ha] at hvaluation + exact (neg_injective (WithZero.exp_injective hvaluation)).symm + +end LocalOrder + +section PrimitiveLocalOrder + +variable {A K L B : Type*} + [CommRing A] [Field K] [CommRing B] [Field L] + [Algebra A K] [Algebra A B] [Algebra B L] + [Algebra K L] [Algebra A L] + [IsScalarTower A K L] + [IsScalarTower A B L] + [IsDomain A] [IsFractionRing A K] + [IsFractionRing B L] [FiniteDimensional K L] + [Algebra.IsSeparable K L] + [IsIntegralClosure B A L] + [IsIntegrallyClosed A] [IsDedekindDomain B] + [Module.IsTorsionFree A B] + +theorem differentIdeal_multiplicity_le_finitePlaceOrder_minpolyDerivative + (x : B) + (hx : Algebra.adjoin K + {algebraMap B L x} = ⊤) + (v : HeightOneSpectrum B) : + (multiplicity v.asIdeal (differentIdeal A B) : Int) <= + finitePlaceOrder v + (algebraMap B L + (aeval x (derivative (minpoly A x)))) := by + rw [finitePlaceOrder_algebraMap_eq_multiplicity _ _ + (minpolyDerivative_ne_zero (A := A) (K := K) (L := L) x)] + exact_mod_cast differentIdeal_multiplicity_le_minpolyDerivativeSpan x hx v + +end PrimitiveLocalOrder + +section NormDiscriminant + +variable {A K L B : Type*} + [CommRing A] [Field K] [CommRing B] [Field L] + [Algebra A K] [Algebra B L] [Algebra A B] [Algebra K L] [Algebra A L] + [IsScalarTower A K L] [IsScalarTower A B L] + [IsDomain A] [IsFractionRing A K] [FiniteDimensional K L] + [Algebra.IsSeparable K L] [IsIntegralClosure B A L] + [IsIntegrallyClosed A] [IsDedekindDomain B] + +/-- The field norm of the integral minimal-polynomial derivative is the +power-basis discriminant, up to the standard sign. -/ +theorem discr_powerBasisOfPrimitiveElement_eq_norm_minpolyDerivative + (x : B) (hx : Algebra.adjoin K {algebraMap B L x} = ⊤) : + let pb : PowerBasis K L := + PowerBasis.ofAdjoinEqTop' (Algebra.IsIntegral.isIntegral _) hx + Algebra.discr K pb.basis = + (-1) ^ (Module.finrank K L * (Module.finrank K L - 1) / 2) * + Algebra.norm K + (algebraMap B L (aeval x (derivative (minpoly A x)))) := by + dsimp only + let pb : PowerBasis K L := + PowerBasis.ofAdjoinEqTop' (Algebra.IsIntegral.isIntegral _) hx + rw [Algebra.discr_powerBasis_eq_norm K pb] + congr 2 + simp only [pb, PowerBasis.ofAdjoinEqTop'_gen] + rw [minpoly.isIntegrallyClosed_eq_field_fractions K L + (IsIntegralClosure.isIntegral A L x), derivative_map, + aeval_map_algebraMap, aeval_algebraMap_apply] + +end NormDiscriminant + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/DedekindDifferentKaehler.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/DedekindDifferentKaehler.lean new file mode 100644 index 0000000000..5df6291f4c --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/DedekindDifferentKaehler.lean @@ -0,0 +1,336 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import Mathlib.RingTheory.DedekindDomain.Different +public import Mathlib.RingTheory.Kaehler.Basic +public import Mathlib.RingTheory.TensorProduct.Maps +public import Mathlib.LinearAlgebra.TensorProduct.Basis + +/-! +# The trace different annihilates Kähler differentials + +For a finite free extension `B / A` of integrally closed domains whose +fraction-field extension is separable, this file proves + +`differentIdeal A B ≤ Module.annihilator B Ω[B⁄A]`. + +The proof clears denominators in the trace-dual separability element. If +`b₁, ..., bₙ` is an integral basis with trace-dual basis `b₁ˇ, ..., bₙˇ` +and `d` lies in the different, then every `d bᵢˇ` is integral. Thus + +`e_d = ∑ i, bᵢ ⊗ d bᵢˇ` + +lies in `B ⊗[A] B`, has product `d`, and is killed by the kernel of the +multiplication map. It follows that multiplication by `d` sends this kernel +into its square, hence kills its cotangent module `I / I² = Ω[B⁄A]`. +-/ + +@[expose] public section + +open scoped BigOperators TensorProduct +open Polynomial Module + +namespace BGS.CorvajaZannier + +noncomputable section + +section TraceSeparabilityElement + +variable {K L ι : Type*} [Field K] [Field L] [Algebra K L] + [FiniteDimensional K L] [Algebra.IsSeparable K L] + [Fintype ι] [DecidableEq ι] + +/-- The separability element attached to a basis and its trace-dual basis. -/ +def traceSeparabilityElement (b : Basis ι K L) : L ⊗[K] L := + ∑ i, b i ⊗ₜ[K] b.traceDual i + +private lemma traceDual_mul_eq_sum_repr (b : Basis ι K L) (x : L) (j : ι) : + x * b.traceDual j = ∑ i, b.repr (x * b i) j • b.traceDual i := by + rw [← b.traceDual.sum_repr (x * b.traceDual j)] + apply Finset.sum_congr rfl + intro i hi + congr 1 + calc + (b.traceDual).repr (x * b.traceDual j) i = + Algebra.traceForm K L (x * b.traceDual j) (b i) := + b.traceDual_repr_apply _ _ + _ = Algebra.traceForm K L (x * b i) (b.traceDual j) := by + simp only [Algebra.traceForm_apply] + congr 1 + ring + _ = (b.traceDual.traceDual).repr (x * b i) j := + ((b.traceDual).traceDual_repr_apply _ _).symm + _ = b.repr (x * b i) j := by rw [b.traceDual_traceDual] + +/-- The trace-dual separability element commutes with the two copies of the +field extension in the tensor product. -/ +theorem traceSeparabilityElement_central (b : Basis ι K L) (x : L) : + (x ⊗ₜ[K] (1 : L)) * traceSeparabilityElement b = + ((1 : L) ⊗ₜ[K] x) * traceSeparabilityElement b := by + apply (TensorProduct.equivFinsuppOfBasisLeft b).injective + ext j + simp only [traceSeparabilityElement, Finset.mul_sum, + Algebra.TensorProduct.tmul_mul_tmul, one_mul, map_sum] + simp only [Finset.sum_apply'] + simp_rw [TensorProduct.equivFinsuppOfBasisLeft_apply_tmul_apply] + simp only [Basis.repr_self, Finsupp.single_apply, ite_smul, one_smul, zero_smul, + Finset.sum_ite_eq', Finset.mem_univ, ite_true] + rw [← traceDual_mul_eq_sum_repr b x j] + +/-- Multiplication sends the trace-dual separability element to one. -/ +theorem traceSeparabilityElement_mul (b : Basis ι K L) : + Algebra.TensorProduct.lmul' K (traceSeparabilityElement b) = 1 := by + apply sub_eq_zero.mp + apply (traceForm_nondegenerate K L).1 + intro y + change Algebra.trace K L + ((Algebra.TensorProduct.lmul' K (traceSeparabilityElement b) - 1) * y) = 0 + rw [sub_mul, one_mul, map_sub, sub_eq_zero, traceSeparabilityElement, map_sum] + simp only [Algebra.TensorProduct.lmul'_apply_tmul, Finset.sum_mul, map_sum] + rw [Algebra.trace_eq_matrix_trace b, Matrix.trace] + apply Finset.sum_congr rfl + intro i hi + rw [Matrix.diag_apply, Algebra.leftMulMatrix_eq_repr_mul] + calc + Algebra.trace K L (b i * b.traceDual i * y) = + Algebra.traceForm K L (y * b i) (b.traceDual i) := by + simp only [Algebra.traceForm_apply] + congr 1 + ring + _ = (b.traceDual.traceDual).repr (y * b i) i := + ((b.traceDual).traceDual_repr_apply _ _).symm + _ = b.repr (y * b i) i := by rw [b.traceDual_traceDual] + +end TraceSeparabilityElement + +section KaehlerFromSeparabilityElement + +variable {R S : Type*} [CommRing R] [CommRing S] [Algebra R S] + +/-- A denominator-cleared separability element with product `d` proves that +`d` annihilates the relative Kähler differentials. -/ +theorem mem_kaehlerAnnihilator_of_separabilityElement + (d : S) (e : S ⊗[R] S) + (hcentral : ∀ s : S, (s ⊗ₜ[R] (1 : S)) * e = ((1 : S) ⊗ₜ[R] s) * e) + (hmul : Algebra.TensorProduct.lmul' R e = d) : + d ∈ Module.annihilator S Ω[S⁄R] := by + rw [Module.mem_annihilator] + intro m + let I := KaehlerDifferential.ideal R S + obtain ⟨x, rfl⟩ := Ideal.toCotangent_surjective I m + suffices d • (I.toCotangent x : I.Cotangent) = 0 by + exact this + rw [← smul_one_smul (S ⊗[R] S) d (I.toCotangent x)] + rw [show d • (1 : S ⊗[R] S) = algebraMap S (S ⊗[R] S) d by + simp [Algebra.smul_def]] + rw [← LinearMap.map_smul I.toCotangent] + apply (Ideal.toCotangent_eq_zero I _).2 + have hxspan : (x : S ⊗[R] S) ∈ + Submodule.span S (Set.range fun s : S ↦ + (1 : S) ⊗ₜ[R] s - s ⊗ₜ[R] (1 : S)) := by + rw [KaehlerDifferential.submodule_span_range_eq_ideal] + exact x.2 + have hxe : (x : S ⊗[R] S) * e = 0 := by + refine Submodule.span_induction ?_ ?_ ?_ ?_ hxspan + · rintro y ⟨s, rfl⟩ + rw [sub_mul, sub_eq_zero] + exact (hcentral s).symm + · rw [zero_mul] + · intro y z hy hz hye hze + rw [add_mul, hye, hze, add_zero] + · intro c y hy hye + rw [smul_mul_assoc, hye, smul_zero] + let delta : S ⊗[R] S := d ⊗ₜ[R] (1 : S) - e + have hdelta : delta ∈ I := by + change Algebra.TensorProduct.lmul' R delta = 0 + simp [delta, hmul] + rw [pow_two] + have hprod : delta * (x : S ⊗[R] S) ∈ I * I := + Ideal.mul_mem_mul hdelta x.2 + convert hprod using 1 + · simp only [Submodule.coe_smul, Algebra.smul_def, + Algebra.TensorProduct.algebraMap_apply] + dsimp [delta] + rw [sub_mul, mul_comm e, hxe, sub_zero] + +end KaehlerFromSeparabilityElement + +section IntegralDifferent + +open scoped nonZeroDivisors + +variable {A K B L κ : Type*} + [CommRing A] [Field K] [CommRing B] [Field L] + [Algebra A K] [Algebra B L] [Algebra A B] [Algebra K L] [Algebra A L] + [IsScalarTower A K L] [IsScalarTower A B L] + [IsDomain A] [IsFractionRing A K] [FiniteDimensional K L] + [Algebra.IsSeparable K L] [IsIntegralClosure B A L] + [IsIntegrallyClosed A] [IsDedekindDomain B] + [Module.IsTorsionFree A B] + [IsLocalization (Algebra.algebraMapSubmonoid B A⁰) L] + [Fintype κ] [DecidableEq κ] + +private lemma exists_integral_traceDual_mul + (bA : Basis κ A B) (d : B) (hd : d ∈ differentIdeal A B) (i : κ) : + ∃ c : B, algebraMap B L c = algebraMap B L d * + (bA.localizationLocalization K A⁰ L).traceDual i := by + let bK := bA.localizationLocalization K A⁰ L + have hbspan : (1 : Submodule B L).restrictScalars A = + Submodule.span A (Set.range bK) := by + rw [Submodule.one_eq_range] + exact (bA.localizationLocalization_span K A⁰ L).symm + have hdual : bK.traceDual i ∈ Submodule.traceDual A K (1 : Submodule B L) := by + rw [← Submodule.restrictScalars_mem A, + Submodule.traceDual_span_of_basis A (1 : Submodule B L) bK hbspan] + exact Submodule.subset_span (Set.mem_range_self i) + let : IsFractionRing B L := + IsIntegralClosure.isFractionRing_of_finite_extension A K L B + have hd' : algebraMap B L d ∈ + (FractionalIdeal.dual A K (1 : FractionalIdeal B⁰ L))⁻¹ := by + have h := FractionalIdeal.mem_coeIdeal_of_mem (S := B⁰) (P := L) hd + rwa [coeIdeal_differentIdeal A K L B] at h + have hdual' : bK.traceDual i ∈ + FractionalIdeal.dual A K (1 : FractionalIdeal B⁰ L) := by + change bK.traceDual i ∈ + (FractionalIdeal.dual A K (1 : FractionalIdeal B⁰ L) : Submodule B L) + rw [FractionalIdeal.coe_dual_one] + exact hdual + have hprod : algebraMap B L d * bK.traceDual i ∈ + (1 : FractionalIdeal B⁰ L) := + (FractionalIdeal.mem_inv_iff + (FractionalIdeal.dual_ne_zero A K + (@one_ne_zero (FractionalIdeal B⁰ L) _ _ _))).mp hd' _ hdual' + obtain ⟨c, hc⟩ := (FractionalIdeal.mem_one_iff B⁰).mp hprod + exact ⟨c, hc⟩ + +end IntegralDifferent + +section CanonicalDifferent + +open scoped nonZeroDivisors + +variable {A B κ : Type*} + [CommRing A] [CommRing B] [Algebra A B] + [IsDomain A] [IsIntegrallyClosed A] [IsDedekindDomain B] + [Module.IsTorsionFree A B] [Module.Finite A B] + [Algebra (FractionRing A) (FractionRing B)] + [IsScalarTower A (FractionRing A) (FractionRing B)] + [Algebra.IsSeparable (FractionRing A) (FractionRing B)] + [Fintype κ] [DecidableEq κ] + +omit [DecidableEq κ] in +private theorem mem_kaehlerAnnihilator_of_mem_differentIdeal_of_basis + (bA : Basis κ A B) (d : B) (hd : d ∈ differentIdeal A B) : + d ∈ Module.annihilator B Ω[B⁄A] := by + classical + let : IsIntegralClosure B A (FractionRing B) := + IsIntegralClosure.of_isIntegrallyClosed B A (FractionRing B) + let : Algebra.IsAlgebraic (FractionRing A) (FractionRing B) := + isAlgebraic_of_isFractionRing A B .. + let : IsLocalization + (Algebra.algebraMapSubmonoid B A⁰) (FractionRing B) := + IsIntegralClosure.isLocalization A (FractionRing A) (FractionRing B) B + let : FiniteDimensional (FractionRing A) (FractionRing B) := + .of_isLocalization A B A⁰ + let bK := bA.localizationLocalization (FractionRing A) A⁰ (FractionRing B) + let c : κ → B := fun i ↦ + Classical.choose (exists_integral_traceDual_mul + (K := FractionRing A) (L := FractionRing B) bA d hd i) + have hc (i : κ) : algebraMap B (FractionRing B) (c i) = + algebraMap B (FractionRing B) d * bK.traceDual i := by + exact Classical.choose_spec (exists_integral_traceDual_mul + (K := FractionRing A) (L := FractionRing B) bA d hd i) + let e : B ⊗[A] B := ∑ i, bA i ⊗ₜ[A] c i + apply mem_kaehlerAnnihilator_of_separabilityElement d e + · intro x + apply (TensorProduct.equivFinsuppOfBasisLeft bA).injective + ext j + simp only [e, Finset.mul_sum, Algebra.TensorProduct.tmul_mul_tmul, + one_mul, map_sum, Finset.sum_apply'] + simp_rw [TensorProduct.equivFinsuppOfBasisLeft_apply_tmul_apply] + simp only [Basis.repr_self, Finsupp.single_apply, ite_smul, one_smul, + zero_smul, Finset.sum_ite_eq', Finset.mem_univ, ite_true] + apply FaithfulSMul.algebraMap_injective B (FractionRing B) + rw [map_sum] + have htrace := traceDual_mul_eq_sum_repr bK + (algebraMap B (FractionRing B) x) j + calc + ∑ i, algebraMap B (FractionRing B) + ((bA.repr (x * bA i) j) • c i) = + algebraMap B (FractionRing B) d * + ∑ i, bK.repr + (algebraMap B (FractionRing B) x * bK i) j • + bK.traceDual i := by + rw [Finset.mul_sum] + apply Finset.sum_congr rfl + intro i hi + rw [Algebra.smul_def, map_mul, hc] + have harg : algebraMap B (FractionRing B) x * bK i = + algebraMap B (FractionRing B) (x * bA i) := by + simp only [bK, Basis.localizationLocalization_apply, map_mul] + rw [harg] + simp only [bK, Basis.localizationLocalization_repr_algebraMap] + simp only [Algebra.smul_def] + rw [← IsScalarTower.algebraMap_apply A B (FractionRing B), + ← IsScalarTower.algebraMap_apply A (FractionRing A) + (FractionRing B)] + ring + _ = algebraMap B (FractionRing B) d * + (algebraMap B (FractionRing B) x * bK.traceDual j) := by + rw [htrace] + _ = algebraMap B (FractionRing B) x * + (algebraMap B (FractionRing B) d * bK.traceDual j) := by ring + _ = algebraMap B (FractionRing B) (x * c j) := by + rw [map_mul, hc] + · apply FaithfulSMul.algebraMap_injective B (FractionRing B) + simp only [e, map_sum, Algebra.TensorProduct.lmul'_apply_tmul, + map_mul, hc] + have hsum : ∑ i, bK i * bK.traceDual i = 1 := by + simpa only [traceSeparabilityElement, map_sum, + Algebra.TensorProduct.lmul'_apply_tmul] using + (traceSeparabilityElement_mul + (K := FractionRing A) (L := FractionRing B) bK) + calc + ∑ i, algebraMap B (FractionRing B) (bA i) * + (algebraMap B (FractionRing B) d * bK.traceDual i) = + algebraMap B (FractionRing B) d * + ∑ i, bK i * bK.traceDual i := by + rw [Finset.mul_sum] + apply Finset.sum_congr rfl + intro i hi + simp only [bK, Basis.localizationLocalization_apply] + ring + _ = algebraMap B (FractionRing B) d := by rw [hsum, mul_one] + +/-- The trace different is contained in the annihilator of the relative +Kähler differentials. -/ +theorem differentIdeal_le_kaehlerDifferentialAnnihilator + [Module.Free A B] : + differentIdeal A B ≤ Module.annihilator B Ω[B⁄A] := by + intro d hd + let bA := Module.Free.chooseBasis A B + let := Classical.decEq (Module.Free.ChooseBasisIndex A B) + exact mem_kaehlerAnnihilator_of_mem_differentIdeal_of_basis bA d hd + +/-- In a principal target, a generator of the trace different is also a +Kähler-annihilating scalar. This applies to a localized DVR whenever the +localized extension is finite free. -/ +theorem exists_differentIdeal_generator_mem_kaehlerAnnihilator + [Module.Free A B] [IsPrincipalIdealRing B] : + ∃ c : B, Ideal.span {c} = differentIdeal A B ∧ + c ∈ Module.annihilator B Ω[B⁄A] := by + let c : B := Submodule.IsPrincipal.generator (differentIdeal A B) + refine ⟨c, Ideal.span_singleton_generator _, ?_⟩ + exact differentIdeal_le_kaehlerDifferentialAnnihilator + (Submodule.IsPrincipal.generator_mem (differentIdeal A B)) + +end CanonicalDifferent + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/DedekindLeadingTermCancellation.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/DedekindLeadingTermCancellation.lean new file mode 100644 index 0000000000..b1480c8a9f --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/DedekindLeadingTermCancellation.lean @@ -0,0 +1,199 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.DedekindPlaceOrder +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PerfectConstants +public import Mathlib.Tactic + +/-! +# Leading-term cancellation at a Dedekind DVR place + +At a discrete valuation place, two nonzero functions of the same order have +unit leading coefficients. If the derivation-constant field surjects onto +the residue field, one can subtract a constant multiple of one function from +the other and cancel that leading coefficient. The result either vanishes +or has strictly larger order. + +This is the global-Dedekind analogue of the Laurent-series cancellation used +in Corvaja--Zannier case (i). The surjectivity hypothesis is stated directly +on the residue field, so the theorem can be applied independently of how the +constant field is presented. +-/ + +@[expose] public section + +open scoped nonZeroDivisors +open IsDedekindDomain Multiplicative WithZero + +namespace BGS.CorvajaZannier + +noncomputable section + +variable {C R L : Type*} [Field C] [CommRing R] [IsDedekindDomain R] + [IsDiscreteValuationRing R] [Field L] [Algebra C R] [Algebra R L] + [Algebra C L] [IsScalarTower C R L] [IsFractionRing R L] + +/-- A nonzero regular element lying in the place has positive order. -/ +theorem one_le_finitePlaceOrder_algebraMap_of_mem + (v : HeightOneSpectrum R) (a : R) (ha : a ∈ v.asIdeal) (ha0 : a ≠ 0) : + (1 : ℤ) ≤ finitePlaceOrder v (algebraMap R L a) := by + have hmap : algebraMap R L a ≠ 0 := by + intro hzero + apply ha0 + exact IsFractionRing.injective R L (by simpa using hzero) + have hvaluation := + valuation_eq_exp_neg_finitePlaceOrder v (algebraMap R L a) hmap + rw [HeightOneSpectrum.valuation_of_algebraMap] at hvaluation + have hlt : exp (-finitePlaceOrder v (algebraMap R L a)) < 1 := by + rw [← hvaluation] + exact (v.intValuation_lt_one_iff_mem a).2 ha + rw [← exp_zero, exp_lt_exp] at hlt + omega + +omit [IsDedekindDomain R] [IsDiscreteValuationRing R] in +/-- Residue-field surjectivity lets constants cancel the ratio of two unit +leading coefficients. -/ +theorem exists_constant_unit_sub_mul_mem + (v : HeightOneSpectrum R) + (hresidue : Function.Surjective + (algebraMap C v.asIdeal.ResidueField)) + (u w : Rˣ) : + ∃ c : C, (u : R) - algebraMap C R c * (w : R) ∈ v.asIdeal := by + let κ := v.asIdeal.ResidueField + obtain ⟨c, hc⟩ := hresidue + (algebraMap R κ (((u * w⁻¹ : Rˣ) : R))) + refine ⟨c, ?_⟩ + rw [← Ideal.algebraMap_residueField_eq_zero] + calc + algebraMap R κ ((u : R) - algebraMap C R c * (w : R)) = + algebraMap R κ (u : R) - + algebraMap C κ c * algebraMap R κ (w : R) := by + rw [map_sub, map_mul, ← IsScalarTower.algebraMap_apply C R κ] + _ = algebraMap R κ (u : R) - + algebraMap R κ (((u * w⁻¹ : Rˣ) : R)) * + algebraMap R κ (w : R) := by rw [hc] + _ = 0 := by + rw [← map_mul] + simp + +/-- If constants surject onto the residue field at `v`, equal-order nonzero +functions have a constant leading-term cancellation. The cancelled function +is either zero or has strictly larger finite-place order. + +No uniformizer is part of the interface: one is chosen internally from the +DVR structure, and uniqueness of the maximal ideal identifies it with `v`. -/ +theorem exists_constant_finitePlaceOrder_sub_mul_eq_zero_or_lt + (v : HeightOneSpectrum R) + (hresidue : Function.Surjective + (algebraMap C v.asIdeal.ResidueField)) + (x y : L) (hx : x ≠ 0) (hy : y ≠ 0) + (horder : finitePlaceOrder v x = finitePlaceOrder v y) : + ∃ c : C, + x - algebraMap C L c * y = 0 ∨ + finitePlaceOrder v x < + finitePlaceOrder v (x - algebraMap C L c * y) := by + obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible R + have hπIdeal : v.asIdeal = Ideal.span {π} := by + calc + v.asIdeal = IsLocalRing.maximalIdeal R := + IsLocalRing.eq_maximalIdeal v.isMaximal + _ = Ideal.span {π} := + (IsDiscreteValuationRing.irreducible_iff_uniformizer π).mp hπ + obtain ⟨nx, ux, hxrepr⟩ := + IsDiscreteValuationRing.exists_units_eq_smul_zpow_of_irreducible + (K := L) hπ hx + obtain ⟨ny, uy, hyrepr⟩ := + IsDiscreteValuationRing.exists_units_eq_smul_zpow_of_irreducible + (K := L) hπ hy + have hxrepr' : + x = algebraMap R L (ux : R) * (algebraMap R L π) ^ nx := by + simpa [Units.smul_def, Algebra.smul_def] using hxrepr + have hyrepr' : + y = algebraMap R L (uy : R) * (algebraMap R L π) ^ ny := by + simpa [Units.smul_def, Algebra.smul_def] using hyrepr + have hxOrder : finitePlaceOrder v x = nx := by + rw [hxrepr'] + exact finitePlaceOrder_unit_mul_uniformizer_zpow + v π hπ hπIdeal ux nx + have hyOrder : finitePlaceOrder v y = ny := by + rw [hyrepr'] + exact finitePlaceOrder_unit_mul_uniformizer_zpow + v π hπ hπIdeal uy ny + have hnxny : nx = ny := by omega + rw [← hnxny] at hyrepr' + obtain ⟨c, hc⟩ := exists_constant_unit_sub_mul_mem v hresidue ux uy + let a : R := (ux : R) - algebraMap C R c * (uy : R) + have haMem : a ∈ v.asIdeal := by simpa [a] using hc + have hfactor : + x - algebraMap C L c * y = + algebraMap R L a * (algebraMap R L π) ^ nx := by + rw [hxrepr', hyrepr'] + simp only [a, map_sub, map_mul] + rw [IsScalarTower.algebraMap_apply C R L] + ring + by_cases ha : a = 0 + · refine ⟨c, Or.inl ?_⟩ + rw [hfactor, ha, map_zero, zero_mul] + · refine ⟨c, Or.inr ?_⟩ + have haMap : algebraMap R L a ≠ 0 := by + intro hzero + apply ha + exact IsFractionRing.injective R L (by simpa using hzero) + have hπMap : algebraMap R L π ≠ 0 := by + simpa using hπ.ne_zero + have hprod := finitePrincipalDivisor_mul (R := R) + (algebraMap R L a) ((algebraMap R L π) ^ nx) + haMap (zpow_ne_zero nx hπMap) + have hprodOrder := congrArg (fun D ↦ D v) hprod + simp only [finitePrincipalDivisor_apply, Finsupp.add_apply] at hprodOrder + rw [finitePlaceOrder_uniformizer_zpow v π hπ hπIdeal nx] at hprodOrder + have haOrder : (1 : ℤ) ≤ finitePlaceOrder v (algebraMap R L a) := + one_le_finitePlaceOrder_algebraMap_of_mem v a haMem ha + rw [hxOrder, hfactor, hprodOrder] + omega + +section FrobeniusConstants + +variable {K : Type*} [Field K] {p : ℕ} [Fact p.Prime] + [CharP K p] [CharP L p] [PerfectField K] + [Algebra K R] [Algebra K L] [IsScalarTower K R L] + +/-- Over a perfect field of constants, the cancelling coefficient may be +regarded as an element of the Frobenius subfield `L^p`, which is the constant +field of the separating derivation used by Corvaja--Zannier. + +The residue-surjectivity hypothesis is deliberately imposed on the genuine +constant field `K`: the full subfield `L^p` is not contained in a nontrivial +valuation ring. Perfectness embeds `K` into `L^p`, and this is exactly enough +to make the column operation linear over the derivation-constant field. -/ +theorem exists_frobeniusSubfield_constant_finitePlaceOrder_sub_mul_eq_zero_or_lt + (v : HeightOneSpectrum R) + (hresidue : Function.Surjective + (algebraMap K v.asIdeal.ResidueField)) + (x y : L) (hx : x ≠ 0) (hy : y ≠ 0) + (horder : finitePlaceOrder v x = finitePlaceOrder v y) : + ∃ c : frobeniusSubfield L p, + x - algebraMap (frobeniusSubfield L p) L c * y = 0 ∨ + finitePlaceOrder v x < finitePlaceOrder v + (x - algebraMap (frobeniusSubfield L p) L c * y) := by + obtain ⟨c, hc⟩ := + exists_constant_finitePlaceOrder_sub_mul_eq_zero_or_lt + (C := K) v hresidue x y hx hy horder + let cF : frobeniusSubfield L p := + perfectConstantsToFrobeniusSubfield (K := K) (L := L) (p := p) c + refine ⟨cF, ?_⟩ + have hcF : algebraMap (frobeniusSubfield L p) L cF = algebraMap K L c := by + exact coe_perfectConstantsToFrobeniusSubfield + (K := K) (L := L) (p := p) c + simpa only [hcF] using hc + +end FrobeniusConstants + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/DedekindLocalDerivationExtension.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/DedekindLocalDerivationExtension.lean new file mode 100644 index 0000000000..966f3b1d5d --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/DedekindLocalDerivationExtension.lean @@ -0,0 +1,275 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import Mathlib.RingTheory.Etale.Kaehler +public import Mathlib.RingTheory.DedekindDomain.Different +public import Mathlib.RingTheory.Flat.TorsionFree +public import Mathlib.RingTheory.Smooth.Fiber + +/-! +# Extending derivations through local Dedekind rings + +Lift derivations uniquely through formally etale maps and apply this to unramified localizations +and primes away from the different. +-/ + +@[expose] public section + +namespace BGS.CorvajaZannier + +noncomputable section + +attribute [local instance] FractionRing.liftAlgebra + FractionRing.isScalarTower_liftAlgebra + +variable {C S T U : Type*} + [CommRing C] [CommRing S] [CommRing T] [CommRing U] + [Algebra C S] [Algebra C T] [Algebra S T] + [Algebra C U] [Algebra S U] [Algebra T U] + [IsScalarTower C S T] [IsScalarTower C S U] + [IsScalarTower C T U] [IsScalarTower S T U] + +/-- A derivation over `C` which vanishes on `S` is an `S`-derivation. -/ +def derivationToRelative + (D : Derivation C T U) + (hD : ∀ s : S, D (algebraMap S T s) = 0) : + Derivation S T U where + toLinearMap := + { toFun := D + map_add' := D.map_add + map_smul' := by + intro s t + rw [show s • t = algebraMap S T s * t by + exact Algebra.smul_def s t] + rw [D.leibniz, hD, smul_zero, add_zero, + IsScalarTower.algebraMap_smul T, RingHom.id_apply] } + map_one_eq_zero' := D.map_one_eq_zero + leibniz' := D.leibniz + +omit [Algebra C S] [IsScalarTower C S T] [IsScalarTower C S U] + [IsScalarTower C T U] in +@[simp] +theorem derivationToRelative_apply + (D : Derivation C T U) + (hD : ∀ s : S, D (algebraMap S T s) = 0) (t : T) : + derivationToRelative D hD t = D t := + rfl + +omit [Algebra C S] [IsScalarTower C S T] [IsScalarTower C S U] + [IsScalarTower C T U] in +/-- Relative formal unramifiedness makes a `C`-derivation into a `T`-module +unique once its restriction to `S` is fixed. -/ +theorem derivation_ext_of_formallyUnramified + [Algebra.FormallyUnramified S T] + (D₁ D₂ : Derivation C T U) + (hD : ∀ s : S, D₁ (algebraMap S T s) = D₂ (algebraMap S T s)) : + D₁ = D₂ := by + let E : Derivation C T U := D₁ - D₂ + have hE : ∀ s : S, E (algebraMap S T s) = 0 := by + intro s + exact sub_eq_zero.mpr (hD s) + let Erel : Derivation S T U := derivationToRelative E hE + have hLift : Erel.liftKaehlerDifferential = 0 := by + apply LinearMap.ext + intro x + rw [show x = 0 from Subsingleton.elim x 0] + simp + have hErel : Erel = 0 := by + rw [← Erel.liftKaehlerDifferential_comp, hLift] + rfl + apply Derivation.ext + intro t + have := Derivation.congr_fun hErel t + apply sub_eq_zero.mp + simpa [Erel, E, derivationToRelative] using this + +/-- Lift a `C`-derivation through a formally étale `S`-algebra. The target +may be any compatible `T`-algebra. -/ +noncomputable def formallyEtaleDerivationLift + [Algebra.FormallyEtale S T] + (D : Derivation C S U) : Derivation C T U := + KaehlerDifferential.linearMapEquivDerivation C T + ((D.liftKaehlerDifferential.liftBaseChange T).comp + (KaehlerDifferential.tensorKaehlerEquivOfFormallyEtale C S T).symm.toLinearMap) + +@[simp] +theorem formallyEtaleDerivationLift_algebraMap + [Algebra.FormallyEtale S T] + (D : Derivation C S U) (s : S) : + formallyEtaleDerivationLift D (algebraMap S T s) = D s := by + change (D.liftKaehlerDifferential.liftBaseChange T) + ((KaehlerDifferential.tensorKaehlerEquivOfFormallyEtale C S T).symm + (KaehlerDifferential.D C T (algebraMap S T s))) = D s + rw [KaehlerDifferential.tensorKaehlerEquivOfFormallyEtale_symm_D_algebraMap] + simp + +/-- The formally étale lift is the unique extension of the given derivation. -/ +theorem formallyEtaleDerivationLift_unique + [Algebra.FormallyEtale S T] + (D : Derivation C S U) (E : Derivation C T U) + (hE : ∀ s : S, E (algebraMap S T s) = D s) : + E = formallyEtaleDerivationLift D := by + apply derivation_ext_of_formallyUnramified (S := S) + E (formallyEtaleDerivationLift D) + intro s + rw [hE, formallyEtaleDerivationLift_algebraMap] + +/-- Extend a derivation taking values in the base ring to one taking values +in the formally étale algebra. -/ +noncomputable def formallyEtaleDerivationExtension + [Algebra.FormallyEtale S T] + (D : Derivation C S S) : Derivation C T T := + formallyEtaleDerivationLift ((Algebra.linearMap S T).compDer D) + +@[simp] +theorem formallyEtaleDerivationExtension_algebraMap + [Algebra.FormallyEtale S T] + (D : Derivation C S S) (s : S) : + formallyEtaleDerivationExtension D (algebraMap S T s) = + algebraMap S T (D s) := by + simp [formallyEtaleDerivationExtension] + +omit [IsScalarTower C S U] in +/-- If an ambient derivation preserves the base local ring, then it preserves +every formally étale extension ring inside the ambient algebra. -/ +theorem formallyEtale_derivation_preserves + [Algebra.FormallyEtale S T] + (D : Derivation C S S) (E : Derivation C U U) + (hE : ∀ s : S, E (algebraMap S U s) = algebraMap S U (D s)) : + ∃ D' : Derivation C T T, + (∀ s : S, D' (algebraMap S T s) = algebraMap S T (D s)) ∧ + ∀ t : T, E (algebraMap T U t) = algebraMap T U (D' t) := by + let D' : Derivation C T T := formallyEtaleDerivationExtension D + refine ⟨D', formallyEtaleDerivationExtension_algebraMap D, ?_⟩ + have hDer : E.compAlgebraMap T = + (Algebra.linearMap T U).compDer D' := by + apply derivation_ext_of_formallyUnramified (S := S) + intro s + change E (algebraMap T U (algebraMap S T s)) = + algebraMap T U (D' (algebraMap S T s)) + rw [show D' = formallyEtaleDerivationExtension D from rfl, + formallyEtaleDerivationExtension_algebraMap] + simpa only [IsScalarTower.algebraMap_apply S T U] using hE s + intro t + exact Derivation.congr_fun hDer t + +/-- A finite torsion-free extension of Dedekind domains is formally étale on +the local branch at every unramified prime. -/ +theorem dedekindLocal_formallyEtale_of_isUnramifiedAt + {A B : Type*} [CommRing A] [CommRing B] + [IsDedekindDomain A] [IsDedekindDomain B] + [Algebra A B] [Module.IsTorsionFree A B] [Module.Finite A B] + (p : Ideal A) (Q : Ideal B) [p.IsPrime] [Q.IsPrime] [Q.LiesOver p] + [Algebra (Localization.AtPrime p) (Localization.AtPrime Q)] + [IsScalarTower A (Localization.AtPrime p) (Localization.AtPrime Q)] + [Algebra.IsUnramifiedAt A Q] : + Algebra.FormallyEtale (Localization.AtPrime p) + (Localization.AtPrime Q) := by + let : Algebra.FinitePresentation A B := + Algebra.FinitePresentation.of_finiteType.mp inferInstance + let : Algebra.FormallyEtale A (Localization.AtPrime Q) := + Algebra.IsEtaleAt.of_isUnramifiedAt_of_flat Q + exact Algebra.FormallyEtale.of_restrictScalars + (R := A) (A := Localization.AtPrime p) (B := Localization.AtPrime Q) + +/-- Outside the different ideal, the corresponding map of Dedekind local +rings is formally étale. -/ +theorem dedekindLocal_formallyEtale_of_not_dvd_different + {A B : Type*} [CommRing A] [CommRing B] + [IsDedekindDomain A] [IsDedekindDomain B] + [Algebra A B] [Module.IsTorsionFree A B] [Module.Finite A B] + [Algebra.IsSeparable (FractionRing A) (FractionRing B)] + (p : Ideal A) (Q : Ideal B) [p.IsPrime] [Q.IsPrime] [Q.LiesOver p] + [Algebra (Localization.AtPrime p) (Localization.AtPrime Q)] + [IsScalarTower A (Localization.AtPrime p) (Localization.AtPrime Q)] + (hQ : ¬ Q ∣ differentIdeal A B) : + Algebra.FormallyEtale (Localization.AtPrime p) + (Localization.AtPrime Q) := by + let : Algebra.IsUnramifiedAt A Q := + not_dvd_differentIdeal_iff.mp hQ + exact dedekindLocal_formallyEtale_of_isUnramifiedAt p Q + +/-- An ambient derivation preserving the base Dedekind local ring preserves +an unramified local branch of a finite torsion-free Dedekind extension. -/ +theorem dedekindLocal_derivation_preserves_of_isUnramifiedAt + {A B C U : Type*} + [CommRing A] [CommRing B] [CommRing C] [CommRing U] + [IsDedekindDomain A] [IsDedekindDomain B] + [Algebra A B] [Module.IsTorsionFree A B] [Module.Finite A B] + (p : Ideal A) (Q : Ideal B) [p.IsPrime] [Q.IsPrime] [Q.LiesOver p] + [Algebra (Localization.AtPrime p) (Localization.AtPrime Q)] + [IsScalarTower A (Localization.AtPrime p) (Localization.AtPrime Q)] + [Algebra C (Localization.AtPrime p)] + [Algebra C (Localization.AtPrime Q)] + [Algebra C U] + [Algebra (Localization.AtPrime p) U] + [Algebra (Localization.AtPrime Q) U] + [IsScalarTower C (Localization.AtPrime p) (Localization.AtPrime Q)] + [IsScalarTower C (Localization.AtPrime p) U] + [IsScalarTower C (Localization.AtPrime Q) U] + [IsScalarTower (Localization.AtPrime p) (Localization.AtPrime Q) U] + [Algebra.IsUnramifiedAt A Q] + (D : Derivation C (Localization.AtPrime p) (Localization.AtPrime p)) + (E : Derivation C U U) + (hE : ∀ s : Localization.AtPrime p, + E (algebraMap (Localization.AtPrime p) U s) = + algebraMap (Localization.AtPrime p) U (D s)) : + ∃ D' : Derivation C (Localization.AtPrime Q) (Localization.AtPrime Q), + (∀ s : Localization.AtPrime p, + D' (algebraMap (Localization.AtPrime p) (Localization.AtPrime Q) s) = + algebraMap (Localization.AtPrime p) (Localization.AtPrime Q) (D s)) ∧ + ∀ t : Localization.AtPrime Q, + E (algebraMap (Localization.AtPrime Q) U t) = + algebraMap (Localization.AtPrime Q) U (D' t) := by + let : Algebra.FormallyEtale (Localization.AtPrime p) + (Localization.AtPrime Q) := + dedekindLocal_formallyEtale_of_isUnramifiedAt p Q + exact formallyEtale_derivation_preserves D E hE + +/-- Away from the different, an ambient derivation preserving the base local +ring preserves the selected extension DVR. This is the direct local +derivation-extension statement used in the Corvaja--Zannier argument. -/ +theorem dedekindLocal_derivation_preserves_of_not_dvd_different + {A B C U : Type*} + [CommRing A] [CommRing B] [CommRing C] [CommRing U] + [IsDedekindDomain A] [IsDedekindDomain B] + [Algebra A B] [Module.IsTorsionFree A B] [Module.Finite A B] + [Algebra.IsSeparable (FractionRing A) (FractionRing B)] + (p : Ideal A) (Q : Ideal B) [p.IsPrime] [Q.IsPrime] [Q.LiesOver p] + [Algebra (Localization.AtPrime p) (Localization.AtPrime Q)] + [IsScalarTower A (Localization.AtPrime p) (Localization.AtPrime Q)] + [Algebra C (Localization.AtPrime p)] + [Algebra C (Localization.AtPrime Q)] + [Algebra C U] + [Algebra (Localization.AtPrime p) U] + [Algebra (Localization.AtPrime Q) U] + [IsScalarTower C (Localization.AtPrime p) (Localization.AtPrime Q)] + [IsScalarTower C (Localization.AtPrime p) U] + [IsScalarTower C (Localization.AtPrime Q) U] + [IsScalarTower (Localization.AtPrime p) (Localization.AtPrime Q) U] + (hQ : ¬ Q ∣ differentIdeal A B) + (D : Derivation C (Localization.AtPrime p) (Localization.AtPrime p)) + (E : Derivation C U U) + (hE : ∀ s : Localization.AtPrime p, + E (algebraMap (Localization.AtPrime p) U s) = + algebraMap (Localization.AtPrime p) U (D s)) : + ∃ D' : Derivation C (Localization.AtPrime Q) (Localization.AtPrime Q), + (∀ s : Localization.AtPrime p, + D' (algebraMap (Localization.AtPrime p) (Localization.AtPrime Q) s) = + algebraMap (Localization.AtPrime p) (Localization.AtPrime Q) (D s)) ∧ + ∀ t : Localization.AtPrime Q, + E (algebraMap (Localization.AtPrime Q) U t) = + algebraMap (Localization.AtPrime Q) U (D' t) := by + let : Algebra.FormallyEtale (Localization.AtPrime p) + (Localization.AtPrime Q) := + dedekindLocal_formallyEtale_of_not_dvd_different p Q hQ + exact formallyEtale_derivation_preserves D E hE + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/DedekindLocalWronskian.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/DedekindLocalWronskian.lean new file mode 100644 index 0000000000..668f18e609 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/DedekindLocalWronskian.lean @@ -0,0 +1,542 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.DedekindPlaceOrder +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.WronskianChangeParameter +public import Mathlib.LinearAlgebra.Matrix.Determinant.Basic + +/-! +# Wronskian order estimates at a Dedekind DVR place + +This file proves the determinant-level local estimate directly in a fraction +field equipped with a height-one-place order. It avoids passage to Laurent +series: the only local input is a DVR-preserving derivation which sends a +chosen uniformizer to one. +-/ + +@[expose] public section + +namespace BGS.CorvajaZannier + +noncomputable section + +open scoped Matrix BigOperators +open IsDedekindDomain Multiplicative WithZero + +variable {R L : Type*} [CommRing R] [IsDedekindDomain R] + [Field L] [Algebra R L] [IsFractionRing R L] + +/-- The order of a finite product is the sum of the orders, including zero +factors via `WithTop`. -/ +theorem finitePlaceOrderTop_finset_prod + {ι : Type*} (v : HeightOneSpectrum R) + (s : Finset ι) (g : ι → L) : + finitePlaceOrderTop v (∏ i ∈ s, g i) = + ∑ i ∈ s, finitePlaceOrderTop v (g i) := by + classical + induction s using Finset.induction_on with + | empty => simp + | @insert a s ha ih => + simp only [Finset.prod_insert, Finset.sum_insert, ha, not_false_eq_true] + rw [finitePlaceOrderTop_mul, ih] + +/-- If every summand has order at least `b`, then their finite sum also has +order at least `b`. This is the cancellation step in the determinant +estimate. -/ +theorem le_finitePlaceOrderTop_finset_sum_of_forall + {ι : Type*} (v : HeightOneSpectrum R) + (b : WithTop ℤ) (s : Finset ι) (g : ι → L) + (h : ∀ i ∈ s, b ≤ finitePlaceOrderTop v (g i)) : + b ≤ finitePlaceOrderTop v (∑ i ∈ s, g i) := by + classical + induction s using Finset.induction_on with + | empty => simp + | @insert a s ha ih => + simp only [Finset.sum_insert, ha, not_false_eq_true] + have haBound : b ≤ finitePlaceOrderTop v (g a) := + h a (Finset.mem_insert_self a s) + have hsBound : b ≤ finitePlaceOrderTop v (∑ i ∈ s, g i) := by + apply ih + intro i hi + exact h i (Finset.mem_insert_of_mem hi) + exact (le_min haBound hsBound).trans + (finitePlaceOrderTop_add_ge_min v (g a) (∑ i ∈ s, g i)) + +/-- Multiplication by an integer coefficient cannot decrease finite-place +order. This handles the permutation signs in the Leibniz determinant +formula. -/ +theorem finitePlaceOrderTop_le_intCast_mul + (v : HeightOneSpectrum R) (z : ℤ) (x : L) : + finitePlaceOrderTop v x ≤ finitePlaceOrderTop v ((z : L) * x) := by + rw [finitePlaceOrderTop_mul] + have hz : (0 : WithTop ℤ) ≤ finitePlaceOrderTop v (z : L) := by + simpa using finitePlaceOrderTop_algebraMap_nonnegative + (L := L) v (z : R) + calc + finitePlaceOrderTop v x = 0 + finitePlaceOrderTop v x := by simp + _ ≤ finitePlaceOrderTop v (z : L) + finitePlaceOrderTop v x := + add_le_add hz le_rfl + +private theorem coe_sum_int_finset + {ι : Type*} (s : Finset ι) (g : ι → ℤ) : + (((∑ i ∈ s, g i : ℤ) : ℤ) : WithTop ℤ) = + ∑ i ∈ s, ((g i : ℤ) : WithTop ℤ) := by + classical + induction s using Finset.induction_on with + | empty => simp + | @insert a s ha ih => simp [ha, ih, WithTop.coe_add] + +private theorem coe_sum_int + {ι : Type*} [Fintype ι] (g : ι → ℤ) : + (((∑ i, g i : ℤ) : ℤ) : WithTop ℤ) = + ∑ i, ((g i : ℤ) : WithTop ℤ) := by + classical + exact coe_sum_int_finset Finset.univ g + +section DVR + +variable [IsDiscreteValuationRing R] +variable {C : Type*} [Field C] [Algebra C R] [Algebra C L] + [IsScalarTower C R L] + +/-- An indexed ordinary-derivation Wronskian over the fraction field. The +function `ε` records the derivative order assigned to each row. -/ +def indexedDedekindLocalWronskian + {ι : Type*} [Fintype ι] (D : Derivation C L L) + (ε : ι → ℕ) (f : ι → L) : Matrix ι ι L := + fun i j ↦ ((D : L → L)^[ε i]) (f j) + +/-- Apply a constant scalar matrix to the columns of an indexed fraction-field +family. -/ +def indexedDedekindLocalColumnCombination + {ι : Type*} [Fintype ι] (f : ι → L) (A : Matrix ι ι C) : ι → L := + fun j ↦ ∑ i, A i j • f i + +private theorem derivation_iterate_sum_smul + {ι : Type*} [Fintype ι] (D : Derivation C L L) + (r : ℕ) (a : ι → C) (f : ι → L) : + ((D : L → L)^[r]) (∑ i, a i • f i) = + ∑ i, a i • ((D : L → L)^[r]) (f i) := by + induction r with + | zero => simp + | succ r ih => + simp_rw [Function.iterate_succ_apply'] + rw [ih, map_sum] + simp + +/-- Constant column operations commute with the indexed DVR Wronskian. -/ +theorem indexedDedekindLocalWronskian_columnCombination + {ι : Type*} [Fintype ι] + (D : Derivation C L L) (ε : ι → ℕ) (f : ι → L) + (A : Matrix ι ι C) : + indexedDedekindLocalWronskian D ε + (indexedDedekindLocalColumnCombination f A) = + indexedDedekindLocalWronskian D ε f * + A.map (algebraMap C L) := by + classical + apply Matrix.ext + intro i j + rw [Matrix.mul_apply] + simp only [indexedDedekindLocalWronskian, + indexedDedekindLocalColumnCombination, Matrix.map_apply] + rw [derivation_iterate_sum_smul] + simp only [Algebra.smul_def] + apply Finset.sum_congr rfl + intro k _ + exact mul_comm _ _ + +/-- A determinant-one constant column operation preserves the indexed DVR +Wronskian determinant. -/ +theorem indexedDedekindLocalWronskian_det_columnCombination_of_det_eq_one + {ι : Type*} [Fintype ι] [DecidableEq ι] + (D : Derivation C L L) (ε : ι → ℕ) (f : ι → L) + (A : Matrix ι ι C) (hA : A.det = 1) : + (indexedDedekindLocalWronskian D ε + (indexedDedekindLocalColumnCombination f A)).det = + (indexedDedekindLocalWronskian D ε f).det := by + rw [indexedDedekindLocalWronskian_columnCombination, Matrix.det_mul] + have hdetmap : (A.map (algebraMap C L)).det = 1 := by + calc + (A.map (algebraMap C L)).det = algebraMap C L A.det := by + simpa using ((algebraMap C L).map_det A).symm + _ = 1 := by rw [hA, map_one] + rw [hdetmap, mul_one] + +omit [IsDedekindDomain R] [IsFractionRing R L] [IsDiscreteValuationRing R] + [Algebra C R] [IsScalarTower C R L] in +private theorem derivation_iterate_algebraMap_exists + (D : Derivation C L L) + (hDIntegral : ∀ r : R, ∃ s : R, + D (algebraMap R L r) = algebraMap R L s) + (m : ℕ) (r : R) : + ∃ s : R, ((D : L → L)^[m]) (algebraMap R L r) = algebraMap R L s := by + induction m with + | zero => exact ⟨r, rfl⟩ + | succ m ih => + rw [Function.iterate_succ_apply'] + obtain ⟨s, hs⟩ := ih + rw [hs] + exact hDIntegral s + +omit [Algebra C R] [IsScalarTower C R L] in +/-- For any DVR-preserving derivation, the indexed Wronskian determinant has +order at least the sum of its column orders minus the sum of its row +derivative orders. Cancellation in the determinant expansion is included. -/ +theorem finitePlaceOrderTop_indexedDedekindLocalWronskian_det_lower_bound_of_preserves + {ι : Type*} [Fintype ι] [DecidableEq ι] + (v : HeightOneSpectrum R) (π : R) (hπ : Irreducible π) + (hπIdeal : v.asIdeal = Ideal.span {π}) + (D : Derivation C L L) + (hDIntegral : ∀ r : R, ∃ s : R, + D (algebraMap R L r) = algebraMap R L s) + (ε : ι → ℕ) (f : ι → L) : + (∑ j, finitePlaceOrderTop v (f j)) + + ((-(∑ i, (ε i : ℤ)) : ℤ) : WithTop ℤ) ≤ + finitePlaceOrderTop v (indexedDedekindLocalWronskian D ε f).det := by + rw [Matrix.det_apply'] + apply le_finitePlaceOrderTop_finset_sum_of_forall + intro σ _ + let term : L := + ((Equiv.Perm.sign σ : ℤ) : L) * + ∏ i, indexedDedekindLocalWronskian D ε f (σ i) i + change + (∑ j, finitePlaceOrderTop v (f j)) + + ((-(∑ i, (ε i : ℤ)) : ℤ) : WithTop ℤ) ≤ + finitePlaceOrderTop v term + calc + (∑ j, finitePlaceOrderTop v (f j)) + + ((-(∑ i, (ε i : ℤ)) : ℤ) : WithTop ℤ) = + ∑ j, (finitePlaceOrderTop v (f j) + + ((-(ε (σ j) : ℤ) : ℤ) : WithTop ℤ)) := by + rw [Finset.sum_add_distrib] + congr 1 + rw [← coe_sum_int] + congr 1 + rw [Finset.sum_neg_distrib] + congr 1 + exact (Equiv.sum_comp σ (fun i ↦ (ε i : ℤ))).symm + _ ≤ ∑ j, finitePlaceOrderTop v + (((D : L → L)^[ε (σ j)]) (f j)) := by + gcongr with j + exact finitePlaceOrderTop_derivation_iterate_ge_sub_nat_of_preserves + v π hπ hπIdeal D hDIntegral (ε (σ j)) (f j) + _ = finitePlaceOrderTop v + (∏ i, indexedDedekindLocalWronskian D ε f (σ i) i) := by + rw [finitePlaceOrderTop_finset_prod] + rfl + _ ≤ finitePlaceOrderTop v term := by + exact finitePlaceOrderTop_le_intCast_mul v + (Equiv.Perm.sign σ : ℤ) + (∏ i, indexedDedekindLocalWronskian D ε f (σ i) i) + +omit [Algebra C R] [IsScalarTower C R L] in +/-- The normalized-uniformizer form retained for compatibility with the +existing local-parameter API. -/ +theorem finitePlaceOrderTop_indexedDedekindLocalWronskian_det_lower_bound + {ι : Type*} [Fintype ι] [DecidableEq ι] + (v : HeightOneSpectrum R) (π : R) (hπ : Irreducible π) + (hπIdeal : v.asIdeal = Ideal.span {π}) + (D : Derivation C L L) + (hDIntegral : ∀ r : R, ∃ s : R, + D (algebraMap R L r) = algebraMap R L s) + (_hDπ : D (algebraMap R L π) = 1) + (ε : ι → ℕ) (f : ι → L) : + (∑ j, finitePlaceOrderTop v (f j)) + + ((-(∑ i, (ε i : ℤ)) : ℤ) : WithTop ℤ) ≤ + finitePlaceOrderTop v (indexedDedekindLocalWronskian D ε f).det := + finitePlaceOrderTop_indexedDedekindLocalWronskian_det_lower_bound_of_preserves + v π hπ hπIdeal D hDIntegral ε f + +omit [IsDiscreteValuationRing R] [Algebra C R] [IsScalarTower C R L] in +/-- If every column is represented by an element of the DVR and the +derivation preserves the DVR, then the indexed Wronskian determinant is +regular. This is the direct DVR analogue of the regular local auxiliary +case. -/ +theorem finitePlaceOrderTop_indexedDedekindLocalWronskian_det_nonnegative_of_integral + {ι : Type*} [Fintype ι] [DecidableEq ι] + (v : HeightOneSpectrum R) (D : Derivation C L L) + (hDIntegral : ∀ r : R, ∃ s : R, + D (algebraMap R L r) = algebraMap R L s) + (ε : ι → ℕ) (f : ι → L) + (hfIntegral : ∀ j, ∃ r : R, f j = algebraMap R L r) : + (0 : WithTop ℤ) ≤ + finitePlaceOrderTop v (indexedDedekindLocalWronskian D ε f).det := by + rw [Matrix.det_apply'] + apply le_finitePlaceOrderTop_finset_sum_of_forall + intro σ _ + let term : L := + ((Equiv.Perm.sign σ : ℤ) : L) * + ∏ i, indexedDedekindLocalWronskian D ε f (σ i) i + change (0 : WithTop ℤ) ≤ finitePlaceOrderTop v term + calc + (0 : WithTop ℤ) = ∑ _i : ι, (0 : WithTop ℤ) := by simp + _ ≤ ∑ i, finitePlaceOrderTop v + (indexedDedekindLocalWronskian D ε f (σ i) i) := by + gcongr with i + obtain ⟨r, hr⟩ := hfIntegral i + obtain ⟨s, hs⟩ := derivation_iterate_algebraMap_exists + D hDIntegral (ε (σ i)) r + have hentry : indexedDedekindLocalWronskian D ε f (σ i) i = + algebraMap R L s := by + simp only [indexedDedekindLocalWronskian, hr, hs] + rw [hentry] + exact finitePlaceOrderTop_algebraMap_nonnegative (L := L) v s + _ = finitePlaceOrderTop v + (∏ i, indexedDedekindLocalWronskian D ε f (σ i) i) := by + rw [finitePlaceOrderTop_finset_prod] + _ ≤ finitePlaceOrderTop v term := by + exact finitePlaceOrderTop_le_intCast_mul v + (Equiv.Perm.sign σ : ℤ) + (∏ i, indexedDedekindLocalWronskian D ε f (σ i) i) + +omit [Algebra C R] [IsScalarTower C R L] in +/-- The indexed determinant estimate after a determinant-one constant column +operation, assuming only that the derivation preserves the DVR. -/ +theorem + finitePlaceOrderTop_dedekindLocalWronskian_det_lower_bound_after_columnCombination_of_preserves + {ι : Type*} [Fintype ι] [DecidableEq ι] + (v : HeightOneSpectrum R) (π : R) (hπ : Irreducible π) + (hπIdeal : v.asIdeal = Ideal.span {π}) + (D : Derivation C L L) + (hDIntegral : ∀ r : R, ∃ s : R, + D (algebraMap R L r) = algebraMap R L s) + (ε : ι → ℕ) (f : ι → L) (A : Matrix ι ι C) (hA : A.det = 1) : + (∑ j, finitePlaceOrderTop v + (indexedDedekindLocalColumnCombination f A j)) + + ((-(∑ i, (ε i : ℤ)) : ℤ) : WithTop ℤ) ≤ + finitePlaceOrderTop v (indexedDedekindLocalWronskian D ε f).det := by + rw [← indexedDedekindLocalWronskian_det_columnCombination_of_det_eq_one + D ε f A hA] + exact finitePlaceOrderTop_indexedDedekindLocalWronskian_det_lower_bound_of_preserves + v π hπ hπIdeal D hDIntegral ε + (indexedDedekindLocalColumnCombination f A) + +omit [Algebra C R] [IsScalarTower C R L] in +/-- The indexed determinant estimate after a determinant-one constant column +operation. This normalized form is retained for the local-parameter API. -/ +theorem finitePlaceOrderTop_indexedDedekindLocalWronskian_det_lower_bound_after_columnCombination + {ι : Type*} [Fintype ι] [DecidableEq ι] + (v : HeightOneSpectrum R) (π : R) (hπ : Irreducible π) + (hπIdeal : v.asIdeal = Ideal.span {π}) + (D : Derivation C L L) + (hDIntegral : ∀ r : R, ∃ s : R, + D (algebraMap R L r) = algebraMap R L s) + (hDπ : D (algebraMap R L π) = 1) + (ε : ι → ℕ) (f : ι → L) (A : Matrix ι ι C) (hA : A.det = 1) : + (∑ j, finitePlaceOrderTop v + (indexedDedekindLocalColumnCombination f A j)) + + ((-(∑ i, (ε i : ℤ)) : ℤ) : WithTop ℤ) ≤ + finitePlaceOrderTop v (indexedDedekindLocalWronskian D ε f).det := by + rw [← indexedDedekindLocalWronskian_det_columnCombination_of_det_eq_one + D ε f A hA] + exact finitePlaceOrderTop_indexedDedekindLocalWronskian_det_lower_bound + v π hπ hπIdeal D hDIntegral hDπ ε + (indexedDedekindLocalColumnCombination f A) + +/-- Change of parameter for an indexed ordinary Wronskian whose derivative +orders are `0, ..., n - 1`, transported along an explicit equivalence. -/ +theorem indexedDedekindLocalWronskian_det_changeParameter + {ι : Type*} [Fintype ι] [DecidableEq ι] + {n : ℕ} (e : ι ≃ Fin n) (ε : ι → ℕ) + (hε : ∀ i, ε i = (e i : ℕ)) + (D E : Derivation C L L) (a : L) (hD : D = a • E) + (f : ι → L) : + (indexedDedekindLocalWronskian D ε f).det = + a ^ n.choose 2 * (indexedDedekindLocalWronskian E ε f).det := by + let g : Fin n → L := fun j ↦ f (e.symm j) + have hreindexD : Matrix.reindex e e + (indexedDedekindLocalWronskian D ε f) = + BGS.Algebra.derivationWronskian D g := by + ext i j + change ((D : L → L)^[ε (e.symm i)]) (f (e.symm j)) = + (D.toLinearMap ^ (i : ℕ)) (f (e.symm j)) + rw [hε] + simp only [e.apply_symm_apply] + induction i.1 with + | zero => simp + | succ r ih => + rw [Function.iterate_succ_apply', pow_succ', Module.End.mul_apply, ih] + rfl + have hreindexE : Matrix.reindex e e + (indexedDedekindLocalWronskian E ε f) = + BGS.Algebra.derivationWronskian E g := by + ext i j + change ((E : L → L)^[ε (e.symm i)]) (f (e.symm j)) = + (E.toLinearMap ^ (i : ℕ)) (f (e.symm j)) + rw [hε] + simp only [e.apply_symm_apply] + induction i.1 with + | zero => simp + | succ r ih => + rw [Function.iterate_succ_apply', pow_succ', Module.End.mul_apply, ih] + rfl + calc + (indexedDedekindLocalWronskian D ε f).det = + (Matrix.reindex e e + (indexedDedekindLocalWronskian D ε f)).det := by + rw [Matrix.det_reindex_self] + _ = (BGS.Algebra.derivationWronskian D g).det := by rw [hreindexD] + _ = a ^ n.choose 2 * + (BGS.Algebra.derivationWronskian E g).det := + derivationWronskian_det_changeParameter D E a hD g + _ = a ^ n.choose 2 * + (Matrix.reindex e e + (indexedDedekindLocalWronskian E ε f)).det := by rw [hreindexE] + _ = a ^ n.choose 2 * + (indexedDedekindLocalWronskian E ε f).det := by + rw [Matrix.det_reindex_self] + +omit [Algebra C R] [IsScalarTower C R L] in +/-- Indexed scaled-derivation estimate. The equivalence certifies that the +row orders are precisely the ordinary derivative orders, so the scalar costs +the expected triangular exponent. -/ +theorem finitePlaceOrderTop_indexedDedekindLocalWronskian_det_lower_bound_of_scaled_preserves + {ι : Type*} [Fintype ι] [DecidableEq ι] + {n : ℕ} (e : ι ≃ Fin n) (ε : ι → ℕ) + (hε : ∀ i, ε i = (e i : ℕ)) + (v : HeightOneSpectrum R) (π : R) (hπ : Irreducible π) + (hπIdeal : v.asIdeal = Ideal.span {π}) + (D : Derivation C L L) (c : L) + (hScaledIntegral : ∀ r : R, ∃ s : R, + (c • D) (algebraMap R L r) = algebraMap R L s) + (f : ι → L) : + (∑ j, finitePlaceOrderTop v (f j)) + + ((-(∑ i, (ε i : ℤ)) : ℤ) : WithTop ℤ) ≤ + n.choose 2 • finitePlaceOrderTop v c + + finitePlaceOrderTop v + (indexedDedekindLocalWronskian D ε f).det := by + calc + (∑ j, finitePlaceOrderTop v (f j)) + + ((-(∑ i, (ε i : ℤ)) : ℤ) : WithTop ℤ) ≤ + finitePlaceOrderTop v + (indexedDedekindLocalWronskian (c • D) ε f).det := + finitePlaceOrderTop_indexedDedekindLocalWronskian_det_lower_bound_of_preserves + v π hπ hπIdeal (c • D) hScaledIntegral ε f + _ = finitePlaceOrderTop v + (c ^ n.choose 2 * + (indexedDedekindLocalWronskian D ε f).det) := by + rw [indexedDedekindLocalWronskian_det_changeParameter + e ε hε (c • D) D c rfl f] + _ = n.choose 2 • finitePlaceOrderTop v c + + finitePlaceOrderTop v + (indexedDedekindLocalWronskian D ε f).det := by + rw [finitePlaceOrderTop_mul, finitePlaceOrderTop_pow] + +/-- The ordinary `n × n` Wronskian, with derivative orders +`0, ..., n - 1`. -/ +def dedekindLocalWronskian {n : ℕ} + (D : Derivation C L L) (f : Fin n → L) : Matrix (Fin n) (Fin n) L := + indexedDedekindLocalWronskian D (fun i ↦ i.1) f + +/-- The direct Dedekind-local Wronskian is definitionally the ordinary +derivation Wronskian used by the change-of-parameter theorem. -/ +theorem dedekindLocalWronskian_eq_derivationWronskian + (D : Derivation C L L) {n : ℕ} (f : Fin n → L) : + dedekindLocalWronskian D f = BGS.Algebra.derivationWronskian D f := by + ext i j + change ((D : L → L)^[i.1]) (f j) = (D.toLinearMap ^ i.1) (f j) + induction i.1 with + | zero => simp + | succ r ih => + rw [Function.iterate_succ_apply', pow_succ', Module.End.mul_apply, ih] + rfl + +/-- Change of parameter for the direct Dedekind-local Wronskian. In +particular this permits replacing a global derivation by a DVR-preserving +scalar multiple while recording the exact triangular valuation cost. -/ +theorem dedekindLocalWronskian_det_changeParameter + (D E : Derivation C L L) (a : L) (hD : D = a • E) + {n : ℕ} (f : Fin n → L) : + (dedekindLocalWronskian D f).det = + a ^ n.choose 2 * (dedekindLocalWronskian E f).det := by + rw [dedekindLocalWronskian_eq_derivationWronskian, + dedekindLocalWronskian_eq_derivationWronskian] + exact derivationWronskian_det_changeParameter D E a hD f + +omit [Algebra C R] [IsScalarTower C R L] in +/-- For a DVR-preserving derivation, the ordinary Wronskian loses at most the +triangular number `n * (n - 1) / 2` from the sum of its column orders. -/ +theorem finitePlaceOrderTop_dedekindLocalWronskian_det_lower_bound_of_preserves + {n : ℕ} + (v : HeightOneSpectrum R) (π : R) (hπ : Irreducible π) + (hπIdeal : v.asIdeal = Ideal.span {π}) + (D : Derivation C L L) + (hDIntegral : ∀ r : R, ∃ s : R, + D (algebraMap R L r) = algebraMap R L s) + (f : Fin n → L) : + (∑ j, finitePlaceOrderTop v (f j)) + + ((-(n * (n - 1) / 2 : ℕ) : ℤ) : WithTop ℤ) ≤ + finitePlaceOrderTop v (dedekindLocalWronskian D f).det := by + convert finitePlaceOrderTop_indexedDedekindLocalWronskian_det_lower_bound_of_preserves + v π hπ hπIdeal D hDIntegral (fun i : Fin n => i.1) f using 1 + · congr 2 + apply congrArg Neg.neg + rw [Fin.sum_univ_eq_sum_range, ← Nat.cast_sum] + exact congrArg (fun x : ℕ => (x : ℤ)) (Finset.sum_range_id n).symm + · rfl + +omit [Algebra C R] [IsScalarTower C R L] in +/-- A scalar multiple of the ambient derivation may be used to obtain a +DVR-preserving local derivation. The right side records exactly the order of +the scalar to the Wronskian triangular exponent; no false formula for +iterates of `c • D` is used. -/ +theorem finitePlaceOrderTop_dedekindLocalWronskian_det_lower_bound_of_scaled_preserves + {n : ℕ} + (v : HeightOneSpectrum R) (π : R) (hπ : Irreducible π) + (hπIdeal : v.asIdeal = Ideal.span {π}) + (D : Derivation C L L) (c : L) + (hScaledIntegral : ∀ r : R, ∃ s : R, + (c • D) (algebraMap R L r) = algebraMap R L s) + (f : Fin n → L) : + (∑ j, finitePlaceOrderTop v (f j)) + + ((-(n * (n - 1) / 2 : ℕ) : ℤ) : WithTop ℤ) ≤ + n.choose 2 • finitePlaceOrderTop v c + + finitePlaceOrderTop v (dedekindLocalWronskian D f).det := by + calc + (∑ j, finitePlaceOrderTop v (f j)) + + ((-(n * (n - 1) / 2 : ℕ) : ℤ) : WithTop ℤ) ≤ + finitePlaceOrderTop v + (dedekindLocalWronskian (c • D) f).det := + finitePlaceOrderTop_dedekindLocalWronskian_det_lower_bound_of_preserves + v π hπ hπIdeal (c • D) hScaledIntegral f + _ = finitePlaceOrderTop v + (c ^ n.choose 2 * (dedekindLocalWronskian D f).det) := by + rw [dedekindLocalWronskian_det_changeParameter (c • D) D c rfl f] + _ = n.choose 2 • finitePlaceOrderTop v c + + finitePlaceOrderTop v (dedekindLocalWronskian D f).det := by + rw [finitePlaceOrderTop_mul, finitePlaceOrderTop_pow] + +omit [Algebra C R] [IsScalarTower C R L] in +/-- The ordinary Wronskian loses at most the triangular number +`n * (n - 1) / 2` from the sum of its column orders. This normalized form is +retained for the local-parameter API. -/ +theorem finitePlaceOrderTop_dedekindLocalWronskian_det_lower_bound + {n : ℕ} + (v : HeightOneSpectrum R) (π : R) (hπ : Irreducible π) + (hπIdeal : v.asIdeal = Ideal.span {π}) + (D : Derivation C L L) + (hDIntegral : ∀ r : R, ∃ s : R, + D (algebraMap R L r) = algebraMap R L s) + (hDπ : D (algebraMap R L π) = 1) + (f : Fin n → L) : + (∑ j, finitePlaceOrderTop v (f j)) + + ((-(n * (n - 1) / 2 : ℕ) : ℤ) : WithTop ℤ) ≤ + finitePlaceOrderTop v (dedekindLocalWronskian D f).det := by + convert finitePlaceOrderTop_indexedDedekindLocalWronskian_det_lower_bound + v π hπ hπIdeal D hDIntegral hDπ (fun i : Fin n ↦ i.1) f using 1 + · congr 2 + apply congrArg Neg.neg + rw [Fin.sum_univ_eq_sum_range, ← Nat.cast_sum] + exact congrArg (fun x : ℕ ↦ (x : ℤ)) (Finset.sum_range_id n).symm + · rfl + +end DVR + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/DedekindLocalizationDerivationPreservation.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/DedekindLocalizationDerivationPreservation.lean new file mode 100644 index 0000000000..65c134e97a --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/DedekindLocalizationDerivationPreservation.lean @@ -0,0 +1,118 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import Mathlib.RingTheory.Derivation.Basic +public import Mathlib.RingTheory.Localization.Basic +public import Mathlib.RingTheory.Localization.FractionRing +public import Mathlib.Tactic + +/-! +# Derivations preserving localizations + +An ambient derivation that maps a domain into itself also maps every prime +localization into itself. The statement deliberately does not require an +algebra structure from the derivation's constant ring to the localized ring; +that structure need not exist in the Frobenius-constant application. +-/ + +@[expose] public section + +namespace BGS.CorvajaZannier + +noncomputable section + +/-- An ambient derivation which preserves a domain also preserves each of its +localizations at a prime. This is the quotient-rule bridge from a global +different-annihilator certificate to the local DVR Wronskian bounds. -/ +theorem ambientDerivation_preserves_localizationAtPrime_of_preserves + {C R U : Type*} [CommRing C] [CommRing R] [IsDomain R] [Field U] + [Algebra C U] [Algebra R U] [IsFractionRing R U] + (q : Ideal R) [q.IsPrime] + [Algebra (Localization.AtPrime q) U] + [IsScalarTower R (Localization.AtPrime q) U] + (E : Derivation C U U) + (hE : ∀ r : R, ∃ r' : R, + E (algebraMap R U r) = algebraMap R U r') : + ∀ z : Localization.AtPrime q, ∃ z' : Localization.AtPrime q, + E (algebraMap (Localization.AtPrime q) U z) = + algebraMap (Localization.AtPrime q) U z' := by + intro z + obtain ⟨⟨a, d, hd⟩, hzd⟩ := IsLocalization.surj q.primeCompl z + obtain ⟨a', ha'⟩ := hE a + obtain ⟨d', hd'⟩ := hE d + let dSub : q.primeCompl := ⟨d, hd⟩ + let invD : Localization.AtPrime q := + IsLocalization.mk' (Localization.AtPrime q) 1 dSub + let z' : Localization.AtPrime q := + (algebraMap R (Localization.AtPrime q) a' - + z * algebraMap R (Localization.AtPrime q) d') * invD + have hd0 : d ≠ 0 := by + intro hdZero + exact hd (hdZero ▸ q.zero_mem) + have hdU : algebraMap R U d ≠ 0 := by + simpa using (IsFractionRing.injective R U).ne hd0 + have hzdU : + algebraMap (Localization.AtPrime q) U z * algebraMap R U d = + algebraMap R U a := by + calc + algebraMap (Localization.AtPrime q) U z * algebraMap R U d = + algebraMap (Localization.AtPrime q) U z * + algebraMap (Localization.AtPrime q) U + (algebraMap R (Localization.AtPrime q) d) := by + rw [IsScalarTower.algebraMap_apply R + (Localization.AtPrime q) U d] + _ = algebraMap (Localization.AtPrime q) U + (z * algebraMap R (Localization.AtPrime q) d) := by + rw [map_mul] + _ = algebraMap (Localization.AtPrime q) U + (algebraMap R (Localization.AtPrime q) a) := by rw [hzd] + _ = algebraMap R U a := + (IsScalarTower.algebraMap_apply R (Localization.AtPrime q) U a).symm + have hder := congrArg (fun x : U => E x) hzdU + rw [E.leibniz, ha', hd'] at hder + have hder' : + E (algebraMap (Localization.AtPrime q) U z) * algebraMap R U d + + algebraMap (Localization.AtPrime q) U z * algebraMap R U d' = + algebraMap R U a' := by + simp only [Algebra.smul_def, Algebra.algebraMap_self_apply] at hder + linear_combination hder + have hinv : + algebraMap (Localization.AtPrime q) U invD * algebraMap R U d = 1 := by + have hspec := IsLocalization.mk'_spec + (Localization.AtPrime q) (1 : R) dSub + calc + algebraMap (Localization.AtPrime q) U invD * algebraMap R U d = + algebraMap (Localization.AtPrime q) U invD * + algebraMap (Localization.AtPrime q) U + (algebraMap R (Localization.AtPrime q) d) := by + rw [IsScalarTower.algebraMap_apply R + (Localization.AtPrime q) U d] + _ = algebraMap (Localization.AtPrime q) U + (invD * algebraMap R (Localization.AtPrime q) d) := by rw [map_mul] + _ = algebraMap (Localization.AtPrime q) U + (algebraMap R (Localization.AtPrime q) 1) := by + rw [show invD * algebraMap R (Localization.AtPrime q) d = + algebraMap R (Localization.AtPrime q) 1 by + simp [invD, dSub]] + _ = 1 := by simp + refine ⟨z', ?_⟩ + apply mul_right_cancel₀ hdU + calc + E (algebraMap (Localization.AtPrime q) U z) * algebraMap R U d = + algebraMap R U a' - + algebraMap (Localization.AtPrime q) U z * algebraMap R U d' := + eq_sub_of_add_eq hder' + _ = algebraMap (Localization.AtPrime q) U z' * algebraMap R U d := by + simp only [z', map_mul, map_sub] + rw [← IsScalarTower.algebraMap_apply R (Localization.AtPrime q) U a', + ← IsScalarTower.algebraMap_apply R (Localization.AtPrime q) U d'] + rw [mul_assoc, hinv, mul_one] + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/DedekindLocalizationOrder.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/DedekindLocalizationOrder.lean new file mode 100644 index 0000000000..c2ebfd16e0 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/DedekindLocalizationOrder.lean @@ -0,0 +1,233 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.DedekindPlaceOrder +public import Mathlib.RingTheory.Valuation.Discrete.IsDiscreteValuationRing +public import Mathlib.Tactic + +/-! +# Compatibility of global and localized Dedekind orders + +The height-one valuation of a Dedekind domain and the maximal-ideal +valuation of its localization at that height-one prime have the same +normalization. This file proves equality, rather than equivalence up to an +unspecified rescaling, and transfers the associated principal-ideal orders. +-/ + +@[expose] public section + +open scoped nonZeroDivisors +open IsDedekindDomain Multiplicative WithZero + +namespace BGS.CorvajaZannier + +noncomputable section + +/-- Equivalent surjective valuations with value group `ℤᵐ⁰` have the same +normalization. Surjectivity rules out a nontrivial integral rescaling. -/ +theorem valuation_eq_of_isEquiv_of_surjective + {F : Type*} [Field F] + {v w : Valuation F ℤᵐ⁰} + (h : v.IsEquiv w) + (hv : Function.Surjective v) + (hw : Function.Surjective w) : + v = w := by + ext x + by_cases hx : x = 0 + · simp [hx] + obtain ⟨π, hπv⟩ := hv (exp (-1 : ℤ)) + obtain ⟨ρ, hρw⟩ := hw (exp (-1 : ℤ)) + have hπw0 : w π ≠ 0 := by + intro hzero + have : v π = 0 := h.eq_zero.mpr hzero + rw [hπv] at this + exact exp_ne_zero this + have hρv0 : v ρ ≠ 0 := by + intro hzero + have : w ρ = 0 := h.eq_zero.mp hzero + rw [hρw] at this + exact exp_ne_zero this + let a : ℤ := log (w π) + let b : ℤ := log (v ρ) + have hπw : w π = exp a := by + simpa [a] using (exp_log hπw0).symm + have hρv : v ρ = exp b := by + simpa [b] using (exp_log hρv0).symm + have ha : a < 0 := by + rw [← exp_lt_exp, ← hπw] + have hvlt : v π < v 1 := by + rw [hπv, map_one] + simp + simpa using h.lt_iff_lt.mp hvlt + have hb : b < 0 := by + rw [← exp_lt_exp, ← hρv] + have hwlt : w ρ < w 1 := by + rw [hρw, map_one] + simp + simpa using h.lt_iff_lt.mpr hwlt + have hwEq : w π = w (ρ ^ (-a)) := by + rw [hπw, map_zpow₀, hρw, ← exp_zsmul] + congr 1 + simp + have hvEq : v π = v (ρ ^ (-a)) := h.eq_iff.mpr hwEq + have hab : (-a) * b = -1 := by + rw [hπv, map_zpow₀, hρv, ← exp_zsmul] at hvEq + apply exp_injective + simpa [mul_comm] using hvEq.symm + have ha1 : a = -1 := by nlinarith + have hπw1 : w π = exp (-1 : ℤ) := by simpa [ha1] using hπw + have hwx0 : w x ≠ 0 := by simpa using hx + let n : ℤ := log (w x) + have hwx : w x = exp n := by + simpa [n] using (exp_log hwx0).symm + have hwPow : w x = w (π ^ (-n)) := by + rw [hwx, map_zpow₀, hπw1, ← exp_zsmul] + congr 1 + simp + have hvPow : v x = v (π ^ (-n)) := h.eq_iff.mpr hwPow + rw [map_zpow₀, hπv, ← exp_zsmul] at hvPow + calc + v x = exp n := by simpa using hvPow + _ = w x := hwx.symm + +section FractionRingEquiv + +variable {R L : Type*} [CommRing R] [IsDedekindDomain R] + [Field L] [Algebra R L] [IsFractionRing R L] + +/-- The canonical equivalence from the chosen fraction-ring model preserves +every normalized height-one valuation. -/ +theorem fractionRingAlgEquiv_valuation + (q : HeightOneSpectrum R) (x : FractionRing R) : + q.valuation L (FractionRing.algEquiv R L x) = + q.valuation (FractionRing R) x := by + obtain ⟨a, b, hb, rfl⟩ := IsFractionRing.div_surjective R x + rw [map_div₀, (FractionRing.algEquiv R L).commutes a, + (FractionRing.algEquiv R L).commutes b, + Valuation.map_div, Valuation.map_div, + q.valuation_of_algebraMap, q.valuation_of_algebraMap, + q.valuation_of_algebraMap, q.valuation_of_algebraMap] + +/-- The canonical fraction-ring equivalence preserves the additive order at +every height-one prime, including Mathlib's zero-order convention. -/ +theorem fractionRingAlgEquiv_finitePlaceOrder_eq + (q : HeightOneSpectrum R) (x : FractionRing R) : + finitePlaceOrder q (FractionRing.algEquiv R L x) = + finitePlaceOrder q x := by + by_cases hx : x = 0 + · subst x + simp only [map_zero, finitePlaceOrder, + FractionalIdeal.spanSingleton_zero, FractionalIdeal.count_zero] + · have hmap : FractionRing.algEquiv R L x ≠ 0 := by simpa using hx + have hactual := valuation_eq_exp_neg_finitePlaceOrder + q (FractionRing.algEquiv R L x) hmap + have hcanonical := valuation_eq_exp_neg_finitePlaceOrder q x hx + rw [fractionRingAlgEquiv_valuation q x, hcanonical] at hactual + exact neg_injective (exp_injective hactual.symm) + +end FractionRingEquiv + +variable {R S L : Type*} + [CommRing R] [IsDedekindDomain R] + [CommRing S] [IsDomain S] [IsDiscreteValuationRing S] + [Field L] + [Algebra R S] [Algebra R L] [Algebra S L] + [IsScalarTower R S L] + [IsFractionRing R L] + [IsFractionRing S L] + +/-- The normalized valuation of the maximal ideal of `R_q` is the normalized +height-one valuation attached to `q`. -/ +theorem localizationAtPrime_valuation_eq + (q : HeightOneSpectrum R) + [IsLocalization q.asIdeal.primeCompl S] : + (IsDiscreteValuationRing.maximalIdeal S).valuation L = q.valuation L := by + apply valuation_eq_of_isEquiv_of_surjective + · rw [Valuation.isEquiv_iff_val_le_one] + intro x + constructor + · intro hlocal + obtain ⟨s, hs⟩ := IsDiscreteValuationRing.exists_lift_of_le_one hlocal + obtain ⟨⟨a, d, hd⟩, had⟩ := IsLocalization.surj q.asIdeal.primeCompl s + have hdOne : q.valuation L (algebraMap R L d) = 1 := by + rw [HeightOneSpectrum.valuation_eq_one_iff_notMem] + exact hd + have hEq : + algebraMap S L s * algebraMap R L d = algebraMap R L a := by + calc + algebraMap S L s * algebraMap R L d = + algebraMap S L (s * algebraMap R S d) := by + rw [map_mul, IsScalarTower.algebraMap_apply R S L] + _ = algebraMap S L (algebraMap R S a) := by + exact congrArg (algebraMap S L) (by simpa using had) + _ = algebraMap R L a := + (IsScalarTower.algebraMap_apply R S L a).symm + have hValEq := congrArg (q.valuation L) hEq + rw [map_mul, hdOne, mul_one] at hValEq + rw [← hs, hValEq] + exact HeightOneSpectrum.valuation_le_one (K := L) q a + · intro hglobal + obtain ⟨a, d, had⟩ := + HeightOneSpectrum.exists_primeCompl_mul_eq_of_integer q x hglobal + let s : S := IsLocalization.mk' S a d + have hs : algebraMap S L s = x := by + have hdR : (d : R) ≠ 0 := by + intro hd0 + exact d.2 (hd0 ▸ q.asIdeal.zero_mem) + have hdL : algebraMap R L (d : R) ≠ 0 := by + simpa only [map_zero] using (IsFractionRing.injective R L).ne hdR + apply (mul_right_cancel₀ hdL) + calc + algebraMap S L s * algebraMap R L (d : R) = + algebraMap S L (s * algebraMap R S (d : R)) := by + rw [map_mul, IsScalarTower.algebraMap_apply R S L] + _ = algebraMap R L a := by + dsimp [s] + rw [IsLocalization.mk'_spec, + IsScalarTower.algebraMap_apply R S L] + _ = x * algebraMap R L (d : R) := had.symm + rw [← hs] + exact HeightOneSpectrum.valuation_le_one + (K := L) (IsDiscreteValuationRing.maximalIdeal S) s + · exact (IsDiscreteValuationRing.maximalIdeal S).valuation_surjective L + · exact q.valuation_surjective L + +/-- Principal-ideal orders computed globally and in the localized DVR agree. -/ +theorem localizationAtPrime_finitePlaceOrder_eq + (q : HeightOneSpectrum R) + [IsLocalization q.asIdeal.primeCompl S] + (x : L) : + finitePlaceOrder (IsDiscreteValuationRing.maximalIdeal S) x = + finitePlaceOrder q x := by + by_cases hx : x = 0 + · subst x + simp only [finitePlaceOrder, FractionalIdeal.spanSingleton_zero, + FractionalIdeal.count_zero] + · have hlocal := valuation_eq_exp_neg_finitePlaceOrder + (IsDiscreteValuationRing.maximalIdeal S) x hx + have hglobal := valuation_eq_exp_neg_finitePlaceOrder q x hx + rw [localizationAtPrime_valuation_eq q, hglobal] at hlocal + exact neg_injective (exp_injective hlocal.symm) + +/-- `WithTop`-valued orders computed globally and in the localized DVR agree, +including the zero element. -/ +theorem localizationAtPrime_finitePlaceOrderTop_eq + (q : HeightOneSpectrum R) + [IsLocalization q.asIdeal.primeCompl S] + (x : L) : + finitePlaceOrderTop (IsDiscreteValuationRing.maximalIdeal S) x = + finitePlaceOrderTop q x := by + by_cases hx : x = 0 + · simp [hx] + · rw [finitePlaceOrderTop_eq_coe _ _ hx, + finitePlaceOrderTop_eq_coe _ _ hx, + localizationAtPrime_finitePlaceOrder_eq q x] + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/DedekindPerfectResidueCaseI.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/DedekindPerfectResidueCaseI.lean new file mode 100644 index 0000000000..d3d2cea155 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/DedekindPerfectResidueCaseI.lean @@ -0,0 +1,595 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.DedekindAuxiliaryCaseI +public import Mathlib.FieldTheory.Perfect + +/-! +# Corvaja--Zannier case (i) over a perfect residue field + +The usual leading-coefficient cancellation in local case (i) does not require +the global constant field to surject onto the residue field. In +characteristic `p`, it is enough that the residue field is perfect. Given the +ratio of two unit leading coefficients, choose its `p`-th root in the residue +field, lift that root to the DVR, and use the `p`-th power of the lift. This +coefficient is regular and belongs to the Frobenius subfield of the fraction +field, hence is killed by the separating derivation. + +This file packages that argument and then repeats the determinant-one +elimination from `DedekindAuxiliaryCaseI` with coefficients in the Frobenius +subfield. No algebra structure from the whole Frobenius subfield to the DVR +is asserted: such a structure would be false at a nontrivial place. +-/ + +@[expose] public section + +namespace BGS.CorvajaZannier + +noncomputable section + +open scoped Matrix BigOperators +open IsDedekindDomain Multiplicative WithZero + +variable {R L : Type*} [CommRing R] [IsDedekindDomain R] + [IsDiscreteValuationRing R] [Field L] [Algebra R L] + [IsFractionRing R L] + {p : ℕ} [Fact p.Prime] [CharP R p] [CharP L p] + +omit [IsDiscreteValuationRing R] [IsFractionRing R L] in +/-- Over a perfect residue field, the ratio of two unit leading coefficients +can be cancelled by a regular element whose image in the fraction field is a +`p`-th power. + +The extra witness `b : R` records regularity of the coefficient; its image in +`L` is the coefficient represented by `c : L^p`. -/ +theorem exists_frobeniusSubfield_regular_unit_sub_mul_mem_of_perfect_residue + (v : HeightOneSpectrum R) + [PerfectField v.asIdeal.ResidueField] + (u w : Rˣ) : + ∃ (c : frobeniusSubfield L p) (b : R), + algebraMap (frobeniusSubfield L p) L c = algebraMap R L b ∧ + (u : R) - b * (w : R) ∈ v.asIdeal := by + let κ := v.asIdeal.ResidueField + let : CharP κ p := + CharP.of_ringHom_of_ne_zero (algebraMap R κ) p + (Fact.out : p.Prime).ne_zero + let : ExpChar κ p := inferInstance + let ratio : κ := algebraMap R κ (((u * w⁻¹ : Rˣ) : R)) + obtain ⟨z, hz⟩ := surjective_frobenius κ p ratio + obtain ⟨a, ha⟩ := v.asIdeal.algebraMap_residueField_surjective z + let b : R := a ^ p + have hbMap : algebraMap R κ b = ratio := by + rw [show algebraMap R κ b = (algebraMap R κ a) ^ p by + simp [b]] + rw [ha] + simpa [frobenius_def] using hz + have hbCancel : (u : R) - b * (w : R) ∈ v.asIdeal := by + rw [← Ideal.algebraMap_residueField_eq_zero] + rw [map_sub, map_mul, hbMap] + dsimp [ratio] + rw [← map_mul] + simp + change algebraMap R κ (u : R) - algebraMap R κ (u : R) = 0 + exact sub_self _ + have hbFrob : algebraMap R L b ∈ frobeniusSubfield L p := by + refine ⟨algebraMap R L a, ?_⟩ + simp [frobenius_def, b] + let c : frobeniusSubfield L p := ⟨algebraMap R L b, hbFrob⟩ + refine ⟨c, b, ?_, hbCancel⟩ + rfl + +/-- Equal-order nonzero functions admit a strict leading-term cancellation +with a coefficient in the Frobenius subfield whenever the residue field is +perfect. -/ +theorem exists_frobeniusSubfield_finitePlaceOrder_sub_mul_eq_zero_or_lt_of_perfect_residue + (v : HeightOneSpectrum R) + [PerfectField v.asIdeal.ResidueField] + (x y : L) (hx : x ≠ 0) (hy : y ≠ 0) + (horder : finitePlaceOrder v x = finitePlaceOrder v y) : + ∃ c : frobeniusSubfield L p, + x - algebraMap (frobeniusSubfield L p) L c * y = 0 ∨ + finitePlaceOrder v x < finitePlaceOrder v + (x - algebraMap (frobeniusSubfield L p) L c * y) := by + obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible R + have hπIdeal : v.asIdeal = Ideal.span {π} := by + calc + v.asIdeal = IsLocalRing.maximalIdeal R := + IsLocalRing.eq_maximalIdeal v.isMaximal + _ = Ideal.span {π} := + (IsDiscreteValuationRing.irreducible_iff_uniformizer π).mp hπ + obtain ⟨nx, ux, hxrepr⟩ := + IsDiscreteValuationRing.exists_units_eq_smul_zpow_of_irreducible + (K := L) hπ hx + obtain ⟨ny, uy, hyrepr⟩ := + IsDiscreteValuationRing.exists_units_eq_smul_zpow_of_irreducible + (K := L) hπ hy + have hxrepr' : + x = algebraMap R L (ux : R) * (algebraMap R L π) ^ nx := by + simpa [Units.smul_def, Algebra.smul_def] using hxrepr + have hyrepr' : + y = algebraMap R L (uy : R) * (algebraMap R L π) ^ ny := by + simpa [Units.smul_def, Algebra.smul_def] using hyrepr + have hxOrder : finitePlaceOrder v x = nx := by + rw [hxrepr'] + exact finitePlaceOrder_unit_mul_uniformizer_zpow + v π hπ hπIdeal ux nx + have hyOrder : finitePlaceOrder v y = ny := by + rw [hyrepr'] + exact finitePlaceOrder_unit_mul_uniformizer_zpow + v π hπ hπIdeal uy ny + have hnxny : nx = ny := by omega + rw [← hnxny] at hyrepr' + obtain ⟨c, b, hc, hb⟩ := + exists_frobeniusSubfield_regular_unit_sub_mul_mem_of_perfect_residue + (L := L) (p := p) v ux uy + let a : R := (ux : R) - b * (uy : R) + have haMem : a ∈ v.asIdeal := by simpa [a] using hb + have hfactor : + x - algebraMap (frobeniusSubfield L p) L c * y = + algebraMap R L a * (algebraMap R L π) ^ nx := by + rw [hxrepr', hyrepr', hc] + simp only [a, map_sub, map_mul] + ring + by_cases ha : a = 0 + · refine ⟨c, Or.inl ?_⟩ + rw [hfactor, ha, map_zero, zero_mul] + · refine ⟨c, Or.inr ?_⟩ + have haMap : algebraMap R L a ≠ 0 := by + intro hzero + apply ha + exact IsFractionRing.injective R L (by simpa using hzero) + have hπMap : algebraMap R L π ≠ 0 := by + simpa using hπ.ne_zero + have hprod := finitePrincipalDivisor_mul (R := R) + (algebraMap R L a) ((algebraMap R L π) ^ nx) + haMap (zpow_ne_zero nx hπMap) + have hprodOrder := congrArg (fun D ↦ D v) hprod + simp only [finitePrincipalDivisor_apply, Finsupp.add_apply] at hprodOrder + rw [finitePlaceOrder_uniformizer_zpow v π hπ hπIdeal nx] at hprodOrder + have haOrder : (1 : ℤ) ≤ finitePlaceOrder v (algebraMap R L a) := + one_le_finitePlaceOrder_algebraMap_of_mem v a haMem ha + rw [hxOrder, hfactor, hprodOrder] + omega + +/-- Equal negative orders have a Frobenius-subfield cancellation which +strictly lowers the pole-depth measure. -/ +theorem exists_frobeniusSubfield_dedekindPoleDepth_sub_mul_lt_of_perfect_residue + (v : HeightOneSpectrum R) + [PerfectField v.asIdeal.ResidueField] + (x y : L) + (hxneg : finitePlaceOrderTop v x < 0) + (hyneg : finitePlaceOrderTop v y < 0) + (horder : finitePlaceOrderTop v x = finitePlaceOrderTop v y) : + ∃ c : frobeniusSubfield L p, + dedekindPoleDepth v + (x - algebraMap (frobeniusSubfield L p) L c * y) < + dedekindPoleDepth v x ∧ + finitePlaceOrderTop v x < finitePlaceOrderTop v + (x - algebraMap (frobeniusSubfield L p) L c * y) := by + have hx : x ≠ 0 := by + intro h + subst x + simp at hxneg + have hy : y ≠ 0 := by + intro h + subst y + simp at hyneg + have horder' : finitePlaceOrder v x = finitePlaceOrder v y := by + rw [finitePlaceOrderTop_eq_coe v x hx, + finitePlaceOrderTop_eq_coe v y hy] at horder + exact_mod_cast horder + obtain ⟨c, hz | hlt⟩ := + exists_frobeniusSubfield_finitePlaceOrder_sub_mul_eq_zero_or_lt_of_perfect_residue + (p := p) v x y hx hy horder' + · refine ⟨c, ?_, ?_⟩ + · rw [hz] + have hxdepth : 0 < dedekindPoleDepth v x := + (dedekindPoleDepth_pos_iff v x).2 hxneg + simpa only [dedekindPoleDepth_zero] using hxdepth + · rw [hz, finitePlaceOrderTop_eq_coe v x hx] + simp + · by_cases hz : + x - algebraMap (frobeniusSubfield L p) L c * y = 0 + · refine ⟨c, ?_, ?_⟩ + · rw [hz] + have hxdepth : 0 < dedekindPoleDepth v x := + (dedekindPoleDepth_pos_iff v x).2 hxneg + simpa only [dedekindPoleDepth_zero] using hxdepth + · rw [hz, finitePlaceOrderTop_eq_coe v x hx] + simp + · refine ⟨c, ?_, ?_⟩ + · simp only [dedekindPoleDepth, hx, hz, ite_false] + have hxorderneg : finitePlaceOrder v x < 0 := by + rw [finitePlaceOrderTop_eq_coe v x hx] at hxneg + exact_mod_cast hxneg + omega + · rw [finitePlaceOrderTop_eq_coe v x hx, + finitePlaceOrderTop_eq_coe v _ hz] + exact_mod_cast hlt + +private theorem + indexedDedekindLocalColumnCombination_frobenius_transvection_same + {k : ℕ} (f : Fin k → L) (i j : Fin k) + (c : frobeniusSubfield L p) : + indexedDedekindLocalColumnCombination f (Matrix.transvection j i c) i = + f i + c • f j := by + classical + simp [indexedDedekindLocalColumnCombination, Matrix.transvection, + Matrix.single, Matrix.one_apply, add_smul, Finset.sum_add_distrib] + +private theorem + indexedDedekindLocalColumnCombination_frobenius_transvection_ne + {k : ℕ} (f : Fin k → L) (i j b : Fin k) + (c : frobeniusSubfield L p) (hb : b ≠ i) : + indexedDedekindLocalColumnCombination f (Matrix.transvection j i c) b = + f b := by + classical + have hib : i ≠ b := Ne.symm hb + simp [indexedDedekindLocalColumnCombination, Matrix.transvection, + Matrix.single, Matrix.one_apply, hib] + +private theorem indexedDedekindLocalColumnCombination_frobenius_one + {k : ℕ} (f : Fin k → L) : + indexedDedekindLocalColumnCombination f + (1 : Matrix (Fin k) (Fin k) (frobeniusSubfield L p)) = f := by + classical + funext i + simp [indexedDedekindLocalColumnCombination, Matrix.one_apply] + +private theorem + exists_frobeniusSubfield_dedekindPoleWeight_transvection_lt_of_perfect_residue + {k : ℕ} (v : HeightOneSpectrum R) + [PerfectField v.asIdeal.ResidueField] + (f : Fin k → L) (i j : Fin k) + (hi : finitePlaceOrderTop v (f i) < 0) + (hj : finitePlaceOrderTop v (f j) < 0) + (horder : finitePlaceOrderTop v (f i) = finitePlaceOrderTop v (f j)) : + ∃ c : frobeniusSubfield L p, + dedekindPoleWeight v + (indexedDedekindLocalColumnCombination f + (Matrix.transvection j i (-c))) < + dedekindPoleWeight v f ∧ + finitePlaceOrderTop v (f i) < finitePlaceOrderTop v + (f i - algebraMap (frobeniusSubfield L p) L c * f j) := by + obtain ⟨c, hstrict, hraise⟩ := + exists_frobeniusSubfield_dedekindPoleDepth_sub_mul_lt_of_perfect_residue + (p := p) v (f i) (f j) hi hj horder + refine ⟨c, ?_, hraise⟩ + unfold dedekindPoleWeight + apply Finset.sum_lt_sum + · intro b _ + by_cases hb : b = i + · subst b + rw [indexedDedekindLocalColumnCombination_frobenius_transvection_same] + simpa only [Algebra.smul_def, map_neg, sub_eq_add_neg, neg_mul] using + hstrict.le + · rw [indexedDedekindLocalColumnCombination_frobenius_transvection_ne + f i j b (-c) hb] + · refine ⟨i, Finset.mem_univ _, ?_⟩ + rw [indexedDedekindLocalColumnCombination_frobenius_transvection_same] + simpa only [Algebra.smul_def, map_neg, sub_eq_add_neg, neg_mul] using + hstrict + +/-- Repeated equal negative orders can be eliminated over the Frobenius +subfield by a determinant-one matrix when the residue field is perfect. + +Unlike the constant-field version, this theorem does not require an algebra +map from the coefficient field to the DVR. -/ +theorem + exists_det_one_frobeniusSubfield_columnMatrix_negativeOrdersPairwiseDistinct_of_perfect_residue + {k : ℕ} (v : HeightOneSpectrum R) + [PerfectField v.asIdeal.ResidueField] + (a : ℤ) (f : Fin k → L) + (hf : ∀ i, (a : WithTop ℤ) ≤ finitePlaceOrderTop v (f i)) : + ∃ A : Matrix (Fin k) (Fin k) (frobeniusSubfield L p), + A.det = 1 ∧ + NegativeFinitePlaceOrdersPairwiseDistinct v + (indexedDedekindLocalColumnCombination f A) ∧ + ∀ i, (a : WithTop ℤ) ≤ finitePlaceOrderTop v + (indexedDedekindLocalColumnCombination f A i) := by + induction hN : dedekindPoleWeight v f using Nat.strong_induction_on + generalizing f with + | h N ih => + by_cases hdistinct : NegativeFinitePlaceOrdersPairwiseDistinct v f + · refine ⟨(1 : Matrix (Fin k) (Fin k) (frobeniusSubfield L p)), + Matrix.det_one, ?_, ?_⟩ + · simpa [indexedDedekindLocalColumnCombination_frobenius_one] + · simpa [indexedDedekindLocalColumnCombination_frobenius_one] using hf + · have hdup : ∃ i j : Fin k, + finitePlaceOrderTop v (f i) < 0 ∧ + finitePlaceOrderTop v (f j) < 0 ∧ + finitePlaceOrderTop v (f i) = finitePlaceOrderTop v (f j) ∧ + i ≠ j := by + simp only [NegativeFinitePlaceOrdersPairwiseDistinct] at hdistinct + push Not at hdistinct + obtain ⟨i, j, hi, hj, ho, hij⟩ := hdistinct + exact ⟨i, j, hi, hj, ho, hij⟩ + obtain ⟨i, j, hi, hj, horder, hij⟩ := hdup + obtain ⟨c, hweight', hraise⟩ := + exists_frobeniusSubfield_dedekindPoleWeight_transvection_lt_of_perfect_residue + (p := p) v f i j hi hj horder + let T : Matrix (Fin k) (Fin k) (frobeniusSubfield L p) := + Matrix.transvection j i (-c) + let g := indexedDedekindLocalColumnCombination f T + have hweight : dedekindPoleWeight v g < N := by + rw [← hN] + exact hweight' + have hgi : + g i = f i - algebraMap (frobeniusSubfield L p) L c * f j := by + change indexedDedekindLocalColumnCombination f + (Matrix.transvection j i (-c)) i = _ + rw [indexedDedekindLocalColumnCombination_frobenius_transvection_same] + simp only [Algebra.smul_def, map_neg, neg_mul, sub_eq_add_neg] + have hg : ∀ b, (a : WithTop ℤ) ≤ + finitePlaceOrderTop v (g b) := by + intro b + by_cases hb : b = i + · subst b + rw [hgi] + exact (hf i).trans hraise.le + · change (a : WithTop ℤ) ≤ finitePlaceOrderTop v + (indexedDedekindLocalColumnCombination f + (Matrix.transvection j i (-c)) b) + rw [indexedDedekindLocalColumnCombination_frobenius_transvection_ne + f i j b (-c) hb] + exact hf b + obtain ⟨B, hBdet, hBdistinct, hBlower⟩ := ih _ hweight g hg rfl + refine ⟨T * B, ?_, ?_, ?_⟩ + · rw [Matrix.det_mul, hBdet, mul_one] + exact Matrix.det_transvection_of_ne j i (Ne.symm hij) (-c) + · rw [← indexedDedekindLocalColumnCombination_mul] + exact hBdistinct + · rw [← indexedDedekindLocalColumnCombination_mul] + exact hBlower + +/-- Complete local case (i) for a `Fin k` family, with coefficients in the +Frobenius subfield and no residue-surjectivity assumption. -/ +theorem exists_frobeniusSubfield_dedekindCaseI_columnMatrix_and_q_wronskian_bound_of_perfect_residue + {k : ℕ} (v : HeightOneSpectrum R) + [PerfectField v.asIdeal.ResidueField] + (D : Derivation (frobeniusSubfield L p) L L) + (hDIntegral : ∀ r : R, ∃ s : R, + D (algebraMap R L r) = algebraMap R L s) + (epsilonOrder : Fin k → ℕ) (f : Fin k → L) + (a : ℤ) (epsilon q : ℕ) + (ha : a ≤ 0) + (hf : ∀ i, (a : WithTop ℤ) ≤ finitePlaceOrderTop v (f i)) + (hepsilonInjective : Function.Injective epsilonOrder) + (hepsilonMax : ∀ i, epsilonOrder i ≤ epsilon) + (hk : k ≤ epsilon + 1) (hepsilonQ : epsilon + 1 ≤ q) : + ∃ A : Matrix (Fin k) (Fin k) (frobeniusSubfield L p), + A.det = 1 ∧ + (indexedDedekindLocalWronskian D epsilonOrder + (indexedDedekindLocalColumnCombination f A)).det = + (indexedDedekindLocalWronskian D epsilonOrder f).det ∧ + (((q : ℤ) * a : ℤ) : WithTop ℤ) ≤ + finitePlaceOrderTop v + (indexedDedekindLocalWronskian D epsilonOrder f).det := by + obtain ⟨A, hAdet, hdistinct, hlower⟩ := + exists_det_one_frobeniusSubfield_columnMatrix_negativeOrdersPairwiseDistinct_of_perfect_residue + (p := p) v a f hf + let g := indexedDedekindLocalColumnCombination f A + have hdet : + (indexedDedekindLocalWronskian D epsilonOrder g).det = + (indexedDedekindLocalWronskian D epsilonOrder f).det := by + exact indexedDedekindLocalWronskian_det_columnCombination_of_det_eq_one + D epsilonOrder f A hAdet + have hcardRho : + a ≤ -((Finset.univ.filter fun i => + finitePlaceOrderTop v (g i) < 0).card : ℤ) := + card_negativeFinitePlaceOrders_le_neg v g a ha hdistinct hlower + have hcardEpsilon : + (Finset.univ.filter fun i => finitePlaceOrderTop v (g i) < 0).card ≤ + epsilon + 1 := by + calc + (Finset.univ.filter fun i => finitePlaceOrderTop v (g i) < 0).card ≤ + (Finset.univ : Finset (Fin k)).card := Finset.card_filter_le _ _ + _ = k := Fintype.card_fin k + _ ≤ epsilon + 1 := hk + have hbound := + finitePlaceOrderTop_indexedDedekindLocalWronskian_caseI_q_lower_bound + v D hDIntegral epsilonOrder g a epsilon q hdistinct hlower + hepsilonInjective hepsilonMax hcardRho hcardEpsilon ha hepsilonQ + refine ⟨A, hAdet, hdet, ?_⟩ + rw [← hdet] + exact hbound + +/-- Source-facing case-(i) elimination for the full auxiliary family over the +Frobenius subfield. Perfectness of the residue field replaces surjectivity +from a global constant field. -/ +theorem exists_frobeniusSubfield_dedekindLocalAuxiliaryFamily_caseI_columnMatrix_of_perfect_residue + (v : HeightOneSpectrum R) + [PerfectField v.asIdeal.ResidueField] + (u w rho : L) (h k : ℕ) + (hrhoNe : rho ≠ 0) + (huOrder : finitePlaceOrderTop v u = 0) + (hrhoOrder : finitePlaceOrder v rho < 0) + (hgridRegular : ∀ rs : Fin (k + 1) × Fin h, + (0 : WithTop ℤ) ≤ finitePlaceOrderTop v + (u ^ (rs.1 : ℕ) * w ^ (rs.2 : ℕ))) : + ∃ A : Matrix (Fin k) (Fin k) (frobeniusSubfield L p), + A.det = 1 ∧ + NegativeFinitePlaceOrdersPairwiseDistinct v + (dedekindCaseITransformedLocalAuxiliaryFamily u w rho h k A) ∧ + (∀ i, (finitePlaceOrder v rho : WithTop ℤ) ≤ + finitePlaceOrderTop v + (dedekindCaseITransformedLocalAuxiliaryFamily u w rho h k A i)) ∧ + (∀ rs, dedekindCaseITransformedLocalAuxiliaryFamily + u w rho h k A (Sum.inr rs) = + dedekindLocalAuxiliaryFamily u w rho h k (Sum.inr rs)) := by + let first : Fin k → L := + fun i => dedekindLocalAuxiliaryFamily u w rho h k (Sum.inl i) + have hfirstOrder : ∀ i, + finitePlaceOrderTop v (first i) = + (finitePlaceOrder v rho : WithTop ℤ) := by + intro i + simp only [first, dedekindLocalAuxiliaryFamily] + rw [finitePlaceOrderTop_mul, finitePlaceOrderTop_pow, huOrder, + finitePlaceOrderTop_eq_coe v rho hrhoNe] + simp + have hfirstLower : ∀ i, (finitePlaceOrder v rho : WithTop ℤ) ≤ + finitePlaceOrderTop v (first i) := by + intro i + rw [hfirstOrder i] + obtain ⟨A, hAdet, hdistinct, hlower⟩ := + exists_det_one_frobeniusSubfield_columnMatrix_negativeOrdersPairwiseDistinct_of_perfect_residue + (p := p) v (finitePlaceOrder v rho) first hfirstLower + refine ⟨A, hAdet, ?_, ?_, ?_⟩ + · intro x y hx hy hxy + cases x with + | inl i => + cases y with + | inl j => + apply congrArg Sum.inl + apply hdistinct + · simpa [first] using hx + · simpa [first] using hy + · simpa [first] using hxy + | inr rs => + rw [dedekindCaseITransformedLocalAuxiliaryFamily_inr] at hy + exact (not_lt_of_ge (hgridRegular rs)) hy |>.elim + | inr rs => + rw [dedekindCaseITransformedLocalAuxiliaryFamily_inr] at hx + exact (not_lt_of_ge (hgridRegular rs)) hx |>.elim + · intro i + cases i with + | inl j => simpa [first] using hlower j + | inr rs => + rw [dedekindCaseITransformedLocalAuxiliaryFamily_inr] + exact (show (finitePlaceOrder v rho : WithTop ℤ) ≤ 0 by + exact_mod_cast hrhoOrder.le) |>.trans (hgridRegular rs) + · intro rs + exact dedekindCaseITransformedLocalAuxiliaryFamily_inr + u w rho h k A rs + +/-- Full Dedekind-DVR case (i) over the Frobenius subfield: perfect residue +fields supply every leading-term cancellation, the determinant-one column +operation preserves the Wronskian, and the exact `q * ord(rho)` lower bound +follows. -/ +theorem + exists_frobeniusSubfield_dedekindLocalAuxiliaryFamily_caseI_q_wronskian_bound_of_perfect_residue + (v : HeightOneSpectrum R) + [PerfectField v.asIdeal.ResidueField] + (D : Derivation (frobeniusSubfield L p) L L) + (hDIntegral : ∀ r : R, ∃ s : R, + D (algebraMap R L r) = algebraMap R L s) + (u w rho : L) (h k : ℕ) + (epsilonOrder : Sum (Fin k) (Fin (k + 1) × Fin h) → ℕ) + (epsilon q : ℕ) + (hrhoNe : rho ≠ 0) + (huOrder : finitePlaceOrderTop v u = 0) + (hrhoOrder : finitePlaceOrder v rho < 0) + (hgridRegular : ∀ rs : Fin (k + 1) × Fin h, + (0 : WithTop ℤ) ≤ finitePlaceOrderTop v + (u ^ (rs.1 : ℕ) * w ^ (rs.2 : ℕ))) + (hepsilonInjective : Function.Injective epsilonOrder) + (hepsilonMax : ∀ i, epsilonOrder i ≤ epsilon) + (hk : k ≤ epsilon + 1) (hepsilonQ : epsilon + 1 ≤ q) : + ∃ A : Matrix (Fin k) (Fin k) (frobeniusSubfield L p), + A.det = 1 ∧ + (indexedDedekindLocalWronskian D epsilonOrder + (dedekindCaseITransformedLocalAuxiliaryFamily u w rho h k A)).det = + (indexedDedekindLocalWronskian D epsilonOrder + (dedekindLocalAuxiliaryFamily u w rho h k)).det ∧ + (((q : ℤ) * finitePlaceOrder v rho : ℤ) : WithTop ℤ) ≤ + finitePlaceOrderTop v + (indexedDedekindLocalWronskian D epsilonOrder + (dedekindLocalAuxiliaryFamily u w rho h k)).det := by + obtain ⟨A, hAdet, hdistinct, hlower, hgrid⟩ := + exists_frobeniusSubfield_dedekindLocalAuxiliaryFamily_caseI_columnMatrix_of_perfect_residue + (p := p) v u w rho h k hrhoNe huOrder hrhoOrder hgridRegular + let f := dedekindLocalAuxiliaryFamily u w rho h k + let B := dedekindCaseIColumnMatrix h k A + let g := dedekindCaseITransformedLocalAuxiliaryFamily u w rho h k A + have hBdet : B.det = 1 := by + rw [dedekindCaseIColumnMatrix_det, hAdet] + have hdet : + (indexedDedekindLocalWronskian D epsilonOrder g).det = + (indexedDedekindLocalWronskian D epsilonOrder f).det := by + exact indexedDedekindLocalWronskian_det_columnCombination_of_det_eq_one + D epsilonOrder f B hBdet + have hcardRho : + finitePlaceOrder v rho ≤ -((Finset.univ.filter fun i => + finitePlaceOrderTop v (g i) < 0).card : ℤ) := + card_negativeFinitePlaceOrders_le_neg v g (finitePlaceOrder v rho) + hrhoOrder.le hdistinct hlower + let firstPoles : Finset (Fin k) := Finset.univ.filter fun i => + finitePlaceOrderTop v (g (Sum.inl i)) < 0 + have hpoles : + (Finset.univ.filter fun i => finitePlaceOrderTop v (g i) < 0) = + firstPoles.map ⟨Sum.inl, Sum.inl_injective⟩ := by + ext x + cases x with + | inl i => simp [firstPoles] + | inr rs => + have hregg : (0 : WithTop ℤ) ≤ + finitePlaceOrderTop v (g (Sum.inr rs)) := by + change (0 : WithTop ℤ) ≤ finitePlaceOrderTop v + (dedekindCaseITransformedLocalAuxiliaryFamily + u w rho h k A (Sum.inr rs)) + rw [hgrid rs] + simpa [dedekindLocalAuxiliaryFamily] using hgridRegular rs + have hrs : ¬ finitePlaceOrderTop v (g (Sum.inr rs)) < 0 := + not_lt_of_ge hregg + simp [firstPoles, hrs] + have hcardEpsilon : + (Finset.univ.filter fun i => finitePlaceOrderTop v (g i) < 0).card ≤ + epsilon + 1 := by + rw [hpoles, Finset.card_map] + exact (Finset.card_filter_le _ _).trans (by simpa using hk) + have hbound := + finitePlaceOrderTop_indexedDedekindLocalWronskian_caseI_q_lower_bound + v D hDIntegral epsilonOrder g (finitePlaceOrder v rho) epsilon q + hdistinct hlower hepsilonInjective hepsilonMax hcardRho hcardEpsilon + hrhoOrder.le hepsilonQ + refine ⟨A, hAdet, hdet, ?_⟩ + rw [← hdet] + exact hbound + +/-- Source `auxiliaryFamily` endpoint, specialized to +`rho = (1-u)/(1-w)`, over a perfect residue field. -/ +theorem exists_frobeniusSubfield_dedekindAuxiliaryFamily_caseI_q_wronskian_bound_of_perfect_residue + (v : HeightOneSpectrum R) + [PerfectField v.asIdeal.ResidueField] + (D : Derivation (frobeniusSubfield L p) L L) + (hDIntegral : ∀ r : R, ∃ s : R, + D (algebraMap R L r) = algebraMap R L s) + (u w : L) (h k : ℕ) + (epsilonOrder : Sum (Fin k) (Fin (k + 1) × Fin h) → ℕ) + (epsilon q : ℕ) + (hrhoNe : (1 - u) / (1 - w) ≠ 0) + (huOrder : finitePlaceOrderTop v u = 0) + (hrhoOrder : finitePlaceOrder v ((1 - u) / (1 - w)) < 0) + (hgridRegular : ∀ rs : Fin (k + 1) × Fin h, + (0 : WithTop ℤ) ≤ finitePlaceOrderTop v + (u ^ (rs.1 : ℕ) * w ^ (rs.2 : ℕ))) + (hepsilonInjective : Function.Injective epsilonOrder) + (hepsilonMax : ∀ i, epsilonOrder i ≤ epsilon) + (hk : k ≤ epsilon + 1) (hepsilonQ : epsilon + 1 ≤ q) : + ∃ A : Matrix (Fin k) (Fin k) (frobeniusSubfield L p), + A.det = 1 ∧ + (indexedDedekindLocalWronskian D epsilonOrder + (indexedDedekindLocalColumnCombination (auxiliaryFamily u w h k) + (dedekindCaseIColumnMatrix h k A))).det = + (indexedDedekindLocalWronskian D epsilonOrder + (auxiliaryFamily u w h k)).det ∧ + (((q : ℤ) * finitePlaceOrder v ((1 - u) / (1 - w)) : ℤ) : + WithTop ℤ) ≤ + finitePlaceOrderTop v + (indexedDedekindLocalWronskian D epsilonOrder + (auxiliaryFamily u w h k)).det := by + simpa only [dedekindCaseITransformedLocalAuxiliaryFamily, + dedekindLocalAuxiliaryFamily_div_eq_auxiliaryFamily] using + exists_frobeniusSubfield_dedekindLocalAuxiliaryFamily_caseI_q_wronskian_bound_of_perfect_residue + (p := p) v D hDIntegral u w ((1 - u) / (1 - w)) h k epsilonOrder + epsilon q hrhoNe huOrder hrhoOrder hgridRegular hepsilonInjective + hepsilonMax hk hepsilonQ + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/DedekindPlaceOrder.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/DedekindPlaceOrder.lean new file mode 100644 index 0000000000..b83e0a872f --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/DedekindPlaceOrder.lean @@ -0,0 +1,368 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FinitePlaceCompletion +public import Mathlib.RingTheory.DiscreteValuationRing.Basic +public import Mathlib.RingTheory.Derivation.Basic +public import Mathlib.Tactic + +/-! +# Orders at Dedekind places + +Extend local orders to zero using a top value and prove their arithmetic and derivation +estimates through uniformizers. +-/ + +@[expose] public section + +open scoped nonZeroDivisors +open IsDedekindDomain Multiplicative WithZero + +namespace BGS.CorvajaZannier + +noncomputable section + +variable {R L : Type*} [CommRing R] [IsDedekindDomain R] + [Field L] [Algebra R L] [IsFractionRing R L] + +/-- The additive order at a finite place satisfies the ultrametric inequality +on nonzero inputs. -/ +theorem finitePlaceOrder_add_ge_min + (v : HeightOneSpectrum R) (x y : L) + (hx : x ≠ 0) (hy : y ≠ 0) (hxy : x + y ≠ 0) : + min (finitePlaceOrder v x) (finitePlaceOrder v y) ≤ + finitePlaceOrder v (x + y) := by + have hVal := (v.valuation L).map_add x y + rw [valuation_eq_exp_neg_finitePlaceOrder v (x + y) hxy, + valuation_eq_exp_neg_finitePlaceOrder v x hx, + valuation_eq_exp_neg_finitePlaceOrder v y hy] at hVal + by_cases hOrder : finitePlaceOrder v x ≤ finitePlaceOrder v y + · rw [min_eq_left hOrder] + have hExp : exp (-finitePlaceOrder v y) ≤ exp (-finitePlaceOrder v x) := + (WithZero.exp_le_exp).2 (neg_le_neg hOrder) + rw [max_eq_left hExp] at hVal + exact neg_le_neg_iff.mp ((WithZero.exp_le_exp).1 hVal) + · have hOrder' : finitePlaceOrder v y ≤ finitePlaceOrder v x := + le_of_not_ge hOrder + rw [min_eq_right hOrder'] + have hExp : exp (-finitePlaceOrder v x) ≤ exp (-finitePlaceOrder v y) := + (WithZero.exp_le_exp).2 (neg_le_neg hOrder') + rw [max_eq_right hExp] at hVal + exact neg_le_neg_iff.mp ((WithZero.exp_le_exp).1 hVal) + +/-- The order attached to a height-one prime, with the zero element assigned +infinite order. -/ +noncomputable def finitePlaceOrderTop (v : HeightOneSpectrum R) (x : L) : WithTop ℤ := by + classical + exact if x = 0 then ⊤ else finitePlaceOrder v x + +@[simp] +theorem finitePlaceOrderTop_zero (v : HeightOneSpectrum R) : + finitePlaceOrderTop (L := L) v 0 = ⊤ := by + simp [finitePlaceOrderTop] + +@[simp] +theorem finitePlaceOrderTop_eq_top_iff (v : HeightOneSpectrum R) (x : L) : + finitePlaceOrderTop v x = ⊤ ↔ x = 0 := by + simp [finitePlaceOrderTop] + +theorem finitePlaceOrderTop_eq_coe (v : HeightOneSpectrum R) + (x : L) (hx : x ≠ 0) : + finitePlaceOrderTop v x = finitePlaceOrder v x := by + simp [finitePlaceOrderTop, hx] + +theorem finitePlaceOrderTop_add_ge_min + (v : HeightOneSpectrum R) (x y : L) : + min (finitePlaceOrderTop v x) (finitePlaceOrderTop v y) ≤ + finitePlaceOrderTop v (x + y) := by + by_cases hx : x = 0 + · subst x + simp + by_cases hy : y = 0 + · subst y + simp + by_cases hxy : x + y = 0 + · simp [finitePlaceOrderTop, hxy] + simp only [finitePlaceOrderTop_eq_coe v x hx, + finitePlaceOrderTop_eq_coe v y hy, + finitePlaceOrderTop_eq_coe v (x + y) hxy] + exact_mod_cast finitePlaceOrder_add_ge_min v x y hx hy hxy + +theorem finitePlaceOrderTop_mul + (v : HeightOneSpectrum R) (x y : L) : + finitePlaceOrderTop v (x * y) = + finitePlaceOrderTop v x + finitePlaceOrderTop v y := by + by_cases hx : x = 0 + · subst x + simp + by_cases hy : y = 0 + · subst y + simp + rw [finitePlaceOrderTop_eq_coe v (x * y) (mul_ne_zero hx hy), + finitePlaceOrderTop_eq_coe v x hx, + finitePlaceOrderTop_eq_coe v y hy] + norm_cast + have hDivisor := finitePrincipalDivisor_mul (R := R) x y hx hy + exact congrArg (fun D ↦ D v) hDivisor + +@[simp] +theorem finitePlaceOrderTop_one (v : HeightOneSpectrum R) : + finitePlaceOrderTop (L := L) v 1 = 0 := by + rw [finitePlaceOrderTop_eq_coe v 1 one_ne_zero] + have hvaluation := valuation_eq_exp_neg_finitePlaceOrder v (1 : L) one_ne_zero + rw [map_one] at hvaluation + have hexp : exp (0 : ℤ) = exp (-finitePlaceOrder v (1 : L)) := by + simpa using hvaluation + have hzero : (0 : ℤ) = -finitePlaceOrder v (1 : L) := + WithZero.exp_injective hexp + have horder : finitePlaceOrder v (1 : L) = 0 := by omega + exact_mod_cast horder + +/-- The order of a natural power is the corresponding natural multiple of +the order. The `WithTop` formulation also covers a zero base. -/ +theorem finitePlaceOrderTop_pow + (v : HeightOneSpectrum R) (x : L) (n : ℕ) : + finitePlaceOrderTop v (x ^ n) = n • finitePlaceOrderTop v x := by + induction n with + | zero => simp + | succ n ih => + rw [pow_succ, finitePlaceOrderTop_mul, ih, succ_nsmul] + +/-- A regular element of the Dedekind domain has nonnegative order at every +height-one place. -/ +theorem finitePlaceOrderTop_algebraMap_nonnegative + (v : HeightOneSpectrum R) (a : R) : + (0 : WithTop ℤ) ≤ finitePlaceOrderTop v (algebraMap R L a) := by + by_cases ha : a = 0 + · subst a + simp + have hmap : algebraMap R L a ≠ 0 := by + intro hzero + apply ha + apply IsFractionRing.injective R L + simpa using hzero + rw [finitePlaceOrderTop_eq_coe v _ hmap] + have hvaluation := + valuation_eq_exp_neg_finitePlaceOrder v (algebraMap R L a) hmap + rw [HeightOneSpectrum.valuation_of_algebraMap, + v.intValuation_eq_exp_neg_multiplicity ha] at hvaluation + have horder : + finitePlaceOrder v (algebraMap R L a) = + (multiplicity v.asIdeal (Ideal.span {a}) : ℤ) := by + exact (neg_injective (WithZero.exp_injective hvaluation)).symm + rw [horder] + exact_mod_cast Int.natCast_nonneg (multiplicity v.asIdeal (Ideal.span {a})) + +section DVR + +variable [IsDiscreteValuationRing R] + +/-- At the place generated by a uniformizer, a unit times its `n`-th +integer power has order exactly `n`. -/ +theorem finitePlaceOrder_unit_mul_uniformizer_zpow + (v : HeightOneSpectrum R) (π : R) (hπ : Irreducible π) + (hπIdeal : v.asIdeal = Ideal.span {π}) (u : Rˣ) (n : ℤ) : + finitePlaceOrder v + ((algebraMap R L (u : R)) * (algebraMap R L π) ^ n) = n := by + have hπ0 : algebraMap R L π ≠ 0 := by simpa using hπ.ne_zero + have hu0 : algebraMap R L (u : R) ≠ 0 := by simp + have hx0 : + algebraMap R L (u : R) * (algebraMap R L π) ^ n ≠ 0 := + mul_ne_zero hu0 (zpow_ne_zero n hπ0) + have hValπ : v.valuation L (algebraMap R L π) = exp (-1 : ℤ) := by + rw [HeightOneSpectrum.valuation_of_algebraMap, + HeightOneSpectrum.intValuation_singleton v hπ.ne_zero hπIdeal] + have hValu : v.valuation L (algebraMap R L (u : R)) = 1 := by + exact Valuation.Integers.one_of_isUnit' u.isUnit + (HeightOneSpectrum.valuation_le_one (K := L) v) + have hValX : + v.valuation L + ((algebraMap R L (u : R)) * (algebraMap R L π) ^ n) = + exp (-n) := by + rw [map_mul, map_zpow₀ (v.valuation L) (algebraMap R L π) n, + hValu, one_mul, hValπ, ← WithZero.exp_zsmul] + congr 1 + simp + rw [valuation_eq_exp_neg_finitePlaceOrder v _ hx0] at hValX + exact neg_injective (WithZero.exp_injective hValX) + +theorem finitePlaceOrder_uniformizer_zpow + (v : HeightOneSpectrum R) (π : R) (hπ : Irreducible π) + (hπIdeal : v.asIdeal = Ideal.span {π}) (n : ℤ) : + finitePlaceOrder v ((algebraMap R L π) ^ n) = n := by + simpa using finitePlaceOrder_unit_mul_uniformizer_zpow + (L := L) v π hπ hπIdeal (1 : Rˣ) n + +theorem finitePlaceOrderTop_uniformizer_zpow + (v : HeightOneSpectrum R) (π : R) (hπ : Irreducible π) + (hπIdeal : v.asIdeal = Ideal.span {π}) (n : ℤ) : + finitePlaceOrderTop v ((algebraMap R L π) ^ n) = (n : WithTop ℤ) := by + have hπ0 : algebraMap R L π ≠ 0 := by simpa using hπ.ne_zero + rw [finitePlaceOrderTop_eq_coe v _ (zpow_ne_zero n hπ0)] + exact_mod_cast finitePlaceOrder_uniformizer_zpow + (L := L) v π hπ hπIdeal n + +/-- Any derivation preserving a DVR lowers order by at most one. No +normalization of the derivative of the chosen uniformizer is required. The +`WithTop`-valued statement includes the cases `x = 0` and `D x = 0`. -/ +theorem finitePlaceOrderTop_derivation_ge_sub_one_of_preserves + {C : Type*} [Field C] [Algebra C L] + (v : HeightOneSpectrum R) (π : R) (hπ : Irreducible π) + (hπIdeal : v.asIdeal = Ideal.span {π}) + (D : Derivation C L L) + (hDIntegral : ∀ r : R, ∃ s : R, D (algebraMap R L r) = algebraMap R L s) + (x : L) : + finitePlaceOrderTop v x + (-(1 : ℤ) : ℤ) ≤ + finitePlaceOrderTop v (D x) := by + by_cases hx : x = 0 + · subst x + simp + obtain ⟨n, u, hxu⟩ := + IsDiscreteValuationRing.exists_units_eq_smul_zpow_of_irreducible + (K := L) hπ hx + let a : L := algebraMap R L (u : R) + let q : L := algebraMap R L π + have hq0 : q ≠ 0 := by + dsimp [q] + simpa using hπ.ne_zero + have ha0 : a ≠ 0 := by simp [a] + have hx' : x = a * q ^ n := by + simpa [a, q, Units.smul_def, Algebra.smul_def] using hxu + have hOrderX : finitePlaceOrder v x = n := by + rw [hx'] + exact finitePlaceOrder_unit_mul_uniformizer_zpow v π hπ hπIdeal u n + by_cases hDx : D x = 0 + · simp [finitePlaceOrderTop, hDx] + obtain ⟨da, hda⟩ := hDIntegral (u : R) + have hDa : D a = algebraMap R L da := by simpa [a] using hda + obtain ⟨dπ, hdπ⟩ := hDIntegral π + have hDq : D q = algebraMap R L dπ := by simpa [q] using hdπ + have hValπ : v.valuation L q = exp (-1 : ℤ) := by + dsimp [q] + calc + v.valuation L (algebraMap R L π) = v.intValuation π := + HeightOneSpectrum.valuation_of_algebraMap v π + _ = exp (-1 : ℤ) := + HeightOneSpectrum.intValuation_singleton v hπ.ne_zero hπIdeal + have hValu : v.valuation L a = 1 := by + dsimp [a] + exact Valuation.Integers.one_of_isUnit' u.isUnit + (HeightOneSpectrum.valuation_le_one (K := L) v) + have hValPow (m : ℤ) : v.valuation L (q ^ m) = exp (-m) := by + rw [map_zpow₀ (v.valuation L) q m, hValπ, ← WithZero.exp_zsmul] + congr 1 + simp + have hValDa : v.valuation L (D a) ≤ 1 := by + rw [hDa] + exact HeightOneSpectrum.valuation_le_one (K := L) v da + have hValDq : v.valuation L (D q) ≤ 1 := by + rw [hDq] + exact HeightOneSpectrum.valuation_le_one (K := L) v dπ + have hValN : v.valuation L (n : L) ≤ 1 := by + simpa using HeightOneSpectrum.valuation_le_one (K := L) v (n : R) + have hDFormula : + D x = D a * q ^ n + a * ((n : L) * q ^ (n - 1) * D q) := by + rw [hx', D.leibniz, D.leibniz_zpow] + simp only [smul_eq_mul] + ring + have hTermOne : + v.valuation L (D a * q ^ n) ≤ exp (-(n - 1)) := by + rw [map_mul, hValPow] + calc + v.valuation L (D a) * exp (-n) ≤ 1 * exp (-n) := by gcongr + _ = exp (-n) := one_mul _ + _ ≤ exp (-(n - 1)) := (WithZero.exp_le_exp).2 (by omega) + have hTermTwo : + v.valuation L (a * ((n : L) * q ^ (n - 1) * D q)) ≤ + exp (-(n - 1)) := by + rw [map_mul, map_mul, map_mul, hValu, one_mul, hValPow] + calc + v.valuation L (n : L) * exp (-(n - 1)) * v.valuation L (D q) ≤ + 1 * exp (-(n - 1)) * 1 := by gcongr + _ = exp (-(n - 1)) := by simp + have hValDx : v.valuation L (D x) ≤ exp (-(n - 1)) := by + rw [hDFormula] + exact ((v.valuation L).map_add _ _).trans (max_le hTermOne hTermTwo) + rw [valuation_eq_exp_neg_finitePlaceOrder v (D x) hDx] at hValDx + have hOrderDx : n - 1 ≤ finitePlaceOrder v (D x) := by + exact neg_le_neg_iff.mp ((WithZero.exp_le_exp).1 hValDx) + rw [finitePlaceOrderTop_eq_coe v x hx, + finitePlaceOrderTop_eq_coe v (D x) hDx, hOrderX] + norm_cast + +/-- The normalized-uniformizer version retained for callers that naturally +construct a local derivative. -/ +theorem finitePlaceOrderTop_derivation_ge_sub_one + {C : Type*} [Field C] [Algebra C R] [Algebra C L] + [IsScalarTower C R L] + (v : HeightOneSpectrum R) (π : R) (hπ : Irreducible π) + (hπIdeal : v.asIdeal = Ideal.span {π}) + (D : Derivation C L L) + (hDIntegral : ∀ r : R, ∃ s : R, D (algebraMap R L r) = algebraMap R L s) + (_hDπ : D (algebraMap R L π) = 1) (x : L) : + finitePlaceOrderTop v x + (-(1 : ℤ) : ℤ) ≤ + finitePlaceOrderTop v (D x) := + finitePlaceOrderTop_derivation_ge_sub_one_of_preserves + v π hπ hπIdeal D hDIntegral x + +/-- Iterating any DVR-preserving derivation lowers finite-place order by at +most the number of iterations. -/ +theorem finitePlaceOrderTop_derivation_iterate_ge_sub_nat_of_preserves + {C : Type*} [Field C] [Algebra C L] + (v : HeightOneSpectrum R) (π : R) (hπ : Irreducible π) + (hπIdeal : v.asIdeal = Ideal.span {π}) + (D : Derivation C L L) + (hDIntegral : ∀ r : R, ∃ s : R, D (algebraMap R L r) = algebraMap R L s) + (r : ℕ) (x : L) : + finitePlaceOrderTop v x + (-(r : ℤ) : ℤ) ≤ + finitePlaceOrderTop v ((D : L → L)^[r] x) := by + induction r with + | zero => simp + | succ r ih => + rw [Function.iterate_succ_apply'] + have hshift := + add_le_add_right ih ((-(1 : ℤ) : ℤ) : WithTop ℤ) + have hshift' : + (finitePlaceOrderTop v x + (-(r : ℤ) : ℤ)) + + ((-(1 : ℤ) : ℤ) : WithTop ℤ) ≤ + finitePlaceOrderTop v ((D : L → L)^[r] x) + + ((-(1 : ℤ) : ℤ) : WithTop ℤ) := by + simpa [add_comm] using hshift + have hstep := finitePlaceOrderTop_derivation_ge_sub_one_of_preserves + v π hπ hπIdeal D hDIntegral ((D : L → L)^[r] x) + calc + finitePlaceOrderTop v x + (-(↑r.succ : ℤ) : ℤ) = + (finitePlaceOrderTop v x + (-(r : ℤ) : ℤ)) + + ((-(1 : ℤ) : ℤ) : WithTop ℤ) := by + rw [add_assoc] + congr 1 + exact_mod_cast (show -(↑r.succ : ℤ) = -(r : ℤ) + (-(1 : ℤ)) by omega) + _ ≤ finitePlaceOrderTop v ((D : L → L)^[r] x) + + ((-(1 : ℤ) : ℤ) : WithTop ℤ) := hshift' + _ ≤ finitePlaceOrderTop v (D ((D : L → L)^[r] x)) := hstep + +/-- The iterated normalized-uniformizer version retained for compatibility +with the local Wronskian API. -/ +theorem finitePlaceOrderTop_derivation_iterate_ge_sub_nat + {C : Type*} [Field C] [Algebra C R] [Algebra C L] + [IsScalarTower C R L] + (v : HeightOneSpectrum R) (π : R) (hπ : Irreducible π) + (hπIdeal : v.asIdeal = Ideal.span {π}) + (D : Derivation C L L) + (hDIntegral : ∀ r : R, ∃ s : R, D (algebraMap R L r) = algebraMap R L s) + (_hDπ : D (algebraMap R L π) = 1) (r : ℕ) (x : L) : + finitePlaceOrderTop v x + (-(r : ℤ) : ℤ) ≤ + finitePlaceOrderTop v ((D : L → L)^[r] x) := + finitePlaceOrderTop_derivation_iterate_ge_sub_nat_of_preserves + v π hπ hπIdeal D hDIntegral r x + +end DVR + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/DedekindRamifiedDerivationScaling.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/DedekindRamifiedDerivationScaling.lean new file mode 100644 index 0000000000..73e1d93f8a --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/DedekindRamifiedDerivationScaling.lean @@ -0,0 +1,512 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.DedekindDifferentDivisor +public import Mathlib.RingTheory.Conductor +public import Mathlib.RingTheory.Derivation.MapCoeffs +public import Mathlib.RingTheory.RamificationInertia.Ramification + +/-! +# Scaling derivations at ramified Dedekind places + +Let `C → S → T → U` be a tower, let `D` preserve `S`, and let `E` be an +ambient derivation on `U` extending `D`. The transitivity exact sequence for +Kähler differentials shows that every element annihilating `Ω[T⁄S]` clears the +obstruction to `E` preserving `T`. + +For a power basis, the minimal-polynomial derivative supplies such a factor +and generates the trace different. For a general ramified extension, the +comparison between the trace different and the Kähler annihilator is retained +as an explicit hypothesis; mathlib does not currently supply it in the needed +generality. +-/ + +@[expose] public section + +open scoped nonZeroDivisors Polynomial +open IsDedekindDomain + +namespace BGS.CorvajaZannier + +noncomputable section + +variable {C S T U : Type*} + [CommRing C] [CommRing S] [CommRing T] [CommRing U] + [Algebra C S] [Algebra C T] [Algebra S T] + [Algebra C U] [Algebra S U] [Algebra T U] + [IsScalarTower C S T] [IsScalarTower C S U] + [IsScalarTower C T U] [IsScalarTower S T U] + +/-- The ideal of scalars annihilating the relative Kähler differentials. -/ +def kaehlerDifferentialAnnihilator (S T : Type*) + [CommRing S] [CommRing T] [Algebra S T] : Ideal T := + Module.annihilator T Ω[T⁄S] + +theorem mem_kaehlerDifferentialAnnihilator_iff (c : T) : + c ∈ kaehlerDifferentialAnnihilator S T ↔ + ∀ ω : Ω[T⁄S], c • ω = 0 := by + exact Module.mem_annihilator + +theorem liftKaehlerDifferential_algebraMap_compDer + (D : Derivation C S S) : + ((Algebra.linearMap S T).compDer D).liftKaehlerDifferential = + (Algebra.linearMap S T).comp D.liftKaehlerDifferential := by + apply Derivation.liftKaehlerDifferential_unique + ext s + simp + +/-- Evaluation of a base-changed differential agrees with evaluation by an +ambient derivation extending the base derivation. -/ +theorem kaehler_baseChange_evaluation_naturality + (D : Derivation C S S) (E : Derivation C U U) + (hE : ∀ s : S, E (algebraMap S U s) = algebraMap S U (D s)) + (z : TensorProduct S T (KaehlerDifferential C S)) : + algebraMap T U + (((((Algebra.linearMap S T).compDer D).liftKaehlerDifferential).liftBaseChange T) z) = + E.liftKaehlerDifferential + (KaehlerDifferential.map C C T U + (KaehlerDifferential.mapBaseChange C S T z)) := by + induction z using TensorProduct.inductionOn with + | tmul t ω => + rw [LinearMap.liftBaseChange_tmul, + KaehlerDifferential.mapBaseChange_tmul] + simp only [map_smul] + let l₁ : KaehlerDifferential C S →ₗ[S] U := + (Algebra.linearMap S U).comp D.liftKaehlerDifferential + let l₂ : KaehlerDifferential C S →ₗ[S] U := + (E.liftKaehlerDifferential.restrictScalars S).comp + ((KaehlerDifferential.map C C T U).restrictScalars S |>.comp + (KaehlerDifferential.map C C S T)) + have hl : l₁ = l₂ := by + apply Derivation.liftKaehlerDifferential_unique + apply Derivation.ext + intro s + change l₁ (KaehlerDifferential.D C S s) = + l₂ (KaehlerDifferential.D C S s) + dsimp only [l₁, l₂, LinearMap.comp_apply, + LinearMap.restrictScalars_apply] + rw [Derivation.liftKaehlerDifferential_comp_D, + KaehlerDifferential.map_D, KaehlerDifferential.map_D, + Derivation.liftKaehlerDifferential_comp_D] + rw [← IsScalarTower.algebraMap_apply S T U] + simpa using (hE s).symm + have hω : + algebraMap T U + (((Algebra.linearMap S T).compDer D).liftKaehlerDifferential ω) = + E.liftKaehlerDifferential + (KaehlerDifferential.map C C T U + (KaehlerDifferential.map C C S T ω)) := by + rw [liftKaehlerDifferential_algebraMap_compDer] + change algebraMap T U + (algebraMap S T (D.liftKaehlerDifferential ω)) = _ + rw [← IsScalarTower.algebraMap_apply S T U] + simpa [l₁, l₂] using LinearMap.congr_fun hl ω + simpa [Algebra.smul_def] using + congrArg (fun y : U => algebraMap T U t * y) hω + | add x y hx hy => + simp only [map_add, hx, hy] + +/-- A scalar annihilating `Ω[T⁄S]` makes the scaled ambient derivation preserve +`T`. This is the ramified analogue of formal-étale derivation preservation. -/ +theorem scaled_ambientDerivation_preserves_of_mem_kaehlerDifferentialAnnihilator + (D : Derivation C S S) (E : Derivation C U U) + (hE : ∀ s : S, E (algebraMap S U s) = algebraMap S U (D s)) + (c : T) (hc : c ∈ kaehlerDifferentialAnnihilator S T) : + ∀ t : T, ∃ t' : T, + algebraMap T U c * E (algebraMap T U t) = algebraMap T U t' := by + intro t + have hker : KaehlerDifferential.map C S T T + (c • KaehlerDifferential.D C T t) = 0 := by + rw [map_smul, KaehlerDifferential.map_D] + exact (mem_kaehlerDifferentialAnnihilator_iff c).mp hc _ + have hrange : c • KaehlerDifferential.D C T t ∈ + LinearMap.range (KaehlerDifferential.mapBaseChange C S T) := + ((KaehlerDifferential.exact_mapBaseChange_map C S T) + (c • KaehlerDifferential.D C T t)).mp hker + obtain ⟨z, hz⟩ := hrange + let t' : T := + (((((Algebra.linearMap S T).compDer D).liftKaehlerDifferential).liftBaseChange T) z) + refine ⟨t', ?_⟩ + rw [kaehler_baseChange_evaluation_naturality D E hE z, hz, map_smul, + KaehlerDifferential.map_D] + simp [Derivation.liftKaehlerDifferential_comp_D, Algebra.smul_def] + +section PrincipalAnnihilatingIdeal + +variable [IsPrincipalIdealRing T] + +/-- A nonzero principal ideal contained in the Kähler annihilator has a +nonzero generator which clears the ambient derivation. -/ +theorem exists_generator_scaled_ambientDerivation_preserves + (I : Ideal T) (hI : I ≠ ⊥) + (hIann : I ≤ kaehlerDifferentialAnnihilator S T) + (D : Derivation C S S) (E : Derivation C U U) + (hE : ∀ s : S, E (algebraMap S U s) = algebraMap S U (D s)) : + ∃ c : T, + c ≠ 0 ∧ + Ideal.span {c} = I ∧ + c ∈ kaehlerDifferentialAnnihilator S T ∧ + ∀ t : T, ∃ t' : T, + algebraMap T U c * E (algebraMap T U t) = algebraMap T U t' := by + let c : T := Submodule.IsPrincipal.generator I + have hspan : Ideal.span {c} = I := Ideal.span_singleton_generator I + have hc : c ≠ 0 := by + intro hc0 + have hbot : Ideal.span {c} = ⊥ := + Ideal.span_singleton_eq_bot.mpr hc0 + exact hI (hspan.symm.trans hbot) + have hcann : c ∈ kaehlerDifferentialAnnihilator S T := + hIann (Submodule.IsPrincipal.generator_mem I) + exact ⟨c, hc, hspan, hcann, + scaled_ambientDerivation_preserves_of_mem_kaehlerDifferentialAnnihilator + D E hE c hcann⟩ + +end PrincipalAnnihilatingIdeal + +section PowerBasisAnnihilator + +/-- For a power basis, the derivative of the generator's minimal polynomial +annihilates the relative Kähler differentials. -/ +theorem powerBasis_minpolyDerivative_mem_kaehlerDifferentialAnnihilator + (pb : PowerBasis S T) : + Polynomial.aeval pb.gen + (Polynomial.derivative (minpoly S pb.gen)) ∈ + kaehlerDifferentialAnnihilator S T := by + rw [mem_kaehlerDifferentialAnnihilator_iff] + let c : T := Polynomial.aeval pb.gen + (Polynomial.derivative (minpoly S pb.gen)) + have hcgen : c • KaehlerDifferential.D S T pb.gen = 0 := by + have hchain := + (KaehlerDifferential.D S T).map_aeval (minpoly S pb.gen) pb.gen + rw [minpoly.aeval, map_zero] at hchain + exact hchain.symm + intro ω + change c • ω = 0 + let l : KaehlerDifferential S T →ₗ[T] KaehlerDifferential S T := + LinearMap.lsmul T (KaehlerDifferential S T) c + have hl : l = 0 := by + apply Derivation.liftKaehlerDifferential_unique + apply Derivation.ext_of_adjoin_eq_top {pb.gen} pb.adjoin_gen_eq_top + intro x hx + rw [Set.mem_singleton_iff.mp hx] + change c • KaehlerDifferential.D S T pb.gen = 0 + exact hcgen + have hω := LinearMap.congr_fun hl ω + simpa [l] using hω + +/-- The minimal-polynomial derivative of a power-basis generator clears the +ambient derivation. -/ +theorem powerBasis_minpolyDerivative_scaled_ambientDerivation_preserves + (pb : PowerBasis S T) + (D : Derivation C S S) (E : Derivation C U U) + (hE : ∀ s : S, E (algebraMap S U s) = algebraMap S U (D s)) : + ∀ t : T, ∃ t' : T, + algebraMap T U + (Polynomial.aeval pb.gen + (Polynomial.derivative (minpoly S pb.gen))) * + E (algebraMap T U t) = algebraMap T U t' := by + exact + scaled_ambientDerivation_preserves_of_mem_kaehlerDifferentialAnnihilator + D E hE _ + (powerBasis_minpolyDerivative_mem_kaehlerDifferentialAnnihilator pb) + +end PowerBasisAnnihilator + +section PrincipalDifferent + +variable [IsDomain S] [IsDedekindDomain T] + [Module.IsTorsionFree S T] + +/-- If the trace different is contained in the Kähler annihilator, a generator +of the different is an exact ramified derivation-clearing factor. -/ +theorem exists_differentGenerator_scaled_ambientDerivation_preserves + [IsPrincipalIdealRing T] + (hDifferent : differentIdeal S T ≠ ⊥) + (hDifferentKaehler : + differentIdeal S T ≤ kaehlerDifferentialAnnihilator S T) + (D : Derivation C S S) (E : Derivation C U U) + (hE : ∀ s : S, E (algebraMap S U s) = algebraMap S U (D s)) : + ∃ c : T, + c ≠ 0 ∧ + Ideal.span {c} = differentIdeal S T ∧ + c ∈ kaehlerDifferentialAnnihilator S T ∧ + ∀ t : T, ∃ t' : T, + algebraMap T U c * E (algebraMap T U t) = algebraMap T U t' := by + exact exists_generator_scaled_ambientDerivation_preserves + (differentIdeal S T) hDifferent hDifferentKaehler D E hE + +variable {F : Type*} [Field F] [Algebra T F] [IsFractionRing T F] + +/-- A generator of the different has finite-place order exactly equal to the +different multiplicity. -/ +theorem finitePlaceOrder_differentGenerator_eq_multiplicity + (c : T) (hc : c ≠ 0) + (hspan : Ideal.span {c} = differentIdeal S T) + (v : HeightOneSpectrum T) : + finitePlaceOrder v (algebraMap T F c) = + (multiplicity v.asIdeal (differentIdeal S T) : ℤ) := by + rw [finitePlaceOrder_algebraMap_eq_multiplicity v c hc, hspan] + +/-- A single certificate combining ramified derivation preservation with the +exact local order of the clearing factor. -/ +theorem exists_differentGenerator_scaling_certificate + [IsPrincipalIdealRing T] + (hDifferent : differentIdeal S T ≠ ⊥) + (hDifferentKaehler : + differentIdeal S T ≤ kaehlerDifferentialAnnihilator S T) + (D : Derivation C S S) (E : Derivation C U U) + (hE : ∀ s : S, E (algebraMap S U s) = algebraMap S U (D s)) : + ∃ c : T, + c ≠ 0 ∧ + Ideal.span {c} = differentIdeal S T ∧ + c ∈ kaehlerDifferentialAnnihilator S T ∧ + (∀ v : HeightOneSpectrum T, + finitePlaceOrder v (algebraMap T F c) = + (multiplicity v.asIdeal (differentIdeal S T) : ℤ)) ∧ + ∀ t : T, ∃ t' : T, + algebraMap T U c * E (algebraMap T U t) = algebraMap T U t' := by + obtain ⟨c, hc, hspan, hcann, hpreserves⟩ := + exists_differentGenerator_scaled_ambientDerivation_preserves + hDifferent hDifferentKaehler D E hE + exact ⟨c, hc, hspan, hcann, + fun v => finitePlaceOrder_differentGenerator_eq_multiplicity c hc hspan v, + hpreserves⟩ + +end PrincipalDifferent + +section ReparameterizedLocalOrder + +variable {R A F : Type*} [CommRing R] [IsDomain R] + [CommRing A] [IsDedekindDomain A] [Algebra R A] + [Module.IsTorsionFree R A] + [Field F] [Algebra A F] [IsFractionRing A F] + +/-- Multiplication of two nonzero field elements adds their finite-place +orders. This non-`WithTop` form is convenient for exact local certificates. -/ +theorem finitePlaceOrder_mul_eq_add + (v : HeightOneSpectrum A) (x y : F) (hx : x ≠ 0) (hy : y ≠ 0) : + finitePlaceOrder v (x * y) = + finitePlaceOrder v x + finitePlaceOrder v y := by + have h := finitePlaceOrderTop_mul v x y + rw [finitePlaceOrderTop_eq_coe v (x * y) (mul_ne_zero hx hy), + finitePlaceOrderTop_eq_coe v x hx, + finitePlaceOrderTop_eq_coe v y hy] at h + exact_mod_cast h + +/-- Inversion negates finite-place order. -/ +theorem finitePlaceOrder_inv_eq_neg' + (v : HeightOneSpectrum A) (x : F) (hx : x ≠ 0) : + finitePlaceOrder v x⁻¹ = -finitePlaceOrder v x := by + have h := finitePlaceOrder_mul_eq_add v x⁻¹ x (inv_ne_zero hx) hx + rw [inv_mul_cancel₀ hx] at h + have hone : finitePlaceOrder v (1 : F) = 0 := by + have htop := finitePlaceOrderTop_one (L := F) v + rw [finitePlaceOrderTop_eq_coe v 1 one_ne_zero] at htop + exact_mod_cast htop + rw [hone] at h + omega + +/-- Negating a nonzero field element does not change its finite-place order. -/ +theorem finitePlaceOrder_neg_eq + (v : HeightOneSpectrum A) (x : F) (hx : x ≠ 0) : + finitePlaceOrder v (-x) = finitePlaceOrder v x := by + have hval : (v.valuation F) (-x) = (v.valuation F) x := by simp + rw [valuation_eq_exp_neg_finitePlaceOrder v (-x) (neg_ne_zero.mpr hx), + valuation_eq_exp_neg_finitePlaceOrder v x hx] at hval + exact neg_injective (WithZero.exp_injective hval) + +/-- If `s` generates a base height-one prime, then its order at a prime above +it is exactly the ramification index. -/ +theorem finitePlaceOrder_algebraMap_uniformizer_eq_ramificationIdx + (p : HeightOneSpectrum R) (v : HeightOneSpectrum A) + [v.asIdeal.LiesOver p.asIdeal] + (s : R) (hs : s ≠ 0) (hspan : p.asIdeal = Ideal.span {s}) : + finitePlaceOrder v (algebraMap A F (algebraMap R A s)) = + (v.asIdeal.ramificationIdx R : ℤ) := by + have hsA : algebraMap R A s ≠ 0 := by + simpa using (FaithfulSMul.algebraMap_injective R A).ne hs + rw [finitePlaceOrder_algebraMap_eq_multiplicity v _ hsA] + have hmap : p.asIdeal.map (algebraMap R A) ≠ ⊥ := + Ideal.map_ne_bot_of_ne_bot p.ne_bot + rw [show Ideal.span {algebraMap R A s} = + p.asIdeal.map (algebraMap R A) by + rw [hspan, Ideal.map_span, Set.image_singleton]] + exact_mod_cast + (Ideal.IsDedekindDomain.ramificationIdx_eq_multiplicity + p.asIdeal v.asIdeal hmap).symm + +end ReparameterizedLocalOrder + +section PowerBasisDifferent + +variable {K L : Type*} [Field K] [Field L] + [Algebra S K] [Algebra T L] [Algebra K L] [Algebra S L] + [IsScalarTower S K L] [IsScalarTower S T L] + [IsDomain S] [IsFractionRing S K] [IsFractionRing T L] + [FiniteDimensional K L] [Algebra.IsSeparable K L] + [IsIntegralClosure T S L] [IsIntegrallyClosed S] [IsDedekindDomain T] + [Module.IsTorsionFree S T] + +omit [IsFractionRing T L] in +/-- For an integral power basis generated by a primitive field element, the +trace different is exactly the principal ideal generated by the +minimal-polynomial derivative. -/ +theorem differentIdeal_eq_span_powerBasis_minpolyDerivative + (pb : PowerBasis S T) + (hprimitive : Algebra.adjoin K {algebraMap T L pb.gen} = ⊤) : + differentIdeal S T = + Ideal.span + {Polynomial.aeval pb.gen + (Polynomial.derivative (minpoly S pb.gen))} := by + have h := conductor_mul_differentIdeal S K L pb.gen hprimitive + simpa [conductor_eq_top_of_powerBasis pb] using h + +/-- The power-basis derivative has exact order equal to the different +multiplicity at every finite place. -/ +theorem powerBasis_minpolyDerivative_finitePlaceOrder_eq_differentMultiplicity + (pb : PowerBasis S T) + (hprimitive : Algebra.adjoin K {algebraMap T L pb.gen} = ⊤) + (v : HeightOneSpectrum T) : + finitePlaceOrder v + (algebraMap T L + (Polynomial.aeval pb.gen + (Polynomial.derivative (minpoly S pb.gen)))) = + (multiplicity v.asIdeal (differentIdeal S T) : ℤ) := by + rw [finitePlaceOrder_algebraMap_eq_multiplicity v _ + (minpolyDerivative_ne_zero (A := S) (K := K) (L := L) pb.gen)] + rw [differentIdeal_eq_span_powerBasis_minpolyDerivative pb hprimitive] + +/-- In the power-basis case, the minimal-polynomial derivative simultaneously +generates the different, annihilates relative differentials, has exact local +different order, and clears the ambient derivation. -/ +theorem exists_powerBasis_differentGenerator_scaled_ambientDerivation_preserves + (pb : PowerBasis S T) + (hprimitive : Algebra.adjoin K {algebraMap T L pb.gen} = ⊤) + (D : Derivation C S S) (E : Derivation C U U) + (hE : ∀ s : S, E (algebraMap S U s) = algebraMap S U (D s)) : + ∃ c : T, + c ≠ 0 ∧ + Ideal.span {c} = differentIdeal S T ∧ + c ∈ kaehlerDifferentialAnnihilator S T ∧ + (∀ v : HeightOneSpectrum T, + finitePlaceOrder v (algebraMap T L c) = + (multiplicity v.asIdeal (differentIdeal S T) : ℤ)) ∧ + ∀ t : T, ∃ t' : T, + algebraMap T U c * E (algebraMap T U t) = algebraMap T U t' := by + let c : T := Polynomial.aeval pb.gen + (Polynomial.derivative (minpoly S pb.gen)) + refine ⟨c, + minpolyDerivative_ne_zero (A := S) (K := K) (L := L) pb.gen, + ?_, powerBasis_minpolyDerivative_mem_kaehlerDifferentialAnnihilator pb, + ?_, ?_⟩ + · exact (differentIdeal_eq_span_powerBasis_minpolyDerivative + pb hprimitive).symm + · exact fun v => + powerBasis_minpolyDerivative_finitePlaceOrder_eq_differentMultiplicity + pb hprimitive v + · exact powerBasis_minpolyDerivative_scaled_ambientDerivation_preserves + pb D E hE + +/-- Placewise finite certificate extracted from an integral power basis: one +nonzero scalar has exactly the local different order and makes the ambient +derivation preserve the local Dedekind ring. -/ +theorem exists_powerBasis_finitePlace_different_scaling_certificate + (pb : PowerBasis S T) + (hprimitive : Algebra.adjoin K {algebraMap T L pb.gen} = ⊤) + (v : HeightOneSpectrum T) + (D : Derivation C S S) (E : Derivation C U U) + (hE : ∀ s : S, E (algebraMap S U s) = algebraMap S U (D s)) : + ∃ c : T, + c ≠ 0 ∧ + finitePlaceOrder v (algebraMap T L c) = + (multiplicity v.asIdeal (differentIdeal S T) : ℤ) ∧ + ∀ t : T, ∃ t' : T, + algebraMap T U c * E (algebraMap T U t) = algebraMap T U t' := by + obtain ⟨c, hc, _hspan, _hcann, horder, hpreserves⟩ := + exists_powerBasis_differentGenerator_scaled_ambientDerivation_preserves + pb hprimitive D E hE + exact ⟨c, hc, horder v, hpreserves⟩ + +/-- Exact change from the local parameter derivation `D_s` to the global +`X`-derivation when `s = X⁻¹`. If `D_X = -s² D_s`, dividing a different +generator by `-s²` leaves the scaled derivation unchanged and subtracts +`2e` from its local order. Thus the resulting scalar realizes exactly the +infinity coefficient `different exponent - 2 * ramification index` of the +canonical different divisor. -/ +theorem exists_powerBasis_infinity_different_scaling_certificate + [Algebra C L] [IsScalarTower C S L] [IsScalarTower C T L] + (pb : PowerBasis S T) + (hprimitive : Algebra.adjoin K {algebraMap T L pb.gen} = ⊤) + (p : HeightOneSpectrum S) (v : HeightOneSpectrum T) + [v.asIdeal.LiesOver p.asIdeal] + (s : S) (hs : s ≠ 0) (hspan : p.asIdeal = Ideal.span {s}) + (Ds : Derivation C S S) (Es DX : Derivation C L L) + (hEs : ∀ r : S, Es (algebraMap S L r) = algebraMap S L (Ds r)) + (hDX : DX = (-(algebraMap S L s) ^ 2) • Es) : + ∃ δ : T, + δ ≠ 0 ∧ + Ideal.span {δ} = differentIdeal S T ∧ + let c : L := -(algebraMap T L δ) / (algebraMap S L s) ^ 2 + finitePlaceOrder v c = + (multiplicity v.asIdeal (differentIdeal S T) : ℤ) - + 2 * (v.asIdeal.ramificationIdx S : ℤ) ∧ + ∀ t : T, ∃ t' : T, + c * DX (algebraMap T L t) = algebraMap T L t' := by + obtain ⟨δ, hδ, hδspan, _hδann, hδorder, hδpreserves⟩ := + exists_powerBasis_differentGenerator_scaled_ambientDerivation_preserves + (U := L) pb hprimitive Ds Es hEs + refine ⟨δ, hδ, hδspan, ?_, ?_⟩ + · have hsK : algebraMap S K s ≠ 0 := by + intro hzero + exact hs (IsFractionRing.injective S K (by simpa using hzero)) + have hsL : algebraMap S L s ≠ 0 := by + rw [IsScalarTower.algebraMap_apply S K L] + exact (map_ne_zero (algebraMap K L)).2 hsK + have hδL : algebraMap T L δ ≠ 0 := by + intro hzero + exact hδ (IsFractionRing.injective T L (by simpa using hzero)) + have hsOrder : + finitePlaceOrder v (algebraMap S L s) = + (v.asIdeal.ramificationIdx S : ℤ) := by + simpa only [IsScalarTower.algebraMap_apply S T L] using + finitePlaceOrder_algebraMap_uniformizer_eq_ramificationIdx + (F := L) p v s hs hspan + rw [div_eq_mul_inv, + finitePlaceOrder_mul_eq_add v + (-(algebraMap T L δ)) (((algebraMap S L s) ^ 2)⁻¹) + (neg_ne_zero.mpr hδL) (inv_ne_zero (pow_ne_zero 2 hsL)), + finitePlaceOrder_neg_eq v (algebraMap T L δ) hδL, + finitePlaceOrder_inv_eq_neg' v ((algebraMap S L s) ^ 2) + (pow_ne_zero 2 hsL)] + have hsSquareOrder := finitePlaceOrder_mul_eq_add v + (algebraMap S L s) (algebraMap S L s) hsL hsL + rw [← pow_two] at hsSquareOrder + rw [hδorder v, hsSquareOrder, hsOrder] + ring + · intro t + obtain ⟨t', ht'⟩ := hδpreserves t + refine ⟨t', ?_⟩ + have hsK : algebraMap S K s ≠ 0 := by + intro hzero + exact hs (IsFractionRing.injective S K (by simpa using hzero)) + have hsL : algebraMap S L s ≠ 0 := by + rw [IsScalarTower.algebraMap_apply S K L] + exact (map_ne_zero (algebraMap K L)).2 hsK + rw [hDX, Derivation.smul_apply, Algebra.smul_def] + calc + (-(algebraMap T L δ) / (algebraMap S L s) ^ 2) * + (-(algebraMap S L s) ^ 2 * Es (algebraMap T L t)) = + algebraMap T L δ * Es (algebraMap T L t) := by + field_simp + _ = algebraMap T L t' := ht' + +end PowerBasisDifferent + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/ElementaryFiniteFieldBound.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/ElementaryFiniteFieldBound.lean new file mode 100644 index 0000000000..72e97665e6 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/ElementaryFiniteFieldBound.lean @@ -0,0 +1,164 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.External.GeneralCurveTheorems +public import Mathlib.RingTheory.RootsOfUnity.Basic +public import Mathlib.Tactic + +/-! +# Elementary finite-field torsion bounds + +This file records the part of the finite-field Corvaja--Zannier estimate that +uses only the fact that a nonzero polynomial has at most its degree many roots. +It does not use curve geometry or the Corvaja--Zannier Wronskian argument. +-/ + +@[expose] public section + +namespace BGS.External + +noncomputable section + +/-- The torsion intersection injects into the product of the two groups of +roots of unity. Consequently its cardinality is at most the product of the +two specified orders. -/ +theorem torusCurveTorsionIntersection_card_le_orders + {K : Type*} [Field K] [Fintype K] [DecidableEq K] + (f : MvPolynomial (Fin 2) K) (firstOrder secondOrder : ℕ) + (hfirst : 0 < firstOrder) (hsecond : 0 < secondOrder) : + (torusCurveTorsionIntersection K f firstOrder secondOrder).card ≤ + firstOrder * secondOrder := by + let S := torusCurveTorsionIntersection K f firstOrder secondOrder + let : NeZero firstOrder := ⟨hfirst.ne'⟩ + let : NeZero secondOrder := ⟨hsecond.ne'⟩ + let : Fintype (rootsOfUnity firstOrder K) := Fintype.ofFinite _ + let : Fintype (rootsOfUnity secondOrder K) := Fintype.ofFinite _ + let toRoots : {z // z ∈ S} → + rootsOfUnity firstOrder K × rootsOfUnity secondOrder K := fun z ↦ + (⟨z.1.1, (mem_rootsOfUnity firstOrder z.1.1).2 + (mem_torusCurveTorsionIntersection_iff.1 z.2).2.1⟩, + ⟨z.1.2, (mem_rootsOfUnity secondOrder z.1.2).2 + (mem_torusCurveTorsionIntersection_iff.1 z.2).2.2⟩) + have hInjective : Function.Injective toRoots := by + intro z w hzw + apply Subtype.ext + apply Prod.ext + · exact congrArg (fun q ↦ (q.1 : Kˣ)) hzw + · exact congrArg (fun q ↦ (q.2 : Kˣ)) hzw + calc + S.card = Fintype.card {z // z ∈ S} := by simp + _ ≤ Fintype.card + (rootsOfUnity firstOrder K × rootsOfUnity secondOrder K) := + Fintype.card_le_of_injective toRoots hInjective + _ = Nat.card (rootsOfUnity firstOrder K) * + Nat.card (rootsOfUnity secondOrder K) := by + simp only [Fintype.card_prod, Nat.card_eq_fintype_card] + _ ≤ firstOrder * secondOrder := + Nat.mul_le_mul (card_rootsOfUnity K firstOrder) + (card_rootsOfUnity K secondOrder) + +/-- In the small-characteristic regime `p ≤ 12 d₁ d₂`, the second +branch of the Corvaja--Zannier numerical maximum follows from the elementary +finite-group cardinality bound. -/ +theorem torusCurveTorsionIntersection_le_corvajaZannierBound_of_smallChar + (p : ℕ) [Fact p.Prime] + (K : Type*) [Field K] [Fintype K] [DecidableEq K] [CharP K p] + (f : MvPolynomial (Fin 2) K) + (firstDegree secondDegree firstOrder secondOrder : ℕ) + (hfirstOrder : 0 < firstOrder) (hsecondOrder : 0 < secondOrder) + (hsmall : p ≤ 12 * firstDegree * secondDegree) : + ((torusCurveTorsionIntersection K f firstOrder secondOrder).card : ℝ) ≤ + BGS.Markoff.corvajaZannierCorollaryTwoNumericalBound + p firstOrder secondOrder firstDegree secondDegree + (planeTorusEulerCharacteristicBound firstDegree secondDegree) := by + have hp : 0 < p := (Fact.out : p.Prime).pos + have hcardNat := torusCurveTorsionIntersection_card_le_orders + f firstOrder secondOrder hfirstOrder hsecondOrder + have hcardReal : + ((torusCurveTorsionIntersection K f firstOrder secondOrder).card : ℝ) ≤ + ((firstOrder * secondOrder : ℕ) : ℝ) := by + exact_mod_cast hcardNat + have hscaledNat : + p * (firstOrder * secondOrder) ≤ + 12 * (firstOrder * secondOrder * firstDegree * secondDegree) := by + have := Nat.mul_le_mul_right (firstOrder * secondOrder) hsmall + simpa [mul_assoc, mul_left_comm, mul_comm] using this + have hscaledReal' : + (p : ℝ) * ((firstOrder * secondOrder : ℕ) : ℝ) ≤ + 12 * ((firstOrder * secondOrder * firstDegree * secondDegree : ℕ) : ℝ) := by + exact_mod_cast hscaledNat + have hscaledReal : + ((firstOrder * secondOrder : ℕ) : ℝ) * (p : ℝ) ≤ + 12 * ((firstOrder * secondOrder * firstDegree * secondDegree : ℕ) : ℝ) := by + simpa [mul_comm] using hscaledReal' + have hsecond : + ((firstOrder * secondOrder : ℕ) : ℝ) ≤ + 12 * ((firstOrder * secondOrder * firstDegree * secondDegree : ℕ) : ℝ) / + (p : ℝ) := by + apply (le_div_iff₀ (by exact_mod_cast hp)).2 + simpa [mul_comm] using hscaledReal + unfold BGS.Markoff.corvajaZannierCorollaryTwoNumericalBound + exact hcardReal.trans (hsecond.trans (le_max_right _ _)) + +/-- The part of the general plane-curve statement lying strictly outside the +elementary range `p ≤ 12 d₁ d₂`. This is an ordinary proposition, not an +additional assumption or axiom. -/ +def GeneralCorvajaZannierPlaneCurveTheoremAboveElementaryRange : Prop := + ∀ (p : ℕ) [Fact p.Prime] + (K : Type) [Field K] [Fintype K] [DecidableEq K] [CharP K p] + (f : MvPolynomial (Fin 2) K) + (firstDegree secondDegree firstOrder secondOrder : ℕ), + 0 < firstDegree → + 0 < secondDegree → + HasBidegreeAtMost (K := K) f firstDegree secondDegree → + IsCorvajaZannierPlaneCurve f → + 0 < firstOrder → + 0 < secondOrder → + ¬ p ∣ firstOrder → + ¬ p ∣ secondOrder → + 12 * firstDegree * secondDegree < p → + ((torusCurveTorsionIntersection + K f firstOrder secondOrder).card : ℝ) ≤ + BGS.Markoff.corvajaZannierCorollaryTwoNumericalBound + p firstOrder secondOrder firstDegree secondDegree + (planeTorusEulerCharacteristicBound firstDegree secondDegree) + +/-- The full general plane-curve theorem is equivalent to its restriction to +the complementary range `12 d₁ d₂ < p`; the omitted range is exactly the +elementary small-characteristic theorem above. -/ +theorem generalCorvajaZannierPlaneCurveTheorem_iff_aboveElementaryRange : + GeneralCorvajaZannierPlaneCurveTheorem ↔ + GeneralCorvajaZannierPlaneCurveTheoremAboveElementaryRange := by + constructor + · intro hGeneral + unfold GeneralCorvajaZannierPlaneCurveTheoremAboveElementaryRange + intro p _ K _ _ _ _ f firstDegree secondDegree firstOrder secondOrder + hfirstDegree hsecondDegree hbidegree hcurve hfirstOrder hsecondOrder + hfirstPrimeToChar hsecondPrimeToChar _hlarge + exact hGeneral p (K := K) f + firstDegree secondDegree firstOrder secondOrder + hfirstDegree hsecondDegree hbidegree hcurve hfirstOrder hsecondOrder + hfirstPrimeToChar hsecondPrimeToChar + · intro hLarge + unfold GeneralCorvajaZannierPlaneCurveTheorem + intro p _ K _ _ _ _ f firstDegree secondDegree firstOrder secondOrder + hfirstDegree hsecondDegree hbidegree hcurve hfirstOrder hsecondOrder + hfirstPrimeToChar hsecondPrimeToChar + by_cases hsmall : p ≤ 12 * firstDegree * secondDegree + · exact + torusCurveTorsionIntersection_le_corvajaZannierBound_of_smallChar + p K f firstDegree secondDegree firstOrder secondOrder + hfirstOrder hsecondOrder hsmall + · exact hLarge p (K := K) f + firstDegree secondDegree firstOrder secondOrder + hfirstDegree hsecondDegree hbidegree hcurve hfirstOrder hsecondOrder + hfirstPrimeToChar hsecondPrimeToChar (Nat.lt_of_not_ge hsmall) + +end + +end BGS.External diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/EndpointComposition.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/EndpointComposition.lean new file mode 100644 index 0000000000..5b7675a9b8 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/EndpointComposition.lean @@ -0,0 +1,484 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PoweredImageCurve +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.TorsionGcdDivisorBound +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.TorsionBidegreeCount +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.NumericalCorollary +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.ElementaryFiniteFieldBound +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveBidegreeBridge + +/-! +# Composition of the Corvaja--Zannier plane-curve endpoint + +This module discharges the algebraic and numerical bookkeeping between the +public plane-curve interface and the remaining global geometric estimate. It +constructs the powered-image relation from `IsCorvajaZannierPlaneCurve`, proves +that the two powered torsion functions are nonzero, identifies the finite-set +cardinality with the torsion-point subtype cardinality, and composes the +Dedekind gcd divisor estimate with the proved numerical optimization. + +The only remaining input is exposed as the ordinary proposition +`GeneralPlaneCurvePropositionTwoCertificatesAboveElementaryRange`. Its +certificate is precisely a gcd-divisor number which bounds the rational +torsion points, satisfies the trivial degree bound, and satisfies the +Corvaja--Zannier Proposition 2 alternatives. No axiom or typeclass hides this +geometric obligation. +-/ + +@[expose] public section + +namespace BGS.CorvajaZannier + +noncomputable section + +open Polynomial + +theorem pow_sub_one_ne_zero_of_transcendental + {K L : Type*} [Field K] [Field L] [Algebra K L] + {z : L} (hz : Transcendental K z) (n : ℕ) (hn : 0 < n) : + z ^ n - 1 ≠ 0 := by + intro hzero + have hroot : Polynomial.aeval z (Polynomial.X ^ n - 1 : Polynomial K) = 0 := by + simpa using hzero + have hpolyZero := (transcendental_iff.mp hz) + (Polynomial.X ^ n - 1 : Polynomial K) hroot + have hmonic : (Polynomial.X ^ n - Polynomial.C 1 : Polynomial K).Monic := + Polynomial.monic_X_pow_sub_C 1 hn.ne' + exact hmonic.ne_zero (by simpa using hpolyZero) + +theorem torusCurveTorsionIntersection_card_eq_torsionPoint_card + {K : Type*} [Field K] [Fintype K] [DecidableEq K] + (f : MvPolynomial (Fin 2) K) (firstOrder secondOrder : ℕ) : + (BGS.External.torusCurveTorsionIntersection + K f firstOrder secondOrder).card = + Fintype.card (TorusCurveTorsionPoint f firstOrder secondOrder) := by + exact (Fintype.card_coe + (BGS.External.torusCurveTorsionIntersection + K f firstOrder secondOrder)).symm + +theorem poweredTorsionFunctions_ne_zero_of_isCorvajaZannierPlaneCurve + {K : Type*} [Field K] {f : MvPolynomial (Fin 2) K} + (hcurve : BGS.External.IsCorvajaZannierPlaneCurve f) + (firstOrder secondOrder : ℕ) + (hfirstOrder : 0 < firstOrder) (hsecondOrder : 0 < secondOrder) : + let hf : Irreducible f := + irreducible_of_irreducible_map_algebraicClosure hcurve.1 + letI := planeCurveCoordinateRing_isDomain hf + planeCurveFunction f 0 ^ firstOrder - 1 ≠ 0 ∧ + planeCurveFunction f 1 ^ secondOrder - 1 ≠ 0 := by + let hf : Irreducible f := + irreducible_of_irreducible_map_algebraicClosure hcurve.1 + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + have hxTrans : Transcendental K (planeCurveFunction f 0) := + firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hcurve.2.2.2) + have hyTrans : Transcendental K (planeCurveFunction f 1) := + secondCoordinate_transcendental hf + (degreeOf_first_pos_of_pderiv_ne_zero hcurve.2.2.1) + exact ⟨pow_sub_one_ne_zero_of_transcendental + hxTrans firstOrder hfirstOrder, + pow_sub_one_ne_zero_of_transcendental + hyTrans secondOrder hsecondOrder⟩ + +/-- The public curve hypotheses instantiate the canonical powered-image +relation, including the advertised source bidegree bounds. -/ +theorem poweredCoordinateImageRelation_spec_of_isCorvajaZannierPlaneCurve + {K : Type*} [Field K] {f : MvPolynomial (Fin 2) K} + (firstDegree secondDegree firstOrder secondOrder : ℕ) + (hbidegree : BGS.External.HasBidegreeAtMost + f firstDegree secondDegree) + (hcurve : BGS.External.IsCorvajaZannierPlaneCurve f) + (hfirstOrder : 0 < firstOrder) (hsecondOrder : 0 < secondOrder) : + let hf : Irreducible f := + irreducible_of_irreducible_map_algebraicClosure hcurve.1 + letI := planeCurveCoordinateRing_isDomain hf + let g := poweredCoordinateImageRelation hf hcurve.2.2.2 + firstOrder hfirstOrder secondOrder + Irreducible g ∧ + evalBivariate (planeCurveFunction f 0 ^ firstOrder) + (planeCurveFunction f 1 ^ secondOrder) g = 0 ∧ + 0 < g.natDegree ∧ + 0 < (transposeBivariate g).natDegree ∧ + g.natDegree ≤ firstOrder * secondDegree ∧ + (transposeBivariate g).natDegree ≤ secondOrder * firstDegree ∧ + ∀ i, (g.coeff i).natDegree ≤ secondOrder * firstDegree := by + let hf : Irreducible f := + irreducible_of_irreducible_map_algebraicClosure hcurve.1 + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let g := poweredCoordinateImageRelation hf hcurve.2.2.2 + firstOrder hfirstOrder secondOrder + have hspec := poweredCoordinateImageRelation_spec + hf hcurve.2.2.1 hcurve.2.2.2 + firstOrder hfirstOrder secondOrder hsecondOrder + refine ⟨hspec.1, hspec.2.1, hspec.2.2.1, hspec.2.2.2.1, + hspec.2.2.2.2.1.trans ?_, hspec.2.2.2.2.2.1.trans ?_, ?_⟩ + · exact Nat.mul_le_mul_left firstOrder + (degreeOf_second_le_of_hasBidegreeAtMost hbidegree) + · exact Nat.mul_le_mul_left secondOrder + (degreeOf_first_le_of_hasBidegreeAtMost hbidegree) + · intro i + exact (hspec.2.2.2.2.2.2 i).trans + (Nat.mul_le_mul_left secondOrder + (degreeOf_first_le_of_hasBidegreeAtMost hbidegree)) + +/-- The smaller of the degrees of `x ^ firstOrder` and `y ^ secondOrder`, +using only the public bidegree bounds. -/ +def planeCurveTorsionLowerDegree + (firstDegree secondDegree firstOrder secondOrder : ℕ) : ℕ := + min (secondOrder * firstDegree) (firstOrder * secondDegree) + +/-- The larger of the degrees of `x ^ firstOrder` and `y ^ secondOrder`, +using only the public bidegree bounds. -/ +def planeCurveTorsionUpperDegree + (firstDegree secondDegree firstOrder secondOrder : ℕ) : ℕ := + max (secondOrder * firstDegree) (firstOrder * secondDegree) + +theorem planeCurveTorsionLowerDegree_mul_upperDegree + (firstDegree secondDegree firstOrder secondOrder : ℕ) : + planeCurveTorsionLowerDegree firstDegree secondDegree firstOrder secondOrder * + planeCurveTorsionUpperDegree firstDegree secondDegree firstOrder secondOrder = + firstOrder * secondOrder * firstDegree * secondDegree := by + rw [planeCurveTorsionLowerDegree, planeCurveTorsionUpperDegree, min_mul_max] + ac_rfl + +/-- Proposition 2 plus the trivial gcd bound gives exactly the numerical +right-hand side of the public plane-curve theorem, independently of which +powered coordinate has the smaller degree. -/ +theorem planeCurveCorvajaZannierNumericalBound_of_propositionTwo + (p firstDegree secondDegree firstOrder secondOrder : ℕ) (G : ℝ) + (hfirstDegree : 0 < firstDegree) + (hsecondDegree : 0 < secondDegree) + (hfirstOrder : 0 < firstOrder) + (hsecondOrder : 0 < secondOrder) + (hp : 0 < p) + (hGNonneg : 0 ≤ G) + (hGTrivial : G ≤ planeCurveTorsionLowerDegree + firstDegree secondDegree firstOrder secondOrder) + (hPropositionTwo : PropositionTwoNumericalAlternatives + (planeCurveTorsionLowerDegree + firstDegree secondDegree firstOrder secondOrder) + (planeCurveTorsionUpperDegree + firstDegree secondDegree firstOrder secondOrder) + p (2 * firstDegree * secondDegree) G) : + G ≤ BGS.Markoff.corvajaZannierCorollaryTwoNumericalBound + p firstOrder secondOrder firstDegree secondDegree + (BGS.External.planeTorusEulerCharacteristicBound + firstDegree secondDegree) := by + let a := planeCurveTorsionLowerDegree + firstDegree secondDegree firstOrder secondOrder + let b := planeCurveTorsionUpperDegree + firstDegree secondDegree firstOrder secondOrder + let chi : ℕ := 2 * firstDegree * secondDegree + have ha : 0 < a := by + simp only [a, planeCurveTorsionLowerDegree] + exact lt_min (Nat.mul_pos hsecondOrder hfirstDegree) + (Nat.mul_pos hfirstOrder hsecondDegree) + have hab : a ≤ b := by + simp only [a, b, planeCurveTorsionLowerDegree, + planeCurveTorsionUpperDegree] + exact min_le_max + have hchi : 0 < chi := by + simp only [chi] + positivity + have hbound := theoremTwo_maxBound_of_propositionTwo + a b chi p G ha hab hchi hp hGNonneg hGTrivial hPropositionTwo + have habProductNat : + a * b = firstOrder * secondOrder * firstDegree * secondDegree := by + exact planeCurveTorsionLowerDegree_mul_upperDegree + firstDegree secondDegree firstOrder secondOrder + have habProductReal : + (a : ℝ) * (b : ℝ) = + ((firstOrder * secondOrder * firstDegree * secondDegree : ℕ) : ℝ) := by + exact_mod_cast habProductNat + rw [habProductReal] at hbound + unfold BGS.Markoff.corvajaZannierCorollaryTwoNumericalBound + simp only [chi, Nat.cast_mul] at hbound + simpa only [BGS.External.planeTorusEulerCharacteristicBound, + Nat.cast_ofNat, Nat.cast_mul, mul_assoc] using hbound + +/-- A certificate for the only remaining geometric input at the endpoint. +The real number `G` is intended to be the degree of the gcd divisor of the +two powered torsion functions. Its fields state, respectively, that every +rational torsion point contributes to it, that the elementary divisor bound +holds, and that the Corvaja--Zannier Proposition 2 alternatives hold. -/ +def PlaneCurvePropositionTwoCertificate + (p : ℕ) (K : Type*) [Field K] [Fintype K] [DecidableEq K] + (f : MvPolynomial (Fin 2) K) + (firstDegree secondDegree firstOrder secondOrder : ℕ) : Prop := + ∃ G : ℝ, + ((BGS.External.torusCurveTorsionIntersection + K f firstOrder secondOrder).card : ℝ) ≤ G ∧ + G ≤ planeCurveTorsionLowerDegree + firstDegree secondDegree firstOrder secondOrder ∧ + PropositionTwoNumericalAlternatives + (planeCurveTorsionLowerDegree + firstDegree secondDegree firstOrder secondOrder) + (planeCurveTorsionUpperDegree + firstDegree secondDegree firstOrder secondOrder) + p (2 * firstDegree * secondDegree) G + +/-- Proposition 2's alternatives are downward closed in the gcd quantity. -/ +theorem propositionTwoNumericalAlternatives_mono + {a b p chi : ℕ} {G H : ℝ} (hGH : G ≤ H) + (hH : PropositionTwoNumericalAlternatives a b p chi H) : + PropositionTwoNumericalAlternatives a b p chi G := by + intro h k hadmissible + rcases hH h k hadmissible with hdegree | hbound + · exact Or.inl hdegree + · exact Or.inr (hGH.trans hbound) + +theorem torusCurveTorsionIntersection_le_corvajaZannierBound_of_certificate + (p : ℕ) (K : Type*) [Field K] [Fintype K] [DecidableEq K] + (f : MvPolynomial (Fin 2) K) + (firstDegree secondDegree firstOrder secondOrder : ℕ) + (hfirstDegree : 0 < firstDegree) + (hsecondDegree : 0 < secondDegree) + (hfirstOrder : 0 < firstOrder) + (hsecondOrder : 0 < secondOrder) + (hp : 0 < p) + (hcertificate : PlaneCurvePropositionTwoCertificate + p K f firstDegree secondDegree firstOrder secondOrder) : + ((BGS.External.torusCurveTorsionIntersection + K f firstOrder secondOrder).card : ℝ) ≤ + BGS.Markoff.corvajaZannierCorollaryTwoNumericalBound + p firstOrder secondOrder firstDegree secondDegree + (BGS.External.planeTorusEulerCharacteristicBound + firstDegree secondDegree) := by + obtain ⟨G, hcard, htrivial, hpropositionTwo⟩ := hcertificate + have hGNonneg : 0 ≤ G := + (Nat.cast_nonneg + (BGS.External.torusCurveTorsionIntersection + K f firstOrder secondOrder).card).trans hcard + exact hcard.trans + (planeCurveCorvajaZannierNumericalBound_of_propositionTwo + p firstDegree secondDegree firstOrder secondOrder G + hfirstDegree hsecondDegree hfirstOrder hsecondOrder hp + hGNonneg htrivial hpropositionTwo) + +/-- The explicit Dedekind gcd sum supplies a Proposition 2 certificate once +the two still-geometric inequalities for that sum have been proved. -/ +theorem planeCurvePropositionTwoCertificate_of_dedekindGcdSum + {K : Type*} [Field K] [Fintype K] [DecidableEq K] + {f : MvPolynomial (Fin 2) K} + [IsDomain (PlaneCurveCoordinateRing f)] + {B : Type*} [CommRing B] [IsDedekindDomain B] + [Algebra (PlaneCurveCoordinateRing f) B] + [Algebra B (PlaneCurveFunctionField f)] + [IsScalarTower (PlaneCurveCoordinateRing f) B (PlaneCurveFunctionField f)] + [Algebra.IsIntegral (PlaneCurveCoordinateRing f) B] + [FaithfulSMul (PlaneCurveCoordinateRing f) B] + [IsIntegralClosure B (PlaneCurveCoordinateRing f) + (PlaneCurveFunctionField f)] + [IsFractionRing B (PlaneCurveFunctionField f)] + (p firstDegree secondDegree firstOrder secondOrder : ℕ) + (hfirstNonzero : planeCurveFunction f 0 ^ firstOrder - 1 ≠ 0) + (hsecondNonzero : planeCurveFunction f 1 ^ secondOrder - 1 ≠ 0) + (htrivial : + ((∑ v ∈ torsionGcdPlaceSupport (f := f) (B := B) + firstOrder secondOrder, + torsionGcdMultiplicity (f := f) (B := B) + firstOrder secondOrder v : ℕ) : ℝ) ≤ + planeCurveTorsionLowerDegree + firstDegree secondDegree firstOrder secondOrder) + (hpropositionTwo : PropositionTwoNumericalAlternatives + (planeCurveTorsionLowerDegree + firstDegree secondDegree firstOrder secondOrder) + (planeCurveTorsionUpperDegree + firstDegree secondDegree firstOrder secondOrder) + p (2 * firstDegree * secondDegree) + ((∑ v ∈ torsionGcdPlaceSupport (f := f) (B := B) + firstOrder secondOrder, + torsionGcdMultiplicity (f := f) (B := B) + firstOrder secondOrder v : ℕ) : ℝ)) : + PlaneCurvePropositionTwoCertificate + p K f firstDegree secondDegree firstOrder secondOrder := by + let GNat : ℕ := + ∑ v ∈ torsionGcdPlaceSupport (f := f) (B := B) + firstOrder secondOrder, + torsionGcdMultiplicity (f := f) (B := B) + firstOrder secondOrder v + refine ⟨(GNat : ℝ), ?_, htrivial, hpropositionTwo⟩ + have hcardNat := torsionPoint_card_le_torsionGcdMultiplicity_sum + (f := f) (B := B) firstOrder secondOrder + hfirstNonzero hsecondNonzero + have hfinsetNat : + (BGS.External.torusCurveTorsionIntersection + K f firstOrder secondOrder).card ≤ GNat := by + rw [torusCurveTorsionIntersection_card_eq_torsionPoint_card] + exact hcardNat + exact_mod_cast hfinsetNat + +/-- The sharp fiber-counting bound supplies the trivial certificate bound +directly. Consequently an upper gcd divisor only has to satisfy Proposition +2; it need not separately be proved below the smaller coordinate height. -/ +theorem planeCurvePropositionTwoCertificate_of_dedekindGcdSum_and_bidegree + {K : Type*} [Field K] [Fintype K] [DecidableEq K] + {f : MvPolynomial (Fin 2) K} + [IsDomain (PlaneCurveCoordinateRing f)] + {B : Type*} [CommRing B] [IsDedekindDomain B] + [Algebra (PlaneCurveCoordinateRing f) B] + [Algebra B (PlaneCurveFunctionField f)] + [IsScalarTower (PlaneCurveCoordinateRing f) B (PlaneCurveFunctionField f)] + [Algebra.IsIntegral (PlaneCurveCoordinateRing f) B] + [FaithfulSMul (PlaneCurveCoordinateRing f) B] + [IsIntegralClosure B (PlaneCurveCoordinateRing f) + (PlaneCurveFunctionField f)] + [IsFractionRing B (PlaneCurveFunctionField f)] + (p firstDegree secondDegree firstOrder secondOrder : ℕ) + (hbidegree : BGS.External.HasBidegreeAtMost + f firstDegree secondDegree) + (hcurve : BGS.External.IsCorvajaZannierPlaneCurve f) + (hfirstOrder : 0 < firstOrder) (hsecondOrder : 0 < secondOrder) + (hfirstNonzero : planeCurveFunction f 0 ^ firstOrder - 1 ≠ 0) + (hsecondNonzero : planeCurveFunction f 1 ^ secondOrder - 1 ≠ 0) + (hpropositionTwo : PropositionTwoNumericalAlternatives + (planeCurveTorsionLowerDegree + firstDegree secondDegree firstOrder secondOrder) + (planeCurveTorsionUpperDegree + firstDegree secondDegree firstOrder secondOrder) + p (2 * firstDegree * secondDegree) + ((∑ v ∈ torsionGcdPlaceSupport (f := f) (B := B) + firstOrder secondOrder, + torsionGcdMultiplicity (f := f) (B := B) + firstOrder secondOrder v : ℕ) : ℝ)) : + PlaneCurvePropositionTwoCertificate + p K f firstDegree secondDegree firstOrder secondOrder := by + let card : ℕ := + (BGS.External.torusCurveTorsionIntersection + K f firstOrder secondOrder).card + let gcdDegree : ℕ := + ∑ v ∈ torsionGcdPlaceSupport (f := f) (B := B) + firstOrder secondOrder, + torsionGcdMultiplicity (f := f) (B := B) + firstOrder secondOrder v + have hcardTrivial : card ≤ planeCurveTorsionLowerDegree + firstDegree secondDegree firstOrder secondOrder := by + dsimp only [card, planeCurveTorsionLowerDegree] + simpa only [min_comm] using + torusCurveTorsionIntersection_card_le_min_bidegree_order + f firstDegree secondDegree firstOrder secondOrder + hbidegree hcurve hfirstOrder hsecondOrder + have hcardGcd : card ≤ gcdDegree := by + dsimp only [card, gcdDegree] + rw [torusCurveTorsionIntersection_card_eq_torsionPoint_card] + exact torsionPoint_card_le_torsionGcdMultiplicity_sum + (f := f) (B := B) firstOrder secondOrder + hfirstNonzero hsecondNonzero + refine ⟨(card : ℝ), le_rfl, ?_, ?_⟩ + · exact_mod_cast hcardTrivial + · apply propositionTwoNumericalAlternatives_mono + (G := (card : ℝ)) (H := (gcdDegree : ℝ)) + · exact_mod_cast hcardGcd + · simpa only [gcdDegree] using hpropositionTwo + +/-- A concrete Dedekind gcd sum satisfying the divisor and Proposition 2 +inequalities gives the public numerical endpoint directly. -/ +theorem torusCurveTorsionIntersection_le_corvajaZannierBound_of_dedekindGcdSum + {K : Type*} [Field K] [Fintype K] [DecidableEq K] + {f : MvPolynomial (Fin 2) K} + [IsDomain (PlaneCurveCoordinateRing f)] + {B : Type*} [CommRing B] [IsDedekindDomain B] + [Algebra (PlaneCurveCoordinateRing f) B] + [Algebra B (PlaneCurveFunctionField f)] + [IsScalarTower (PlaneCurveCoordinateRing f) B (PlaneCurveFunctionField f)] + [Algebra.IsIntegral (PlaneCurveCoordinateRing f) B] + [FaithfulSMul (PlaneCurveCoordinateRing f) B] + [IsIntegralClosure B (PlaneCurveCoordinateRing f) + (PlaneCurveFunctionField f)] + [IsFractionRing B (PlaneCurveFunctionField f)] + (p firstDegree secondDegree firstOrder secondOrder : ℕ) + (hfirstDegree : 0 < firstDegree) + (hsecondDegree : 0 < secondDegree) + (hfirstOrder : 0 < firstOrder) + (hsecondOrder : 0 < secondOrder) + (hp : 0 < p) + (hfirstNonzero : planeCurveFunction f 0 ^ firstOrder - 1 ≠ 0) + (hsecondNonzero : planeCurveFunction f 1 ^ secondOrder - 1 ≠ 0) + (htrivial : + ((∑ v ∈ torsionGcdPlaceSupport (f := f) (B := B) + firstOrder secondOrder, + torsionGcdMultiplicity (f := f) (B := B) + firstOrder secondOrder v : ℕ) : ℝ) ≤ + planeCurveTorsionLowerDegree + firstDegree secondDegree firstOrder secondOrder) + (hpropositionTwo : PropositionTwoNumericalAlternatives + (planeCurveTorsionLowerDegree + firstDegree secondDegree firstOrder secondOrder) + (planeCurveTorsionUpperDegree + firstDegree secondDegree firstOrder secondOrder) + p (2 * firstDegree * secondDegree) + ((∑ v ∈ torsionGcdPlaceSupport (f := f) (B := B) + firstOrder secondOrder, + torsionGcdMultiplicity (f := f) (B := B) + firstOrder secondOrder v : ℕ) : ℝ)) : + ((BGS.External.torusCurveTorsionIntersection + K f firstOrder secondOrder).card : ℝ) ≤ + BGS.Markoff.corvajaZannierCorollaryTwoNumericalBound + p firstOrder secondOrder firstDegree secondDegree + (BGS.External.planeTorusEulerCharacteristicBound + firstDegree secondDegree) := by + apply torusCurveTorsionIntersection_le_corvajaZannierBound_of_certificate + p K f firstDegree secondDegree firstOrder secondOrder + hfirstDegree hsecondDegree hfirstOrder hsecondOrder hp + exact planeCurvePropositionTwoCertificate_of_dedekindGcdSum + p firstDegree secondDegree firstOrder secondOrder + hfirstNonzero hsecondNonzero htrivial hpropositionTwo + +/-- The remaining above-elementary-range assertion, now reduced to explicit +Proposition 2 certificates. It contains no axiom or typeclass assumption. -/ +def GeneralPlaneCurvePropositionTwoCertificatesAboveElementaryRange : Prop := + ∀ (p : ℕ) [Fact p.Prime] + (K : Type) [Field K] [Fintype K] [DecidableEq K] [CharP K p] + (f : MvPolynomial (Fin 2) K) + (firstDegree secondDegree firstOrder secondOrder : ℕ), + 0 < firstDegree → + 0 < secondDegree → + BGS.External.HasBidegreeAtMost f firstDegree secondDegree → + BGS.External.IsCorvajaZannierPlaneCurve f → + 0 < firstOrder → + 0 < secondOrder → + ¬ p ∣ firstOrder → + ¬ p ∣ secondOrder → + 12 * firstDegree * secondDegree < p → + PlaneCurvePropositionTwoCertificate + p K f firstDegree secondDegree firstOrder secondOrder + +theorem generalCorvajaZannierPlaneCurveTheoremAboveElementaryRange_of_certificates + (hcertificates : + GeneralPlaneCurvePropositionTwoCertificatesAboveElementaryRange) : + BGS.External.GeneralCorvajaZannierPlaneCurveTheoremAboveElementaryRange := by + unfold GeneralPlaneCurvePropositionTwoCertificatesAboveElementaryRange at hcertificates + unfold BGS.External.GeneralCorvajaZannierPlaneCurveTheoremAboveElementaryRange + intro p _ K _ _ _ _ f firstDegree secondDegree firstOrder secondOrder + hfirstDegree hsecondDegree hbidegree hcurve hfirstOrder hsecondOrder + hfirstPrimeToChar hsecondPrimeToChar hlarge + exact torusCurveTorsionIntersection_le_corvajaZannierBound_of_certificate + p K f firstDegree secondDegree firstOrder secondOrder + hfirstDegree hsecondDegree hfirstOrder hsecondOrder + (Fact.out : p.Prime).pos + (hcertificates p (K := K) f + firstDegree secondDegree firstOrder secondOrder + hfirstDegree hsecondDegree hbidegree hcurve + hfirstOrder hsecondOrder hfirstPrimeToChar hsecondPrimeToChar hlarge) + +/-- The exact endpoint follows from the remaining certificate proposition; +the complementary characteristic range is the proved elementary theorem. -/ +theorem generalCorvajaZannierPlaneCurveTheorem_of_certificates + (hcertificates : + GeneralPlaneCurvePropositionTwoCertificatesAboveElementaryRange) : + BGS.External.GeneralCorvajaZannierPlaneCurveTheorem := by + rw [BGS.External.generalCorvajaZannierPlaneCurveTheorem_iff_aboveElementaryRange] + exact generalCorvajaZannierPlaneCurveTheoremAboveElementaryRange_of_certificates + hcertificates + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/FiniteExtensionCanonicalAuxiliaryFinitePlace.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/FiniteExtensionCanonicalAuxiliaryFinitePlace.lean new file mode 100644 index 0000000000..66f885a99e --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/FiniteExtensionCanonicalAuxiliaryFinitePlace.lean @@ -0,0 +1,384 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.AuxiliaryFamilyIndexing +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveAuxiliaryFinitePlace +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveAuxiliaryFinitePlaceCases +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionExceptionalSupport +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.TorsionExhaustiveGcdDivisorBound +public import Mathlib.Tactic + +/-! +# Finite-place cases for the canonical auxiliary family + +Prove the local auxiliary-family inequalities at finite places, including the grid-order and +derivative-order sums. +-/ + +@[expose] public section + +namespace BGS.CorvajaZannier + +noncomputable section + +open scoped nonZeroDivisors Polynomial BigOperators +open IsDedekindDomain + +variable (K : Type*) [Field K] [DecidableEq K] [DecidableEq (RatFunc K)] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] +variable {C : Type*} [Field C] [Algebra C L] + +local instance (priority := 10) finiteCanonicalCasesPolynomialAlgebra : + Algebra K[X] L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K[X] (RatFunc K))) + +local instance finiteCanonicalCasesPolynomialScalarTower : + IsScalarTower K[X] (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + +local instance finiteCanonicalCasesFiniteIntegralClosureModuleFinite : + Module.Finite K[X] (RatFuncFiniteIntegralClosure K L) := + Module.IsNoetherian.finite K[X] (RatFuncFiniteIntegralClosure K L) + +local instance finiteCanonicalCasesFiniteIntegralClosureIsIntegral : + Algebra.IsIntegral K[X] (RatFuncFiniteIntegralClosure K L) := + IsIntegralClosure.isIntegral_algebra K[X] L + +local instance finiteCanonicalCasesPolynomialTorsionFreeTop : + Module.IsTorsionFree K[X] L := + Module.IsTorsionFree.trans_faithfulSMul K[X] (RatFunc K) L + +local instance finiteCanonicalCasesFiniteIntegralClosureIsTorsionFree : + Module.IsTorsionFree K[X] (RatFuncFiniteIntegralClosure K L) := + IsIntegralClosure.isTorsionFree K[X] L + +omit [DecidableEq K] in +private theorem finiteExtensionFinitePlace_gridOrder_sum_eq + (q : FiniteExtensionFinitePlace K L) + (u v : L) (hu : u ≠ 0) (hv : v ≠ 0) (h k : ℕ) : + (∑ rs : Fin (k + 1) × Fin h, + finitePlaceOrder q (u ^ (rs.1 : ℕ) * v ^ (rs.2 : ℕ))) = + finiteExtensionPrincipalDivisor K L + (finiteExtensionAuxiliaryGridProduct L u v h k) (.inl q) := by + have hdiv := congrArg (fun D : FiniteExtensionPlace K L →₀ ℤ => D (.inl q)) + (finiteExtensionPrincipalDivisor_auxiliaryGridProduct K L u v hu hv h k) + rw [hdiv] + rw [Finset.sum_apply'] + apply Finset.sum_congr rfl + intro rs hrs + have hmul := congrArg (fun D : FiniteExtensionPlace K L →₀ ℤ => D (.inl q)) + (finiteExtensionPrincipalDivisor_mul K L + (u ^ (rs.1 : ℕ)) (v ^ (rs.2 : ℕ)) + (pow_ne_zero _ hu) (pow_ne_zero _ hv)) + have hupow := congrArg (fun D : FiniteExtensionPlace K L →₀ ℤ => D (.inl q)) + (finiteExtensionPrincipalDivisor_pow K L u hu (rs.1 : ℕ)) + have hvpow := congrArg (fun D : FiniteExtensionPlace K L →₀ ℤ => D (.inl q)) + (finiteExtensionPrincipalDivisor_pow K L v hv (rs.2 : ℕ)) + simp only [Finsupp.add_apply, Finsupp.smul_apply, nsmul_eq_mul, + finiteExtensionPrincipalDivisor_inl_eq_finitePlaceOrder] at hmul hupow hvpow + rw [hmul, hupow, hvpow] + simp only [Finsupp.add_apply, Finsupp.smul_apply, nsmul_eq_mul, + finiteExtensionPrincipalDivisor_inl_eq_finitePlaceOrder] + +private theorem auxiliaryFamilyDerivativeOrder_sum_int (h k : ℕ) : + (∑ i : Sum (Fin k) (Fin (k + 1) × Fin h), + (auxiliaryFamilyDerivativeOrder h k i : ℤ)) = + ((h * k + h + k).choose 2 : ℤ) := by + exact_mod_cast auxiliaryFamilyDerivativeOrder_sum h k + +omit [DecidableEq K] in +private theorem finitePlaceOrder_gridMonomial_eq_zero + (q : FiniteExtensionFinitePlace K L) + (u v : L) (hu : u ≠ 0) (hv : v ≠ 0) + (huOrder : finitePlaceOrder q u = 0) + (hvOrder : finitePlaceOrder q v = 0) + (i j : ℕ) : + finitePlaceOrder q (u ^ i * v ^ j) = 0 := by + have hmul := congrArg (fun E : FiniteExtensionPlace K L →₀ ℤ => E (.inl q)) + (finiteExtensionPrincipalDivisor_mul K L + (u ^ i) (v ^ j) (pow_ne_zero _ hu) (pow_ne_zero _ hv)) + have hupow := congrArg (fun E : FiniteExtensionPlace K L →₀ ℤ => E (.inl q)) + (finiteExtensionPrincipalDivisor_pow K L u hu i) + have hvpow := congrArg (fun E : FiniteExtensionPlace K L →₀ ℤ => E (.inl q)) + (finiteExtensionPrincipalDivisor_pow K L v hv j) + simp only [Finsupp.add_apply, Finsupp.smul_apply, nsmul_eq_mul, + finiteExtensionPrincipalDivisor_inl_eq_finitePlaceOrder] at hmul hupow hvpow + rw [hmul, hupow, hvpow, huOrder, hvOrder] + simp + +omit [DecidableEq K] in +/-- Finite-place source case (i), specialized to the consecutive derivative +orders on the source auxiliary family. -/ +theorem finiteExtensionFinitePlace_canonicalAuxiliary_caseI + {p : ℕ} [Fact p.Prime] [CharP L p] [Fintype K] + (q : FiniteExtensionFinitePlace K L) + (D : Derivation (frobeniusSubfield L p) L L) + (c : L) (hc : c ≠ 0) + (hScaledIntegral : + ∀ r : FiniteExtensionFinitePlaceLocalRing K L q, + ∃ s : FiniteExtensionFinitePlaceLocalRing K L q, + (c • D) (finiteExtensionFinitePlaceLocalizationToField + (K := K) (L := L) q r) = + finiteExtensionFinitePlaceLocalizationToField + (K := K) (L := L) q s) + (h k : ℕ) (hn : 0 < h * k + h + k) + (u v : L) (hu : u ≠ 0) (hv : v ≠ 0) + (hu1 : u ≠ 1) (hv1 : v ≠ 1) + (huOrder : finitePlaceOrder q u = 0) + (hvOrder : finitePlaceOrder q v = 0) + (hrhoOrder : finitePlaceOrder q ((1 - u) / (1 - v)) < 0) + (hW : (indexedDedekindLocalWronskian D + (auxiliaryFamilyDerivativeOrder h k) + (auxiliaryFamily u v h k)).det ≠ 0) : + ((h * k + h + k : ℕ) : ℤ) * + finiteExtensionPrincipalDivisor K L ((1 - u) / (1 - v)) (.inl q) ≤ + ((h * k + h + k).choose 2 : ℤ) * finitePlaceOrder q c + + finiteExtensionPrincipalDivisor K L + (indexedDedekindLocalWronskian D + (auxiliaryFamilyDerivativeOrder h k) + (auxiliaryFamily u v h k)).det (.inl q) := by + let n := h * k + h + k + have hrho : (1 - u) / (1 - v) ≠ 0 := + div_ne_zero (sub_ne_zero.mpr hu1.symm) (sub_ne_zero.mpr hv1.symm) + have huTop : + finiteExtensionFinitePlaceLocalOrderTop (K := K) (L := L) q u = 0 := by + rw [finiteExtensionFinitePlaceLocalOrderTop_eq_globalOrder q u hu] + exact_mod_cast huOrder + have hrhoLocal : + finiteExtensionFinitePlaceLocalOrder (K := K) (L := L) q + ((1 - u) / (1 - v)) < 0 := by + rw [finiteExtensionFinitePlaceLocalOrder_eq_globalOrder] + exact hrhoOrder + have hgridRegular : ∀ rs : Fin (k + 1) × Fin h, + (0 : WithTop ℤ) ≤ + finiteExtensionFinitePlaceLocalOrderTop (K := K) (L := L) q + (u ^ (rs.1 : ℕ) * v ^ (rs.2 : ℕ)) := by + intro rs + have hmonomial : u ^ (rs.1 : ℕ) * v ^ (rs.2 : ℕ) ≠ 0 := + mul_ne_zero (pow_ne_zero _ hu) (pow_ne_zero _ hv) + rw [finiteExtensionFinitePlaceLocalOrderTop_eq_globalOrder q _ hmonomial] + have hzero := finitePlaceOrder_gridMonomial_eq_zero + K L q u v hu hv huOrder hvOrder (rs.1 : ℕ) (rs.2 : ℕ) + rw [hzero] + exact le_rfl + have hepsilonMax : ∀ i, auxiliaryFamilyDerivativeOrder h k i ≤ n - 1 := by + intro i + exact auxiliaryFamilyDerivativeOrder_le_pred h k hn i + have hkBound : k ≤ (n - 1) + 1 := by + have hcancel : n - 1 + 1 = n := Nat.sub_add_cancel hn + rw [hcancel] + exact auxiliaryFamily_k_le_card h k + have hepsilonQ : (n - 1) + 1 ≤ n := by + rw [Nat.sub_add_cancel hn] + have hbound := + finiteExtensionFinitePlace_auxiliaryFamily_caseI_q_wronskian_bound_of_scaled_preserves + (K := K) (L := L) (p := p) q h k + (auxiliaryFamilyIndexEquiv h k) + (auxiliaryFamilyDerivativeOrder h k) (fun _ => rfl) + (n - 1) n D c hScaledIntegral u v hrho huTop hrhoLocal + hgridRegular (auxiliaryFamilyDerivativeOrder_injective h k) + hepsilonMax hkBound hepsilonQ + rw [finiteExtensionFinitePlaceLocalOrder_eq_globalOrder, + finiteExtensionFinitePlaceLocalOrderTop_eq_globalOrder q c hc, + finiteExtensionFinitePlaceLocalOrderTop_eq_globalOrder q _ hW] at hbound + have hboundInt : + (n : ℤ) * finitePlaceOrder q ((1 - u) / (1 - v)) ≤ + (n.choose 2 : ℤ) * finitePlaceOrder q c + + finitePlaceOrder q + (indexedDedekindLocalWronskian D + (auxiliaryFamilyDerivativeOrder h k) + (auxiliaryFamily u v h k)).det := by + exact_mod_cast hbound + simpa only [n, finiteExtensionPrincipalDivisor_inl_eq_finitePlaceOrder] + using hboundInt + +omit [DecidableEq K] in +/-- Finite-place source case (ii), with every local order converted to the +coefficient used by the exhaustive principal divisor. -/ +theorem finiteExtensionFinitePlace_canonicalAuxiliary_caseII + (q : FiniteExtensionFinitePlace K L) + (D : Derivation C L L) (c : L) (hc : c ≠ 0) + (hScaledIntegral : + ∀ r : FiniteExtensionFinitePlaceLocalRing K L q, + ∃ s : FiniteExtensionFinitePlaceLocalRing K L q, + (c • D) (finiteExtensionFinitePlaceLocalizationToField + (K := K) (L := L) q r) = + finiteExtensionFinitePlaceLocalizationToField + (K := K) (L := L) q s) + (h k : ℕ) (u v : L) (hu : u ≠ 0) (hv : v ≠ 0) + (hu1 : u ≠ 1) (hv1 : v ≠ 1) + (huOrder : 0 ≤ finitePlaceOrder q u) + (hvOrder : 0 ≤ finitePlaceOrder q v) + (hrhoOrder : 0 ≤ finitePlaceOrder q ((1 - u) / (1 - v))) + (hW : (indexedDedekindLocalWronskian D + (auxiliaryFamilyDerivativeOrder h k) + (auxiliaryFamily u v h k)).det ≠ 0) : + 0 ≤ ((h * k + h + k).choose 2 : ℤ) * finitePlaceOrder q c + + finiteExtensionPrincipalDivisor K L + (indexedDedekindLocalWronskian D + (auxiliaryFamilyDerivativeOrder h k) + (auxiliaryFamily u v h k)).det (.inl q) := by + have hrho : (1 - u) / (1 - v) ≠ 0 := + div_ne_zero (sub_ne_zero.mpr hu1.symm) (sub_ne_zero.mpr hv1.symm) + have huTop : (0 : WithTop ℤ) ≤ + finiteExtensionFinitePlaceLocalOrderTop (K := K) (L := L) q u := by + rw [finiteExtensionFinitePlaceLocalOrderTop_eq_globalOrder q u hu] + exact_mod_cast huOrder + have hvTop : (0 : WithTop ℤ) ≤ + finiteExtensionFinitePlaceLocalOrderTop (K := K) (L := L) q v := by + rw [finiteExtensionFinitePlaceLocalOrderTop_eq_globalOrder q v hv] + exact_mod_cast hvOrder + have hrhoTop : (0 : WithTop ℤ) ≤ + finiteExtensionFinitePlaceLocalOrderTop (K := K) (L := L) q + ((1 - u) / (1 - v)) := by + rw [finiteExtensionFinitePlaceLocalOrderTop_eq_globalOrder q _ hrho] + exact_mod_cast hrhoOrder + have hbound := + finiteExtensionFinitePlace_auxiliaryFamily_caseII_nonnegative_of_scaled_preserves + (K := K) (L := L) q h k + (auxiliaryFamilyIndexEquiv h k) + (auxiliaryFamilyDerivativeOrder h k) (fun _ => rfl) + D c hScaledIntegral u v huTop hvTop hrhoTop + rw [finiteExtensionFinitePlaceLocalOrderTop_eq_globalOrder q c hc, + finiteExtensionFinitePlaceLocalOrderTop_eq_globalOrder q _ hW] at hbound + have hboundInt : + 0 ≤ ((h * k + h + k).choose 2 : ℤ) * finitePlaceOrder q c + + finitePlaceOrder q + (indexedDedekindLocalWronskian D + (auxiliaryFamilyDerivativeOrder h k) + (auxiliaryFamily u v h k)).det := by + exact_mod_cast hbound + simpa only [finiteExtensionPrincipalDivisor_inl_eq_finitePlaceOrder] using hboundInt + +omit [DecidableEq K] in +/-- Finite-place source case (iii), expressed directly with the global +principal divisor and the consecutive-order Wronskian. -/ +theorem finiteExtensionFinitePlace_canonicalAuxiliary_caseIII + (q : FiniteExtensionFinitePlace K L) + (D : Derivation C L L) (c : L) (hc : c ≠ 0) + (hScaledIntegral : + ∀ r : FiniteExtensionFinitePlaceLocalRing K L q, + ∃ s : FiniteExtensionFinitePlaceLocalRing K L q, + (c • D) (finiteExtensionFinitePlaceLocalizationToField + (K := K) (L := L) q r) = + finiteExtensionFinitePlaceLocalizationToField + (K := K) (L := L) q s) + (h k : ℕ) (u v : L) (hu : u ≠ 0) (hv : v ≠ 0) + (hu1 : u ≠ 1) (hv1 : v ≠ 1) + (hW : (indexedDedekindLocalWronskian D + (auxiliaryFamilyDerivativeOrder h k) + (auxiliaryFamily u v h k)).det ≠ 0) : + ((k * (k - 1) / 2 : ℕ) : ℤ) * + finiteExtensionPrincipalDivisor K L u (.inl q) + + ((h * k : ℕ) : ℤ) * + finiteExtensionPrincipalDivisor K L v (.inl q) + + (k : ℤ) * finiteExtensionPrincipalDivisor K L + ((1 - u) / (1 - v)) (.inl q) + + finiteExtensionPrincipalDivisor K L + (finiteExtensionAuxiliaryGridProduct L u v h k) (.inl q) - + ((h * k + h + k).choose 2 : ℤ) ≤ + ((h * k + h + k).choose 2 : ℤ) * finitePlaceOrder q c + + finiteExtensionPrincipalDivisor K L + (indexedDedekindLocalWronskian D + (auxiliaryFamilyDerivativeOrder h k) + (auxiliaryFamily u v h k)).det (.inl q) := by + have hbound := + finiteExtensionFinitePlace_auxiliaryFamily_caseIII_source_lower_bound_of_scaled_preserves + (K := K) (L := L) q h k + (auxiliaryFamilyIndexEquiv h k) + (auxiliaryFamilyDerivativeOrder h k) (fun _ => rfl) + D c hScaledIntegral u v hu hv hu1 hv1 + have hrho : (1 - u) / (1 - v) ≠ 0 := + div_ne_zero (sub_ne_zero.mpr hu1.symm) (sub_ne_zero.mpr hv1.symm) + rw [finiteExtensionFinitePlaceLocalOrder_eq_globalOrder, + finiteExtensionFinitePlaceLocalOrder_eq_globalOrder, + finiteExtensionFinitePlaceLocalOrder_eq_globalOrder] at hbound + simp_rw [finiteExtensionFinitePlaceLocalOrder_eq_globalOrder] at hbound + rw [finiteExtensionFinitePlaceLocalOrderTop_eq_globalOrder q c hc, + finiteExtensionFinitePlaceLocalOrderTop_eq_globalOrder q _ hW] at hbound + have hboundInt : + ((k * (k - 1) / 2 : ℕ) : ℤ) * finitePlaceOrder q u + + ((h * k : ℕ) : ℤ) * finitePlaceOrder q v + + (k : ℤ) * finitePlaceOrder q ((1 - u) / (1 - v)) + + (∑ rs : Fin (k + 1) × Fin h, + finitePlaceOrder q (u ^ (rs.1 : ℕ) * v ^ (rs.2 : ℕ))) - + (∑ i : Sum (Fin k) (Fin (k + 1) × Fin h), + (auxiliaryFamilyDerivativeOrder h k i : ℤ)) ≤ + ((h * k + h + k).choose 2 : ℤ) * finitePlaceOrder q c + + finitePlaceOrder q + (indexedDedekindLocalWronskian D + (auxiliaryFamilyDerivativeOrder h k) + (auxiliaryFamily u v h k)).det := by + exact_mod_cast hbound + rw [auxiliaryFamilyDerivativeOrder_sum_int, + finiteExtensionFinitePlace_gridOrder_sum_eq K L q u v hu hv h k] at hboundInt + simpa only [finiteExtensionPrincipalDivisor_inl_eq_finitePlaceOrder] using hboundInt + +omit [DecidableEq K] in +/-- Finite-place source case (iv), in the same global-divisor form. -/ +theorem finiteExtensionFinitePlace_canonicalAuxiliary_caseIV + (q : FiniteExtensionFinitePlace K L) + (D : Derivation C L L) (c : L) (hc : c ≠ 0) + (hScaledIntegral : + ∀ r : FiniteExtensionFinitePlaceLocalRing K L q, + ∃ s : FiniteExtensionFinitePlaceLocalRing K L q, + (c • D) (finiteExtensionFinitePlaceLocalizationToField + (K := K) (L := L) q r) = + finiteExtensionFinitePlaceLocalizationToField + (K := K) (L := L) q s) + (h k : ℕ) (u v : L) (hu : u ≠ 0) (hv : v ≠ 0) + (hu1 : u ≠ 1) (hv1 : v ≠ 1) + (hW : (indexedDedekindLocalWronskian D + (auxiliaryFamilyDerivativeOrder h k) + (auxiliaryFamily u v h k)).det ≠ 0) : + ((k * (k - 1) / 2 : ℕ) : ℤ) * + finiteExtensionPrincipalDivisor K L u (.inl q) + + (k : ℤ) * finiteExtensionPrincipalDivisor K L + ((1 - u) / (1 - v)) (.inl q) + + finiteExtensionPrincipalDivisor K L + (finiteExtensionAuxiliaryGridProduct L u v h k) (.inl q) - + ((h * k + h + k).choose 2 : ℤ) ≤ + ((h * k + h + k).choose 2 : ℤ) * finitePlaceOrder q c + + finiteExtensionPrincipalDivisor K L + (indexedDedekindLocalWronskian D + (auxiliaryFamilyDerivativeOrder h k) + (auxiliaryFamily u v h k)).det (.inl q) := by + have hbound := + finiteExtensionFinitePlace_auxiliaryFamily_caseIV_source_lower_bound_of_scaled_preserves + (K := K) (L := L) q h k + (auxiliaryFamilyIndexEquiv h k) + (auxiliaryFamilyDerivativeOrder h k) (fun _ => rfl) + D c hScaledIntegral u v hu hv hu1 hv1 + rw [finiteExtensionFinitePlaceLocalOrder_eq_globalOrder, + finiteExtensionFinitePlaceLocalOrder_eq_globalOrder] at hbound + simp_rw [finiteExtensionFinitePlaceLocalOrder_eq_globalOrder] at hbound + rw [finiteExtensionFinitePlaceLocalOrderTop_eq_globalOrder q c hc, + finiteExtensionFinitePlaceLocalOrderTop_eq_globalOrder q _ hW] at hbound + have hboundInt : + ((k * (k - 1) / 2 : ℕ) : ℤ) * finitePlaceOrder q u + + (k : ℤ) * finitePlaceOrder q ((1 - u) / (1 - v)) + + (∑ rs : Fin (k + 1) × Fin h, + finitePlaceOrder q (u ^ (rs.1 : ℕ) * v ^ (rs.2 : ℕ))) - + (∑ i : Sum (Fin k) (Fin (k + 1) × Fin h), + (auxiliaryFamilyDerivativeOrder h k i : ℤ)) ≤ + ((h * k + h + k).choose 2 : ℤ) * finitePlaceOrder q c + + finitePlaceOrder q + (indexedDedekindLocalWronskian D + (auxiliaryFamilyDerivativeOrder h k) + (auxiliaryFamily u v h k)).det := by + exact_mod_cast hbound + rw [auxiliaryFamilyDerivativeOrder_sum_int, + finiteExtensionFinitePlace_gridOrder_sum_eq K L q u v hu hv h k] at hboundInt + simpa only [finiteExtensionPrincipalDivisor_inl_eq_finitePlaceOrder] using hboundInt + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/FiniteExtensionCanonicalAuxiliaryFinitePlaceNormalized.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/FiniteExtensionCanonicalAuxiliaryFinitePlaceNormalized.lean new file mode 100644 index 0000000000..9edd030653 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/FiniteExtensionCanonicalAuxiliaryFinitePlaceNormalized.lean @@ -0,0 +1,184 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionCanonicalAuxiliaryFinitePlace +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionCanonicalPlacewiseScaling + +/-! +# Canonical finite-place bounds for a normalized derivation + +The raw local Wronskian estimates accept an arbitrary clearing scalar. This +file chooses that scalar from the different at each finite place, so its order +is definitionally replaced by the coefficient of the canonical different +divisor. These are the four finite-place inputs used by the exhaustive global +summation. +-/ + +@[expose] public section + +namespace BGS.CorvajaZannier + +noncomputable section + +open scoped Polynomial + +variable (K : Type*) [Field K] [Fintype K] [DecidableEq K] + [DecidableEq (RatFunc K)] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] +variable {p : ℕ} [Fact p.Prime] [CharP K p] [CharP L p] + +local instance (priority := 10) normalizedCasesPolynomialAlgebra : + Algebra K[X] L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K[X] (RatFunc K))) + +local instance normalizedCasesPolynomialScalarTower : + IsScalarTower K[X] (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + +local instance normalizedCasesFiniteIntegralClosureModuleFinite : + Module.Finite K[X] (RatFuncFiniteIntegralClosure K L) := + Module.IsNoetherian.finite K[X] (RatFuncFiniteIntegralClosure K L) + +local instance normalizedCasesFiniteIntegralClosureIsIntegral : + Algebra.IsIntegral K[X] (RatFuncFiniteIntegralClosure K L) := + IsIntegralClosure.isIntegral_algebra K[X] L + +local instance normalizedCasesPolynomialTorsionFreeTop : + Module.IsTorsionFree K[X] L := + Module.IsTorsionFree.trans_faithfulSMul K[X] (RatFunc K) L + +local instance normalizedCasesFiniteIntegralClosureIsTorsionFree : + Module.IsTorsionFree K[X] (RatFuncFiniteIntegralClosure K L) := + IsIntegralClosure.isTorsionFree K[X] L + +/-- The canonical different divisor used by the normalized finite-place estimates. -/ +abbrev normalizedFinitePlaceCanonicalDifferent : FiniteExtensionPlace K L →₀ ℤ := + finiteExtensionCanonicalDifferentDivisor K L + (finiteExtensionFiniteDifferentIdeal_ne_bot K L) + +/-- Canonical finite-place case (i), outside the exceptional set with a pole +of `(1-u)/(1-v)`. -/ +theorem finiteExtensionFinitePlace_canonicalAuxiliary_caseI_of_normalized + (q : FiniteExtensionFinitePlace K L) + (D : Derivation (frobeniusSubfield L p) L L) + (hDX : D (algebraMap (RatFunc K) L RatFunc.X) = 1) + (h k : ℕ) (hn : 0 < h * k + h + k) + (u v : L) (hu : u ≠ 0) (hv : v ≠ 0) + (hu1 : u ≠ 1) (hv1 : v ≠ 1) + (huOrder : finitePlaceOrder q u = 0) + (hvOrder : finitePlaceOrder q v = 0) + (hrhoOrder : finitePlaceOrder q ((1 - u) / (1 - v)) < 0) + (hW : (indexedDedekindLocalWronskian D + (auxiliaryFamilyDerivativeOrder h k) + (auxiliaryFamily u v h k)).det ≠ 0) : + ((h * k + h + k : ℕ) : ℤ) * + finiteExtensionPrincipalDivisor K L ((1 - u) / (1 - v)) (.inl q) ≤ + ((h * k + h + k).choose 2 : ℤ) * normalizedFinitePlaceCanonicalDifferent K L (.inl q) + + finiteExtensionPrincipalDivisor K L + (indexedDedekindLocalWronskian D + (auxiliaryFamilyDerivativeOrder h k) + (auxiliaryFamily u v h k)).det (.inl q) := by + obtain ⟨c, hc, hcOrder, hIntegral⟩ := + exists_finiteExtensionFinitePlace_canonicalDifferent_scaling_certificate + K L D hDX q + have hcase := finiteExtensionFinitePlace_canonicalAuxiliary_caseI + K L q D c hc hIntegral h k hn u v hu hv hu1 hv1 + huOrder hvOrder hrhoOrder hW + simpa only [normalizedFinitePlaceCanonicalDifferent, hcOrder] using hcase + +omit [DecidableEq K] in +/-- Canonical finite-place case (ii), outside the exceptional set without a +pole of `(1-u)/(1-v)`. -/ +theorem finiteExtensionFinitePlace_canonicalAuxiliary_caseII_of_normalized + (q : FiniteExtensionFinitePlace K L) + (D : Derivation (frobeniusSubfield L p) L L) + (hDX : D (algebraMap (RatFunc K) L RatFunc.X) = 1) + (h k : ℕ) (u v : L) (hu : u ≠ 0) (hv : v ≠ 0) + (hu1 : u ≠ 1) (hv1 : v ≠ 1) + (huOrder : 0 ≤ finitePlaceOrder q u) + (hvOrder : 0 ≤ finitePlaceOrder q v) + (hrhoOrder : 0 ≤ finitePlaceOrder q ((1 - u) / (1 - v))) + (hW : (indexedDedekindLocalWronskian D + (auxiliaryFamilyDerivativeOrder h k) + (auxiliaryFamily u v h k)).det ≠ 0) : + 0 ≤ ((h * k + h + k).choose 2 : ℤ) * normalizedFinitePlaceCanonicalDifferent K L (.inl q) + + finiteExtensionPrincipalDivisor K L + (indexedDedekindLocalWronskian D + (auxiliaryFamilyDerivativeOrder h k) + (auxiliaryFamily u v h k)).det (.inl q) := by + obtain ⟨c, hc, hcOrder, hIntegral⟩ := + exists_finiteExtensionFinitePlace_canonicalDifferent_scaling_certificate + K L D hDX q + have hcase := finiteExtensionFinitePlace_canonicalAuxiliary_caseII + K L q D c hc hIntegral h k u v hu hv hu1 hv1 + huOrder hvOrder hrhoOrder hW + simpa only [normalizedFinitePlaceCanonicalDifferent, hcOrder] using hcase + +/-- Canonical finite-place case (iii), at a positive-order place of `v`. -/ +theorem finiteExtensionFinitePlace_canonicalAuxiliary_caseIII_of_normalized + (q : FiniteExtensionFinitePlace K L) + (D : Derivation (frobeniusSubfield L p) L L) + (hDX : D (algebraMap (RatFunc K) L RatFunc.X) = 1) + (h k : ℕ) (u v : L) (hu : u ≠ 0) (hv : v ≠ 0) + (hu1 : u ≠ 1) (hv1 : v ≠ 1) + (hW : (indexedDedekindLocalWronskian D + (auxiliaryFamilyDerivativeOrder h k) + (auxiliaryFamily u v h k)).det ≠ 0) : + ((k * (k - 1) / 2 : ℕ) : ℤ) * finiteExtensionPrincipalDivisor K L u (.inl q) + + ((h * k : ℕ) : ℤ) * finiteExtensionPrincipalDivisor K L v (.inl q) + + (k : ℤ) * finiteExtensionPrincipalDivisor K L + ((1 - u) / (1 - v)) (.inl q) + + finiteExtensionPrincipalDivisor K L + (finiteExtensionAuxiliaryGridProduct L u v h k) (.inl q) - + ((h * k + h + k).choose 2 : ℤ) ≤ + ((h * k + h + k).choose 2 : ℤ) * normalizedFinitePlaceCanonicalDifferent K L (.inl q) + + finiteExtensionPrincipalDivisor K L + (indexedDedekindLocalWronskian D + (auxiliaryFamilyDerivativeOrder h k) + (auxiliaryFamily u v h k)).det (.inl q) := by + obtain ⟨c, hc, hcOrder, hIntegral⟩ := + exists_finiteExtensionFinitePlace_canonicalDifferent_scaling_certificate + K L D hDX q + have hcase := finiteExtensionFinitePlace_canonicalAuxiliary_caseIII + K L q D c hc hIntegral h k u v hu hv hu1 hv1 hW + simpa only [normalizedFinitePlaceCanonicalDifferent, hcOrder] using hcase + +/-- Canonical finite-place case (iv), at a nonpositive-order place of `v`. -/ +theorem finiteExtensionFinitePlace_canonicalAuxiliary_caseIV_of_normalized + (q : FiniteExtensionFinitePlace K L) + (D : Derivation (frobeniusSubfield L p) L L) + (hDX : D (algebraMap (RatFunc K) L RatFunc.X) = 1) + (h k : ℕ) (u v : L) (hu : u ≠ 0) (hv : v ≠ 0) + (hu1 : u ≠ 1) (hv1 : v ≠ 1) + (hW : (indexedDedekindLocalWronskian D + (auxiliaryFamilyDerivativeOrder h k) + (auxiliaryFamily u v h k)).det ≠ 0) : + ((k * (k - 1) / 2 : ℕ) : ℤ) * finiteExtensionPrincipalDivisor K L u (.inl q) + + (k : ℤ) * finiteExtensionPrincipalDivisor K L + ((1 - u) / (1 - v)) (.inl q) + + finiteExtensionPrincipalDivisor K L + (finiteExtensionAuxiliaryGridProduct L u v h k) (.inl q) - + ((h * k + h + k).choose 2 : ℤ) ≤ + ((h * k + h + k).choose 2 : ℤ) * normalizedFinitePlaceCanonicalDifferent K L (.inl q) + + finiteExtensionPrincipalDivisor K L + (indexedDedekindLocalWronskian D + (auxiliaryFamilyDerivativeOrder h k) + (auxiliaryFamily u v h k)).det (.inl q) := by + obtain ⟨c, hc, hcOrder, hIntegral⟩ := + exists_finiteExtensionFinitePlace_canonicalDifferent_scaling_certificate + K L D hDX q + have hcase := finiteExtensionFinitePlace_canonicalAuxiliary_caseIV + K L q D c hc hIntegral h k u v hu hv hu1 hv1 hW + simpa only [normalizedFinitePlaceCanonicalDifferent, hcOrder] using hcase + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/FiniteExtensionCanonicalAuxiliaryInfinityPlace.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/FiniteExtensionCanonicalAuxiliaryInfinityPlace.lean new file mode 100644 index 0000000000..93c6b9dba0 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/FiniteExtensionCanonicalAuxiliaryInfinityPlace.lean @@ -0,0 +1,1209 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.AuxiliaryFamilyIndexing +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.DedekindCanonicalDifferentScaling +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.DedekindLocalizationDerivationPreservation +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.DedekindAuxiliaryLocalCases +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.DedekindPerfectResidueCaseI +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionCanonicalDifferentDivisor +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionExceptionalSupport +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.TorsionExhaustiveGcdDivisorBound +public import Mathlib.Tactic + +/-! +# Canonical auxiliary bounds at infinity places + +This module transports the four local Corvaja--Zannier auxiliary-family cases to +branches above the infinity place of a finite separable extension of `RatFunc K`. +The scaling supplied by the canonical different identifies its local order with +the coefficient of `finiteExtensionCanonicalDifferentDivisor` at `.inr P`. +-/ + +@[expose] public section + +namespace BGS.CorvajaZannier + +noncomputable section + + +open scoped nonZeroDivisors Polynomial BigOperators +open IsDedekindDomain + +variable (K : Type*) [Field K] [DecidableEq K] [DecidableEq (RatFunc K)] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +local instance infinityAuxiliaryBaseConstantAlgebra : + Algebra K (RatFuncInfinityIntegers K) := + (ratFuncInfinityConstantRingHom K).toAlgebra + +local instance infinityAuxiliaryBaseConstantTower : + IsScalarTower K (RatFuncInfinityIntegers K) (RatFunc K) := + .of_algebraMap_eq' rfl + +local instance infinityAuxiliaryIntegralClosureModuleFinite : + Module.Finite (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.finite (RatFuncInfinityIntegers K) (RatFunc K) L + (RatFuncInfinityIntegralClosure K L) + +local instance infinityAuxiliaryIntegralClosureIsIntegral : + Algebra.IsIntegral (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.isIntegral_algebra (RatFuncInfinityIntegers K) L + +local instance infinityAuxiliaryBaseTorsionFreeTop : + Module.IsTorsionFree (RatFuncInfinityIntegers K) L := + Module.IsTorsionFree.trans_faithfulSMul + (RatFuncInfinityIntegers K) (RatFunc K) L + +local instance infinityAuxiliaryIntegralClosureIsTorsionFree : + Module.IsTorsionFree (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.isTorsionFree (RatFuncInfinityIntegers K) L + +local instance infinityAuxiliaryIntegralClosureIsDedekindDomain : + IsDedekindDomain (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.isDedekindDomain + (RatFuncInfinityIntegers K) (RatFunc K) L + (RatFuncInfinityIntegralClosure K L) + +local instance infinityAuxiliaryIntegralClosureIsFractionRing : + IsFractionRing (RatFuncInfinityIntegralClosure K L) L := + IsIntegralClosure.isFractionRing_of_finite_extension + (RatFuncInfinityIntegers K) (RatFunc K) L + (RatFuncInfinityIntegralClosure K L) + +local instance infinityAuxiliaryIntegralClosureConstantAlgebra : + Algebra K (RatFuncInfinityIntegralClosure K L) := + RingHom.toAlgebra + ((algebraMap (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L)).comp + (algebraMap K (RatFuncInfinityIntegers K))) + +local instance infinityAuxiliaryIntegralClosureConstantTower : + IsScalarTower K (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) := + .of_algebraMap_eq' rfl + +local instance infinityAuxiliaryBaseFaithfulSmulFractionRing : + FaithfulSMul (RatFuncInfinityIntegers K) + (FractionRing (RatFuncInfinityIntegralClosure K L)) := by + rw [faithfulSMul_iff_algebraMap_injective] + intro x y hxy + have hT := IsFractionRing.injective (RatFuncInfinityIntegralClosure K L) + (FractionRing (RatFuncInfinityIntegralClosure K L)) hxy + have hL := congrArg Subtype.val hT + apply Subtype.ext + apply (algebraMap (RatFunc K) L).injective + exact hL + +local instance infinityAuxiliaryFractionRingAlgebra : + Algebra (FractionRing (RatFuncInfinityIntegers K)) + (FractionRing (RatFuncInfinityIntegralClosure K L)) := + FractionRing.liftAlgebra (RatFuncInfinityIntegers K) + (FractionRing (RatFuncInfinityIntegralClosure K L)) + +local instance infinityAuxiliaryFractionRingSeparable : + Algebra.IsSeparable (FractionRing (RatFuncInfinityIntegers K)) + (FractionRing (RatFuncInfinityIntegralClosure K L)) := by + refine Algebra.IsSeparable.of_equiv_equiv + (ratFuncInfinityFractionRingEquiv K).symm.toRingEquiv + (FractionRing.algEquiv (RatFuncInfinityIntegralClosure K L) L).symm.toRingEquiv ?_ + ext z + exact IsFractionRing.algEquiv_commutes + (ratFuncInfinityFractionRingEquiv K).symm + (FractionRing.algEquiv (RatFuncInfinityIntegralClosure K L) L).symm z + +local instance infinityAuxiliaryPlaceIsPrime + (P : FiniteExtensionInfinityPlace K L) : P.1.IsPrime := + Ideal.primesOver.isPrime (ratFuncInfinityPlace K).asIdeal P + +local instance infinityAuxiliaryPlaceLiesOver + (P : FiniteExtensionInfinityPlace K L) : + P.1.LiesOver (ratFuncInfinityPlace K).asIdeal := + Ideal.primesOver.liesOver (ratFuncInfinityPlace K).asIdeal P + +/-- The localization of the infinity integral closure at one branch. -/ +abbrev FiniteExtensionInfinityPlaceLocalRing + (P : FiniteExtensionInfinityPlace K L) := + Localization.AtPrime + (primeOverHeightOne (ratFuncInfinityPlace K) P).asIdeal + +section InfinityLocalOrder + +variable {K L} + +noncomputable def finiteExtensionInfinityPlaceLocalizationToField + (P : FiniteExtensionInfinityPlace K L) : + FiniteExtensionInfinityPlaceLocalRing K L P →+* L := + IsLocalization.lift + (S := FiniteExtensionInfinityPlaceLocalRing K L P) + (M := (primeOverHeightOne + (ratFuncInfinityPlace K) P).asIdeal.primeCompl) + (g := algebraMap (RatFuncInfinityIntegralClosure K L) L) fun y => + IsLocalization.map_units L + ⟨y.1, (primeOverHeightOne (ratFuncInfinityPlace K) P).asIdeal.primeCompl_le_nonZeroDivisors + y.2⟩ + +omit [DecidableEq K] in +@[simp] theorem finiteExtensionInfinityPlaceLocalizationToField_comp_algebraMap + (P : FiniteExtensionInfinityPlace K L) : + (finiteExtensionInfinityPlaceLocalizationToField + (K := K) (L := L) P).comp + (algebraMap (RatFuncInfinityIntegralClosure K L) + (FiniteExtensionInfinityPlaceLocalRing K L P)) = + algebraMap (RatFuncInfinityIntegralClosure K L) L := by + exact IsLocalization.lift_comp _ + +@[reducible] noncomputable def finiteExtensionInfinityPlaceLocalAlgebra + (P : FiniteExtensionInfinityPlace K L) : + Algebra (FiniteExtensionInfinityPlaceLocalRing K L P) L := + (finiteExtensionInfinityPlaceLocalizationToField + (K := K) (L := L) P).toAlgebra + +omit [DecidableEq K] in +theorem finiteExtensionInfinityPlaceLocalIsFractionRing + (P : FiniteExtensionInfinityPlace K L) : + let _ := finiteExtensionInfinityPlaceLocalAlgebra + (K := K) (L := L) P + IsFractionRing (FiniteExtensionInfinityPlaceLocalRing K L P) L := by + let hIntegralClosureLocalAlgebra : + Algebra (RatFuncInfinityIntegralClosure K L) + (FiniteExtensionInfinityPlaceLocalRing K L P) := inferInstance + let _ := finiteExtensionInfinityPlaceLocalAlgebra + (K := K) (L := L) P + let _ : SMul (RatFuncInfinityIntegralClosure K L) + (FiniteExtensionInfinityPlaceLocalRing K L P) := Algebra.toSMul + let _ : SMul (FiniteExtensionInfinityPlaceLocalRing K L P) L := Algebra.toSMul + let _ : SMul (RatFuncInfinityIntegralClosure K L) L := Algebra.toSMul + let : IsScalarTower (RatFuncInfinityIntegralClosure K L) + (FiniteExtensionInfinityPlaceLocalRing K L P) L := by + have htower := IsScalarTower.of_algebraMap_eq' + (R := RatFuncInfinityIntegralClosure K L) + (S := FiniteExtensionInfinityPlaceLocalRing K L P) (A := L) + (finiteExtensionInfinityPlaceLocalizationToField_comp_algebraMap + (K := K) (L := L) P).symm + exact htower + have hFraction := IsFractionRing.isFractionRing_of_isDomain_of_isLocalization + (R := RatFuncInfinityIntegralClosure K L) + (primeOverHeightOne (ratFuncInfinityPlace K) P).asIdeal.primeCompl + (FiniteExtensionInfinityPlaceLocalRing K L P) L + exact hFraction + +noncomputable def finiteExtensionInfinityPlaceLocalOrderTop + (P : FiniteExtensionInfinityPlace K L) (x : L) : WithTop ℤ := by + let _ := finiteExtensionInfinityPlaceLocalAlgebra + (K := K) (L := L) P + letI := finiteExtensionInfinityPlaceLocalIsFractionRing + (K := K) (L := L) P + letI : IsDiscreteValuationRing + (FiniteExtensionInfinityPlaceLocalRing K L P) := + IsLocalization.AtPrime.isDiscreteValuationRing_of_dedekind_domain + (RatFuncInfinityIntegralClosure K L) + (primeOverHeightOne (ratFuncInfinityPlace K) P).ne_bot + (FiniteExtensionInfinityPlaceLocalRing K L P) + exact finitePlaceOrderTop + (IsDiscreteValuationRing.maximalIdeal + (FiniteExtensionInfinityPlaceLocalRing K L P)) x + +noncomputable def finiteExtensionInfinityPlaceLocalOrder + (P : FiniteExtensionInfinityPlace K L) (x : L) : ℤ := by + let _ := finiteExtensionInfinityPlaceLocalAlgebra + (K := K) (L := L) P + letI := finiteExtensionInfinityPlaceLocalIsFractionRing + (K := K) (L := L) P + letI : IsDiscreteValuationRing + (FiniteExtensionInfinityPlaceLocalRing K L P) := + IsLocalization.AtPrime.isDiscreteValuationRing_of_dedekind_domain + (RatFuncInfinityIntegralClosure K L) + (primeOverHeightOne (ratFuncInfinityPlace K) P).ne_bot + (FiniteExtensionInfinityPlaceLocalRing K L P) + exact finitePlaceOrder + (IsDiscreteValuationRing.maximalIdeal + (FiniteExtensionInfinityPlaceLocalRing K L P)) x + +omit [DecidableEq K] in +theorem finiteExtensionInfinityPlaceLocalOrder_eq_globalOrder + (P : FiniteExtensionInfinityPlace K L) (x : L) : + finiteExtensionInfinityPlaceLocalOrder (K := K) (L := L) P x = + finitePlaceOrder (primeOverHeightOne (ratFuncInfinityPlace K) P) x := by + let _ := finiteExtensionInfinityPlaceLocalAlgebra + (K := K) (L := L) P + let := finiteExtensionInfinityPlaceLocalIsFractionRing + (K := K) (L := L) P + let : IsDiscreteValuationRing + (FiniteExtensionInfinityPlaceLocalRing K L P) := + IsLocalization.AtPrime.isDiscreteValuationRing_of_dedekind_domain + (RatFuncInfinityIntegralClosure K L) + (primeOverHeightOne (ratFuncInfinityPlace K) P).ne_bot + (FiniteExtensionInfinityPlaceLocalRing K L P) + let _ : SMul (RatFuncInfinityIntegralClosure K L) + (FiniteExtensionInfinityPlaceLocalRing K L P) := Algebra.toSMul + let _ : SMul (FiniteExtensionInfinityPlaceLocalRing K L P) L := Algebra.toSMul + let _ : SMul (RatFuncInfinityIntegralClosure K L) L := Algebra.toSMul + let : IsScalarTower (RatFuncInfinityIntegralClosure K L) + (FiniteExtensionInfinityPlaceLocalRing K L P) L := by + have htower := IsScalarTower.of_algebraMap_eq' + (R := RatFuncInfinityIntegralClosure K L) + (S := FiniteExtensionInfinityPlaceLocalRing K L P) (A := L) + (finiteExtensionInfinityPlaceLocalizationToField_comp_algebraMap + (K := K) (L := L) P).symm + exact htower + change finitePlaceOrder + (IsDiscreteValuationRing.maximalIdeal + (FiniteExtensionInfinityPlaceLocalRing K L P)) x = _ + have hOrder := localizationAtPrime_finitePlaceOrder_eq + (S := FiniteExtensionInfinityPlaceLocalRing K L P) + (primeOverHeightOne (ratFuncInfinityPlace K) P) x + exact hOrder + +omit [DecidableEq K] in +theorem finiteExtensionInfinityPlaceLocalOrderTop_eq_globalOrder + (P : FiniteExtensionInfinityPlace K L) (x : L) (hx : x ≠ 0) : + finiteExtensionInfinityPlaceLocalOrderTop (K := K) (L := L) P x = + (finitePlaceOrder + (primeOverHeightOne (ratFuncInfinityPlace K) P) x : WithTop ℤ) := by + let _ := finiteExtensionInfinityPlaceLocalAlgebra + (K := K) (L := L) P + let := finiteExtensionInfinityPlaceLocalIsFractionRing + (K := K) (L := L) P + let : IsDiscreteValuationRing + (FiniteExtensionInfinityPlaceLocalRing K L P) := + IsLocalization.AtPrime.isDiscreteValuationRing_of_dedekind_domain + (RatFuncInfinityIntegralClosure K L) + (primeOverHeightOne (ratFuncInfinityPlace K) P).ne_bot + (FiniteExtensionInfinityPlaceLocalRing K L P) + simp only [finiteExtensionInfinityPlaceLocalOrderTop] + rw [finitePlaceOrderTop_eq_coe _ _ hx] + exact_mod_cast finiteExtensionInfinityPlaceLocalOrder_eq_globalOrder + (K := K) (L := L) P x + +omit [DecidableEq K] in +@[simp] theorem finiteExtensionInfinityPlaceLocalOrderTop_mul + (P : FiniteExtensionInfinityPlace K L) (x y : L) : + finiteExtensionInfinityPlaceLocalOrderTop (K := K) (L := L) P (x * y) = + finiteExtensionInfinityPlaceLocalOrderTop (K := K) (L := L) P x + + finiteExtensionInfinityPlaceLocalOrderTop (K := K) (L := L) P y := by + simp only [finiteExtensionInfinityPlaceLocalOrderTop, + finitePlaceOrderTop_mul] + +omit [DecidableEq K] in +@[simp] theorem finiteExtensionInfinityPlaceLocalOrderTop_pow + (P : FiniteExtensionInfinityPlace K L) (x : L) (n : ℕ) : + finiteExtensionInfinityPlaceLocalOrderTop (K := K) (L := L) P (x ^ n) = + n • finiteExtensionInfinityPlaceLocalOrderTop (K := K) (L := L) P x := by + simp only [finiteExtensionInfinityPlaceLocalOrderTop, + finitePlaceOrderTop_pow] + +end InfinityLocalOrder + +section InfinityLocalAuxiliaryBounds + +variable {K L} +variable {C : Type*} [Field C] [Algebra C L] + +omit [DecidableEq K] in +/-- Preservation of the infinity integral closure propagates to the selected +localized branch. -/ +theorem finiteExtensionInfinityPlace_local_preserves_of_global_preserves + (P : FiniteExtensionInfinityPlace K L) + (E : Derivation C L L) + (hE : ∀ t : RatFuncInfinityIntegralClosure K L, + ∃ t' : RatFuncInfinityIntegralClosure K L, + E (algebraMap (RatFuncInfinityIntegralClosure K L) L t) = + algebraMap (RatFuncInfinityIntegralClosure K L) L t') : + ∀ r : FiniteExtensionInfinityPlaceLocalRing K L P, + ∃ s : FiniteExtensionInfinityPlaceLocalRing K L P, + E (finiteExtensionInfinityPlaceLocalizationToField + (K := K) (L := L) P r) = + finiteExtensionInfinityPlaceLocalizationToField + (K := K) (L := L) P s := by + let hLocalAlgebra := finiteExtensionInfinityPlaceLocalAlgebra + (K := K) (L := L) P + let hLocalFraction := finiteExtensionInfinityPlaceLocalIsFractionRing + (K := K) (L := L) P + let _ : SMul (RatFuncInfinityIntegralClosure K L) + (FiniteExtensionInfinityPlaceLocalRing K L P) := Algebra.toSMul + let _ : SMul (FiniteExtensionInfinityPlaceLocalRing K L P) L := Algebra.toSMul + let _ : SMul (RatFuncInfinityIntegralClosure K L) L := Algebra.toSMul + let : IsScalarTower (RatFuncInfinityIntegralClosure K L) + (FiniteExtensionInfinityPlaceLocalRing K L P) L := by + have htower := IsScalarTower.of_algebraMap_eq' + (R := RatFuncInfinityIntegralClosure K L) + (S := FiniteExtensionInfinityPlaceLocalRing K L P) (A := L) + (finiteExtensionInfinityPlaceLocalizationToField_comp_algebraMap + (K := K) (L := L) P).symm + exact htower + have hPreserves := ambientDerivation_preserves_localizationAtPrime_of_preserves + (primeOverHeightOne (ratFuncInfinityPlace K) P).asIdeal E hE + exact hPreserves + +/-- The infinity different supplies the exact canonical scaling coefficient. +The reciprocal-parameter derivations are explicit inputs: `Es` preserves the +infinity valuation ring and `D = -s² Es` after restricting constants. -/ +theorem exists_finiteExtensionInfinityPlace_canonicalDifferent_scaling_certificate + [Algebra K L] [IsScalarTower K (RatFunc K) L] + [IsScalarTower K (RatFuncInfinityIntegers K) L] + [IsScalarTower K (RatFuncInfinityIntegralClosure K L) L] + [IsScalarTower (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) L] + [Algebra K C] [IsScalarTower K C L] + (D : Derivation C L L) + (Ds : Derivation K (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegers K)) + (Es : Derivation K L L) + (hEs : ∀ r : RatFuncInfinityIntegers K, + Es (algebraMap (RatFuncInfinityIntegers K) L r) = + algebraMap (RatFuncInfinityIntegers K) L (Ds r)) + (hDX : D.restrictScalars K = + (-(algebraMap (RatFuncInfinityIntegers K) L + (ratFuncInfinityUniformizer K)) ^ 2) • Es) + (P : FiniteExtensionInfinityPlace K L) : + ∃ c : L, c ≠ 0 ∧ + finitePlaceOrder (primeOverHeightOne (ratFuncInfinityPlace K) P) c = + finiteExtensionCanonicalDifferentDivisor K L + (finiteExtensionFiniteDifferentIdeal_ne_bot K L) (.inr P) ∧ + ∀ r : FiniteExtensionInfinityPlaceLocalRing K L P, + ∃ s : FiniteExtensionInfinityPlaceLocalRing K L P, + (c • D) (finiteExtensionInfinityPlaceLocalizationToField + (K := K) (L := L) P r) = + finiteExtensionInfinityPlaceLocalizationToField + (K := K) (L := L) P s := by + let q := primeOverHeightOne (ratFuncInfinityPlace K) P + let : q.asIdeal.LiesOver (ratFuncInfinityPlace K).asIdeal := by + simpa [q] using + (Ideal.primesOver.liesOver (ratFuncInfinityPlace K).asIdeal P) + have hs : ratFuncInfinityUniformizer K ≠ 0 := by + intro hsZero + have hcoe : (ratFuncInfinityUniformizer K : RatFunc K) = 0 := + congrArg Subtype.val hsZero + exact (ratFuncInfinityUniformizer_isUniformizer K).ne_zero hcoe + obtain ⟨δ, hδ, _hδmem, _hδmult, hOrder, hPreserves⟩ := + exists_infinity_different_localGenerator_scaling_certificate + (C := K) (S := RatFuncInfinityIntegers K) + (T := RatFuncInfinityIntegralClosure K L) (L := L) + (ratFuncInfinityPlace K) q (ratFuncInfinityUniformizer K) hs + (ratFuncInfinityPlace_span_uniformizer K) Ds Es + (D.restrictScalars K) hEs hDX + let c : L := + -(algebraMap (RatFuncInfinityIntegralClosure K L) L δ) / + (algebraMap (RatFuncInfinityIntegers K) L + (ratFuncInfinityUniformizer K)) ^ 2 + have hδL : algebraMap (RatFuncInfinityIntegralClosure K L) L δ ≠ 0 := by + simpa using + (IsFractionRing.injective (RatFuncInfinityIntegralClosure K L) L).ne hδ + have hsL : algebraMap (RatFuncInfinityIntegers K) L + (ratFuncInfinityUniformizer K) ≠ 0 := by + have hsT : algebraMap (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) + (ratFuncInfinityUniformizer K) ≠ 0 := by + simpa using (FaithfulSMul.algebraMap_injective + (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L)).ne hs + rw [IsScalarTower.algebraMap_apply (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) L] + exact (IsFractionRing.injective + (RatFuncInfinityIntegralClosure K L) L).ne hsT + have hc : c ≠ 0 := div_ne_zero (neg_ne_zero.mpr hδL) (pow_ne_zero 2 hsL) + have hGlobal : ∀ t : RatFuncInfinityIntegralClosure K L, + ∃ t' : RatFuncInfinityIntegralClosure K L, + (c • D) (algebraMap (RatFuncInfinityIntegralClosure K L) L t) = + algebraMap (RatFuncInfinityIntegralClosure K L) L t' := by + intro t + obtain ⟨t', ht'⟩ := hPreserves t + refine ⟨t', ?_⟩ + simpa only [c, Derivation.smul_apply, Algebra.smul_def, + Algebra.algebraMap_self_apply, Derivation.restrictScalars_apply] using ht' + refine ⟨c, hc, ?_, ?_⟩ + · rw [primeOverHeightOne_asIdeal] at hOrder + simpa only [c, finiteExtensionCanonicalDifferentDivisor_inr] using hOrder + · exact finiteExtensionInfinityPlace_local_preserves_of_global_preserves + (K := K) (L := L) P (c • D) hGlobal + +omit [DecidableEq K] in +/-- Infinity-place source case (iii), after scaling a global derivation by a +factor preserving the infinity integral closure. -/ +theorem finiteExtensionInfinityPlace_auxiliaryFamily_caseIII_of_scaled_preserves + (P : FiniteExtensionInfinityPlace K L) + (h k : ℕ) {n : ℕ} + (e : Sum (Fin k) (Fin (k + 1) × Fin h) ≃ Fin n) + (epsilon : Sum (Fin k) (Fin (k + 1) × Fin h) → ℕ) + (hepsilon : ∀ i, epsilon i = (e i : ℕ)) + (D : Derivation C L L) (c : L) + (hScaledLocal : + ∀ r : FiniteExtensionInfinityPlaceLocalRing K L P, + ∃ s : FiniteExtensionInfinityPlaceLocalRing K L P, + (c • D) (finiteExtensionInfinityPlaceLocalizationToField + (K := K) (L := L) P r) = + finiteExtensionInfinityPlaceLocalizationToField + (K := K) (L := L) P s) + (u v : L) (hu : u ≠ 0) (hv : v ≠ 0) + (hu1 : u ≠ 1) (hv1 : v ≠ 1) : + (((k * (k - 1) / 2 : ℕ) * + finiteExtensionInfinityPlaceLocalOrder (K := K) (L := L) P u + + (h * k) * + finiteExtensionInfinityPlaceLocalOrder (K := K) (L := L) P v + + k * finiteExtensionInfinityPlaceLocalOrder (K := K) (L := L) P + ((1 - u) / (1 - v)) + + ∑ rs : Fin (k + 1) × Fin h, + finiteExtensionInfinityPlaceLocalOrder (K := K) (L := L) P + (u ^ (rs.1 : ℕ) * v ^ (rs.2 : ℕ)) - + ∑ i, (epsilon i : ℤ) : ℤ) : WithTop ℤ) ≤ + n.choose 2 • + finiteExtensionInfinityPlaceLocalOrderTop (K := K) (L := L) P c + + finiteExtensionInfinityPlaceLocalOrderTop (K := K) (L := L) P + (indexedDedekindLocalWronskian D epsilon + (auxiliaryFamily u v h k)).det := by + let hLocalAlgebra := finiteExtensionInfinityPlaceLocalAlgebra + (K := K) (L := L) P + let hLocalFraction := finiteExtensionInfinityPlaceLocalIsFractionRing + (K := K) (L := L) P + let : IsDiscreteValuationRing + (FiniteExtensionInfinityPlaceLocalRing K L P) := + IsLocalization.AtPrime.isDiscreteValuationRing_of_dedekind_domain + (RatFuncInfinityIntegralClosure K L) + (primeOverHeightOne (ratFuncInfinityPlace K) P).ne_bot + (FiniteExtensionInfinityPlaceLocalRing K L P) + have hbound := + finitePlaceOrderTop_auxiliaryFamily_caseIII_source_lower_bound_of_preserves + (IsDiscreteValuationRing.maximalIdeal + (FiniteExtensionInfinityPlaceLocalRing K L P)) + (c • D) hScaledLocal h k epsilon u v hu hv hu1 hv1 + have hchange := indexedDedekindLocalWronskian_det_changeParameter + e epsilon hepsilon (c • D) D c rfl (auxiliaryFamily u v h k) + change (((_ : ℤ) : WithTop ℤ) ≤ _) at hbound + rw [hchange, finitePlaceOrderTop_mul, finitePlaceOrderTop_pow] at hbound + exact hbound + +omit [DecidableEq K] in +/-- Infinity-place source case (iv), with the same exact scaling correction. -/ +theorem finiteExtensionInfinityPlace_auxiliaryFamily_caseIV_of_scaled_preserves + (P : FiniteExtensionInfinityPlace K L) + (h k : ℕ) {n : ℕ} + (e : Sum (Fin k) (Fin (k + 1) × Fin h) ≃ Fin n) + (epsilon : Sum (Fin k) (Fin (k + 1) × Fin h) → ℕ) + (hepsilon : ∀ i, epsilon i = (e i : ℕ)) + (D : Derivation C L L) (c : L) + (hScaledLocal : + ∀ r : FiniteExtensionInfinityPlaceLocalRing K L P, + ∃ s : FiniteExtensionInfinityPlaceLocalRing K L P, + (c • D) (finiteExtensionInfinityPlaceLocalizationToField + (K := K) (L := L) P r) = + finiteExtensionInfinityPlaceLocalizationToField + (K := K) (L := L) P s) + (u v : L) (hu : u ≠ 0) (hv : v ≠ 0) + (hu1 : u ≠ 1) (hv1 : v ≠ 1) : + (((k * (k - 1) / 2 : ℕ) * + finiteExtensionInfinityPlaceLocalOrder (K := K) (L := L) P u + + k * finiteExtensionInfinityPlaceLocalOrder (K := K) (L := L) P + ((1 - u) / (1 - v)) + + ∑ rs : Fin (k + 1) × Fin h, + finiteExtensionInfinityPlaceLocalOrder (K := K) (L := L) P + (u ^ (rs.1 : ℕ) * v ^ (rs.2 : ℕ)) - + ∑ i, (epsilon i : ℤ) : ℤ) : WithTop ℤ) ≤ + n.choose 2 • + finiteExtensionInfinityPlaceLocalOrderTop (K := K) (L := L) P c + + finiteExtensionInfinityPlaceLocalOrderTop (K := K) (L := L) P + (indexedDedekindLocalWronskian D epsilon + (auxiliaryFamily u v h k)).det := by + let hLocalAlgebra := finiteExtensionInfinityPlaceLocalAlgebra + (K := K) (L := L) P + let hLocalFraction := finiteExtensionInfinityPlaceLocalIsFractionRing + (K := K) (L := L) P + let : IsDiscreteValuationRing + (FiniteExtensionInfinityPlaceLocalRing K L P) := + IsLocalization.AtPrime.isDiscreteValuationRing_of_dedekind_domain + (RatFuncInfinityIntegralClosure K L) + (primeOverHeightOne (ratFuncInfinityPlace K) P).ne_bot + (FiniteExtensionInfinityPlaceLocalRing K L P) + have hbound := + finitePlaceOrderTop_auxiliaryFamily_caseIV_source_lower_bound_of_preserves + (IsDiscreteValuationRing.maximalIdeal + (FiniteExtensionInfinityPlaceLocalRing K L P)) + (c • D) hScaledLocal h k epsilon u v hu hv hu1 hv1 + have hchange := indexedDedekindLocalWronskian_det_changeParameter + e epsilon hepsilon (c • D) D c rfl (auxiliaryFamily u v h k) + change (((_ : ℤ) : WithTop ℤ) ≤ _) at hbound + rw [hchange, finitePlaceOrderTop_mul, finitePlaceOrderTop_pow] at hbound + exact hbound + +end InfinityLocalAuxiliaryBounds + +section InfinityGlobalOrderHelpers + +variable {K L} + +@[simp] theorem finiteExtensionPrincipalDivisor_inr_eq_infinityPlaceOrder + (x : L) (P : FiniteExtensionInfinityPlace K L) : + finiteExtensionPrincipalDivisor K L x (.inr P) = + finitePlaceOrder (primeOverHeightOne (ratFuncInfinityPlace K) P) x := by + rw [finiteExtensionPrincipalDivisor_inr] + symm + simpa [ratFuncInfinityIntegralClosureFractionRingEquiv] using + fractionRingAlgEquiv_finitePlaceOrder_eq + (R := RatFuncInfinityIntegralClosure K L) (L := L) + (primeOverHeightOne (ratFuncInfinityPlace K) P) + ((ratFuncInfinityIntegralClosureFractionRingEquiv K L).symm x) + +private theorem finiteExtensionInfinityPlace_gridOrder_sum_eq + (P : FiniteExtensionInfinityPlace K L) + (u v : L) (hu : u ≠ 0) (hv : v ≠ 0) (h k : ℕ) : + (∑ rs : Fin (k + 1) × Fin h, + finitePlaceOrder (primeOverHeightOne (ratFuncInfinityPlace K) P) + (u ^ (rs.1 : ℕ) * v ^ (rs.2 : ℕ))) = + finiteExtensionPrincipalDivisor K L + (finiteExtensionAuxiliaryGridProduct L u v h k) (.inr P) := by + have hdiv := congrArg + (fun D : FiniteExtensionPlace K L →₀ ℤ => D (.inr P)) + (finiteExtensionPrincipalDivisor_auxiliaryGridProduct K L u v hu hv h k) + rw [hdiv] + rw [Finset.sum_apply'] + apply Finset.sum_congr rfl + intro rs hrs + have hmul := congrArg + (fun D : FiniteExtensionPlace K L →₀ ℤ => D (.inr P)) + (finiteExtensionPrincipalDivisor_mul K L + (u ^ (rs.1 : ℕ)) (v ^ (rs.2 : ℕ)) + (pow_ne_zero _ hu) (pow_ne_zero _ hv)) + have hupow := congrArg + (fun D : FiniteExtensionPlace K L →₀ ℤ => D (.inr P)) + (finiteExtensionPrincipalDivisor_pow K L u hu (rs.1 : ℕ)) + have hvpow := congrArg + (fun D : FiniteExtensionPlace K L →₀ ℤ => D (.inr P)) + (finiteExtensionPrincipalDivisor_pow K L v hv (rs.2 : ℕ)) + simp only [Finsupp.add_apply, Finsupp.smul_apply, nsmul_eq_mul, + finiteExtensionPrincipalDivisor_inr_eq_infinityPlaceOrder] at hmul hupow hvpow + rw [hmul, hupow, hvpow] + simp only [Finsupp.add_apply, Finsupp.smul_apply, nsmul_eq_mul, + finiteExtensionPrincipalDivisor_inr_eq_infinityPlaceOrder] + +private theorem infinityAuxiliaryFamilyDerivativeOrder_sum_int (h k : ℕ) : + (∑ i : Sum (Fin k) (Fin (k + 1) × Fin h), + (auxiliaryFamilyDerivativeOrder h k i : ℤ)) = + ((h * k + h + k).choose 2 : ℤ) := by + exact_mod_cast auxiliaryFamilyDerivativeOrder_sum h k + +end InfinityGlobalOrderHelpers + +section InfinityCanonicalAuxiliaryCases + +variable {K L} +variable {C : Type*} [Field C] [Algebra C L] + +/-- Infinity source case (iii), expressed with the actual canonical different +coefficient and exhaustive principal divisors. -/ +theorem finiteExtensionInfinityPlace_canonicalAuxiliary_caseIII_of_scaling + (P : FiniteExtensionInfinityPlace K L) + (D : Derivation C L L) (c : L) (hc : c ≠ 0) + (hcOrder : + finitePlaceOrder (primeOverHeightOne (ratFuncInfinityPlace K) P) c = + finiteExtensionCanonicalDifferentDivisor K L + (finiteExtensionFiniteDifferentIdeal_ne_bot K L) (.inr P)) + (hScaledLocal : + ∀ r : FiniteExtensionInfinityPlaceLocalRing K L P, + ∃ s : FiniteExtensionInfinityPlaceLocalRing K L P, + (c • D) (finiteExtensionInfinityPlaceLocalizationToField + (K := K) (L := L) P r) = + finiteExtensionInfinityPlaceLocalizationToField + (K := K) (L := L) P s) + (h k : ℕ) (u v : L) (hu : u ≠ 0) (hv : v ≠ 0) + (hu1 : u ≠ 1) (hv1 : v ≠ 1) + (hW : (indexedDedekindLocalWronskian D + (auxiliaryFamilyDerivativeOrder h k) + (auxiliaryFamily u v h k)).det ≠ 0) : + ((k * (k - 1) / 2 : ℕ) : ℤ) * + finiteExtensionPrincipalDivisor K L u (.inr P) + + ((h * k : ℕ) : ℤ) * + finiteExtensionPrincipalDivisor K L v (.inr P) + + (k : ℤ) * finiteExtensionPrincipalDivisor K L + ((1 - u) / (1 - v)) (.inr P) + + finiteExtensionPrincipalDivisor K L + (finiteExtensionAuxiliaryGridProduct L u v h k) (.inr P) - + ((h * k + h + k).choose 2 : ℤ) ≤ + ((h * k + h + k).choose 2 : ℤ) * + finiteExtensionCanonicalDifferentDivisor K L + (finiteExtensionFiniteDifferentIdeal_ne_bot K L) (.inr P) + + finiteExtensionPrincipalDivisor K L + (indexedDedekindLocalWronskian D + (auxiliaryFamilyDerivativeOrder h k) + (auxiliaryFamily u v h k)).det (.inr P) := by + have hbound := + finiteExtensionInfinityPlace_auxiliaryFamily_caseIII_of_scaled_preserves + (K := K) (L := L) P h k + (auxiliaryFamilyIndexEquiv h k) + (auxiliaryFamilyDerivativeOrder h k) (fun _ => rfl) + D c hScaledLocal u v hu hv hu1 hv1 + rw [finiteExtensionInfinityPlaceLocalOrder_eq_globalOrder, + finiteExtensionInfinityPlaceLocalOrder_eq_globalOrder, + finiteExtensionInfinityPlaceLocalOrder_eq_globalOrder] at hbound + simp_rw [finiteExtensionInfinityPlaceLocalOrder_eq_globalOrder] at hbound + rw [finiteExtensionInfinityPlaceLocalOrderTop_eq_globalOrder P c hc, + finiteExtensionInfinityPlaceLocalOrderTop_eq_globalOrder P _ hW] at hbound + have hboundInt : + ((k * (k - 1) / 2 : ℕ) : ℤ) * + finitePlaceOrder (primeOverHeightOne (ratFuncInfinityPlace K) P) u + + ((h * k : ℕ) : ℤ) * + finitePlaceOrder (primeOverHeightOne (ratFuncInfinityPlace K) P) v + + (k : ℤ) * + finitePlaceOrder (primeOverHeightOne (ratFuncInfinityPlace K) P) + ((1 - u) / (1 - v)) + + ∑ rs : Fin (k + 1) × Fin h, + finitePlaceOrder (primeOverHeightOne (ratFuncInfinityPlace K) P) + (u ^ (rs.1 : ℕ) * v ^ (rs.2 : ℕ)) - + ∑ i : Sum (Fin k) (Fin (k + 1) × Fin h), + (auxiliaryFamilyDerivativeOrder h k i : ℤ) ≤ + (h * k + h + k).choose 2 • + finitePlaceOrder (primeOverHeightOne (ratFuncInfinityPlace K) P) c + + finitePlaceOrder (primeOverHeightOne (ratFuncInfinityPlace K) P) + (indexedDedekindLocalWronskian D + (auxiliaryFamilyDerivativeOrder h k) + (auxiliaryFamily u v h k)).det := by + exact_mod_cast hbound + rw [infinityAuxiliaryFamilyDerivativeOrder_sum_int, + finiteExtensionInfinityPlace_gridOrder_sum_eq P u v hu hv h k, + hcOrder] at hboundInt + simpa only [nsmul_eq_mul, + finiteExtensionPrincipalDivisor_inr_eq_infinityPlaceOrder] using + hboundInt + +/-- Infinity source case (iv), in the same canonical global-divisor form. -/ +theorem finiteExtensionInfinityPlace_canonicalAuxiliary_caseIV_of_scaling + (P : FiniteExtensionInfinityPlace K L) + (D : Derivation C L L) (c : L) (hc : c ≠ 0) + (hcOrder : + finitePlaceOrder (primeOverHeightOne (ratFuncInfinityPlace K) P) c = + finiteExtensionCanonicalDifferentDivisor K L + (finiteExtensionFiniteDifferentIdeal_ne_bot K L) (.inr P)) + (hScaledLocal : + ∀ r : FiniteExtensionInfinityPlaceLocalRing K L P, + ∃ s : FiniteExtensionInfinityPlaceLocalRing K L P, + (c • D) (finiteExtensionInfinityPlaceLocalizationToField + (K := K) (L := L) P r) = + finiteExtensionInfinityPlaceLocalizationToField + (K := K) (L := L) P s) + (h k : ℕ) (u v : L) (hu : u ≠ 0) (hv : v ≠ 0) + (hu1 : u ≠ 1) (hv1 : v ≠ 1) + (hW : (indexedDedekindLocalWronskian D + (auxiliaryFamilyDerivativeOrder h k) + (auxiliaryFamily u v h k)).det ≠ 0) : + ((k * (k - 1) / 2 : ℕ) : ℤ) * + finiteExtensionPrincipalDivisor K L u (.inr P) + + (k : ℤ) * finiteExtensionPrincipalDivisor K L + ((1 - u) / (1 - v)) (.inr P) + + finiteExtensionPrincipalDivisor K L + (finiteExtensionAuxiliaryGridProduct L u v h k) (.inr P) - + ((h * k + h + k).choose 2 : ℤ) ≤ + ((h * k + h + k).choose 2 : ℤ) * + finiteExtensionCanonicalDifferentDivisor K L + (finiteExtensionFiniteDifferentIdeal_ne_bot K L) (.inr P) + + finiteExtensionPrincipalDivisor K L + (indexedDedekindLocalWronskian D + (auxiliaryFamilyDerivativeOrder h k) + (auxiliaryFamily u v h k)).det (.inr P) := by + have hbound := + finiteExtensionInfinityPlace_auxiliaryFamily_caseIV_of_scaled_preserves + (K := K) (L := L) P h k + (auxiliaryFamilyIndexEquiv h k) + (auxiliaryFamilyDerivativeOrder h k) (fun _ => rfl) + D c hScaledLocal u v hu hv hu1 hv1 + rw [finiteExtensionInfinityPlaceLocalOrder_eq_globalOrder, + finiteExtensionInfinityPlaceLocalOrder_eq_globalOrder] at hbound + simp_rw [finiteExtensionInfinityPlaceLocalOrder_eq_globalOrder] at hbound + rw [finiteExtensionInfinityPlaceLocalOrderTop_eq_globalOrder P c hc, + finiteExtensionInfinityPlaceLocalOrderTop_eq_globalOrder P _ hW] at hbound + have hboundInt : + ((k * (k - 1) / 2 : ℕ) : ℤ) * + finitePlaceOrder (primeOverHeightOne (ratFuncInfinityPlace K) P) u + + (k : ℤ) * + finitePlaceOrder (primeOverHeightOne (ratFuncInfinityPlace K) P) + ((1 - u) / (1 - v)) + + ∑ rs : Fin (k + 1) × Fin h, + finitePlaceOrder (primeOverHeightOne (ratFuncInfinityPlace K) P) + (u ^ (rs.1 : ℕ) * v ^ (rs.2 : ℕ)) - + ∑ i : Sum (Fin k) (Fin (k + 1) × Fin h), + (auxiliaryFamilyDerivativeOrder h k i : ℤ) ≤ + (h * k + h + k).choose 2 • + finitePlaceOrder (primeOverHeightOne (ratFuncInfinityPlace K) P) c + + finitePlaceOrder (primeOverHeightOne (ratFuncInfinityPlace K) P) + (indexedDedekindLocalWronskian D + (auxiliaryFamilyDerivativeOrder h k) + (auxiliaryFamily u v h k)).det := by + exact_mod_cast hbound + rw [infinityAuxiliaryFamilyDerivativeOrder_sum_int, + finiteExtensionInfinityPlace_gridOrder_sum_eq P u v hu hv h k, + hcOrder] at hboundInt + simpa only [nsmul_eq_mul, + finiteExtensionPrincipalDivisor_inr_eq_infinityPlaceOrder] using + hboundInt + +end InfinityCanonicalAuxiliaryCases + +section InfinityCaseII + +variable {K L} +variable {C : Type*} [Field C] [Algebra C L] + +omit [DecidableEq K] in +theorem finiteExtensionInfinityPlace_exists_local_lift_of_orderTop_nonnegative + (P : FiniteExtensionInfinityPlace K L) (x : L) + (hx : (0 : WithTop ℤ) ≤ + finiteExtensionInfinityPlaceLocalOrderTop (K := K) (L := L) P x) : + ∃ x₀ : FiniteExtensionInfinityPlaceLocalRing K L P, + x = finiteExtensionInfinityPlaceLocalizationToField + (K := K) (L := L) P x₀ := by + let _ := finiteExtensionInfinityPlaceLocalAlgebra (K := K) (L := L) P + let := finiteExtensionInfinityPlaceLocalIsFractionRing + (K := K) (L := L) P + let : IsDiscreteValuationRing + (FiniteExtensionInfinityPlaceLocalRing K L P) := + IsLocalization.AtPrime.isDiscreteValuationRing_of_dedekind_domain + (RatFuncInfinityIntegralClosure K L) + (primeOverHeightOne (ratFuncInfinityPlace K) P).ne_bot + (FiniteExtensionInfinityPlaceLocalRing K L P) + by_cases hx0 : x = 0 + · exact ⟨0, by simp [hx0]⟩ + have horder : 0 ≤ finitePlaceOrder + (IsDiscreteValuationRing.maximalIdeal + (FiniteExtensionInfinityPlaceLocalRing K L P)) x := by + simpa only [finiteExtensionInfinityPlaceLocalOrderTop, + finitePlaceOrderTop_eq_coe _ _ hx0, WithTop.coe_nonneg] using hx + have hval : + (IsDiscreteValuationRing.maximalIdeal + (FiniteExtensionInfinityPlaceLocalRing K L P)).valuation L x ≤ 1 := by + rw [valuation_eq_exp_neg_finitePlaceOrder _ x hx0] + simpa only [← WithZero.exp_zero] using + (WithZero.exp_le_exp.mpr (by omega : + -finitePlaceOrder + (IsDiscreteValuationRing.maximalIdeal + (FiniteExtensionInfinityPlaceLocalRing K L P)) x ≤ 0)) + obtain ⟨x₀, hx₀⟩ := IsDiscreteValuationRing.exists_lift_of_le_one hval + exact ⟨x₀, hx₀.symm⟩ + +omit [DecidableEq K] in +theorem finiteExtensionInfinityPlace_auxiliaryFamily_caseII_of_scaled_preserves + (P : FiniteExtensionInfinityPlace K L) + (h k : ℕ) {n : ℕ} + (e : Sum (Fin k) (Fin (k + 1) × Fin h) ≃ Fin n) + (epsilon : Sum (Fin k) (Fin (k + 1) × Fin h) → ℕ) + (hepsilon : ∀ i, epsilon i = (e i : ℕ)) + (D : Derivation C L L) (c : L) + (hScaledLocal : + ∀ r : FiniteExtensionInfinityPlaceLocalRing K L P, + ∃ s : FiniteExtensionInfinityPlaceLocalRing K L P, + (c • D) (finiteExtensionInfinityPlaceLocalizationToField + (K := K) (L := L) P r) = + finiteExtensionInfinityPlaceLocalizationToField + (K := K) (L := L) P s) + (u v : L) + (hu : (0 : WithTop ℤ) ≤ + finiteExtensionInfinityPlaceLocalOrderTop (K := K) (L := L) P u) + (hv : (0 : WithTop ℤ) ≤ + finiteExtensionInfinityPlaceLocalOrderTop (K := K) (L := L) P v) + (hrho : (0 : WithTop ℤ) ≤ + finiteExtensionInfinityPlaceLocalOrderTop (K := K) (L := L) P + ((1 - u) / (1 - v))) : + (0 : WithTop ℤ) ≤ + n.choose 2 • + finiteExtensionInfinityPlaceLocalOrderTop (K := K) (L := L) P c + + finiteExtensionInfinityPlaceLocalOrderTop (K := K) (L := L) P + (indexedDedekindLocalWronskian D epsilon + (auxiliaryFamily u v h k)).det := by + let _ := finiteExtensionInfinityPlaceLocalAlgebra (K := K) (L := L) P + let := finiteExtensionInfinityPlaceLocalIsFractionRing + (K := K) (L := L) P + let : IsDiscreteValuationRing + (FiniteExtensionInfinityPlaceLocalRing K L P) := + IsLocalization.AtPrime.isDiscreteValuationRing_of_dedekind_domain + (RatFuncInfinityIntegralClosure K L) + (primeOverHeightOne (ratFuncInfinityPlace K) P).ne_bot + (FiniteExtensionInfinityPlaceLocalRing K L P) + have hbound := finitePlaceOrderTop_auxiliaryFamily_caseII_nonnegative_of_integral + (IsDiscreteValuationRing.maximalIdeal + (FiniteExtensionInfinityPlaceLocalRing K L P)) + (c • D) hScaledLocal h k epsilon u v + (by + obtain ⟨u₀, hu₀⟩ := + finiteExtensionInfinityPlace_exists_local_lift_of_orderTop_nonnegative + P u hu + exact ⟨u₀, hu₀⟩) + (by + obtain ⟨v₀, hv₀⟩ := + finiteExtensionInfinityPlace_exists_local_lift_of_orderTop_nonnegative + P v hv + exact ⟨v₀, hv₀⟩) + (by + obtain ⟨rho₀, hrho₀⟩ := + finiteExtensionInfinityPlace_exists_local_lift_of_orderTop_nonnegative + P ((1 - u) / (1 - v)) hrho + exact ⟨rho₀, hrho₀⟩) + have hchange := indexedDedekindLocalWronskian_det_changeParameter + e epsilon hepsilon (c • D) D c rfl (auxiliaryFamily u v h k) + rw [hchange, finitePlaceOrderTop_mul, finitePlaceOrderTop_pow] at hbound + exact hbound + +theorem finiteExtensionInfinityPlace_canonicalAuxiliary_caseII_of_scaling + (P : FiniteExtensionInfinityPlace K L) + (D : Derivation C L L) (c : L) (hc : c ≠ 0) + (hcOrder : + finitePlaceOrder (primeOverHeightOne (ratFuncInfinityPlace K) P) c = + finiteExtensionCanonicalDifferentDivisor K L + (finiteExtensionFiniteDifferentIdeal_ne_bot K L) (.inr P)) + (hScaledLocal : + ∀ r : FiniteExtensionInfinityPlaceLocalRing K L P, + ∃ s : FiniteExtensionInfinityPlaceLocalRing K L P, + (c • D) (finiteExtensionInfinityPlaceLocalizationToField + (K := K) (L := L) P r) = + finiteExtensionInfinityPlaceLocalizationToField + (K := K) (L := L) P s) + (h k : ℕ) (u v : L) (hu : u ≠ 0) (hv : v ≠ 0) + (hu1 : u ≠ 1) (hv1 : v ≠ 1) + (huOrder : 0 ≤ + finitePlaceOrder (primeOverHeightOne (ratFuncInfinityPlace K) P) u) + (hvOrder : 0 ≤ + finitePlaceOrder (primeOverHeightOne (ratFuncInfinityPlace K) P) v) + (hrhoOrder : 0 ≤ + finitePlaceOrder (primeOverHeightOne (ratFuncInfinityPlace K) P) + ((1 - u) / (1 - v))) + (hW : (indexedDedekindLocalWronskian D + (auxiliaryFamilyDerivativeOrder h k) + (auxiliaryFamily u v h k)).det ≠ 0) : + 0 ≤ ((h * k + h + k).choose 2 : ℤ) * + finiteExtensionCanonicalDifferentDivisor K L + (finiteExtensionFiniteDifferentIdeal_ne_bot K L) (.inr P) + + finiteExtensionPrincipalDivisor K L + (indexedDedekindLocalWronskian D + (auxiliaryFamilyDerivativeOrder h k) + (auxiliaryFamily u v h k)).det (.inr P) := by + have hrho : (1 - u) / (1 - v) ≠ 0 := + div_ne_zero (sub_ne_zero.mpr hu1.symm) (sub_ne_zero.mpr hv1.symm) + have huTop : (0 : WithTop ℤ) ≤ + finiteExtensionInfinityPlaceLocalOrderTop (K := K) (L := L) P u := by + rw [finiteExtensionInfinityPlaceLocalOrderTop_eq_globalOrder P u hu] + exact_mod_cast huOrder + have hvTop : (0 : WithTop ℤ) ≤ + finiteExtensionInfinityPlaceLocalOrderTop (K := K) (L := L) P v := by + rw [finiteExtensionInfinityPlaceLocalOrderTop_eq_globalOrder P v hv] + exact_mod_cast hvOrder + have hrhoTop : (0 : WithTop ℤ) ≤ + finiteExtensionInfinityPlaceLocalOrderTop (K := K) (L := L) P + ((1 - u) / (1 - v)) := by + rw [finiteExtensionInfinityPlaceLocalOrderTop_eq_globalOrder P _ hrho] + exact_mod_cast hrhoOrder + have hbound := + finiteExtensionInfinityPlace_auxiliaryFamily_caseII_of_scaled_preserves + (K := K) (L := L) P h k + (auxiliaryFamilyIndexEquiv h k) + (auxiliaryFamilyDerivativeOrder h k) (fun _ => rfl) + D c hScaledLocal u v huTop hvTop hrhoTop + rw [finiteExtensionInfinityPlaceLocalOrderTop_eq_globalOrder P c hc, + finiteExtensionInfinityPlaceLocalOrderTop_eq_globalOrder P _ hW] at hbound + have hboundInt : + 0 ≤ (h * k + h + k).choose 2 • + finitePlaceOrder (primeOverHeightOne (ratFuncInfinityPlace K) P) c + + finitePlaceOrder (primeOverHeightOne (ratFuncInfinityPlace K) P) + (indexedDedekindLocalWronskian D + (auxiliaryFamilyDerivativeOrder h k) + (auxiliaryFamily u v h k)).det := by + exact_mod_cast hbound + rw [hcOrder] at hboundInt + simpa only [nsmul_eq_mul, + finiteExtensionPrincipalDivisor_inr_eq_infinityPlaceOrder] using hboundInt + +end InfinityCaseII + +section InfinityResiduePerfect + +variable {K L} + +theorem ratFuncInfinityPlace_residueField_finite [Fintype K] : + Finite (ratFuncInfinityPlace K).asIdeal.ResidueField := by + exact Finite.of_injective (ratFuncInfinityPlaceResidueEquiv K) + (ratFuncInfinityPlaceResidueEquiv K).injective + +theorem finiteExtensionInfinityPlace_residueField_finite [Fintype K] + (P : FiniteExtensionInfinityPlace K L) : Finite P.1.ResidueField := by + let p := (ratFuncInfinityPlace K).asIdeal + let : Finite p.ResidueField := + ratFuncInfinityPlace_residueField_finite (K := K) + let : P.1.LiesOver p := by + simpa [p] using Ideal.primesOver.liesOver + (ratFuncInfinityPlace K).asIdeal P + let hLocalAlg := Localization.AtPrime.algebraOfLiesOver p P.1 + have : IsScalarTower (RatFuncInfinityIntegers K) (Localization.AtPrime p) + (Localization.AtPrime P.1) := inferInstance + let : Algebra.QuasiFiniteAt (RatFuncInfinityIntegers K) P.1 := inferInstance + let : Module.Finite p.ResidueField P.1.ResidueField := inferInstance + exact Module.finite_of_finite p.ResidueField + +theorem finiteExtensionInfinityPlaceLocal_residueField_perfect [Fintype K] + (P : FiniteExtensionInfinityPlace K L) : + letI : IsDiscreteValuationRing + (FiniteExtensionInfinityPlaceLocalRing K L P) := + IsLocalization.AtPrime.isDiscreteValuationRing_of_dedekind_domain + (RatFuncInfinityIntegralClosure K L) + (primeOverHeightOne (ratFuncInfinityPlace K) P).ne_bot + (FiniteExtensionInfinityPlaceLocalRing K L P) + PerfectField + (IsDiscreteValuationRing.maximalIdeal + (FiniteExtensionInfinityPlaceLocalRing K L P)).asIdeal.ResidueField := by + let q := (primeOverHeightOne (ratFuncInfinityPlace K) P).asIdeal + let : Finite q.ResidueField := by + simpa [q, primeOverHeightOne_asIdeal] using + finiteExtensionInfinityPlace_residueField_finite (K := K) (L := L) P + let : Finite (HasQuotient.Quotient + (RatFuncInfinityIntegralClosure K L) q) := + Finite.of_injective + (algebraMap (HasQuotient.Quotient + (RatFuncInfinityIntegralClosure K L) q) q.ResidueField) + q.injective_algebraMap_quotient_residueField + let : IsDiscreteValuationRing + (FiniteExtensionInfinityPlaceLocalRing K L P) := + IsLocalization.AtPrime.isDiscreteValuationRing_of_dedekind_domain + (RatFuncInfinityIntegralClosure K L) + (primeOverHeightOne (ratFuncInfinityPlace K) P).ne_bot + (FiniteExtensionInfinityPlaceLocalRing K L P) + let e := IsLocalization.AtPrime.equivQuotMaximalIdeal q + (FiniteExtensionInfinityPlaceLocalRing K L P) + let : Finite (HasQuotient.Quotient + (FiniteExtensionInfinityPlaceLocalRing K L P) + (IsDiscreteValuationRing.maximalIdeal + (FiniteExtensionInfinityPlaceLocalRing K L P)).asIdeal) := + Finite.of_injective e.symm e.symm.injective + let Rq := HasQuotient.Quotient + (FiniteExtensionInfinityPlaceLocalRing K L P) + (IsDiscreteValuationRing.maximalIdeal + (FiniteExtensionInfinityPlaceLocalRing K L P)).asIdeal + let : Finite + (IsDiscreteValuationRing.maximalIdeal + (FiniteExtensionInfinityPlaceLocalRing K L P)).asIdeal.ResidueField := + IsLocalization.finite Rq (nonZeroDivisors Rq) + exact PerfectField.ofFinite + +end InfinityResiduePerfect + +section InfinityCaseI + +variable {K L} +variable {p : ℕ} [Fact p.Prime] [CharP L p] + +private theorem infinityPlaceOrder_gridMonomial_eq_zero + (P : FiniteExtensionInfinityPlace K L) + (u v : L) (hu : u ≠ 0) (hv : v ≠ 0) + (huOrder : finitePlaceOrder + (primeOverHeightOne (ratFuncInfinityPlace K) P) u = 0) + (hvOrder : finitePlaceOrder + (primeOverHeightOne (ratFuncInfinityPlace K) P) v = 0) + (i j : ℕ) : + finitePlaceOrder (primeOverHeightOne (ratFuncInfinityPlace K) P) + (u ^ i * v ^ j) = 0 := by + have hmul := congrArg + (fun E : FiniteExtensionPlace K L →₀ ℤ => E (.inr P)) + (finiteExtensionPrincipalDivisor_mul K L + (u ^ i) (v ^ j) (pow_ne_zero _ hu) (pow_ne_zero _ hv)) + have hupow := congrArg + (fun E : FiniteExtensionPlace K L →₀ ℤ => E (.inr P)) + (finiteExtensionPrincipalDivisor_pow K L u hu i) + have hvpow := congrArg + (fun E : FiniteExtensionPlace K L →₀ ℤ => E (.inr P)) + (finiteExtensionPrincipalDivisor_pow K L v hv j) + simp only [Finsupp.add_apply, Finsupp.smul_apply, nsmul_eq_mul, + finiteExtensionPrincipalDivisor_inr_eq_infinityPlaceOrder] at hmul hupow hvpow + rw [hmul, hupow, hvpow, huOrder, hvOrder] + simp + +theorem finiteExtensionInfinityPlace_auxiliaryFamily_caseI_of_scaled_preserves + [Fintype K] + (P : FiniteExtensionInfinityPlace K L) + (h k : ℕ) {n : ℕ} + (e : Sum (Fin k) (Fin (k + 1) × Fin h) ≃ Fin n) + (epsilonOrder : Sum (Fin k) (Fin (k + 1) × Fin h) → ℕ) + (hepsilon : ∀ i, epsilonOrder i = (e i : ℕ)) + (epsilon qBound : ℕ) + (D : Derivation (frobeniusSubfield L p) L L) (c : L) + (hScaledLocal : + ∀ r : FiniteExtensionInfinityPlaceLocalRing K L P, + ∃ s : FiniteExtensionInfinityPlaceLocalRing K L P, + (c • D) (finiteExtensionInfinityPlaceLocalizationToField + (K := K) (L := L) P r) = + finiteExtensionInfinityPlaceLocalizationToField + (K := K) (L := L) P s) + (u v : L) + (hrhoNe : (1 - u) / (1 - v) ≠ 0) + (huOrder : + finiteExtensionInfinityPlaceLocalOrderTop (K := K) (L := L) P u = 0) + (hrhoOrder : + finiteExtensionInfinityPlaceLocalOrder (K := K) (L := L) P + ((1 - u) / (1 - v)) < 0) + (hgridRegular : ∀ rs : Fin (k + 1) × Fin h, + (0 : WithTop ℤ) ≤ + finiteExtensionInfinityPlaceLocalOrderTop (K := K) (L := L) P + (u ^ (rs.1 : ℕ) * v ^ (rs.2 : ℕ))) + (hepsilonInjective : Function.Injective epsilonOrder) + (hepsilonMax : ∀ i, epsilonOrder i ≤ epsilon) + (hk : k ≤ epsilon + 1) (hepsilonQ : epsilon + 1 ≤ qBound) : + (((qBound : ℤ) * + finiteExtensionInfinityPlaceLocalOrder (K := K) (L := L) P + ((1 - u) / (1 - v)) : ℤ) : WithTop ℤ) ≤ + n.choose 2 • + finiteExtensionInfinityPlaceLocalOrderTop (K := K) (L := L) P c + + finiteExtensionInfinityPlaceLocalOrderTop (K := K) (L := L) P + (indexedDedekindLocalWronskian D epsilonOrder + (auxiliaryFamily u v h k)).det := by + let _ := finiteExtensionInfinityPlaceLocalAlgebra (K := K) (L := L) P + let := finiteExtensionInfinityPlaceLocalIsFractionRing + (K := K) (L := L) P + let : IsDiscreteValuationRing + (FiniteExtensionInfinityPlaceLocalRing K L P) := + IsLocalization.AtPrime.isDiscreteValuationRing_of_dedekind_domain + (RatFuncInfinityIntegralClosure K L) + (primeOverHeightOne (ratFuncInfinityPlace K) P).ne_bot + (FiniteExtensionInfinityPlaceLocalRing K L P) + let : CharP (FiniteExtensionInfinityPlaceLocalRing K L P) p := ⟨by + intro m + rw [← map_eq_zero_iff + (finiteExtensionInfinityPlaceLocalizationToField + (K := K) (L := L) P) + (by + change Function.Injective + (algebraMap (FiniteExtensionInfinityPlaceLocalRing K L P) L) + exact IsFractionRing.injective + (FiniteExtensionInfinityPlaceLocalRing K L P) L), + map_natCast, CharP.cast_eq_zero_iff L p]⟩ + let : PerfectField + (IsDiscreteValuationRing.maximalIdeal + (FiniteExtensionInfinityPlaceLocalRing K L P)).asIdeal.ResidueField := + finiteExtensionInfinityPlaceLocal_residueField_perfect + (K := K) (L := L) P + obtain ⟨A, hAdet, hdet, hbound⟩ := + exists_frobeniusSubfield_dedekindAuxiliaryFamily_caseI_q_wronskian_bound_of_perfect_residue + (p := p) + (IsDiscreteValuationRing.maximalIdeal + (FiniteExtensionInfinityPlaceLocalRing K L P)) + (c • D) hScaledLocal u v h k epsilonOrder epsilon qBound + hrhoNe huOrder hrhoOrder hgridRegular hepsilonInjective + hepsilonMax hk hepsilonQ + have hchange := indexedDedekindLocalWronskian_det_changeParameter + e epsilonOrder hepsilon (c • D) D c rfl (auxiliaryFamily u v h k) + rw [hchange, finitePlaceOrderTop_mul, finitePlaceOrderTop_pow] at hbound + change (((qBound : ℤ) * + finiteExtensionInfinityPlaceLocalOrder (K := K) (L := L) P + ((1 - u) / (1 - v)) : ℤ) : WithTop ℤ) ≤ + n.choose 2 • + finiteExtensionInfinityPlaceLocalOrderTop (K := K) (L := L) P c + + finiteExtensionInfinityPlaceLocalOrderTop (K := K) (L := L) P + (indexedDedekindLocalWronskian D epsilonOrder + (auxiliaryFamily u v h k)).det at hbound + exact hbound + +theorem finiteExtensionInfinityPlace_canonicalAuxiliary_caseI_of_scaling + [Fintype K] + (P : FiniteExtensionInfinityPlace K L) + (D : Derivation (frobeniusSubfield L p) L L) + (c : L) (hc : c ≠ 0) + (hcOrder : + finitePlaceOrder (primeOverHeightOne (ratFuncInfinityPlace K) P) c = + finiteExtensionCanonicalDifferentDivisor K L + (finiteExtensionFiniteDifferentIdeal_ne_bot K L) (.inr P)) + (hScaledLocal : + ∀ r : FiniteExtensionInfinityPlaceLocalRing K L P, + ∃ s : FiniteExtensionInfinityPlaceLocalRing K L P, + (c • D) (finiteExtensionInfinityPlaceLocalizationToField + (K := K) (L := L) P r) = + finiteExtensionInfinityPlaceLocalizationToField + (K := K) (L := L) P s) + (h k : ℕ) (hn : 0 < h * k + h + k) + (u v : L) (hu : u ≠ 0) (hv : v ≠ 0) + (hu1 : u ≠ 1) (hv1 : v ≠ 1) + (huOrder : finitePlaceOrder + (primeOverHeightOne (ratFuncInfinityPlace K) P) u = 0) + (hvOrder : finitePlaceOrder + (primeOverHeightOne (ratFuncInfinityPlace K) P) v = 0) + (hrhoOrder : finitePlaceOrder + (primeOverHeightOne (ratFuncInfinityPlace K) P) + ((1 - u) / (1 - v)) < 0) + (hW : (indexedDedekindLocalWronskian D + (auxiliaryFamilyDerivativeOrder h k) + (auxiliaryFamily u v h k)).det ≠ 0) : + ((h * k + h + k : ℕ) : ℤ) * + finiteExtensionPrincipalDivisor K L + ((1 - u) / (1 - v)) (.inr P) ≤ + ((h * k + h + k).choose 2 : ℤ) * + finiteExtensionCanonicalDifferentDivisor K L + (finiteExtensionFiniteDifferentIdeal_ne_bot K L) (.inr P) + + finiteExtensionPrincipalDivisor K L + (indexedDedekindLocalWronskian D + (auxiliaryFamilyDerivativeOrder h k) + (auxiliaryFamily u v h k)).det (.inr P) := by + let n := h * k + h + k + have hrho : (1 - u) / (1 - v) ≠ 0 := + div_ne_zero (sub_ne_zero.mpr hu1.symm) (sub_ne_zero.mpr hv1.symm) + have huTop : + finiteExtensionInfinityPlaceLocalOrderTop (K := K) (L := L) P u = 0 := by + rw [finiteExtensionInfinityPlaceLocalOrderTop_eq_globalOrder P u hu] + exact_mod_cast huOrder + have hrhoLocal : + finiteExtensionInfinityPlaceLocalOrder (K := K) (L := L) P + ((1 - u) / (1 - v)) < 0 := by + rw [finiteExtensionInfinityPlaceLocalOrder_eq_globalOrder] + exact hrhoOrder + have hgridRegular : ∀ rs : Fin (k + 1) × Fin h, + (0 : WithTop ℤ) ≤ + finiteExtensionInfinityPlaceLocalOrderTop (K := K) (L := L) P + (u ^ (rs.1 : ℕ) * v ^ (rs.2 : ℕ)) := by + intro rs + have hmonomial : u ^ (rs.1 : ℕ) * v ^ (rs.2 : ℕ) ≠ 0 := + mul_ne_zero (pow_ne_zero _ hu) (pow_ne_zero _ hv) + rw [finiteExtensionInfinityPlaceLocalOrderTop_eq_globalOrder P _ hmonomial] + have hzero := infinityPlaceOrder_gridMonomial_eq_zero + (K := K) (L := L) P u v hu hv huOrder hvOrder + (rs.1 : ℕ) (rs.2 : ℕ) + rw [hzero] + exact le_rfl + have hepsilonMax : ∀ i, auxiliaryFamilyDerivativeOrder h k i ≤ n - 1 := by + intro i + exact auxiliaryFamilyDerivativeOrder_le_pred h k hn i + have hkBound : k ≤ (n - 1) + 1 := by + have hcancel : n - 1 + 1 = n := Nat.sub_add_cancel hn + rw [hcancel] + exact auxiliaryFamily_k_le_card h k + have hepsilonQ : (n - 1) + 1 ≤ n := by + rw [Nat.sub_add_cancel hn] + have hbound := + finiteExtensionInfinityPlace_auxiliaryFamily_caseI_of_scaled_preserves + (K := K) (L := L) (p := p) P h k + (auxiliaryFamilyIndexEquiv h k) + (auxiliaryFamilyDerivativeOrder h k) (fun _ => rfl) + (n - 1) n D c hScaledLocal u v hrho huTop hrhoLocal + hgridRegular (auxiliaryFamilyDerivativeOrder_injective h k) + hepsilonMax hkBound hepsilonQ + rw [finiteExtensionInfinityPlaceLocalOrder_eq_globalOrder, + finiteExtensionInfinityPlaceLocalOrderTop_eq_globalOrder P c hc, + finiteExtensionInfinityPlaceLocalOrderTop_eq_globalOrder P _ hW] at hbound + have hboundInt : + (n : ℤ) * + finitePlaceOrder (primeOverHeightOne (ratFuncInfinityPlace K) P) + ((1 - u) / (1 - v)) ≤ + n.choose 2 • + finitePlaceOrder (primeOverHeightOne (ratFuncInfinityPlace K) P) c + + finitePlaceOrder (primeOverHeightOne (ratFuncInfinityPlace K) P) + (indexedDedekindLocalWronskian D + (auxiliaryFamilyDerivativeOrder h k) + (auxiliaryFamily u v h k)).det := by + exact_mod_cast hbound + rw [hcOrder] at hboundInt + simpa only [n, nsmul_eq_mul, + finiteExtensionPrincipalDivisor_inr_eq_infinityPlaceOrder] using hboundInt + +end InfinityCaseI + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/FiniteExtensionCanonicalDifferentDivisor.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/FiniteExtensionCanonicalDifferentDivisor.lean new file mode 100644 index 0000000000..91ce04cbe8 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/FiniteExtensionCanonicalDifferentDivisor.lean @@ -0,0 +1,345 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionCanonicalWronskian +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveInfinityDifferentDegree +public import Mathlib.RingTheory.RamificationInertia.Basic + +/-! +# The canonical different divisor of a finite function-field extension + +For a finite separable extension `L / K(X)`, this module packages the local +correction divisor of the differential `dX`. Its coefficient is the different +exponent at a finite place and `different exponent - 2 * ramification index` +above infinity. The weighted degree is therefore the total different degree +minus twice the extension degree. +-/ + +@[expose] public section + +open scoped BigOperators nonZeroDivisors Polynomial +open IsDedekindDomain + +namespace BGS.CorvajaZannier + +noncomputable section + +variable (K : Type*) [Field K] [DecidableEq K] [DecidableEq (RatFunc K)] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +local instance (priority := 10) canonicalDifferentPolynomialAlgebra : Algebra K[X] L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K[X] (RatFunc K))) + +local instance canonicalDifferentPolynomialScalarTower : + IsScalarTower K[X] (RatFunc K) L := + ⟨fun r s x => by + simp only [Algebra.smul_def] + rw [map_mul] + change (algebraMap (RatFunc K) L (algebraMap K[X] (RatFunc K) r) * + algebraMap (RatFunc K) L s) * x = + algebraMap K[X] L r * (algebraMap (RatFunc K) L s * x) + rw [show algebraMap K[X] L r = + algebraMap (RatFunc K) L (algebraMap K[X] (RatFunc K) r) by rfl] + ring⟩ + +local instance canonicalDifferentFiniteIntegralClosureModuleFinite : + Module.Finite K[X] (RatFuncFiniteIntegralClosure K L) := + Module.IsNoetherian.finite K[X] (RatFuncFiniteIntegralClosure K L) + +local instance canonicalDifferentFiniteIntegralClosureIsIntegral : + Algebra.IsIntegral K[X] (RatFuncFiniteIntegralClosure K L) := + IsIntegralClosure.isIntegral_algebra K[X] L + +local instance canonicalDifferentPolynomialTorsionFreeTop : + Module.IsTorsionFree K[X] L := + Module.IsTorsionFree.trans_faithfulSMul K[X] (RatFunc K) L + +local instance canonicalDifferentFiniteIntegralClosureIsTorsionFree : + Module.IsTorsionFree K[X] (RatFuncFiniteIntegralClosure K L) := + IsIntegralClosure.isTorsionFree K[X] L + +local instance canonicalDifferentFiniteBaseFaithfulSmulFractionRing : + FaithfulSMul K[X] + (FractionRing (RatFuncFiniteIntegralClosure K L)) := by + rw [faithfulSMul_iff_algebraMap_injective] + intro x y hxy + have hS := IsFractionRing.injective (RatFuncFiniteIntegralClosure K L) + (FractionRing (RatFuncFiniteIntegralClosure K L)) hxy + exact FunctionField.ringOfIntegers.algebraMap_injective K L hS + +local instance canonicalDifferentFiniteFractionRingAlgebra : + Algebra (FractionRing K[X]) + (FractionRing (RatFuncFiniteIntegralClosure K L)) := + FractionRing.liftAlgebra K[X] + (FractionRing (RatFuncFiniteIntegralClosure K L)) + +local instance canonicalDifferentFiniteFractionRingSeparable : + Algebra.IsSeparable (FractionRing K[X]) + (FractionRing (RatFuncFiniteIntegralClosure K L)) := by + refine Algebra.IsSeparable.of_equiv_equiv + (ratFuncFiniteFractionRingEquiv K).symm.toRingEquiv + (ratFuncFiniteIntegralClosureFractionRingEquiv K L).symm.toRingEquiv ?_ + ext z + exact IsFractionRing.algEquiv_commutes + (ratFuncFiniteFractionRingEquiv K).symm + (ratFuncFiniteIntegralClosureFractionRingEquiv K L).symm z + +local instance canonicalDifferentInfinityIntegralClosureModuleFinite : + Module.Finite (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.finite (RatFuncInfinityIntegers K) (RatFunc K) L + (RatFuncInfinityIntegralClosure K L) + +local instance canonicalDifferentInfinityIntegralClosureIsIntegral : + Algebra.IsIntegral (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.isIntegral_algebra (RatFuncInfinityIntegers K) L + +local instance canonicalDifferentInfinityTorsionFreeTop : + Module.IsTorsionFree (RatFuncInfinityIntegers K) L := + Module.IsTorsionFree.trans_faithfulSMul + (RatFuncInfinityIntegers K) (RatFunc K) L + +local instance canonicalDifferentInfinityIntegralClosureIsTorsionFree : + Module.IsTorsionFree (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.isTorsionFree (RatFuncInfinityIntegers K) L + +local instance canonicalDifferentInfinityIntegralClosureIsDedekindDomain : + IsDedekindDomain (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.isDedekindDomain + (RatFuncInfinityIntegers K) (RatFunc K) L + (RatFuncInfinityIntegralClosure K L) + +local instance canonicalDifferentInfinityIntegralClosureIsFractionRing : + IsFractionRing (RatFuncInfinityIntegralClosure K L) L := + IsIntegralClosure.isFractionRing_of_finite_extension + (RatFuncInfinityIntegers K) (RatFunc K) L + (RatFuncInfinityIntegralClosure K L) + +local instance canonicalDifferentInfinityPlaceFintype : + Fintype (FiniteExtensionInfinityPlace K L) := + Set.Finite.fintype + (IsDedekindDomain.primesOver_finite + (ratFuncInfinityPlace K).asIdeal + (RatFuncInfinityIntegralClosure K L)) + +/-- The finite-place part of the different divisor, with integer coefficients. -/ +def finiteExtensionFiniteDifferentDivisor + (hDifferent : differentIdeal K[X] + (RatFuncFiniteIntegralClosure K L) ≠ ⊥) : + FiniteExtensionFinitePlace K L →₀ ℤ := + (differentMultiplicityDivisor K[X] + (RatFuncFiniteIntegralClosure K L) hDifferent).mapRange + (fun n : ℕ => (n : ℤ)) (by simp) + +omit [DecidableEq K] [DecidableEq (RatFunc K)] in +@[simp] theorem finiteExtensionFiniteDifferentDivisor_apply + (hDifferent : differentIdeal K[X] + (RatFuncFiniteIntegralClosure K L) ≠ ⊥) + (q : FiniteExtensionFinitePlace K L) : + finiteExtensionFiniteDifferentDivisor K L hDifferent q = + (multiplicity q.asIdeal + (differentIdeal K[X] (RatFuncFiniteIntegralClosure K L)) : ℤ) := by + simp [finiteExtensionFiniteDifferentDivisor, + differentMultiplicityDivisor_apply] + +/-- Above infinity, the canonical correction is the different exponent minus +twice the ramification index over the parameter `X⁻¹`. -/ +def finiteExtensionInfinityCanonicalDifferentDivisor : + FiniteExtensionInfinityPlace K L →₀ ℤ := + Finsupp.equivFunOnFinite.symm (fun P => + (multiplicity P.1 + (differentIdeal (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L)) : ℤ) - + 2 * (P.1.ramificationIdx (RatFuncInfinityIntegers K) : ℤ)) + +omit [DecidableEq K] in +@[simp] theorem finiteExtensionInfinityCanonicalDifferentDivisor_apply + (P : FiniteExtensionInfinityPlace K L) : + finiteExtensionInfinityCanonicalDifferentDivisor K L P = + (multiplicity P.1 + (differentIdeal (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L)) : ℤ) - + 2 * (P.1.ramificationIdx (RatFuncInfinityIntegers K) : ℤ) := by + simp [finiteExtensionInfinityCanonicalDifferentDivisor] + +/-- The exhaustive canonical divisor attached to `dX`: the finite different +at finite places and `different - 2e` above infinity. -/ +def finiteExtensionCanonicalDifferentDivisor + (hDifferent : differentIdeal K[X] + (RatFuncFiniteIntegralClosure K L) ≠ ⊥) : + FiniteExtensionPlace K L →₀ ℤ := + (finiteExtensionFiniteDifferentDivisor K L hDifferent).sumElim + (finiteExtensionInfinityCanonicalDifferentDivisor K L) + +omit [DecidableEq K] in +@[simp] theorem finiteExtensionCanonicalDifferentDivisor_inl + (hDifferent : differentIdeal K[X] + (RatFuncFiniteIntegralClosure K L) ≠ ⊥) + (q : FiniteExtensionFinitePlace K L) : + finiteExtensionCanonicalDifferentDivisor K L hDifferent (.inl q) = + (multiplicity q.asIdeal + (differentIdeal K[X] (RatFuncFiniteIntegralClosure K L)) : ℤ) := by + simp [finiteExtensionCanonicalDifferentDivisor] + +omit [DecidableEq K] in +@[simp] theorem finiteExtensionCanonicalDifferentDivisor_inr + (hDifferent : differentIdeal K[X] + (RatFuncFiniteIntegralClosure K L) ≠ ⊥) + (P : FiniteExtensionInfinityPlace K L) : + finiteExtensionCanonicalDifferentDivisor K L hDifferent (.inr P) = + (multiplicity P.1 + (differentIdeal (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L)) : ℤ) - + 2 * (P.1.ramificationIdx (RatFuncInfinityIntegers K) : ℤ) := by + simp [finiteExtensionCanonicalDifferentDivisor] + +/-- Residue- and base-place-degree weighted finite different degree. -/ +def finiteExtensionFiniteDifferentDegree + (hDifferent : differentIdeal K[X] + (RatFuncFiniteIntegralClosure K L) ≠ ⊥) : ℕ := + (differentMultiplicityDivisor K[X] + (RatFuncFiniteIntegralClosure K L) hDifferent).sum + (fun q e => e * q.asIdeal.inertiaDeg K[X] * + ratFuncFinitePlaceDegree (HeightOneSpectrum.under K[X] q)) + +omit [DecidableEq K] in +theorem finiteExtensionInfinity_sum_ramification_inertia_eq_finrank : + (∑ P : FiniteExtensionInfinityPlace K L, + P.1.ramificationIdx (RatFuncInfinityIntegers K) * + P.1.inertiaDeg (RatFuncInfinityIntegers K)) = + Module.finrank (RatFunc K) L := by + calc + _ = Module.finrank (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) := + Ideal.sum_ramification_inertia_eq_finrank + (ratFuncInfinityPlace K).asIdeal + (RatFuncInfinityIntegralClosure K L) + _ = Module.finrank (RatFunc K) L := + (IsFractionRing.finrank_eq + (RatFuncInfinityIntegers K) (RatFunc K) + (RatFuncInfinityIntegralClosure K L) L).symm + +omit [DecidableEq K] [DecidableEq (RatFunc K)] in +/-- The finite different is nonzero in the separable extension model. -/ +theorem finiteExtensionFiniteDifferentIdeal_ne_bot : + differentIdeal K[X] (RatFuncFiniteIntegralClosure K L) ≠ ⊥ := by + exact differentIdeal_ne_bot + +/-- Degree formula for the canonical different divisor, given the standard +ramification-inertia sum above infinity. -/ +theorem finiteExtensionCanonicalDifferentDivisor_degree_of_ramification_sum + (hDifferent : differentIdeal K[X] + (RatFuncFiniteIntegralClosure K L) ≠ ⊥) + (hRamification : + (∑ P : FiniteExtensionInfinityPlace K L, + P.1.ramificationIdx (RatFuncInfinityIntegers K) * + P.1.inertiaDeg (RatFuncInfinityIntegers K)) = + Module.finrank (RatFunc K) L) : + finiteExtensionDivisorDegree K L + (finiteExtensionCanonicalDifferentDivisor K L hDifferent) = + (finiteExtensionFiniteDifferentDegree K L hDifferent : ℤ) + + (infinityDifferentDegree K L : ℤ) - + 2 * (Module.finrank (RatFunc K) L : ℤ) := by + rw [finiteExtensionDivisorDegree, finiteExtensionCanonicalDifferentDivisor, + Finsupp.sum_sumElim] + have hfinite : + (finiteExtensionFiniteDifferentDivisor K L hDifferent).sum + (fun q e => e * + (finiteExtensionPlaceDegree K L (.inl q) : ℤ)) = + (finiteExtensionFiniteDifferentDegree K L hDifferent : ℤ) := by + rw [finiteExtensionFiniteDifferentDivisor, + Finsupp.sum_mapRange_index (fun _ => by simp)] + simp only [finiteExtensionPlaceDegree] + rw [finiteExtensionFiniteDifferentDegree, Nat.cast_finsupp_sum] + apply Finsupp.sum_congr + intro q hq + push_cast + ring + have hfinite' : + (finiteExtensionFiniteDifferentDivisor K L hDifferent).sum + ((fun v e => e * + (finiteExtensionPlaceDegree K L v : ℤ)) ∘ Sum.inl) = + (finiteExtensionFiniteDifferentDegree K L hDifferent : ℤ) := by + change + (finiteExtensionFiniteDifferentDivisor K L hDifferent).sum + (fun q e => e * + (finiteExtensionPlaceDegree K L (.inl q) : ℤ)) = _ + exact hfinite + rw [hfinite'] + rw [Finsupp.sum_fintype _ _ (fun _ => by simp)] + simp only [Function.comp_apply, finiteExtensionPlaceDegree, + finiteExtensionInfinityCanonicalDifferentDivisor_apply] + rw [infinityDifferentDegree, Nat.cast_sum] + push_cast + rw [← hRamification] + push_cast + simp_rw [sub_mul] + rw [Finset.sum_sub_distrib] + have hdiff : + (∑ P : FiniteExtensionInfinityPlace K L, + (multiplicity P.1 + (differentIdeal (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L)) : ℤ) * + (P.1.inertiaDeg (RatFuncInfinityIntegers K) : ℤ)) = + ∑ P : FiniteExtensionInfinityPlace K L, + (P.1.inertiaDeg (RatFuncInfinityIntegers K) : ℤ) * + (multiplicity P.1 + (differentIdeal (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L)) : ℤ) := by + apply Finset.sum_congr rfl + intro P hP + ring + rw [hdiff] + simp_rw [mul_assoc] + rw [← Finset.mul_sum] + ring + +/-- The canonical different divisor has weighted degree equal to the finite +different degree plus the infinity different degree minus twice `[L : K(X)]`. -/ +theorem finiteExtensionCanonicalDifferentDivisor_degree : + finiteExtensionDivisorDegree K L + (finiteExtensionCanonicalDifferentDivisor K L + (finiteExtensionFiniteDifferentIdeal_ne_bot K L)) = + (finiteExtensionFiniteDifferentDegree K L + (finiteExtensionFiniteDifferentIdeal_ne_bot K L) : ℤ) + + (infinityDifferentDegree K L : ℤ) - + 2 * (Module.finrank (RatFunc K) L : ℤ) := by + exact finiteExtensionCanonicalDifferentDivisor_degree_of_ramification_sum + K L (finiteExtensionFiniteDifferentIdeal_ne_bot K L) + (finiteExtensionInfinity_sum_ramification_inertia_eq_finrank K L) + +/-- Separate finite-discriminant and complementary infinity bounds combine +into the expected canonical bound `totalDifferent - 2 * [L : K(X)]`. -/ +theorem finiteExtensionCanonicalDifferentDivisor_degree_le_of_bounds + (finiteDiscriminantDegree totalDifferentBudget : ℕ) + (hFinite : finiteExtensionFiniteDifferentDegree K L + (finiteExtensionFiniteDifferentIdeal_ne_bot K L) ≤ + finiteDiscriminantDegree) + (hInfinity : (infinityDifferentDegree K L : ℤ) ≤ + (totalDifferentBudget : ℤ) - (finiteDiscriminantDegree : ℤ)) : + finiteExtensionDivisorDegree K L + (finiteExtensionCanonicalDifferentDivisor K L + (finiteExtensionFiniteDifferentIdeal_ne_bot K L)) ≤ + (totalDifferentBudget : ℤ) - + 2 * (Module.finrank (RatFunc K) L : ℤ) := by + rw [finiteExtensionCanonicalDifferentDivisor_degree] + have hFiniteInt : + (finiteExtensionFiniteDifferentDegree K L + (finiteExtensionFiniteDifferentIdeal_ne_bot K L) : ℤ) ≤ + (finiteDiscriminantDegree : ℤ) := by + exact_mod_cast hFinite + omega + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/FiniteExtensionCanonicalGcdBound.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/FiniteExtensionCanonicalGcdBound.lean new file mode 100644 index 0000000000..3c095bafed --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/FiniteExtensionCanonicalGcdBound.lean @@ -0,0 +1,97 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionOneSubGcdHeight +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.GlobalWronskianSummation +public import Mathlib.Tactic + +/-! +# A gcd bound from the canonical Wronskian inequality + +Deduce the finite-extension gcd estimate from the residue-weighted canonical Wronskian bound. +-/ + +@[expose] public section + +namespace BGS.CorvajaZannier + +noncomputable section + +variable (K : Type*) [Field K] [DecidableEq K] [DecidableEq (RatFunc K)] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +/-- The exact integer-valued canonical Wronskian inequality, together with +the one-minus divisor comparison, implies the numerical bound of Proposition +2 for the exhaustive gcd divisor. -/ +theorem finiteExtensionGcdBound_of_canonicalWronskianInequality + (u v : L) (hu : u ≠ 0) (hv : v ≠ 0) + (huone : u ≠ 1) (hvone : v ≠ 1) + (h k : ℕ) (hn : 0 < h * k + h + k) (chi : ℕ) + (hWronskian : + Int.ofNat (h * k) * + Int.ofNat (finiteExtensionPositiveDegree K L v) - + Int.ofNat k * + (Int.ofNat (finiteExtensionPositiveDegree K L v) + + Int.ofNat (finiteExtensionPositiveDegree K L u)) - + Int.ofNat ((h * k + h + k).choose 2) * Int.ofNat chi ≤ + Int.ofNat (h * k + h + k) * + Int.ofNat (finiteExtensionOutsideHeight K L ((1 - u) / (1 - v)) + (propositionTwoExceptionalPlaces K L u v))) : + (finiteExtensionGcdWeightedDegree K L (1 - u) (1 - v) : ℝ) ≤ + (((h + 2 * k : ℕ) : ℝ) / ((h * k + h + k : ℕ) : ℝ)) * + (finiteExtensionPositiveDegree K L v : ℝ) + + ((k : ℝ) / ((h * k + h + k : ℕ) : ℝ)) * + (finiteExtensionPositiveDegree K L u : ℝ) + + (((((h * k + h + k : ℕ) : ℝ) - 1) / 2) * (chi : ℝ)) := by + let H : ℕ := finiteExtensionOutsideHeight K L ((1 - u) / (1 - v)) + (propositionTwoExceptionalPlaces K L u v) + have hsum := + finiteExtensionOneSubGcd_add_outsideHeight_le_positiveDegree_coordinate + K L u v hu hv huone hvone + have hsumReal : + (finiteExtensionGcdWeightedDegree K L (1 - u) (1 - v) : ℝ) + + (H : ℝ) ≤ (finiteExtensionPositiveDegree K L v : ℝ) := by + dsimp only [H] + exact_mod_cast hsum + have hGHeight : + (finiteExtensionGcdWeightedDegree K L (1 - u) (1 - v) : ℝ) ≤ + (finiteExtensionPositiveDegree K L v : ℝ) - (H : ℝ) := by + linarith + have hWronskianCast : + ((Int.ofNat (h * k) * + Int.ofNat (finiteExtensionPositiveDegree K L v) - + Int.ofNat k * + (Int.ofNat (finiteExtensionPositiveDegree K L v) + + Int.ofNat (finiteExtensionPositiveDegree K L u)) - + Int.ofNat ((h * k + h + k).choose 2) * Int.ofNat chi : ℤ) : ℝ) ≤ + ((Int.ofNat (h * k + h + k) * Int.ofNat H : ℤ) : ℝ) := + Int.cast_le.mpr hWronskian + push_cast at hWronskianCast + have hWronskianReal : + (((h * k : ℕ) : ℝ) * + (finiteExtensionPositiveDegree K L v : ℝ) - + (k : ℝ) * + ((finiteExtensionPositiveDegree K L v : ℝ) + + (finiteExtensionPositiveDegree K L u : ℝ)) - + (((h * k + h + k).choose 2 : ℕ) : ℝ) * (chi : ℝ) ≤ + ((h * k + h + k : ℕ) : ℝ) * (H : ℝ)) := by + simpa only [Int.ofNat_eq_natCast, Int.cast_mul, Int.cast_natCast, + Nat.cast_mul] using hWronskianCast + apply gcdBound_of_globalWronskianInequality + (finiteExtensionPositiveDegree K L v : ℝ) + (finiteExtensionPositiveDegree K L u : ℝ) + (chi : ℝ) + (finiteExtensionGcdWeightedDegree K L (1 - u) (1 - v) : ℝ) + (H : ℝ) h k hn hGHeight + simpa only [Nat.cast_choose_two] using hWronskianReal + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/FiniteExtensionCanonicalGlobalGcdBound.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/FiniteExtensionCanonicalGlobalGcdBound.lean new file mode 100644 index 0000000000..f1731452a8 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/FiniteExtensionCanonicalGlobalGcdBound.lean @@ -0,0 +1,155 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionCanonicalGcdBound +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionCanonicalDifferentDivisor +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionCanonicalPlaceSum +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionExceptionalPlaceBounds +public import Mathlib.Tactic + +/-! +# Canonical placewise bounds imply the exhaustive gcd estimate + +This is the global composition boundary for Corvaja--Zannier Proposition 2. +It fixes the canonical different divisor and the direct zero-and-pole +exceptional set, discharges all support bookkeeping, performs the exhaustive +weighted place sum, and then converts the resulting Wronskian inequality into +the numerical gcd estimate. +-/ + +@[expose] public section + +namespace BGS.CorvajaZannier + +noncomputable section + +open scoped BigOperators + +variable (K : Type*) [Field K] [DecidableEq K] [DecidableEq (RatFunc K)] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +attribute [local instance] Classical.decEq + +/-- The four canonical local estimates, together with the logarithmic Euler +degree bound, imply the exact exhaustive weighted gcd bound of Proposition 2. +-/ +theorem finiteExtensionGcdBound_of_canonicalPlacewiseBounds + (u v W : L) (hu : u ≠ 0) (hv : v ≠ 0) + (huone : u ≠ 1) (hvone : v ≠ 1) (hW : W ≠ 0) + (h k : ℕ) (hn : 0 < h * k + h + k) (chi : ℕ) + (hEuler : + finiteExtensionDivisorDegree K L + (finiteExtensionCanonicalDifferentDivisor K L + (finiteExtensionFiniteDifferentIdeal_ne_bot K L)) + + (∑ P ∈ propositionTwoExceptionalPlaces K L u v, + finiteExtensionPlaceDegree K L P : ℤ) ≤ (chi : ℤ)) + (hCaseI : ∀ P, + P ∉ propositionTwoExceptionalPlaces K L u v → + finiteExtensionPrincipalDivisor K L ((1 - u) / (1 - v)) P < 0 → + ((h * k + h + k : ℕ) : ℤ) * + finiteExtensionPrincipalDivisor K L ((1 - u) / (1 - v)) P ≤ + ((h * k + h + k).choose 2 : ℤ) * + finiteExtensionCanonicalDifferentDivisor K L + (finiteExtensionFiniteDifferentIdeal_ne_bot K L) P + + finiteExtensionPrincipalDivisor K L W P) + (hCaseII : ∀ P, + P ∉ propositionTwoExceptionalPlaces K L u v → + 0 ≤ finiteExtensionPrincipalDivisor K L ((1 - u) / (1 - v)) P → + 0 ≤ ((h * k + h + k).choose 2 : ℤ) * + finiteExtensionCanonicalDifferentDivisor K L + (finiteExtensionFiniteDifferentIdeal_ne_bot K L) P + + finiteExtensionPrincipalDivisor K L W P) + (hCaseIII : ∀ P, + P ∈ propositionTwoExceptionalPlaces K L u v → + 0 < finiteExtensionPrincipalDivisor K L v P → + ((k * (k - 1) / 2 : ℕ) : ℤ) * + finiteExtensionPrincipalDivisor K L u P + + ((h * k : ℕ) : ℤ) * finiteExtensionPrincipalDivisor K L v P + + (k : ℤ) * finiteExtensionPrincipalDivisor K L + ((1 - u) / (1 - v)) P + + finiteExtensionPrincipalDivisor K L + (finiteExtensionAuxiliaryGridProduct L u v h k) P - + ((h * k + h + k).choose 2 : ℤ) ≤ + ((h * k + h + k).choose 2 : ℤ) * + finiteExtensionCanonicalDifferentDivisor K L + (finiteExtensionFiniteDifferentIdeal_ne_bot K L) P + + finiteExtensionPrincipalDivisor K L W P) + (hCaseIV : ∀ P, + P ∈ propositionTwoExceptionalPlaces K L u v → + finiteExtensionPrincipalDivisor K L v P ≤ 0 → + ((k * (k - 1) / 2 : ℕ) : ℤ) * + finiteExtensionPrincipalDivisor K L u P + + (k : ℤ) * finiteExtensionPrincipalDivisor K L + ((1 - u) / (1 - v)) P + + finiteExtensionPrincipalDivisor K L + (finiteExtensionAuxiliaryGridProduct L u v h k) P - + ((h * k + h + k).choose 2 : ℤ) ≤ + ((h * k + h + k).choose 2 : ℤ) * + finiteExtensionCanonicalDifferentDivisor K L + (finiteExtensionFiniteDifferentIdeal_ne_bot K L) P + + finiteExtensionPrincipalDivisor K L W P) : + (finiteExtensionGcdWeightedDegree K L (1 - u) (1 - v) : ℝ) ≤ + ((h + 2 * k : ℕ) : ℝ) / ((h * k + h + k : ℕ) : ℝ) * + (finiteExtensionPositiveDegree K L v : ℝ) + + (k : ℝ) / ((h * k + h + k : ℕ) : ℝ) * + (finiteExtensionPositiveDegree K L u : ℝ) + + ((((h * k + h + k : ℕ) : ℝ) - 1) / 2) * (chi : ℝ) := by + let S := propositionTwoExceptionalPlaces K L u v + let canonical := finiteExtensionCanonicalDifferentDivisor K L + (finiteExtensionFiniteDifferentIdeal_ne_bot K L) + let rho := (1 - u) / (1 - v) + let grid := finiteExtensionAuxiliaryGridProduct L u v h k + have hgrid : grid ≠ 0 := by + dsimp only [grid, finiteExtensionAuxiliaryGridProduct] + exact Finset.prod_ne_zero_iff.mpr fun rs _ => + mul_ne_zero (pow_ne_zero _ hu) (pow_ne_zero _ hv) + have hUOutside : ∀ P, P ∉ S → + finiteExtensionPrincipalDivisor K L u P = 0 := by + intro P hP + exact + finiteExtensionPrincipalDivisor_u_eq_zero_outside_propositionTwoExceptionalPlaces + K L u v P hP + have hGridOutside : ∀ P, P ∉ S → + finiteExtensionPrincipalDivisor K L grid P = 0 := by + intro P hP + exact + finiteExtensionPrincipalDivisor_auxiliaryGridProduct_eq_zero_outside_propositionTwoExceptionalPlaces + K L u v hu hv h k P hP + have hVPositiveSupport : ∀ P, + 0 < finiteExtensionPrincipalDivisor K L v P → P ∈ S := by + intro P hP + exact mem_propositionTwoExceptionalPlaces_of_v_order_pos K L u v P hP + have hRhoSupport : + -((finiteExtensionPositiveDegree K L u : ℤ) + + (finiteExtensionPositiveDegree K L v : ℤ)) ≤ + ∑ P ∈ S, finiteExtensionPrincipalDivisor K L rho P * + (finiteExtensionPlaceDegree K L P : ℤ) := by + have hbound := finiteExtensionOneSubU_div_oneSubV_weightedOrder_lower_bound + K L u v hu hv huone hvone S + dsimp only [rho] + linarith + have hGlobal := + globalWronskianInequality_of_finiteExtensionCanonicalPlacewiseBounds + K L S canonical u v rho grid W h k (h * k + h + k) + ((h * k + h + k).choose 2) chi hu hgrid hW + hUOutside hGridOutside hVPositiveSupport + (by simpa only [S, canonical] using hEuler) + hRhoSupport + (by simpa only [S, canonical, rho] using hCaseI) + (by simpa only [S, canonical, rho] using hCaseII) + (by simpa only [S, canonical, rho, grid] using hCaseIII) + (by simpa only [S, canonical, rho, grid] using hCaseIV) + exact finiteExtensionGcdBound_of_canonicalWronskianInequality + K L u v hu hv huone hvone h k hn chi (by + simpa only [S, rho, add_comm, Int.ofNat_eq_natCast] using hGlobal) + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/FiniteExtensionCanonicalGlobalNormalized.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/FiniteExtensionCanonicalGlobalNormalized.lean new file mode 100644 index 0000000000..930a871085 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/FiniteExtensionCanonicalGlobalNormalized.lean @@ -0,0 +1,202 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionCanonicalAuxiliaryFinitePlaceNormalized +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionCanonicalGlobalGcdBound + +/-! +# Global canonical bound from a normalized derivation + +The finite-place branch is now completely automatic: the different supplies +the canonical clearing scalar, and the four local estimates are selected after +splitting the exhaustive place type. This module leaves only the four +corresponding infinity statements as explicit inputs. +-/ + +@[expose] public section + +namespace BGS.CorvajaZannier + +noncomputable section + +open scoped BigOperators Polynomial + +variable (K : Type*) [Field K] [Fintype K] [DecidableEq K] + [DecidableEq (RatFunc K)] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] +variable {p : ℕ} [Fact p.Prime] [CharP K p] [CharP L p] + +local instance (priority := 10) globalNormalizedPolynomialAlgebra : + Algebra K[X] L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K[X] (RatFunc K))) + +local instance globalNormalizedPolynomialScalarTower : + IsScalarTower K[X] (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + +local instance globalNormalizedFiniteIntegralClosureModuleFinite : + Module.Finite K[X] (RatFuncFiniteIntegralClosure K L) := + Module.IsNoetherian.finite K[X] (RatFuncFiniteIntegralClosure K L) + +local instance globalNormalizedFiniteIntegralClosureIsIntegral : + Algebra.IsIntegral K[X] (RatFuncFiniteIntegralClosure K L) := + IsIntegralClosure.isIntegral_algebra K[X] L + +local instance globalNormalizedPolynomialTorsionFreeTop : + Module.IsTorsionFree K[X] L := + Module.IsTorsionFree.trans_faithfulSMul K[X] (RatFunc K) L + +local instance globalNormalizedFiniteIntegralClosureIsTorsionFree : + Module.IsTorsionFree K[X] (RatFuncFiniteIntegralClosure K L) := + IsIntegralClosure.isTorsionFree K[X] L + +attribute [local instance] Classical.decEq + +/-- A normalized Frobenius-constant derivation and the four infinity cases +imply the exact exhaustive Proposition 2 gcd estimate. -/ +theorem finiteExtensionGcdBound_of_normalizedCanonicalInfinityPlacewiseBounds + (D : Derivation (frobeniusSubfield L p) L L) + (hDX : D (algebraMap (RatFunc K) L RatFunc.X) = 1) + (u v : L) (hu : u ≠ 0) (hv : v ≠ 0) + (huone : u ≠ 1) (hvone : v ≠ 1) + (h k : ℕ) (hn : 0 < h * k + h + k) (chi : ℕ) + (hWronskian : + (indexedDedekindLocalWronskian D + (auxiliaryFamilyDerivativeOrder h k) + (auxiliaryFamily u v h k)).det ≠ 0) + (hEuler : + finiteExtensionDivisorDegree K L + (finiteExtensionCanonicalDifferentDivisor K L + (finiteExtensionFiniteDifferentIdeal_ne_bot K L)) + + (∑ P ∈ propositionTwoExceptionalPlaces K L u v, + finiteExtensionPlaceDegree K L P : ℤ) ≤ (chi : ℤ)) + (hInfinityCaseI : ∀ P : FiniteExtensionInfinityPlace K L, + (Sum.inr P : FiniteExtensionPlace K L) ∉ + propositionTwoExceptionalPlaces K L u v → + finiteExtensionPrincipalDivisor K L ((1 - u) / (1 - v)) (.inr P) < 0 → + ((h * k + h + k : ℕ) : ℤ) * + finiteExtensionPrincipalDivisor K L ((1 - u) / (1 - v)) (.inr P) ≤ + ((h * k + h + k).choose 2 : ℤ) * + finiteExtensionCanonicalDifferentDivisor K L + (finiteExtensionFiniteDifferentIdeal_ne_bot K L) (.inr P) + + finiteExtensionPrincipalDivisor K L + (indexedDedekindLocalWronskian D + (auxiliaryFamilyDerivativeOrder h k) + (auxiliaryFamily u v h k)).det (.inr P)) + (hInfinityCaseII : ∀ P : FiniteExtensionInfinityPlace K L, + (Sum.inr P : FiniteExtensionPlace K L) ∉ + propositionTwoExceptionalPlaces K L u v → + 0 ≤ finiteExtensionPrincipalDivisor K L ((1 - u) / (1 - v)) (.inr P) → + 0 ≤ ((h * k + h + k).choose 2 : ℤ) * + finiteExtensionCanonicalDifferentDivisor K L + (finiteExtensionFiniteDifferentIdeal_ne_bot K L) (.inr P) + + finiteExtensionPrincipalDivisor K L + (indexedDedekindLocalWronskian D + (auxiliaryFamilyDerivativeOrder h k) + (auxiliaryFamily u v h k)).det (.inr P)) + (hInfinityCaseIII : ∀ P : FiniteExtensionInfinityPlace K L, + (Sum.inr P : FiniteExtensionPlace K L) ∈ + propositionTwoExceptionalPlaces K L u v → + 0 < finiteExtensionPrincipalDivisor K L v (.inr P) → + ((k * (k - 1) / 2 : ℕ) : ℤ) * + finiteExtensionPrincipalDivisor K L u (.inr P) + + ((h * k : ℕ) : ℤ) * finiteExtensionPrincipalDivisor K L v (.inr P) + + (k : ℤ) * finiteExtensionPrincipalDivisor K L + ((1 - u) / (1 - v)) (.inr P) + + finiteExtensionPrincipalDivisor K L + (finiteExtensionAuxiliaryGridProduct L u v h k) (.inr P) - + ((h * k + h + k).choose 2 : ℤ) ≤ + ((h * k + h + k).choose 2 : ℤ) * + finiteExtensionCanonicalDifferentDivisor K L + (finiteExtensionFiniteDifferentIdeal_ne_bot K L) (.inr P) + + finiteExtensionPrincipalDivisor K L + (indexedDedekindLocalWronskian D + (auxiliaryFamilyDerivativeOrder h k) + (auxiliaryFamily u v h k)).det (.inr P)) + (hInfinityCaseIV : ∀ P : FiniteExtensionInfinityPlace K L, + (Sum.inr P : FiniteExtensionPlace K L) ∈ + propositionTwoExceptionalPlaces K L u v → + finiteExtensionPrincipalDivisor K L v (.inr P) ≤ 0 → + ((k * (k - 1) / 2 : ℕ) : ℤ) * + finiteExtensionPrincipalDivisor K L u (.inr P) + + (k : ℤ) * finiteExtensionPrincipalDivisor K L + ((1 - u) / (1 - v)) (.inr P) + + finiteExtensionPrincipalDivisor K L + (finiteExtensionAuxiliaryGridProduct L u v h k) (.inr P) - + ((h * k + h + k).choose 2 : ℤ) ≤ + ((h * k + h + k).choose 2 : ℤ) * + finiteExtensionCanonicalDifferentDivisor K L + (finiteExtensionFiniteDifferentIdeal_ne_bot K L) (.inr P) + + finiteExtensionPrincipalDivisor K L + (indexedDedekindLocalWronskian D + (auxiliaryFamilyDerivativeOrder h k) + (auxiliaryFamily u v h k)).det (.inr P)) : + (finiteExtensionGcdWeightedDegree K L (1 - u) (1 - v) : ℝ) ≤ + ((h + 2 * k : ℕ) : ℝ) / ((h * k + h + k : ℕ) : ℝ) * + (finiteExtensionPositiveDegree K L v : ℝ) + + (k : ℝ) / ((h * k + h + k : ℕ) : ℝ) * + (finiteExtensionPositiveDegree K L u : ℝ) + + ((((h * k + h + k : ℕ) : ℝ) - 1) / 2) * (chi : ℝ) := by + let W := (indexedDedekindLocalWronskian D + (auxiliaryFamilyDerivativeOrder h k) + (auxiliaryFamily u v h k)).det + apply finiteExtensionGcdBound_of_canonicalPlacewiseBounds + K L u v W hu hv huone hvone hWronskian h k hn chi hEuler + · intro P hP hrho + cases P with + | inl q => + have huOrder : finitePlaceOrder q u = 0 := by + simpa only [finiteExtensionPrincipalDivisor_inl_eq_finitePlaceOrder] using + finiteExtensionPrincipalDivisor_u_eq_zero_outside_propositionTwoExceptionalPlaces + K L u v (.inl q) hP + have hvOrder : finitePlaceOrder q v = 0 := by + simpa only [finiteExtensionPrincipalDivisor_inl_eq_finitePlaceOrder] using + finiteExtensionPrincipalDivisor_v_eq_zero_outside_propositionTwoExceptionalPlaces + K L u v (.inl q) hP + exact finiteExtensionFinitePlace_canonicalAuxiliary_caseI_of_normalized + K L q D hDX h k hn u v hu hv huone hvone huOrder hvOrder + (by simpa only [finiteExtensionPrincipalDivisor_inl_eq_finitePlaceOrder] + using hrho) + hWronskian + | inr P => exact hInfinityCaseI P hP hrho + · intro P hP hrho + cases P with + | inl q => + have huOrder : finitePlaceOrder q u = 0 := by + simpa only [finiteExtensionPrincipalDivisor_inl_eq_finitePlaceOrder] using + finiteExtensionPrincipalDivisor_u_eq_zero_outside_propositionTwoExceptionalPlaces + K L u v (.inl q) hP + have hvOrder : finitePlaceOrder q v = 0 := by + simpa only [finiteExtensionPrincipalDivisor_inl_eq_finitePlaceOrder] using + finiteExtensionPrincipalDivisor_v_eq_zero_outside_propositionTwoExceptionalPlaces + K L u v (.inl q) hP + exact finiteExtensionFinitePlace_canonicalAuxiliary_caseII_of_normalized + K L q D hDX h k u v hu hv huone hvone huOrder.ge hvOrder.ge + (by simpa only [finiteExtensionPrincipalDivisor_inl_eq_finitePlaceOrder] + using hrho) + hWronskian + | inr P => exact hInfinityCaseII P hP hrho + · intro P hP hvP + cases P with + | inl q => + exact finiteExtensionFinitePlace_canonicalAuxiliary_caseIII_of_normalized + K L q D hDX h k u v hu hv huone hvone hWronskian + | inr P => exact hInfinityCaseIII P hP hvP + · intro P hP hvP + cases P with + | inl q => + exact finiteExtensionFinitePlace_canonicalAuxiliary_caseIV_of_normalized + K L q D hDX h k u v hu hv huone hvone hWronskian + | inr P => exact hInfinityCaseIV P hP hvP + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/FiniteExtensionCanonicalGlobalNormalizedAutomatic.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/FiniteExtensionCanonicalGlobalNormalizedAutomatic.lean new file mode 100644 index 0000000000..ac8b3275c7 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/FiniteExtensionCanonicalGlobalNormalizedAutomatic.lean @@ -0,0 +1,647 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionCanonicalAuxiliaryInfinityPlace +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionCanonicalGlobalNormalized +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.DedekindLocalDerivationExtension +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PerfectConstants +public import Mathlib.Tactic + +/-! +# Normalized global derivations for the canonical argument + +Construct the rational-function derivations and reciprocal-chart estimates used to normalize the +global canonical Wronskian argument. +-/ + +@[expose] public section + +namespace BGS.CorvajaZannier + +noncomputable section + + +open scoped Polynomial nonZeroDivisors +open Multiplicative WithZero IsDedekindDomain + +variable (K : Type*) [Field K] [DecidableEq K] + [DecidableEq (RatFunc K)] + +local instance automaticInfinityConstantAlgebra : + Algebra K (RatFuncInfinityIntegers K) := + (ratFuncInfinityConstantRingHom K).toAlgebra + +local instance automaticInfinityConstantTower : + IsScalarTower K (RatFuncInfinityIntegers K) (RatFunc K) := + IsScalarTower.of_algebraMap_eq' rfl + +noncomputable def probeRatFuncDerivation : + Derivation K (RatFunc K) (RatFunc K) := by + letI : IsScalarTower K K[X] (RatFunc K) := + IsScalarTower.of_algebraMap_eq' rfl + letI : Algebra.FormallyEtale K[X] (RatFunc K) := + Algebra.FormallyEtale.of_isLocalization K[X]⁰ + exact formallyEtaleDerivationExtension (Polynomial.mkDerivation K 1) + +@[simp] theorem probeRatFuncDerivation_algebraMap (f : K[X]) : + probeRatFuncDerivation K (algebraMap K[X] (RatFunc K) f) = + algebraMap K[X] (RatFunc K) f.derivative := by + let : IsScalarTower K K[X] (RatFunc K) := + IsScalarTower.of_algebraMap_eq' rfl + let : Algebra.FormallyEtale K[X] (RatFunc K) := + Algebra.FormallyEtale.of_isLocalization K[X]⁰ + simpa only [probeRatFuncDerivation, + Polynomial.mkDerivation_apply, smul_eq_mul, mul_one] using + formallyEtaleDerivationExtension_algebraMap + (T := RatFunc K) (Polynomial.mkDerivation K 1) f + +example : probeRatFuncDerivation K RatFunc.X = 1 := by + rw [← RatFunc.algebraMap_X] + rw [probeRatFuncDerivation_algebraMap] + simp + +theorem probeRatFuncDerivation_eq (x : RatFunc K) : + probeRatFuncDerivation K x = + (algebraMap K[X] (RatFunc K) x.denom)⁻¹ ^ 2 * + algebraMap K[X] (RatFunc K) + (x.denom * x.num.derivative - x.num * x.denom.derivative) := by + conv_lhs => rw [← RatFunc.num_div_denom x] + rw [Derivation.leibniz_div, + probeRatFuncDerivation_algebraMap, + probeRatFuncDerivation_algebraMap] + rw [map_sub, map_mul, map_mul] + simp only [Algebra.smul_def, Algebra.algebraMap_self_apply] + +omit [DecidableEq (RatFunc K)] in +private theorem natDegree_derivativeNumerator_le + (p q : K[X]) (hp : p ≠ 0) (hq : q ≠ 0) + (hN : q * p.derivative - p * q.derivative ≠ 0) : + (q * p.derivative - p * q.derivative).natDegree ≤ + p.natDegree + q.natDegree - 1 := by + have hsum : 0 < p.natDegree + q.natDegree := by + by_contra h + have hpdeg : p.natDegree = 0 := by omega + have hqdeg : q.natDegree = 0 := by omega + have hpder : p.derivative = 0 := by + rw [Polynomial.eq_C_of_natDegree_eq_zero hpdeg, + Polynomial.derivative_C] + have hqder : q.derivative = 0 := by + rw [Polynomial.eq_C_of_natDegree_eq_zero hqdeg, + Polynomial.derivative_C] + simp [hpder, hqder] at hN + have hleft : (q * p.derivative).natDegree ≤ + p.natDegree + q.natDegree - 1 := by + by_cases hpder : p.derivative = 0 + · rw [hpder, mul_zero, Polynomial.natDegree_zero] + omega + · have hpdeg : p.natDegree ≠ 0 := by + intro hzero + apply hpder + rw [Polynomial.eq_C_of_natDegree_eq_zero hzero, + Polynomial.derivative_C] + rw [Polynomial.natDegree_mul hq hpder] + have hder := Polynomial.natDegree_derivative_le p + omega + have hright : (p * q.derivative).natDegree ≤ + p.natDegree + q.natDegree - 1 := by + by_cases hqder : q.derivative = 0 + · rw [hqder, mul_zero, Polynomial.natDegree_zero] + omega + · have hqdeg : q.natDegree ≠ 0 := by + intro hzero + apply hqder + rw [Polynomial.eq_C_of_natDegree_eq_zero hzero, + Polynomial.derivative_C] + rw [Polynomial.natDegree_mul hp hqder] + have hder := Polynomial.natDegree_derivative_le q + omega + exact (Polynomial.natDegree_sub_le _ _).trans (max_le hleft hright) + +theorem probeRatFuncDerivation_intDegree_le_sub_one + (x : RatFunc K) (hx : x ≠ 0) + (hDx : probeRatFuncDerivation K x ≠ 0) : + (probeRatFuncDerivation K x).intDegree ≤ x.intDegree - 1 := by + let N := x.denom * x.num.derivative - x.num * x.denom.derivative + have hden : algebraMap K[X] (RatFunc K) x.denom ≠ 0 := + RatFunc.algebraMap_ne_zero x.denom_ne_zero + have hN : N ≠ 0 := by + intro hzero + apply hDx + rw [probeRatFuncDerivation_eq] + change _ * algebraMap K[X] (RatFunc K) N = 0 + rw [hzero, map_zero, mul_zero] + have hrepr : probeRatFuncDerivation K x = + algebraMap K[X] (RatFunc K) N / + algebraMap K[X] (RatFunc K) (x.denom ^ 2) := by + rw [probeRatFuncDerivation_eq, map_pow] + change _ * algebraMap K[X] (RatFunc K) N = _ + field_simp + rw [hrepr, RatFunc.intDegree_div + (RatFunc.algebraMap_ne_zero hN) + (RatFunc.algebraMap_ne_zero (pow_ne_zero 2 x.denom_ne_zero)), + RatFunc.intDegree_polynomial, RatFunc.intDegree_polynomial, + Polynomial.natDegree_pow, RatFunc.intDegree] + have hdegree := natDegree_derivativeNumerator_le + K x.num x.denom (RatFunc.num_ne_zero hx) x.denom_ne_zero hN + have hsum : 0 < x.num.natDegree + x.denom.natDegree := by + by_contra h + have hnumDegree : x.num.natDegree = 0 := by omega + have hdenDegree : x.denom.natDegree = 0 := by omega + apply hN + change x.denom * x.num.derivative - + x.num * x.denom.derivative = 0 + rw [Polynomial.eq_C_of_natDegree_eq_zero hnumDegree, + Polynomial.eq_C_of_natDegree_eq_zero hdenDegree, + Polynomial.derivative_C, Polynomial.derivative_C] + simp + have hdegreeInt : + ((x.denom * x.num.derivative - + x.num * x.denom.derivative).natDegree : ℤ) ≤ + ((x.num.natDegree + x.denom.natDegree - 1 : ℕ) : ℤ) := by + exact_mod_cast hdegree + rw [Nat.cast_sub (by omega : 1 ≤ + x.num.natDegree + x.denom.natDegree)] at hdegreeInt + simp only [N] at hdegree ⊢ + omega + +noncomputable def probeRatFuncReciprocalDerivation : + Derivation K (RatFunc K) (RatFunc K) := + (-RatFunc.X ^ 2 : RatFunc K) • probeRatFuncDerivation K + +@[simp] theorem probeRatFuncReciprocalDerivation_apply (x : RatFunc K) : + probeRatFuncReciprocalDerivation K x = + -RatFunc.X ^ 2 * probeRatFuncDerivation K x := by + simp only [probeRatFuncReciprocalDerivation, Derivation.smul_apply, + Algebra.smul_def, Algebra.algebraMap_self_apply] + +theorem probeRatFuncReciprocalDerivation_intDegree_nonpositive_of_negative + (x : RatFunc K) (hxDegree : x.intDegree < 0) : + (probeRatFuncReciprocalDerivation K x).intDegree ≤ 0 := by + by_cases hEx : probeRatFuncReciprocalDerivation K x = 0 + · simp [hEx] + have hx : x ≠ 0 := by + intro hzero + apply hEx + simp [hzero] + have hDx : probeRatFuncDerivation K x ≠ 0 := by + intro hzero + apply hEx + rw [probeRatFuncReciprocalDerivation_apply, hzero, mul_zero] + rw [probeRatFuncReciprocalDerivation_apply, + RatFunc.intDegree_mul + (neg_ne_zero.mpr (pow_ne_zero 2 RatFunc.X_ne_zero)) hDx, + RatFunc.intDegree_neg, + show (RatFunc.X ^ 2 : RatFunc K).intDegree = 2 by + rw [pow_two, + RatFunc.intDegree_mul RatFunc.X_ne_zero RatFunc.X_ne_zero, + RatFunc.intDegree_X] + norm_num] + have hder := probeRatFuncDerivation_intDegree_le_sub_one K x hx hDx + omega + +theorem probeRatFuncReciprocalDerivation_mem_infinityIntegers + (r : RatFuncInfinityIntegers K) : + probeRatFuncReciprocalDerivation K (r : RatFunc K) ∈ + RatFuncInfinityIntegers K := by + obtain ⟨c, hc⟩ := + ratFuncInfinityIntegers_exists_constant_mod_maximalIdeal K r + let y : RatFuncInfinityIntegers K := + r - algebraMap K (RatFuncInfinityIntegers K) c + have hyMax : y ∈ (ratFuncInfinityPlace K).asIdeal := by + simpa only [y] using hc + have hEr : probeRatFuncReciprocalDerivation K (r : RatFunc K) = + probeRatFuncReciprocalDerivation K (y : RatFunc K) := by + rw [show (y : RatFunc K) = (r : RatFunc K) - RatFunc.C c by rfl] + rw [map_sub] + have hconst : probeRatFuncReciprocalDerivation K (RatFunc.C c) = 0 := by + exact (probeRatFuncReciprocalDerivation K).map_algebraMap c + rw [hconst, sub_zero] + rw [hEr] + by_cases hy : (y : RatFunc K) = 0 + · simp [hy] + have hyDegree : (y : RatFunc K).intDegree < 0 := by + change y ∈ IsLocalRing.maximalIdeal + (RatFuncInfinityIntegers K) at hyMax + rw [IsLocalRing.mem_maximalIdeal, mem_nonunits_iff, + Valuation.Integer.not_isUnit_iff_valuation_lt_one] at hyMax + change RatFunc.inftyValuation K (y : RatFunc K) < 1 at hyMax + rw [RatFunc.inftyValuation_apply, + RatFunc.inftyValuation_of_nonzero K hy, + ← exp_zero, exp_lt_exp] at hyMax + exact hyMax + by_cases hEy : probeRatFuncReciprocalDerivation K (y : RatFunc K) = 0 + · simp [hEy] + change RatFunc.inftyValuation K + (probeRatFuncReciprocalDerivation K (y : RatFunc K)) ≤ 1 + rw [RatFunc.inftyValuation_apply, + RatFunc.inftyValuation_of_nonzero K hEy, + ← exp_zero, exp_le_exp] + exact probeRatFuncReciprocalDerivation_intDegree_nonpositive_of_negative + K (y : RatFunc K) hyDegree + +noncomputable def probeInfinityRingDerivation : + Derivation K (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegers K) where + toLinearMap := + { toFun := fun r => + ⟨probeRatFuncReciprocalDerivation K (r : RatFunc K), + probeRatFuncReciprocalDerivation_mem_infinityIntegers K r⟩ + map_add' := by + intro x y + apply Subtype.ext + exact map_add (probeRatFuncReciprocalDerivation K) + (x : RatFunc K) (y : RatFunc K) + map_smul' := by + intro c x + apply Subtype.ext + change probeRatFuncReciprocalDerivation K + (algebraMap K (RatFunc K) c * (x : RatFunc K)) = + algebraMap K (RatFunc K) c * + probeRatFuncReciprocalDerivation K (x : RatFunc K) + simpa only [Algebra.smul_def, Algebra.algebraMap_self_apply] using + (probeRatFuncReciprocalDerivation K).map_smul c (x : RatFunc K) } + map_one_eq_zero' := by + apply Subtype.ext + exact (probeRatFuncReciprocalDerivation K).map_one_eq_zero + leibniz' := by + intro x y + apply Subtype.ext + exact (probeRatFuncReciprocalDerivation K).leibniz + (x : RatFunc K) (y : RatFunc K) + +@[simp] theorem probeInfinityRingDerivation_coe + (r : RatFuncInfinityIntegers K) : + ((probeInfinityRingDerivation K r : RatFuncInfinityIntegers K) : + RatFunc K) = probeRatFuncReciprocalDerivation K (r : RatFunc K) := + rfl + +section AmbientExtension + +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] +variable {p : ℕ} [Fact p.Prime] [CharP K p] [CharP L p] + [PerfectField K] + +local instance probeConstantAlgebraL : Algebra K L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K (RatFunc K))) + +local instance probeConstantRatFuncTower : + IsScalarTower K (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + +local instance probeInfinityConstantLTower : + IsScalarTower K (RatFuncInfinityIntegers K) L := + IsScalarTower.of_algebraMap_eq' + (R := K) (S := RatFuncInfinityIntegers K) (A := L) rfl + +local instance automaticInfinityClosureConstantAlgebra : + Algebra K (RatFuncInfinityIntegralClosure K L) := + RingHom.toAlgebra + ((algebraMap (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L)).comp + (algebraMap K (RatFuncInfinityIntegers K))) + +local instance probeInfinityClosureConstantBaseTower : + IsScalarTower K (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) := + IsScalarTower.of_algebraMap_eq' + (R := K) (S := RatFuncInfinityIntegers K) + (A := RatFuncInfinityIntegralClosure K L) rfl + +local instance probeInfinityClosureToFieldTower : + IsScalarTower (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) L := + IsScalarTower.of_algebraMap_eq' + (R := RatFuncInfinityIntegers K) + (S := RatFuncInfinityIntegralClosure K L) (A := L) rfl + +local instance probeInfinityClosureConstantToFieldTower : + IsScalarTower K (RatFuncInfinityIntegralClosure K L) L := + IsScalarTower.of_algebraMap_eq' + (R := K) (S := RatFuncInfinityIntegralClosure K L) (A := L) rfl + +local instance probeInfinityClosureModuleFinite : + Module.Finite (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.finite (RatFuncInfinityIntegers K) (RatFunc K) L + (RatFuncInfinityIntegralClosure K L) + +local instance probeInfinityClosureIsIntegral : + Algebra.IsIntegral (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.isIntegral_algebra (RatFuncInfinityIntegers K) L + +local instance probeInfinityBaseTorsionFreeTop : + Module.IsTorsionFree (RatFuncInfinityIntegers K) L := + Module.IsTorsionFree.trans_faithfulSMul + (RatFuncInfinityIntegers K) (RatFunc K) L + +local instance probeInfinityClosureIsTorsionFree : + Module.IsTorsionFree (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.isTorsionFree (RatFuncInfinityIntegers K) L + +local instance probeInfinityClosureIsDedekindDomain : + IsDedekindDomain (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.isDedekindDomain + (RatFuncInfinityIntegers K) (RatFunc K) L + (RatFuncInfinityIntegralClosure K L) + +local instance probeInfinityClosureIsFractionRing : + IsFractionRing (RatFuncInfinityIntegralClosure K L) L := + IsIntegralClosure.isFractionRing_of_finite_extension + (RatFuncInfinityIntegers K) (RatFunc K) L + (RatFuncInfinityIntegralClosure K L) + +local instance (priority := 10) probePolynomialLAlgebra : Algebra K[X] L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K[X] (RatFunc K))) + +local instance probePolynomialRatFuncLTower : + IsScalarTower K[X] (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' + (R := K[X]) (S := RatFunc K) (A := L) rfl + +local instance probePolynomialConstantLTower : + IsScalarTower K K[X] L := + IsScalarTower.of_algebraMap_eq' rfl + +local instance probeFrobeniusConstantAlgebra : + Algebra K (frobeniusSubfield L p) := + (perfectConstantsToFrobeniusSubfield + (K := K) (L := L) (p := p)).toAlgebra + +local instance probeFrobeniusConstantTower : + IsScalarTower K (frobeniusSubfield L p) L := + IsScalarTower.of_algebraMap_eq' rfl + +omit [FiniteDimensional (RatFunc K) L] [Algebra.IsSeparable (RatFunc K) L] in +theorem probe_normalizedDerivation_comp_ratFunc + (D : Derivation (frobeniusSubfield L p) L L) + (hDX : D (algebraMap (RatFunc K) L RatFunc.X) = 1) : + (D.restrictScalars K).compAlgebraMap (RatFunc K) = + (Algebra.linearMap (RatFunc K) L).compDer + (probeRatFuncDerivation K) := by + let : IsScalarTower K K[X] (RatFunc K) := + IsScalarTower.of_algebraMap_eq' + (R := K) (S := K[X]) (A := RatFunc K) rfl + let : Algebra.FormallyEtale K[X] (RatFunc K) := + Algebra.FormallyEtale.of_isLocalization K[X]⁰ + apply derivation_ext_of_formallyUnramified (S := K[X]) + intro f + change (D.restrictScalars K) + (algebraMap (RatFunc K) L + (algebraMap K[X] (RatFunc K) f)) = + algebraMap (RatFunc K) L + (probeRatFuncDerivation K + (algebraMap K[X] (RatFunc K) f)) + rw [show algebraMap (RatFunc K) L + (algebraMap K[X] (RatFunc K) f) = algebraMap K[X] L f by + rw [IsScalarTower.algebraMap_apply K[X] (RatFunc K) L]] + have hpoly : (D.restrictScalars K).compAlgebraMap K[X] = + (Algebra.linearMap K[X] L).compDer + (Polynomial.mkDerivation K 1) := by + apply Polynomial.derivation_ext + calc + ((D.restrictScalars K).compAlgebraMap K[X]) Polynomial.X = + D (algebraMap (RatFunc K) L RatFunc.X) := by + change D (algebraMap K[X] L Polynomial.X) = _ + rw [IsScalarTower.algebraMap_apply K[X] (RatFunc K) L, + RatFunc.algebraMap_X] + _ = 1 := hDX + _ = ((Algebra.linearMap K[X] L).compDer + (Polynomial.mkDerivation K 1)) Polynomial.X := by simp + have hpolyf := Derivation.congr_fun hpoly f + change (D.restrictScalars K) (algebraMap K[X] L f) = + algebraMap K[X] L ((Polynomial.mkDerivation K 1) f) at hpolyf + rw [hpolyf] + change algebraMap K[X] L ((Polynomial.mkDerivation K 1) f) = _ + rw [show (probeRatFuncDerivation K) + (algebraMap K[X] (RatFunc K) f) = + algebraMap K[X] (RatFunc K) ((Polynomial.mkDerivation K 1) f) by + simpa only [Polynomial.mkDerivation_apply, smul_eq_mul, mul_one] using + probeRatFuncDerivation_algebraMap K f] + rw [IsScalarTower.algebraMap_apply K[X] (RatFunc K) L] + +noncomputable def probeAmbientReciprocalDerivation + (D : Derivation (frobeniusSubfield L p) L L) : + Derivation K L L := + (-(algebraMap (RatFunc K) L RatFunc.X) ^ 2) • + D.restrictScalars K + +omit [FiniteDimensional (RatFunc K) L] [Algebra.IsSeparable (RatFunc K) L] in +theorem probeAmbientReciprocalDerivation_extends + (D : Derivation (frobeniusSubfield L p) L L) + (hDX : D (algebraMap (RatFunc K) L RatFunc.X) = 1) + (r : RatFuncInfinityIntegers K) : + probeAmbientReciprocalDerivation K L D + (algebraMap (RatFuncInfinityIntegers K) L r) = + algebraMap (RatFuncInfinityIntegers K) L + (probeInfinityRingDerivation K r) := by + have hcomp := Derivation.congr_fun + (probe_normalizedDerivation_comp_ratFunc K L D hDX) + (r : RatFunc K) + change (D.restrictScalars K) + (algebraMap (RatFunc K) L (r : RatFunc K)) = + algebraMap (RatFunc K) L + (probeRatFuncDerivation K (r : RatFunc K)) at hcomp + rw [probeAmbientReciprocalDerivation, + Derivation.smul_apply, Algebra.smul_def, + Algebra.algebraMap_self_apply] + change -(algebraMap (RatFunc K) L RatFunc.X) ^ 2 * + (D.restrictScalars K) + (algebraMap (RatFunc K) L (r : RatFunc K)) = + algebraMap (RatFunc K) L + ((probeInfinityRingDerivation K r : + RatFuncInfinityIntegers K) : RatFunc K) + rw [hcomp] + change -(algebraMap (RatFunc K) L RatFunc.X) ^ 2 * + algebraMap (RatFunc K) L + (probeRatFuncDerivation K (r : RatFunc K)) = + algebraMap (RatFunc K) L + (probeRatFuncReciprocalDerivation K (r : RatFunc K)) + rw [probeRatFuncReciprocalDerivation_apply, map_mul, map_neg, map_pow] + +omit [DecidableEq K] [FiniteDimensional (RatFunc K) L] [Algebra.IsSeparable (RatFunc K) L] in +theorem probeAmbientReciprocalDerivation_changeParameter + (D : Derivation (frobeniusSubfield L p) L L) : + D.restrictScalars K = + (-(algebraMap (RatFuncInfinityIntegers K) L + (ratFuncInfinityUniformizer K)) ^ 2) • + probeAmbientReciprocalDerivation K L D := by + let sL : L := algebraMap (RatFuncInfinityIntegers K) L + (ratFuncInfinityUniformizer K) + let xL : L := algebraMap (RatFunc K) L RatFunc.X + have hsx : sL * xL = 1 := by + rw [show sL = algebraMap (RatFunc K) L (1 / RatFunc.X) by rfl, + ← map_mul, div_mul_cancel₀ _ RatFunc.X_ne_zero, map_one] + have hscalar : -(sL ^ 2) * -(xL ^ 2) = 1 := by + calc + -(sL ^ 2) * -(xL ^ 2) = (sL * xL) ^ 2 := by ring + _ = 1 := by rw [hsx]; simp + apply Derivation.ext + intro z + simp only [probeAmbientReciprocalDerivation, + Derivation.smul_apply, Algebra.smul_def, + Algebra.algebraMap_self_apply] + change (D.restrictScalars K) z = + -(sL ^ 2) * (-(xL ^ 2) * (D.restrictScalars K) z) + rw [← mul_assoc, hscalar, one_mul] + +theorem probe_exists_normalizedInfinityScaling + (D : Derivation (frobeniusSubfield L p) L L) + (hDX : D (algebraMap (RatFunc K) L RatFunc.X) = 1) + (P : FiniteExtensionInfinityPlace K L) : + ∃ c : L, c ≠ 0 ∧ + finitePlaceOrder (primeOverHeightOne (ratFuncInfinityPlace K) P) c = + finiteExtensionCanonicalDifferentDivisor K L + (finiteExtensionFiniteDifferentIdeal_ne_bot K L) (.inr P) ∧ + ∀ r : FiniteExtensionInfinityPlaceLocalRing K L P, + ∃ s : FiniteExtensionInfinityPlaceLocalRing K L P, + (c • D) (finiteExtensionInfinityPlaceLocalizationToField + (K := K) (L := L) P r) = + finiteExtensionInfinityPlaceLocalizationToField + (K := K) (L := L) P s := by + let : IsScalarTower K (RatFuncInfinityIntegers K) L := + probeInfinityConstantLTower K L + exact exists_finiteExtensionInfinityPlace_canonicalDifferent_scaling_certificate + (K := K) (L := L) D (probeInfinityRingDerivation K) + (probeAmbientReciprocalDerivation K L D) + (probeAmbientReciprocalDerivation_extends K L D hDX) + (probeAmbientReciprocalDerivation_changeParameter K L D) P + +end AmbientExtension + +section GlobalNormalized + +variable [Fintype K] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] +variable {p : ℕ} [Fact p.Prime] [CharP K p] [CharP L p] + +local instance globalInfinityClosureModuleFinite : + Module.Finite (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.finite (RatFuncInfinityIntegers K) (RatFunc K) L + (RatFuncInfinityIntegralClosure K L) + +local instance globalInfinityClosureIsIntegral : + Algebra.IsIntegral (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.isIntegral_algebra (RatFuncInfinityIntegers K) L + +local instance globalInfinityBaseTorsionFreeTop : + Module.IsTorsionFree (RatFuncInfinityIntegers K) L := + Module.IsTorsionFree.trans_faithfulSMul + (RatFuncInfinityIntegers K) (RatFunc K) L + +local instance globalInfinityClosureIsTorsionFree : + Module.IsTorsionFree (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.isTorsionFree (RatFuncInfinityIntegers K) L + +local instance globalInfinityClosureIsDedekindDomain : + IsDedekindDomain (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.isDedekindDomain + (RatFuncInfinityIntegers K) (RatFunc K) L + (RatFuncInfinityIntegralClosure K L) + +local instance globalInfinityClosureIsFractionRing : + IsFractionRing (RatFuncInfinityIntegralClosure K L) L := + IsIntegralClosure.isFractionRing_of_finite_extension + (RatFuncInfinityIntegers K) (RatFunc K) L + (RatFuncInfinityIntegralClosure K L) + +/-- The exact exhaustive Proposition 2 gcd estimate from a normalized +Frobenius-constant derivation. The infinity-place hypotheses of +`finiteExtensionGcdBound_of_normalizedCanonicalInfinityPlacewiseBounds` are +automatic: the reciprocal derivation at infinity gives the change of +parameter, and the different supplies the canonical clearing scalar. -/ +theorem finiteExtensionGcdBound_of_normalizedCanonicalPlacewiseBounds + (D : Derivation (frobeniusSubfield L p) L L) + (hDX : D (algebraMap (RatFunc K) L RatFunc.X) = 1) + (u v : L) (hu : u ≠ 0) (hv : v ≠ 0) + (huone : u ≠ 1) (hvone : v ≠ 1) + (h k : ℕ) (hn : 0 < h * k + h + k) (chi : ℕ) + (hWronskian : + (indexedDedekindLocalWronskian D + (auxiliaryFamilyDerivativeOrder h k) + (auxiliaryFamily u v h k)).det ≠ 0) + (hEuler : + finiteExtensionDivisorDegree K L + (finiteExtensionCanonicalDifferentDivisor K L + (finiteExtensionFiniteDifferentIdeal_ne_bot K L)) + + (∑ P ∈ propositionTwoExceptionalPlaces K L u v, + finiteExtensionPlaceDegree K L P : ℤ) ≤ (chi : ℤ)) : + (finiteExtensionGcdWeightedDegree K L (1 - u) (1 - v) : ℝ) ≤ + ((h + 2 * k : ℕ) : ℝ) / ((h * k + h + k : ℕ) : ℝ) * + (finiteExtensionPositiveDegree K L v : ℝ) + + (k : ℝ) / ((h * k + h + k : ℕ) : ℝ) * + (finiteExtensionPositiveDegree K L u : ℝ) + + ((((h * k + h + k : ℕ) : ℝ) - 1) / 2) * (chi : ℝ) := by + apply finiteExtensionGcdBound_of_normalizedCanonicalInfinityPlacewiseBounds + K L D hDX u v hu hv huone hvone h k hn chi hWronskian hEuler + · intro P hP hrho + obtain ⟨c, hc, hcOrder, hScaledLocal⟩ := + probe_exists_normalizedInfinityScaling K L D hDX P + have huOrder : + finitePlaceOrder (primeOverHeightOne (ratFuncInfinityPlace K) P) u = 0 := by + simpa only [finiteExtensionPrincipalDivisor_inr_eq_infinityPlaceOrder] using + finiteExtensionPrincipalDivisor_u_eq_zero_outside_propositionTwoExceptionalPlaces + K L u v (.inr P) hP + have hvOrder : + finitePlaceOrder (primeOverHeightOne (ratFuncInfinityPlace K) P) v = 0 := by + simpa only [finiteExtensionPrincipalDivisor_inr_eq_infinityPlaceOrder] using + finiteExtensionPrincipalDivisor_v_eq_zero_outside_propositionTwoExceptionalPlaces + K L u v (.inr P) hP + exact finiteExtensionInfinityPlace_canonicalAuxiliary_caseI_of_scaling + (K := K) (L := L) P D c hc hcOrder hScaledLocal h k hn + u v hu hv huone hvone huOrder hvOrder + (by simpa only [finiteExtensionPrincipalDivisor_inr_eq_infinityPlaceOrder] + using hrho) + hWronskian + · intro P hP hrho + obtain ⟨c, hc, hcOrder, hScaledLocal⟩ := + probe_exists_normalizedInfinityScaling K L D hDX P + have huOrder : + finitePlaceOrder (primeOverHeightOne (ratFuncInfinityPlace K) P) u = 0 := by + simpa only [finiteExtensionPrincipalDivisor_inr_eq_infinityPlaceOrder] using + finiteExtensionPrincipalDivisor_u_eq_zero_outside_propositionTwoExceptionalPlaces + K L u v (.inr P) hP + have hvOrder : + finitePlaceOrder (primeOverHeightOne (ratFuncInfinityPlace K) P) v = 0 := by + simpa only [finiteExtensionPrincipalDivisor_inr_eq_infinityPlaceOrder] using + finiteExtensionPrincipalDivisor_v_eq_zero_outside_propositionTwoExceptionalPlaces + K L u v (.inr P) hP + exact finiteExtensionInfinityPlace_canonicalAuxiliary_caseII_of_scaling + (K := K) (L := L) P D c hc hcOrder hScaledLocal h k + u v hu hv huone hvone huOrder.ge hvOrder.ge + (by simpa only [finiteExtensionPrincipalDivisor_inr_eq_infinityPlaceOrder] + using hrho) + hWronskian + · intro P _hP _hvP + obtain ⟨c, hc, hcOrder, hScaledLocal⟩ := + probe_exists_normalizedInfinityScaling K L D hDX P + exact finiteExtensionInfinityPlace_canonicalAuxiliary_caseIII_of_scaling + (K := K) (L := L) P D c hc hcOrder hScaledLocal h k + u v hu hv huone hvone hWronskian + · intro P _hP _hvP + obtain ⟨c, hc, hcOrder, hScaledLocal⟩ := + probe_exists_normalizedInfinityScaling K L D hDX P + exact finiteExtensionInfinityPlace_canonicalAuxiliary_caseIV_of_scaling + (K := K) (L := L) P D c hc hcOrder hScaledLocal h k + u v hu hv huone hvone hWronskian + +end GlobalNormalized + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/FiniteExtensionCanonicalPlaceSum.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/FiniteExtensionCanonicalPlaceSum.lean new file mode 100644 index 0000000000..28bacf3383 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/FiniteExtensionCanonicalPlaceSum.lean @@ -0,0 +1,341 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.GlobalWronskianWeightedPlaceSum +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionCanonicalWronskian +public import Mathlib.Tactic + +/-! +# Canonical Wronskian sums over all places + +Sum the local Wronskian inequalities with residue-degree weights, separating exceptional places +from the outside pole height. +-/ + +@[expose] public section + +open scoped BigOperators + +namespace BGS.CorvajaZannier + +noncomputable section + +variable (K : Type*) [Field K] [DecidableEq K] [DecidableEq (RatFunc K)] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +attribute [local instance] Classical.decEq + +/-- The finite set on which all terms in the canonical Wronskian summation +can be nonzero. -/ +def finiteExtensionCanonicalSummationSupport + (S : Finset (FiniteExtensionPlace K L)) + (canonical : FiniteExtensionPlace K L →₀ ℤ) + (u v rho grid W : L) : Finset (FiniteExtensionPlace K L) := by + classical + exact S ∪ canonical.support ∪ + (finiteExtensionPrincipalDivisor K L u).support ∪ + (finiteExtensionPrincipalDivisor K L v).support ∪ + (finiteExtensionPrincipalDivisor K L rho).support ∪ + (finiteExtensionPrincipalDivisor K L grid).support ∪ + (finiteExtensionPrincipalDivisor K L W).support + +/-- The pole height of `rho` away from an exceptional set. -/ +def finiteExtensionOutsideHeight + (rho : L) (S : Finset (FiniteExtensionPlace K L)) : ℕ := by + classical + exact ∑ P ∈ (finiteExtensionPrincipalDivisor K L rho).support.filter + (fun P => P ∉ S ∧ finiteExtensionPrincipalDivisor K L rho P < 0), + (finiteExtensionPrincipalDivisor K L rho P).natAbs * + finiteExtensionPlaceDegree K L P + +theorem finiteExtensionOutsideHeight_negativeSum + (rho : L) (S : Finset (FiniteExtensionPlace K L)) : + ∑ P ∈ (finiteExtensionPrincipalDivisor K L rho).support.filter + (fun P => P ∉ S ∧ finiteExtensionPrincipalDivisor K L rho P < 0), + finiteExtensionPrincipalDivisor K L rho P * + (finiteExtensionPlaceDegree K L P : ℤ) = + -(finiteExtensionOutsideHeight K L rho S : ℤ) := by + classical + rw [finiteExtensionOutsideHeight, Nat.cast_sum, ← Finset.sum_neg_distrib] + apply Finset.sum_congr rfl + intro P hP + have hneg : finiteExtensionPrincipalDivisor K L rho P < 0 := + (Finset.mem_filter.mp hP).2.2 + rw [Nat.cast_mul, Int.natCast_natAbs, abs_of_nonpos (le_of_lt hneg)] + ring + +private theorem sum_negative_outside_subtype + {X : Type*} [DecidableEq X] (D : X →₀ ℤ) (S T : Finset X) + (hDT : D.support ⊆ T) (weight : X → ℤ) + (S' : Finset {x // x ∈ T}) + (hS' : ∀ x : {x // x ∈ T}, x ∈ S' ↔ x.1 ∈ S) : + ∑ x ∈ Finset.univ.filter (fun x : {x // x ∈ T} => x ∉ S' ∧ D x.1 < 0), + D x.1 * weight x.1 = + ∑ x ∈ D.support.filter (fun x => x ∉ S ∧ D x < 0), D x * weight x := by + classical + rw [Finset.sum_filter] + simp_rw [hS'] + calc + _ = ∑ x ∈ T, if x ∉ S ∧ D x < 0 then D x * weight x else 0 := + (Finset.sum_subtype T (fun x => by simp) + (fun x => if x ∉ S ∧ D x < 0 then D x * weight x else 0)).symm + _ = ∑ x ∈ D.support, if x ∉ S ∧ D x < 0 then D x * weight x else 0 := by + symm + apply Finset.sum_subset hDT + intro x hx hnot + simp [Finsupp.notMem_support_iff.mp hnot] + _ = _ := by rw [Finset.sum_filter] + +/-- Exhaustive residue-degree-weighted summation with a genuine canonical +divisor and a nonzero global Wronskian. -/ +theorem globalWronskianInequality_of_finiteExtensionCanonicalPlacewiseBounds + (S : Finset (FiniteExtensionPlace K L)) + (canonical : FiniteExtensionPlace K L →₀ ℤ) + (u v rho grid W : L) + (h k n sigma chi : ℕ) + (hu : u ≠ 0) (hgrid : grid ≠ 0) (hW : W ≠ 0) + (hUOutside : ∀ P, P ∉ S → finiteExtensionPrincipalDivisor K L u P = 0) + (hGridOutside : ∀ P, P ∉ S → + finiteExtensionPrincipalDivisor K L grid P = 0) + (hVPositiveSupport : ∀ P, + 0 < finiteExtensionPrincipalDivisor K L v P → P ∈ S) + (hEuler : finiteExtensionDivisorDegree K L canonical + + (∑ P ∈ S, finiteExtensionPlaceDegree K L P : ℤ) ≤ (chi : ℤ)) + (hRhoSupport : + -((finiteExtensionPositiveDegree K L u : ℤ) + + (finiteExtensionPositiveDegree K L v : ℤ)) ≤ + ∑ P ∈ S, finiteExtensionPrincipalDivisor K L rho P * + (finiteExtensionPlaceDegree K L P : ℤ)) + (hCaseI : ∀ P, P ∉ S → + finiteExtensionPrincipalDivisor K L rho P < 0 → + (n : ℤ) * finiteExtensionPrincipalDivisor K L rho P ≤ + (sigma : ℤ) * canonical P + + finiteExtensionPrincipalDivisor K L W P) + (hCaseII : ∀ P, P ∉ S → + 0 ≤ finiteExtensionPrincipalDivisor K L rho P → + 0 ≤ (sigma : ℤ) * canonical P + + finiteExtensionPrincipalDivisor K L W P) + (hCaseIII : ∀ P, P ∈ S → + 0 < finiteExtensionPrincipalDivisor K L v P → + ((k * (k - 1) / 2 : ℕ) : ℤ) * + finiteExtensionPrincipalDivisor K L u P + + ((h * k : ℕ) : ℤ) * finiteExtensionPrincipalDivisor K L v P + + (k : ℤ) * finiteExtensionPrincipalDivisor K L rho P + + finiteExtensionPrincipalDivisor K L grid P - (sigma : ℤ) ≤ + (sigma : ℤ) * canonical P + + finiteExtensionPrincipalDivisor K L W P) + (hCaseIV : ∀ P, P ∈ S → + finiteExtensionPrincipalDivisor K L v P ≤ 0 → + ((k * (k - 1) / 2 : ℕ) : ℤ) * + finiteExtensionPrincipalDivisor K L u P + + (k : ℤ) * finiteExtensionPrincipalDivisor K L rho P + + finiteExtensionPrincipalDivisor K L grid P - (sigma : ℤ) ≤ + (sigma : ℤ) * canonical P + + finiteExtensionPrincipalDivisor K L W P) : + ((h * k : ℕ) : ℤ) * (finiteExtensionPositiveDegree K L v : ℤ) - + (k : ℤ) * ((finiteExtensionPositiveDegree K L u : ℤ) + + (finiteExtensionPositiveDegree K L v : ℤ)) - + (sigma : ℤ) * (chi : ℤ) ≤ + (n : ℤ) * (finiteExtensionOutsideHeight K L rho S : ℤ) := by + classical + let T := finiteExtensionCanonicalSummationSupport K L S canonical u v rho grid W + let I := {P // P ∈ T} + let eS : {P // P ∈ S} ↪ I := + ⟨fun P => ⟨P.1, by + change P.1 ∈ finiteExtensionCanonicalSummationSupport K L S canonical u v rho grid W + simp [finiteExtensionCanonicalSummationSupport, P.2]⟩, + fun P Q hPQ => Subtype.ext + (congrArg (fun R : I => R.1) hPQ)⟩ + let S' : Finset I := S.attach.map eS + let ord (x : L) : I → ℤ := fun P => finiteExtensionPrincipalDivisor K L x P.1 + let ordW : I → ℤ := fun P => + (sigma : ℤ) * canonical P.1 + finiteExtensionPrincipalDivisor K L W P.1 + have hS'_iff (P : I) : P ∈ S' ↔ P.1 ∈ S := by + constructor + · intro hP + rcases Finset.mem_map.mp hP with ⟨Q, hQS, hQP⟩ + have : Q.1 = P.1 := congrArg Subtype.val hQP + simpa [this] using Q.2 + · intro hP + let Q : {P // P ∈ S} := ⟨P.1, hP⟩ + have hQattach : Q ∈ S.attach := by simp [Q] + apply Finset.mem_map.mpr + refine ⟨Q, hQattach, ?_⟩ + apply Subtype.ext + rfl + have hsum_of_support_subset + (D : FiniteExtensionPlace K L →₀ ℤ) (hDT : D.support ⊆ T) : + ∑ P : I, D P.1 * (finiteExtensionPlaceDegree K L P.1 : ℤ) = + D.sum (fun P a => a * (finiteExtensionPlaceDegree K L P : ℤ)) := by + rw [← Finset.sum_subtype T (fun P => by simp) (fun P => + D P * (finiteExtensionPlaceDegree K L P : ℤ))] + symm + exact Finsupp.sum_of_support_subset D hDT + (fun P a => a * (finiteExtensionPlaceDegree K L P : ℤ)) + (by simp) + have hcanonicalSupport : canonical.support ⊆ T := by + intro P hP + simp [T, finiteExtensionCanonicalSummationSupport, hP] + have hWsupport : (finiteExtensionPrincipalDivisor K L W).support ⊆ T := by + intro P hP + simp [T, finiteExtensionCanonicalSummationSupport, hP] + have hUSum : ∑ P : I, ord u P * + (finiteExtensionPlaceDegree K L P.1 : ℤ) = 0 := by + rw [hsum_of_support_subset (finiteExtensionPrincipalDivisor K L u)] + · exact finiteExtensionPrincipalDivisorDegreeSum_eq_zero K L u hu + · intro P hP + simp [T, finiteExtensionCanonicalSummationSupport, hP] + have hGridSum : ∑ P : I, ord grid P * + (finiteExtensionPlaceDegree K L P.1 : ℤ) = 0 := by + rw [hsum_of_support_subset (finiteExtensionPrincipalDivisor K L grid)] + · exact finiteExtensionPrincipalDivisorDegreeSum_eq_zero K L grid hgrid + · intro P hP + simp [T, finiteExtensionCanonicalSummationSupport, hP] + have hCanonicalSum : ∑ P : I, ordW P * + (finiteExtensionPlaceDegree K L P.1 : ℤ) = + (sigma : ℤ) * finiteExtensionDivisorDegree K L canonical := by + change ∑ P : I, + ((sigma : ℤ) * canonical P.1 + + finiteExtensionPrincipalDivisor K L W P.1) * + (finiteExtensionPlaceDegree K L P.1 : ℤ) = _ + simp_rw [add_mul, Finset.sum_add_distrib] + have hscale : + (∑ P : I, (sigma : ℤ) * canonical P.1 * + (finiteExtensionPlaceDegree K L P.1 : ℤ)) = + (sigma : ℤ) * ∑ P : I, canonical P.1 * + (finiteExtensionPlaceDegree K L P.1 : ℤ) := by + calc + _ = ∑ P : I, (sigma : ℤ) * + (canonical P.1 * (finiteExtensionPlaceDegree K L P.1 : ℤ)) := by + apply Finset.sum_congr rfl + intro P hP + ring + _ = _ := by rw [Finset.mul_sum] + rw [hscale] + rw [hsum_of_support_subset canonical hcanonicalSupport, + hsum_of_support_subset (finiteExtensionPrincipalDivisor K L W) hWsupport] + have hprincipal := finiteExtensionPrincipalDivisorDegreeSum_eq_zero K L W hW + change (finiteExtensionPrincipalDivisor K L W).sum + (fun P a => a * (finiteExtensionPlaceDegree K L P : ℤ)) = 0 at hprincipal + rw [hprincipal, add_zero] + rfl + have hDegreeS : ∑ P ∈ S', finiteExtensionPlaceDegree K L P.1 = + ∑ P ∈ S, finiteExtensionPlaceDegree K L P := by + change ∑ P ∈ S.attach.map eS, finiteExtensionPlaceDegree K L P.1 = _ + rw [Finset.sum_map] + change ∑ P ∈ S.attach, finiteExtensionPlaceDegree K L P.1 = _ + exact Finset.sum_attach S (fun P => finiteExtensionPlaceDegree K L P) + have hSumS (F : FiniteExtensionPlace K L → ℤ) : + ∑ P ∈ S', F P.1 = ∑ P ∈ S, F P := by + change ∑ P ∈ S.attach.map eS, F P.1 = _ + rw [Finset.sum_map] + change ∑ P ∈ S.attach, F P.1 = _ + exact Finset.sum_attach S F + have hOutside : + ∑ P ∈ Finset.univ.filter (fun P : I => P ∉ S' ∧ ord rho P < 0), + ord rho P * (finiteExtensionPlaceDegree K L P.1 : ℤ) = + -(finiteExtensionOutsideHeight K L rho S : ℤ) := by + have hsupport : (finiteExtensionPrincipalDivisor K L rho).support ⊆ T := by + intro P hP + simp [T, finiteExtensionCanonicalSummationSupport, hP] + calc + _ = ∑ P ∈ (finiteExtensionPrincipalDivisor K L rho).support.filter + (fun P => P ∉ S ∧ finiteExtensionPrincipalDivisor K L rho P < 0), + finiteExtensionPrincipalDivisor K L rho P * + (finiteExtensionPlaceDegree K L P : ℤ) := + sum_negative_outside_subtype (finiteExtensionPrincipalDivisor K L rho) S T + hsupport (fun P => (finiteExtensionPlaceDegree K L P : ℤ)) S' hS'_iff + _ = _ := finiteExtensionOutsideHeight_negativeSum K L rho S + apply globalWronskianInequality_of_weightedPlacewiseBounds + (fun P : I => finiteExtensionPlaceDegree K L P.1) S' + (ord u) (ord v) (ord rho) (ord grid) ordW + h k n sigma + (finiteExtensionPositiveDegree K L u) + (finiteExtensionPositiveDegree K L v) + chi (finiteExtensionOutsideHeight K L rho S) + (finiteExtensionDivisorDegree K L canonical) + · intro P hP + exact hUOutside P.1 ((hS'_iff P).not.mp hP) + · intro P hP + exact hGridOutside P.1 ((hS'_iff P).not.mp hP) + · exact hUSum + · exact hGridSum + · have hpositive : ∀ P : I, 0 < ord v P → P ∈ S' := by + intro P hP + rw [hS'_iff] + exact hVPositiveSupport P.1 hP + let D := finiteExtensionPrincipalDivisor K L v + have hDsupport : D.support ⊆ T := by + intro P hP + have hne : finiteExtensionPrincipalDivisor K L v P ≠ 0 := by + simpa [D, Finsupp.mem_support_iff] using + (Finsupp.mem_support_iff.mp hP) + simp [T, finiteExtensionCanonicalSummationSupport, + Finsupp.mem_support_iff, hne] + have hPositiveAll : + (∑ P : I, if 0 < ord v P then + ord v P * (finiteExtensionPlaceDegree K L P.1 : ℤ) else 0) = + (finiteExtensionPositiveDegree K L v : ℤ) := by + calc + _ = ∑ P ∈ T, if 0 < D P then + D P * (finiteExtensionPlaceDegree K L P : ℤ) else 0 := by + exact (Finset.sum_subtype T (fun P => by simp) + (fun P => if 0 < D P then + D P * (finiteExtensionPlaceDegree K L P : ℤ) else 0)).symm + _ = ∑ P ∈ D.support, if 0 < D P then + D P * (finiteExtensionPlaceDegree K L P : ℤ) else 0 := by + apply Eq.symm + apply Finset.sum_subset hDsupport + intro P hPT hnot + have hzero : D P = 0 := Finsupp.notMem_support_iff.mp hnot + simp [hzero] + _ = ∑ P ∈ D.support.filter (fun P => 0 < D P), + D P * (finiteExtensionPlaceDegree K L P : ℤ) := by + rw [Finset.sum_filter] + _ = (finiteExtensionPositiveDegree K L v : ℤ) := by + exact (finiteExtensionPositiveDegree_cast K L v).symm + calc + ∑ P ∈ S'.filter (fun P => 0 < ord v P), + ord v P * (finiteExtensionPlaceDegree K L P.1 : ℤ) = + ∑ P ∈ S', if 0 < ord v P then + ord v P * (finiteExtensionPlaceDegree K L P.1 : ℤ) else 0 := by + rw [Finset.sum_filter] + _ = ∑ P : I, if 0 < ord v P then + ord v P * (finiteExtensionPlaceDegree K L P.1 : ℤ) else 0 := by + apply Finset.sum_subset (Finset.subset_univ S') + intro P hP hnotS + have hnotpos : ¬ 0 < ord v P := by + intro hpos + exact hnotS (hpositive P hpos) + simp [hnotpos] + _ = _ := hPositiveAll + · exact hOutside + · exact hCanonicalSum + · rw [hDegreeS] + simpa only [Nat.cast_sum] using hEuler + · change -((finiteExtensionPositiveDegree K L u : ℤ) + + (finiteExtensionPositiveDegree K L v : ℤ)) ≤ + ∑ P ∈ S', finiteExtensionPrincipalDivisor K L rho P.1 * + (finiteExtensionPlaceDegree K L P.1 : ℤ) + rw [hSumS (fun P => finiteExtensionPrincipalDivisor K L rho P * + (finiteExtensionPlaceDegree K L P : ℤ))] + exact hRhoSupport + · intro P hPS hneg + exact hCaseI P.1 ((hS'_iff P).not.mp hPS) hneg + · intro P hPS hnonneg + exact hCaseII P.1 ((hS'_iff P).not.mp hPS) hnonneg + · intro P hPS hpos + exact hCaseIII P.1 ((hS'_iff P).mp hPS) hpos + · intro P hPS hnonpos + exact hCaseIV P.1 ((hS'_iff P).mp hPS) hnonpos + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/FiniteExtensionCanonicalPlacewiseScaling.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/FiniteExtensionCanonicalPlacewiseScaling.lean new file mode 100644 index 0000000000..77f9d0578a --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/FiniteExtensionCanonicalPlacewiseScaling.lean @@ -0,0 +1,170 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.DedekindCanonicalDifferentScaling +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.DedekindLocalizationDerivationPreservation +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionCanonicalDifferentDivisor +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PerfectConstants +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveAuxiliaryFinitePlace +public import Mathlib.Tactic + +/-! +# Canonical derivation scalings at finite extension places + +This file instantiates the abstract different-annihilator construction for a +finite separable extension of `K(X)`. If the Frobenius-constant derivation is +normalized by `D(X) = 1`, the resulting scalar has order equal to the finite +coefficient of the canonical different divisor. The quotient-rule bridge then +shows that the scaled derivation preserves the complete localized DVR used by +the finite-place Wronskian estimates. +-/ + +@[expose] public section + +namespace BGS.CorvajaZannier + +noncomputable section + +open scoped nonZeroDivisors Polynomial +open IsDedekindDomain + +variable (K : Type*) [Field K] [PerfectField K] + [DecidableEq (RatFunc K)] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] +variable {p : ℕ} [Fact p.Prime] [CharP K p] [CharP L p] + +local instance (priority := 10) canonicalScalingPolynomialAlgebra : + Algebra K[X] L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K[X] (RatFunc K))) + +local instance canonicalScalingPolynomialScalarTower : + IsScalarTower K[X] (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + +local instance canonicalScalingFiniteIntegralClosureModuleFinite : + Module.Finite K[X] (RatFuncFiniteIntegralClosure K L) := + Module.IsNoetherian.finite K[X] (RatFuncFiniteIntegralClosure K L) + +local instance canonicalScalingFiniteIntegralClosureIsIntegral : + Algebra.IsIntegral K[X] (RatFuncFiniteIntegralClosure K L) := + IsIntegralClosure.isIntegral_algebra K[X] L + +local instance canonicalScalingPolynomialTorsionFreeTop : + Module.IsTorsionFree K[X] L := + Module.IsTorsionFree.trans_faithfulSMul K[X] (RatFunc K) L + +local instance canonicalScalingFiniteIntegralClosureIsTorsionFree : + Module.IsTorsionFree K[X] (RatFuncFiniteIntegralClosure K L) := + IsIntegralClosure.isTorsionFree K[X] L + +local instance canonicalScalingFiniteBaseFaithfulSmulFractionRing : + FaithfulSMul K[X] + (FractionRing (RatFuncFiniteIntegralClosure K L)) := by + rw [faithfulSMul_iff_algebraMap_injective] + intro x y hxy + have hS := IsFractionRing.injective (RatFuncFiniteIntegralClosure K L) + (FractionRing (RatFuncFiniteIntegralClosure K L)) hxy + exact FunctionField.ringOfIntegers.algebraMap_injective K L hS + +local instance canonicalScalingFiniteFractionRingAlgebra : + Algebra (FractionRing K[X]) + (FractionRing (RatFuncFiniteIntegralClosure K L)) := + FractionRing.liftAlgebra K[X] + (FractionRing (RatFuncFiniteIntegralClosure K L)) + +local instance canonicalScalingFiniteFractionRingSeparable : + Algebra.IsSeparable (FractionRing K[X]) + (FractionRing (RatFuncFiniteIntegralClosure K L)) := by + refine Algebra.IsSeparable.of_equiv_equiv + (ratFuncFiniteFractionRingEquiv K).symm.toRingEquiv + (ratFuncFiniteIntegralClosureFractionRingEquiv K L).symm.toRingEquiv ?_ + ext z + exact IsFractionRing.algEquiv_commutes + (ratFuncFiniteFractionRingEquiv K).symm + (ratFuncFiniteIntegralClosureFractionRingEquiv K L).symm z + +/-- At every finite place, the normalized Frobenius-constant derivation admits +a scalar whose order is the canonical different coefficient and whose scalar +multiple preserves the localized DVR. -/ +theorem exists_finiteExtensionFinitePlace_canonicalDifferent_scaling_certificate + (D : Derivation (frobeniusSubfield L p) L L) + (hDX : D (algebraMap (RatFunc K) L RatFunc.X) = 1) + (q : FiniteExtensionFinitePlace K L) : + ∃ c : L, c ≠ 0 ∧ + finitePlaceOrder q c = + finiteExtensionCanonicalDifferentDivisor K L + (finiteExtensionFiniteDifferentIdeal_ne_bot K L) (.inl q) ∧ + ∀ r : FiniteExtensionFinitePlaceLocalRing K L q, + ∃ s : FiniteExtensionFinitePlaceLocalRing K L q, + (c • D) (finiteExtensionFinitePlaceLocalizationToField + (K := K) (L := L) q r) = + finiteExtensionFinitePlaceLocalizationToField + (K := K) (L := L) q s := by + let : Algebra K L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K (RatFunc K))) + let : IsScalarTower K (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + let : IsScalarTower K K[X] L := + IsScalarTower.of_algebraMap_eq' rfl + let F := frobeniusSubfield L p + let : Algebra K F := + (perfectConstantsToFrobeniusSubfield (K := K) (L := L) (p := p)).toAlgebra + let : IsScalarTower K F L := IsScalarTower.of_algebraMap_eq' rfl + let Ds : Derivation K K[X] K[X] := Polynomial.mkDerivation K 1 + let E : Derivation K L L := D.restrictScalars K + have hE : ∀ s : K[X], + E (algebraMap K[X] L s) = algebraMap K[X] L (Ds s) := by + have hder : E.compAlgebraMap K[X] = + (Algebra.linearMap K[X] L).compDer Ds := by + apply Polynomial.derivation_ext + calc + (E.compAlgebraMap K[X]) Polynomial.X = + E (algebraMap K[X] L Polynomial.X) := rfl + _ = D (algebraMap (RatFunc K) L RatFunc.X) := by + rw [IsScalarTower.algebraMap_apply K[X] (RatFunc K) L] + rw [RatFunc.algebraMap_X] + rfl + _ = 1 := hDX + _ = ((Algebra.linearMap K[X] L).compDer Ds) Polynomial.X := by + simp [Ds] + intro s + exact Derivation.congr_fun hder s + obtain ⟨δ, hδ, _hδmem, _hδmult, hδorder, _hδann, hδpreserves⟩ := + exists_finitePlace_different_localGenerator_scaling_certificate + (C := K) (S := K[X]) (T := RatFuncFiniteIntegralClosure K L) + (U := L) (F := L) q Ds E hE + let c : L := algebraMap (RatFuncFiniteIntegralClosure K L) L δ + have hc : c ≠ 0 := by + exact (IsFractionRing.injective (RatFuncFiniteIntegralClosure K L) L).ne hδ + refine ⟨c, hc, ?_, ?_⟩ + · simpa only [c, finiteExtensionCanonicalDifferentDivisor_inl] using hδorder + · let := finiteExtensionFinitePlaceLocalAlgebra (K := K) (L := L) q + let : IsScalarTower (RatFuncFiniteIntegralClosure K L) + (FiniteExtensionFinitePlaceLocalRing K L q) L := by + apply IsScalarTower.of_algebraMap_eq' + exact (finiteExtensionFinitePlaceLocalizationToField_comp_algebraMap + (K := K) (L := L) q).symm + have hGlobal : ∀ t : RatFuncFiniteIntegralClosure K L, + ∃ t' : RatFuncFiniteIntegralClosure K L, + (c • D) (algebraMap (RatFuncFiniteIntegralClosure K L) L t) = + algebraMap (RatFuncFiniteIntegralClosure K L) L t' := by + intro t + obtain ⟨t', ht'⟩ := hδpreserves t + refine ⟨t', ?_⟩ + simpa only [c, E, Derivation.smul_apply, Algebra.smul_def, + Algebra.algebraMap_self_apply, Derivation.restrictScalars_apply] using ht' + exact ambientDerivation_preserves_localizationAtPrime_of_preserves + q.asIdeal (c • D) hGlobal + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/FiniteExtensionCanonicalWronskian.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/FiniteExtensionCanonicalWronskian.lean new file mode 100644 index 0000000000..46f6e4face --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/FiniteExtensionCanonicalWronskian.lean @@ -0,0 +1,500 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.DedekindDifferentDivisor +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.DedekindLocalWronskian +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionPolynomialHeight +public import Mathlib.Tactic + +/-! +# The global Wronskian divisor and the finite different degree + +This module supplies two exact global pieces of the Corvaja--Zannier +Wronskian argument for a finite separable extension of `K(X)`. + +First, a global derivation gives one global Wronskian element. Replacing it +at a place by a local-parameter derivation changes the order by exactly the +triangular multiple of the change-of-parameter coefficient. Accordingly, +the local Wronskians form the sum of the principal divisor of the global +Wronskian and a triangular multiple of a canonical correction divisor. The +product formula then proves that its degree is exactly the triangular +multiple of the canonical degree. + +Second, for an integral primitive element in the finite integral closure, +the weighted degree of the finite different is bounded by the degree of its +power-basis discriminant. This is obtained without an abstract norm-of-ideal +interface: ideal multiplicities are identified with finite-place orders, and +the existing exhaustive norm formula evaluates their weighted sum. + +What is deliberately not asserted here is a Riemann--Hurwitz theorem, an +identification of the correction divisor at the places above infinity, or a +plane-curve genus/boundary estimate. Those are the remaining geometric +inputs needed to derive the final bound `canonicalDegree + |S| <= 2ab`. +-/ + +@[expose] public section + +open scoped nonZeroDivisors Polynomial +open IsDedekindDomain + +namespace BGS.CorvajaZannier + +noncomputable section + +attribute [local instance] FractionRing.liftAlgebra + FractionRing.isScalarTower_liftAlgebra + +variable (K : Type*) [Field K] [DecidableEq K] [DecidableEq (RatFunc K)] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +local instance (priority := 10) canonicalWronskianPolynomialAlgebra : + Algebra K[X] L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K[X] (RatFunc K))) + +local instance canonicalWronskianPolynomialScalarTower : + IsScalarTower K[X] (RatFunc K) L := + ⟨fun r s x => by + simp only [Algebra.smul_def] + rw [map_mul] + change (algebraMap (RatFunc K) L (algebraMap K[X] (RatFunc K) r) * + algebraMap (RatFunc K) L s) * x = + algebraMap K[X] L r * (algebraMap (RatFunc K) L s * x) + rw [show algebraMap K[X] L r = + algebraMap (RatFunc K) L (algebraMap K[X] (RatFunc K) r) by rfl] + ring⟩ + +local instance canonicalWronskianFiniteIntegralClosureModuleFinite : + Module.Finite K[X] (RatFuncFiniteIntegralClosure K L) := + Module.IsNoetherian.finite K[X] (RatFuncFiniteIntegralClosure K L) + +local instance canonicalWronskianPolynomialTorsionFreeTop : + Module.IsTorsionFree K[X] L := + Module.IsTorsionFree.trans_faithfulSMul K[X] (RatFunc K) L + +local instance canonicalWronskianFiniteIntegralClosureIsIntegral : + Algebra.IsIntegral K[X] (RatFuncFiniteIntegralClosure K L) := + IsIntegralClosure.isIntegral_algebra K[X] L + +local instance canonicalWronskianFiniteIntegralClosureIsTorsionFree : + Module.IsTorsionFree K[X] (RatFuncFiniteIntegralClosure K L) := + IsIntegralClosure.isTorsionFree K[X] L + +/-! ## The finite different and the discriminant degree -/ + +omit [DecidableEq K] [DecidableEq (RatFunc K)] in +private theorem finiteExtensionFinitePrincipalDivisor_algebraMap_apply + (d : RatFuncFiniteIntegralClosure K L) (hd : d ≠ 0) + (q : FiniteExtensionFinitePlace K L) : + finiteExtensionFinitePrincipalDivisor K L + (algebraMap (RatFuncFiniteIntegralClosure K L) L d) q = + (multiplicity q.asIdeal (Ideal.span {d}) : ℤ) := by + let e := ratFuncFiniteIntegralClosureFractionRingEquiv K L + have hrepr : + e.symm (algebraMap (RatFuncFiniteIntegralClosure K L) L d) = + algebraMap (RatFuncFiniteIntegralClosure K L) + (FractionRing (RatFuncFiniteIntegralClosure K L)) d := by + apply e.injective + rw [e.apply_symm_apply, e.commutes] + rw [finiteExtensionFinitePrincipalDivisor_apply, hrepr, + finitePlaceOrder_algebraMap_eq_multiplicity q d hd] + +omit [DecidableEq K] [DecidableEq (RatFunc K)] in +private theorem finiteExtensionFinitePrincipalDivisor_algebraMap_eq_mapRange + (d : RatFuncFiniteIntegralClosure K L) (hd : d ≠ 0) : + finiteExtensionFinitePrincipalDivisor K L + (algebraMap (RatFuncFiniteIntegralClosure K L) L d) = + (idealMultiplicityDivisor (Ideal.span {d}) + (by simpa [Ideal.span_singleton_eq_bot] using hd)).mapRange + (fun n : ℕ => (n : ℤ)) (by simp) := by + ext q + rw [finiteExtensionFinitePrincipalDivisor_algebraMap_apply K L d hd, + Finsupp.mapRange_apply, idealMultiplicityDivisor_apply] + +omit [DecidableEq (RatFunc K)] in +/-- The weighted degree of the principal ideal of an integral element is the +finite-place degree sum of that element in the exhaustive `K(X)` model. -/ +theorem idealMultiplicityWeightedDegree_eq_finiteExtensionFiniteDirectDegreeSum + (d : RatFuncFiniteIntegralClosure K L) (hd : d ≠ 0) : + ((idealMultiplicityDivisor (Ideal.span {d}) + (by simpa [Ideal.span_singleton_eq_bot] using hd)).sum + (fun q e => e * q.asIdeal.inertiaDeg K[X] * + ratFuncFinitePlaceDegree (HeightOneSpectrum.under K[X] q)) : ℤ) = + finiteExtensionFiniteDirectDegreeSum K L + (algebraMap (RatFuncFiniteIntegralClosure K L) L d) := by + rw [finiteExtensionFiniteDirectDegreeSum, + finiteExtensionFinitePrincipalDivisor_algebraMap_eq_mapRange K L d hd, + Finsupp.sum_mapRange_index (fun q => by simp)] + +omit [DecidableEq (RatFunc K)] in +/-- The finite different degree is bounded by the finite degree of the +minimal-polynomial derivative of an integral primitive element. -/ +theorem finiteDifferentDegree_le_minpolyDerivativeDegree + (x : RatFuncFiniteIntegralClosure K L) + (hx : Algebra.adjoin (RatFunc K) + {algebraMap (RatFuncFiniteIntegralClosure K L) L x} = ⊤) : + ((differentMultiplicityDivisor K[X] (RatFuncFiniteIntegralClosure K L) + (differentIdeal_ne_bot_of_primitiveElement + (A := K[X]) (K := RatFunc K) (L := L) + (B := RatFuncFiniteIntegralClosure K L) x hx)).sum + (fun q e => e * q.asIdeal.inertiaDeg K[X] * + ratFuncFinitePlaceDegree (HeightOneSpectrum.under K[X] q)) : ℤ) ≤ + finiteExtensionFiniteDirectDegreeSum K L + (algebraMap (RatFuncFiniteIntegralClosure K L) L + (Polynomial.aeval x (Polynomial.derivative (minpoly K[X] x)))) := by + classical + let d : RatFuncFiniteIntegralClosure K L := + Polynomial.aeval x (Polynomial.derivative (minpoly K[X] x)) + have hd : d ≠ 0 := by + simpa [d] using minpolyDerivative_ne_zero + (A := K[X]) (K := RatFunc K) (L := L) x + have hbound := differentMultiplicityWeightedSum_le_minpolyDerivative + (A := K[X]) (K := RatFunc K) (L := L) + (B := RatFuncFiniteIntegralClosure K L) x hx + (fun q => q.asIdeal.inertiaDeg K[X] * + ratFuncFinitePlaceDegree (HeightOneSpectrum.under K[X] q)) + have hcast : + (((differentMultiplicityDivisor K[X] + (RatFuncFiniteIntegralClosure K L) + (differentIdeal_ne_bot_of_primitiveElement + (A := K[X]) (K := RatFunc K) (L := L) + (B := RatFuncFiniteIntegralClosure K L) x hx)).sum + (fun q e => e * q.asIdeal.inertiaDeg K[X] * + ratFuncFinitePlaceDegree (HeightOneSpectrum.under K[X] q)) : ℕ) : ℤ) ≤ + (((idealMultiplicityDivisor (Ideal.span {d}) + (by + simpa [d] using minpolyDerivative_span_ne_bot + (A := K[X]) (K := RatFunc K) (L := L) + (B := RatFuncFiniteIntegralClosure K L) x)).sum + (fun q e => e * q.asIdeal.inertiaDeg K[X] * + ratFuncFinitePlaceDegree (HeightOneSpectrum.under K[X] q)) : ℕ) : ℤ) := by + exact_mod_cast (show + (differentMultiplicityDivisor K[X] + (RatFuncFiniteIntegralClosure K L) + (differentIdeal_ne_bot_of_primitiveElement + (A := K[X]) (K := RatFunc K) (L := L) + (B := RatFuncFiniteIntegralClosure K L) x hx)).sum + (fun q e => e * q.asIdeal.inertiaDeg K[X] * + ratFuncFinitePlaceDegree (HeightOneSpectrum.under K[X] q)) ≤ + (idealMultiplicityDivisor (Ideal.span {d}) + (by + simpa [d] using minpolyDerivative_span_ne_bot + (A := K[X]) (K := RatFunc K) (L := L) + (B := RatFuncFiniteIntegralClosure K L) x)).sum + (fun q e => e * q.asIdeal.inertiaDeg K[X] * + ratFuncFinitePlaceDegree (HeightOneSpectrum.under K[X] q)) by + simpa only [d, Nat.mul_assoc] using hbound) + have hcast' : + (differentMultiplicityDivisor K[X] + (RatFuncFiniteIntegralClosure K L) + (differentIdeal_ne_bot_of_primitiveElement + (A := K[X]) (K := RatFunc K) (L := L) + (B := RatFuncFiniteIntegralClosure K L) x hx)).sum + (fun q e => (e : ℤ) * q.asIdeal.inertiaDeg K[X] * + ratFuncFinitePlaceDegree (HeightOneSpectrum.under K[X] q)) ≤ + (idealMultiplicityDivisor (Ideal.span {d}) + (by + simpa [d] using minpolyDerivative_span_ne_bot + (A := K[X]) (K := RatFunc K) (L := L) + (B := RatFuncFiniteIntegralClosure K L) x)).sum + (fun q e => (e : ℤ) * q.asIdeal.inertiaDeg K[X] * + ratFuncFinitePlaceDegree (HeightOneSpectrum.under K[X] q)) := by + simpa only [Nat.cast_finsupp_sum, Nat.cast_mul] using hcast + rw [idealMultiplicityWeightedDegree_eq_finiteExtensionFiniteDirectDegreeSum + K L d hd] at hcast' + simpa only [d] using hcast' + +omit [DecidableEq K] [DecidableEq (RatFunc K)] in +private theorem ratFunc_intDegree_neg_one_pow (m : ℕ) : + ((-1 : RatFunc K) ^ m).intDegree = 0 := by + induction m with + | zero => simp + | succ m ih => + rw [pow_succ, RatFunc.intDegree_mul (pow_ne_zero m (by simp)) (by simp), ih] + simp + +omit [DecidableEq (RatFunc K)] in +/-- The finite degree of the integral minimal-polynomial derivative is exactly +the rational-function degree of the associated power-basis discriminant. -/ +theorem finiteExtensionMinpolyDerivativeDegree_eq_powerBasisDiscriminantDegree + (x : RatFuncFiniteIntegralClosure K L) + (hx : Algebra.adjoin (RatFunc K) + {algebraMap (RatFuncFiniteIntegralClosure K L) L x} = ⊤) : + finiteExtensionFiniteDirectDegreeSum K L + (algebraMap (RatFuncFiniteIntegralClosure K L) L + (Polynomial.aeval x (Polynomial.derivative (minpoly K[X] x)))) = + (Algebra.discr (RatFunc K) + (PowerBasis.ofAdjoinEqTop' + (Algebra.IsIntegral.isIntegral + (algebraMap (RatFuncFiniteIntegralClosure K L) L x)) hx).basis).intDegree := by + classical + let d : RatFuncFiniteIntegralClosure K L := + Polynomial.aeval x (Polynomial.derivative (minpoly K[X] x)) + let y : L := algebraMap (RatFuncFiniteIntegralClosure K L) L d + have hd : d ≠ 0 := by + simpa [d] using minpolyDerivative_ne_zero + (A := K[X]) (K := RatFunc K) (L := L) x + have hy : y ≠ 0 := + (IsFractionRing.injective (RatFuncFiniteIntegralClosure K L) L).ne hd + have hnorm : Algebra.norm (RatFunc K) y ≠ 0 := + Algebra.norm_ne_zero_iff.mpr hy + rw [show algebraMap (RatFuncFiniteIntegralClosure K L) L + (Polynomial.aeval x (Polynomial.derivative (minpoly K[X] x))) = y by rfl, + finiteExtensionFiniteDirectDegreeSum_eq_grouped K L y hy, + finiteExtensionFinitePlaceDegreeSum_eq_normFinitePlaceDegreeSum K L y hy, + ratFuncExhaustiveFinitePlaceDegreeSum_eq_intDegree _ hnorm] + have hdisc := discr_powerBasisOfPrimitiveElement_eq_norm_minpolyDerivative + (A := K[X]) (K := RatFunc K) (L := L) + (B := RatFuncFiniteIntegralClosure K L) x hx + change Algebra.discr (RatFunc K) + (PowerBasis.ofAdjoinEqTop' + (Algebra.IsIntegral.isIntegral + (algebraMap (RatFuncFiniteIntegralClosure K L) L x)) hx).basis = + (-1) ^ (Module.finrank (RatFunc K) L * + (Module.finrank (RatFunc K) L - 1) / 2) * Algebra.norm (RatFunc K) y at hdisc + have hdegree := congrArg RatFunc.intDegree hdisc + rw [RatFunc.intDegree_mul (pow_ne_zero _ (by simp)) hnorm, + ratFunc_intDegree_neg_one_pow K] at hdegree + omega + +omit [DecidableEq (RatFunc K)] in +/-- The finite different degree is bounded by the power-basis discriminant +degree of any integral primitive element. -/ +theorem finiteDifferentDegree_le_powerBasisDiscriminantDegree + (x : RatFuncFiniteIntegralClosure K L) + (hx : Algebra.adjoin (RatFunc K) + {algebraMap (RatFuncFiniteIntegralClosure K L) L x} = ⊤) : + (differentMultiplicityDivisor K[X] (RatFuncFiniteIntegralClosure K L) + (differentIdeal_ne_bot_of_primitiveElement + (A := K[X]) (K := RatFunc K) (L := L) + (B := RatFuncFiniteIntegralClosure K L) x hx)).sum + (fun q e => (e : ℤ) * q.asIdeal.inertiaDeg K[X] * + ratFuncFinitePlaceDegree (HeightOneSpectrum.under K[X] q)) ≤ + (Algebra.discr (RatFunc K) + (PowerBasis.ofAdjoinEqTop' + (Algebra.IsIntegral.isIntegral + (algebraMap (RatFuncFiniteIntegralClosure K L) L x)) hx).basis).intDegree := by + classical + calc + _ ≤ finiteExtensionFiniteDirectDegreeSum K L + (algebraMap (RatFuncFiniteIntegralClosure K L) L + (Polynomial.aeval x (Polynomial.derivative (minpoly K[X] x)))) := + finiteDifferentDegree_le_minpolyDerivativeDegree K L x hx + _ = _ := + finiteExtensionMinpolyDerivativeDegree_eq_powerBasisDiscriminantDegree K L x hx + +/-! ## The local-parameter Wronskian divisor -/ + +section WronskianDivisor + +variable {C : Type*} [Field C] [Algebra C L] + +/-- The global ordinary Wronskian attached to one derivation. -/ +def finiteExtensionGlobalWronskian {n : ℕ} + (D : Derivation C L L) (g : Fin n → L) : L := + (BGS.Algebra.derivationWronskian D g).det + +section LocalChangeParameter + +variable {R : Type*} [CommRing R] [IsDedekindDomain R] + [Algebra R L] [IsFractionRing R L] + +private theorem finitePlaceOrder_mul_of_ne_zero + (v : HeightOneSpectrum R) (x y : L) (hx : x ≠ 0) (hy : y ≠ 0) : + finitePlaceOrder v (x * y) = finitePlaceOrder v x + finitePlaceOrder v y := by + have h := finitePlaceOrderTop_mul v x y + rw [finitePlaceOrderTop_eq_coe v (x * y) (mul_ne_zero hx hy), + finitePlaceOrderTop_eq_coe v x hx, + finitePlaceOrderTop_eq_coe v y hy] at h + exact_mod_cast h + +private theorem finitePlaceOrder_pow_of_ne_zero + (v : HeightOneSpectrum R) (x : L) (hx : x ≠ 0) (m : ℕ) : + finitePlaceOrder v (x ^ m) = m • finitePlaceOrder v x := by + have h := finitePlaceOrderTop_pow v x m + rw [finitePlaceOrderTop_eq_coe v (x ^ m) (pow_ne_zero m hx), + finitePlaceOrderTop_eq_coe v x hx] at h + exact_mod_cast h + +/-- Exact order change from a global derivation to a local-parameter +derivation. If `D = a E`, then the local `E`-Wronskian has the global +`D`-Wronskian order minus `choose(n,2)` times the order of `a`. -/ +theorem finitePlaceOrder_globalWronskian_changeParameter + (v : HeightOneSpectrum R) {n : ℕ} + (D E : Derivation C L L) (a : L) (hD : D = a • E) + (g : Fin n → L) (ha : a ≠ 0) + (hE : finiteExtensionGlobalWronskian L E g ≠ 0) : + finitePlaceOrder v (finiteExtensionGlobalWronskian L E g) = + finitePlaceOrder v (finiteExtensionGlobalWronskian L D g) - + (n.choose 2 : ℤ) * finitePlaceOrder v a := by + have hchange := derivationWronskian_det_changeParameter D E a hD g + change finiteExtensionGlobalWronskian L D g = + a ^ n.choose 2 * finiteExtensionGlobalWronskian L E g at hchange + have hpow : a ^ n.choose 2 ≠ 0 := pow_ne_zero _ ha + have hord := finitePlaceOrder_mul_of_ne_zero L v + (a ^ n.choose 2) (finiteExtensionGlobalWronskian L E g) hpow hE + rw [← hchange, finitePlaceOrder_pow_of_ne_zero L v a ha] at hord + simp only [nsmul_eq_mul] at hord + omega + +end LocalChangeParameter + +/-- Degree of a finitely supported divisor on the exhaustive places of the +finite extension. -/ +def finiteExtensionDivisorDegree + (D : FiniteExtensionPlace K L →₀ ℤ) : ℤ := + D.sum (fun v e => e * (finiteExtensionPlaceDegree K L v : ℤ)) + +/-- The divisor represented by local-parameter Wronskians: the principal +divisor of the global Wronskian plus the triangular multiple of a supplied +canonical correction divisor. -/ +def finiteExtensionLocalWronskianDivisor {n : ℕ} + (D : Derivation C L L) (g : Fin n → L) + (canonicalDivisor : FiniteExtensionPlace K L →₀ ℤ) : + FiniteExtensionPlace K L →₀ ℤ := + (n.choose 2 : ℤ) • canonicalDivisor + + finiteExtensionPrincipalDivisor K L + (finiteExtensionGlobalWronskian L D g) + +omit [DecidableEq K] in +@[simp] theorem finiteExtensionLocalWronskianDivisor_apply {n : ℕ} + (D : Derivation C L L) (g : Fin n → L) + (canonicalDivisor : FiniteExtensionPlace K L →₀ ℤ) + (v : FiniteExtensionPlace K L) : + finiteExtensionLocalWronskianDivisor K L D g canonicalDivisor v = + (n.choose 2 : ℤ) * canonicalDivisor v + + finiteExtensionPrincipalDivisor K L + (finiteExtensionGlobalWronskian L D g) v := by + simp [finiteExtensionLocalWronskianDivisor] + +/-- The product formula kills the principal global Wronskian contribution. +Thus the local Wronskian divisor has exactly the triangular multiple of the +canonical degree. -/ +theorem finiteExtensionLocalWronskianDivisor_degree + {n : ℕ} (D : Derivation C L L) (g : Fin n → L) + (canonicalDivisor : FiniteExtensionPlace K L →₀ ℤ) + (hW : finiteExtensionGlobalWronskian L D g ≠ 0) : + finiteExtensionDivisorDegree K L + (finiteExtensionLocalWronskianDivisor K L D g canonicalDivisor) = + (n.choose 2 : ℤ) * + finiteExtensionDivisorDegree K L canonicalDivisor := by + classical + rw [finiteExtensionDivisorDegree, finiteExtensionLocalWronskianDivisor, + Finsupp.sum_add_index (by simp) (by intros; ring), + Finsupp.sum_smul_index (by simp)] + have hprincipal : + (finiteExtensionPrincipalDivisor K L + (finiteExtensionGlobalWronskian L D g)).sum + (fun v e => e * (finiteExtensionPlaceDegree K L v : ℤ)) = 0 := by + exact finiteExtensionPrincipalDivisorDegreeSum_eq_zero K L + (finiteExtensionGlobalWronskian L D g) hW + rw [hprincipal] + simp only [finiteExtensionDivisorDegree] + rw [add_zero] + unfold Finsupp.sum + rw [Finset.mul_sum] + apply Finset.sum_congr rfl + intro v hv + ring + +omit [DecidableEq K] in +/-- Over algebraically closed constants every place has degree one, so the +global canonical identity becomes the ordinary unweighted sum of local +Wronskian orders used by Corvaja--Zannier. -/ +theorem finiteExtensionLocalWronskianDivisor_sum + [IsAlgClosed K] + {n : ℕ} (D : Derivation C L L) (g : Fin n → L) + (canonicalDivisor : FiniteExtensionPlace K L →₀ ℤ) + (hW : finiteExtensionGlobalWronskian L D g ≠ 0) : + (finiteExtensionLocalWronskianDivisor K L D g canonicalDivisor).sum + (fun _ e => e) = + (n.choose 2 : ℤ) * canonicalDivisor.sum (fun _ e => e) := by + classical + have hdegree := finiteExtensionLocalWronskianDivisor_degree + K L D g canonicalDivisor hW + simpa only [finiteExtensionDivisorDegree, + finiteExtensionPlaceDegree_eq_one K L, + Int.ofNat_eq_natCast, Nat.cast_one, mul_one] using hdegree + +end WronskianDivisor + +/-! ## Final log-canonical arithmetic -/ + +/-- Once geometry bounds the canonical degree with the coarse boundary +allowance `2(a+b)`, and the actual exceptional set has at most that many +points, the exact Corvaja--Zannier choice `chi = 2ab` follows. -/ +theorem canonicalDegree_add_boundaryCard_le_twice_bidegree + {I : Type*} (S : Finset I) (canonicalDegree : ℤ) + (firstDegree secondDegree : ℕ) + (hCanonical : + canonicalDegree + (2 * (firstDegree + secondDegree) : ℕ) ≤ + (2 * firstDegree * secondDegree : ℕ)) + (hBoundary : S.card ≤ 2 * (firstDegree + secondDegree)) : + canonicalDegree + S.card ≤ + (2 * firstDegree * secondDegree : ℕ) := by + have hBoundaryInt : (S.card : ℤ) ≤ + (2 * (firstDegree + secondDegree) : ℕ) := by + exact_mod_cast hBoundary + omega + +/-- The usual genus and toric-boundary estimates imply the exact +log-canonical allowance used by Corvaja--Zannier. This theorem is purely the +numerical assembly: constructing a normalization and proving the two supplied +geometric estimates remain separate obligations. -/ +theorem canonicalDegree_add_boundaryCard_le_twice_bidegree_of_genus_bound + {I : Type*} (S : Finset I) (canonicalDegree : ℤ) + (genus firstDegree secondDegree : ℕ) + (hFirst : 0 < firstDegree) (hSecond : 0 < secondDegree) + (hCanonical : canonicalDegree ≤ 2 * (genus : ℤ) - 2) + (hGenus : genus ≤ (firstDegree - 1) * (secondDegree - 1)) + (hBoundary : S.card ≤ 2 * (firstDegree + secondDegree)) : + canonicalDegree + S.card ≤ + (2 * firstDegree * secondDegree : ℕ) := by + have hGenusInt : (genus : ℤ) ≤ + ((firstDegree - 1 : ℕ) : ℤ) * ((secondDegree - 1 : ℕ) : ℤ) := by + exact_mod_cast hGenus + have hFirstOne : 1 ≤ firstDegree := hFirst + have hSecondOne : 1 ≤ secondDegree := hSecond + rw [Nat.cast_sub hFirstOne, Nat.cast_sub hSecondOne] at hGenusInt + have hBoundaryInt : (S.card : ℤ) ≤ + 2 * ((firstDegree : ℤ) + secondDegree) := by + exact_mod_cast hBoundary + norm_num at hGenusInt hBoundaryInt ⊢ + nlinarith + +/-- The divisor-theoretic replacement for the genus-bound assembly. If the +canonical correction is bounded by the total different minus twice the +projection degree, the sharp bivariate discriminant budget and the toric +boundary budget give the same log-canonical bound `2 * a * b` directly. -/ +theorem canonicalDegree_add_boundaryCard_le_twice_bidegree_of_different_bound + {I : Type*} (S : Finset I) (canonicalDegree : ℤ) + (totalDifferent firstDegree secondDegree : ℕ) + (hSecond : 0 < secondDegree) + (hCanonical : + canonicalDegree ≤ (totalDifferent : ℤ) - 2 * (secondDegree : ℤ)) + (hDifferent : + totalDifferent ≤ (2 * secondDegree - 2) * firstDegree) + (hBoundary : S.card ≤ 2 * (firstDegree + secondDegree)) : + canonicalDegree + S.card ≤ + (2 * firstDegree * secondDegree : ℕ) := by + have hDifferentInt : (totalDifferent : ℤ) ≤ + ((2 * secondDegree - 2) * firstDegree : ℕ) := by + exact_mod_cast hDifferent + have hBoundaryInt : (S.card : ℤ) ≤ + (2 * (firstDegree + secondDegree) : ℕ) := by + exact_mod_cast hBoundary + rw [Nat.cast_mul, Nat.cast_sub (by omega : 2 ≤ 2 * secondDegree), + Nat.cast_mul, Nat.cast_ofNat] at hDifferentInt + norm_num at hDifferentInt hBoundaryInt ⊢ + nlinarith + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/FiniteExtensionExceptionalPlaceBounds.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/FiniteExtensionExceptionalPlaceBounds.lean new file mode 100644 index 0000000000..2cc23c71a0 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/FiniteExtensionExceptionalPlaceBounds.lean @@ -0,0 +1,193 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionExceptionalSupport +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionOneSubGcdHeight +public import Mathlib.Tactic + +/-! +# Direct weighted bounds on exhaustive exceptional places + +The family-place API is useful when several functions are indexed together. +The canonical global summation, however, is stated directly on the exhaustive +sum of finite and infinite places. This file records the corresponding +subset lower bound and specializes it to the one-minus quotient used in +Proposition 2. +-/ + +@[expose] public section + +namespace BGS.CorvajaZannier + +noncomputable section + +open scoped BigOperators + +variable (K : Type*) [Field K] [DecidableEq K] [DecidableEq (RatFunc K)] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +attribute [local instance] Classical.decEq + +omit [DecidableEq K] in +/-- The first coordinate has order zero away from the direct Proposition 2 +exceptional set. -/ +theorem finiteExtensionPrincipalDivisor_u_eq_zero_outside_propositionTwoExceptionalPlaces + (u v : L) (P : FiniteExtensionPlace K L) + (hP : P ∉ propositionTwoExceptionalPlaces K L u v) : + finiteExtensionPrincipalDivisor K L u P = 0 := by + apply Finsupp.notMem_support_iff.mp + intro hmem + apply hP + rw [propositionTwoExceptionalPlaces] + exact Finset.mem_union_left _ hmem + +omit [DecidableEq K] in +/-- The second coordinate has order zero away from the direct Proposition 2 +exceptional set. -/ +theorem finiteExtensionPrincipalDivisor_v_eq_zero_outside_propositionTwoExceptionalPlaces + (u v : L) (P : FiniteExtensionPlace K L) + (hP : P ∉ propositionTwoExceptionalPlaces K L u v) : + finiteExtensionPrincipalDivisor K L v P = 0 := by + apply Finsupp.notMem_support_iff.mp + intro hmem + apply hP + rw [propositionTwoExceptionalPlaces] + exact Finset.mem_union_right _ hmem + +omit [DecidableEq K] in +/-- Every positive-order place of the second coordinate belongs to the direct +Proposition 2 exceptional set. -/ +theorem mem_propositionTwoExceptionalPlaces_of_v_order_pos + (u v : L) (P : FiniteExtensionPlace K L) + (hP : 0 < finiteExtensionPrincipalDivisor K L v P) : + P ∈ propositionTwoExceptionalPlaces K L u v := by + rw [propositionTwoExceptionalPlaces] + exact Finset.mem_union_right _ (Finsupp.mem_support_iff.mpr (ne_of_gt hP)) + +omit [DecidableEq K] in +/-- Every auxiliary grid product has order zero away from the direct +Proposition 2 exceptional set. -/ +theorem finiteExtensionPrincipalDivisor_auxiliaryGridProduct_eq_zero_outside_propositionTwoExceptionalPlaces + (u v : L) (hu : u ≠ 0) (hv : v ≠ 0) + (h k : ℕ) (P : FiniteExtensionPlace K L) + (hP : P ∉ propositionTwoExceptionalPlaces K L u v) : + finiteExtensionPrincipalDivisor K L + (finiteExtensionAuxiliaryGridProduct L u v h k) P = 0 := by + rw [finiteExtensionPrincipalDivisor_auxiliaryGridProduct K L u v hu hv h k] + have huP := + finiteExtensionPrincipalDivisor_u_eq_zero_outside_propositionTwoExceptionalPlaces + K L u v P hP + have hvP := + finiteExtensionPrincipalDivisor_v_eq_zero_outside_propositionTwoExceptionalPlaces + K L u v P hP + simp only [Finset.sum_apply', Finsupp.add_apply, Finsupp.smul_apply, + huP, hvP, nsmul_zero, add_zero, Finset.sum_const_zero] + +/-- On any finite set of exhaustive places, the weighted order sum of a +function is bounded below by minus its full pole height. -/ +theorem finiteExtensionWeightedOrder_sum_ge_neg_height + (x : L) (S : Finset (FiniteExtensionPlace K L)) : + -((finiteExtensionHeight K L x : ℕ) : ℤ) ≤ + ∑ P ∈ S, finiteExtensionPrincipalDivisor K L x P * + (finiteExtensionPlaceDegree K L P : ℤ) := by + classical + let D := finiteExtensionPrincipalDivisor K L x + let N := D.support.filter (fun P => D P < 0) + let T := S.filter (fun P => D P < 0) + have hTN : T ⊆ N := by + intro P hP + have hneg : D P < 0 := (Finset.mem_filter.mp hP).2 + exact Finset.mem_filter.mpr + ⟨Finsupp.mem_support_iff.mpr (ne_of_lt hneg), hneg⟩ + have hfilterTN : N.filter (fun P => P ∈ T) = T := by + ext P + simp only [Finset.mem_filter] + constructor + · exact fun hP => hP.2 + · exact fun hP => ⟨hTN hP, hP⟩ + have hMissingNonpos : + ∑ P ∈ N.filter (fun P => P ∉ T), + D P * (finiteExtensionPlaceDegree K L P : ℤ) ≤ 0 := by + apply Finset.sum_nonpos + intro P hP + have hneg : D P < 0 := + (Finset.mem_filter.mp (Finset.mem_filter.mp hP).1).2 + exact mul_nonpos_of_nonpos_of_nonneg (le_of_lt hneg) (by positivity) + have hNegativeAllLeT : + (∑ P ∈ N, D P * (finiteExtensionPlaceDegree K L P : ℤ)) ≤ + ∑ P ∈ T, D P * (finiteExtensionPlaceDegree K L P : ℤ) := by + have hsplit := Finset.sum_filter_add_sum_filter_not N + (fun P => P ∈ T) + (fun P => D P * (finiteExtensionPlaceDegree K L P : ℤ)) + rw [hfilterTN] at hsplit + linarith + have hRemainingNonneg : + 0 ≤ ∑ P ∈ S.filter (fun P => ¬ D P < 0), + D P * (finiteExtensionPlaceDegree K L P : ℤ) := by + apply Finset.sum_nonneg + intro P hP + have hnonneg : 0 ≤ D P := le_of_not_gt (Finset.mem_filter.mp hP).2 + exact mul_nonneg hnonneg (by positivity) + have hTLeS : + (∑ P ∈ T, D P * (finiteExtensionPlaceDegree K L P : ℤ)) ≤ + ∑ P ∈ S, D P * (finiteExtensionPlaceDegree K L P : ℤ) := by + have hsplit := Finset.sum_filter_add_sum_filter_not S + (fun P => D P < 0) + (fun P => D P * (finiteExtensionPlaceDegree K L P : ℤ)) + change + (∑ P ∈ T, D P * (finiteExtensionPlaceDegree K L P : ℤ)) + + ∑ P ∈ S.filter (fun P => ¬ D P < 0), + D P * (finiteExtensionPlaceDegree K L P : ℤ) = + ∑ P ∈ S, D P * (finiteExtensionPlaceDegree K L P : ℤ) at hsplit + linarith + have hNegativeAll := finiteExtensionHeight_negativeSum K L x + change -((finiteExtensionHeight K L x : ℕ) : ℤ) = + ∑ P ∈ N, D P * (finiteExtensionPlaceDegree K L P : ℤ) at hNegativeAll + rw [hNegativeAll] + exact hNegativeAllLeT.trans hTLeS + +/-- The exceptional-set contribution of `(1-u)/(1-v)` is bounded below by +minus the sum of the two coordinate heights. The assertion holds for every +finite set, and hence in particular for the zero-and-pole set of `u,v`. -/ +theorem finiteExtensionOneSubU_div_oneSubV_weightedOrder_lower_bound + (u v : L) (hu : u ≠ 0) (hv : v ≠ 0) + (huone : u ≠ 1) (hvone : v ≠ 1) + (S : Finset (FiniteExtensionPlace K L)) : + -((finiteExtensionPositiveDegree K L u : ℕ) : ℤ) - + (finiteExtensionPositiveDegree K L v : ℤ) ≤ + ∑ P ∈ S, + finiteExtensionPrincipalDivisor K L ((1 - u) / (1 - v)) P * + (finiteExtensionPlaceDegree K L P : ℤ) := by + have hheight : + finiteExtensionHeight K L ((1 - u) / (1 - v)) ≤ + finiteExtensionPositiveDegree K L u + + finiteExtensionPositiveDegree K L v := by + calc + finiteExtensionHeight K L ((1 - u) / (1 - v)) ≤ + finiteExtensionHeight K L u + finiteExtensionHeight K L v := + by simpa only [add_comm] using + finiteExtensionHeight_one_sub_div_one_sub_le K L + v u hv hu hvone huone + _ = finiteExtensionPositiveDegree K L u + + finiteExtensionPositiveDegree K L v := by + rw [finiteExtensionPositiveDegree_eq_height K L u hu, + finiteExtensionPositiveDegree_eq_height K L v hv] + have hheightInt : + (finiteExtensionHeight K L ((1 - u) / (1 - v)) : ℤ) ≤ + (finiteExtensionPositiveDegree K L u : ℤ) + + (finiteExtensionPositiveDegree K L v : ℤ) := by + exact_mod_cast hheight + have hsubset := finiteExtensionWeightedOrder_sum_ge_neg_height + K L ((1 - u) / (1 - v)) S + linarith + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/FiniteExtensionExceptionalSupport.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/FiniteExtensionExceptionalSupport.lean new file mode 100644 index 0000000000..60e18d99f3 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/FiniteExtensionExceptionalSupport.lean @@ -0,0 +1,955 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionPolynomialHeight +public import Mathlib.Tactic + +/-! +# Exceptional-place bookkeeping for Corvaja--Zannier + +This file constructs the exceptional set used in the global summation in +Corvaja--Zannier Proposition 2. For two nonzero functions `u` and `v`, it is +the union of the supports of their exhaustive principal divisors. Thus both +functions, every auxiliary grid monomial, and their grid product have order +zero away from the set. Its residue-degree-weighted size is at most twice +the sum of the two heights. + +The final section proves the source estimate + +`-(H(u) + H(v)) <= sum_{w in S} ord_w ((1-v)/(1-u)) deg(w)`. + +The same estimate is also supplied in the paper's orientation +`(1-u)/(1-v)`. No algebraic-closedness hypothesis is needed for the weighted +statements; over an algebraically closed constant field they specialize to +ordinary cardinality and unweighted orders. + +Source provenance: published pages 1936--1937; checked semantic +reconstruction `Papers/CorvajaZannier2013/CorvajaZannier2013.tex`, lines +731--779. The earlier Proposition 2 source gives the same bookkeeping in +`Papers/arXiv-math-0512074v3/jag_rivisto2.tex`, lines 618--653. +-/ + +@[expose] public section + +open scoped nonZeroDivisors Polynomial BigOperators +open IsDedekindDomain + +namespace BGS.CorvajaZannier + +noncomputable section + +variable (K : Type*) [Field K] [DecidableEq K] [DecidableEq (RatFunc K)] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +local instance (priority := 10) exceptionalSupportPolynomialAlgebra : Algebra K[X] L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K[X] (RatFunc K))) + +local instance exceptionalSupportPolynomialScalarTower : + IsScalarTower K[X] (RatFunc K) L := + ⟨fun r s x => by + simp only [Algebra.smul_def] + rw [map_mul] + change (algebraMap (RatFunc K) L (algebraMap K[X] (RatFunc K) r) * + algebraMap (RatFunc K) L s) * x = + algebraMap K[X] L r * (algebraMap (RatFunc K) L s * x) + rw [show algebraMap K[X] L r = + algebraMap (RatFunc K) L (algebraMap K[X] (RatFunc K) r) by rfl] + ring⟩ + +local instance exceptionalSupportFiniteIntegralClosureModuleFinite : + Module.Finite K[X] (RatFuncFiniteIntegralClosure K L) := + Module.IsNoetherian.finite K[X] (RatFuncFiniteIntegralClosure K L) + +local instance exceptionalSupportFiniteIntegralClosureIsIntegral : + Algebra.IsIntegral K[X] (RatFuncFiniteIntegralClosure K L) := + IsIntegralClosure.isIntegral_algebra K[X] L + +local instance exceptionalSupportPolynomialTorsionFreeTop : + Module.IsTorsionFree K[X] L := + Module.IsTorsionFree.trans_faithfulSMul K[X] (RatFunc K) L + +local instance exceptionalSupportFiniteIntegralClosureIsTorsionFree : + Module.IsTorsionFree K[X] (RatFuncFiniteIntegralClosure K L) := + IsIntegralClosure.isTorsionFree K[X] L + +local instance exceptionalSupportInfinityIntegralClosureModuleFinite : + Module.Finite (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.finite (RatFuncInfinityIntegers K) (RatFunc K) L + (RatFuncInfinityIntegralClosure K L) + +local instance exceptionalSupportInfinityIntegralClosureIsDedekindDomain : + IsDedekindDomain (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.isDedekindDomain (RatFuncInfinityIntegers K) (RatFunc K) L + (RatFuncInfinityIntegralClosure K L) + +private theorem finitePlaceOrder_one + {R F : Type*} [CommRing R] [IsDedekindDomain R] + [Field F] [Algebra R F] [IsFractionRing R F] + (w : HeightOneSpectrum R) : + finitePlaceOrder w (1 : F) = 0 := by + have h := finitePlaceOrderTop_one (L := F) w + rw [finitePlaceOrderTop_eq_coe w (1 : F) one_ne_zero] at h + exact_mod_cast h + +omit [DecidableEq K] in +/-- The exhaustive principal divisor of one is zero. -/ +theorem finiteExtensionPrincipalDivisor_one : + finiteExtensionPrincipalDivisor K L (1 : L) = 0 := by + classical + ext w + cases w with + | inl q => + rw [finiteExtensionPrincipalDivisor_inl] + simpa using finitePlaceOrder_one + (w := q) (F := FractionRing (RatFuncFiniteIntegralClosure K L)) + | inr P => + rw [finiteExtensionPrincipalDivisor_inr] + simpa using finitePlaceOrder_one + (w := primeOverHeightOne (ratFuncInfinityPlace K) P) + (F := FractionRing (RatFuncInfinityIntegralClosure K L)) + +omit [DecidableEq K] in +/-- Exhaustive principal divisors turn a nonzero product into a sum. -/ +theorem finiteExtensionPrincipalDivisor_mul + (x y : L) (hx : x ≠ 0) (hy : y ≠ 0) : + finiteExtensionPrincipalDivisor K L (x * y) = + finiteExtensionPrincipalDivisor K L x + + finiteExtensionPrincipalDivisor K L y := by + classical + ext w + cases w with + | inl q => + have hx' : + (ratFuncFiniteIntegralClosureFractionRingEquiv K L).symm x ≠ 0 := + by simpa using + (ratFuncFiniteIntegralClosureFractionRingEquiv K L).symm.injective.ne hx + have hy' : + (ratFuncFiniteIntegralClosureFractionRingEquiv K L).symm y ≠ 0 := + by simpa using + (ratFuncFiniteIntegralClosureFractionRingEquiv K L).symm.injective.ne hy + have h := congrArg (fun D => D q) + (finitePrincipalDivisor_mul + (R := RatFuncFiniteIntegralClosure K L) + ((ratFuncFiniteIntegralClosureFractionRingEquiv K L).symm x) + ((ratFuncFiniteIntegralClosureFractionRingEquiv K L).symm y) + hx' hy') + simpa only [finiteExtensionPrincipalDivisor_inl, map_mul, + finitePrincipalDivisor_apply, Finsupp.add_apply] using h + | inr P => + let w := primeOverHeightOne (ratFuncInfinityPlace K) P + have hx' : + (ratFuncInfinityIntegralClosureFractionRingEquiv K L).symm x ≠ 0 := + by simpa using + (ratFuncInfinityIntegralClosureFractionRingEquiv K L).symm.injective.ne hx + have hy' : + (ratFuncInfinityIntegralClosureFractionRingEquiv K L).symm y ≠ 0 := + by simpa using + (ratFuncInfinityIntegralClosureFractionRingEquiv K L).symm.injective.ne hy + have h := congrArg (fun D => D w) + (finitePrincipalDivisor_mul + (R := RatFuncInfinityIntegralClosure K L) + ((ratFuncInfinityIntegralClosureFractionRingEquiv K L).symm x) + ((ratFuncInfinityIntegralClosureFractionRingEquiv K L).symm y) + hx' hy') + simpa only [finiteExtensionPrincipalDivisor_inr, map_mul, + finitePrincipalDivisor_apply, Finsupp.add_apply] using h + +omit [DecidableEq K] in +/-- Exhaustive principal divisors turn a nonzero power into a multiple. -/ +theorem finiteExtensionPrincipalDivisor_pow + (x : L) (hx : x ≠ 0) (m : ℕ) : + finiteExtensionPrincipalDivisor K L (x ^ m) = + m • finiteExtensionPrincipalDivisor K L x := by + classical + induction m with + | zero => simp [finiteExtensionPrincipalDivisor_one K L] + | succ m ih => + rw [pow_succ, finiteExtensionPrincipalDivisor_mul K L + (x ^ m) x (pow_ne_zero _ hx) hx, ih, succ_nsmul] + +omit [DecidableEq K] in +/-- Exhaustive principal divisors turn a nonzero inverse into a negative. -/ +theorem finiteExtensionPrincipalDivisor_inv + (x : L) (hx : x ≠ 0) : + finiteExtensionPrincipalDivisor K L x⁻¹ = + -finiteExtensionPrincipalDivisor K L x := by + classical + have hmul := finiteExtensionPrincipalDivisor_mul K L x⁻¹ x + (inv_ne_zero hx) hx + rw [inv_mul_cancel₀ hx, finiteExtensionPrincipalDivisor_one K L] at hmul + exact eq_neg_of_add_eq_zero_left hmul.symm + +omit [DecidableEq K] in +/-- Exhaustive principal divisors turn a quotient into a difference. -/ +theorem finiteExtensionPrincipalDivisor_div + (x y : L) (hx : x ≠ 0) (hy : y ≠ 0) : + finiteExtensionPrincipalDivisor K L (x / y) = + finiteExtensionPrincipalDivisor K L x - + finiteExtensionPrincipalDivisor K L y := by + classical + rw [div_eq_mul_inv, finiteExtensionPrincipalDivisor_mul K L x y⁻¹ hx + (inv_ne_zero hy), finiteExtensionPrincipalDivisor_inv K L y hy, sub_eq_add_neg] + +/-- Product of all grid monomials in the auxiliary family. Its divisor is +the `ordGrid` term in the global Wronskian summation. -/ +def finiteExtensionAuxiliaryGridProduct (u v : L) (h k : ℕ) : L := + ∏ rs : Fin (k + 1) × Fin h, u ^ (rs.1 : ℕ) * v ^ (rs.2 : ℕ) + +omit [DecidableEq K] in +private theorem finiteExtensionPrincipalDivisor_finset_prod + {ι : Type*} (s : Finset ι) (g : ι → L) + (hg : ∀ i ∈ s, g i ≠ 0) : + finiteExtensionPrincipalDivisor K L (∏ i ∈ s, g i) = + ∑ i ∈ s, finiteExtensionPrincipalDivisor K L (g i) := by + classical + induction s using Finset.induction_on with + | empty => simp [finiteExtensionPrincipalDivisor_one K L] + | @insert a s ha ih => + have hga : g a ≠ 0 := hg a (Finset.mem_insert_self a s) + have hgs : ∀ i ∈ s, g i ≠ 0 := fun i hi => + hg i (Finset.mem_insert_of_mem hi) + rw [Finset.prod_insert ha, Finset.sum_insert ha, + finiteExtensionPrincipalDivisor_mul K L _ _ hga + (Finset.prod_ne_zero_iff.mpr hgs), ih hgs] + +omit [DecidableEq K] in +/-- Exact principal-divisor formula for the auxiliary grid product. -/ +theorem finiteExtensionPrincipalDivisor_auxiliaryGridProduct + (u v : L) (hu : u ≠ 0) (hv : v ≠ 0) (h k : ℕ) : + finiteExtensionPrincipalDivisor K L + (finiteExtensionAuxiliaryGridProduct L u v h k) = + ∑ rs : Fin (k + 1) × Fin h, + ((rs.1 : ℕ) • finiteExtensionPrincipalDivisor K L u + + (rs.2 : ℕ) • finiteExtensionPrincipalDivisor K L v) := by + classical + rw [finiteExtensionAuxiliaryGridProduct, + finiteExtensionPrincipalDivisor_finset_prod K L Finset.univ + (fun rs : Fin (k + 1) × Fin h => + u ^ (rs.1 : ℕ) * v ^ (rs.2 : ℕ))] + · apply Finset.sum_congr rfl + intro rs _ + rw [finiteExtensionPrincipalDivisor_mul K L _ _ + (pow_ne_zero _ hu) (pow_ne_zero _ hv), + finiteExtensionPrincipalDivisor_pow K L u hu, + finiteExtensionPrincipalDivisor_pow K L v hv] + · intro rs _ + exact mul_ne_zero (pow_ne_zero _ hu) (pow_ne_zero _ hv) + +private theorem weightedSupportDegree_le_positive_add_negative + {ι : Type*} (D : ι →₀ ℤ) (weight : ι → ℕ) : + ∑ i ∈ D.support, weight i ≤ + (∑ i ∈ D.support.filter (fun i => 0 < D i), + (D i).toNat * weight i) + + ∑ i ∈ D.support.filter (fun i => D i < 0), + (-D i).toNat * weight i := by + classical + have hfilters : + D.support.filter (fun i => ¬ 0 < D i) = + D.support.filter (fun i => D i < 0) := by + ext i + simp only [Finset.mem_filter] + constructor + · intro ⟨hi, hnotpos⟩ + have hine : D i ≠ 0 := Finsupp.mem_support_iff.mp hi + exact ⟨hi, lt_of_le_of_ne (le_of_not_gt hnotpos) hine⟩ + · intro ⟨hi, hneg⟩ + exact ⟨hi, not_lt_of_ge (le_of_lt hneg)⟩ + rw [← Finset.sum_filter_add_sum_filter_not D.support + (fun i => 0 < D i) weight, hfilters] + apply Nat.add_le_add + · apply Finset.sum_le_sum + intro i hi + have hpos : 0 < D i := (Finset.mem_filter.mp hi).2 + have hone : 1 ≤ (D i).toNat := by omega + simpa using Nat.mul_le_mul_right (weight i) hone + · apply Finset.sum_le_sum + intro i hi + have hneg : D i < 0 := (Finset.mem_filter.mp hi).2 + have hone : 1 ≤ (-D i).toNat := by omega + simpa using Nat.mul_le_mul_right (weight i) hone + +local instance exceptionalSupportPlaceDecidableEq : + DecidableEq (FiniteExtensionPlace K L) := Classical.decEq _ + +/-- The residue-degree-weighted number of places in the support of a +principal divisor is bounded by its positive degree plus its pole height. -/ +theorem finiteExtensionPrincipalDivisor_supportDegree_le + (x : L) : + ∑ w ∈ (finiteExtensionPrincipalDivisor K L x).support, + finiteExtensionPlaceDegree K L w ≤ + finiteExtensionPositiveDegree K L x + finiteExtensionHeight K L x := by + simpa only [finiteExtensionPositiveDegree, finiteExtensionHeight] using + weightedSupportDegree_le_positive_add_negative + (finiteExtensionPrincipalDivisor K L x) + (finiteExtensionPlaceDegree K L) + +/-- For a nonzero function, the weighted support has degree at most twice +its height. -/ +theorem finiteExtensionPrincipalDivisor_supportDegree_le_two_mul_height + (x : L) (hx : x ≠ 0) : + ∑ w ∈ (finiteExtensionPrincipalDivisor K L x).support, + finiteExtensionPlaceDegree K L w ≤ + 2 * finiteExtensionPositiveDegree K L x := by + calc + _ ≤ finiteExtensionPositiveDegree K L x + finiteExtensionHeight K L x := + finiteExtensionPrincipalDivisor_supportDegree_le K L x + _ = finiteExtensionPositiveDegree K L x + + finiteExtensionPositiveDegree K L x := by + rw [← finiteExtensionPositiveDegree_eq_height K L x hx] + _ = _ := by omega + +private def finsuppWeightedNegativeDegree + {ι : Type*} [DecidableEq ι] (D : ι →₀ ℤ) (weight : ι → ℕ) : ℕ := + ∑ i ∈ D.support, (-D i).toNat * weight i + +private theorem finsuppWeightedNegativeDegree_eq_filter + {ι : Type*} [DecidableEq ι] (D : ι →₀ ℤ) (weight : ι → ℕ) : + finsuppWeightedNegativeDegree D weight = + ∑ i ∈ D.support.filter (fun i => D i < 0), + (-D i).toNat * weight i := by + classical + calc + ∑ i ∈ D.support, (-D i).toNat * weight i = + (∑ i ∈ D.support.filter (fun i => D i < 0), + (-D i).toNat * weight i) + + ∑ i ∈ D.support.filter (fun i => ¬ D i < 0), + (-D i).toNat * weight i := by + rw [Finset.sum_filter_add_sum_filter_not] + _ = (∑ i ∈ D.support.filter (fun i => D i < 0), + (-D i).toNat * weight i) + 0 := by + congr 1 + apply Finset.sum_eq_zero + intro i hi + have hnonneg : 0 ≤ D i := le_of_not_gt (Finset.mem_filter.mp hi).2 + rw [Int.toNat_of_nonpos (neg_nonpos.mpr hnonneg)] + simp + _ = _ := by simp + +private theorem finsuppWeightedPositiveDegree_eq_filter + {ι : Type*} (D : ι →₀ ℤ) (weight : ι → ℕ) : + (∑ i ∈ D.support, (D i).toNat * weight i) = + ∑ i ∈ D.support.filter (fun i => 0 < D i), + (D i).toNat * weight i := by + classical + calc + ∑ i ∈ D.support, (D i).toNat * weight i = + (∑ i ∈ D.support.filter (fun i => 0 < D i), + (D i).toNat * weight i) + + ∑ i ∈ D.support.filter (fun i => ¬ 0 < D i), + (D i).toNat * weight i := by + rw [Finset.sum_filter_add_sum_filter_not] + _ = (∑ i ∈ D.support.filter (fun i => 0 < D i), + (D i).toNat * weight i) + 0 := by + congr 1 + apply Finset.sum_eq_zero + intro i hi + have hnonpos : D i ≤ 0 := le_of_not_gt (Finset.mem_filter.mp hi).2 + rw [Int.toNat_of_nonpos hnonpos] + simp + _ = _ := by simp + +private theorem finsuppWeightedNegativeDegree_eq_sum_of_support_subset + {ι : Type*} [DecidableEq ι] (D : ι →₀ ℤ) (weight : ι → ℕ) + (s : Finset ι) (hs : D.support ⊆ s) : + finsuppWeightedNegativeDegree D weight = + ∑ i ∈ s, (-D i).toNat * weight i := by + apply Finset.sum_subset hs + intro i _ hi + have hzero : D i = 0 := Finsupp.notMem_support_iff.mp hi + simp [hzero] + +private theorem finsuppWeightedNegativeDegree_add_le + {ι : Type*} [DecidableEq ι] (D E : ι →₀ ℤ) (weight : ι → ℕ) : + finsuppWeightedNegativeDegree (D + E) weight ≤ + finsuppWeightedNegativeDegree D weight + + finsuppWeightedNegativeDegree E weight := by + let s := D.support ∪ E.support + rw [finsuppWeightedNegativeDegree_eq_sum_of_support_subset + (D + E) weight s Finsupp.support_add, + finsuppWeightedNegativeDegree_eq_sum_of_support_subset + D weight s Finset.subset_union_left, + finsuppWeightedNegativeDegree_eq_sum_of_support_subset + E weight s Finset.subset_union_right, + ← Finset.sum_add_distrib] + apply Finset.sum_le_sum + intro i _ + have hlocal : (-(D i + E i)).toNat ≤ + (-D i).toNat + (-E i).toNat := by omega + simpa [Finsupp.add_apply, add_mul] using + Nat.mul_le_mul_right (weight i) hlocal + +private theorem finiteExtensionHeight_eq_finsuppWeightedNegativeDegree + (x : L) : + finiteExtensionHeight K L x = + finsuppWeightedNegativeDegree + (finiteExtensionPrincipalDivisor K L x) + (finiteExtensionPlaceDegree K L) := by + rw [finsuppWeightedNegativeDegree_eq_filter] + rfl + +/-- Pole height is subadditive under multiplication. -/ +theorem finiteExtensionHeight_mul_le + (x y : L) (hx : x ≠ 0) (hy : y ≠ 0) : + finiteExtensionHeight K L (x * y) ≤ + finiteExtensionHeight K L x + finiteExtensionHeight K L y := by + rw [finiteExtensionHeight_eq_finsuppWeightedNegativeDegree, + finiteExtensionHeight_eq_finsuppWeightedNegativeDegree, + finiteExtensionHeight_eq_finsuppWeightedNegativeDegree, + finiteExtensionPrincipalDivisor_mul K L x y hx hy] + exact finsuppWeightedNegativeDegree_add_le _ _ _ + +/-- The pole height of an inverse is the positive degree of the original +function. -/ +theorem finiteExtensionHeight_inv_eq_positiveDegree + (x : L) (hx : x ≠ 0) : + finiteExtensionHeight K L x⁻¹ = finiteExtensionPositiveDegree K L x := by + rw [finiteExtensionHeight_eq_finsuppWeightedNegativeDegree, + finiteExtensionPrincipalDivisor_inv K L x hx, + finsuppWeightedNegativeDegree, + finiteExtensionPositiveDegree] + simpa using finsuppWeightedPositiveDegree_eq_filter + (finiteExtensionPrincipalDivisor K L x) (finiteExtensionPlaceDegree K L) + +/-- Pole height is invariant under inversion of a nonzero function. -/ +theorem finiteExtensionHeight_inv + (x : L) (hx : x ≠ 0) : + finiteExtensionHeight K L x⁻¹ = finiteExtensionHeight K L x := by + rw [finiteExtensionHeight_inv_eq_positiveDegree K L x hx, + finiteExtensionPositiveDegree_eq_height K L x hx] + +/-- Pole height is subadditive under division. -/ +theorem finiteExtensionHeight_div_le + (x y : L) (hx : x ≠ 0) (hy : y ≠ 0) : + finiteExtensionHeight K L (x / y) ≤ + finiteExtensionHeight K L x + finiteExtensionHeight K L y := by + rw [div_eq_mul_inv] + calc + finiteExtensionHeight K L (x * y⁻¹) ≤ + finiteExtensionHeight K L x + finiteExtensionHeight K L y⁻¹ := + finiteExtensionHeight_mul_le K L x y⁻¹ hx (inv_ne_zero hy) + _ = _ := by rw [finiteExtensionHeight_inv K L y hy] + +private theorem finitePlaceOrder_neg + {R F : Type*} [CommRing R] [IsDedekindDomain R] + [Field F] [Algebra R F] [IsFractionRing R F] + (w : HeightOneSpectrum R) (x : F) (hx : x ≠ 0) : + finitePlaceOrder w (-x) = finitePlaceOrder w x := by + have hval : (w.valuation F) (-x) = (w.valuation F) x := by simp + rw [valuation_eq_exp_neg_finitePlaceOrder w (-x) (neg_ne_zero.mpr hx), + valuation_eq_exp_neg_finitePlaceOrder w x hx] at hval + have horder := WithZero.exp_injective hval + omega + +private theorem finitePlaceOrder_one_sub_eq_of_neg + {R F : Type*} [CommRing R] [IsDedekindDomain R] + [Field F] [Algebra R F] [IsFractionRing R F] + (w : HeightOneSpectrum R) (x : F) (hx : x ≠ 0) + (hxneg : finitePlaceOrder w x < 0) : + finitePlaceOrder w (1 - x) = finitePlaceOrder w x := by + have hxone : x ≠ 1 := by + intro h + subst x + rw [finitePlaceOrder_one] at hxneg + omega + have honeSub : 1 - x ≠ 0 := sub_ne_zero.mpr hxone.symm + have hlower := finitePlaceOrder_add_ge_min w (1 : F) (-x) + one_ne_zero (neg_ne_zero.mpr hx) + (by simpa [sub_eq_add_neg] using honeSub) + rw [show (1 : F) + -x = 1 - x by ring, + finitePlaceOrder_one, finitePlaceOrder_neg w x hx, + min_eq_right (le_of_lt hxneg)] at hlower + have hreverse := finitePlaceOrder_add_ge_min w (1 : F) (-(1 - x)) + one_ne_zero (neg_ne_zero.mpr honeSub) + (by simpa using hx) + rw [show (1 : F) + -(1 - x) = x by ring, + finitePlaceOrder_one, + finitePlaceOrder_neg w (1 - x) honeSub] at hreverse + by_cases hnonneg : 0 ≤ finitePlaceOrder w (1 - x) + · rw [min_eq_left hnonneg] at hreverse + omega + · have hnonpos : finitePlaceOrder w (1 - x) ≤ 0 := le_of_not_ge hnonneg + rw [min_eq_right hnonpos] at hreverse + exact le_antisymm hreverse hlower + +omit [DecidableEq K] in +/-- At a pole of `x`, subtracting `x` from one does not change the exhaustive +place order. -/ +theorem finiteExtensionPrincipalDivisor_one_sub_apply_of_neg + (x : L) (hx : x ≠ 0) (w : FiniteExtensionPlace K L) + (hxneg : finiteExtensionPrincipalDivisor K L x w < 0) : + finiteExtensionPrincipalDivisor K L (1 - x) w = + finiteExtensionPrincipalDivisor K L x w := by + cases w with + | inl q => + have hx' : + (ratFuncFiniteIntegralClosureFractionRingEquiv K L).symm x ≠ 0 := by + simpa using + (ratFuncFiniteIntegralClosureFractionRingEquiv K L).symm.injective.ne hx + change finitePlaceOrder q + ((ratFuncFiniteIntegralClosureFractionRingEquiv K L).symm x) < 0 at hxneg + change finitePlaceOrder q + ((ratFuncFiniteIntegralClosureFractionRingEquiv K L).symm (1 - x)) = + finitePlaceOrder q + ((ratFuncFiniteIntegralClosureFractionRingEquiv K L).symm x) + rw [map_sub, map_one] + exact finitePlaceOrder_one_sub_eq_of_neg q _ hx' hxneg + | inr P => + let q := primeOverHeightOne (ratFuncInfinityPlace K) P + have hx' : + (ratFuncInfinityIntegralClosureFractionRingEquiv K L).symm x ≠ 0 := by + simpa using + (ratFuncInfinityIntegralClosureFractionRingEquiv K L).symm.injective.ne hx + change finitePlaceOrder q + ((ratFuncInfinityIntegralClosureFractionRingEquiv K L).symm x) < 0 at hxneg + change finitePlaceOrder q + ((ratFuncInfinityIntegralClosureFractionRingEquiv K L).symm (1 - x)) = + finitePlaceOrder q + ((ratFuncInfinityIntegralClosureFractionRingEquiv K L).symm x) + rw [map_sub, map_one] + exact finitePlaceOrder_one_sub_eq_of_neg q _ hx' hxneg + +omit [DecidableEq K] in +private theorem finiteExtensionPrincipalDivisor_one_sub_negativePart + (x : L) (hx : x ≠ 0) (hxone : x ≠ 1) + (w : FiniteExtensionPlace K L) : + (-finiteExtensionPrincipalDivisor K L (1 - x) w).toNat = + (-finiteExtensionPrincipalDivisor K L x w).toNat := by + by_cases hxneg : finiteExtensionPrincipalDivisor K L x w < 0 + · rw [finiteExtensionPrincipalDivisor_one_sub_apply_of_neg K L x hx w hxneg] + · by_cases hsubneg : finiteExtensionPrincipalDivisor K L (1 - x) w < 0 + · have hsubne : 1 - x ≠ 0 := sub_ne_zero.mpr hxone.symm + have hreverse := finiteExtensionPrincipalDivisor_one_sub_apply_of_neg + K L (1 - x) hsubne w hsubneg + rw [show (1 : L) - (1 - x) = x by ring] at hreverse + rw [hreverse] + · have hxnonneg : 0 ≤ finiteExtensionPrincipalDivisor K L x w := + le_of_not_gt hxneg + have hsubnonneg : 0 ≤ + finiteExtensionPrincipalDivisor K L (1 - x) w := + le_of_not_gt hsubneg + rw [Int.toNat_of_nonpos (neg_nonpos.mpr hsubnonneg), + Int.toNat_of_nonpos (neg_nonpos.mpr hxnonneg)] + +/-- The functions `x` and `1-x` have the same pole height. -/ +theorem finiteExtensionHeight_one_sub + (x : L) (hx : x ≠ 0) (hxone : x ≠ 1) : + finiteExtensionHeight K L (1 - x) = finiteExtensionHeight K L x := by + rw [finiteExtensionHeight_eq_finsuppWeightedNegativeDegree, + finiteExtensionHeight_eq_finsuppWeightedNegativeDegree] + let Dsub := finiteExtensionPrincipalDivisor K L (1 - x) + let Dx := finiteExtensionPrincipalDivisor K L x + let s := Dsub.support ∪ Dx.support + rw [finsuppWeightedNegativeDegree_eq_sum_of_support_subset + Dsub (finiteExtensionPlaceDegree K L) s Finset.subset_union_left, + finsuppWeightedNegativeDegree_eq_sum_of_support_subset + Dx (finiteExtensionPlaceDegree K L) s Finset.subset_union_right] + apply Finset.sum_congr rfl + intro w _ + rw [show Dsub w = finiteExtensionPrincipalDivisor K L (1 - x) w by rfl, + show Dx w = finiteExtensionPrincipalDivisor K L x w by rfl, + finiteExtensionPrincipalDivisor_one_sub_negativePart K L x hx hxone w] + +private theorem sum_union_le_sum_add_sum + {ι : Type*} [DecidableEq ι] (s t : Finset ι) (g : ι → ℕ) : + ∑ i ∈ s ∪ t, g i ≤ (∑ i ∈ s, g i) + ∑ i ∈ t, g i := by + calc + ∑ i ∈ s ∪ t, g i = + (∑ i ∈ s, g i) + ∑ i ∈ t \ s, g i := by + rw [show s ∪ t = s ∪ (t \ s) by ext i; simp, + Finset.sum_union Finset.disjoint_sdiff] + _ ≤ (∑ i ∈ s, g i) + ∑ i ∈ t, g i := by + exact Nat.add_le_add_left + (Finset.sum_le_sum_of_subset Finset.sdiff_subset) _ + +section ExceptionalSet + +variable {A : Type*} [Fintype A] + +/-- Embed the divisor support of one function into the common support of its family. -/ +def finiteExtensionFamilyMemberSupportEmbedding + (f : A → L) (a : A) : + {w // w ∈ (finiteExtensionPrincipalDivisor K L (f a)).support} ↪ + FiniteExtensionFamilyPlace K L f where + toFun w := ⟨w.1, + finiteExtensionPrincipalDivisor_support_subset_familySupport K L f a w.2⟩ + inj' := by + intro w z hwz + apply Subtype.ext + exact congrArg + (fun q : FiniteExtensionFamilyPlace K L f => q.1) hwz + +/-- The support of one family member, lifted to the common family place +type. -/ +def finiteExtensionFamilyMemberSupport (f : A → L) (a : A) : + Finset (FiniteExtensionFamilyPlace K L f) := by + classical + exact (finiteExtensionPrincipalDivisor K L (f a)).support.attach.map + (finiteExtensionFamilyMemberSupportEmbedding K L f a) + +omit [DecidableEq K] in +@[simp] +theorem mem_finiteExtensionFamilyMemberSupport_iff + (f : A → L) (a : A) (w : FiniteExtensionFamilyPlace K L f) : + w ∈ finiteExtensionFamilyMemberSupport K L f a ↔ + w.1 ∈ (finiteExtensionPrincipalDivisor K L (f a)).support := by + classical + constructor + · intro hw + rw [finiteExtensionFamilyMemberSupport, Finset.mem_map] at hw + obtain ⟨z, _, hz⟩ := hw + have hval : z.1 = w.1 := congrArg + (fun q : FiniteExtensionFamilyPlace K L f => q.1) hz + simpa only [hval] using z.2 + · intro hw + rw [finiteExtensionFamilyMemberSupport, Finset.mem_map] + refine ⟨⟨w.1, hw⟩, by simp, ?_⟩ + apply Subtype.ext + rfl + +theorem sum_finiteExtensionFamilyMemberSupport_placeDegree + (f : A → L) (a : A) : + ∑ w ∈ finiteExtensionFamilyMemberSupport K L f a, + finiteExtensionPlaceDegree K L w.1 = + ∑ w ∈ (finiteExtensionPrincipalDivisor K L (f a)).support, + finiteExtensionPlaceDegree K L w := by + classical + rw [finiteExtensionFamilyMemberSupport, Finset.sum_map] + simpa [finiteExtensionFamilyMemberSupportEmbedding] using! + (Finset.sum_attach + (finiteExtensionPrincipalDivisor K L (f a)).support + (fun w => finiteExtensionPlaceDegree K L w)) + +/-- The finite exceptional set consisting exactly of the zero and pole places +of the selected functions `u` and `v`, embedded into a caller's common family +place type. -/ +def finiteExtensionExceptionalSet (f : A → L) (iU iV : A) : + Finset (FiniteExtensionFamilyPlace K L f) := by + classical + exact finiteExtensionFamilyMemberSupport K L f iU ∪ + finiteExtensionFamilyMemberSupport K L f iV + +omit [DecidableEq K] in +@[simp] +theorem mem_finiteExtensionExceptionalSet_iff + (f : A → L) (iU iV : A) (w : FiniteExtensionFamilyPlace K L f) : + w ∈ finiteExtensionExceptionalSet K L f iU iV ↔ + w.1 ∈ (finiteExtensionPrincipalDivisor K L (f iU)).support ∨ + w.1 ∈ (finiteExtensionPrincipalDivisor K L (f iV)).support := by + classical + simp [finiteExtensionExceptionalSet] + +/-- Residue-degree-weighted boundary bound for the exceptional set. -/ +theorem finiteExtensionExceptionalSet_weightedDegree_le + (f : A → L) (iU iV : A) (hu : f iU ≠ 0) (hv : f iV ≠ 0) : + ∑ w ∈ finiteExtensionExceptionalSet K L f iU iV, + finiteExtensionPlaceDegree K L w.1 ≤ + 2 * (finiteExtensionPositiveDegree K L (f iU) + + finiteExtensionPositiveDegree K L (f iV)) := by + calc + _ ≤ + (∑ w ∈ finiteExtensionFamilyMemberSupport K L f iU, + finiteExtensionPlaceDegree K L w.1) + + ∑ w ∈ finiteExtensionFamilyMemberSupport K L f iV, + finiteExtensionPlaceDegree K L w.1 := by + simpa only [finiteExtensionExceptionalSet] using + sum_union_le_sum_add_sum + (finiteExtensionFamilyMemberSupport K L f iU) + (finiteExtensionFamilyMemberSupport K L f iV) + (fun w => finiteExtensionPlaceDegree K L w.1) + _ = + (∑ w ∈ (finiteExtensionPrincipalDivisor K L (f iU)).support, + finiteExtensionPlaceDegree K L w) + + ∑ w ∈ (finiteExtensionPrincipalDivisor K L (f iV)).support, + finiteExtensionPlaceDegree K L w := by + rw [sum_finiteExtensionFamilyMemberSupport_placeDegree, + sum_finiteExtensionFamilyMemberSupport_placeDegree] + _ ≤ 2 * finiteExtensionPositiveDegree K L (f iU) + + 2 * finiteExtensionPositiveDegree K L (f iV) := + Nat.add_le_add + (finiteExtensionPrincipalDivisor_supportDegree_le_two_mul_height + K L (f iU) hu) + (finiteExtensionPrincipalDivisor_supportDegree_le_two_mul_height + K L (f iV) hv) + _ = _ := by omega + +/-- The sum of the weighted orders over an arbitrary subset of the common +family place type is bounded below by minus the full pole height. -/ +theorem finiteExtensionFamilyWeightedOrder_sum_ge_neg_height + (f : A → L) (a : A) + (S : Finset (FiniteExtensionFamilyPlace K L f)) : + -((finiteExtensionHeight K L (f a) : ℕ) : ℤ) ≤ + ∑ w ∈ S, finiteExtensionFamilyWeightedOrder K L f a w := by + classical + let N := Finset.univ.filter + (fun w : FiniteExtensionFamilyPlace K L f => + finiteExtensionFamilyOrder K L f a w < 0) + let T := S.filter + (fun w : FiniteExtensionFamilyPlace K L f => + finiteExtensionFamilyOrder K L f a w < 0) + have hTN : T ⊆ N := by + intro w hw + exact Finset.mem_filter.mpr ⟨Finset.mem_univ w, + (Finset.mem_filter.mp hw).2⟩ + have hfilterTN : N.filter (fun w => w ∈ T) = T := by + ext w + simp only [Finset.mem_filter] + constructor + · exact fun hw => hw.2 + · exact fun hw => ⟨hTN hw, hw⟩ + have hMissingNonpos : + ∑ w ∈ N.filter (fun w => ¬ w ∈ T), + finiteExtensionFamilyWeightedOrder K L f a w ≤ 0 := by + apply Finset.sum_nonpos + intro w hw + have hneg : finiteExtensionFamilyOrder K L f a w < 0 := by + exact (Finset.mem_filter.mp (Finset.mem_filter.mp hw).1).2 + rw [finiteExtensionFamilyWeightedOrder] + exact mul_nonpos_of_nonpos_of_nonneg (le_of_lt hneg) (by positivity) + have hNegativeAllLeT : + (∑ w ∈ N, finiteExtensionFamilyWeightedOrder K L f a w) ≤ + ∑ w ∈ T, finiteExtensionFamilyWeightedOrder K L f a w := by + have hsplit := Finset.sum_filter_add_sum_filter_not N + (fun w => w ∈ T) (fun w => + finiteExtensionFamilyWeightedOrder K L f a w) + rw [hfilterTN] at hsplit + linarith + have hRemainingNonneg : + 0 ≤ ∑ w ∈ S.filter (fun w => + ¬ finiteExtensionFamilyOrder K L f a w < 0), + finiteExtensionFamilyWeightedOrder K L f a w := by + apply Finset.sum_nonneg + intro w hw + have hnonneg : 0 ≤ finiteExtensionFamilyOrder K L f a w := + le_of_not_gt (Finset.mem_filter.mp hw).2 + rw [finiteExtensionFamilyWeightedOrder] + exact mul_nonneg hnonneg (by positivity) + have hTLeS : + (∑ w ∈ T, finiteExtensionFamilyWeightedOrder K L f a w) ≤ + ∑ w ∈ S, finiteExtensionFamilyWeightedOrder K L f a w := by + have hsplit := Finset.sum_filter_add_sum_filter_not S + (fun w => finiteExtensionFamilyOrder K L f a w < 0) + (fun w => finiteExtensionFamilyWeightedOrder K L f a w) + change (∑ w ∈ T, finiteExtensionFamilyWeightedOrder K L f a w) + + ∑ w ∈ S.filter (fun w => + ¬ finiteExtensionFamilyOrder K L f a w < 0), + finiteExtensionFamilyWeightedOrder K L f a w = + ∑ w ∈ S, finiteExtensionFamilyWeightedOrder K L f a w at hsplit + linarith + have hNegativeAll := finiteExtensionFamilyWeightedNegativeSum K L f a + change (∑ w ∈ N, finiteExtensionFamilyWeightedOrder K L f a w) = + -((finiteExtensionHeight K L (f a) : ℕ) : ℤ) at hNegativeAll + rw [← hNegativeAll] + exact hNegativeAllLeT.trans hTLeS + +/-- The height bound for the reciprocal one-minus ratio used in the support +estimate. -/ +theorem finiteExtensionHeight_one_sub_div_one_sub_le + (u v : L) (hu : u ≠ 0) (hv : v ≠ 0) + (huone : u ≠ 1) (hvone : v ≠ 1) : + finiteExtensionHeight K L ((1 - v) / (1 - u)) ≤ + finiteExtensionHeight K L u + finiteExtensionHeight K L v := by + have hnum : 1 - v ≠ 0 := sub_ne_zero.mpr hvone.symm + have hden : 1 - u ≠ 0 := sub_ne_zero.mpr huone.symm + calc + finiteExtensionHeight K L ((1 - v) / (1 - u)) ≤ + finiteExtensionHeight K L (1 - v) + + finiteExtensionHeight K L (1 - u) := + finiteExtensionHeight_div_le K L (1 - v) (1 - u) hnum hden + _ = finiteExtensionHeight K L v + finiteExtensionHeight K L u := by + rw [finiteExtensionHeight_one_sub K L v hv hvone, + finiteExtensionHeight_one_sub K L u hu huone] + _ = _ := by omega + +/-- The source lower bound for the exceptional-set contribution of +`rho = (1-v)/(1-u)`. -/ +theorem finiteExtensionExceptionalSet_oneSubV_div_oneSubU_weightedOrder_lower_bound + (f : A → L) (iU iV iRho : A) + (hu : f iU ≠ 0) (hv : f iV ≠ 0) + (huone : f iU ≠ 1) (hvone : f iV ≠ 1) + (hRho : f iRho = (1 - f iV) / (1 - f iU)) : + -((finiteExtensionPositiveDegree K L (f iU) : ℕ) + + finiteExtensionPositiveDegree K L (f iV) : ℤ) ≤ + ∑ w ∈ finiteExtensionExceptionalSet K L f iU iV, + finiteExtensionFamilyWeightedOrder K L f iRho w := by + have hheight : + finiteExtensionHeight K L (f iRho) ≤ + finiteExtensionPositiveDegree K L (f iU) + + finiteExtensionPositiveDegree K L (f iV) := by + rw [hRho] + calc + finiteExtensionHeight K L ((1 - f iV) / (1 - f iU)) ≤ + finiteExtensionHeight K L (f iU) + + finiteExtensionHeight K L (f iV) := + finiteExtensionHeight_one_sub_div_one_sub_le K L + (f iU) (f iV) hu hv huone hvone + _ = _ := by + rw [← finiteExtensionPositiveDegree_eq_height K L (f iU) hu, + ← finiteExtensionPositiveDegree_eq_height K L (f iV) hv] + have hheightInt : + (finiteExtensionHeight K L (f iRho) : ℤ) ≤ + (finiteExtensionPositiveDegree K L (f iU) : ℤ) + + (finiteExtensionPositiveDegree K L (f iV) : ℤ) := by + exact_mod_cast hheight + exact (neg_le_neg hheightInt).trans + (finiteExtensionFamilyWeightedOrder_sum_ge_neg_height K L f iRho + (finiteExtensionExceptionalSet K L f iU iV)) + +/-- The same lower bound in the paper's orientation +`rho = (1-u)/(1-v)`. -/ +theorem finiteExtensionExceptionalSet_oneSubU_div_oneSubV_weightedOrder_lower_bound + (f : A → L) (iU iV iRho : A) + (hu : f iU ≠ 0) (hv : f iV ≠ 0) + (huone : f iU ≠ 1) (hvone : f iV ≠ 1) + (hRho : f iRho = (1 - f iU) / (1 - f iV)) : + -((finiteExtensionPositiveDegree K L (f iU) : ℕ) + + finiteExtensionPositiveDegree K L (f iV) : ℤ) ≤ + ∑ w ∈ finiteExtensionExceptionalSet K L f iU iV, + finiteExtensionFamilyWeightedOrder K L f iRho w := by + simpa [finiteExtensionExceptionalSet, Finset.union_comm, add_comm] using + finiteExtensionExceptionalSet_oneSubV_div_oneSubU_weightedOrder_lower_bound + K L f iV iU iRho hv hu hvone huone hRho + +omit [DecidableEq K] in +/-- Away from the exceptional set, `u` has order zero. -/ +theorem finiteExtensionFamilyOrder_u_eq_zero_outsideExceptionalSet + (f : A → L) (iU iV : A) (w : FiniteExtensionFamilyPlace K L f) + (hw : w ∉ finiteExtensionExceptionalSet K L f iU iV) : + finiteExtensionFamilyOrder K L f iU w = 0 := by + apply finiteExtensionFamilyOrder_eq_zero_of_not_mem_support K L f iU w + exact (not_or.mp ((mem_finiteExtensionExceptionalSet_iff K L f iU iV w).not.mp hw)).1 + +omit [DecidableEq K] in +/-- Away from the exceptional set, `v` has order zero. -/ +theorem finiteExtensionFamilyOrder_v_eq_zero_outsideExceptionalSet + (f : A → L) (iU iV : A) (w : FiniteExtensionFamilyPlace K L f) + (hw : w ∉ finiteExtensionExceptionalSet K L f iU iV) : + finiteExtensionFamilyOrder K L f iV w = 0 := by + apply finiteExtensionFamilyOrder_eq_zero_of_not_mem_support K L f iV w + exact (not_or.mp ((mem_finiteExtensionExceptionalSet_iff K L f iU iV w).not.mp hw)).2 + +omit [DecidableEq K] in +/-- Every positive-order place of `v` lies in the exceptional set. -/ +theorem finiteExtensionFamilyOrder_v_positive_mem_exceptionalSet + (f : A → L) (iU iV : A) (w : FiniteExtensionFamilyPlace K L f) + (hw : 0 < finiteExtensionFamilyOrder K L f iV w) : + w ∈ finiteExtensionExceptionalSet K L f iU iV := by + classical + rw [mem_finiteExtensionExceptionalSet_iff] + right + rw [Finsupp.mem_support_iff] + exact ne_of_gt hw + +omit [DecidableEq K] in +/-- Every individual grid monomial has order zero away from the exceptional +set. -/ +theorem finiteExtensionPrincipalDivisor_gridMonomial_eq_zero_outside + (f : A → L) (iU iV : A) (hu : f iU ≠ 0) (hv : f iV ≠ 0) + (r s : ℕ) (w : FiniteExtensionFamilyPlace K L f) + (hw : w ∉ finiteExtensionExceptionalSet K L f iU iV) : + finiteExtensionPrincipalDivisor K L + (f iU ^ r * f iV ^ s) w.1 = 0 := by + rw [finiteExtensionPrincipalDivisor_mul K L _ _ + (pow_ne_zero _ hu) (pow_ne_zero _ hv), + finiteExtensionPrincipalDivisor_pow K L (f iU) hu, + finiteExtensionPrincipalDivisor_pow K L (f iV) hv] + have hu0 := finiteExtensionFamilyOrder_u_eq_zero_outsideExceptionalSet + K L f iU iV w hw + have hv0 := finiteExtensionFamilyOrder_v_eq_zero_outsideExceptionalSet + K L f iU iV w hw + change finiteExtensionPrincipalDivisor K L (f iU) w.1 = 0 at hu0 + change finiteExtensionPrincipalDivisor K L (f iV) w.1 = 0 at hv0 + simp [hu0, hv0] + +omit [DecidableEq K] in +/-- The auxiliary grid product has order zero away from the zero and pole +places of `u` and `v`. -/ +theorem finiteExtensionPrincipalDivisor_auxiliaryGridProduct_eq_zero_outside + (f : A → L) (iU iV : A) (hu : f iU ≠ 0) (hv : f iV ≠ 0) + (h k : ℕ) (w : FiniteExtensionFamilyPlace K L f) + (hw : w ∉ finiteExtensionExceptionalSet K L f iU iV) : + finiteExtensionPrincipalDivisor K L + (finiteExtensionAuxiliaryGridProduct L (f iU) (f iV) h k) w.1 = 0 := by + rw [finiteExtensionPrincipalDivisor_auxiliaryGridProduct K L + (f iU) (f iV) hu hv h k] + have hu0 := finiteExtensionFamilyOrder_u_eq_zero_outsideExceptionalSet + K L f iU iV w hw + have hv0 := finiteExtensionFamilyOrder_v_eq_zero_outsideExceptionalSet + K L f iU iV w hw + change finiteExtensionPrincipalDivisor K L (f iU) w.1 = 0 at hu0 + change finiteExtensionPrincipalDivisor K L (f iV) w.1 = 0 at hv0 + simp [hu0, hv0] + +/-- A family entry equal to the grid product has family order zero away from +the exceptional set. -/ +theorem finiteExtensionFamilyOrder_gridProduct_eq_zero_outsideExceptionalSet + (f : A → L) (iU iV iGrid : A) (hu : f iU ≠ 0) (hv : f iV ≠ 0) + (h k : ℕ) + (hGrid : f iGrid = finiteExtensionAuxiliaryGridProduct L (f iU) (f iV) h k) + (w : FiniteExtensionFamilyPlace K L f) + (hw : w ∉ finiteExtensionExceptionalSet K L f iU iV) : + finiteExtensionFamilyOrder K L f iGrid w = 0 := by + rw [finiteExtensionFamilyOrder, hGrid] + exact finiteExtensionPrincipalDivisor_auxiliaryGridProduct_eq_zero_outside + K L f iU iV hu hv h k w hw + +section AlgebraicallyClosedConstants + +variable [IsAlgClosed K] + +/-- Over an algebraically closed constant field, the weighted boundary bound +is the ordinary cardinality bound used in the published proof. -/ +theorem finiteExtensionExceptionalSet_card_le + (f : A → L) (iU iV : A) (hu : f iU ≠ 0) (hv : f iV ≠ 0) : + (finiteExtensionExceptionalSet K L f iU iV).card ≤ + 2 * (finiteExtensionPositiveDegree K L (f iU) + + finiteExtensionPositiveDegree K L (f iV)) := by + have hbound := finiteExtensionExceptionalSet_weightedDegree_le + K L f iU iV hu hv + simpa [finiteExtensionPlaceDegree_eq_one K L] using hbound + +/-- Unweighted source estimate for `rho = (1-v)/(1-u)` over algebraically +closed constants. -/ +theorem finiteExtensionExceptionalSet_oneSubV_div_oneSubU_order_lower_bound + (f : A → L) (iU iV iRho : A) + (hu : f iU ≠ 0) (hv : f iV ≠ 0) + (huone : f iU ≠ 1) (hvone : f iV ≠ 1) + (hRho : f iRho = (1 - f iV) / (1 - f iU)) : + -((finiteExtensionPositiveDegree K L (f iU) : ℕ) + + finiteExtensionPositiveDegree K L (f iV) : ℤ) ≤ + ∑ w ∈ finiteExtensionExceptionalSet K L f iU iV, + finiteExtensionFamilyOrder K L f iRho w := by + simpa only [finiteExtensionFamilyWeightedOrder_eq_order K L f iRho] using + finiteExtensionExceptionalSet_oneSubV_div_oneSubU_weightedOrder_lower_bound + K L f iU iV iRho hu hv huone hvone hRho + +/-- Unweighted source estimate in the paper's orientation +`rho = (1-u)/(1-v)`. -/ +theorem finiteExtensionExceptionalSet_oneSubU_div_oneSubV_order_lower_bound + (f : A → L) (iU iV iRho : A) + (hu : f iU ≠ 0) (hv : f iV ≠ 0) + (huone : f iU ≠ 1) (hvone : f iV ≠ 1) + (hRho : f iRho = (1 - f iU) / (1 - f iV)) : + -((finiteExtensionPositiveDegree K L (f iU) : ℕ) + + finiteExtensionPositiveDegree K L (f iV) : ℤ) ≤ + ∑ w ∈ finiteExtensionExceptionalSet K L f iU iV, + finiteExtensionFamilyOrder K L f iRho w := by + simpa only [finiteExtensionFamilyWeightedOrder_eq_order K L f iRho] using + finiteExtensionExceptionalSet_oneSubU_div_oneSubV_weightedOrder_lower_bound + K L f iU iV iRho hu hv huone hvone hRho + +end AlgebraicallyClosedConstants + +end ExceptionalSet + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/FiniteExtensionExhaustiveProductFormula.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/FiniteExtensionExhaustiveProductFormula.lean new file mode 100644 index 0000000000..337e3b60c6 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/FiniteExtensionExhaustiveProductFormula.lean @@ -0,0 +1,359 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.InfinityPlace +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.RatFuncExhaustiveProductFormula +public import Mathlib.NumberTheory.FunctionField + +/-! +# Exhaustive product formula in a finite extension of `K(X)` + +This file combines the norm/count formula at every finite polynomial place +with the corresponding formula at infinity. An element of a finite +separable extension is transported to the canonical fraction fields of the +two integral closures. Naturality of the field norm shows that both models +compute the same norm in `K(X)`. + +The final theorem sums the residue-degree-weighted orders at every prime +above every finite place, with the finite-place degree factor, and at every +prime above infinity. The total is zero. +-/ + +@[expose] public section + +open scoped nonZeroDivisors Polynomial +open IsDedekindDomain Multiplicative WithZero + +attribute [local instance] FractionRing.liftAlgebra + FractionRing.isScalarTower_liftAlgebra + +namespace BGS.CorvajaZannier + +noncomputable section + +variable (K : Type*) [Field K] [DecidableEq K] [DecidableEq (RatFunc K)] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +local instance (priority := 10) polynomialAlgebra : Algebra K[X] L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K[X] (RatFunc K))) + +local instance polynomialScalarTower : IsScalarTower K[X] (RatFunc K) L := + ⟨fun r s x ↦ by + simp only [Algebra.smul_def] + rw [map_mul] + change (algebraMap (RatFunc K) L (algebraMap K[X] (RatFunc K) r) * + algebraMap (RatFunc K) L s) * x = + algebraMap K[X] L r * (algebraMap (RatFunc K) L s * x) + rw [show algebraMap K[X] L r = + algebraMap (RatFunc K) L (algebraMap K[X] (RatFunc K) r) by rfl] + ring⟩ + +abbrev RatFuncFiniteIntegralClosure := FunctionField.ringOfIntegers K L + +noncomputable def ratFuncFiniteFractionRingEquiv : + FractionRing K[X] ≃ₐ[K[X]] RatFunc K := + FractionRing.algEquiv K[X] (RatFunc K) + +omit [DecidableEq K] [DecidableEq (RatFunc K)] in +theorem ratFuncFiniteFractionRingEquiv_valuation + (v : HeightOneSpectrum K[X]) (x : FractionRing K[X]) : + v.valuation (RatFunc K) (ratFuncFiniteFractionRingEquiv K x) = + v.valuation (FractionRing K[X]) x := by + obtain ⟨a, b, hb, rfl⟩ := IsFractionRing.div_surjective K[X] x + rw [map_div₀, (ratFuncFiniteFractionRingEquiv K).commutes a, + (ratFuncFiniteFractionRingEquiv K).commutes b, + Valuation.map_div, Valuation.map_div, + v.valuation_of_algebraMap, v.valuation_of_algebraMap, + v.valuation_of_algebraMap, v.valuation_of_algebraMap] + +omit [DecidableEq K] [DecidableEq (RatFunc K)] in +theorem ratFuncFiniteFractionRing_order_eq + (v : HeightOneSpectrum K[X]) (x : FractionRing K[X]) (hx : x ≠ 0) : + finitePlaceOrder v x = + ratFuncFiniteOrder v (ratFuncFiniteFractionRingEquiv K x) := by + let e := ratFuncFiniteFractionRingEquiv K + have hcanon := valuation_eq_exp_neg_finitePlaceOrder + (R := K[X]) (L := FractionRing K[X]) v x hx + have he_ne : e x ≠ 0 := by simpa using hx + have hactual := valuation_eq_exp_neg_finitePlaceOrder + (R := K[X]) (L := RatFunc K) v (e x) he_ne + have hval := ratFuncFiniteFractionRingEquiv_valuation K v x + have hexp : exp (-finitePlaceOrder v x) = + exp (-finitePlaceOrder v (e x)) := by + rw [← hcanon, ← hactual] + exact hval.symm + rw [exp_inj] at hexp + change finitePlaceOrder v x = finitePlaceOrder v (e x) + omega + +noncomputable def ratFuncFiniteIntegralClosureFractionRingEquiv : + FractionRing (RatFuncFiniteIntegralClosure K L) ≃ₐ[RatFuncFiniteIntegralClosure K L] L := + FractionRing.algEquiv (RatFuncFiniteIntegralClosure K L) L + +local instance finiteIntegralClosureModuleFinite : + Module.Finite K[X] (RatFuncFiniteIntegralClosure K L) := + Module.IsNoetherian.finite K[X] (RatFuncFiniteIntegralClosure K L) + +local instance finiteIntegralClosureIsIntegral : + Algebra.IsIntegral K[X] (RatFuncFiniteIntegralClosure K L) := + IsIntegralClosure.isIntegral_algebra K[X] L + +local instance polynomialTorsionFreeTop : Module.IsTorsionFree K[X] L := + Module.IsTorsionFree.trans_faithfulSMul K[X] (RatFunc K) L + +local instance finiteIntegralClosureIsTorsionFree : + Module.IsTorsionFree K[X] (RatFuncFiniteIntegralClosure K L) := + IsIntegralClosure.isTorsionFree K[X] L + +local instance finiteBaseFaithfulSMulExtensionFractionRing : + FaithfulSMul K[X] (FractionRing (RatFuncFiniteIntegralClosure K L)) := by + rw [faithfulSMul_iff_algebraMap_injective] + intro x y hxy + have hS := IsFractionRing.injective (RatFuncFiniteIntegralClosure K L) + (FractionRing (RatFuncFiniteIntegralClosure K L)) hxy + exact FunctionField.ringOfIntegers.algebraMap_injective K L hS + +local instance finiteFractionRingAlgebra : + Algebra (FractionRing K[X]) + (FractionRing (RatFuncFiniteIntegralClosure K L)) := + FractionRing.liftAlgebra K[X] + (FractionRing (RatFuncFiniteIntegralClosure K L)) + +local instance finiteFractionRingSeparable : + Algebra.IsSeparable (FractionRing K[X]) + (FractionRing (RatFuncFiniteIntegralClosure K L)) := by + refine Algebra.IsSeparable.of_equiv_equiv + (ratFuncFiniteFractionRingEquiv K).symm.toRingEquiv + (ratFuncFiniteIntegralClosureFractionRingEquiv K L).symm.toRingEquiv ?_ + ext z + exact IsFractionRing.algEquiv_commutes + (ratFuncFiniteFractionRingEquiv K).symm + (ratFuncFiniteIntegralClosureFractionRingEquiv K L).symm z + +local instance infinityIntegralClosureModuleFinite' : + Module.Finite (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.finite (RatFuncInfinityIntegers K) (RatFunc K) L + (RatFuncInfinityIntegralClosure K L) + +local instance infinityIntegralClosureIsDedekindDomain' : + IsDedekindDomain (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.isDedekindDomain (RatFuncInfinityIntegers K) (RatFunc K) L + (RatFuncInfinityIntegralClosure K L) + +local instance infinityIntegralClosureIsFractionRing' : + IsFractionRing (RatFuncInfinityIntegralClosure K L) L := + IsIntegralClosure.isFractionRing_of_finite_extension + (RatFuncInfinityIntegers K) (RatFunc K) L + (RatFuncInfinityIntegralClosure K L) + +noncomputable def ratFuncInfinityIntegralClosureFractionRingEquiv : + FractionRing (RatFuncInfinityIntegralClosure K L) ≃ₐ[RatFuncInfinityIntegralClosure K L] L := + FractionRing.algEquiv (RatFuncInfinityIntegralClosure K L) L + +local instance infinityBaseFaithfulSMulExtensionFractionRing' : + FaithfulSMul (RatFuncInfinityIntegers K) + (FractionRing (RatFuncInfinityIntegralClosure K L)) := by + rw [faithfulSMul_iff_algebraMap_injective] + intro x y hxy + have hS := IsFractionRing.injective (RatFuncInfinityIntegralClosure K L) + (FractionRing (RatFuncInfinityIntegralClosure K L)) hxy + have hL := congrArg Subtype.val hS + apply Subtype.ext + apply (algebraMap (RatFunc K) L).injective + change algebraMap (RatFunc K) L (x : RatFunc K) = + algebraMap (RatFunc K) L (y : RatFunc K) + exact hL + +local instance infinityFractionRingAlgebra' : + Algebra (FractionRing (RatFuncInfinityIntegers K)) + (FractionRing (RatFuncInfinityIntegralClosure K L)) := + FractionRing.liftAlgebra (RatFuncInfinityIntegers K) + (FractionRing (RatFuncInfinityIntegralClosure K L)) + +local instance infinityFractionRingSeparable' : + Algebra.IsSeparable (FractionRing (RatFuncInfinityIntegers K)) + (FractionRing (RatFuncInfinityIntegralClosure K L)) := by + refine Algebra.IsSeparable.of_equiv_equiv + (ratFuncInfinityFractionRingEquiv K).symm.toRingEquiv + (ratFuncInfinityIntegralClosureFractionRingEquiv K L).symm.toRingEquiv ?_ + ext z + exact IsFractionRing.algEquiv_commutes + (ratFuncInfinityFractionRingEquiv K).symm + (ratFuncInfinityIntegralClosureFractionRingEquiv K L).symm z + +omit [DecidableEq K] [DecidableEq (RatFunc K)] + [Algebra.IsSeparable (RatFunc K) L] in +theorem ratFuncFinite_norm_transport (x : L) : + ratFuncFiniteFractionRingEquiv K + (Algebra.norm (FractionRing K[X]) + ((ratFuncFiniteIntegralClosureFractionRingEquiv K L).symm x)) = + Algebra.norm (RatFunc K) x := by + let eA := ratFuncFiniteFractionRingEquiv K + let eS := ratFuncFiniteIntegralClosureFractionRingEquiv K L + have hcompat : + RingHom.comp (algebraMap (RatFunc K) L) eA.toRingEquiv.toRingHom = + RingHom.comp eS.toRingEquiv.toRingHom + (algebraMap (FractionRing K[X]) + (FractionRing (RatFuncFiniteIntegralClosure K L))) := by + ext z + exact IsFractionRing.algEquiv_commutes eA eS z + have hnorm := Algebra.norm_eq_of_equiv_equiv + eA.toRingEquiv eS.toRingEquiv hcompat (eS.symm x) + calc + eA (Algebra.norm (FractionRing K[X]) (eS.symm x)) = + eA (eA.symm (Algebra.norm (RatFunc K) (eS (eS.symm x)))) := + congrArg eA hnorm + _ = Algebra.norm (RatFunc K) x := by simp + +omit [DecidableEq K] [Algebra.IsSeparable (RatFunc K) L] + in +theorem ratFuncInfinity_norm_transport (x : L) : + ratFuncInfinityFractionRingEquiv K + (Algebra.norm (FractionRing (RatFuncInfinityIntegers K)) + ((ratFuncInfinityIntegralClosureFractionRingEquiv K L).symm x)) = + Algebra.norm (RatFunc K) x := by + let eA := ratFuncInfinityFractionRingEquiv K + let eS := ratFuncInfinityIntegralClosureFractionRingEquiv K L + have hcompat : + RingHom.comp (algebraMap (RatFunc K) L) eA.toRingEquiv.toRingHom = + RingHom.comp eS.toRingEquiv.toRingHom + (algebraMap (FractionRing (RatFuncInfinityIntegers K)) + (FractionRing (RatFuncInfinityIntegralClosure K L))) := by + ext z + exact IsFractionRing.algEquiv_commutes eA eS z + have hnorm := Algebra.norm_eq_of_equiv_equiv + eA.toRingEquiv eS.toRingEquiv hcompat (eS.symm x) + calc + eA (Algebra.norm (FractionRing (RatFuncInfinityIntegers K)) (eS.symm x)) = + eA (eA.symm (Algebra.norm (RatFunc K) (eS (eS.symm x)))) := + congrArg eA hnorm + _ = Algebra.norm (RatFunc K) x := by simp + +omit [DecidableEq K] [DecidableEq (RatFunc K)] in +theorem finitePrimesAbove_weightedOrder_eq_normOrder + (p : HeightOneSpectrum K[X]) (x : L) (hx : x ≠ 0) : + (∑ P : p.asIdeal.primesOver (RatFuncFiniteIntegralClosure K L), + (P.1.inertiaDeg K[X] : ℤ) * + finitePlaceOrder (primeOverHeightOne p P) + ((ratFuncFiniteIntegralClosureFractionRingEquiv K L).symm x)) = + ratFuncFiniteOrder p (Algebra.norm (RatFunc K) x) := by + let y := (ratFuncFiniteIntegralClosureFractionRingEquiv K L).symm x + have hy : y ≠ 0 := by simpa [y] using hx + have hcount := count_spanSingleton_norm_eq_sum_inertiaDeg_mul_count + (R := K[X]) (S := RatFuncFiniteIntegralClosure K L) p y + change finitePlaceOrder p (Algebra.norm (FractionRing K[X]) y) = + ∑ P : p.asIdeal.primesOver (RatFuncFiniteIntegralClosure K L), + (P.1.inertiaDeg K[X] : ℤ) * + finitePlaceOrder (primeOverHeightOne p P) y at hcount + have hnorm_ne : Algebra.norm (FractionRing K[X]) y ≠ 0 := by + intro hzero + have hmapped := congrArg (ratFuncFiniteFractionRingEquiv K) hzero + rw [map_zero, ratFuncFinite_norm_transport K L x] at hmapped + exact (Algebra.norm_ne_zero_iff.mpr hx) hmapped + calc + _ = finitePlaceOrder p (Algebra.norm (FractionRing K[X]) y) := hcount.symm + _ = ratFuncFiniteOrder p + (ratFuncFiniteFractionRingEquiv K + (Algebra.norm (FractionRing K[X]) y)) := + ratFuncFiniteFractionRing_order_eq K p _ hnorm_ne + _ = ratFuncFiniteOrder p (Algebra.norm (RatFunc K) x) := by + rw [ratFuncFinite_norm_transport K L x] + +omit [DecidableEq K] in +theorem primesAboveInfinity_weightedOrder_eq_normInfinityOrder + (x : L) (hx : x ≠ 0) : + (∑ P : (ratFuncInfinityPlace K).asIdeal.primesOver + (RatFuncInfinityIntegralClosure K L), + (P.1.inertiaDeg (RatFuncInfinityIntegers K) : ℤ) * + finitePlaceOrder (primeOverHeightOne (ratFuncInfinityPlace K) P) + ((ratFuncInfinityIntegralClosureFractionRingEquiv K L).symm x)) = + ratFuncInfinityOrder (Algebra.norm (RatFunc K) x) := by + let y := (ratFuncInfinityIntegralClosureFractionRingEquiv K L).symm x + have hy : y ≠ 0 := by simpa [y] using hx + have hcount := count_spanSingleton_norm_at_infinity_eq_sum + (K := K) (L := L) y + change finitePlaceOrder (ratFuncInfinityPlace K) + (Algebra.norm (FractionRing (RatFuncInfinityIntegers K)) y) = + ∑ P : (ratFuncInfinityPlace K).asIdeal.primesOver + (RatFuncInfinityIntegralClosure K L), + (P.1.inertiaDeg (RatFuncInfinityIntegers K) : ℤ) * + finitePlaceOrder (primeOverHeightOne (ratFuncInfinityPlace K) P) y at hcount + have hnorm_ne : + Algebra.norm (FractionRing (RatFuncInfinityIntegers K)) y ≠ 0 := by + intro hzero + have hmapped := congrArg (ratFuncInfinityFractionRingEquiv K) hzero + rw [map_zero, ratFuncInfinity_norm_transport K L x] at hmapped + exact (Algebra.norm_ne_zero_iff.mpr hx) hmapped + calc + _ = finitePlaceOrder (ratFuncInfinityPlace K) + (Algebra.norm (FractionRing (RatFuncInfinityIntegers K)) y) := hcount.symm + _ = ratFuncInfinityOrder + (ratFuncInfinityFractionRingEquiv K + (Algebra.norm (FractionRing (RatFuncInfinityIntegers K)) y)) := + ratFuncInfinityFractionRing_order_eq K _ hnorm_ne + _ = ratFuncInfinityOrder (Algebra.norm (RatFunc K) x) := by + rw [ratFuncInfinity_norm_transport K L x] + +/-- The exhaustive finite-place contribution in `L`, grouped by the finite +places of `K(X)` supporting the divisor of the norm. -/ +def finiteExtensionFinitePlaceDegreeSum (x : L) : ℤ := + (ratFuncFiniteDivisor (Algebra.norm (RatFunc K) x)).sum + (fun p _ ↦ + (∑ P : p.asIdeal.primesOver (RatFuncFiniteIntegralClosure K L), + (P.1.inertiaDeg K[X] : ℤ) * + finitePlaceOrder (primeOverHeightOne p P) + ((ratFuncFiniteIntegralClosureFractionRingEquiv K L).symm x)) * + (ratFuncFinitePlaceDegree p : ℤ)) + +/-- The contribution of all primes of `L` above the place at infinity. -/ +def finiteExtensionInfinityOrderSum (x : L) : ℤ := + ∑ P : (ratFuncInfinityPlace K).asIdeal.primesOver + (RatFuncInfinityIntegralClosure K L), + (P.1.inertiaDeg (RatFuncInfinityIntegers K) : ℤ) * + finitePlaceOrder (primeOverHeightOne (ratFuncInfinityPlace K) P) + ((ratFuncInfinityIntegralClosureFractionRingEquiv K L).symm x) + +omit [DecidableEq (RatFunc K)] in +theorem finiteExtensionFinitePlaceDegreeSum_eq_normFinitePlaceDegreeSum + (x : L) (hx : x ≠ 0) : + finiteExtensionFinitePlaceDegreeSum K L x = + ratFuncExhaustiveFinitePlaceDegreeSum (Algebra.norm (RatFunc K) x) := by + rw [finiteExtensionFinitePlaceDegreeSum, + ratFuncExhaustiveFinitePlaceDegreeSum] + apply Finsupp.sum_congr + intro p _ + rw [finitePrimesAbove_weightedOrder_eq_normOrder K L p x hx, + ratFuncFiniteDivisor_apply] + +omit [DecidableEq K] in +theorem finiteExtensionInfinityOrderSum_eq_normInfinityOrder + (x : L) (hx : x ≠ 0) : + finiteExtensionInfinityOrderSum K L x = + ratFuncInfinityOrder (Algebra.norm (RatFunc K) x) := by + exact primesAboveInfinity_weightedOrder_eq_normInfinityOrder K L x hx + +/-- The exhaustive weighted principal-divisor product formula in a finite +separable extension `L / K(X)`. Every finite prime is grouped under its base +finite place and weighted by residue degree times the degree of that base +place; the second sum contains every prime above infinity. -/ +theorem finiteExtension_exhaustivePrincipalDivisor_productFormula + (x : L) (hx : x ≠ 0) : + finiteExtensionFinitePlaceDegreeSum K L x + + finiteExtensionInfinityOrderSum K L x = 0 := by + rw [finiteExtensionFinitePlaceDegreeSum_eq_normFinitePlaceDegreeSum K L x hx, + finiteExtensionInfinityOrderSum_eq_normInfinityOrder K L x hx] + apply ratFunc_exhaustiveFinitePlace_plus_infinity_productFormula + exact Algebra.norm_ne_zero_iff.mpr hx + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/FiniteExtensionGcdOutsideHeight.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/FiniteExtensionGcdOutsideHeight.lean new file mode 100644 index 0000000000..7548732e4f --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/FiniteExtensionGcdOutsideHeight.lean @@ -0,0 +1,179 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionCanonicalPlaceSum +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.TorsionExhaustiveGcdDivisorBound +public import Mathlib.Tactic + +/-! The gcd divisor is controlled by the poles of the one-minus quotient. -/ + +@[expose] public section + +open scoped BigOperators + +namespace BGS.CorvajaZannier + +noncomputable section + +variable (K : Type*) [Field K] [DecidableEq K] [DecidableEq (RatFunc K)] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +attribute [local instance] Classical.decEq + +omit [DecidableEq K] [FiniteDimensional (RatFunc K) L] [Algebra.IsSeparable (RatFunc K) L] in +/-- The local integer identity behind the Corvaja--Zannier comparison between +the gcd divisor and the pole height of `(1-u)/(1-v)`. -/ +theorem gcdMultiplicity_add_outsidePole_le_secondPositivePart + (S : Finset (FiniteExtensionPlace K L)) + (Du Dv Drho : FiniteExtensionPlace K L → ℤ) + (P : FiniteExtensionPlace K L) + (hRho : Drho P = Du P - Dv P) + (hOutside : P ∉ S → 0 ≤ Du P ∧ 0 ≤ Dv P) + (hInside : P ∈ S → min (Du P) (Dv P) ≤ 0) : + Int.toNat (min (Du P) (Dv P)) + + (if P ∉ S ∧ Drho P < 0 then (Drho P).natAbs else 0) ≤ + Int.toNat (Dv P) := by + by_cases hPS : P ∈ S + · have hmin := hInside hPS + have hminToNat : Int.toNat (min (Du P) (Dv P)) = 0 := + Int.toNat_of_nonpos hmin + simp [hPS, hminToNat] + · obtain ⟨hDu, hDv⟩ := hOutside hPS + rw [hRho] + by_cases hneg : Du P - Dv P < 0 + · simp only [hPS, not_false_eq_true, hneg, and_self, ite_eq_left] + have hmin : min (Du P) (Dv P) = Du P := + min_eq_left (sub_nonpos.mp (le_of_lt hneg)) + have hcast : + ((Int.toNat (min (Du P) (Dv P)) + + (Du P - Dv P).natAbs : ℕ) : ℤ) ≤ + (Int.toNat (Dv P) : ℤ) := by + rw [Nat.cast_add, Int.toNat_of_nonneg (le_min hDu hDv), + Int.toNat_of_nonneg hDv, Int.natCast_natAbs, + abs_of_nonpos (le_of_lt hneg), hmin] + omega + exact_mod_cast hcast + · have hnonneg : 0 ≤ Du P - Dv P := le_of_not_gt hneg + simp only [hPS, not_false_eq_true, hneg, and_false, ite_false, add_zero] + exact Int.toNat_le_toNat (min_le_right _ _) + +/-- If the local order of `rho` is the difference of the two one-minus +orders, those one-minus orders are nonnegative off `S`, and their minimum is +nonpositive on `S`, then gcd degree plus outside pole height is bounded by the +positive degree of the second one-minus function. -/ +theorem finiteExtensionGcdWeightedDegree_add_outsideHeight_le + (x y rho : L) (S : Finset (FiniteExtensionPlace K L)) + (hRho : ∀ P, finiteExtensionPrincipalDivisor K L rho P = + finiteExtensionPrincipalDivisor K L x P - + finiteExtensionPrincipalDivisor K L y P) + (hOutside : ∀ P, P ∉ S → + 0 ≤ finiteExtensionPrincipalDivisor K L x P ∧ + 0 ≤ finiteExtensionPrincipalDivisor K L y P) + (hInside : ∀ P, P ∈ S → + min (finiteExtensionPrincipalDivisor K L x P) + (finiteExtensionPrincipalDivisor K L y P) ≤ 0) : + finiteExtensionGcdWeightedDegree K L x y + + finiteExtensionOutsideHeight K L rho S ≤ + finiteExtensionPositiveDegree K L y := by + classical + let Dx := finiteExtensionPrincipalDivisor K L x + let Dy := finiteExtensionPrincipalDivisor K L y + let Drho := finiteExtensionPrincipalDivisor K L rho + let T : Finset (FiniteExtensionPlace K L) := + S ∪ Dx.support ∪ Dy.support ∪ Drho.support + have hGcdSupport : finiteExtensionGcdSupport K L x y ⊆ T := by + intro P hP + rcases Finset.mem_union.mp hP with hxP | hyP + · simp [T, Dx, hxP] + · simp [T, Dy, hyP] + have hRhoSupport : Drho.support ⊆ T := by + intro P hP + simp [T, hP] + have hYSupport : Dy.support ⊆ T := by + intro P hP + simp [T, hP] + have hGcd : finiteExtensionGcdWeightedDegree K L x y = + ∑ P ∈ T, Int.toNat (min (Dx P) (Dy P)) * + finiteExtensionPlaceDegree K L P := by + rw [finiteExtensionGcdWeightedDegree] + apply Finset.sum_subset hGcdSupport + intro P hPT hnot + have hx0 : Dx P = 0 := by + apply Finsupp.notMem_support_iff.mp + intro hxmem + exact hnot (by + rw [finiteExtensionGcdSupport] + exact Finset.mem_union_left _ hxmem) + have hy0 : Dy P = 0 := by + apply Finsupp.notMem_support_iff.mp + intro hymem + exact hnot (by + rw [finiteExtensionGcdSupport] + exact Finset.mem_union_right _ hymem) + simp [finiteExtensionGcdMultiplicity, Dx, Dy, hx0, hy0] + have hOutsideHeight : finiteExtensionOutsideHeight K L rho S = + ∑ P ∈ T, (if P ∉ S ∧ Drho P < 0 then (Drho P).natAbs else 0) * + finiteExtensionPlaceDegree K L P := by + rw [finiteExtensionOutsideHeight] + rw [Finset.sum_filter] + change (∑ P ∈ Drho.support, + if P ∉ S ∧ Drho P < 0 then + (Drho P).natAbs * finiteExtensionPlaceDegree K L P else 0) = _ + calc + _ = ∑ P ∈ Drho.support, + (if P ∉ S ∧ Drho P < 0 then (Drho P).natAbs else 0) * + finiteExtensionPlaceDegree K L P := by + apply Finset.sum_congr rfl + intro P hP + split_ifs <;> simp + _ = _ := by + apply Finset.sum_subset hRhoSupport + intro P hPT hnot + have hzero : Drho P = 0 := Finsupp.notMem_support_iff.mp hnot + simp [hzero] + have hPositive : finiteExtensionPositiveDegree K L y = + ∑ P ∈ T, Int.toNat (Dy P) * finiteExtensionPlaceDegree K L P := by + rw [finiteExtensionPositiveDegree] + rw [Finset.sum_filter] + change (∑ P ∈ Dy.support, + if 0 < Dy P then Int.toNat (Dy P) * + finiteExtensionPlaceDegree K L P else 0) = _ + calc + _ = ∑ P ∈ Dy.support, Int.toNat (Dy P) * + finiteExtensionPlaceDegree K L P := by + apply Finset.sum_congr rfl + intro P hP + by_cases hpos : 0 < Dy P + · simp [hpos] + · have hnonpos : Dy P ≤ 0 := le_of_not_gt hpos + simp [hpos, Int.toNat_of_nonpos hnonpos] + _ = _ := by + apply Finset.sum_subset hYSupport + intro P hPT hnot + have hzero : Dy P = 0 := Finsupp.notMem_support_iff.mp hnot + simp [hzero] + rw [hGcd, hOutsideHeight, hPositive, ← Finset.sum_add_distrib] + apply Finset.sum_le_sum + intro P hPT + have hlocal := gcdMultiplicity_add_outsidePole_le_secondPositivePart + K L S Dx Dy Drho P (hRho P) (hOutside P) (hInside P) + calc + Int.toNat (min (Dx P) (Dy P)) * finiteExtensionPlaceDegree K L P + + (if P ∉ S ∧ Drho P < 0 then (Drho P).natAbs else 0) * + finiteExtensionPlaceDegree K L P = + (Int.toNat (min (Dx P) (Dy P)) + + (if P ∉ S ∧ Drho P < 0 then (Drho P).natAbs else 0)) * + finiteExtensionPlaceDegree K L P := by rw [add_mul] + _ ≤ Int.toNat (Dy P) * finiteExtensionPlaceDegree K L P := + Nat.mul_le_mul_right (finiteExtensionPlaceDegree K L P) hlocal + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/FiniteExtensionOneSubGcdHeight.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/FiniteExtensionOneSubGcdHeight.lean new file mode 100644 index 0000000000..0ea2a2fc4c --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/FiniteExtensionOneSubGcdHeight.lean @@ -0,0 +1,293 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionGcdOutsideHeight +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionExceptionalSupport +public import Mathlib.Tactic + +/-! +# The gcd height of a function and its complement + +Control the common divisor of a function and one minus that function using local orders, +exceptional places, and outside height. +-/ + +@[expose] public section + +namespace BGS.CorvajaZannier + +noncomputable section + +open scoped nonZeroDivisors Polynomial BigOperators +open IsDedekindDomain + +variable (K : Type*) [Field K] [DecidableEq K] [DecidableEq (RatFunc K)] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +attribute [local instance] Classical.decEq + +local instance (priority := 10) oneSubGcdPolynomialAlgebra : Algebra K[X] L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K[X] (RatFunc K))) + +local instance oneSubGcdPolynomialScalarTower : + IsScalarTower K[X] (RatFunc K) L := + ⟨fun r s x => by + simp only [Algebra.smul_def] + rw [map_mul] + change (algebraMap (RatFunc K) L (algebraMap K[X] (RatFunc K) r) * + algebraMap (RatFunc K) L s) * x = + algebraMap K[X] L r * (algebraMap (RatFunc K) L s * x) + rw [show algebraMap K[X] L r = + algebraMap (RatFunc K) L (algebraMap K[X] (RatFunc K) r) by rfl] + ring⟩ + +local instance oneSubGcdFiniteIntegralClosureModuleFinite : + Module.Finite K[X] (RatFuncFiniteIntegralClosure K L) := + Module.IsNoetherian.finite K[X] (RatFuncFiniteIntegralClosure K L) + +local instance oneSubGcdFiniteIntegralClosureIsIntegral : + Algebra.IsIntegral K[X] (RatFuncFiniteIntegralClosure K L) := + IsIntegralClosure.isIntegral_algebra K[X] L + +local instance oneSubGcdPolynomialTorsionFreeTop : + Module.IsTorsionFree K[X] L := + Module.IsTorsionFree.trans_faithfulSMul K[X] (RatFunc K) L + +local instance oneSubGcdFiniteIntegralClosureIsTorsionFree : + Module.IsTorsionFree K[X] (RatFuncFiniteIntegralClosure K L) := + IsIntegralClosure.isTorsionFree K[X] L + +local instance oneSubGcdInfinityIntegralClosureModuleFinite : + Module.Finite (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.finite (RatFuncInfinityIntegers K) (RatFunc K) L + (RatFuncInfinityIntegralClosure K L) + +local instance oneSubGcdInfinityIntegralClosureIsIntegral : + Algebra.IsIntegral (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.isIntegral_algebra (RatFuncInfinityIntegers K) L + +local instance oneSubGcdInfinityTorsionFreeTop : + Module.IsTorsionFree (RatFuncInfinityIntegers K) L := + Module.IsTorsionFree.trans_faithfulSMul + (RatFuncInfinityIntegers K) (RatFunc K) L + +local instance oneSubGcdInfinityIntegralClosureIsTorsionFree : + Module.IsTorsionFree (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.isTorsionFree (RatFuncInfinityIntegers K) L + +local instance oneSubGcdInfinityIntegralClosureIsDedekindDomain : + IsDedekindDomain (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.isDedekindDomain (RatFuncInfinityIntegers K) (RatFunc K) L + (RatFuncInfinityIntegralClosure K L) + +omit [DecidableEq K] in +theorem finiteExtensionPrincipalDivisor_add_ge_min + (x y : L) (hx : x ≠ 0) (hy : y ≠ 0) (hxy : x + y ≠ 0) + (w : FiniteExtensionPlace K L) : + min (finiteExtensionPrincipalDivisor K L x w) + (finiteExtensionPrincipalDivisor K L y w) ≤ + finiteExtensionPrincipalDivisor K L (x + y) w := by + cases w with + | inl q => + let e := ratFuncFiniteIntegralClosureFractionRingEquiv K L + have hx' : e.symm x ≠ 0 := by simpa using e.symm.injective.ne hx + have hy' : e.symm y ≠ 0 := by simpa using e.symm.injective.ne hy + have hxy' : e.symm (x + y) ≠ 0 := by + simpa using e.symm.injective.ne hxy + simp only [finiteExtensionPrincipalDivisor_inl] + change min (finitePlaceOrder q (e.symm x)) + (finitePlaceOrder q (e.symm y)) ≤ + finitePlaceOrder q (e.symm (x + y)) + have hadd : e.symm (x + y) = e.symm x + e.symm y := + e.symm.map_add x y + rw [hadd] + exact finitePlaceOrder_add_ge_min q (e.symm x) (e.symm y) + hx' hy' (by rw [← hadd]; exact hxy') + | inr P => + let q := primeOverHeightOne (ratFuncInfinityPlace K) P + let e := ratFuncInfinityIntegralClosureFractionRingEquiv K L + have hx' : e.symm x ≠ 0 := by simpa using e.symm.injective.ne hx + have hy' : e.symm y ≠ 0 := by simpa using e.symm.injective.ne hy + have hxy' : e.symm (x + y) ≠ 0 := by + simpa using e.symm.injective.ne hxy + simp only [finiteExtensionPrincipalDivisor_inr] + change min (finitePlaceOrder q (e.symm x)) + (finitePlaceOrder q (e.symm y)) ≤ + finitePlaceOrder q (e.symm (x + y)) + have hadd : e.symm (x + y) = e.symm x + e.symm y := + e.symm.map_add x y + rw [hadd] + exact finitePlaceOrder_add_ge_min q (e.symm x) (e.symm y) + hx' hy' (by rw [← hadd]; exact hxy') + +private theorem finitePlaceOrder_neg_oneSubGcd + {R F : Type*} [CommRing R] [IsDedekindDomain R] + [Field F] [Algebra R F] [IsFractionRing R F] + (w : HeightOneSpectrum R) (x : F) (hx : x ≠ 0) : + finitePlaceOrder w (-x) = finitePlaceOrder w x := by + have hval : (w.valuation F) (-x) = (w.valuation F) x := by simp + rw [valuation_eq_exp_neg_finitePlaceOrder w (-x) (neg_ne_zero.mpr hx), + valuation_eq_exp_neg_finitePlaceOrder w x hx] at hval + have horder := WithZero.exp_injective hval + omega + +omit [DecidableEq K] in +theorem finiteExtensionPrincipalDivisor_neg_apply + (x : L) (hx : x ≠ 0) (w : FiniteExtensionPlace K L) : + finiteExtensionPrincipalDivisor K L (-x) w = + finiteExtensionPrincipalDivisor K L x w := by + cases w with + | inl q => + simp only [finiteExtensionPrincipalDivisor_inl, map_neg] + exact finitePlaceOrder_neg_oneSubGcd q _ + (by simpa using + (ratFuncFiniteIntegralClosureFractionRingEquiv K L).symm.injective.ne hx) + | inr P => + simp only [finiteExtensionPrincipalDivisor_inr, map_neg] + exact finitePlaceOrder_neg_oneSubGcd + (primeOverHeightOne (ratFuncInfinityPlace K) P) _ + (by simpa using + (ratFuncInfinityIntegralClosureFractionRingEquiv K L).symm.injective.ne hx) + +omit [DecidableEq K] in +theorem finiteExtensionPrincipalDivisor_one_sub_nonnegative_of_eq_zero + (x : L) (hxone : x ≠ 1) + (w : FiniteExtensionPlace K L) + (hzero : finiteExtensionPrincipalDivisor K L x w = 0) : + 0 ≤ finiteExtensionPrincipalDivisor K L (1 - x) w := by + by_contra h + have hneg : finiteExtensionPrincipalDivisor K L (1 - x) w < 0 := + lt_of_not_ge h + have hsub : (1 : L) - x ≠ 0 := sub_ne_zero.mpr hxone.symm + have heq := finiteExtensionPrincipalDivisor_one_sub_apply_of_neg + K L (1 - x) hsub w hneg + rw [show (1 : L) - (1 - x) = x by ring] at heq + omega + +omit [DecidableEq K] in +theorem finiteExtensionPrincipalDivisor_eq_zero_of_one_sub_pos + (x : L) (hx : x ≠ 0) (hxone : x ≠ 1) + (w : FiniteExtensionPlace K L) + (hpos : 0 < finiteExtensionPrincipalDivisor K L (1 - x) w) : + finiteExtensionPrincipalDivisor K L x w = 0 := by + have hsub : (1 : L) - x ≠ 0 := sub_ne_zero.mpr hxone.symm + have hlower := finiteExtensionPrincipalDivisor_add_ge_min + K L (1 : L) (-(1 - x)) one_ne_zero (neg_ne_zero.mpr hsub) + (by simpa using hx) w + rw [finiteExtensionPrincipalDivisor_one K L, + show (1 : L) + -(1 - x) = x by ring] at hlower + simp only [Finsupp.zero_apply] at hlower + have hnegOrder : + finiteExtensionPrincipalDivisor K L (-(1 - x)) w = + finiteExtensionPrincipalDivisor K L (1 - x) w := + finiteExtensionPrincipalDivisor_neg_apply K L (1 - x) hsub w + rw [hnegOrder] at hlower + have hxnonneg : 0 ≤ finiteExtensionPrincipalDivisor K L x w := by + simpa [min_eq_left (le_of_lt hpos)] using hlower + have hreverse := finiteExtensionPrincipalDivisor_add_ge_min + K L x (1 - x) hx hsub (by simp) w + rw [show x + (1 - x) = (1 : L) by ring, + finiteExtensionPrincipalDivisor_one K L] at hreverse + simp only [Finsupp.zero_apply] at hreverse + rcases le_total (finiteExtensionPrincipalDivisor K L x w) + (finiteExtensionPrincipalDivisor K L (1 - x) w) with hle | hle + · rw [min_eq_left hle] at hreverse + omega + · rw [min_eq_right hle] at hreverse + omega + +/-- The exceptional places used in Proposition 2: exactly the zeroes and +poles of the two coordinates. -/ +def propositionTwoExceptionalPlaces (u v : L) : + Finset (FiniteExtensionPlace K L) := by + classical + exact (finiteExtensionPrincipalDivisor K L u).support ∪ + (finiteExtensionPrincipalDivisor K L v).support + +/-- The divisor-theoretic gcd comparison used in Proposition 2, now on the +actual exhaustive place type used by the canonical Wronskian sum. -/ +theorem finiteExtensionOneSubGcd_add_outsideHeight_le_positiveDegree + (u v : L) (hu : u ≠ 0) (hv : v ≠ 0) + (huone : u ≠ 1) (hvone : v ≠ 1) : + finiteExtensionGcdWeightedDegree K L (1 - u) (1 - v) + + finiteExtensionOutsideHeight K L ((1 - u) / (1 - v)) + (propositionTwoExceptionalPlaces K L u v) ≤ + finiteExtensionPositiveDegree K L (1 - v) := by + apply finiteExtensionGcdWeightedDegree_add_outsideHeight_le + · intro P + have huSub : (1 : L) - u ≠ 0 := sub_ne_zero.mpr huone.symm + have hvSub : (1 : L) - v ≠ 0 := sub_ne_zero.mpr hvone.symm + have hdiv := congrArg (fun D => D P) + (finiteExtensionPrincipalDivisor_div K L (1 - u) (1 - v) + huSub hvSub) + simpa using hdiv + · intro P hP + have hu0 : finiteExtensionPrincipalDivisor K L u P = 0 := by + apply Finsupp.notMem_support_iff.mp + intro huP + exact hP (by + rw [propositionTwoExceptionalPlaces] + exact Finset.mem_union_left _ huP) + have hv0 : finiteExtensionPrincipalDivisor K L v P = 0 := by + apply Finsupp.notMem_support_iff.mp + intro hvP + exact hP (by + rw [propositionTwoExceptionalPlaces] + exact Finset.mem_union_right _ hvP) + exact ⟨ + finiteExtensionPrincipalDivisor_one_sub_nonnegative_of_eq_zero + K L u huone P hu0, + finiteExtensionPrincipalDivisor_one_sub_nonnegative_of_eq_zero + K L v hvone P hv0⟩ + · intro P hP + by_contra hmin + have hminpos : 0 < min + (finiteExtensionPrincipalDivisor K L (1 - u) P) + (finiteExtensionPrincipalDivisor K L (1 - v) P) := + lt_of_not_ge hmin + have huPos : 0 < finiteExtensionPrincipalDivisor K L (1 - u) P := + lt_of_lt_of_le hminpos (min_le_left _ _) + have hvPos : 0 < finiteExtensionPrincipalDivisor K L (1 - v) P := + lt_of_lt_of_le hminpos (min_le_right _ _) + have hu0 := finiteExtensionPrincipalDivisor_eq_zero_of_one_sub_pos + K L u hu huone P huPos + have hv0 := finiteExtensionPrincipalDivisor_eq_zero_of_one_sub_pos + K L v hv hvone P hvPos + rw [propositionTwoExceptionalPlaces] at hP + rcases Finset.mem_union.mp hP with huP | hvP + · exact (Finsupp.mem_support_iff.mp huP) hu0 + · exact (Finsupp.mem_support_iff.mp hvP) hv0 + +/-- In the gcd comparison, the positive degree of `1-v` is exactly the +coordinate height, hence the positive degree of `v`. -/ +theorem finiteExtensionOneSubGcd_add_outsideHeight_le_positiveDegree_coordinate + (u v : L) (hu : u ≠ 0) (hv : v ≠ 0) + (huone : u ≠ 1) (hvone : v ≠ 1) : + finiteExtensionGcdWeightedDegree K L (1 - u) (1 - v) + + finiteExtensionOutsideHeight K L ((1 - u) / (1 - v)) + (propositionTwoExceptionalPlaces K L u v) ≤ + finiteExtensionPositiveDegree K L v := by + calc + _ ≤ finiteExtensionPositiveDegree K L (1 - v) := + finiteExtensionOneSubGcd_add_outsideHeight_le_positiveDegree + K L u v hu hv huone hvone + _ = finiteExtensionPositiveDegree K L v := by + rw [finiteExtensionPositiveDegree_eq_height K L (1 - v) + (sub_ne_zero.mpr hvone.symm), + finiteExtensionHeight_one_sub K L v hv hvone, + ← finiteExtensionPositiveDegree_eq_height K L v hv] + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/FiniteExtensionPolynomialHeight.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/FiniteExtensionPolynomialHeight.lean new file mode 100644 index 0000000000..f6722e1e2d --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/FiniteExtensionPolynomialHeight.lean @@ -0,0 +1,296 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionPrincipalDivisor +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.DedekindPlaceOrder +public import Mathlib.Tactic + +/-! +# Height of a polynomial in a finite rational-function extension + +For a nonzero polynomial `P : K[X]`, regarded first as a rational function and +then as an element of a finite separable extension `L / K(X)`, this file proves +that the positive degree of its exhaustive principal divisor is + +`Module.finrank (RatFunc K) L * P.natDegree`. + +The proof is place-theoretic. At finite places the lift is integral, hence has +nonnegative order. Above infinity its inverse is integral, hence its order is +nonpositive. The positive part is therefore exactly the finite-place degree +sum, which is evaluated by the norm and the rational-function product formula. +No algebraic-closedness hypothesis on the constant field is needed. +-/ + +@[expose] public section + +open scoped nonZeroDivisors Polynomial +open IsDedekindDomain Multiplicative WithZero + +namespace BGS.CorvajaZannier + +noncomputable section + +attribute [local instance] FractionRing.liftAlgebra + FractionRing.isScalarTower_liftAlgebra + +variable (K : Type*) [Field K] [DecidableEq K] [DecidableEq (RatFunc K)] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +local instance (priority := 10) polynomialHeightPolynomialAlgebra : Algebra K[X] L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K[X] (RatFunc K))) + +local instance polynomialHeightPolynomialScalarTower : + IsScalarTower K[X] (RatFunc K) L := + ⟨fun r s x => by + simp only [Algebra.smul_def] + rw [map_mul] + change (algebraMap (RatFunc K) L (algebraMap K[X] (RatFunc K) r) * + algebraMap (RatFunc K) L s) * x = + algebraMap K[X] L r * (algebraMap (RatFunc K) L s * x) + rw [show algebraMap K[X] L r = + algebraMap (RatFunc K) L (algebraMap K[X] (RatFunc K) r) by rfl] + ring⟩ + +local instance polynomialHeightFiniteIntegralClosureModuleFinite : + Module.Finite K[X] (RatFuncFiniteIntegralClosure K L) := + Module.IsNoetherian.finite K[X] (RatFuncFiniteIntegralClosure K L) + +local instance polynomialHeightFiniteIntegralClosureIsIntegral : + Algebra.IsIntegral K[X] (RatFuncFiniteIntegralClosure K L) := + IsIntegralClosure.isIntegral_algebra K[X] L + +local instance polynomialHeightPolynomialTorsionFreeTop : + Module.IsTorsionFree K[X] L := + Module.IsTorsionFree.trans_faithfulSMul K[X] (RatFunc K) L + +local instance polynomialHeightFiniteIntegralClosureIsTorsionFree : + Module.IsTorsionFree K[X] (RatFuncFiniteIntegralClosure K L) := + IsIntegralClosure.isTorsionFree K[X] L + +local instance polynomialHeightInfinityIntegralClosureModuleFinite : + Module.Finite (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.finite (RatFuncInfinityIntegers K) (RatFunc K) L + (RatFuncInfinityIntegralClosure K L) + +local instance polynomialHeightInfinityIntegralClosureIsDedekindDomain : + IsDedekindDomain (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.isDedekindDomain (RatFuncInfinityIntegers K) (RatFunc K) L + (RatFuncInfinityIntegralClosure K L) + +/-- The order of an inverse at a height-one place is the negative order. -/ +theorem finitePlaceOrder_inv_eq_neg + {R F : Type*} [CommRing R] [IsDedekindDomain R] + [Field F] [Algebra R F] [IsFractionRing R F] + (v : HeightOneSpectrum R) (x : F) (hx : x ≠ 0) : + finitePlaceOrder v x⁻¹ = -finitePlaceOrder v x := by + have hone := finitePrincipalDivisor_mul (R := R) + (1 : F) (1 : F) one_ne_zero one_ne_zero + have hone' := congrArg (fun D => D v) hone + simp only [one_mul, finitePrincipalDivisor_apply, Finsupp.add_apply] at hone' + have hmul := finitePrincipalDivisor_mul (R := R) + x⁻¹ x (inv_ne_zero hx) hx + have hmul' := congrArg (fun D => D v) hmul + rw [inv_mul_cancel₀ hx] at hmul' + simp only [finitePrincipalDivisor_apply, Finsupp.add_apply] at hmul' + omega + +/-- A nonzero regular element has nonnegative finite-place order. -/ +theorem finitePlaceOrder_algebraMap_nonnegative + {R F : Type*} [CommRing R] [IsDedekindDomain R] + [Field F] [Algebra R F] [IsFractionRing R F] + (v : HeightOneSpectrum R) (a : R) (ha : a ≠ 0) : + 0 ≤ finitePlaceOrder v (algebraMap R F a) := by + have hmap : algebraMap R F a ≠ 0 := by + intro hzero + apply ha + apply IsFractionRing.injective R F + simpa using hzero + have htop := finitePlaceOrderTop_algebraMap_nonnegative (L := F) v a + rw [finitePlaceOrderTop_eq_coe v _ hmap] at htop + exact_mod_cast htop + +omit [DecidableEq K] in +private theorem polynomial_lift_finitePlaceOrder_nonnegative + (P : K[X]) (hP : P ≠ 0) + (q : FiniteExtensionFinitePlace K L) : + 0 ≤ finiteExtensionPrincipalDivisor K L + (algebraMap (RatFunc K) L (algebraMap K[X] (RatFunc K) P)) (.inl q) := by + classical + let S := RatFuncFiniteIntegralClosure K L + let e := ratFuncFiniteIntegralClosureFractionRingEquiv K L + let s : S := algebraMap K[X] S P + have hs : s ≠ 0 := by + have hinj : Function.Injective (algebraMap K[X] S) := + FunctionField.ringOfIntegers.algebraMap_injective K L + simpa [s] using hinj.ne hP + have hrepr : + e.symm (algebraMap (RatFunc K) L + (algebraMap K[X] (RatFunc K) P)) = + algebraMap S (FractionRing S) s := by + apply e.injective + rw [e.apply_symm_apply, e.commutes] + rfl + rw [finiteExtensionPrincipalDivisor_inl, hrepr] + exact finitePlaceOrder_algebraMap_nonnegative q s hs + +omit [DecidableEq K] in +private theorem polynomial_lift_infinityPlaceOrder_nonpositive + (P : K[X]) (hP : P ≠ 0) + (q : FiniteExtensionInfinityPlace K L) : + finiteExtensionPrincipalDivisor K L + (algebraMap (RatFunc K) L (algebraMap K[X] (RatFunc K) P)) (.inr q) ≤ 0 := by + classical + let f : RatFunc K := algebraMap K[X] (RatFunc K) P + let x : L := algebraMap (RatFunc K) L f + let S := RatFuncInfinityIntegralClosure K L + let e := ratFuncInfinityIntegralClosureFractionRingEquiv K L + have hf : f ≠ 0 := RatFunc.algebraMap_ne_zero hP + have hx : x ≠ 0 := (map_ne_zero (algebraMap (RatFunc K) L)).2 hf + let a : RatFuncInfinityIntegers K := ⟨f⁻¹, by + change RatFunc.inftyValuation K f⁻¹ ≤ 1 + rw [RatFunc.inftyValuation_apply, + RatFunc.inftyValuation_of_nonzero K (inv_ne_zero hf), + ← exp_zero, exp_le_exp, RatFunc.intDegree_inv] + have hdegree : f.intDegree = (P.natDegree : ℤ) := by + exact RatFunc.intDegree_polynomial + rw [hdegree] + omega⟩ + let s : S := algebraMap (RatFuncInfinityIntegers K) S a + have ha : a ≠ 0 := by + intro hzero + apply inv_ne_zero hf + have hval := congrArg Subtype.val hzero + simpa [a] using hval + have hs : s ≠ 0 := by + intro hzero + apply ha + apply Subtype.ext + apply (algebraMap (RatFunc K) L).injective + have hL := congrArg Subtype.val hzero + change algebraMap (RatFunc K) L (a : RatFunc K) = + algebraMap (RatFunc K) L (0 : RatFunc K) + simpa [s] using hL + have hrepr : (e.symm x)⁻¹ = algebraMap S (FractionRing S) s := by + apply e.injective + rw [map_inv₀, e.apply_symm_apply, e.commutes] + change x⁻¹ = algebraMap (RatFunc K) L (a : RatFunc K) + simp [x, a, f] + have hey : e.symm x ≠ 0 := by simpa using hx + have hinv : 0 ≤ finitePlaceOrder + (primeOverHeightOne (ratFuncInfinityPlace K) q) ((e.symm x)⁻¹) := by + rw [hrepr] + exact finitePlaceOrder_algebraMap_nonnegative _ s hs + rw [finiteExtensionPrincipalDivisor_inr] + change finitePlaceOrder + (primeOverHeightOne (ratFuncInfinityPlace K) q) (e.symm x) ≤ 0 + rw [finitePlaceOrder_inv_eq_neg _ _ hey] at hinv + omega + +theorem finiteExtensionPositiveDegree_polynomial_cast + (P : K[X]) (hP : P ≠ 0) : + (finiteExtensionPositiveDegree K L + (algebraMap (RatFunc K) L + (algebraMap K[X] (RatFunc K) P)) : ℤ) = + finiteExtensionFiniteDirectDegreeSum K L + (algebraMap (RatFunc K) L + (algebraMap K[X] (RatFunc K) P)) := by + let x : L := algebraMap (RatFunc K) L + (algebraMap K[X] (RatFunc K) P) + let D := finiteExtensionPrincipalDivisor K L x + rw [finiteExtensionPositiveDegree_cast] + change (∑ v ∈ D.support.filter (fun v => 0 < D v), + D v * (finiteExtensionPlaceDegree K L v : ℤ)) = _ + have hfilter : + (∑ v ∈ D.support.filter (fun v => 0 < D v), + D v * (finiteExtensionPlaceDegree K L v : ℤ)) = + D.sum (fun v n => if 0 < n then + n * (finiteExtensionPlaceDegree K L v : ℤ) else 0) := by + rw [Finsupp.sum] + exact Finset.sum_filter _ _ + rw [hfilter] + change _ = finiteExtensionFiniteDirectDegreeSum K L x + rw [show D = + (finiteExtensionFinitePrincipalDivisor K L x).sumElim + (finiteExtensionInfinityPrincipalDivisor K L x) by + rfl, + Finsupp.sum_sumElim] + rw [finiteExtensionFiniteDirectDegreeSum] + have hfinite : + (finiteExtensionFinitePrincipalDivisor K L x).sum + (fun q n => if 0 < n then + n * (finiteExtensionPlaceDegree K L (.inl q) : ℤ) else 0) = + (finiteExtensionFinitePrincipalDivisor K L x).sum + (fun q n => n * (q.asIdeal.inertiaDeg K[X] : ℤ) * + (ratFuncFinitePlaceDegree (HeightOneSpectrum.under K[X] q) : ℤ)) := by + apply Finsupp.sum_congr + intro q hq + have hnonneg := polynomial_lift_finitePlaceOrder_nonnegative K L P hP q + have hne : finiteExtensionFinitePrincipalDivisor K L x q ≠ 0 := + Finsupp.mem_support_iff.mp hq + have hpos : 0 < finiteExtensionFinitePrincipalDivisor K L x q := by + rw [finiteExtensionFinitePrincipalDivisor_apply] + change 0 < finiteExtensionPrincipalDivisor K L x (.inl q) + exact lt_of_le_of_ne hnonneg (Ne.symm hne) + rw [ite_eq_left hpos] + simp only [finiteExtensionPlaceDegree, Nat.cast_mul] + ring + have hinfinity : + (finiteExtensionInfinityPrincipalDivisor K L x).sum + (fun q n => if 0 < n then + n * (finiteExtensionPlaceDegree K L (.inr q) : ℤ) else 0) = 0 := by + rw [Finsupp.sum] + apply Finset.sum_eq_zero + intro q hq + have hnonpos := polynomial_lift_infinityPlaceOrder_nonpositive K L P hP q + have hnotpos : ¬ 0 < finiteExtensionInfinityPrincipalDivisor K L x q := by + rw [finiteExtensionInfinityPrincipalDivisor_apply] + change ¬ 0 < finiteExtensionPrincipalDivisor K L x (.inr q) + exact not_lt_of_ge hnonpos + rw [ite_eq_right hnotpos] + change + (finiteExtensionFinitePrincipalDivisor K L x).sum + (fun q n => if 0 < n then + n * (finiteExtensionPlaceDegree K L (.inl q) : ℤ) else 0) + + (finiteExtensionInfinityPrincipalDivisor K L x).sum + (fun q n => if 0 < n then + n * (finiteExtensionPlaceDegree K L (.inr q) : ℤ) else 0) = + (finiteExtensionFinitePrincipalDivisor K L x).sum + (fun q n => n * (q.asIdeal.inertiaDeg K[X] : ℤ) * + (ratFuncFinitePlaceDegree (HeightOneSpectrum.under K[X] q) : ℤ)) + rw [hfinite, hinfinity, add_zero] + +theorem finiteExtensionPositiveDegree_polynomial + (P : K[X]) (hP : P ≠ 0) : + finiteExtensionPositiveDegree K L + (algebraMap (RatFunc K) L + (algebraMap K[X] (RatFunc K) P)) = + Module.finrank (RatFunc K) L * P.natDegree := by + have hx : algebraMap (RatFunc K) L + (algebraMap K[X] (RatFunc K) P) ≠ 0 := by + exact (map_ne_zero (algebraMap (RatFunc K) L)).2 + (RatFunc.algebraMap_ne_zero hP) + have hcast := finiteExtensionPositiveDegree_polynomial_cast K L P hP + rw [finiteExtensionFiniteDirectDegreeSum_eq_grouped K L _ hx, + finiteExtensionFinitePlaceDegreeSum_eq_normFinitePlaceDegreeSum K L _ hx, + Algebra.norm_algebraMap, + ratFuncExhaustiveFinitePlaceDegreeSum_eq_intDegree _ + (pow_ne_zero _ (RatFunc.algebraMap_ne_zero hP))] at hcast + have hdegree : + ((algebraMap K[X] (RatFunc K) P) ^ Module.finrank (RatFunc K) L).intDegree = + (Module.finrank (RatFunc K) L * P.natDegree : ℕ) := by + rw [← map_pow, RatFunc.intDegree_polynomial, Polynomial.natDegree_pow] + rw [hdegree] at hcast + exact_mod_cast hcast + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/FiniteExtensionPositiveDegreePower.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/FiniteExtensionPositiveDegreePower.lean new file mode 100644 index 0000000000..a52a6b9a64 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/FiniteExtensionPositiveDegreePower.lean @@ -0,0 +1,76 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionExceptionalSupport +public import Mathlib.Tactic + +/-! # Positive divisor degree of a power -/ + +@[expose] public section + +namespace BGS.CorvajaZannier + +noncomputable section + +open scoped BigOperators + +variable (K : Type*) [Field K] [DecidableEq K] + [DecidableEq (RatFunc K)] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +/-- The positive degree of a principal divisor scales by the exponent. -/ +theorem finiteExtensionPositiveDegree_pow + (x : L) (hx : x ≠ 0) (m : ℕ) : + finiteExtensionPositiveDegree K L (x ^ m) = + m * finiteExtensionPositiveDegree K L x := by + classical + by_cases hm : m = 0 + · subst m + simp [finiteExtensionPositiveDegree, + finiteExtensionPrincipalDivisor_one K L] + have hmpos : 0 < m := Nat.pos_of_ne_zero hm + rw [finiteExtensionPositiveDegree, + finiteExtensionPrincipalDivisor_pow K L x hx m] + have hsupp : + (m • finiteExtensionPrincipalDivisor K L x).support = + (finiteExtensionPrincipalDivisor K L x).support := by + ext w + simp only [Finsupp.mem_support_iff, Finsupp.smul_apply, nsmul_eq_mul] + constructor + · exact fun h hzero ↦ h (by rw [hzero, mul_zero]) + · exact fun h hzero ↦ h (mul_eq_zero.mp hzero |>.resolve_left + (by exact_mod_cast hm)) + rw [hsupp] + have hfilter : + (finiteExtensionPrincipalDivisor K L x).support.filter + (fun w ↦ 0 < (m • finiteExtensionPrincipalDivisor K L x) w) = + (finiteExtensionPrincipalDivisor K L x).support.filter + (fun w ↦ 0 < finiteExtensionPrincipalDivisor K L x w) := by + apply Finset.filter_congr + intro w hw + simp only [Finsupp.smul_apply, nsmul_eq_mul] + have hmposInt : (0 : ℤ) < m := by exact_mod_cast hmpos + constructor + · intro h + nlinarith + · intro h + exact mul_pos hmposInt h + rw [hfilter, finiteExtensionPositiveDegree, Finset.mul_sum] + apply Finset.sum_congr rfl + intro w hw + have hwpos : 0 < finiteExtensionPrincipalDivisor K L x w := + (Finset.mem_filter.mp hw).2 + simp only [Finsupp.smul_apply, nsmul_eq_mul] + rw [Int.toNat_mul (by positivity) hwpos.le] + simp [Nat.mul_assoc] + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/FiniteExtensionPrincipalDivisor.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/FiniteExtensionPrincipalDivisor.lean new file mode 100644 index 0000000000..860b72d32a --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/FiniteExtensionPrincipalDivisor.lean @@ -0,0 +1,1039 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionExhaustiveProductFormula +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.GlobalWronskianWeightedPlaceSum +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.InfinityInertiaDegree +public import Mathlib.Tactic + +/-! +# Principal divisors on the exhaustive places of a finite function field + +This file packages the finite primes and the primes above infinity of a finite +separable extension `L / K(X)` into one place type. Principal divisors on that +type have finite support. Their degree-weighted sum is proved to vanish by +regrouping finite primes below `K[X]` and applying the exhaustive norm product +formula. + +It also provides common finite supports for arbitrary finite families, +degree-weighted product formulas on those family place types, and the positive +degree / pole-height decomposition. Over an algebraically closed constant +field, all finite and above-infinity residue degrees are proved equal to one, +so the ordinary-order specialization has no residual place-degree hypothesis. +-/ + +@[expose] public section + +open scoped nonZeroDivisors Polynomial +open IsDedekindDomain + +namespace BGS.CorvajaZannier + +noncomputable section + +variable (K : Type*) [Field K] [DecidableEq K] [DecidableEq (RatFunc K)] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +local instance (priority := 10) principalDivisorPolynomialAlgebra : Algebra K[X] L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K[X] (RatFunc K))) + +local instance principalDivisorPolynomialScalarTower : IsScalarTower K[X] (RatFunc K) L := + ⟨fun r s x => by + simp only [Algebra.smul_def] + rw [map_mul] + change (algebraMap (RatFunc K) L (algebraMap K[X] (RatFunc K) r) * + algebraMap (RatFunc K) L s) * x = + algebraMap K[X] L r * (algebraMap (RatFunc K) L s * x) + rw [show algebraMap K[X] L r = + algebraMap (RatFunc K) L (algebraMap K[X] (RatFunc K) r) by rfl] + ring⟩ + +local instance principalDivisorFiniteIntegralClosureModuleFinite : + Module.Finite K[X] (RatFuncFiniteIntegralClosure K L) := + Module.IsNoetherian.finite K[X] (RatFuncFiniteIntegralClosure K L) + +local instance principalDivisorFiniteIntegralClosureIsIntegral : + Algebra.IsIntegral K[X] (RatFuncFiniteIntegralClosure K L) := + IsIntegralClosure.isIntegral_algebra K[X] L + +local instance principalDivisorPolynomialTorsionFreeTop : Module.IsTorsionFree K[X] L := + Module.IsTorsionFree.trans_faithfulSMul K[X] (RatFunc K) L + +local instance principalDivisorFiniteIntegralClosureIsTorsionFree : + Module.IsTorsionFree K[X] (RatFuncFiniteIntegralClosure K L) := + IsIntegralClosure.isTorsionFree K[X] L + +local instance principalDivisorInfinityIntegralClosureModuleFinite : + Module.Finite (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.finite (RatFuncInfinityIntegers K) (RatFunc K) L + (RatFuncInfinityIntegralClosure K L) + +local instance principalDivisorInfinityIntegralClosureIsIntegral : + Algebra.IsIntegral (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.isIntegral_algebra (RatFuncInfinityIntegers K) L + +local instance principalDivisorInfinityIntegralClosureIsTorsionFree : + Module.IsTorsionFree (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.isTorsionFree (RatFuncInfinityIntegers K) L + +local instance principalDivisorInfinityIntegralClosureIsDedekindDomain : + IsDedekindDomain (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.isDedekindDomain (RatFuncInfinityIntegers K) (RatFunc K) L + (RatFuncInfinityIntegralClosure K L) + +def finitePlaceFiberEquivPrimesOver (p : HeightOneSpectrum K[X]) : + {q : HeightOneSpectrum (RatFuncFiniteIntegralClosure K L) // + HeightOneSpectrum.under K[X] q = p} ≃ + p.asIdeal.primesOver (RatFuncFiniteIntegralClosure K L) where + toFun q := ⟨q.1.asIdeal, q.1.isPrime, ⟨by + have h := congrArg HeightOneSpectrum.asIdeal q.2 + exact h.symm⟩⟩ + invFun P := ⟨primeOverHeightOne p P, by + apply HeightOneSpectrum.ext + exact (Ideal.over_def P.1 p.asIdeal).symm⟩ + left_inv q := by + apply Subtype.ext + apply HeightOneSpectrum.ext + rfl + right_inv P := by + apply Subtype.ext + rfl + +abbrev FiniteExtensionFinitePlace := + HeightOneSpectrum (RatFuncFiniteIntegralClosure K L) + +abbrev FiniteExtensionInfinityPlace := + (ratFuncInfinityPlace K).asIdeal.primesOver + (RatFuncInfinityIntegralClosure K L) + +abbrev FiniteExtensionPlace := + FiniteExtensionFinitePlace K L ⊕ FiniteExtensionInfinityPlace K L + +local instance principalDivisorInfinityPlaceFintype : + Fintype (FiniteExtensionInfinityPlace K L) := + Set.Finite.fintype + (IsDedekindDomain.primesOver_finite + (ratFuncInfinityPlace K).asIdeal + (RatFuncInfinityIntegralClosure K L)) + +def finiteExtensionFinitePrincipalDivisor (x : L) : + FiniteExtensionFinitePlace K L →₀ ℤ := + finitePrincipalDivisor + ((ratFuncFiniteIntegralClosureFractionRingEquiv K L).symm x) + +omit [DecidableEq K] [DecidableEq (RatFunc K)] in +@[simp] theorem finiteExtensionFinitePrincipalDivisor_apply + (x : L) (q : FiniteExtensionFinitePlace K L) : + finiteExtensionFinitePrincipalDivisor K L x q = + finitePlaceOrder q + ((ratFuncFiniteIntegralClosureFractionRingEquiv K L).symm x) := by + simp [finiteExtensionFinitePrincipalDivisor] + +def finiteExtensionInfinityPrincipalDivisor (x : L) : + FiniteExtensionInfinityPlace K L →₀ ℤ := + Finsupp.equivFunOnFinite.symm (fun P => + finitePlaceOrder (primeOverHeightOne (ratFuncInfinityPlace K) P) + ((ratFuncInfinityIntegralClosureFractionRingEquiv K L).symm x)) + +omit [DecidableEq K] in +@[simp] theorem finiteExtensionInfinityPrincipalDivisor_apply + (x : L) (P : FiniteExtensionInfinityPlace K L) : + finiteExtensionInfinityPrincipalDivisor K L x P = + finitePlaceOrder (primeOverHeightOne (ratFuncInfinityPlace K) P) + ((ratFuncInfinityIntegralClosureFractionRingEquiv K L).symm x) := by + simp [finiteExtensionInfinityPrincipalDivisor] + +def finiteExtensionPrincipalDivisor (x : L) : + FiniteExtensionPlace K L →₀ ℤ := + (finiteExtensionFinitePrincipalDivisor K L x).sumElim + (finiteExtensionInfinityPrincipalDivisor K L x) + +omit [DecidableEq K] in +@[simp] theorem finiteExtensionPrincipalDivisor_inl + (x : L) (q : FiniteExtensionFinitePlace K L) : + finiteExtensionPrincipalDivisor K L x (.inl q) = + finitePlaceOrder q + ((ratFuncFiniteIntegralClosureFractionRingEquiv K L).symm x) := by + classical + simp [finiteExtensionPrincipalDivisor] + +omit [DecidableEq K] in +@[simp] theorem finiteExtensionPrincipalDivisor_inr + (x : L) (P : FiniteExtensionInfinityPlace K L) : + finiteExtensionPrincipalDivisor K L x (.inr P) = + finitePlaceOrder (primeOverHeightOne (ratFuncInfinityPlace K) P) + ((ratFuncInfinityIntegralClosureFractionRingEquiv K L).symm x) := by + classical + simp [finiteExtensionPrincipalDivisor] + +def finiteExtensionFiniteResidueWeightedDivisor (x : L) : + FiniteExtensionFinitePlace K L →₀ ℤ := + (finiteExtensionFinitePrincipalDivisor K L x).sum (fun q n => + Finsupp.single q ((q.asIdeal.inertiaDeg K[X] : ℤ) * n)) + +omit [DecidableEq K] [DecidableEq (RatFunc K)] in +@[simp] theorem finiteExtensionFiniteResidueWeightedDivisor_apply + (x : L) (q : FiniteExtensionFinitePlace K L) : + finiteExtensionFiniteResidueWeightedDivisor K L x q = + (q.asIdeal.inertiaDeg K[X] : ℤ) * + finitePlaceOrder q + ((ratFuncFiniteIntegralClosureFractionRingEquiv K L).symm x) := by + classical + rw [finiteExtensionFiniteResidueWeightedDivisor, Finsupp.sum_apply] + unfold Finsupp.sum + by_cases hq : q ∈ (finiteExtensionFinitePrincipalDivisor K L x).support + · rw [Finset.sum_eq_single q] + · simp + · intro b hb hbq + simp [hbq] + · exact fun hnot => (hnot hq).elim + · rw [Finset.sum_eq_zero] + · change 0 = (q.asIdeal.inertiaDeg K[X] : ℤ) * + finiteExtensionFinitePrincipalDivisor K L x q + rw [Finsupp.notMem_support_iff.mp hq] + simp + · intro b hb + have hbq : b ≠ q := by + intro h + subst h + exact hq hb + simp [hbq] + +def finiteExtensionFiniteDivisorBelow (x : L) : + HeightOneSpectrum K[X] →₀ ℤ := + (finiteExtensionFiniteResidueWeightedDivisor K L x).mapDomain + (HeightOneSpectrum.under K[X]) + +omit [DecidableEq K] [DecidableEq (RatFunc K)] in +theorem finiteExtensionFiniteDivisorBelow_apply + (x : L) (p : HeightOneSpectrum K[X]) : + finiteExtensionFiniteDivisorBelow K L x p = + ∑ P : p.asIdeal.primesOver (RatFuncFiniteIntegralClosure K L), + (P.1.inertiaDeg K[X] : ℤ) * + finitePlaceOrder (primeOverHeightOne p P) + ((ratFuncFiniteIntegralClosureFractionRingEquiv K L).symm x) := by + classical + let e := finitePlaceFiberEquivPrimesOver K L p + let : Fintype {q : FiniteExtensionFinitePlace K L // + HeightOneSpectrum.under K[X] q = p} := + Fintype.ofEquiv (p.asIdeal.primesOver (RatFuncFiniteIntegralClosure K L)) e.symm + let P₀ : p.asIdeal.primesOver (RatFuncFiniteIntegralClosure K L) := + Classical.choice (Set.nonempty_coe_sort.mpr + (Set.nonempty_iff_ne_empty.mpr (by + intro hempty + have hncard := IsDedekindDomain.primesOver_ncard_ne_zero p.asIdeal + (RatFuncFiniteIntegralClosure K L) + exact hncard (by simp [hempty])))) + let q₀ : FiniteExtensionFinitePlace K L := primeOverHeightOne p P₀ + have hq₀ : HeightOneSpectrum.under K[X] q₀ = p := by + apply HeightOneSpectrum.ext + exact (Ideal.over_def P₀.1 p.asIdeal).symm + rw [finiteExtensionFiniteDivisorBelow, show p = + HeightOneSpectrum.under K[X] q₀ from hq₀.symm, + Finsupp.mapDomain_apply_eq_sum] + let D := finiteExtensionFiniteResidueWeightedDivisor K L x + have hfilter : + (∑ q ∈ D.support with HeightOneSpectrum.under K[X] q = + HeightOneSpectrum.under K[X] q₀, D q) = + ∑ q : {q : FiniteExtensionFinitePlace K L // + HeightOneSpectrum.under K[X] q = p}, D q := by + rw [hq₀] + calc + _ = ∑ q ∈ Finset.subtype + (fun q => HeightOneSpectrum.under K[X] q = p) D.support, + D q := (Finset.sum_subtype_eq_sum_filter (s := D.support) + (fun q => D q)).symm + _ = ∑ q : {q : FiniteExtensionFinitePlace K L // + HeightOneSpectrum.under K[X] q = p}, D q := by + apply Finset.sum_subset (Finset.subset_univ _) + intro q _ hq + have hnot : q.1 ∉ D.support := by + intro hmem + exact hq (Finset.mem_subtype.mpr hmem) + exact Finsupp.notMem_support_iff.mp hnot + rw [hfilter] + rw [hq₀] + apply Fintype.sum_equiv e + intro q + have hplace : primeOverHeightOne p (e q) = q.1 := by + apply HeightOneSpectrum.ext + rfl + simp only [D, finiteExtensionFiniteResidueWeightedDivisor_apply] + rw [hplace] + rfl + +omit [DecidableEq K] [DecidableEq (RatFunc K)] in +theorem finiteExtensionFiniteDivisorBelow_eq_normDivisor + (x : L) (hx : x ≠ 0) : + finiteExtensionFiniteDivisorBelow K L x = + ratFuncFiniteDivisor (Algebra.norm (RatFunc K) x) := by + classical + ext p + rw [finiteExtensionFiniteDivisorBelow_apply K L x p, + finitePrimesAbove_weightedOrder_eq_normOrder K L p x hx, + ratFuncFiniteDivisor_apply] + +/-- The finite-place degree sum written directly on the height-one primes of +the finite integral closure. -/ +def finiteExtensionFiniteDirectDegreeSum (x : L) : ℤ := + (finiteExtensionFinitePrincipalDivisor K L x).sum (fun q n => + n * (q.asIdeal.inertiaDeg K[X] : ℤ) * + (ratFuncFinitePlaceDegree (HeightOneSpectrum.under K[X] q) : ℤ)) + +omit [DecidableEq (RatFunc K)] in +theorem finiteExtensionFiniteDirectDegreeSum_eq_grouped + (x : L) (hx : x ≠ 0) : + finiteExtensionFiniteDirectDegreeSum K L x = + finiteExtensionFinitePlaceDegreeSum K L x := by + classical + let D := finiteExtensionFinitePrincipalDivisor K L x + let DW := finiteExtensionFiniteResidueWeightedDivisor K L x + let DB := finiteExtensionFiniteDivisorBelow K L x + calc + finiteExtensionFiniteDirectDegreeSum K L x = + DW.sum (fun q n => n * + (ratFuncFinitePlaceDegree (HeightOneSpectrum.under K[X] q) : ℤ)) := by + rw [finiteExtensionFiniteDirectDegreeSum] + change D.sum _ = DW.sum _ + dsimp only [DW] + rw [finiteExtensionFiniteResidueWeightedDivisor, + Finsupp.sum_sum_index (fun _ => by simp) + (fun _ _ _ => by ring)] + apply Finsupp.sum_congr + intro q _ + rw [Finsupp.sum_single_index] + · ring + · simp + _ = DB.sum (fun p n => n * (ratFuncFinitePlaceDegree p : ℤ)) := by + dsimp only [DB, DW] + rw [finiteExtensionFiniteDivisorBelow] + symm + apply Finsupp.sum_mapDomain_index + · intro + simp + · intro _ _ _ + ring + _ = finiteExtensionFinitePlaceDegreeSum K L x := by + dsimp only [DB] + rw [finiteExtensionFiniteDivisorBelow_eq_normDivisor K L x hx, + finiteExtensionFinitePlaceDegreeSum] + apply Finsupp.sum_congr + intro p _ + rw [ratFuncFiniteDivisor_apply, + finitePrimesAbove_weightedOrder_eq_normOrder K L p x hx] + +/-- The above-infinity order sum written as a `Finsupp.sum` on the infinity +part of the principal divisor. -/ +def finiteExtensionInfinityDirectDegreeSum (x : L) : ℤ := + (finiteExtensionInfinityPrincipalDivisor K L x).sum (fun P n => + n * (P.1.inertiaDeg (RatFuncInfinityIntegers K) : ℤ)) + +omit [DecidableEq K] in +theorem finiteExtensionInfinityDirectDegreeSum_eq_grouped (x : L) : + finiteExtensionInfinityDirectDegreeSum K L x = + finiteExtensionInfinityOrderSum K L x := by + classical + rw [finiteExtensionInfinityDirectDegreeSum, + Finsupp.sum_fintype _ _ (fun _ => by simp), + finiteExtensionInfinityOrderSum] + apply Finset.sum_congr rfl + intro P _ + rw [finiteExtensionInfinityPrincipalDivisor_apply] + ring + +/-- Degree of a place of `L`: residue degree times the degree of the place +below it. The place at infinity of `K(X)` has degree one. -/ +def finiteExtensionPlaceDegree : FiniteExtensionPlace K L → ℕ + | .inl q => q.asIdeal.inertiaDeg K[X] * + ratFuncFinitePlaceDegree (HeightOneSpectrum.under K[X] q) + | .inr P => P.1.inertiaDeg (RatFuncInfinityIntegers K) + +/-- Degree of the exhaustive principal divisor, summed on the actual finite +and above-infinity places of `L`. -/ +def finiteExtensionPrincipalDivisorDegreeSum (x : L) : ℤ := + (finiteExtensionPrincipalDivisor K L x).sum (fun v n => + n * (finiteExtensionPlaceDegree K L v : ℤ)) + +theorem finiteExtensionPrincipalDivisorDegreeSum_eq_grouped + (x : L) (hx : x ≠ 0) : + finiteExtensionPrincipalDivisorDegreeSum K L x = + finiteExtensionFinitePlaceDegreeSum K L x + + finiteExtensionInfinityOrderSum K L x := by + rw [finiteExtensionPrincipalDivisorDegreeSum, + finiteExtensionPrincipalDivisor, Finsupp.sum_sumElim, + ← finiteExtensionFiniteDirectDegreeSum_eq_grouped K L x hx, + ← finiteExtensionInfinityDirectDegreeSum_eq_grouped K L x] + rw [finiteExtensionFiniteDirectDegreeSum, + finiteExtensionInfinityDirectDegreeSum] + congr 1 + · apply Finsupp.sum_congr + intro q _ + simp only [Function.comp_apply, finiteExtensionPlaceDegree, Nat.cast_mul] + ring + +/-- Product formula on the actual place type, rather than grouped below the +base places. -/ +theorem finiteExtensionPrincipalDivisorDegreeSum_eq_zero + (x : L) (hx : x ≠ 0) : + finiteExtensionPrincipalDivisorDegreeSum K L x = 0 := by + rw [finiteExtensionPrincipalDivisorDegreeSum_eq_grouped K L x hx] + exact finiteExtension_exhaustivePrincipalDivisor_productFormula K L x hx + +/-- Positive degree of the principal divisor of `x`. -/ +def finiteExtensionPositiveDegree (x : L) : ℕ := + ∑ v ∈ (finiteExtensionPrincipalDivisor K L x).support.filter + (fun v => 0 < finiteExtensionPrincipalDivisor K L x v), + (finiteExtensionPrincipalDivisor K L x v).toNat * + finiteExtensionPlaceDegree K L v + +/-- Pole height of `x`, i.e. the degree of the negative part of its principal +divisor. -/ +def finiteExtensionHeight (x : L) : ℕ := + ∑ v ∈ (finiteExtensionPrincipalDivisor K L x).support.filter + (fun v => finiteExtensionPrincipalDivisor K L x v < 0), + (-finiteExtensionPrincipalDivisor K L x v).toNat * + finiteExtensionPlaceDegree K L v + +theorem finiteExtensionPositiveDegree_cast + (x : L) : + (finiteExtensionPositiveDegree K L x : ℤ) = + ∑ v ∈ (finiteExtensionPrincipalDivisor K L x).support.filter + (fun v => 0 < finiteExtensionPrincipalDivisor K L x v), + finiteExtensionPrincipalDivisor K L x v * + (finiteExtensionPlaceDegree K L v : ℤ) := by + rw [finiteExtensionPositiveDegree, Nat.cast_sum] + apply Finset.sum_congr rfl + intro v hv + have hpos : 0 < finiteExtensionPrincipalDivisor K L x v := + (Finset.mem_filter.mp hv).2 + rw [Nat.cast_mul, Int.toNat_of_nonneg (le_of_lt hpos)] + +theorem finiteExtensionHeight_negativeSum + (x : L) : + -((finiteExtensionHeight K L x : ℕ) : ℤ) = + ∑ v ∈ (finiteExtensionPrincipalDivisor K L x).support.filter + (fun v => finiteExtensionPrincipalDivisor K L x v < 0), + finiteExtensionPrincipalDivisor K L x v * + (finiteExtensionPlaceDegree K L v : ℤ) := by + rw [finiteExtensionHeight, Nat.cast_sum, ← Finset.sum_neg_distrib] + apply Finset.sum_congr rfl + intro v hv + have hneg : finiteExtensionPrincipalDivisor K L x v < 0 := + (Finset.mem_filter.mp hv).2 + rw [Nat.cast_mul, Int.toNat_of_nonneg (Int.neg_nonneg.mpr (le_of_lt hneg))] + ring + +theorem finiteExtensionPositiveDegree_eq_height + (x : L) (hx : x ≠ 0) : + finiteExtensionPositiveDegree K L x = finiteExtensionHeight K L x := by + have hproduct := finiteExtensionPrincipalDivisorDegreeSum_eq_zero K L x hx + rw [finiteExtensionPrincipalDivisorDegreeSum] at hproduct + have hsplit : + (finiteExtensionPrincipalDivisor K L x).sum (fun v n => + n * (finiteExtensionPlaceDegree K L v : ℤ)) = + (∑ v ∈ (finiteExtensionPrincipalDivisor K L x).support.filter + (fun v => 0 < finiteExtensionPrincipalDivisor K L x v), + finiteExtensionPrincipalDivisor K L x v * + (finiteExtensionPlaceDegree K L v : ℤ)) + + (∑ v ∈ (finiteExtensionPrincipalDivisor K L x).support.filter + (fun v => finiteExtensionPrincipalDivisor K L x v < 0), + finiteExtensionPrincipalDivisor K L x v * + (finiteExtensionPlaceDegree K L v : ℤ)) := by + rw [Finsupp.sum] + rw [← Finset.sum_filter_add_sum_filter_not + (finiteExtensionPrincipalDivisor K L x).support + (fun v => 0 < finiteExtensionPrincipalDivisor K L x v)] + congr 1 + have hfilters : + (finiteExtensionPrincipalDivisor K L x).support.filter + (fun v => ¬ 0 < finiteExtensionPrincipalDivisor K L x v) = + (finiteExtensionPrincipalDivisor K L x).support.filter + (fun v => finiteExtensionPrincipalDivisor K L x v < 0) := by + ext v + simp only [Finset.mem_filter] + constructor + · intro ⟨hv, hnotpos⟩ + have hvne : finiteExtensionPrincipalDivisor K L x v ≠ 0 := + Finsupp.mem_support_iff.mp hv + exact ⟨hv, lt_of_le_of_ne (le_of_not_gt hnotpos) hvne⟩ + · intro ⟨hv, hneg⟩ + exact ⟨hv, not_lt_of_ge (le_of_lt hneg)⟩ + rw [hfilters] + have hcast : (finiteExtensionPositiveDegree K L x : ℤ) = + (finiteExtensionHeight K L x : ℤ) := by + rw [finiteExtensionPositiveDegree_cast] + rw [hsplit, ← finiteExtensionHeight_negativeSum K L x] at hproduct + omega + exact_mod_cast hcast + +section Families + +variable {A : Type*} [Fintype A] + +local instance familyPlaceDecidableEq : DecidableEq (FiniteExtensionPlace K L) := + Classical.decEq _ + +/-- A single finite place set supporting the principal divisors of every +member of a finite family. -/ +def finiteExtensionFamilySupport (f : A → L) : + Finset (FiniteExtensionPlace K L) := by + classical + exact Finset.univ.biUnion (fun a => + (finiteExtensionPrincipalDivisor K L (f a)).support) + +abbrev FiniteExtensionFamilyPlace (f : A → L) := + {v : FiniteExtensionPlace K L // v ∈ finiteExtensionFamilySupport K L f} + +/-- Ordinary order of a family member on the common finite place set. -/ +def finiteExtensionFamilyOrder (f : A → L) (a : A) + (v : FiniteExtensionFamilyPlace K L f) : ℤ := + finiteExtensionPrincipalDivisor K L (f a) v.1 + +/-- Degree-weighted order. These are the values whose unweighted sum is zero +without any algebraic-closedness assumption on the constant field. -/ +def finiteExtensionFamilyWeightedOrder (f : A → L) (a : A) + (v : FiniteExtensionFamilyPlace K L f) : ℤ := + finiteExtensionFamilyOrder K L f a v * + (finiteExtensionPlaceDegree K L v.1 : ℤ) + +omit [DecidableEq K] in +theorem finiteExtensionPrincipalDivisor_support_subset_familySupport + (f : A → L) (a : A) : + (finiteExtensionPrincipalDivisor K L (f a)).support ⊆ + finiteExtensionFamilySupport K L f := by + intro v hv + simp only [finiteExtensionFamilySupport, Finset.mem_biUnion, + Finset.mem_univ, true_and] + exact ⟨a, hv⟩ + +omit [DecidableEq K] in +theorem finiteExtensionFamilyOrder_eq_zero_of_not_mem_support + (f : A → L) (a : A) (v : FiniteExtensionFamilyPlace K L f) + (hv : v.1 ∉ (finiteExtensionPrincipalDivisor K L (f a)).support) : + finiteExtensionFamilyOrder K L f a v = 0 := by + exact Finsupp.notMem_support_iff.mp hv + +/-- Product formula for any member of an arbitrary finite family, on the one +common finite place type attached to that family. -/ +theorem finiteExtensionFamilyWeightedOrder_sum_eq_zero + (f : A → L) (a : A) (ha : f a ≠ 0) : + ∑ v : FiniteExtensionFamilyPlace K L f, + finiteExtensionFamilyWeightedOrder K L f a v = 0 := by + let D := finiteExtensionPrincipalDivisor K L (f a) + let S := finiteExtensionFamilySupport K L f + calc + ∑ v : FiniteExtensionFamilyPlace K L f, + finiteExtensionFamilyWeightedOrder K L f a v = + ∑ v ∈ S, D v * (finiteExtensionPlaceDegree K L v : ℤ) := by + symm + apply Finset.sum_subtype S (fun _ => Iff.rfl) + _ = ∑ v ∈ D.support, + D v * (finiteExtensionPlaceDegree K L v : ℤ) := by + symm + apply Finset.sum_subset + (finiteExtensionPrincipalDivisor_support_subset_familySupport K L f a) + intro v _ hv + have hzero : D v = 0 := by + apply Finsupp.notMem_support_iff.mp + exact hv + simp [hzero] + _ = finiteExtensionPrincipalDivisorDegreeSum K L (f a) := by + rfl + _ = 0 := finiteExtensionPrincipalDivisorDegreeSum_eq_zero K L (f a) ha + +theorem finiteExtensionFamilyWeightedPositiveSum + (f : A → L) (a : A) : + ∑ v ∈ Finset.univ.filter + (fun v : FiniteExtensionFamilyPlace K L f => + 0 < finiteExtensionFamilyOrder K L f a v), + finiteExtensionFamilyWeightedOrder K L f a v = + (finiteExtensionPositiveDegree K L (f a) : ℤ) := by + let D := finiteExtensionPrincipalDivisor K L (f a) + let S := finiteExtensionFamilySupport K L f + rw [finiteExtensionPositiveDegree_cast K L (f a)] + calc + _ = ∑ v : FiniteExtensionFamilyPlace K L f, + if 0 < finiteExtensionFamilyOrder K L f a v then + finiteExtensionFamilyWeightedOrder K L f a v else 0 := by + rw [Finset.sum_filter] + _ = ∑ v ∈ S, if 0 < D v then + D v * (finiteExtensionPlaceDegree K L v : ℤ) else 0 := by + symm + apply Finset.sum_subtype S (fun _ => Iff.rfl) + _ = ∑ v ∈ S.filter (fun v => 0 < D v), + D v * (finiteExtensionPlaceDegree K L v : ℤ) := by + rw [Finset.sum_filter] + _ = ∑ v ∈ D.support.filter (fun v => 0 < D v), + D v * (finiteExtensionPlaceDegree K L v : ℤ) := by + symm + apply Finset.sum_subset + · intro v hv + exact Finset.mem_filter.mpr ⟨ + finiteExtensionPrincipalDivisor_support_subset_familySupport K L f a + (Finset.mem_filter.mp hv).1, + (Finset.mem_filter.mp hv).2⟩ + · intro v hvS hvD + have hnotSupport : v ∉ D.support := by + intro hv + exact hvD (Finset.mem_filter.mpr ⟨hv, (Finset.mem_filter.mp hvS).2⟩) + have hzero := Finsupp.notMem_support_iff.mp hnotSupport + simp [hzero] + +theorem finiteExtensionFamilyWeightedNegativeSum + (f : A → L) (a : A) : + ∑ v ∈ Finset.univ.filter + (fun v : FiniteExtensionFamilyPlace K L f => + finiteExtensionFamilyOrder K L f a v < 0), + finiteExtensionFamilyWeightedOrder K L f a v = + -((finiteExtensionHeight K L (f a) : ℕ) : ℤ) := by + let D := finiteExtensionPrincipalDivisor K L (f a) + let S := finiteExtensionFamilySupport K L f + rw [finiteExtensionHeight_negativeSum K L (f a)] + calc + _ = ∑ v : FiniteExtensionFamilyPlace K L f, + if finiteExtensionFamilyOrder K L f a v < 0 then + finiteExtensionFamilyWeightedOrder K L f a v else 0 := by + rw [Finset.sum_filter] + _ = ∑ v ∈ S, if D v < 0 then + D v * (finiteExtensionPlaceDegree K L v : ℤ) else 0 := by + symm + apply Finset.sum_subtype S (fun _ => Iff.rfl) + _ = ∑ v ∈ S.filter (fun v => D v < 0), + D v * (finiteExtensionPlaceDegree K L v : ℤ) := by + rw [Finset.sum_filter] + _ = ∑ v ∈ D.support.filter (fun v => D v < 0), + D v * (finiteExtensionPlaceDegree K L v : ℤ) := by + symm + apply Finset.sum_subset + · intro v hv + exact Finset.mem_filter.mpr ⟨ + finiteExtensionPrincipalDivisor_support_subset_familySupport K L f a + (Finset.mem_filter.mp hv).1, + (Finset.mem_filter.mp hv).2⟩ + · intro v hvS hvD + have hnotSupport : v ∉ D.support := by + intro hv + exact hvD (Finset.mem_filter.mpr ⟨hv, (Finset.mem_filter.mp hvS).2⟩) + have hzero := Finsupp.notMem_support_iff.mp hnotSupport + simp [hzero] + +/-- Pole height outside a caller-specified exceptional set. This is the +quantity occurring on the right of the global Wronskian inequality. -/ +def finiteExtensionFamilyOutsideHeight + (f : A → L) (S : Finset (FiniteExtensionFamilyPlace K L f)) + (a : A) : ℕ := by + classical + exact ∑ v ∈ Finset.univ.filter (fun v => v ∉ S ∧ + finiteExtensionFamilyOrder K L f a v < 0), + (finiteExtensionFamilyWeightedOrder K L f a v).natAbs + +theorem finiteExtensionFamilyOutsideHeight_negativeSum + (f : A → L) (S : Finset (FiniteExtensionFamilyPlace K L f)) + (a : A) : + ∑ v ∈ Finset.univ.filter (fun v => v ∉ S ∧ + finiteExtensionFamilyOrder K L f a v < 0), + finiteExtensionFamilyWeightedOrder K L f a v = + -((finiteExtensionFamilyOutsideHeight K L f S a : ℕ) : ℤ) := by + classical + rw [finiteExtensionFamilyOutsideHeight, Nat.cast_sum, + ← Finset.sum_neg_distrib] + apply Finset.sum_congr rfl + intro v hv + have hneg : finiteExtensionFamilyOrder K L f a v < 0 := + (Finset.mem_filter.mp hv).2.2 + have hdegree : 0 ≤ (finiteExtensionPlaceDegree K L v.1 : ℤ) := by + positivity + have hweighted : finiteExtensionFamilyWeightedOrder K L f a v ≤ 0 := by + rw [finiteExtensionFamilyWeightedOrder] + exact mul_nonpos_of_nonpos_of_nonneg (le_of_lt hneg) hdegree + rw [Int.natCast_natAbs, abs_of_nonpos hweighted] + ring + +end Families + +section WeightedFamilies + +variable {A : Type*} [Fintype A] + +/-- The residue-degree-weighted Corvaja--Zannier summation on the exhaustive +family place type. Unlike the later degree-one specialization, this theorem +does not assume that the constant field is algebraically closed. -/ +theorem globalWronskianInequality_of_finiteExtensionWeightedPlacewiseBounds + (f : A → L) (iU iV iRho iGrid iW : A) + (S : Finset (FiniteExtensionFamilyPlace K L f)) + (h k n sigma chi : ℕ) (canonicalDegree : ℤ) + (hUne : f iU ≠ 0) (hGridne : f iGrid ≠ 0) + (hUOutside : ∀ i, i ∉ S → + finiteExtensionFamilyOrder K L f iU i = 0) + (hGridOutside : ∀ i, i ∉ S → + finiteExtensionFamilyOrder K L f iGrid i = 0) + (hVPositiveSupport : ∀ i, + 0 < finiteExtensionFamilyOrder K L f iV i → i ∈ S) + (hCanonical : + ∑ i, finiteExtensionFamilyWeightedOrder K L f iW i = + (sigma : ℤ) * canonicalDegree) + (hEuler : canonicalDegree + + (∑ i ∈ S, finiteExtensionPlaceDegree K L i.1 : ℕ) ≤ (chi : ℤ)) + (hRhoSupport : + -((finiteExtensionPositiveDegree K L (f iU) : ℤ) + + (finiteExtensionPositiveDegree K L (f iV) : ℤ)) ≤ + ∑ i ∈ S, finiteExtensionFamilyWeightedOrder K L f iRho i) + (hCaseI : ∀ i, i ∉ S → + finiteExtensionFamilyOrder K L f iRho i < 0 → + (n : ℤ) * finiteExtensionFamilyOrder K L f iRho i ≤ + finiteExtensionFamilyOrder K L f iW i) + (hCaseII : ∀ i, i ∉ S → + 0 ≤ finiteExtensionFamilyOrder K L f iRho i → + 0 ≤ finiteExtensionFamilyOrder K L f iW i) + (hCaseIII : ∀ i, i ∈ S → + 0 < finiteExtensionFamilyOrder K L f iV i → + ((k * (k - 1) / 2 : ℕ) : ℤ) * + finiteExtensionFamilyOrder K L f iU i + + ((h * k : ℕ) : ℤ) * finiteExtensionFamilyOrder K L f iV i + + (k : ℤ) * finiteExtensionFamilyOrder K L f iRho i + + finiteExtensionFamilyOrder K L f iGrid i - (sigma : ℤ) ≤ + finiteExtensionFamilyOrder K L f iW i) + (hCaseIV : ∀ i, i ∈ S → + finiteExtensionFamilyOrder K L f iV i ≤ 0 → + ((k * (k - 1) / 2 : ℕ) : ℤ) * + finiteExtensionFamilyOrder K L f iU i + + (k : ℤ) * finiteExtensionFamilyOrder K L f iRho i + + finiteExtensionFamilyOrder K L f iGrid i - (sigma : ℤ) ≤ + finiteExtensionFamilyOrder K L f iW i) : + ((h * k : ℕ) : ℤ) * + (finiteExtensionPositiveDegree K L (f iV) : ℤ) - + (k : ℤ) * + ((finiteExtensionPositiveDegree K L (f iU) : ℤ) + + (finiteExtensionPositiveDegree K L (f iV) : ℤ)) - + (sigma : ℤ) * (chi : ℤ) ≤ + (n : ℤ) * + (finiteExtensionFamilyOutsideHeight K L f S iRho : ℤ) := by + classical + have hUSum : + ∑ i, finiteExtensionFamilyOrder K L f iU i * + (finiteExtensionPlaceDegree K L i.1 : ℤ) = 0 := by + simpa only [finiteExtensionFamilyWeightedOrder] using + finiteExtensionFamilyWeightedOrder_sum_eq_zero K L f iU hUne + have hGridSum : + ∑ i, finiteExtensionFamilyOrder K L f iGrid i * + (finiteExtensionPlaceDegree K L i.1 : ℤ) = 0 := by + simpa only [finiteExtensionFamilyWeightedOrder] using + finiteExtensionFamilyWeightedOrder_sum_eq_zero K L f iGrid hGridne + have hPositiveAll := finiteExtensionFamilyWeightedPositiveSum K L f iV + have hDegreeV : + ∑ i ∈ S.filter (fun i ↦ + 0 < finiteExtensionFamilyOrder K L f iV i), + finiteExtensionFamilyOrder K L f iV i * + (finiteExtensionPlaceDegree K L i.1 : ℤ) = + finiteExtensionPositiveDegree K L (f iV) := by + calc + _ = ∑ i ∈ Finset.univ.filter (fun i ↦ + 0 < finiteExtensionFamilyOrder K L f iV i), + finiteExtensionFamilyWeightedOrder K L f iV i := by + rw [show (∑ i ∈ S.filter (fun i ↦ + 0 < finiteExtensionFamilyOrder K L f iV i), + finiteExtensionFamilyOrder K L f iV i * + (finiteExtensionPlaceDegree K L i.1 : ℤ)) = + ∑ i ∈ S.filter (fun i ↦ + 0 < finiteExtensionFamilyOrder K L f iV i), + finiteExtensionFamilyWeightedOrder K L f iV i by + apply Finset.sum_congr rfl + intro i _ + rfl] + apply Finset.sum_subset + · intro i hi + exact Finset.mem_filter.mpr ⟨Finset.mem_univ i, + (Finset.mem_filter.mp hi).2⟩ + · intro i hi hiS + have hpos := (Finset.mem_filter.mp hi).2 + exact False.elim + (hiS (Finset.mem_filter.mpr ⟨hVPositiveSupport i hpos, hpos⟩)) + _ = _ := hPositiveAll + have hOutside := finiteExtensionFamilyOutsideHeight_negativeSum K L f S iRho + have hOutside' : + ∑ i ∈ Finset.univ.filter (fun i ↦ i ∉ S ∧ + finiteExtensionFamilyOrder K L f iRho i < 0), + finiteExtensionFamilyOrder K L f iRho i * + (finiteExtensionPlaceDegree K L i.1 : ℤ) = + -((finiteExtensionFamilyOutsideHeight K L f S iRho : ℕ) : ℤ) := by + rw [show (∑ i ∈ Finset.univ.filter (fun i ↦ i ∉ S ∧ + finiteExtensionFamilyOrder K L f iRho i < 0), + finiteExtensionFamilyOrder K L f iRho i * + (finiteExtensionPlaceDegree K L i.1 : ℤ)) = + ∑ i ∈ Finset.univ.filter (fun i ↦ i ∉ S ∧ + finiteExtensionFamilyOrder K L f iRho i < 0), + finiteExtensionFamilyWeightedOrder K L f iRho i by + apply Finset.sum_congr rfl + intro i _ + rfl] + convert hOutside using 1 + apply Finset.sum_congr + · ext i + simp only [Finset.mem_filter, Finset.mem_univ, true_and] + · intro i hi + rfl + apply globalWronskianInequality_of_weightedPlacewiseBounds + (fun i ↦ finiteExtensionPlaceDegree K L i.1) S + (finiteExtensionFamilyOrder K L f iU) + (finiteExtensionFamilyOrder K L f iV) + (finiteExtensionFamilyOrder K L f iRho) + (finiteExtensionFamilyOrder K L f iGrid) + (finiteExtensionFamilyOrder K L f iW) + h k n sigma + (finiteExtensionPositiveDegree K L (f iU)) + (finiteExtensionPositiveDegree K L (f iV)) + chi (finiteExtensionFamilyOutsideHeight K L f S iRho) + canonicalDegree + · exact hUOutside + · exact hGridOutside + · exact hUSum + · exact hGridSum + · exact hDegreeV + · exact hOutside' + · simpa only [finiteExtensionFamilyWeightedOrder] using hCanonical + · exact hEuler + · simpa only [finiteExtensionFamilyWeightedOrder] using hRhoSupport + · exact hCaseI + · exact hCaseII + · exact hCaseIII + · exact hCaseIV + +end WeightedFamilies + +section AlgebraicallyClosedProbe + +variable [IsAlgClosed K] + +local instance finiteIntegralClosureConstantAlgebra : + Algebra K (RatFuncFiniteIntegralClosure K L) := + RingHom.toAlgebra ((algebraMap K[X] (RatFuncFiniteIntegralClosure K L)).comp + (algebraMap K K[X])) + +local instance finiteIntegralClosureConstantTower : + IsScalarTower K K[X] (RatFuncFiniteIntegralClosure K L) := + .of_algebraMap_eq' rfl + +noncomputable def ratFuncFinitePlaceResidueEquiv (p : HeightOneSpectrum K[X]) : + p.asIdeal.ResidueField ≃ₐ[K] K := by + let r := finitePlaceNormalizedPrime p + have hr0 : (r : K[X]) ≠ 0 := r.property.1.ne_zero + have hrmonic : (r : K[X]).Monic := + (Polynomial.normalize_eq_self_iff_monic hr0).mp r.property.2 + have hrdegree : (r : K[X]).degree = 1 := + IsAlgClosed.degree_eq_one_of_irreducible K r.property.1.irreducible + let c : K := -(r : K[X]).coeff 0 + have hrlinear : (r : K[X]) = Polynomial.X - Polynomial.C c := by + rw [Polynomial.eq_X_add_C_of_degree_eq_one hrdegree, hrmonic.leadingCoeff] + simp [c] + have hpideal : p.asIdeal = Ideal.span + ({Polynomial.X - Polynomial.C c} : Set K[X]) := by + calc + p.asIdeal = (normalizedPrimeFinitePlace (K := K) r).asIdeal := by + rw [normalizedPrimeFinitePlace_finitePlaceNormalizedPrime] + _ = Ideal.span ({(r : K[X])} : Set K[X]) := rfl + _ = Ideal.span ({Polynomial.X - Polynomial.C c} : Set K[X]) := by + rw [hrlinear] + let eQuot : (K[X] ⧸ p.asIdeal) ≃ₐ[K] K := + (Ideal.quotientEquivAlgOfEq K hpideal).trans + (Polynomial.quotientSpanXSubCAlgEquiv c) + let eResidue : (K[X] ⧸ p.asIdeal) ≃ₐ[K] p.asIdeal.ResidueField := + AlgEquiv.ofBijective + (IsScalarTower.toAlgHom K (K[X] ⧸ p.asIdeal) p.asIdeal.ResidueField) + p.asIdeal.bijective_algebraMap_quotient_residueField + exact eResidue.symm.trans eQuot + +omit [DecidableEq (RatFunc K)] in +theorem ratFuncFinitePlaceDegree_eq_one (p : HeightOneSpectrum K[X]) : + ratFuncFinitePlaceDegree p = 1 := by + let r := finitePlaceNormalizedPrime p + have hrdegree : (r : K[X]).degree = 1 := + IsAlgClosed.degree_eq_one_of_irreducible K r.property.1.irreducible + rw [ratFuncFinitePlaceDegree] + exact Polynomial.natDegree_eq_of_degree_eq_some hrdegree + +omit [DecidableEq K] in +omit [DecidableEq (RatFunc K)] in +theorem finiteExtensionFinitePlace_inertiaDeg_eq_one + (q : FiniteExtensionFinitePlace K L) : + q.asIdeal.inertiaDeg K[X] = 1 := by + classical + let p := HeightOneSpectrum.under K[X] q + let : q.asIdeal.LiesOver p.asIdeal := ⟨rfl⟩ + let hLocalAlg := + Localization.AtPrime.algebraOfLiesOver p.asIdeal q.asIdeal + have : IsScalarTower K[X] (Localization.AtPrime p.asIdeal) + (Localization.AtPrime q.asIdeal) := inferInstance + let : IsAlgClosed p.asIdeal.ResidueField := + IsAlgClosed.of_ringEquiv K p.asIdeal.ResidueField + (ratFuncFinitePlaceResidueEquiv K p).symm.toRingEquiv + let : Algebra.QuasiFiniteAt K[X] q.asIdeal := inferInstance + let : Module.Finite p.asIdeal.ResidueField q.asIdeal.ResidueField := + inferInstance + let : Algebra.IsIntegral p.asIdeal.ResidueField q.asIdeal.ResidueField := + Algebra.IsIntegral.of_finite _ _ + rw [Ideal.inertiaDeg_eq p.asIdeal q.asIdeal, + Algebra.finrank_eq_one_iff_bijective_algebraMap] + exact IsAlgClosed.algebraMap_bijective_of_isIntegral + +/-- Over an algebraically closed constant field, all actual places of the +extension have degree one. -/ +theorem finiteExtensionPlaceDegree_eq_one + (v : FiniteExtensionPlace K L) : + finiteExtensionPlaceDegree K L v = 1 := by + cases v with + | inl q => + simp [finiteExtensionPlaceDegree, + finiteExtensionFinitePlace_inertiaDeg_eq_one K L q, + ratFuncFinitePlaceDegree_eq_one K + (HeightOneSpectrum.under K[X] q)] + | inr P => + simpa [finiteExtensionPlaceDegree] using + finiteExtensionInfinityPlace_inertiaDeg_eq_one K L P + +section AlgebraicallyClosedFamilies + +variable {A : Type*} [Fintype A] + +omit [DecidableEq K] in +/-- Ordinary (unweighted) product formula on the common family place type. -/ +theorem finiteExtensionFamilyOrder_sum_eq_zero + (f : A → L) (a : A) (ha : f a ≠ 0) : + ∑ v : FiniteExtensionFamilyPlace K L f, + finiteExtensionFamilyOrder K L f a v = 0 := by + classical + have hweighted := finiteExtensionFamilyWeightedOrder_sum_eq_zero K L f a ha + simpa only [finiteExtensionFamilyWeightedOrder, + finiteExtensionPlaceDegree_eq_one K L, + Int.ofNat_eq_natCast, Nat.cast_one, mul_one] using hweighted + +theorem finiteExtensionFamilyWeightedOrder_eq_order + (f : A → L) (a : A) (v : FiniteExtensionFamilyPlace K L f) : + finiteExtensionFamilyWeightedOrder K L f a v = + finiteExtensionFamilyOrder K L f a v := by + rw [finiteExtensionFamilyWeightedOrder, + finiteExtensionPlaceDegree_eq_one K L] + simp + +/-- The global Corvaja--Zannier summation specialized to the exhaustive family +place type. Principal-divisor sums, the positive degree of `V`, and the pole +height of `rho` outside `S` are discharged by this file. The exceptional-set +support conditions, canonical-divisor identity and bound, rho support bound, +and the four local Wronskian estimates remain explicit inputs. -/ +theorem globalWronskianInequality_of_finiteExtensionPlacewiseBounds + (f : A → L) (iU iV iRho iGrid iW : A) + (S : Finset (FiniteExtensionFamilyPlace K L f)) + (h k n sigma chi : ℕ) (canonicalDegree : ℤ) + (hUne : f iU ≠ 0) (hGridne : f iGrid ≠ 0) + (hUOutside : ∀ i, i ∉ S → + finiteExtensionFamilyOrder K L f iU i = 0) + (hGridOutside : ∀ i, i ∉ S → + finiteExtensionFamilyOrder K L f iGrid i = 0) + (hVPositiveSupport : ∀ i, + 0 < finiteExtensionFamilyOrder K L f iV i → i ∈ S) + (hCanonical : + ∑ i, finiteExtensionFamilyOrder K L f iW i = + (sigma : ℤ) * canonicalDegree) + (hEuler : canonicalDegree + S.card ≤ (chi : ℤ)) + (hRhoSupport : + -((finiteExtensionPositiveDegree K L (f iU) : ℤ) + + (finiteExtensionPositiveDegree K L (f iV) : ℤ)) ≤ + ∑ i ∈ S, finiteExtensionFamilyOrder K L f iRho i) + (hCaseI : ∀ i, i ∉ S → + finiteExtensionFamilyOrder K L f iRho i < 0 → + (n : ℤ) * finiteExtensionFamilyOrder K L f iRho i ≤ + finiteExtensionFamilyOrder K L f iW i) + (hCaseII : ∀ i, i ∉ S → + 0 ≤ finiteExtensionFamilyOrder K L f iRho i → + 0 ≤ finiteExtensionFamilyOrder K L f iW i) + (hCaseIII : ∀ i, i ∈ S → + 0 < finiteExtensionFamilyOrder K L f iV i → + ((k * (k - 1) / 2 : ℕ) : ℤ) * + finiteExtensionFamilyOrder K L f iU i + + ((h * k : ℕ) : ℤ) * finiteExtensionFamilyOrder K L f iV i + + (k : ℤ) * finiteExtensionFamilyOrder K L f iRho i + + finiteExtensionFamilyOrder K L f iGrid i - (sigma : ℤ) ≤ + finiteExtensionFamilyOrder K L f iW i) + (hCaseIV : ∀ i, i ∈ S → + finiteExtensionFamilyOrder K L f iV i ≤ 0 → + ((k * (k - 1) / 2 : ℕ) : ℤ) * + finiteExtensionFamilyOrder K L f iU i + + (k : ℤ) * finiteExtensionFamilyOrder K L f iRho i + + finiteExtensionFamilyOrder K L f iGrid i - (sigma : ℤ) ≤ + finiteExtensionFamilyOrder K L f iW i) : + ((h * k : ℕ) : ℤ) * + (finiteExtensionPositiveDegree K L (f iV) : ℤ) - + (k : ℤ) * + ((finiteExtensionPositiveDegree K L (f iU) : ℤ) + + (finiteExtensionPositiveDegree K L (f iV) : ℤ)) - + (sigma : ℤ) * (chi : ℤ) ≤ + (n : ℤ) * + (finiteExtensionFamilyOutsideHeight K L f S iRho : ℤ) := by + classical + have hUSum : ∑ i, finiteExtensionFamilyOrder K L f iU i = 0 := + finiteExtensionFamilyOrder_sum_eq_zero K L f iU hUne + have hGridSum : ∑ i, finiteExtensionFamilyOrder K L f iGrid i = 0 := + finiteExtensionFamilyOrder_sum_eq_zero K L f iGrid hGridne + have hPositiveAll := finiteExtensionFamilyWeightedPositiveSum K L f iV + simp_rw [finiteExtensionFamilyWeightedOrder_eq_order K L f iV] at hPositiveAll + have hDegreeV : + ∑ i ∈ S.filter (fun i => + 0 < finiteExtensionFamilyOrder K L f iV i), + finiteExtensionFamilyOrder K L f iV i = + finiteExtensionPositiveDegree K L (f iV) := by + calc + _ = ∑ i ∈ Finset.univ.filter (fun i => + 0 < finiteExtensionFamilyOrder K L f iV i), + finiteExtensionFamilyOrder K L f iV i := by + apply Finset.sum_subset + · intro i hi + exact Finset.mem_filter.mpr ⟨Finset.mem_univ i, + (Finset.mem_filter.mp hi).2⟩ + · intro i hi hiS + have hpos := (Finset.mem_filter.mp hi).2 + exact False.elim + (hiS (Finset.mem_filter.mpr ⟨hVPositiveSupport i hpos, hpos⟩)) + _ = _ := hPositiveAll + have hOutside := finiteExtensionFamilyOutsideHeight_negativeSum K L f S iRho + simp_rw [finiteExtensionFamilyWeightedOrder_eq_order K L f iRho] at hOutside + have hOutside' : + ∑ i ∈ Finset.univ.filter (fun i => i ∉ S ∧ + finiteExtensionFamilyOrder K L f iRho i < 0), + finiteExtensionFamilyOrder K L f iRho i = + -((finiteExtensionFamilyOutsideHeight K L f S iRho : ℕ) : ℤ) := by + convert hOutside using 1 + apply Finset.sum_congr + · ext i + simp only [Finset.mem_filter, Finset.mem_univ, true_and] + · intro i hi + rfl + exact globalWronskianInequality_of_placewiseBounds + S + (finiteExtensionFamilyOrder K L f iU) + (finiteExtensionFamilyOrder K L f iV) + (finiteExtensionFamilyOrder K L f iRho) + (finiteExtensionFamilyOrder K L f iGrid) + (finiteExtensionFamilyOrder K L f iW) + h k n sigma + (finiteExtensionPositiveDegree K L (f iU)) + (finiteExtensionPositiveDegree K L (f iV)) + chi (finiteExtensionFamilyOutsideHeight K L f S iRho) + canonicalDegree hUOutside hGridOutside hUSum hGridSum hDegreeV + hOutside' hCanonical hEuler hRhoSupport hCaseI hCaseII hCaseIII hCaseIV + +end AlgebraicallyClosedFamilies + +end AlgebraicallyClosedProbe + +end +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/FiniteExtensionProductFormula.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/FiniteExtensionProductFormula.lean new file mode 100644 index 0000000000..b390f4fced --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/FiniteExtensionProductFormula.lean @@ -0,0 +1,318 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.RiemannRoch.SeparableRelNorm +public import Mathlib.FieldTheory.IsSepClosed + +/-! +# Finite-extension norm and place-count formula + +For a finite torsion-free extension of Dedekind domains, this file identifies +the exponent of the relative norm of an integral ideal at a height-one prime +with the inertia-degree-weighted sum of the ideal's exponents at all primes +above it. The principal-integral specialization gives the corresponding +formula for `Algebra.intNorm`. + +This is the finite-place norm bridge needed to pass from the rational-function +field product formula to a finite function-field extension. The final theorem +clears a denominator to extend the identity to arbitrary elements of the +fraction field. Places at infinity are treated separately. +-/ + +@[expose] public section + +open scoped nonZeroDivisors +open IsDedekindDomain UniqueFactorizationMonoid + +attribute [local instance] FractionRing.liftAlgebra + FractionRing.isScalarTower_liftAlgebra + +namespace BGS.CorvajaZannier + +noncomputable section + + +section PrimeOver + +variable {R S : Type*} [CommRing R] [IsDomain R] + [CommRing S] [IsDomain S] [Algebra R S] [Module.IsTorsionFree R S] + +/-- A prime of `S` over a height-one prime of `R`, regarded as a height-one +prime of `S`. -/ +def primeOverHeightOne (p : HeightOneSpectrum R) + (P : p.asIdeal.primesOver S) : HeightOneSpectrum S where + asIdeal := P.1 + isPrime := P.2.1 + ne_bot := Ideal.ne_bot_of_mem_primesOver p.ne_bot P.2 + +@[simp] +theorem primeOverHeightOne_asIdeal (p : HeightOneSpectrum R) + (P : p.asIdeal.primesOver S) : + (primeOverHeightOne p P).asIdeal = P.1 := rfl + +end PrimeOver + +section RelativeNorm + +variable {R S : Type*} [CommRing R] [IsDedekindDomain R] + [CommRing S] [IsDedekindDomain S] [Algebra R S] [Module.Finite R S] + [Module.IsTorsionFree R S] + [Algebra.IsSeparable (FractionRing R) (FractionRing S)] + +local instance relativeNormFractionRingFiniteDimensional : + FiniteDimensional (FractionRing R) (FractionRing S) := + Module.Finite.of_isLocalization R S R⁰ + +local notation3 "K" => FractionRing R +local notation3 "L" => FractionRing S + +/-- The maximal-prime relative-norm formula needs separability of the actual +fraction-field extension, not perfectness of the base fraction field. The +normal-closure proof is the same as Mathlib's +`Ideal.relNorm_eq_pow_of_isMaximal`, with that sharper hypothesis. -/ +private theorem relNorm_eq_pow_of_isMaximal_of_isSeparable + (P : Ideal S) (p : Ideal R) [P.LiesOver p] + [P.IsMaximal] [p.IsMaximal] : + Ideal.relNorm R P = p ^ P.inertiaDeg R := by + exact Ideal.relNorm_eq_pow_of_isMaximal_of_isSeparable P p + +private theorem count_relNorm_heightOne_of_liesOver (p : HeightOneSpectrum R) + (Q : HeightOneSpectrum S) (hQp : Q.asIdeal.LiesOver p.asIdeal) : + FractionalIdeal.count (FractionRing R) p + (Ideal.relNorm R Q.asIdeal : + FractionalIdeal R⁰ (FractionRing R)) = + Q.asIdeal.inertiaDeg R := by + classical + have hpmax : p.asIdeal.IsMaximal := + Ring.DimensionLEOne.maximalOfPrime p.ne_bot p.isPrime + have hQmax : Q.asIdeal.IsMaximal := + Ring.DimensionLEOne.maximalOfPrime Q.ne_bot Q.isPrime + let : Q.asIdeal.LiesOver p.asIdeal := hQp + rw [relNorm_eq_pow_of_isMaximal_of_isSeparable Q.asIdeal p.asIdeal] + rw [FractionalIdeal.coeIdeal_pow] + simp [FractionalIdeal.count_pow, FractionalIdeal.count_self] + +private theorem count_relNorm_heightOne_of_not_liesOver + (p : HeightOneSpectrum R) (Q : HeightOneSpectrum S) + (hQp : ¬ Q.asIdeal.LiesOver p.asIdeal) : + FractionalIdeal.count (FractionRing R) p + (Ideal.relNorm R Q.asIdeal : + FractionalIdeal R⁰ (FractionRing R)) = 0 := by + classical + let q : HeightOneSpectrum R := HeightOneSpectrum.under R Q + have hqmax : q.asIdeal.IsMaximal := + Ring.DimensionLEOne.maximalOfPrime q.ne_bot q.isPrime + have hQmax : Q.asIdeal.IsMaximal := + Ring.DimensionLEOne.maximalOfPrime Q.ne_bot Q.isPrime + have hQq : Q.asIdeal.LiesOver q.asIdeal := by + change Q.asIdeal.LiesOver (Q.asIdeal.under R) + infer_instance + have hqp : q ≠ p := by + intro heq + apply hQp + rw [← heq] + exact hQq + let : Q.asIdeal.LiesOver q.asIdeal := hQq + rw [relNorm_eq_pow_of_isMaximal_of_isSeparable Q.asIdeal q.asIdeal] + rw [FractionalIdeal.coeIdeal_pow] + rw [FractionalIdeal.count_pow, + FractionalIdeal.count_maximal_coprime (FractionRing R) p hqp] + simp + +/-- The finite-prime exponent of the relative norm of an integral ideal is +the residue-degree-weighted sum of its exponents at primes above it. -/ +theorem count_relNorm_eq_sum_inertiaDeg_mul_count + (p : HeightOneSpectrum R) [Fintype (p.asIdeal.primesOver S)] + (I : Ideal S) : + FractionalIdeal.count (FractionRing R) p + (Ideal.relNorm R I : FractionalIdeal R⁰ (FractionRing R)) = + ∑ P : p.asIdeal.primesOver S, + (P.1.inertiaDeg R : ℤ) * + FractionalIdeal.count (FractionRing S) (primeOverHeightOne p P) + (I : FractionalIdeal S⁰ (FractionRing S)) := by + classical + let property : Ideal S → Prop := fun J ↦ + FractionalIdeal.count (FractionRing R) p + (Ideal.relNorm R J : FractionalIdeal R⁰ (FractionRing R)) = + ∑ P : p.asIdeal.primesOver S, + (P.1.inertiaDeg R : ℤ) * + FractionalIdeal.count (FractionRing S) (primeOverHeightOne p P) + (J : FractionalIdeal S⁰ (FractionRing S)) + by_cases hI : I = ⊥ + · subst hI + simp [FractionalIdeal.count_zero] + rw [← Ideal.prod_normalizedFactors_eq_self hI] + refine Multiset.prod_induction property (normalizedFactors I) ?_ ?_ ?_ + · intro A B hA hB + by_cases hA0 : A = ⊥ + · subst hA0 + simp [property, FractionalIdeal.count_zero] + by_cases hB0 : B = ⊥ + · subst hB0 + simp [property, FractionalIdeal.count_zero] + simp only [property, map_mul, FractionalIdeal.coeIdeal_mul] + rw [FractionalIdeal.count_mul _ _ + (FractionalIdeal.coeIdeal_ne_zero.mpr + (Ideal.relNorm_eq_bot_iff.not.mpr hA0)) + (FractionalIdeal.coeIdeal_ne_zero.mpr + (Ideal.relNorm_eq_bot_iff.not.mpr hB0)), hA, hB] + simp_rw [FractionalIdeal.count_mul _ _ + (FractionalIdeal.coeIdeal_ne_zero.mpr hA0) + (FractionalIdeal.coeIdeal_ne_zero.mpr hB0), mul_add] + exact Finset.sum_add_distrib.symm + · simp [property, FractionalIdeal.count_one] + · intro Q hQ + have hQ0 : Q ≠ ⊥ := + UniqueFactorizationMonoid.ne_zero_of_mem_normalizedFactors hQ + rw [Ideal.mem_normalizedFactors_iff hI] at hQ + let q : HeightOneSpectrum S := ⟨Q, hQ.1, hQ0⟩ + dsimp only [property] + by_cases hQp : Q.LiesOver p.asIdeal + · rw [count_relNorm_heightOne_of_liesOver p q hQp] + let P : p.asIdeal.primesOver S := ⟨Q, hQ.1, hQp⟩ + rw [Finset.sum_eq_single P] + · have heq : primeOverHeightOne p P = q := by + apply HeightOneSpectrum.ext + rfl + rw [heq] + have hcount : + FractionalIdeal.count (FractionRing S) q + (Q : FractionalIdeal S⁰ (FractionRing S)) = 1 := by + change FractionalIdeal.count (FractionRing S) q + (q.asIdeal : FractionalIdeal S⁰ (FractionRing S)) = 1 + exact FractionalIdeal.count_self (FractionRing S) q + rw [hcount, mul_one] + · intro P' _ hP' + have hne : primeOverHeightOne p P' ≠ q := by + intro heq + apply hP' + apply Subtype.ext + exact HeightOneSpectrum.ext_iff.mp heq + have hcount : + FractionalIdeal.count (FractionRing S) (primeOverHeightOne p P') + (Q : FractionalIdeal S⁰ (FractionRing S)) = 0 := by + change FractionalIdeal.count (FractionRing S) (primeOverHeightOne p P') + (q.asIdeal : FractionalIdeal S⁰ (FractionRing S)) = 0 + exact FractionalIdeal.count_maximal_coprime + (FractionRing S) (primeOverHeightOne p P') hne.symm + rw [hcount, mul_zero] + · intro hP + exact (hP (Finset.mem_univ P)).elim + · rw [count_relNorm_heightOne_of_not_liesOver p q hQp] + symm + apply Finset.sum_eq_zero + intro P _ + have hne : primeOverHeightOne p P ≠ q := by + intro heq + apply hQp + have hPQ : P.1 = Q := HeightOneSpectrum.ext_iff.mp heq + rw [← hPQ] + exact P.2.2 + have hcount : + FractionalIdeal.count (FractionRing S) (primeOverHeightOne p P) + (Q : FractionalIdeal S⁰ (FractionRing S)) = 0 := by + change FractionalIdeal.count (FractionRing S) (primeOverHeightOne p P) + (q.asIdeal : FractionalIdeal S⁰ (FractionRing S)) = 0 + exact FractionalIdeal.count_maximal_coprime + (FractionRing S) (primeOverHeightOne p P) hne.symm + rw [hcount, mul_zero] + +/-- For an integral element, the finite-place order of its integral norm is +the residue-degree-weighted sum of the principal orders above the place. -/ +theorem count_spanSingleton_intNorm_eq_sum_inertiaDeg_mul_count + (p : HeightOneSpectrum R) [Fintype (p.asIdeal.primesOver S)] + (x : S) : + FractionalIdeal.count (FractionRing R) p + (FractionalIdeal.spanSingleton R⁰ + (algebraMap R (FractionRing R) (Algebra.intNorm R S x))) = + ∑ P : p.asIdeal.primesOver S, + (P.1.inertiaDeg R : ℤ) * + FractionalIdeal.count (FractionRing S) (primeOverHeightOne p P) + (FractionalIdeal.spanSingleton S⁰ + (algebraMap S (FractionRing S) x)) := by + simpa only [Ideal.relNorm_singleton, + FractionalIdeal.coeIdeal_span_singleton] using + count_relNorm_eq_sum_inertiaDeg_mul_count p (Ideal.span {x}) + +/-- The same principal-integral identity with the field norm written +explicitly in the fraction fields. -/ +theorem count_spanSingleton_norm_algebraMap_eq_sum_inertiaDeg_mul_count + (p : HeightOneSpectrum R) [Fintype (p.asIdeal.primesOver S)] + (x : S) : + FractionalIdeal.count (FractionRing R) p + (FractionalIdeal.spanSingleton R⁰ + (Algebra.norm (FractionRing R) + (algebraMap S (FractionRing S) x))) = + ∑ P : p.asIdeal.primesOver S, + (P.1.inertiaDeg R : ℤ) * + FractionalIdeal.count (FractionRing S) (primeOverHeightOne p P) + (FractionalIdeal.spanSingleton S⁰ + (algebraMap S (FractionRing S) x)) := by + simpa only [Algebra.algebraMap_intNorm_fractionRing] using + count_spanSingleton_intNorm_eq_sum_inertiaDeg_mul_count p x + +/-- For an arbitrary fraction-field element, the finite-place order of its +field norm is the residue-degree-weighted sum of its principal orders at the +places above the given base place. -/ +theorem count_spanSingleton_norm_eq_sum_inertiaDeg_mul_count + (p : HeightOneSpectrum R) [Fintype (p.asIdeal.primesOver S)] + (x : FractionRing S) : + FractionalIdeal.count (FractionRing R) p + (FractionalIdeal.spanSingleton R⁰ + (Algebra.norm (FractionRing R) x)) = + ∑ P : p.asIdeal.primesOver S, + (P.1.inertiaDeg R : ℤ) * + FractionalIdeal.count (FractionRing S) (primeOverHeightOne p P) + (FractionalIdeal.spanSingleton S⁰ x) := by + obtain ⟨a, b, hb, rfl⟩ := IsFractionRing.div_surjective S x + have hb0 : b ≠ 0 := nonZeroDivisors.ne_zero hb + by_cases ha0 : a = 0 + · subst a + simp [FractionalIdeal.count_zero] + have hma0 : algebraMap S (FractionRing S) a ≠ 0 := by simp [ha0] + have hmb0 : algebraMap S (FractionRing S) b ≠ 0 := by simp [hb0] + have hna0 : Algebra.norm (FractionRing R) + (algebraMap S (FractionRing S) a) ≠ 0 := Algebra.norm_ne_zero_iff.mpr hma0 + have hnb0 : Algebra.norm (FractionRing R) + (algebraMap S (FractionRing S) b) ≠ 0 := Algebra.norm_ne_zero_iff.mpr hmb0 + have hcount (q : HeightOneSpectrum S) : + FractionalIdeal.count (FractionRing S) q + (FractionalIdeal.spanSingleton S⁰ + (algebraMap S (FractionRing S) a * + (algebraMap S (FractionRing S) b)⁻¹)) = + FractionalIdeal.count (FractionRing S) q + (FractionalIdeal.spanSingleton S⁰ + (algebraMap S (FractionRing S) a)) - + FractionalIdeal.count (FractionRing S) q + (FractionalIdeal.spanSingleton S⁰ + (algebraMap S (FractionRing S) b)) := by + rw [← FractionalIdeal.spanSingleton_mul_spanSingleton, + ← FractionalIdeal.spanSingleton_inv, + FractionalIdeal.count_mul _ _ + ((FractionalIdeal.spanSingleton_ne_zero_iff).2 hma0) + (inv_ne_zero ((FractionalIdeal.spanSingleton_ne_zero_iff).2 hmb0)), + FractionalIdeal.count_inv] + simp [sub_eq_add_neg] + rw [div_eq_mul_inv, map_mul, Algebra.norm_inv, + ← FractionalIdeal.spanSingleton_mul_spanSingleton, + ← FractionalIdeal.spanSingleton_inv] + rw [FractionalIdeal.count_mul _ _ + ((FractionalIdeal.spanSingleton_ne_zero_iff).2 hna0) + (inv_ne_zero ((FractionalIdeal.spanSingleton_ne_zero_iff).2 hnb0)), + FractionalIdeal.count_inv] + simp_rw [hcount, mul_sub] + rw [count_spanSingleton_norm_algebraMap_eq_sum_inertiaDeg_mul_count p a, + count_spanSingleton_norm_algebraMap_eq_sum_inertiaDeg_mul_count p b, + Finset.sum_sub_distrib] + simp [sub_eq_add_neg] + +end RelativeNorm + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/FiniteExtensionResidueSurjectivity.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/FiniteExtensionResidueSurjectivity.lean new file mode 100644 index 0000000000..b1571b5530 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/FiniteExtensionResidueSurjectivity.lean @@ -0,0 +1,167 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionPrincipalDivisor + +/-! +# Constants surject onto residue fields of all function-field places + +Let `L / K(X)` be finite and separable, with `K` algebraically closed. At a +finite place of `L`, the residue field is integral over the residue field of +the place below it; the latter is canonically `K`. The same argument applies +above infinity, using the explicit residue equivalence at the rational +function infinity place. Thus constants surject onto every residue field. + +This is the exact coefficient-lifting input used by Corvaja--Zannier case (i): +equal negative leading terms can be cancelled by a genuine constant. +-/ + +@[expose] public section + +open scoped nonZeroDivisors Polynomial +open IsDedekindDomain + +namespace BGS.CorvajaZannier + +noncomputable section + +variable (K : Type*) [Field K] [DecidableEq K] [DecidableEq (RatFunc K)] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +local instance (priority := 10) residuePolynomialAlgebra : Algebra K[X] L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K[X] (RatFunc K))) + +local instance residuePolynomialScalarTower : + IsScalarTower K[X] (RatFunc K) L := + .of_algebraMap_eq' rfl + +local instance residueFiniteIntegralClosureModuleFinite : + Module.Finite K[X] (RatFuncFiniteIntegralClosure K L) := + Module.IsNoetherian.finite K[X] (RatFuncFiniteIntegralClosure K L) + +local instance residueFiniteIntegralClosureIsIntegral : + Algebra.IsIntegral K[X] (RatFuncFiniteIntegralClosure K L) := + IsIntegralClosure.isIntegral_algebra K[X] L + +local instance residuePolynomialTorsionFreeTop : + Module.IsTorsionFree K[X] L := + Module.IsTorsionFree.trans_faithfulSMul K[X] (RatFunc K) L + +local instance residueFiniteIntegralClosureIsTorsionFree : + Module.IsTorsionFree K[X] (RatFuncFiniteIntegralClosure K L) := + IsIntegralClosure.isTorsionFree K[X] L + +local instance residueFiniteIntegralClosureConstantAlgebra : + Algebra K (RatFuncFiniteIntegralClosure K L) := + RingHom.toAlgebra ((algebraMap K[X] + (RatFuncFiniteIntegralClosure K L)).comp (algebraMap K K[X])) + +local instance residueFiniteIntegralClosureConstantTower : + IsScalarTower K K[X] (RatFuncFiniteIntegralClosure K L) := + .of_algebraMap_eq' rfl + +local instance residueInfinityConstantAlgebra : + Algebra K (RatFuncInfinityIntegers K) := + (ratFuncInfinityConstantRingHom K).toAlgebra + +local instance residueInfinityConstantTower : + IsScalarTower K (RatFuncInfinityIntegers K) (RatFunc K) := + .of_algebraMap_eq' rfl + +local instance residueInfinityIntegralClosureModuleFinite : + Module.Finite (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.finite (RatFuncInfinityIntegers K) (RatFunc K) L + (RatFuncInfinityIntegralClosure K L) + +local instance residueInfinityIntegralClosureIsIntegral : + Algebra.IsIntegral (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.isIntegral_algebra (RatFuncInfinityIntegers K) L + +local instance residueInfinityIntegralClosureConstantAlgebra : + Algebra K (RatFuncInfinityIntegralClosure K L) := + RingHom.toAlgebra + ((algebraMap (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L)).comp + (algebraMap K (RatFuncInfinityIntegers K))) + +local instance residueInfinityIntegralClosureConstantTower : + IsScalarTower K (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) := + .of_algebraMap_eq' rfl + +variable [IsAlgClosed K] + +omit [DecidableEq K] in +omit [DecidableEq (RatFunc K)] in +/-- Constants surject onto the residue field of every finite place of a finite +separable extension of `K(X)`, when `K` is algebraically closed. -/ +theorem finiteExtensionFinitePlace_constantResidue_surjective + (q : FiniteExtensionFinitePlace K L) : + Function.Surjective (algebraMap K q.asIdeal.ResidueField) := by + classical + let p := HeightOneSpectrum.under K[X] q + let : q.asIdeal.LiesOver p.asIdeal := ⟨rfl⟩ + let hLocalAlg := + Localization.AtPrime.algebraOfLiesOver p.asIdeal q.asIdeal + have : IsScalarTower K[X] (Localization.AtPrime p.asIdeal) + (Localization.AtPrime q.asIdeal) := inferInstance + let : Algebra.QuasiFiniteAt K[X] q.asIdeal := inferInstance + let : Module.Finite p.asIdeal.ResidueField q.asIdeal.ResidueField := + inferInstance + let : Algebra.IsIntegral p.asIdeal.ResidueField q.asIdeal.ResidueField := + Algebra.IsIntegral.of_finite _ _ + let e := ratFuncFinitePlaceResidueEquiv K p + let : IsAlgClosed p.asIdeal.ResidueField := + IsAlgClosed.of_ringEquiv K p.asIdeal.ResidueField e.symm.toRingEquiv + let : IsScalarTower K p.asIdeal.ResidueField q.asIdeal.ResidueField := + inferInstance + intro z + obtain ⟨a, ha⟩ := + (IsAlgClosed.algebraMap_bijective_of_isIntegral + (k := p.asIdeal.ResidueField) (K := q.asIdeal.ResidueField)).2 z + refine ⟨e a, ?_⟩ + rw [← ha, IsScalarTower.algebraMap_apply K p.asIdeal.ResidueField] + congr 1 + apply e.injective + simp + +/-- Constants surject onto the residue field of every place above infinity in +a finite separable extension of `K(X)`, when `K` is algebraically closed. -/ +theorem finiteExtensionInfinityPlace_constantResidue_surjective + (P : FiniteExtensionInfinityPlace K L) : + Function.Surjective (algebraMap K P.1.ResidueField) := by + let p := (ratFuncInfinityPlace K).asIdeal + let hLocalAlg := + Localization.AtPrime.algebraOfLiesOver p P.1 + have : IsScalarTower (RatFuncInfinityIntegers K) (Localization.AtPrime p) + (Localization.AtPrime P.1) := inferInstance + let : Algebra.QuasiFiniteAt (RatFuncInfinityIntegers K) P.1 := + inferInstance + let : Module.Finite p.ResidueField P.1.ResidueField := inferInstance + let : Algebra.IsIntegral p.ResidueField P.1.ResidueField := + Algebra.IsIntegral.of_finite _ _ + let e := ratFuncInfinityPlaceResidueEquiv K + let : IsAlgClosed p.ResidueField := + IsAlgClosed.of_ringEquiv K p.ResidueField e.symm.toRingEquiv + let : IsScalarTower K p.ResidueField P.1.ResidueField := inferInstance + intro z + obtain ⟨a, ha⟩ := + (IsAlgClosed.algebraMap_bijective_of_isIntegral + (k := p.ResidueField) (K := P.1.ResidueField)).2 z + refine ⟨e a, ?_⟩ + rw [← ha, IsScalarTower.algebraMap_apply K p.ResidueField] + congr 1 + simpa using (e.symm.commutes (e a)).symm + +end +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/FiniteFunctionFieldDegree.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/FiniteFunctionFieldDegree.lean new file mode 100644 index 0000000000..22eddacaf7 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/FiniteFunctionFieldDegree.lean @@ -0,0 +1,166 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import Mathlib.FieldTheory.Finite.Basic +public import Mathlib.FieldTheory.RatFunc.IntermediateField +public import Mathlib.FieldTheory.Relrank + +/-! +# Frobenius degree of a finite function field + +Let `k` be a finite field and put `q = #k`. The `q`-power Frobenius is a +`k`-algebra endomorphism, since it fixes every element of `k`. This file +proves that a finite extension `L / k(X)` has degree exactly `q` over the +image of that endomorphism. + +This `q` is the cardinality of the constant field, not merely its +characteristic `p`. Thus `q = p` only when `k` is the prime field. The +Corvaja--Zannier formulation with `k` contained in a larger field of +cardinality `q ^ m` corresponds to an iterate of this Frobenius step; the +declarations below prove the single `#k`-power step. + +No separability hypothesis is required. Frobenius transports the finite +extension `L / k(X)` to the corresponding extension of image fields, while +the rational function field contributes the factor `q`. +-/ + +@[expose] public section + +namespace BGS.CorvajaZannier + +noncomputable section + +open IntermediateField RatFunc +open scoped Polynomial + +variable (k : Type*) [Field k] [Fintype k] + +/-- In `k(X)`, the image of the `#k`-power Frobenius is exactly +`k(X ^ #k)`. -/ +theorem ratFunc_frobeniusFieldRange_eq_adjoin_pow_card : + (FiniteField.frobeniusAlgHom k k⟮X⟯).fieldRange = + k⟮(X : k⟮X⟯) ^ Fintype.card k⟯ := by + calc + (FiniteField.frobeniusAlgHom k k⟮X⟯).fieldRange = + (⊤ : IntermediateField k k⟮X⟯).map + (FiniteField.frobeniusAlgHom k k⟮X⟯) := + AlgHom.fieldRange_eq_map _ + _ = k⟮(FiniteField.frobeniusAlgHom k k⟮X⟯) (X : k⟮X⟯)⟯ := by + rw [← RatFunc.adjoin_X (K := k), IntermediateField.adjoin_map] + simp + _ = k⟮(X : k⟮X⟯) ^ Fintype.card k⟯ := by + rw [FiniteField.frobeniusAlgHom_apply] + +/-- The rational function field has degree `#k` over the image of its +`#k`-power Frobenius. -/ +theorem ratFunc_finrank_frobeniusFieldRange_eq_card : + Module.finrank (FiniteField.frobeniusAlgHom k k⟮X⟯).fieldRange k⟮X⟯ = + Fintype.card k := by + rw [ratFunc_frobeniusFieldRange_eq_adjoin_pow_card] + rw [RatFunc.finrank_eq_max_natDegree] + have hpow : (X : k⟮X⟯) ^ Fintype.card k = + algebraMap k[X] k⟮X⟯ (Polynomial.X ^ Fintype.card k) := by + simp + rw [hpow, RatFunc.num_algebraMap, RatFunc.denom_algebraMap] + simp + +variable {L : Type*} [Field L] [Algebra k L] [Algebra k⟮X⟯ L] + [IsScalarTower k k⟮X⟯ L] [FiniteDimensional k⟮X⟯ L] + +/-- A finite extension of `k(X)` has degree `#k` over the image of its +`#k`-power Frobenius. + +The proof compares the two towers through the Frobenius image. The embedded +rational base contributes degree `#k`, and Frobenius preserves the relative +degree of the finite top extension. -/ +theorem finiteFunctionField_finrank_frobeniusFieldRange_eq_card : + Module.finrank (FiniteField.frobeniusAlgHom k L).fieldRange L = + Fintype.card k := by + let i : k⟮X⟯ →ₐ[k] L := Algebra.algHom k k⟮X⟯ L + let φF : k⟮X⟯ →ₐ[k] k⟮X⟯ := FiniteField.frobeniusAlgHom k k⟮X⟯ + let φL : L →ₐ[k] L := FiniteField.frobeniusAlgHom k L + let F0 : IntermediateField k L := i.fieldRange + let Fq0 : IntermediateField k L := φF.fieldRange.map i + let Lq : IntermediateField k L := φL.fieldRange + have hcomp : φL.comp i = i.comp φF := by + ext x + change (i x) ^ Fintype.card k = i (x ^ Fintype.card k) + exact (map_pow i x (Fintype.card k)).symm + have hFmap : F0.map φL = Fq0 := by + change i.fieldRange.map φL = φF.fieldRange.map i + rw [AlgHom.map_fieldRange, AlgHom.map_fieldRange, hcomp] + have hTopMap : (⊤ : IntermediateField k L).map φL = Lq := by + exact (AlgHom.fieldRange_eq_map φL).symm + have hRelativeFrobenius : + IntermediateField.relfinrank Fq0 Lq = + IntermediateField.relfinrank F0 (⊤ : IntermediateField k L) := by + have h := IntermediateField.relfinrank_map_map + F0 (⊤ : IntermediateField k L) φL + rwa [hFmap, hTopMap] at h + have hFq0F0 : Fq0 ≤ F0 := by + change φF.fieldRange.map i ≤ i.fieldRange + calc + φF.fieldRange.map i ≤ + (⊤ : IntermediateField k k⟮X⟯).map i := + IntermediateField.map_mono i le_top + _ = i.fieldRange := (AlgHom.fieldRange_eq_map i).symm + have hFq0Lq : Fq0 ≤ Lq := by + rw [← hFmap, ← hTopMap] + exact IntermediateField.map_mono φL le_top + have hBaseDegree : + IntermediateField.relfinrank Fq0 F0 = Fintype.card k := by + have h := IntermediateField.relfinrank_map_map + φF.fieldRange (⊤ : IntermediateField k k⟮X⟯) i + change IntermediateField.relfinrank Fq0 F0 = Fintype.card k + calc + IntermediateField.relfinrank Fq0 F0 = + IntermediateField.relfinrank φF.fieldRange + (⊤ : IntermediateField k k⟮X⟯) := by + simpa only [Fq0, F0, AlgHom.fieldRange_eq_map] using h + _ = Module.finrank φF.fieldRange k⟮X⟯ := + IntermediateField.relfinrank_top_right _ + _ = Fintype.card k := ratFunc_finrank_frobeniusFieldRange_eq_card k + have hBaseTower := IntermediateField.relfinrank_mul_relfinrank + hFq0F0 (show F0 ≤ (⊤ : IntermediateField k L) from le_top) + have hFrobeniusTower := IntermediateField.relfinrank_mul_relfinrank + hFq0Lq (show Lq ≤ (⊤ : IntermediateField k L) from le_top) + rw [hBaseDegree] at hBaseTower + rw [hRelativeFrobenius] at hFrobeniusTower + let e : k⟮X⟯ ≃ₐ[k] F0 := i.equivFieldRange + let b := Module.finBasis k⟮X⟯ L + let b0 := b.mapCoeffs e.toRingEquiv (by + intro c x + simp only [Algebra.smul_def] + apply congrArg (· * x) + simp only [e, F0] + exact Algebra.algHom_apply k k⟮X⟯ L c) + let : FiniteDimensional F0 L := b0.finiteDimensional_of_finite + have hF0TopPos : 0 < IntermediateField.relfinrank F0 + (⊤ : IntermediateField k L) := by + rw [IntermediateField.relfinrank_top_right] + exact Module.finrank_pos + have hcancel : + IntermediateField.relfinrank F0 (⊤ : IntermediateField k L) * Fintype.card k = + IntermediateField.relfinrank F0 (⊤ : IntermediateField k L) * + IntermediateField.relfinrank Lq (⊤ : IntermediateField k L) := by + calc + _ = Fintype.card k * + IntermediateField.relfinrank F0 (⊤ : IntermediateField k L) := Nat.mul_comm _ _ + _ = IntermediateField.relfinrank Fq0 (⊤ : IntermediateField k L) := hBaseTower + _ = IntermediateField.relfinrank F0 (⊤ : IntermediateField k L) * + IntermediateField.relfinrank Lq (⊤ : IntermediateField k L) := + hFrobeniusTower.symm + have hResult : IntermediateField.relfinrank Lq + (⊤ : IntermediateField k L) = Fintype.card k := by + exact (Nat.mul_left_cancel hF0TopPos hcancel).symm + rw [← IntermediateField.relfinrank_top_right Lq] + exact hResult + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/FinitePlaceCompletion.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/FinitePlaceCompletion.lean new file mode 100644 index 0000000000..f12f82d853 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/FinitePlaceCompletion.lean @@ -0,0 +1,134 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import Mathlib.RingTheory.DedekindDomain.AdicValuation +public import Mathlib.RingTheory.DedekindDomain.Factorization + +/-! +# Finite places and their adic completions + +Let `R` be a Dedekind domain with fraction field `L`. Mathlib supplies both +the exponent `FractionalIdeal.count L v I` of a height-one prime `v` in a +fractional ideal `I` and the `v`-adic completion of `L`. This file connects +those two interfaces for principal fractional ideals. + +For a nonzero global function `x`, the valuation of its image in the actual +adic completion is `exp (-ord_v(x))`, where `ord_v(x)` is the exponent of `v` +in `(x)`. The orders at all finite places are also packaged as a genuine +finitely supported divisor. This is the finite-place part of the global +divisor infrastructure needed in the Corvaja--Zannier Wronskian argument. + +It does not add the places above infinity, a degree map on divisors, or the +canonical-divisor degree formula. +-/ + +@[expose] public section + +open scoped nonZeroDivisors +open IsDedekindDomain Multiplicative WithZero + +namespace BGS.CorvajaZannier + +noncomputable section + +variable {R L : Type*} [CommRing R] [IsDedekindDomain R] + [Field L] [Algebra R L] [IsFractionRing R L] + +/-- The additive order of `x` at the finite place `v`, defined as the +exponent of `v` in the principal fractional ideal `(x)`. -/ +def finitePlaceOrder (v : HeightOneSpectrum R) (x : L) : ℤ := + FractionalIdeal.count L v (FractionalIdeal.spanSingleton R⁰ x) + +/-- The multiplicative `v`-adic valuation is the exponential of minus the +additive order defined by principal fractional-ideal factorization. -/ +theorem valuation_eq_exp_neg_finitePlaceOrder + (v : HeightOneSpectrum R) (x : L) (hx : x ≠ 0) : + v.valuation L x = exp (-finitePlaceOrder v x) := by + obtain ⟨⟨n, d, hd⟩, hnd⟩ := IsLocalization.surj (nonZeroDivisors R) x + obtain rfl : x = IsLocalization.mk' L n ⟨d, hd⟩ := + IsLocalization.eq_mk'_iff_mul_eq.mpr hnd + have hn : n ≠ 0 := by + intro hn + apply hx + simp [hn] + have hd' : d ≠ 0 := nonZeroDivisors.ne_zero hd + have hprincipal : + FractionalIdeal.spanSingleton R⁰ (IsLocalization.mk' L n ⟨d, hd⟩) = + FractionalIdeal.spanSingleton R⁰ ((algebraMap R L d)⁻¹) * + (↑(Ideal.span {n}) : FractionalIdeal R⁰ L) := by + rw [FractionalIdeal.coeIdeal_span_singleton, + FractionalIdeal.spanSingleton_mul_spanSingleton] + apply congrArg (FractionalIdeal.spanSingleton R⁰) + rw [IsFractionRing.mk'_eq_div, div_eq_mul_inv, mul_comm] + have hspan : + FractionalIdeal.spanSingleton R⁰ (IsLocalization.mk' L n ⟨d, hd⟩) ≠ 0 := by + rw [FractionalIdeal.spanSingleton_ne_zero_iff] + exact hx + rw [IsDedekindDomain.HeightOneSpectrum.valuation_of_mk', + IsDedekindDomain.HeightOneSpectrum.intValuation_if_neg v hn, + IsDedekindDomain.HeightOneSpectrum.intValuation_if_neg v hd', + finitePlaceOrder, + FractionalIdeal.count_well_defined L v hspan hprincipal] + rw [← exp_sub] + congr 1 + ring + +/-- The canonical embedding of the global fraction field into the actual +adic completion attached to a finite place. -/ +def finitePlaceCompletionEmbedding (v : HeightOneSpectrum R) : + L →+* v.adicCompletion L := + algebraMap L (v.adicCompletion L) + +theorem finitePlaceCompletionEmbedding_injective (v : HeightOneSpectrum R) : + Function.Injective (finitePlaceCompletionEmbedding (R := R) (L := L) v) := + (finitePlaceCompletionEmbedding (R := R) (L := L) v).injective + +/-- After the canonical completion embedding, the completed-field valuation +still records the exponent of `v` in the global principal fractional ideal. -/ +theorem valued_finitePlaceCompletionEmbedding_eq_exp_neg_order + (v : HeightOneSpectrum R) (x : L) (hx : x ≠ 0) : + Valued.v (finitePlaceCompletionEmbedding (R := R) (L := L) v x) = + exp (-finitePlaceOrder v x) := by + calc + Valued.v (finitePlaceCompletionEmbedding (R := R) (L := L) v x) = + v.valuation L x := by + simp [finitePlaceCompletionEmbedding, + IsDedekindDomain.HeightOneSpectrum.algebraMap_adicCompletion] + _ = exp (-finitePlaceOrder v x) := + valuation_eq_exp_neg_finitePlaceOrder v x hx + +/-- The finite-place part of the principal divisor of `x`. Finiteness is +provided by unique factorization of nonzero fractional ideals in a Dedekind +domain (and is harmlessly true for `x = 0` under Mathlib's `count 0 = 0` +convention). -/ +def finitePrincipalDivisor (x : L) : HeightOneSpectrum R →₀ ℤ := + let h := FractionalIdeal.finite_factors + (FractionalIdeal.spanSingleton R⁰ x) + Finsupp.mk h.toFinset (fun v ↦ finitePlaceOrder v x) + (fun _ ↦ h.mem_toFinset) + +@[simp] +theorem finitePrincipalDivisor_apply (x : L) (v : HeightOneSpectrum R) : + finitePrincipalDivisor x v = finitePlaceOrder v x := rfl + +/-- The finite principal divisor of a nonzero product is the sum of the two +finite principal divisors. -/ +theorem finitePrincipalDivisor_mul + (x y : L) (hx : x ≠ 0) (hy : y ≠ 0) : + finitePrincipalDivisor (R := R) (x * y) = + finitePrincipalDivisor (R := R) x + finitePrincipalDivisor (R := R) y := by + ext v + simp only [finitePrincipalDivisor_apply, Finsupp.add_apply, finitePlaceOrder] + rw [← FractionalIdeal.spanSingleton_mul_spanSingleton, + FractionalIdeal.count_mul L v] + · exact FractionalIdeal.spanSingleton_ne_zero_iff.mpr hx + · exact FractionalIdeal.spanSingleton_ne_zero_iff.mpr hy + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/FrobeniusSubfield.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/FrobeniusSubfield.lean new file mode 100644 index 0000000000..e41ffec486 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/FrobeniusSubfield.lean @@ -0,0 +1,281 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import Mathlib.Algebra.CharP.Frobenius +public import Mathlib.Algebra.Field.Subfield.Basic +public import Mathlib.Algebra.Polynomial.Derivation +public import Mathlib.Algebra.Polynomial.Expand +public import Mathlib.FieldTheory.IntermediateField.Adjoin.Algebra +public import Mathlib.FieldTheory.KummerPolynomial +public import Mathlib.FieldTheory.PurelyInseparable.Basic +public import Mathlib.RingTheory.Adjoin.PowerBasis +public import Mathlib.RingTheory.Derivation.Basic + +/-! +# The Frobenius subfield + +Every derivation in characteristic `p` kills `p`-th powers. Consequently the +image of Frobenius is contained in the derivation's constant field. The +field extension over that image is purely inseparable. If a parameter `z` is +not a `p`-th power and the extension over `L^p(z)` is separable, the two +properties force `L = L^p(z)`; Kummer irreducibility then gives the exact +degree `[L : L^p] = p`. + +The last two hypotheses are the algebraic boundary at which the geometric +notion of a separating parameter enters. They are explicit theorem +hypotheses rather than hidden curve axioms. + +For such a parameter, polynomial differentiation descends along evaluation +at `z` to a derivation of `L`. Its constants are exactly the Frobenius +subfield: the degree-`< p` normal form of an element has zero derivative only +when it is constant. +-/ + +@[expose] public section + +namespace BGS.CorvajaZannier + +noncomputable section + +/-- The subfield of `p`-th powers in a field of prime characteristic `p`. -/ +abbrev frobeniusSubfield (L : Type*) [Field L] (p : ℕ) + [Fact p.Prime] [CharP L p] : Subfield L := + (frobenius L p).fieldRange + +variable {R L : Type*} [CommRing R] [Field L] [Algebra R L] + {p : ℕ} [Fact p.Prime] [CharP L p] + +/-- Every Frobenius power is killed by every derivation. -/ +theorem derivation_frobenius_eq_zero (D : Derivation R L L) (x : L) : + D (frobenius L p x) = 0 := by + rw [frobenius_def, D.leibniz_pow] + simp + +/-- The Frobenius image subfield is contained in the constant field of every +derivation. -/ +theorem frobenius_fieldRange_is_constant (D : Derivation R L L) + (x : (frobenius L p).fieldRange) : + D (x : L) = 0 := by + rcases x.2 with ⟨y, hy⟩ + rw [← hy] + exact derivation_frobenius_eq_zero D y + +section FrobeniusDegree + +variable {L : Type*} [Field L] (p : ℕ) [Fact p.Prime] [CharP L p] + +/-- The extension of a characteristic-`p` field over its Frobenius image is +purely inseparable (of exponent at most one). -/ +theorem frobeniusSubfield_isPurelyInseparable : + IsPurelyInseparable (frobeniusSubfield L p) L := by + rw [isPurelyInseparable_iff_pow_mem (frobeniusSubfield L p) p] + intro x + refine ⟨1, ?_⟩ + rw [pow_one] + exact ⟨⟨x ^ p, ⟨x, by simp [frobenius_def]⟩⟩, rfl⟩ + +/-- A parameter over which the Frobenius-pure extension becomes separable +generates the whole field over the Frobenius subfield. + +This is the algebraic first assertion of the separating-parameter lemma: the +extension over `L^p(z)` is simultaneously purely inseparable and separable, +and is therefore trivial. -/ +theorem adjoin_frobeniusSubfield_eq_top + (z : L) + [Algebra.IsSeparable + (IntermediateField.adjoin (frobeniusSubfield L p) {z}) L] : + IntermediateField.adjoin (frobeniusSubfield L p) {z} = ⊤ := by + let F : Subfield L := frobeniusSubfield L p + let E : IntermediateField F L := IntermediateField.adjoin F {z} + let : IsPurelyInseparable F L := frobeniusSubfield_isPurelyInseparable p + let : IsPurelyInseparable E L := IsPurelyInseparable.tower_top F E L + have hbij : Function.Bijective (algebraMap E L) := + IsPurelyInseparable.bijective_algebraMap_of_isSeparable E L + change E = ⊤ + apply top_unique + intro x _ + obtain ⟨y, hy⟩ := hbij.2 x + rw [← hy] + exact y.property + +/-- A Frobenius-separating parameter gives the exact degree of the Frobenius +subfield. + +The separability hypothesis implies that the simultaneously purely +inseparable extension `L / L^p(z)` is trivial. Since `z` is not in `L^p`, its +minimal polynomial over `L^p` is the irreducible polynomial +`X ^ p - z ^ p`, of degree `p`. -/ +theorem finrank_frobeniusSubfield_eq_char + (z : L) (hz : z ∉ frobeniusSubfield L p) + [Algebra.IsSeparable + (IntermediateField.adjoin (frobeniusSubfield L p) {z}) L] : + Module.finrank (frobeniusSubfield L p) L = p := by + let F : Subfield L := frobeniusSubfield L p + let E : IntermediateField F L := IntermediateField.adjoin F {z} + let zp : F := ⟨z ^ p, ⟨z, by simp [frobenius_def]⟩⟩ + have hnoRoot : ∀ b : F, b ^ p ≠ zp := by + intro b hb + apply hz + have hpowers : (b : L) ^ p = z ^ p := by + simpa [zp] using congrArg Subtype.val hb + have hbz : (b : L) = z := by + exact frobenius_inj L p (by simpa [frobenius_def] using hpowers) + rw [← hbz] + exact b.property + have hirr : Irreducible (Polynomial.X ^ p - Polynomial.C zp) := + X_pow_sub_C_irreducible_of_prime (Fact.out : p.Prime) hnoRoot + have hmonic : (Polynomial.X ^ p - Polynomial.C zp).Monic := + Polynomial.monic_X_pow_sub_C zp (Fact.out : p.Prime).ne_zero + have hroot : Polynomial.aeval z (Polynomial.X ^ p - Polynomial.C zp) = 0 := by + simp only [map_sub, map_pow, Polynomial.aeval_X, Polynomial.aeval_C] + rw [Subfield.algebraMap_ofSubfield] + simp [zp] + have hzint : IsIntegral F z := ⟨_, hmonic, hroot⟩ + have hminpoly : minpoly F z = Polynomial.X ^ p - Polynomial.C zp := + (minpoly.eq_of_irreducible_of_monic hirr hroot hmonic).symm + have hfinE : Module.finrank F E = p := by + rw [IntermediateField.adjoin.finrank hzint, hminpoly, + Polynomial.natDegree_X_pow_sub_C] + let : IsPurelyInseparable F L := frobeniusSubfield_isPurelyInseparable p + let : IsPurelyInseparable E L := IsPurelyInseparable.tower_top F E L + have hbij : Function.Bijective (algebraMap E L) := + IsPurelyInseparable.bijective_algebraMap_of_isSeparable E L + let e : E ≃ₐ[F] L := + AlgEquiv.ofBijective (IsScalarTower.toAlgHom F E L) hbij + exact e.toLinearEquiv.finrank_eq ▸ hfinE + +/-- A Frobenius-separating parameter determines a derivation whose constant +field is exactly the Frobenius subfield. + +The derivation is obtained by descending polynomial differentiation through +the surjective evaluation map `F[X] → L`, where `F = L^p`. Its kernel is +computed from the unique polynomial representative of degree less than `p`: +in characteristic `p`, a polynomial with zero derivative is an expansion in +`X ^ p`, and the degree bound forces that expansion to be constant. -/ +theorem exists_derivation_with_exact_frobenius_constants + (z : L) (hz : z ∉ frobeniusSubfield L p) + [Algebra.IsSeparable + (IntermediateField.adjoin (frobeniusSubfield L p) {z}) L] : + ∃ D : Derivation (frobeniusSubfield L p) L L, + D z = 1 ∧ + ∀ x : L, D x = 0 ↔ + ∃ c : frobeniusSubfield L p, + algebraMap (frobeniusSubfield L p) L c = x := by + let F : Subfield L := frobeniusSubfield L p + let E : IntermediateField F L := IntermediateField.adjoin F {z} + let zp : F := ⟨z ^ p, ⟨z, by simp [frobenius_def]⟩⟩ + have hnoRoot : ∀ b : F, b ^ p ≠ zp := by + intro b hb + apply hz + have hpowers : (b : L) ^ p = z ^ p := by + simpa [zp] using congrArg Subtype.val hb + have hbz : (b : L) = z := by + exact frobenius_inj L p (by simpa [frobenius_def] using hpowers) + rw [← hbz] + exact b.property + have hirr : Irreducible (Polynomial.X ^ p - Polynomial.C zp) := + X_pow_sub_C_irreducible_of_prime (Fact.out : p.Prime) hnoRoot + have hmonic : (Polynomial.X ^ p - Polynomial.C zp).Monic := + Polynomial.monic_X_pow_sub_C zp (Fact.out : p.Prime).ne_zero + have hroot : Polynomial.aeval z (Polynomial.X ^ p - Polynomial.C zp) = 0 := by + simp only [map_sub, map_pow, Polynomial.aeval_X, Polynomial.aeval_C] + rw [Subfield.algebraMap_ofSubfield] + simp [zp] + have hzint : IsIntegral F z := ⟨_, hmonic, hroot⟩ + have hminpoly : minpoly F z = Polynomial.X ^ p - Polynomial.C zp := + (minpoly.eq_of_irreducible_of_monic hirr hroot hmonic).symm + let : IsPurelyInseparable F L := frobeniusSubfield_isPurelyInseparable p + let : IsPurelyInseparable E L := IsPurelyInseparable.tower_top F E L + have hbij : Function.Bijective (algebraMap E L) := + IsPurelyInseparable.bijective_algebraMap_of_isSeparable E L + have hEtop : E = ⊤ := by + apply top_unique + intro x hx + obtain ⟨y, hy⟩ := hbij.2 x + rw [← hy] + exact y.property + have hAlgTop : Algebra.adjoin F {z} = ⊤ := by + have hzalg : IsAlgebraic F z := hzint.isAlgebraic + apply (IntermediateField.adjoin_eq_top_iff_of_isAlgebraic + (S := ({z} : Set L)) (by simpa)).mp + simpa [E] using hEtop + have heval : Function.Surjective + (Polynomial.aeval z : Polynomial F →ₐ[F] L) := by + rw [← AlgHom.range_eq_top, ← Algebra.adjoin_singleton_eq_range_aeval] + exact hAlgTop + have hderivMin : Polynomial.derivative (minpoly F z) = 0 := by + rw [hminpoly] + simp [Polynomial.derivative_pow] + have hstable : ∀ q : Polynomial F, Polynomial.aeval z q = 0 → + Polynomial.aeval z q.derivative = 0 := by + intro q hq + rcases minpoly.dvd F z hq with ⟨r, rfl⟩ + rw [Polynomial.derivative_mul, hderivMin] + simp [minpoly.aeval] + let D : Derivation F L L := + Polynomial.derivative'.liftOfSurjective heval hstable + have hDz : D z = 1 := by + have h := Derivation.liftOfSurjective_apply + (d := Polynomial.derivative') heval hstable Polynomial.X + simpa [D] using h + refine ⟨D, hDz, ?_⟩ + intro x + change D x = 0 ↔ ∃ c : F, algebraMap F L c = x + constructor + · intro hx + let pb : PowerBasis F L := PowerBasis.ofAdjoinEqTop hzint hAlgTop + obtain ⟨q, hqdeg, hxq⟩ := pb.exists_eq_aeval x + have hpbgen : pb.gen = z := PowerBasis.ofAdjoinEqTop_gen hzint hAlgTop + have hpbDim : pb.dim = p := by + rw [PowerBasis.ofAdjoinEqTop_dim, hminpoly, + Polynomial.natDegree_X_pow_sub_C] + rw [hpbDim] at hqdeg + rw [hpbgen] at hxq + have hEvalDeriv : Polynomial.aeval z q.derivative = 0 := by + have h := Derivation.liftOfSurjective_apply + (d := Polynomial.derivative') heval hstable q + change Polynomial.aeval z (Polynomial.derivative' q) = 0 + rw [← h, ← hxq] + exact hx + have hqderiv : q.derivative = 0 := by + by_contra hne + have hdvd : minpoly F z ∣ q.derivative := minpoly.dvd F z hEvalDeriv + have hle := Polynomial.natDegree_le_of_dvd hdvd hne + rw [hminpoly, Polynomial.natDegree_X_pow_sub_C] at hle + have hlt : q.derivative.natDegree < p := by + exact (Polynomial.natDegree_derivative_le q).trans_lt + ((Nat.sub_le q.natDegree 1).trans_lt hqdeg) + exact (Nat.not_lt_of_ge hle) hlt + have hexpand : Polynomial.expand F p (Polynomial.contract p q) = q := + Polynomial.expand_contract p hqderiv (Fact.out : p.Prime).ne_zero + have hcontractDegree : (Polynomial.contract p q).natDegree = 0 := by + have hdegrees : (Polynomial.contract p q).natDegree * p = q.natDegree := by + simpa only [Polynomial.natDegree_expand] using + congrArg Polynomial.natDegree hexpand + by_contra hne + have hpos : 0 < (Polynomial.contract p q).natDegree := Nat.pos_of_ne_zero hne + have hp_le : p ≤ q.natDegree := by + calc + p ≤ (Polynomial.contract p q).natDegree * p := + Nat.le_mul_of_pos_left p hpos + _ = q.natDegree := hdegrees + exact (Nat.not_le_of_lt hqdeg) hp_le + have hqConstant : q = Polynomial.C ((Polynomial.contract p q).coeff 0) := by + rw [← hexpand, Polynomial.eq_C_of_natDegree_eq_zero hcontractDegree] + simp + refine ⟨(Polynomial.contract p q).coeff 0, ?_⟩ + rw [hxq, hqConstant] + simp + · rintro ⟨c, rfl⟩ + exact D.map_algebraMap c + +end FrobeniusDegree + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/FrobeniusWronskian.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/FrobeniusWronskian.lean new file mode 100644 index 0000000000..5357624929 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/FrobeniusWronskian.lean @@ -0,0 +1,54 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Algebra.DifferentialWronskian +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FrobeniusSubfield + +/-! +# Frobenius constants and ordinary Wronskians + +A Frobenius-separating parameter supplies a derivation whose exact constant +field is the Frobenius subfield. Combining that construction with the +ordinary differential-field Wronskian criterion gives the algebraic +Wronskian boundary used in the Corvaja--Zannier argument. +-/ + +@[expose] public section + +namespace BGS.CorvajaZannier + +noncomputable section + +variable {L : Type*} [Field L] (p : ℕ) [Fact p.Prime] [CharP L p] + +/-- A Frobenius-separating parameter gives a derivation normalized by +`D z = 1`, with exact constant field `L^p`, for which every finite family has +nonzero ordinary Wronskian exactly when it is linearly independent over +`L^p`. -/ +theorem exists_derivation_with_exact_constants_and_wronskian_criterion + (z : L) (hz : z ∉ frobeniusSubfield L p) + [Algebra.IsSeparable + (IntermediateField.adjoin (frobeniusSubfield L p) {z}) L] : + ∃ D : Derivation (frobeniusSubfield L p) L L, + D z = 1 ∧ + (∀ x : L, D x = 0 ↔ + ∃ c : frobeniusSubfield L p, + algebraMap (frobeniusSubfield L p) L c = x) ∧ + ∀ (n : ℕ) (f : Fin n → L), + (BGS.Algebra.derivationWronskian D f).det ≠ 0 ↔ + LinearIndependent (frobeniusSubfield L p) f := by + obtain ⟨D, hDz, hconstants⟩ := + exists_derivation_with_exact_frobenius_constants p z hz + refine ⟨D, hDz, hconstants, ?_⟩ + intro n f + exact BGS.Algebra.derivationWronskian_det_ne_zero_iff_linearIndependent D + (fun x hx ↦ (hconstants x).mp hx) f + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/FunctionFieldProductFormula.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/FunctionFieldProductFormula.lean new file mode 100644 index 0000000000..3d97739614 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/FunctionFieldProductFormula.lean @@ -0,0 +1,184 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import Mathlib.NumberTheory.RatFunc.Ostrowski +public import Mathlib.RingTheory.DedekindDomain.Factorization +public import Mathlib.RingTheory.Ideal.IsPrincipal +public import Mathlib.RingTheory.UniqueFactorizationDomain.NormalizedFactors +public import Mathlib.Algebra.Polynomial.BigOperators + +/-! +# A normalized-factor product formula for the rational function field + +This file proves the normalized-factor form of the degree-zero formula for a +principal divisor on `K(X)`. At every normalized prime factor, the +multiplicity is identified with the actual Dedekind-domain exponent +`FractionalIdeal.count` of the principal fractional ideal. Normalized +polynomial factorization makes the finite contribution explicit; the +remaining term is Mathlib's valuation at infinity. Packaging that finite +contribution as one exhaustive sum over `HeightOneSpectrum K[X]` is completed +in `RatFuncExhaustiveProductFormula`. + +This is the base-field input for the Corvaja--Zannier valuation argument. It +does **not** yet supply the corresponding formula for a finite extension of +`K(X)`: Mathlib currently has no packaged degree map on the divisor group of +the integral closure, nor the global finite-place identity combining +ramification and residue degrees over each base place. +-/ + +@[expose] public section + +open scoped nonZeroDivisors +open IsDedekindDomain Polynomial UniqueFactorizationMonoid +open Multiplicative WithZero + +namespace BGS.CorvajaZannier + +noncomputable section + +variable {K : Type*} [Field K] + +/-- The height-one prime of `K[X]` cut out by a prime polynomial. -/ +def polynomialFinitePlace (r : K[X]) (hr : Prime r) : HeightOneSpectrum K[X] where + asIdeal := Ideal.span {r} + isPrime := (Ideal.span_singleton_prime hr.ne_zero).2 hr + ne_bot := by + intro h + exact hr.ne_zero (Ideal.span_singleton_eq_bot.mp h) + +@[simp] +theorem polynomialFinitePlace_asIdeal (r : K[X]) (hr : Prime r) : + (polynomialFinitePlace r hr).asIdeal = Ideal.span {r} := rfl + +/-- The sum of the degrees of the normalized irreducible factors of a +nonzero polynomial, with multiplicity, is its degree. -/ +theorem sum_normalizedFactor_natDegree [DecidableEq K] + (p : K[X]) (hp : p ≠ 0) : + ∑ r ∈ (normalizedFactors p).toFinset, + (normalizedFactors p).count r * r.natDegree = p.natDegree := by + have hprodDegree : (normalizedFactors p).prod.natDegree = p.natDegree := + Polynomial.natDegree_eq_of_degree_eq + (Polynomial.degree_eq_degree_of_associated (prod_normalizedFactors hp)) + calc + ∑ r ∈ (normalizedFactors p).toFinset, + (normalizedFactors p).count r * r.natDegree = + (Multiset.map Polynomial.natDegree (normalizedFactors p)).sum := by + simpa [nsmul_eq_mul, mul_comm] using + (Finset.sum_multiset_map_count (normalizedFactors p) + Polynomial.natDegree).symm + _ = (normalizedFactors p).prod.natDegree := by + rw [Polynomial.natDegree_multiset_prod] + exact zero_notMem_normalizedFactors p + _ = p.natDegree := hprodDegree + +/-- The additive order of a rational function at a finite polynomial place, +implemented by the Dedekind-domain exponent of its principal fractional ideal. -/ +def ratFuncFiniteOrder (v : HeightOneSpectrum K[X]) (f : RatFunc K) : ℤ := + FractionalIdeal.count (RatFunc K) v + (FractionalIdeal.spanSingleton (K[X])⁰ f) + +private theorem ratFunc_principal_fractionalIdeal_representation + (f : RatFunc K) : + FractionalIdeal.spanSingleton (K[X])⁰ f = + FractionalIdeal.spanSingleton (K[X])⁰ + ((algebraMap K[X] (RatFunc K) f.denom)⁻¹) * + (↑(Ideal.span {f.num}) : FractionalIdeal (K[X])⁰ (RatFunc K)) := by + rw [FractionalIdeal.coeIdeal_span_singleton, + FractionalIdeal.spanSingleton_mul_spanSingleton] + apply congrArg (FractionalIdeal.spanSingleton (K[X])⁰) + simpa only [div_eq_mul_inv, mul_comm] using (RatFunc.num_div_denom f).symm + +/-- At a normalized prime polynomial, the Dedekind-domain order of a +nonzero rational function is the numerator multiplicity minus the denominator +multiplicity. -/ +theorem ratFuncFiniteOrder_polynomialFinitePlace + [DecidableEq K] + (f : RatFunc K) (hf : f ≠ 0) (r : K[X]) (hr : Prime r) + (hrnorm : normalize r = r) : + ratFuncFiniteOrder (polynomialFinitePlace r hr) f = + ((normalizedFactors f.num).count r : ℤ) - + (normalizedFactors f.denom).count r := by + have hprincipal : + FractionalIdeal.spanSingleton (K[X])⁰ f ≠ 0 := by + rw [FractionalIdeal.spanSingleton_ne_zero_iff] + exact hf + rw [ratFuncFiniteOrder, + FractionalIdeal.count_well_defined (RatFunc K) + (polynomialFinitePlace r hr) hprincipal + (ratFunc_principal_fractionalIdeal_representation f)] + change + ((Associates.mk (Ideal.span {r})).count + (Associates.mk (Ideal.span {f.num})).factors : ℤ) - + ((Associates.mk (Ideal.span {r})).count + (Associates.mk (Ideal.span {f.denom})).factors : ℤ) = _ + congr 1 <;> norm_cast + · rw [Ideal.count_associates_factors_eq + (by + intro h + exact RatFunc.num_ne_zero hf (Ideal.span_singleton_eq_bot.mp h)) + ((Ideal.span_singleton_prime hr.ne_zero).2 hr) + (by + intro h + exact hr.ne_zero (Ideal.span_singleton_eq_bot.mp h)), + Ideal.count_span_normalizedFactors_eq (RatFunc.num_ne_zero hf) hr, + hrnorm] + · rw [Ideal.count_associates_factors_eq + (by + intro h + exact f.denom_ne_zero (Ideal.span_singleton_eq_bot.mp h)) + ((Ideal.span_singleton_prime hr.ne_zero).2 hr) + (by + intro h + exact hr.ne_zero (Ideal.span_singleton_eq_bot.mp h)), + Ideal.count_span_normalizedFactors_eq f.denom_ne_zero hr, + hrnorm] + +/-- The degree-weighted finite-place contribution of a nonzero rational +function, written as its zero contribution minus its pole contribution. The +preceding theorem identifies the multiplicities here with +`FractionalIdeal.count` at the corresponding height-one primes. -/ +def ratFuncFinitePlaceDegreeSum [DecidableEq K] (f : RatFunc K) : ℤ := + (∑ r ∈ (normalizedFactors f.num).toFinset, + (normalizedFactors f.num).count r * r.natDegree : ℕ) - + (∑ r ∈ (normalizedFactors f.denom).toFinset, + (normalizedFactors f.denom).count r * r.natDegree : ℕ) + +/-- The additive order at infinity. Mathlib's multiplicative infinity +valuation sends a nonzero `f` to `exp (-ratFuncInfinityOrder f)`. -/ +def ratFuncInfinityOrder (f : RatFunc K) : ℤ := -f.intDegree + +theorem inftyValuation_eq_exp_neg_ratFuncInfinityOrder + [DecidableEq (RatFunc K)] (f : RatFunc K) (hf : f ≠ 0) : + RatFunc.inftyValuation K f = + exp (-ratFuncInfinityOrder f) := by + rw [RatFunc.inftyValuation_apply] + rw [RatFunc.inftyValuation_of_nonzero (F := K) hf] + simp only [ratFuncInfinityOrder, neg_neg] + +theorem ratFuncFinitePlaceDegreeSum_eq_intDegree + [DecidableEq K] + (f : RatFunc K) (hf : f ≠ 0) : + ratFuncFinitePlaceDegreeSum f = f.intDegree := by + rw [ratFuncFinitePlaceDegreeSum, + sum_normalizedFactor_natDegree f.num (RatFunc.num_ne_zero hf), + sum_normalizedFactor_natDegree f.denom f.denom_ne_zero] + rfl + +/-- The normalized-factor form of the product formula for `K(X)`: the +degree-weighted numerator-minus-denominator contribution plus the order at +infinity is zero. -/ +theorem ratFunc_finitePlace_plus_infinity_productFormula + [DecidableEq K] + (f : RatFunc K) (hf : f ≠ 0) : + ratFuncFinitePlaceDegreeSum f + ratFuncInfinityOrder f = 0 := by + rw [ratFuncFinitePlaceDegreeSum_eq_intDegree f hf] + simp only [ratFuncInfinityOrder, add_neg_cancel] + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/GeneralCorvajaZannier.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/GeneralCorvajaZannier.lean new file mode 100644 index 0000000000..448940cdf2 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/GeneralCorvajaZannier.lean @@ -0,0 +1,126 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurvePropositionTwoGeometric +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurvePropositionTwoDegreeBridge +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PoweredImageIndexBound + +/-! +# The general Corvaja--Zannier plane-curve theorem + +This file is the final public assembly. Its first theorem isolates the sole +powered-image index input, so that the geometric index theorem can be audited +independently; the unconditional endpoint below instantiates that input. +-/ + +@[expose] public section + +namespace BGS.CorvajaZannier + +noncomputable section + + +/-- A uniform source-to-powered-image index bound supplies all Proposition 2 +certificates above the elementary range. -/ +theorem generalPlaneCurvePropositionTwoCertificatesAboveElementaryRange_of_poweredImageIndexBound + (hindex : ∀ (p : ℕ) [Fact p.Prime] + (K : Type) [Field K] [Fintype K] [DecidableEq K] [CharP K p] + (f : MvPolynomial (Fin 2) K) (m n : ℕ) + (hcurve : BGS.External.IsCorvajaZannierPlaneCurve f) + (_hm : 0 < m) (_hn : 0 < n) (_hmPrime : ¬ p ∣ m) (_hnPrime : ¬ p ∣ n), + let hf : Irreducible f := + irreducible_of_irreducible_map_algebraicClosure + hcurve.1 + letI := planeCurveCoordinateRing_isDomain hf + Module.finrank (PoweredImageOverFirst f m n) + (PlaneCurveFunctionField f) ≤ + 2 * MvPolynomial.degreeOf 0 f * MvPolynomial.degreeOf 1 f) : + GeneralPlaneCurvePropositionTwoCertificatesAboveElementaryRange := by + apply generalPlaneCurvePropositionTwoCertificatesAboveElementaryRange_of_actualDegree + intro p _ K _ _ _ _ f firstDegree secondDegree firstOrder secondOrder + _hfirstDegree _hsecondDegree hbidegree hcurve hfirstOrder hsecondOrder + hfirstPrimeToChar hsecondPrimeToChar hlarge + let hf : Irreducible f := + irreducible_of_irreducible_map_algebraicClosure hcurve.1 + have hfirstActual : MvPolynomial.degreeOf 0 f ≤ firstDegree := + degreeOf_first_le_of_hasBidegreeAtMost hbidegree + have hsecondActual : MvPolynomial.degreeOf 1 f ≤ secondDegree := + degreeOf_second_le_of_hasBidegreeAtMost hbidegree + have hactualDegreeProduct : + 12 * MvPolynomial.degreeOf 0 f * MvPolynomial.degreeOf 1 f ≤ + 12 * firstDegree * secondDegree := + Nat.mul_le_mul (Nat.mul_le_mul_left 12 hfirstActual) hsecondActual + have hlargeActual : + 12 * MvPolynomial.degreeOf 0 f * MvPolynomial.degreeOf 1 f < p := + hactualDegreeProduct.trans_lt hlarge + have hpoweredIndex : + letI := planeCurveCoordinateRing_isDomain hf + Module.finrank (PoweredImageOverFirst f firstOrder secondOrder) + (PlaneCurveFunctionField f) ≤ + 2 * MvPolynomial.degreeOf 0 f * MvPolynomial.degreeOf 1 f := by + simpa only [hf] using hindex p K f firstOrder secondOrder + hcurve hfirstOrder hsecondOrder hfirstPrimeToChar hsecondPrimeToChar + simpa only [hf] using + planeCurvePropositionTwo_of_poweredImageIndexBound + (p := p) hf hcurve.1 hcurve.2.2.1 hcurve.2.2.2 + firstOrder secondOrder hfirstOrder hsecondOrder + hfirstPrimeToChar hsecondPrimeToChar hlargeActual hpoweredIndex + +/-- The public finite-field Corvaja--Zannier theorem follows from the exact +powered-image index statement. -/ +theorem generalCorvajaZannierPlaneCurveTheorem_of_poweredImageIndexBound + (hindex : ∀ (p : ℕ) [Fact p.Prime] + (K : Type) [Field K] [Fintype K] [DecidableEq K] [CharP K p] + (f : MvPolynomial (Fin 2) K) (m n : ℕ) + (hcurve : BGS.External.IsCorvajaZannierPlaneCurve f) + (_hm : 0 < m) (_hn : 0 < n) (_hmPrime : ¬ p ∣ m) (_hnPrime : ¬ p ∣ n), + let hf : Irreducible f := + irreducible_of_irreducible_map_algebraicClosure + hcurve.1 + letI := planeCurveCoordinateRing_isDomain hf + Module.finrank (PoweredImageOverFirst f m n) + (PlaneCurveFunctionField f) ≤ + 2 * MvPolynomial.degreeOf 0 f * MvPolynomial.degreeOf 1 f) : + BGS.External.GeneralCorvajaZannierPlaneCurveTheorem := + generalCorvajaZannierPlaneCurveTheorem_of_certificates + (generalPlaneCurvePropositionTwoCertificatesAboveElementaryRange_of_poweredImageIndexBound + hindex) + +/-- The geometric powered-image index input required by the final assembly is +provided by the exact Galois stabilizer count. -/ +theorem poweredImageIndexBound_of_isCorvajaZannierPlaneCurve + (p : ℕ) [Fact p.Prime] + (K : Type) [Field K] [Fintype K] [DecidableEq K] [CharP K p] + (f : MvPolynomial (Fin 2) K) (m n : ℕ) + (hcurve : BGS.External.IsCorvajaZannierPlaneCurve f) + (hm : 0 < m) (hn : 0 < n) (hmPrime : ¬ p ∣ m) (hnPrime : ¬ p ∣ n) : + let hf : Irreducible f := + irreducible_of_irreducible_map_algebraicClosure hcurve.1 + letI := planeCurveCoordinateRing_isDomain hf + Module.finrank (PoweredImageOverFirst f m n) + (PlaneCurveFunctionField f) ≤ + 2 * MvPolynomial.degreeOf 0 f * MvPolynomial.degreeOf 1 f := by + exact finrank_poweredImageOverFirst_le_twice_bidegree + hcurve.1 hcurve.2.1 hcurve.2.2.1 hcurve.2.2.2 + m n hm hn hmPrime hnPrime + +/-- The unconditional certificates for the high-characteristic range. -/ +theorem generalPlaneCurvePropositionTwoCertificatesAboveElementaryRange : + GeneralPlaneCurvePropositionTwoCertificatesAboveElementaryRange := + generalPlaneCurvePropositionTwoCertificatesAboveElementaryRange_of_poweredImageIndexBound + poweredImageIndexBound_of_isCorvajaZannierPlaneCurve + +/-- **The general Corvaja--Zannier finite-field plane-curve theorem.** -/ +theorem generalCorvajaZannierPlaneCurveTheorem : + BGS.External.GeneralCorvajaZannierPlaneCurveTheorem := + generalCorvajaZannierPlaneCurveTheorem_of_poweredImageIndexBound + poweredImageIndexBound_of_isCorvajaZannierPlaneCurve + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/GlobalWronskianPlaceSum.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/GlobalWronskianPlaceSum.lean new file mode 100644 index 0000000000..b50896ceb7 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/GlobalWronskianPlaceSum.lean @@ -0,0 +1,192 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.GlobalWronskianSummation +public import Mathlib.Tactic + +/-! +# Summing the four local Corvaja--Zannier Wronskian cases + +This module proves the exact finite-support divisor summation used in +Corvaja--Zannier Proposition 2. Its hypotheses are the four already proved +local lower bounds together with explicit principal-divisor, degree, and +canonical-divisor identities. Thus it isolates the remaining geometric +boundary: constructing these data from the places of the plane-curve +function field. +-/ + +@[expose] public section + +namespace BGS.CorvajaZannier + +noncomputable section + +/-- Finite-support form of the summation step in the proof of +Corvaja--Zannier Proposition 2. -/ +theorem globalWronskianInequality_of_placewiseBounds + {ι : Type*} [Fintype ι] [DecidableEq ι] + (S : Finset ι) + (ordU ordV ordRho ordGrid ordW : ι → ℤ) + (h k n sigma degreeU degreeV chi heightOutside : ℕ) + (canonicalDegree : ℤ) + (hUOutside : ∀ i, i ∉ S → ordU i = 0) + (hGridOutside : ∀ i, i ∉ S → ordGrid i = 0) + (hUSum : ∑ i, ordU i = 0) + (hGridSum : ∑ i, ordGrid i = 0) + (hDegreeV : ∑ i ∈ S.filter (fun i ↦ 0 < ordV i), ordV i = degreeV) + (hOutsideHeight : + ∑ i ∈ Finset.univ.filter (fun i ↦ i ∉ S ∧ ordRho i < 0), ordRho i = + -(heightOutside : ℤ)) + (hCanonical : ∑ i, ordW i = (sigma : ℤ) * canonicalDegree) + (hEuler : canonicalDegree + S.card ≤ (chi : ℤ)) + (hRhoSupport : + -((degreeU : ℤ) + (degreeV : ℤ)) ≤ ∑ i ∈ S, ordRho i) + (hCaseI : ∀ i, i ∉ S → ordRho i < 0 → + (n : ℤ) * ordRho i ≤ ordW i) + (hCaseII : ∀ i, i ∉ S → 0 ≤ ordRho i → 0 ≤ ordW i) + (hCaseIII : ∀ i, i ∈ S → 0 < ordV i → + ((k * (k - 1) / 2 : ℕ) : ℤ) * ordU i + + ((h * k : ℕ) : ℤ) * ordV i + (k : ℤ) * ordRho i + + ordGrid i - (sigma : ℤ) ≤ ordW i) + (hCaseIV : ∀ i, i ∈ S → ordV i ≤ 0 → + ((k * (k - 1) / 2 : ℕ) : ℤ) * ordU i + + (k : ℤ) * ordRho i + ordGrid i - (sigma : ℤ) ≤ ordW i) : + ((h * k : ℕ) : ℤ) * (degreeV : ℤ) - + (k : ℤ) * ((degreeU : ℤ) + (degreeV : ℤ)) - + (sigma : ℤ) * (chi : ℤ) ≤ + (n : ℤ) * (heightOutside : ℤ) := by + let base : ι → ℤ := fun i ↦ + ((k * (k - 1) / 2 : ℕ) : ℤ) * ordU i + + (k : ℤ) * ordRho i + ordGrid i - (sigma : ℤ) + let lower : ι → ℤ := fun i ↦ + if i ∈ S then + base i + if 0 < ordV i then ((h * k : ℕ) : ℤ) * ordV i else 0 + else if ordRho i < 0 then (n : ℤ) * ordRho i else 0 + have hPointwise (i : ι) : lower i ≤ ordW i := by + by_cases hiS : i ∈ S + · by_cases hvi : 0 < ordV i + · have hLocal := hCaseIII i hiS hvi + simp only [lower, hiS, ite_eq_left, hvi] + dsimp [base] + norm_num at hLocal ⊢ + linarith + · have hvi' : ordV i ≤ 0 := le_of_not_gt hvi + simpa [lower, base, hiS, hvi] using hCaseIV i hiS hvi' + · by_cases hρi : ordRho i < 0 + · simpa [lower, hiS, hρi] using hCaseI i hiS hρi + · have hρi' : 0 ≤ ordRho i := le_of_not_gt hρi + simpa [lower, hiS, hρi] using hCaseII i hiS hρi' + have hSumLower : ∑ i, lower i ≤ ∑ i, ordW i := + Finset.sum_le_sum fun i _ ↦ hPointwise i + have hSumUOnS : ∑ i ∈ S, ordU i = 0 := by + calc + ∑ i ∈ S, ordU i = ∑ i, ordU i := by + apply Finset.sum_subset (Finset.subset_univ S) + intro i _ hiS + exact hUOutside i hiS + _ = 0 := hUSum + have hSumGridOnS : ∑ i ∈ S, ordGrid i = 0 := by + calc + ∑ i ∈ S, ordGrid i = ∑ i, ordGrid i := by + apply Finset.sum_subset (Finset.subset_univ S) + intro i _ hiS + exact hGridOutside i hiS + _ = 0 := hGridSum + have hPositiveVSum : + ∑ i ∈ S, (if 0 < ordV i then ((h * k : ℕ) : ℤ) * ordV i else 0) = + ((h * k : ℕ) : ℤ) * (degreeV : ℤ) := by + calc + _ = ∑ i ∈ S.filter (fun i ↦ 0 < ordV i), + ((h * k : ℕ) : ℤ) * ordV i := by + exact (Finset.sum_filter + (s := S) (fun i ↦ 0 < ordV i) + (fun i ↦ ((h * k : ℕ) : ℤ) * ordV i)).symm + _ = ((h * k : ℕ) : ℤ) * + (∑ i ∈ S.filter (fun i ↦ 0 < ordV i), ordV i) := by + rw [Finset.mul_sum] + _ = ((h * k : ℕ) : ℤ) * (degreeV : ℤ) := by rw [hDegreeV] + have hOutsideRhoSum : + ∑ i ∈ Finset.univ.filter (fun i ↦ i ∉ S), + (if ordRho i < 0 then (n : ℤ) * ordRho i else 0) = + -(n : ℤ) * (heightOutside : ℤ) := by + calc + _ = ∑ i ∈ (Finset.univ.filter (fun i ↦ i ∉ S)).filter + (fun i ↦ ordRho i < 0), (n : ℤ) * ordRho i := by + exact (Finset.sum_filter + (s := Finset.univ.filter (fun i ↦ i ∉ S)) + (fun i ↦ ordRho i < 0) + (fun i ↦ (n : ℤ) * ordRho i)).symm + _ = ∑ i ∈ Finset.univ.filter (fun i ↦ i ∉ S ∧ ordRho i < 0), + (n : ℤ) * ordRho i := by rw [Finset.filter_filter] + _ = (n : ℤ) * + (∑ i ∈ Finset.univ.filter (fun i ↦ i ∉ S ∧ ordRho i < 0), + ordRho i) := by rw [Finset.mul_sum] + _ = -(n : ℤ) * (heightOutside : ℤ) := by rw [hOutsideHeight]; ring + have hBaseSum : + ∑ i ∈ S, base i = + (k : ℤ) * (∑ i ∈ S, ordRho i) - (sigma : ℤ) * S.card := by + dsimp [base] + rw [Finset.sum_sub_distrib, Finset.sum_add_distrib, + Finset.sum_add_distrib, ← Finset.mul_sum, ← Finset.mul_sum, + hSumUOnS, hSumGridOnS] + simp + ring + have hLowerSum : + ∑ i, lower i = + (k : ℤ) * (∑ i ∈ S, ordRho i) - (sigma : ℤ) * S.card + + ((h * k : ℕ) : ℤ) * (degreeV : ℤ) - + (n : ℤ) * (heightOutside : ℤ) := by + have hSplit := Finset.sum_filter_add_sum_filter_not + Finset.univ (fun i ↦ i ∈ S) lower + have hFilterS : Finset.univ.filter (fun i ↦ i ∈ S) = S := by + ext i + simp + rw [hFilterS] at hSplit + calc + ∑ i, lower i = + (∑ i ∈ S, + (base i + if 0 < ordV i then ((h * k : ℕ) : ℤ) * ordV i else 0)) + + ∑ i ∈ Finset.univ.filter (fun i ↦ i ∉ S), + (if ordRho i < 0 then (n : ℤ) * ordRho i else 0) := by + rw [← hSplit] + congr 1 + · apply Finset.sum_congr rfl + intro i hi + simp only [lower, hi, ite_eq_left] + · apply Finset.sum_congr rfl + intro i hi + have hiS : i ∉ S := (Finset.mem_filter.1 hi).2 + simp only [lower, hiS, ite_false] + _ = (∑ i ∈ S, base i) + + (∑ i ∈ S, + (if 0 < ordV i then ((h * k : ℕ) : ℤ) * ordV i else 0)) + + ∑ i ∈ Finset.univ.filter (fun i ↦ i ∉ S), + (if ordRho i < 0 then (n : ℤ) * ordRho i else 0) := by + rw [Finset.sum_add_distrib] + _ = _ := by rw [hBaseSum, hPositiveVSum, hOutsideRhoSum]; ring + rw [hLowerSum, hCanonical] at hSumLower + have hRhoScaled : + -(k : ℤ) * ((degreeU : ℤ) + (degreeV : ℤ)) ≤ + (k : ℤ) * (∑ i ∈ S, ordRho i) := by + have hScaled := + mul_le_mul_of_nonneg_left hRhoSupport (Int.natCast_nonneg k) + calc + -(k : ℤ) * ((degreeU : ℤ) + (degreeV : ℤ)) = + (k : ℤ) * (-((degreeU : ℤ) + (degreeV : ℤ))) := by ring + _ ≤ (k : ℤ) * (∑ i ∈ S, ordRho i) := hScaled + have hEulerScaled : + (sigma : ℤ) * canonicalDegree + (sigma : ℤ) * S.card ≤ + (sigma : ℤ) * (chi : ℤ) := by + have hScaled := + mul_le_mul_of_nonneg_left hEuler (Int.natCast_nonneg sigma) + linarith + linarith + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/GlobalWronskianSummation.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/GlobalWronskianSummation.lean new file mode 100644 index 0000000000..8933da3120 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/GlobalWronskianSummation.lean @@ -0,0 +1,108 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.ParameterizedBound + +/-! +# Global Wronskian summation for Corvaja--Zannier Proposition 2 + +This file formalizes the exact real-arithmetic passage from the global +Wronskian divisor inequality to the numerical alternatives consumed by the +proved optimization stage. The remaining geometric theorem must supply the +displayed summed Wronskian inequality; it is not assumed as an axiom or hidden +in a typeclass. +-/ + +@[expose] public section + +namespace BGS.CorvajaZannier + +noncomputable section + +/-- The real-arithmetic passage from the global Wronskian inequality to the +displayed gcd bound in Corvaja--Zannier Proposition 2. -/ +theorem gcdBound_of_globalWronskianInequality + (a b chi G heightOutside : ℝ) (h k : ℕ) + (hn : 0 < h * k + h + k) + (hGHeight : G ≤ a - heightOutside) + (hWronskian : + ((h * k : ℕ) : ℝ) * a - (k : ℝ) * (a + b) - + (((h * k + h + k : ℕ) : ℝ) * + (((h * k + h + k : ℕ) : ℝ) - 1) / 2) * chi ≤ + ((h * k + h + k : ℕ) : ℝ) * heightOutside) : + G ≤ + (((h + 2 * k : ℕ) : ℝ) / ((h * k + h + k : ℕ) : ℝ)) * a + + ((k : ℝ) / ((h * k + h + k : ℕ) : ℝ)) * b + + (((((h * k + h + k : ℕ) : ℝ) - 1) / 2) * chi) := by + let n : ℕ := h * k + h + k + have hnReal : 0 < (n : ℝ) := by exact_mod_cast hn + have hmain : + (n : ℝ) * G ≤ + ((h + 2 * k : ℕ) : ℝ) * a + (k : ℝ) * b + + (((n : ℝ) * ((n : ℝ) - 1) / 2) * chi) := by + dsimp [n] at hnReal ⊢ + norm_num at hWronskian ⊢ + have hGScaled := mul_le_mul_of_nonneg_left hGHeight hnReal.le + norm_num at hGScaled + have hNegHeight : + -(↑h * ↑k + ↑h + ↑k) * heightOutside ≤ + -(↑h * ↑k) * a + ↑k * (a + b) + + ((↑h * ↑k + ↑h + ↑k) * + (↑h * ↑k + ↑h + ↑k - 1) / 2) * chi := by + linarith + calc + (↑h * ↑k + ↑h + ↑k) * G ≤ + (↑h * ↑k + ↑h + ↑k) * (a - heightOutside) := hGScaled + _ = (↑h * ↑k + ↑h + ↑k) * a - + (↑h * ↑k + ↑h + ↑k) * heightOutside := by ring + _ ≤ (↑h * ↑k + ↑h + ↑k) * a + + (-(↑h * ↑k) * a + ↑k * (a + b) + + ((↑h * ↑k + ↑h + ↑k) * + (↑h * ↑k + ↑h + ↑k - 1) / 2) * chi) := + by linarith + _ = (↑h + 2 * ↑k) * a + ↑k * b + + ((↑h * ↑k + ↑h + ↑k) * + (↑h * ↑k + ↑h + ↑k - 1) / 2) * chi := by ring + calc + G ≤ (((h + 2 * k : ℕ) : ℝ) * a + (k : ℝ) * b + + (((n : ℝ) * ((n : ℝ) - 1) / 2) * chi)) / (n : ℝ) := by + apply (le_div_iff₀ hnReal).2 + simpa [mul_comm] using hmain + _ = + (((h + 2 * k : ℕ) : ℝ) / ((h * k + h + k : ℕ) : ℝ)) * a + + ((k : ℝ) / ((h * k + h + k : ℕ) : ℝ)) * b + + (((((h * k + h + k : ℕ) : ℝ) - 1) / 2) * chi) := by + dsimp [n] + field_simp [hnReal.ne'] + +/-- Proposition 2's numerical alternatives follow once the single outside +height comparison and the summed Wronskian inequality have been established +for every admissible parameter pair outside the degree alternative. -/ +theorem propositionTwoNumericalAlternatives_of_globalWronskianInequality + (a b p chi : ℕ) (G heightOutside : ℝ) + (hGHeight : G ≤ (a : ℝ) - heightOutside) + (hWronskian : ∀ h k : ℕ, + PropositionTwoParametersAreAdmissible a b p h k → + ¬(a ≤ k ∧ b ≤ h) → + ((h * k : ℕ) : ℝ) * (a : ℝ) - + (k : ℝ) * ((a : ℝ) + (b : ℝ)) - + (((h * k + h + k : ℕ) : ℝ) * + (((h * k + h + k : ℕ) : ℝ) - 1) / 2) * (chi : ℝ) ≤ + ((h * k + h + k : ℕ) : ℝ) * heightOutside) : + PropositionTwoNumericalAlternatives a b p chi G := by + intro h k hadmissible + by_cases hdegree : a ≤ k ∧ b ≤ h + · exact Or.inl hdegree + · exact Or.inr <| + gcdBound_of_globalWronskianInequality + (a : ℝ) (b : ℝ) (chi : ℝ) G heightOutside h k + hadmissible.1 hGHeight (hWronskian h k hadmissible hdegree) + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/GlobalWronskianWeightedPlaceSum.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/GlobalWronskianWeightedPlaceSum.lean new file mode 100644 index 0000000000..072b23e685 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/GlobalWronskianWeightedPlaceSum.lean @@ -0,0 +1,159 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.GlobalWronskianPlaceSum +public import Mathlib.Tactic + +/-! +# Degree-weighted Corvaja--Zannier Wronskian summation + +The published proof sums local orders with the residue degree of each place. +This module derives the weighted version of the four-case global inequality by +replacing a place of weight `e` by `e` identical copies and applying +`globalWronskianInequality_of_placewiseBounds`. + +This is the finite combinatorial form of the weighted divisor summation in +Corvaja--Zannier, Proposition 2 (published reconstruction, pp. 15--16). +-/ + +@[expose] public section + +namespace BGS.CorvajaZannier + +noncomputable section + +private abbrev ReplicatedPlace {ι : Type*} (weight : ι → ℕ) := + Σ i, Fin (weight i) + +private def replicatedFinset {ι : Type*} [Fintype ι] [DecidableEq ι] + (weight : ι → ℕ) (S : Finset ι) : + Finset (ReplicatedPlace weight) := by + classical + exact Finset.univ.filter (fun x ↦ x.1 ∈ S) + +private theorem sum_replicatedFinset + {ι : Type*} [Fintype ι] [DecidableEq ι] + (weight : ι → ℕ) (S : Finset ι) (F : ι → ℤ) : + ∑ x ∈ replicatedFinset weight S, F x.1 = + ∑ i ∈ S, (weight i : ℤ) * F i := by + classical + rw [replicatedFinset, Finset.sum_filter, Fintype.sum_sigma] + calc + ∑ i, ∑ _j : Fin (weight i), (if i ∈ S then F i else 0) = + ∑ i, if i ∈ S then (weight i : ℤ) * F i else 0 := by + apply Finset.sum_congr rfl + intro i _ + by_cases hi : i ∈ S + · simp [hi, Finset.sum_const] + · simp [hi] + _ = ∑ i ∈ S, (weight i : ℤ) * F i := by + rw [← Finset.sum_filter] + congr 1 + ext i + simp + +private theorem card_replicatedFinset + {ι : Type*} [Fintype ι] [DecidableEq ι] + (weight : ι → ℕ) (S : Finset ι) : + (replicatedFinset weight S).card = ∑ i ∈ S, weight i := by + classical + have h := sum_replicatedFinset weight S (fun _ ↦ (1 : ℤ)) + simp only [Finset.sum_const, nsmul_eq_mul, mul_one] at h + exact_mod_cast h + +/-- Residue-degree-weighted finite-support form of the global summation step in +the proof of Corvaja--Zannier Proposition 2. -/ +theorem globalWronskianInequality_of_weightedPlacewiseBounds + {ι : Type*} [Fintype ι] [DecidableEq ι] + (weight : ι → ℕ) (S : Finset ι) + (ordU ordV ordRho ordGrid ordW : ι → ℤ) + (h k n sigma degreeU degreeV chi heightOutside : ℕ) + (canonicalDegree : ℤ) + (hUOutside : ∀ i, i ∉ S → ordU i = 0) + (hGridOutside : ∀ i, i ∉ S → ordGrid i = 0) + (hUSum : ∑ i, ordU i * (weight i : ℤ) = 0) + (hGridSum : ∑ i, ordGrid i * (weight i : ℤ) = 0) + (hDegreeV : ∑ i ∈ S.filter (fun i ↦ 0 < ordV i), + ordV i * (weight i : ℤ) = degreeV) + (hOutsideHeight : + ∑ i ∈ Finset.univ.filter (fun i ↦ i ∉ S ∧ ordRho i < 0), + ordRho i * (weight i : ℤ) = -(heightOutside : ℤ)) + (hCanonical : ∑ i, ordW i * (weight i : ℤ) = + (sigma : ℤ) * canonicalDegree) + (hEuler : canonicalDegree + (∑ i ∈ S, weight i : ℕ) ≤ (chi : ℤ)) + (hRhoSupport : + -((degreeU : ℤ) + (degreeV : ℤ)) ≤ + ∑ i ∈ S, ordRho i * (weight i : ℤ)) + (hCaseI : ∀ i, i ∉ S → ordRho i < 0 → + (n : ℤ) * ordRho i ≤ ordW i) + (hCaseII : ∀ i, i ∉ S → 0 ≤ ordRho i → 0 ≤ ordW i) + (hCaseIII : ∀ i, i ∈ S → 0 < ordV i → + ((k * (k - 1) / 2 : ℕ) : ℤ) * ordU i + + ((h * k : ℕ) : ℤ) * ordV i + (k : ℤ) * ordRho i + + ordGrid i - (sigma : ℤ) ≤ ordW i) + (hCaseIV : ∀ i, i ∈ S → ordV i ≤ 0 → + ((k * (k - 1) / 2 : ℕ) : ℤ) * ordU i + + (k : ℤ) * ordRho i + ordGrid i - (sigma : ℤ) ≤ ordW i) : + ((h * k : ℕ) : ℤ) * (degreeV : ℤ) - + (k : ℤ) * ((degreeU : ℤ) + (degreeV : ℤ)) - + (sigma : ℤ) * (chi : ℤ) ≤ + (n : ℤ) * (heightOutside : ℤ) := by + classical + let ι' := ReplicatedPlace weight + let S' : Finset ι' := replicatedFinset weight S + let lift (F : ι → ℤ) : ι' → ℤ := fun x ↦ F x.1 + apply globalWronskianInequality_of_placewiseBounds + S' (lift ordU) (lift ordV) (lift ordRho) (lift ordGrid) (lift ordW) + h k n sigma degreeU degreeV chi heightOutside canonicalDegree + · intro x hx + apply hUOutside x.1 + simpa [S', replicatedFinset] using hx + · intro x hx + apply hGridOutside x.1 + simpa [S', replicatedFinset] using hx + · simpa [lift, replicatedFinset, mul_comm] using + (sum_replicatedFinset weight Finset.univ ordU).trans + (by simpa [mul_comm] using hUSum) + · simpa [lift, replicatedFinset, mul_comm] using + (sum_replicatedFinset weight Finset.univ ordGrid).trans + (by simpa [mul_comm] using hGridSum) + · rw [show S'.filter (fun x ↦ 0 < lift ordV x) = + replicatedFinset weight (S.filter fun i ↦ 0 < ordV i) by + ext x + simp [S', replicatedFinset, lift]] + rw [sum_replicatedFinset] + simpa [mul_comm] using hDegreeV + · rw [show Finset.univ.filter (fun x : ι' ↦ x ∉ S' ∧ lift ordRho x < 0) = + replicatedFinset weight + (Finset.univ.filter fun i ↦ i ∉ S ∧ ordRho i < 0) by + ext x + simp [S', replicatedFinset, lift]] + rw [sum_replicatedFinset] + simpa [mul_comm] using hOutsideHeight + · simpa [lift, replicatedFinset, mul_comm] using + (sum_replicatedFinset weight Finset.univ ordW).trans + (by simpa [mul_comm] using hCanonical) + · rw [show S'.card = ∑ i ∈ S, weight i by + exact card_replicatedFinset weight S] + exact hEuler + · rw [show ∑ x ∈ S', lift ordRho x = + ∑ i ∈ S, (weight i : ℤ) * ordRho i by + exact sum_replicatedFinset weight S ordRho] + simpa [mul_comm] using hRhoSupport + · intro x hxS hxRho + exact hCaseI x.1 (by simpa [S', replicatedFinset] using hxS) hxRho + · intro x hxS hxRho + exact hCaseII x.1 (by simpa [S', replicatedFinset] using hxS) hxRho + · intro x hxS hxV + exact hCaseIII x.1 (by simpa [S', replicatedFinset] using hxS) hxV + · intro x hxS hxV + exact hCaseIV x.1 (by simpa [S', replicatedFinset] using hxS) hxV + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/InfinityInertiaDegree.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/InfinityInertiaDegree.lean new file mode 100644 index 0000000000..f3206e8408 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/InfinityInertiaDegree.lean @@ -0,0 +1,242 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.InfinityPlace +public import Mathlib.Tactic + +/-! +# Residue degree one above the rational-function place at infinity + +For the infinity valuation ring of `K(X)`, every integral rational function is +congruent modulo the maximal ideal to a constant. Consequently its residue +field is canonically a copy of `K`. When `K` is algebraically closed, the +residue field at every prime above infinity in a finite separable extension of +`K(X)` is therefore the same field, so the corresponding inertia degree is +one. +-/ + +@[expose] public section + +open scoped nonZeroDivisors Polynomial +open IsDedekindDomain Multiplicative WithZero + +namespace BGS.CorvajaZannier + +noncomputable section + +variable (K : Type*) [Field K] [DecidableEq K] [DecidableEq (RatFunc K)] + +/-- Embed the constant field into the infinity valuation ring. -/ +noncomputable def ratFuncInfinityConstantRingHom : + K →+* RatFuncInfinityIntegers K := + (RatFunc.C : K →+* RatFunc K).codRestrict (RatFuncInfinityIntegers K) (fun c => by + by_cases hc : c = 0 + · simp [hc] + · change RatFunc.inftyValuation K (RatFunc.C c) ≤ 1 + rw [RatFunc.inftyValuation.C (F := K) hc]) + +local instance ratFuncInfinityConstantAlgebra : + Algebra K (RatFuncInfinityIntegers K) := + (ratFuncInfinityConstantRingHom K).toAlgebra + +/-- The constant-field algebra map has underlying rational function `RatFunc.C c`. -/ +@[simp] theorem ratFuncInfinityConstantAlgebra_coe (c : K) : + ((algebraMap K (RatFuncInfinityIntegers K) c : + RatFuncInfinityIntegers K) : RatFunc K) = RatFunc.C c := by + rfl + +local instance ratFuncInfinityConstantTower : + IsScalarTower K (RatFuncInfinityIntegers K) (RatFunc K) := + .of_algebraMap_eq' rfl + +/-- Every rational function integral at infinity is congruent to a constant +modulo the maximal ideal at infinity. -/ +theorem ratFuncInfinityIntegers_exists_constant_mod_maximalIdeal + (r : RatFuncInfinityIntegers K) : + ∃ c : K, r - algebraMap K (RatFuncInfinityIntegers K) c ∈ + (ratFuncInfinityPlace K).asIdeal := by + let f : RatFunc K := r + by_cases hf : f = 0 + · refine ⟨0, ?_⟩ + have hr : r = 0 := by + apply Subtype.ext + exact hf + simp [hr] + have hdegree : f.intDegree ≤ 0 := by + have hmem := r.property + change RatFunc.inftyValuation K f ≤ 1 at hmem + rw [RatFunc.inftyValuation_apply, + RatFunc.inftyValuation_of_nonzero K hf, ← exp_zero, exp_le_exp] at hmem + exact hmem + rcases lt_or_eq_of_le hdegree with hdegree | hdegree + · refine ⟨0, ?_⟩ + simp only [map_zero, sub_zero] + change r ∈ IsLocalRing.maximalIdeal (RatFuncInfinityIntegers K) + rw [IsLocalRing.mem_maximalIdeal] + change ¬ IsUnit r + rw [Valuation.Integer.not_isUnit_iff_valuation_lt_one] + change RatFunc.inftyValuation K f < 1 + rw [RatFunc.inftyValuation_apply, + RatFunc.inftyValuation_of_nonzero K hf, ← exp_zero, exp_lt_exp] + exact hdegree + · let c : K := f.num.leadingCoeff / f.denom.leadingCoeff + refine ⟨c, ?_⟩ + let P : K[X] := f.num - Polynomial.C c * f.denom + have hnum : f.num ≠ 0 := RatFunc.num_ne_zero hf + have hdenom : f.denom ≠ 0 := f.denom_ne_zero + have hlcnum : f.num.leadingCoeff ≠ 0 := + Polynomial.leadingCoeff_ne_zero.mpr hnum + have hlcdenom : f.denom.leadingCoeff ≠ 0 := + Polynomial.leadingCoeff_ne_zero.mpr hdenom + have hc : c ≠ 0 := div_ne_zero hlcnum hlcdenom + have hnatDegree : f.num.natDegree = f.denom.natDegree := by + rw [RatFunc.intDegree] at hdegree + omega + have hdegreeEq : f.num.degree = (Polynomial.C c * f.denom).degree := by + rw [Polynomial.degree_C_mul hc, + Polynomial.degree_eq_natDegree hnum, + Polynomial.degree_eq_natDegree hdenom, + hnatDegree] + have hleadingCoeff : + f.num.leadingCoeff = (Polynomial.C c * f.denom).leadingCoeff := by + rw [Polynomial.leadingCoeff_mul, Polynomial.leadingCoeff_C] + exact (div_mul_cancel₀ f.num.leadingCoeff hlcdenom).symm + have hdegreeP : P.degree < f.num.degree := by + exact Polynomial.degree_sub_lt_left hdegreeEq hnum hleadingCoeff + have hrepr : f - RatFunc.C c = + algebraMap K[X] (RatFunc K) P / + algebraMap K[X] (RatFunc K) f.denom := by + calc + f - RatFunc.C c = + algebraMap K[X] (RatFunc K) f.num / + algebraMap K[X] (RatFunc K) f.denom - RatFunc.C c := by + rw [RatFunc.num_div_denom] + _ = (algebraMap K[X] (RatFunc K) f.num - + RatFunc.C c * algebraMap K[X] (RatFunc K) f.denom) / + algebraMap K[X] (RatFunc K) f.denom := by + field_simp [RatFunc.algebraMap_ne_zero hdenom] + _ = _ := by simp [P] + by_cases hP : P = 0 + · have hdiff : f - RatFunc.C c = 0 := by simp [hrepr, hP] + have hrEq : r = algebraMap K (RatFuncInfinityIntegers K) c := by + apply Subtype.ext + simpa [f] using sub_eq_zero.mp hdiff + simp [hrEq] + · have hnatDegreeP : P.natDegree < f.denom.natDegree := by + rw [Polynomial.natDegree_lt_iff_degree_lt hP] + calc + P.degree < f.num.degree := hdegreeP + _ = (f.num.natDegree : WithBot ℕ) := + Polynomial.degree_eq_natDegree hnum + _ = (f.denom.natDegree : WithBot ℕ) := by rw [hnatDegree] + have hdiff : f - RatFunc.C c ≠ 0 := by + rw [hrepr] + exact div_ne_zero + (RatFunc.algebraMap_ne_zero hP) + (RatFunc.algebraMap_ne_zero hdenom) + change r - algebraMap K (RatFuncInfinityIntegers K) c ∈ + IsLocalRing.maximalIdeal (RatFuncInfinityIntegers K) + rw [IsLocalRing.mem_maximalIdeal] + change ¬ IsUnit (r - algebraMap K (RatFuncInfinityIntegers K) c) + rw [Valuation.Integer.not_isUnit_iff_valuation_lt_one] + change RatFunc.inftyValuation K (f - RatFunc.C c) < 1 + rw [RatFunc.inftyValuation_apply, + RatFunc.inftyValuation_of_nonzero K hdiff, ← exp_zero, exp_lt_exp, + hrepr, RatFunc.intDegree_div + (RatFunc.algebraMap_ne_zero hP) + (RatFunc.algebraMap_ne_zero hdenom), + RatFunc.intDegree_polynomial, RatFunc.intDegree_polynomial] + omega + +/-- The residue field of the rational-function place at infinity is the +constant field. -/ +noncomputable def ratFuncInfinityPlaceResidueEquiv : + (ratFuncInfinityPlace K).asIdeal.ResidueField ≃ₐ[K] K := by + let p := (ratFuncInfinityPlace K).asIdeal + have hsurjective : + Function.Surjective (algebraMap K p.ResidueField) := by + intro z + obtain ⟨r, hr⟩ := p.algebraMap_residueField_surjective z + obtain ⟨c, hc⟩ := + ratFuncInfinityIntegers_exists_constant_mod_maximalIdeal K r + have hzero : + algebraMap (RatFuncInfinityIntegers K) p.ResidueField + (r - algebraMap K (RatFuncInfinityIntegers K) c) = 0 := + Ideal.algebraMap_residueField_eq_zero.mpr hc + have heq : + algebraMap (RatFuncInfinityIntegers K) p.ResidueField r = + algebraMap (RatFuncInfinityIntegers K) p.ResidueField + (algebraMap K (RatFuncInfinityIntegers K) c) := by + exact sub_eq_zero.mp (by simpa only [map_sub] using hzero) + refine ⟨c, ?_⟩ + calc + algebraMap K p.ResidueField c = + algebraMap (RatFuncInfinityIntegers K) p.ResidueField + (algebraMap K (RatFuncInfinityIntegers K) c) := by + rw [IsScalarTower.algebraMap_apply K + (RatFuncInfinityIntegers K) p.ResidueField] + _ = algebraMap (RatFuncInfinityIntegers K) p.ResidueField r := heq.symm + _ = z := hr + exact (AlgEquiv.ofBijective (Algebra.ofId K _) + ⟨RingHom.injective _, hsurjective⟩).symm + +section Extension + +variable [IsAlgClosed K] + +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +local instance infinityInertiaIntegralClosureModuleFinite : + Module.Finite (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.finite (RatFuncInfinityIntegers K) (RatFunc K) L + (RatFuncInfinityIntegralClosure K L) + +local instance infinityInertiaIntegralClosureIsIntegral : + Algebra.IsIntegral (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.isIntegral_algebra (RatFuncInfinityIntegers K) L + +omit [DecidableEq K] in +/-- Over an algebraically closed constant field, every prime above the place at +infinity has residue degree (inertia degree) one. -/ +theorem finiteExtensionInfinityPlace_inertiaDeg_eq_one + (P : (ratFuncInfinityPlace K).asIdeal.primesOver + (RatFuncInfinityIntegralClosure K L)) : + P.1.inertiaDeg (RatFuncInfinityIntegers K) = 1 := by + classical + let hLocalAlg := + Localization.AtPrime.algebraOfLiesOver + (ratFuncInfinityPlace K).asIdeal P.1 + let : IsScalarTower (RatFuncInfinityIntegers K) + (Localization.AtPrime (ratFuncInfinityPlace K).asIdeal) (Localization.AtPrime P.1) := + inferInstance + let : IsAlgClosed (ratFuncInfinityPlace K).asIdeal.ResidueField := + IsAlgClosed.of_ringEquiv K + (ratFuncInfinityPlace K).asIdeal.ResidueField + (ratFuncInfinityPlaceResidueEquiv K).symm.toRingEquiv + let : Algebra (ratFuncInfinityPlace K).asIdeal.ResidueField + P.1.ResidueField := IsLocalRing.ResidueField.instAlgebra + let : Algebra.QuasiFiniteAt (RatFuncInfinityIntegers K) P.1 := + inferInstance + let : Module.Finite + (ratFuncInfinityPlace K).asIdeal.ResidueField + P.1.ResidueField := inferInstance + let : Algebra.IsIntegral + (ratFuncInfinityPlace K).asIdeal.ResidueField + P.1.ResidueField := Algebra.IsIntegral.of_finite _ _ + rw [Ideal.inertiaDeg_eq (ratFuncInfinityPlace K).asIdeal P.1, + Algebra.finrank_eq_one_iff_bijective_algebraMap] + exact IsAlgClosed.algebraMap_bijective_of_isIntegral + +end Extension + +end +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/InfinityPlace.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/InfinityPlace.lean new file mode 100644 index 0000000000..8da0190de5 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/InfinityPlace.lean @@ -0,0 +1,293 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionProductFormula +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FinitePlaceCompletion +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FunctionFieldProductFormula +public import Mathlib.RingTheory.DiscreteValuationRing.TFAE +public import Mathlib.RingTheory.Valuation.Archimedean +public import Mathlib.RingTheory.Valuation.Discrete.IsDiscreteValuationRing + +/-! +# The place at infinity and its primes in finite extensions + +This file realizes the place at infinity of `K(X)` as an honest height-one +prime. Its base ring is the integer ring of `RatFunc.inftyValuation`; this is +a discrete valuation ring with uniformizer `X⁻¹`. The resulting +fractional-ideal order is proved to equal the previously defined +`ratFuncInfinityOrder = -intDegree`. + +For a finite separable extension `L / K(X)`, the integral closure of the +infinity valuation ring is Dedekind and finite over the base. The final +theorem specializes the finite-extension norm/count formula to the unique +base prime, producing the residue-degree-weighted sum over all primes above +infinity. +-/ + +@[expose] public section + +open scoped nonZeroDivisors +open IsDedekindDomain Multiplicative WithZero + +attribute [local instance] FractionRing.liftAlgebra + FractionRing.isScalarTower_liftAlgebra + +namespace BGS.CorvajaZannier + +noncomputable section + +variable (K : Type*) [Field K] [DecidableEq (RatFunc K)] + +/-- The valuation ring of the place at infinity of `K(X)`. -/ +abbrev RatFuncInfinityIntegers := (RatFunc.inftyValuation K).integer + +instance : IsDiscreteValuationRing (RatFuncInfinityIntegers K) := + (RatFunc.inftyValuation K).valuationSubring_isDiscreteValuationRing + +instance : IsDedekindDomain (RatFuncInfinityIntegers K) := by + let hnf : ¬ IsField (RatFuncInfinityIntegers K) := + IsDiscreteValuationRing.not_isField (RatFuncInfinityIntegers K) + apply ((IsDiscreteValuationRing.TFAE (RatFuncInfinityIntegers K) hnf).out 1 3).mp + infer_instance + +/-- The unique height-one prime of the infinity valuation ring. -/ +def ratFuncInfinityPlace : HeightOneSpectrum (RatFuncInfinityIntegers K) := + IsDiscreteValuationRing.maximalIdeal (RatFuncInfinityIntegers K) + +/-- `X⁻¹` as an element of the infinity valuation ring. -/ +def ratFuncInfinityUniformizer : RatFuncInfinityIntegers K := + ⟨1 / RatFunc.X, by + change RatFunc.inftyValuation K (1 / RatFunc.X) ≤ 1 + rw [RatFunc.inftyValuation.X_inv] + rw [← WithZero.exp_zero, WithZero.exp_le_exp] + omega⟩ + +theorem ratFuncInfinityUniformizer_isUniformizer : + (RatFunc.inftyValuation K).IsUniformizer (ratFuncInfinityUniformizer K) := by + rw [Valuation.IsUniformizer, + Valuation.IsRankOneDiscrete.generator_eq_exp_neg_one_of_mem_range] + · simp [ratFuncInfinityUniformizer] + · exact ⟨1 / RatFunc.X, RatFunc.inftyValuation.X_inv (F := K)⟩ + +theorem ratFuncInfinityPlace_span_uniformizer : + (ratFuncInfinityPlace K).asIdeal = Ideal.span {ratFuncInfinityUniformizer K} := by + exact Valuation.IsUniformizer.is_generator + (ratFuncInfinityUniformizer_isUniformizer K) + +/-- The canonical fraction field of the infinity valuation ring, identified +with the usual rational-function field. -/ +noncomputable def ratFuncInfinityFractionRingEquiv : + FractionRing (RatFuncInfinityIntegers K) ≃ₐ[RatFuncInfinityIntegers K] RatFunc K := + FractionRing.algEquiv (RatFuncInfinityIntegers K) (RatFunc K) + +/-- The height-one valuation is unchanged by the canonical identification of +the fraction field of the infinity valuation ring with `K(X)`. -/ +theorem ratFuncInfinityFractionRingEquiv_valuation + (x : FractionRing (RatFuncInfinityIntegers K)) : + (ratFuncInfinityPlace K).valuation (RatFunc K) + (ratFuncInfinityFractionRingEquiv K x) = + (ratFuncInfinityPlace K).valuation + (FractionRing (RatFuncInfinityIntegers K)) x := by + obtain ⟨a, b, hb, rfl⟩ := + IsFractionRing.div_surjective (RatFuncInfinityIntegers K) x + rw [map_div₀, (ratFuncInfinityFractionRingEquiv K).commutes a, + (ratFuncInfinityFractionRingEquiv K).commutes b, + Valuation.map_div, Valuation.map_div, + (ratFuncInfinityPlace K).valuation_of_algebraMap, + (ratFuncInfinityPlace K).valuation_of_algebraMap, + (ratFuncInfinityPlace K).valuation_of_algebraMap, + (ratFuncInfinityPlace K).valuation_of_algebraMap] + +/-- The height-one-prime order on the infinity valuation ring agrees with +the usual rational-function order `-intDegree`. -/ +theorem ratFuncInfinityPlace_order_eq + (f : RatFunc K) (hf : f ≠ 0) : + finitePlaceOrder (ratFuncInfinityPlace K) f = ratFuncInfinityOrder f := by + have hadic := valuation_eq_exp_neg_finitePlaceOrder + (R := RatFuncInfinityIntegers K) (L := RatFunc K) + (ratFuncInfinityPlace K) f hf + have hpi_ne : ratFuncInfinityUniformizer K ≠ 0 := by + intro h + have hc := congrArg Subtype.val h + exact (one_div_ne_zero RatFunc.X_ne_zero) hc + have hadic_pi : + (ratFuncInfinityPlace K).valuation (RatFunc K) + (algebraMap (RatFuncInfinityIntegers K) (RatFunc K) + (ratFuncInfinityUniformizer K)) = exp (-1 : ℤ) := by + rw [IsDedekindDomain.HeightOneSpectrum.valuation_of_algebraMap] + exact (ratFuncInfinityPlace K).intValuation_singleton hpi_ne + (ratFuncInfinityPlace_span_uniformizer K) + let d : ℤ := f.intDegree + let u0 : RatFunc K := f * RatFunc.X ^ (-d) + have hinfty_u0 : RatFunc.inftyValuation K u0 = 1 := by + rw [show u0 = f * RatFunc.X ^ (-d) by rfl, map_mul, + RatFunc.inftyValuation_apply, + RatFunc.inftyValuation_of_nonzero (F := K) hf, + RatFunc.inftyValuation.X_zpow, ← WithZero.exp_add] + simp [d] + let u : RatFuncInfinityIntegers K := ⟨u0, hinfty_u0.le⟩ + have hu_unit : IsUnit u := by + apply (Valuation.Integers.isUnit_iff_valuation_eq_one + (Valuation.integer.integers (RatFunc.inftyValuation K))).mpr + exact hinfty_u0 + have hadic_u : + (ratFuncInfinityPlace K).valuation (RatFunc K) + (algebraMap (RatFuncInfinityIntegers K) (RatFunc K) u) = 1 := by + exact Valuation.Integers.one_of_isUnit' hu_unit + (fun x ↦ (ratFuncInfinityPlace K).valuation_le_one x) + have hadic_invX : + (ratFuncInfinityPlace K).valuation (RatFunc K) (1 / RatFunc.X) = + exp (-1 : ℤ) := by + change (ratFuncInfinityPlace K).valuation (RatFunc K) (1 / RatFunc.X) = + exp (-1 : ℤ) at hadic_pi + exact hadic_pi + have hadic_X : + (ratFuncInfinityPlace K).valuation (RatFunc K) RatFunc.X = exp (1 : ℤ) := by + calc + (ratFuncInfinityPlace K).valuation (RatFunc K) RatFunc.X = + (ratFuncInfinityPlace K).valuation (RatFunc K) ((1 / RatFunc.X)⁻¹) := by + congr 1 + simp + _ = ((ratFuncInfinityPlace K).valuation (RatFunc K) (1 / RatFunc.X))⁻¹ := by + rw [map_inv₀] + _ = (exp (-1 : ℤ))⁻¹ := by rw [hadic_invX] + _ = exp (1 : ℤ) := by simp + have hcancel : RatFunc.X ^ d * RatFunc.X ^ (-d) = (1 : RatFunc K) := by + rw [← zpow_add₀ RatFunc.X_ne_zero] + simp + have hdecomp : + f = RatFunc.X ^ d * + algebraMap (RatFuncInfinityIntegers K) (RatFunc K) u := by + change f = RatFunc.X ^ d * u0 + change f = RatFunc.X ^ d * (f * RatFunc.X ^ (-d)) + symm + rw [← mul_assoc, mul_comm (RatFunc.X ^ d) f, mul_assoc, hcancel, mul_one] + have hadic_f : + (ratFuncInfinityPlace K).valuation (RatFunc K) f = exp d := by + rw [hdecomp, map_mul, map_zpow₀, hadic_X, hadic_u, mul_one] + simp + have hexp : + exp (-finitePlaceOrder (ratFuncInfinityPlace K) f) = exp d := + hadic.symm.trans hadic_f + rw [exp_inj] at hexp + rw [ratFuncInfinityOrder] + omega + +/-- In the canonical `FractionRing` model used by the norm/count theorem, the +height-one-prime count still equals the ordinary rational-function order at +infinity after applying the canonical field equivalence. -/ +theorem ratFuncInfinityFractionRing_order_eq + (x : FractionRing (RatFuncInfinityIntegers K)) (hx : x ≠ 0) : + finitePlaceOrder (ratFuncInfinityPlace K) x = + ratFuncInfinityOrder (ratFuncInfinityFractionRingEquiv K x) := by + let e := ratFuncInfinityFractionRingEquiv K + have hcanon := valuation_eq_exp_neg_finitePlaceOrder + (R := RatFuncInfinityIntegers K) + (L := FractionRing (RatFuncInfinityIntegers K)) + (ratFuncInfinityPlace K) x hx + have he_ne : e x ≠ 0 := by simpa using hx + have hactual := valuation_eq_exp_neg_finitePlaceOrder + (R := RatFuncInfinityIntegers K) (L := RatFunc K) + (ratFuncInfinityPlace K) (e x) he_ne + have hval := ratFuncInfinityFractionRingEquiv_valuation K x + have hexp : + exp (-finitePlaceOrder (ratFuncInfinityPlace K) x) = + exp (-finitePlaceOrder (ratFuncInfinityPlace K) (e x)) := by + rw [← hcanon, ← hactual] + exact hval.symm + rw [exp_inj] at hexp + have hcount : finitePlaceOrder (ratFuncInfinityPlace K) x = + finitePlaceOrder (ratFuncInfinityPlace K) (e x) := by omega + rw [hcount] + exact ratFuncInfinityPlace_order_eq K (e x) he_ne + +section Extension + +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + +/-- The integral closure in a finite extension at the infinity valuation +ring. -/ +abbrev RatFuncInfinityIntegralClosure := + integralClosure (RatFuncInfinityIntegers K) L + +variable [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +local instance infinityIntegralClosureModuleFinite : + Module.Finite (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.finite (RatFuncInfinityIntegers K) (RatFunc K) L + (RatFuncInfinityIntegralClosure K L) + +local instance infinityIntegralClosureIsDedekindDomain : + IsDedekindDomain (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.isDedekindDomain (RatFuncInfinityIntegers K) (RatFunc K) L + (RatFuncInfinityIntegralClosure K L) + +local instance infinityIntegralClosureIsFractionRing : + IsFractionRing (RatFuncInfinityIntegralClosure K L) L := + IsIntegralClosure.isFractionRing_of_finite_extension + (RatFuncInfinityIntegers K) (RatFunc K) L + (RatFuncInfinityIntegralClosure K L) + +local instance infinityBaseFaithfulSMulExtensionFractionRing : + FaithfulSMul (RatFuncInfinityIntegers K) + (FractionRing (RatFuncInfinityIntegralClosure K L)) := by + rw [faithfulSMul_iff_algebraMap_injective] + intro x y hxy + have hS := IsFractionRing.injective (RatFuncInfinityIntegralClosure K L) + (FractionRing (RatFuncInfinityIntegralClosure K L)) hxy + have hL := congrArg Subtype.val hS + apply Subtype.ext + apply (algebraMap (RatFunc K) L).injective + change algebraMap (RatFunc K) L (x : RatFunc K) = + algebraMap (RatFunc K) L (y : RatFunc K) + exact hL + +local instance infinityFractionRingAlgebra : + Algebra (FractionRing (RatFuncInfinityIntegers K)) + (FractionRing (RatFuncInfinityIntegralClosure K L)) := + FractionRing.liftAlgebra (RatFuncInfinityIntegers K) + (FractionRing (RatFuncInfinityIntegralClosure K L)) + +local instance infinityFractionRingSeparable : + Algebra.IsSeparable (FractionRing (RatFuncInfinityIntegers K)) + (FractionRing (RatFuncInfinityIntegralClosure K L)) := by + refine Algebra.IsSeparable.of_equiv_equiv + (ratFuncInfinityFractionRingEquiv K).symm.toRingEquiv + (FractionRing.algEquiv (RatFuncInfinityIntegralClosure K L) L).symm.toRingEquiv ?_ + ext z + exact IsFractionRing.algEquiv_commutes + (ratFuncInfinityFractionRingEquiv K).symm + (FractionRing.algEquiv (RatFuncInfinityIntegralClosure K L) L).symm z + +/-- The norm/count identity at infinity in a finite separable extension of +`K(X)`: the order of the norm at infinity is the residue-degree-weighted sum +of the orders at all primes above infinity. -/ +theorem count_spanSingleton_norm_at_infinity_eq_sum + (x : FractionRing (RatFuncInfinityIntegralClosure K L)) : + FractionalIdeal.count (FractionRing (RatFuncInfinityIntegers K)) + (ratFuncInfinityPlace K) + (FractionalIdeal.spanSingleton (RatFuncInfinityIntegers K)⁰ + (Algebra.norm (FractionRing (RatFuncInfinityIntegers K)) x)) = + ∑ P : (ratFuncInfinityPlace K).asIdeal.primesOver + (RatFuncInfinityIntegralClosure K L), + (P.1.inertiaDeg (RatFuncInfinityIntegers K) : ℤ) * + FractionalIdeal.count + (FractionRing (RatFuncInfinityIntegralClosure K L)) + (primeOverHeightOne (ratFuncInfinityPlace K) P) + (FractionalIdeal.spanSingleton + (RatFuncInfinityIntegralClosure K L)⁰ x) := by + exact count_spanSingleton_norm_eq_sum_inertiaDeg_mul_count + (ratFuncInfinityPlace K) x + +end Extension + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/LaurentFrobeniusBasis.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/LaurentFrobeniusBasis.lean new file mode 100644 index 0000000000..95242adf91 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/LaurentFrobeniusBasis.lean @@ -0,0 +1,186 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import Mathlib.RingTheory.Adjoin.PowerBasis +public import Mathlib.RingTheory.LaurentSeries + +/-! +# Exponent dilation on Laurent series + +This file isolates the *parameter* map `z |-> z^q` on `K((z))`. It is not +the coefficientwise Frobenius: coefficients are left unchanged. +-/ + +@[expose] public section + +open HahnSeries + +noncomputable section + +namespace BGS.CorvajaZannier + +variable (K : Type*) [Field K] + +/-- Multiplication of Laurent exponents by `q`. -/ +def laurentExponentDilationIndex (q : ℕ) : ℤ →+ ℤ where + toFun n := (q : ℤ) * n + map_zero' := by simp + map_add' _ _ := by ring + +@[simp] +theorem laurentExponentDilationIndex_apply (q : ℕ) (n : ℤ) : + laurentExponentDilationIndex q n = (q : ℤ) * n := rfl + +theorem laurentExponentDilationIndex_injective {q : ℕ} (hq : 0 < q) : + Function.Injective (laurentExponentDilationIndex q) := by + intro a b hab + simp only [laurentExponentDilationIndex_apply] at hab + exact mul_left_cancel₀ (by exact_mod_cast hq.ne') hab + +theorem laurentExponentDilationIndex_le_iff {q : ℕ} (hq : 0 < q) (a b : ℤ) : + laurentExponentDilationIndex q a ≤ laurentExponentDilationIndex q b ↔ a ≤ b := by + simp only [laurentExponentDilationIndex_apply] + exact Int.mul_le_mul_left (by exact_mod_cast hq) + +/-- The `K`-algebra embedding of Laurent series induced by `z |-> z^q`. + +This map dilates exponents and fixes every coefficient. In particular it is +different from coefficientwise Frobenius unless extra hypotheses identify the +two maps on a chosen constant field. +-/ +def laurentExponentDilation {q : ℕ} (hq : 0 < q) : + LaurentSeries K →ₐ[K] LaurentSeries K := + { HahnSeries.embDomainRingHom (R := K) (Γ := ℤ) (Γ' := ℤ) + (laurentExponentDilationIndex q) + (laurentExponentDilationIndex_injective hq) + (laurentExponentDilationIndex_le_iff hq) with + commutes' := by + intro a + rw [LaurentSeries.algebraMap_apply] + change HahnSeries.embDomain _ (HahnSeries.C a) = HahnSeries.C a + exact HahnSeries.embDomainRingHom_C } + +theorem laurentExponentDilation_injective {q : ℕ} (hq : 0 < q) : + Function.Injective (laurentExponentDilation K hq) := + by + change Function.Injective + (HahnSeries.embDomain (R := K) (Γ := ℤ) (Γ' := ℤ) _) + exact HahnSeries.embDomain_injective + +@[simp] +theorem coeff_laurentExponentDilation_mul {q : ℕ} (hq : 0 < q) + (f : LaurentSeries K) (n : ℤ) : + ((laurentExponentDilation K hq) f).coeff ((q : ℤ) * n) = f.coeff n := + by + change (HahnSeries.embDomain (R := K) (Γ := ℤ) (Γ' := ℤ) _ f).coeff _ = _ + exact HahnSeries.embDomain_coeff + +@[simp] +theorem laurentExponentDilation_single {q : ℕ} (hq : 0 < q) + (n : ℤ) (a : K) : + (laurentExponentDilation K hq) (HahnSeries.single n a) = + HahnSeries.single ((q : ℤ) * n) a := + by + change HahnSeries.embDomain (R := K) (Γ := ℤ) (Γ' := ℤ) _ + (HahnSeries.single n a) = _ + exact HahnSeries.embDomain_single + +/-- The embedded copy `K((z^q))` inside `K((z))`. -/ +abbrev laurentExponentSubfield {q : ℕ} (hq : 0 < q) : + IntermediateField K (LaurentSeries K) := + (laurentExponentDilation K hq).fieldRange + +/-- A chosen inverse image under exponent dilation. -/ +def laurentUndilate {q : ℕ} (hq : 0 < q) + (a : laurentExponentSubfield K hq) : LaurentSeries K := + Classical.choose (AlgHom.mem_fieldRange.mp a.property) + +@[simp] +theorem laurentExponentDilation_undilate {q : ℕ} (hq : 0 < q) + (a : laurentExponentSubfield K hq) : + (laurentExponentDilation K hq) (laurentUndilate K hq a) = a := + Classical.choose_spec (AlgHom.mem_fieldRange.mp a.property) + +/-- The Laurent parameter `z`. -/ +def laurentParameter : LaurentSeries K := HahnSeries.single 1 1 + +@[simp] +theorem laurentParameter_pow (n : ℕ) : + laurentParameter K ^ n = HahnSeries.single (n : ℤ) 1 := by + simp [laurentParameter, HahnSeries.single_pow] + +private theorem dilation_notin_wrong_residue {q : ℕ} (hq : 0 < q) + (i j : Fin q) (hij : i ≠ j) (n : ℤ) : + (q : ℤ) * n + (i : ℤ) - (j : ℤ) ∉ + Set.range (laurentExponentDilationIndex q) := by + rintro ⟨m, hm⟩ + simp only [laurentExponentDilationIndex_apply] at hm + have hqz : (0 : ℤ) < q := by exact_mod_cast hq + have hi0 : (0 : ℤ) ≤ i := Int.natCast_nonneg _ + have hj0 : (0 : ℤ) ≤ j := Int.natCast_nonneg _ + have hiq : (i : ℤ) < q := by exact_mod_cast i.isLt + have hjq : (j : ℤ) < q := by exact_mod_cast j.isLt + have heq : (q : ℤ) * (m - n) = (i : ℤ) - (j : ℤ) := by + nlinarith + have hmn : m - n = 0 := by + by_contra hne + rcases lt_or_gt_of_ne hne with hneg | hpos + · have : (q : ℤ) * (m - n) ≤ -q := by nlinarith + nlinarith + · have : (q : ℤ) ≤ q * (m - n) := by nlinarith + nlinarith + apply hij + apply Fin.ext + exact_mod_cast (by nlinarith [heq, hmn] : (i : ℤ) = j) + +theorem coeff_subfield_smul_parameter_pow {q : ℕ} (hq : 0 < q) + (a : laurentExponentSubfield K hq) (i j : Fin q) (n : ℤ) : + (a • laurentParameter K ^ (j : ℕ)).coeff ((q : ℤ) * n + (i : ℤ)) = + if i = j then (laurentUndilate K hq a).coeff n else 0 := by + rw [laurentParameter_pow, Algebra.smul_def, HahnSeries.coeff_mul_single] + simp only [mul_one] + change ((a : LaurentSeries K)).coeff ((q : ℤ) * n + (i : ℤ) - (j : ℤ)) = _ + split_ifs with hij + · subst j + rw [add_sub_cancel_right] + rw [← laurentExponentDilation_undilate K hq a] + exact coeff_laurentExponentDilation_mul K hq _ _ + · rw [← laurentExponentDilation_undilate K hq a] + change (HahnSeries.embDomain (R := K) (Γ := ℤ) (Γ' := ℤ) _ + (laurentUndilate K hq a)).coeff + ((q : ℤ) * n + (i : ℤ) - (j : ℤ)) = 0 + exact HahnSeries.embDomain_of_notMem_range + (dilation_notin_wrong_residue hq i j hij n) + +/-- The residue classes of exponents prove that +`1, z, ..., z^(q-1)` are linearly independent over the embedded field +`K((z^q))`. + +This is the local linear-disjointness half of the Laurent-series argument. It +does not assert spanning; the complementary spanning statement requires an +explicit residue-component decomposition of arbitrary Laurent series. +-/ +theorem linearIndependent_laurentParameter_pow {q : ℕ} (hq : 0 < q) : + LinearIndependent (laurentExponentSubfield K hq) + (fun i : Fin q ↦ laurentParameter K ^ (i : ℕ)) := by + rw [Fintype.linearIndependent_iff] + intro g hg i + have hcoeff (n : ℤ) : (laurentUndilate K hq (g i)).coeff n = 0 := by + have hc := congrArg + (fun f : LaurentSeries K ↦ f.coeff ((q : ℤ) * n + (i : ℤ))) hg + simp only [HahnSeries.coeff_sum, + coeff_subfield_smul_parameter_pow K hq] at hc + simpa using hc + have hundilate : laurentUndilate K hq (g i) = 0 := by + ext n + simpa using hcoeff n + apply Subtype.ext + change (g i : LaurentSeries K) = 0 + rw [← laurentExponentDilation_undilate K hq (g i), hundilate, map_zero] + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/LaurentFrobeniusPowerBasis.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/LaurentFrobeniusPowerBasis.lean new file mode 100644 index 0000000000..d1ce57cb75 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/LaurentFrobeniusPowerBasis.lean @@ -0,0 +1,137 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.LaurentFrobeniusBasis +public import Mathlib.LinearAlgebra.Basis.Basic +public import Mathlib.LinearAlgebra.Dimension.StrongRankCondition + +/-! +# The Laurent-series power basis over exponent dilation + +Every Laurent series splits uniquely into its `q` exponent residue classes. +Together with the residue-class independence theorem, this proves that +`1, z, ..., z^(q-1)` is a basis of `K((z))` over `K((z^q))` and that the +extension has degree `q`. +-/ + +@[expose] public section + +open HahnSeries + +noncomputable section + +namespace BGS.CorvajaZannier + +variable (K : Type*) [Field K] + +/-- The Laurent series obtained from the coefficients of `f` in one residue +class modulo `q`. -/ +def laurentResidueComponent {q : ℕ} (hq : 0 < q) + (f : LaurentSeries K) (i : Fin q) : LaurentSeries K := + HahnSeries.ofSuppBddBelow + (fun n : ℤ ↦ f.coeff ((q : ℤ) * n + (i : ℤ))) (by + refine ⟨min 0 (f.order - (i : ℤ)), ?_⟩ + intro n hn + change f.coeff ((q : ℤ) * n + (i : ℤ)) ≠ 0 at hn + have hord : f.order ≤ (q : ℤ) * n + (i : ℤ) := + HahnSeries.order_le_of_coeff_ne_zero hn + by_cases hn0 : 0 ≤ n + · exact (min_le_left _ _).trans hn0 + · have hnneg : n < 0 := lt_of_not_ge hn0 + have hqone : (1 : ℤ) ≤ q := by exact_mod_cast hq + have hmul : (q : ℤ) * n ≤ n := by nlinarith + exact (min_le_right _ _).trans (by linarith)) + +@[simp] +theorem coeff_laurentResidueComponent {q : ℕ} (hq : 0 < q) + (f : LaurentSeries K) (i : Fin q) (n : ℤ) : + (laurentResidueComponent K hq f i).coeff n = + f.coeff ((q : ℤ) * n + (i : ℤ)) := + rfl + +/-- A residue component, embedded back by exponent dilation and regarded as a +scalar in `K((z^q))`. -/ +def laurentResidueScalar {q : ℕ} (hq : 0 < q) + (f : LaurentSeries K) (i : Fin q) : laurentExponentSubfield K hq := + ⟨(laurentExponentDilation K hq) (laurentResidueComponent K hq f i), + ⟨laurentResidueComponent K hq f i, rfl⟩⟩ + +theorem laurentUndilate_residueScalar {q : ℕ} (hq : 0 < q) + (f : LaurentSeries K) (i : Fin q) : + laurentUndilate K hq (laurentResidueScalar K hq f i) = + laurentResidueComponent K hq f i := by + apply laurentExponentDilation_injective K hq + rw [laurentExponentDilation_undilate] + rfl + +/-- Euclidean division gives the exponent residue in `Fin q`. -/ +def laurentExponentResidue {q : ℕ} (hq : 0 < q) (m : ℤ) : Fin q := + ⟨(m % (q : ℤ)).toNat, by + have hnonneg : 0 ≤ m % (q : ℤ) := Int.emod_nonneg _ (by exact_mod_cast hq.ne') + have hlt : m % (q : ℤ) < q := Int.emod_lt_of_pos _ (by exact_mod_cast hq) + rw [Int.toNat_lt hnonneg] + exact hlt⟩ + +@[simp] +theorem coe_laurentExponentResidue {q : ℕ} (hq : 0 < q) (m : ℤ) : + ((laurentExponentResidue hq m : Fin q) : ℤ) = m % (q : ℤ) := by + have hqz : (q : ℤ) ≠ 0 := by exact_mod_cast hq.ne' + have hnonneg : 0 ≤ m % (q : ℤ) := Int.emod_nonneg _ hqz + simp [laurentExponentResidue, Int.toNat_of_nonneg hnonneg] + +theorem exponent_ediv_residue {q : ℕ} (hq : 0 < q) (m : ℤ) : + (q : ℤ) * (m / (q : ℤ)) + (laurentExponentResidue hq m : ℤ) = m := by + rw [coe_laurentExponentResidue] + linarith [Int.emod_add_mul_ediv m (q : ℤ)] + +/-- Reassemble a Laurent series from its `q` residue components. -/ +theorem sum_residueScalar_smul_parameter_pow {q : ℕ} (hq : 0 < q) + (f : LaurentSeries K) : + (∑ i : Fin q, + laurentResidueScalar K hq f i • laurentParameter K ^ (i : ℕ)) = f := by + ext m + let i₀ : Fin q := laurentExponentResidue hq m + let n : ℤ := m / (q : ℤ) + have hm : (q : ℤ) * n + (i₀ : ℤ) = m := by + exact exponent_ediv_residue hq m + rw [← hm] + simp only [HahnSeries.coeff_sum, + coeff_subfield_smul_parameter_pow K hq] + rw [Finset.sum_ite_eq Finset.univ i₀] + simp only [Finset.mem_univ, ite_true] + rw [laurentUndilate_residueScalar, coeff_laurentResidueComponent, hm] + +/-- The powers `1,z,...,z^(q-1)` span `K((z))` over `K((z^q))`. -/ +theorem span_laurentParameter_pow_eq_top {q : ℕ} (hq : 0 < q) : + Submodule.span (laurentExponentSubfield K hq) + (Set.range (fun i : Fin q ↦ laurentParameter K ^ (i : ℕ))) = ⊤ := by + apply top_unique + intro f _ + rw [← sum_residueScalar_smul_parameter_pow K hq f] + exact Submodule.sum_mem _ fun i _ ↦ + Submodule.smul_mem _ _ + (Submodule.subset_span (Set.mem_range_self i)) + +/-- The source's Laurent power basis. -/ +noncomputable def laurentParameterPowerBasis {q : ℕ} (hq : 0 < q) : + Module.Basis (Fin q) (laurentExponentSubfield K hq) (LaurentSeries K) := + Module.Basis.mk (linearIndependent_laurentParameter_pow K hq) + (span_laurentParameter_pow_eq_top K hq).ge + +@[simp] +theorem laurentParameterPowerBasis_apply {q : ℕ} (hq : 0 < q) (i : Fin q) : + laurentParameterPowerBasis K hq i = laurentParameter K ^ (i : ℕ) := + Module.Basis.mk_apply _ _ i + +/-- The exponent-dilation Laurent subfield has index exactly `q`. -/ +theorem finrank_laurentExponentSubfield {q : ℕ} (hq : 0 < q) : + Module.finrank (laurentExponentSubfield K hq) (LaurentSeries K) = q := by + rw [Module.finrank_eq_card_basis (laurentParameterPowerBasis K hq)] + exact Fintype.card_fin q + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/LocalAuxiliaryCaseI.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/LocalAuxiliaryCaseI.lean new file mode 100644 index 0000000000..e7c758aa45 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/LocalAuxiliaryCaseI.lean @@ -0,0 +1,777 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.LocalAuxiliaryWronskian +public import Mathlib.Algebra.Order.Group.Int.Sum +public import Mathlib.LinearAlgebra.Matrix.Transvection + +/-! +# Corvaja--Zannier local case (i) + +This file formalizes the column elimination and the sharp local Wronskian +estimate in case (i) of Corvaja--Zannier's Proposition 2. Repeated negative +Laurent orders are eliminated by an explicitly constructed product of +transvections. Consequently the column matrix has determinant one; the +finite-dimensional elimination is not assumed as a hypothesis. + +The second part isolates the exact source inequalities. Pairwise-distinct +negative column orders give the first triangular-number gain, and distinct +derivative orders give the second. Under the source's cardinal inequalities +this sharpens the ordinary Wronskian order to +`rhoOrder * (epsilon + 1)`, and hence to `rhoOrder * q` when +`epsilon + 1 ≤ q`. + +Source provenance: published pages 1935--1936; checked semantic reconstruction +`Papers/CorvajaZannier2013/CorvajaZannier2013.tex`, lines 640--685. +-/ + +@[expose] public section + +namespace BGS.CorvajaZannier + +noncomputable section + +open scoped Matrix BigOperators + +open HahnSeries LaurentSeries + +variable {K : Type*} [Field K] + +/-- The depth of the negative part of a Laurent series. -/ +def laurentPoleDepth (f : LaurentSeries K) : ℕ := Int.toNat (-f.order) + +/-- A terminating measure for repeated leading-term cancellation. -/ +def laurentPoleWeight {k : ℕ} (f : Fin k → LaurentSeries K) : ℕ := + ∑ i, laurentPoleDepth (f i) + +/-- All negative orders in a finite family are pairwise distinct. -/ +def NegativeOrdersPairwiseDistinct {ι : Type*} + (f : ι → LaurentSeries K) : Prop := + ∀ ⦃i j : ι⦄, (f i).order < 0 → (f j).order < 0 → + (f i).order = (f j).order → i = j + +/-- Cancel the leading term of `x` using a series `y` of the same order. -/ +def cancelLaurentLeadingTerm (x y : LaurentSeries K) : LaurentSeries K := + x - (x.leadingCoeff / y.leadingCoeff) • y + +@[simp] +theorem laurentPoleDepth_pos_iff (f : LaurentSeries K) : + 0 < laurentPoleDepth f ↔ f.order < 0 := by + simp [laurentPoleDepth] + +@[simp] +theorem laurentPoleDepth_eq_zero_iff (f : LaurentSeries K) : + laurentPoleDepth f = 0 ↔ 0 ≤ f.order := by + simp [laurentPoleDepth, Int.toNat_eq_zero] + +/-- Cancellation of equal leading terms strictly raises Laurent order. -/ +theorem order_lt_orderTop_cancelLaurentLeadingTerm + (x y : LaurentSeries K) (hx : x ≠ 0) (hy : y ≠ 0) + (horder : x.order = y.order) : + (x.order : WithTop ℤ) < (cancelLaurentLeadingTerm x y).orderTop := by + have hycoeff : y.coeff y.order ≠ 0 := HahnSeries.coeff_order_eq_zero.not.2 hy + have hxcoeff : x.coeff x.order ≠ 0 := HahnSeries.coeff_order_eq_zero.not.2 hx + have hylc : y.leadingCoeff ≠ 0 := by + simpa [HahnSeries.leadingCoeff_eq] using hycoeff + have hc : x.leadingCoeff / y.leadingCoeff ≠ 0 := div_ne_zero + (by simpa [HahnSeries.leadingCoeff_eq] using hxcoeff) hylc + have hscaled : (x.leadingCoeff / y.leadingCoeff) • y ≠ 0 := smul_ne_zero hc hy + have hscaledOrder : + ((x.leadingCoeff / y.leadingCoeff) • y).order = y.order := by + apply le_antisymm + · apply HahnSeries.order_le_of_coeff_ne_zero + simp only [HahnSeries.coeff_smul] + exact mul_ne_zero hc hycoeff + · exact HahnSeries.le_order_smul _ _ hscaled + have hscaledTop : + ((x.leadingCoeff / y.leadingCoeff) • y).orderTop = + (x.order : WithTop ℤ) := by + rw [← HahnSeries.order_eq_orderTop_of_ne_zero hscaled, hscaledOrder, ← horder] + have hlc : + ((x.leadingCoeff / y.leadingCoeff) • y).leadingCoeff = x.leadingCoeff := by + rw [HahnSeries.leadingCoeff_eq, hscaledOrder, HahnSeries.coeff_smul] + rw [HahnSeries.leadingCoeff_eq] + simp only [smul_eq_mul] + rw [← HahnSeries.leadingCoeff_eq (x := y)] + exact div_mul_cancel₀ _ hylc + have hxtop : x.orderTop = (x.order : WithTop ℤ) := + (HahnSeries.order_eq_orderTop_of_ne_zero hx).symm + unfold cancelLaurentLeadingTerm + exact HahnSeries.le_orderTop_of_leadingCoeff_eq hxtop hscaledTop hlc.symm + +/-- Leading-term cancellation strictly decreases pole depth. -/ +theorem laurentPoleDepth_cancelLaurentLeadingTerm_lt + (x y : LaurentSeries K) (hxneg : x.order < 0) + (hyneg : y.order < 0) (horder : x.order = y.order) : + laurentPoleDepth (cancelLaurentLeadingTerm x y) < laurentPoleDepth x := by + have hx : x ≠ 0 := by + intro h + simp [h] at hxneg + have hy : y ≠ 0 := by + intro h + simp [h] at hyneg + have hraise := order_lt_orderTop_cancelLaurentLeadingTerm x y hx hy horder + by_cases hz : cancelLaurentLeadingTerm x y = 0 + · simp [laurentPoleDepth, hz] + omega + · rw [← HahnSeries.order_eq_orderTop_of_ne_zero hz] at hraise + simp only [WithTop.coe_lt_coe] at hraise + simp [laurentPoleDepth] + omega + +private theorem indexedColumnCombination_transvection_same {k : ℕ} + (f : Fin k → LaurentSeries K) (i j : Fin k) (c : K) : + indexedLaurentSeriesColumnCombination f (Matrix.transvection j i c) i = + f i + c • f j := by + classical + simp [indexedLaurentSeriesColumnCombination, Matrix.transvection, + Matrix.single, Matrix.one_apply, add_smul, Finset.sum_add_distrib] + +private theorem indexedColumnCombination_transvection_ne {k : ℕ} + (f : Fin k → LaurentSeries K) (i j b : Fin k) (c : K) (hb : b ≠ i) : + indexedLaurentSeriesColumnCombination f (Matrix.transvection j i c) b = + f b := by + classical + have hib : i ≠ b := Ne.symm hb + simp [indexedLaurentSeriesColumnCombination, Matrix.transvection, + Matrix.single, Matrix.one_apply, hib] + +private theorem laurentPoleWeight_transvection_lt {k : ℕ} + (f : Fin k → LaurentSeries K) (i j : Fin k) + (hi : (f i).order < 0) (hj : (f j).order < 0) + (horder : (f i).order = (f j).order) : + laurentPoleWeight + (indexedLaurentSeriesColumnCombination f + (Matrix.transvection j i (-(f i).leadingCoeff / (f j).leadingCoeff))) < + laurentPoleWeight f := by + let c : K := -(f i).leadingCoeff / (f j).leadingCoeff + let g := indexedLaurentSeriesColumnCombination f (Matrix.transvection j i c) + have hgi : g i = cancelLaurentLeadingTerm (f i) (f j) := by + change indexedLaurentSeriesColumnCombination f (Matrix.transvection j i c) i = _ + rw [indexedColumnCombination_transvection_same] + simp only [c, cancelLaurentLeadingTerm, neg_div, neg_smul, sub_eq_add_neg] + have hstrict : laurentPoleDepth (g i) < laurentPoleDepth (f i) := by + rw [hgi] + exact laurentPoleDepth_cancelLaurentLeadingTerm_lt (f i) (f j) hi hj horder + unfold laurentPoleWeight + apply Finset.sum_lt_sum + · intro b _ + by_cases hb : b = i + · subst b + exact hstrict.le + · rw [indexedColumnCombination_transvection_ne f i j b c hb] + · exact ⟨i, Finset.mem_univ _, hstrict⟩ + +/-- Successive constant column combinations compose by matrix multiplication. -/ +theorem indexedLaurentSeriesColumnCombination_mul {k : ℕ} + (f : Fin k → LaurentSeries K) (A B : Matrix (Fin k) (Fin k) K) : + indexedLaurentSeriesColumnCombination + (indexedLaurentSeriesColumnCombination f A) B = + indexedLaurentSeriesColumnCombination f (A * B) := by + classical + funext b + simp only [indexedLaurentSeriesColumnCombination, Matrix.mul_apply] + simp_rw [Finset.smul_sum, smul_smul] + rw [Finset.sum_comm] + apply Finset.sum_congr rfl + intro i _ + rw [Finset.sum_smul] + apply Finset.sum_congr rfl + intro j _ + rw [mul_comm (B j b) (A i j)] + +private theorem indexedLaurentSeriesColumnCombination_one {k : ℕ} + (f : Fin k → LaurentSeries K) : + indexedLaurentSeriesColumnCombination f 1 = f := by + classical + funext i + simp [indexedLaurentSeriesColumnCombination, Matrix.one_apply] + +/-- Explicit finite-dimensional elimination of repeated negative orders. +The resulting matrix is a product of transvections and therefore has +determinant one. -/ +theorem exists_det_one_columnMatrix_negativeOrdersPairwiseDistinct + {k : ℕ} (a : ℤ) (ha : a ≤ 0) + (f : Fin k → LaurentSeries K) (hf : ∀ i, a ≤ (f i).order) : + ∃ A : Matrix (Fin k) (Fin k) K, + A.det = 1 ∧ + NegativeOrdersPairwiseDistinct + (indexedLaurentSeriesColumnCombination f A) ∧ + ∀ i, a ≤ (indexedLaurentSeriesColumnCombination f A i).order := by + induction hN : laurentPoleWeight f using Nat.strong_induction_on generalizing f with + | h N ih => + by_cases hdistinct : NegativeOrdersPairwiseDistinct f + · refine ⟨1, Matrix.det_one, ?_, ?_⟩ + · simpa [indexedLaurentSeriesColumnCombination_one] + · simpa [indexedLaurentSeriesColumnCombination_one] using hf + · have hdup : ∃ i j : Fin k, + (f i).order < 0 ∧ (f j).order < 0 ∧ + (f i).order = (f j).order ∧ i ≠ j := by + simp only [NegativeOrdersPairwiseDistinct] at hdistinct + push Not at hdistinct + obtain ⟨i, j, hi, hj, ho, hij⟩ := hdistinct + exact ⟨i, j, hi, hj, ho, hij⟩ + obtain ⟨i, j, hi, hj, horder, hij⟩ := hdup + let c : K := -(f i).leadingCoeff / (f j).leadingCoeff + let T : Matrix (Fin k) (Fin k) K := Matrix.transvection j i c + let g := indexedLaurentSeriesColumnCombination f T + have hweight : laurentPoleWeight g < N := by + rw [← hN] + exact laurentPoleWeight_transvection_lt f i j hi hj horder + have hgi : g i = cancelLaurentLeadingTerm (f i) (f j) := by + change indexedLaurentSeriesColumnCombination f + (Matrix.transvection j i c) i = _ + rw [indexedColumnCombination_transvection_same] + simp only [c, cancelLaurentLeadingTerm, neg_div, neg_smul, sub_eq_add_neg] + have hg : ∀ b, a ≤ (g b).order := by + intro b + by_cases hb : b = i + · subst b + rw [hgi] + have hfi : f i ≠ 0 := by + intro hz + simp [hz] at hi + have hfj : f j ≠ 0 := by + intro hz + simp [hz] at hj + have hraise := + order_lt_orderTop_cancelLaurentLeadingTerm (f i) (f j) hfi hfj horder + by_cases hz : cancelLaurentLeadingTerm (f i) (f j) = 0 + · simpa [hz] using ha + · rw [← HahnSeries.order_eq_orderTop_of_ne_zero hz] at hraise + simp only [WithTop.coe_lt_coe] at hraise + exact (hf i).trans hraise.le + · change a ≤ (indexedLaurentSeriesColumnCombination f + (Matrix.transvection j i c) b).order + rw [indexedColumnCombination_transvection_ne f i j b c hb] + exact hf b + obtain ⟨B, hBdet, hBdistinct, hBlower⟩ := ih _ hweight g hg rfl + refine ⟨T * B, ?_, ?_, ?_⟩ + · rw [Matrix.det_mul, hBdet, mul_one] + exact Matrix.det_transvection_of_ne j i (Ne.symm hij) c + · rw [← indexedLaurentSeriesColumnCombination_mul] + exact hBdistinct + · rw [← indexedLaurentSeriesColumnCombination_mul] + exact hBlower + +/-- Sharp lower sum bound for distinct integers bounded below. -/ +theorem sum_range_add_le_sum_of_injOn {ι : Type*} + (s : Finset ι) (w : ι → ℤ) (a : ℤ) + (hinj : Set.InjOn w (s : Set ι)) (hlower : ∀ i ∈ s, a ≤ w i) : + (∑ n ∈ Finset.range s.card, (a + n : ℤ)) ≤ ∑ i ∈ s, w i := by + classical + have hcard : (s.image w).card = s.card := Finset.card_image_iff.mpr hinj + have hbound := Finset.sum_range_le_sum + (s := s.image w) (c := a) (by + intro x hx + rw [Finset.mem_image] at hx + obtain ⟨i, hi, rfl⟩ := hx + exact hlower i hi) + rw [hcard] at hbound + simpa [Finset.sum_image hinj] using hbound + +/-- Sharp upper sum bound for distinct natural numbers bounded above. -/ +theorem sum_le_sum_range_sub_of_injOn {ι : Type*} + (s : Finset ι) (e : ι → ℕ) (epsilon : ℕ) + (hinj : Set.InjOn e (s : Set ι)) (hupper : ∀ i ∈ s, e i ≤ epsilon) : + (∑ i ∈ s, (e i : ℤ)) ≤ + ∑ n ∈ Finset.range s.card, ((epsilon : ℤ) - n) := by + classical + let w : ι → ℤ := fun i => e i + have hinjw : Set.InjOn w (s : Set ι) := by + intro i hi j hj hij + exact hinj hi hj (by simpa [w] using hij) + have hcard : (s.image w).card = s.card := Finset.card_image_iff.mpr hinjw + have hbound := Finset.sum_le_sum_range + (s := s.image w) (c := (epsilon : ℤ)) (by + intro x hx + rw [Finset.mem_image] at hx + obtain ⟨i, hi, rfl⟩ := hx + change (e i : ℤ) ≤ (epsilon : ℤ) + exact_mod_cast hupper i hi) + rw [hcard] at hbound + simpa [w, Finset.sum_image hinjw] using hbound + +private theorem caseI_addVal_prod {ι : Type*} + (s : Finset ι) (g : ι → LaurentSeries K) : + HahnSeries.addVal ℤ K (∏ i ∈ s, g i) = + ∑ i ∈ s, HahnSeries.addVal ℤ K (g i) := by + classical + induction s using Finset.induction_on with + | empty => simp + | @insert a s ha ih => simp [ha, ih, AddValuation.map_mul] + +private theorem caseI_coe_sum_int_finset {ι : Type*} + (s : Finset ι) (g : ι → ℤ) : + (((∑ i ∈ s, g i : ℤ) : ℤ) : WithTop ℤ) = + ∑ i ∈ s, ((g i : ℤ) : WithTop ℤ) := by + classical + induction s using Finset.induction_on with + | empty => simp + | @insert a s ha ih => simp [ha, ih, WithTop.coe_add] + +/-- The determinant bound in which only pole columns pay a derivative-order +cost; regular columns contribute a nonnegative order. -/ +theorem orderTop_indexedWronskian_det_lower_bound_of_poles + {ι : Type*} [Fintype ι] [DecidableEq ι] + (epsilonOrder : ι → ℕ) (g : ι → LaurentSeries K) (poles : Finset ι) + (E : ℤ) + (hregular : ∀ i ∉ poles, 0 ≤ (g i).order) + (hselected : ∀ σ : Equiv.Perm ι, + (∑ i ∈ poles, (epsilonOrder (σ i) : ℤ)) ≤ E) : + ((((∑ i ∈ poles, (g i).order) - E : ℤ)) : WithTop ℤ) ≤ + (indexedLaurentSeriesWronskian epsilonOrder g).det.orderTop := by + rw [Matrix.det_apply] + change ((((∑ i ∈ poles, (g i).order) - E : ℤ)) : WithTop ℤ) ≤ + HahnSeries.addVal ℤ K + (∑ σ, Equiv.Perm.sign σ • + ∏ i, indexedLaurentSeriesWronskian epsilonOrder g (σ i) i) + apply AddValuation.map_le_sum + intro σ _ + calc + ((((∑ i ∈ poles, (g i).order) - E : ℤ)) : WithTop ℤ) ≤ + (((∑ i ∈ poles, + ((g i).order - (epsilonOrder (σ i) : ℤ)) : ℤ)) : WithTop ℤ) := by + rw [Finset.sum_sub_distrib] + exact_mod_cast sub_le_sub_left (hselected σ) _ + _ = ∑ i, if i ∈ poles then + (((g i).order - (epsilonOrder (σ i) : ℤ) : ℤ) : WithTop ℤ) + else 0 := by + rw [Finset.sum_ite_mem_eq] + exact caseI_coe_sum_int_finset poles + (fun i => (g i).order - (epsilonOrder (σ i) : ℤ)) + _ ≤ ∑ i, + ((((LaurentSeries.derivative K)^[epsilonOrder (σ i)]) (g i)).orderTop) := by + gcongr with i + by_cases hi : i ∈ poles + · simp only [hi, ite_true] + exact order_sub_le_orderTop_derivative_iterate (epsilonOrder (σ i)) (g i) + · simp only [hi, ite_false] + exact orderTop_derivative_iterate_nonnegative_of_order_nonnegative + (epsilonOrder (σ i)) (g i) (hregular i hi) + _ = (∏ i, + indexedLaurentSeriesWronskian epsilonOrder g (σ i) i).orderTop := by + rw [← HahnSeries.addVal_apply, caseI_addVal_prod] + simp only [HahnSeries.addVal_apply] + rfl + _ ≤ (Equiv.Perm.sign σ • + ∏ i, indexedLaurentSeriesWronskian epsilonOrder g (σ i) i).orderTop := by + exact orderTop_le_orderTop_smul _ _ + +private theorem sum_range_int_mul_two (r : ℕ) : + (∑ n ∈ Finset.range r, (n : ℤ)) * 2 = + (r : ℤ) * (r - 1 : ℕ) := by + have h := congrArg (fun n : ℕ => (n : ℤ)) + (Finset.sum_range_id_mul_two r) + push_cast at h + exact h + +private theorem int_natCast_mul_pred (r : ℕ) : + (r : ℤ) * (r - 1 : ℕ) = (r : ℤ) * ((r : ℤ) - 1) := by + cases r <;> simp + +/-- The exact intermediate bound in source case (i). -/ +theorem orderTop_indexedWronskian_det_caseI_epsilon_plus_one_lower_bound + {ι : Type*} [Fintype ι] [DecidableEq ι] + (epsilonOrder : ι → ℕ) (g : ι → LaurentSeries K) + (rhoOrder : ℤ) (epsilon : ℕ) + (hgdistinct : NegativeOrdersPairwiseDistinct g) + (hglower : ∀ i, rhoOrder ≤ (g i).order) + (hepsilonInjective : Function.Injective epsilonOrder) + (hepsilonMax : ∀ i, epsilonOrder i ≤ epsilon) + (hcardRho : rhoOrder ≤ + -((Finset.univ.filter fun i => (g i).order < 0).card : ℤ)) + (hcardEpsilon : + (Finset.univ.filter fun i => (g i).order < 0).card ≤ epsilon + 1) : + ((rhoOrder * (epsilon + 1 : ℕ) : ℤ) : WithTop ℤ) ≤ + (indexedLaurentSeriesWronskian epsilonOrder g).det.orderTop := by + let poles : Finset ι := Finset.univ.filter fun i => (g i).order < 0 + let E : ℤ := ∑ n ∈ Finset.range poles.card, ((epsilon : ℤ) - n) + have horderInj : Set.InjOn (fun i => (g i).order) (poles : Set ι) := by + intro i hi j hj hij + apply hgdistinct + · simpa [poles] using hi + · simpa [poles] using hj + · exact hij + have hpoleLower : + (∑ n ∈ Finset.range poles.card, (rhoOrder + n : ℤ)) ≤ + ∑ i ∈ poles, (g i).order := + sum_range_add_le_sum_of_injOn poles (fun i => (g i).order) rhoOrder + horderInj (fun i _ => hglower i) + have hselected : ∀ σ : Equiv.Perm ι, + (∑ i ∈ poles, (epsilonOrder (σ i) : ℤ)) ≤ E := by + intro σ + apply sum_le_sum_range_sub_of_injOn poles (fun i => epsilonOrder (σ i)) epsilon + · intro i hi j hj hij + exact σ.injective (hepsilonInjective hij) + · intro i _ + exact hepsilonMax (σ i) + have hregular : ∀ i ∉ poles, 0 ≤ (g i).order := by + intro i hi + simp only [poles, Finset.mem_filter, Finset.mem_univ, true_and] at hi + omega + have hW := orderTop_indexedWronskian_det_lower_bound_of_poles + epsilonOrder g poles E hregular hselected + apply le_trans ?_ hW + norm_cast + have hcardRho' : rhoOrder ≤ -(poles.card : ℤ) := by + simpa [poles] using hcardRho + have hcardEpsilon' : poles.card ≤ epsilon + 1 := by + simpa [poles] using hcardEpsilon + let S : ℤ := ∑ n ∈ Finset.range poles.card, (n : ℤ) + have htri : S * 2 = (poles.card : ℤ) * (poles.card - 1 : ℕ) := by + exact sum_range_int_mul_two poles.card + have htri' : S * 2 = (poles.card : ℤ) * ((poles.card : ℤ) - 1) := + htri.trans (int_natCast_mul_pred poles.card) + have hpoleRange : + (∑ n ∈ Finset.range poles.card, (rhoOrder + n : ℤ)) = + (poles.card : ℤ) * rhoOrder + S := by + rw [Finset.sum_add_distrib] + simp [S, mul_comm] + have hcostRange : E = + (poles.card : ℤ) * epsilon - S := by + change (∑ n ∈ Finset.range poles.card, ((epsilon : ℤ) - n)) = _ + rw [Finset.sum_sub_distrib] + simp [S, mul_comm] + have hgapEpsilon : + 0 ≤ (epsilon + 1 : ℤ) - (poles.card : ℤ) := by + have hcast : (poles.card : ℤ) ≤ (epsilon + 1 : ℕ) := by + exact_mod_cast hcardEpsilon' + omega + have hgapRho : 0 ≤ -rhoOrder - (poles.card : ℤ) := by omega + have hgapProduct : + 0 ≤ ((epsilon + 1 : ℤ) - (poles.card : ℤ)) * + (-rhoOrder - (poles.card : ℤ)) := + mul_nonneg hgapEpsilon hgapRho + calc + rhoOrder * (epsilon + 1 : ℕ) ≤ + (∑ n ∈ Finset.range poles.card, (rhoOrder + n : ℤ)) - E := by + rw [hpoleRange, hcostRange] + push_cast + nlinarith + _ ≤ (∑ i ∈ poles, (g i).order) - E := sub_le_sub_right hpoleLower E + +/-- Source case (i), in the final `q * rhoOrder` form. -/ +theorem orderTop_indexedWronskian_det_caseI_q_lower_bound + {ι : Type*} [Fintype ι] [DecidableEq ι] + (epsilonOrder : ι → ℕ) (g : ι → LaurentSeries K) + (rhoOrder : ℤ) (epsilon q : ℕ) + (hgdistinct : NegativeOrdersPairwiseDistinct g) + (hglower : ∀ i, rhoOrder ≤ (g i).order) + (hepsilonInjective : Function.Injective epsilonOrder) + (hepsilonMax : ∀ i, epsilonOrder i ≤ epsilon) + (hcardRho : rhoOrder ≤ + -((Finset.univ.filter fun i => (g i).order < 0).card : ℤ)) + (hcardEpsilon : + (Finset.univ.filter fun i => (g i).order < 0).card ≤ epsilon + 1) + (hrho : rhoOrder ≤ 0) (hepsilonQ : epsilon + 1 ≤ q) : + (((q : ℤ) * rhoOrder : ℤ) : WithTop ℤ) ≤ + (indexedLaurentSeriesWronskian epsilonOrder g).det.orderTop := by + apply le_trans ?_ + (orderTop_indexedWronskian_det_caseI_epsilon_plus_one_lower_bound + epsilonOrder g rhoOrder epsilon hgdistinct hglower hepsilonInjective + hepsilonMax hcardRho hcardEpsilon) + norm_cast + have hepsilonQ' : (epsilon + 1 : ℤ) ≤ q := by exact_mod_cast hepsilonQ + calc + (q : ℤ) * rhoOrder ≤ (epsilon + 1 : ℤ) * rhoOrder := + mul_le_mul_of_nonpos_right hepsilonQ' hrho + _ = rhoOrder * (epsilon + 1 : ℕ) := by push_cast; ring + +/-- Pairwise-distinct negative integers bounded below by a nonpositive integer +are no more numerous than its pole depth. -/ +theorem card_negativeOrders_le_neg + {ι : Type*} [Fintype ι] + (g : ι → LaurentSeries K) (a : ℤ) (ha : a ≤ 0) + (hgdistinct : NegativeOrdersPairwiseDistinct g) + (hglower : ∀ i, a ≤ (g i).order) : + a ≤ -((Finset.univ.filter fun i => (g i).order < 0).card : ℤ) := by + classical + let poles : Finset ι := Finset.univ.filter fun i => (g i).order < 0 + let w : ι → ℤ := fun i => (g i).order + have hinj : Set.InjOn w (poles : Set ι) := by + intro i hi j hj hij + apply hgdistinct + · simpa [poles] using hi + · simpa [poles] using hj + · exact hij + have hsubset : poles.image w ⊆ Finset.Ico a 0 := by + intro x hx + rw [Finset.mem_image] at hx + obtain ⟨i, hi, rfl⟩ := hx + rw [Finset.mem_Ico] + exact ⟨hglower i, by simpa [poles] using hi⟩ + have hcard := Finset.card_le_card hsubset + rw [Finset.card_image_iff.mpr hinj, Int.card_Ico] at hcard + have hcard' : poles.card ≤ Int.toNat (-a) := by simpa using hcard + have hcast : (poles.card : ℤ) ≤ Int.toNat (-a) := by + exact_mod_cast hcard' + have htoNat : (Int.toNat (-a) : ℤ) = -a := by + rw [Int.toNat_of_nonneg] + omega + rw [htoNat] at hcast + simpa [poles] using (show a ≤ -(poles.card : ℤ) by omega) + +/-- Complete local case (i) for an arbitrary `Fin k` family. The theorem +constructs the determinant-one elimination matrix, preserves the original +Wronskian determinant, and proves the final `q * a` order bound. -/ +theorem exists_caseI_columnMatrix_and_q_wronskian_bound + {k : ℕ} (epsilonOrder : Fin k → ℕ) + (f : Fin k → LaurentSeries K) (a : ℤ) (epsilon q : ℕ) + (ha : a ≤ 0) (hf : ∀ i, a ≤ (f i).order) + (hepsilonInjective : Function.Injective epsilonOrder) + (hepsilonMax : ∀ i, epsilonOrder i ≤ epsilon) + (hk : k ≤ epsilon + 1) (hepsilonQ : epsilon + 1 ≤ q) : + ∃ A : Matrix (Fin k) (Fin k) K, + A.det = 1 ∧ + (indexedLaurentSeriesWronskian epsilonOrder + (indexedLaurentSeriesColumnCombination f A)).det = + (indexedLaurentSeriesWronskian epsilonOrder f).det ∧ + (((q : ℤ) * a : ℤ) : WithTop ℤ) ≤ + (indexedLaurentSeriesWronskian epsilonOrder f).det.orderTop := by + obtain ⟨A, hAdet, hdistinct, hlower⟩ := + exists_det_one_columnMatrix_negativeOrdersPairwiseDistinct a ha f hf + let g := indexedLaurentSeriesColumnCombination f A + have hdet : + (indexedLaurentSeriesWronskian epsilonOrder g).det = + (indexedLaurentSeriesWronskian epsilonOrder f).det := by + exact indexedLaurentSeriesWronskian_det_columnCombination_of_det_eq_one + epsilonOrder f A hAdet + have hcardRho : + a ≤ -((Finset.univ.filter fun i => (g i).order < 0).card : ℤ) := + card_negativeOrders_le_neg g a ha hdistinct hlower + have hcardEpsilon : + (Finset.univ.filter fun i => (g i).order < 0).card ≤ epsilon + 1 := by + calc + (Finset.univ.filter fun i => (g i).order < 0).card ≤ + (Finset.univ : Finset (Fin k)).card := Finset.card_filter_le _ _ + _ = k := Fintype.card_fin k + _ ≤ epsilon + 1 := hk + have hbound := orderTop_indexedWronskian_det_caseI_q_lower_bound + epsilonOrder g a epsilon q hdistinct hlower hepsilonInjective hepsilonMax + hcardRho hcardEpsilon ha hepsilonQ + refine ⟨A, hAdet, hdet, ?_⟩ + rw [← hdet] + exact hbound + +/-- Extend a first-block column operation by the identity on the grid columns +of the source auxiliary family. -/ +def caseIColumnMatrix (h k : ℕ) (A : Matrix (Fin k) (Fin k) K) : + Matrix (Sum (Fin k) (Fin (k + 1) × Fin h)) + (Sum (Fin k) (Fin (k + 1) × Fin h)) K := + Matrix.fromBlocks A 0 0 1 + +theorem caseIColumnMatrix_det (h k : ℕ) (A : Matrix (Fin k) (Fin k) K) : + (caseIColumnMatrix (K := K) h k A).det = A.det := by + rw [caseIColumnMatrix, Matrix.det_fromBlocks_zero₁₂] + simp + +theorem indexedColumnCombination_caseIColumnMatrix_inl + (h k : ℕ) + (f : Sum (Fin k) (Fin (k + 1) × Fin h) → LaurentSeries K) + (A : Matrix (Fin k) (Fin k) K) (i : Fin k) : + indexedLaurentSeriesColumnCombination f (caseIColumnMatrix h k A) (Sum.inl i) = + indexedLaurentSeriesColumnCombination (fun j => f (Sum.inl j)) A i := by + classical + rw [indexedLaurentSeriesColumnCombination, Fintype.sum_sum_type] + simp [caseIColumnMatrix, indexedLaurentSeriesColumnCombination] + +theorem indexedColumnCombination_caseIColumnMatrix_inr + (h k : ℕ) + (f : Sum (Fin k) (Fin (k + 1) × Fin h) → LaurentSeries K) + (A : Matrix (Fin k) (Fin k) K) (rs : Fin (k + 1) × Fin h) : + indexedLaurentSeriesColumnCombination f (caseIColumnMatrix h k A) (Sum.inr rs) = + f (Sum.inr rs) := by + classical + rw [indexedLaurentSeriesColumnCombination, Fintype.sum_sum_type] + simp [caseIColumnMatrix, Matrix.one_apply] + +/-- The full auxiliary family after a case-(i) operation on its first block. -/ +def caseITransformedLocalAuxiliaryFamily + (u v rho : LaurentSeries K) (h k : ℕ) (A : Matrix (Fin k) (Fin k) K) : + Sum (Fin k) (Fin (k + 1) × Fin h) → LaurentSeries K := + indexedLaurentSeriesColumnCombination (localAuxiliaryFamily u v rho h k) + (caseIColumnMatrix h k A) + +@[simp] +theorem caseITransformedLocalAuxiliaryFamily_inl + (u v rho : LaurentSeries K) (h k : ℕ) + (A : Matrix (Fin k) (Fin k) K) (i : Fin k) : + caseITransformedLocalAuxiliaryFamily u v rho h k A (Sum.inl i) = + indexedLaurentSeriesColumnCombination + (fun j => localAuxiliaryFamily u v rho h k (Sum.inl j)) A i := + indexedColumnCombination_caseIColumnMatrix_inl h k + (localAuxiliaryFamily u v rho h k) A i + +@[simp] +theorem caseITransformedLocalAuxiliaryFamily_inr + (u v rho : LaurentSeries K) (h k : ℕ) + (A : Matrix (Fin k) (Fin k) K) (rs : Fin (k + 1) × Fin h) : + caseITransformedLocalAuxiliaryFamily u v rho h k A (Sum.inr rs) = + localAuxiliaryFamily u v rho h k (Sum.inr rs) := + indexedColumnCombination_caseIColumnMatrix_inr h k + (localAuxiliaryFamily u v rho h k) A rs + +/-- The exact source-facing case-(i) result for `localAuxiliaryFamily`. +Only the first `k` columns can have poles; the constructed block matrix +eliminates their repeated negative orders and fixes every grid column. -/ +theorem exists_localAuxiliaryFamily_caseI_columnMatrix + (u v rho : LaurentSeries K) (h k : ℕ) + (hu : u ≠ 0) (hrhoNe : rho ≠ 0) + (huOrder : u.order = 0) (hrhoOrder : rho.order ≤ 0) + (hgridRegular : ∀ rs : Fin (k + 1) × Fin h, + 0 ≤ (u ^ (rs.1 : ℕ) * v ^ (rs.2 : ℕ)).order) : + ∃ A : Matrix (Fin k) (Fin k) K, + A.det = 1 ∧ + NegativeOrdersPairwiseDistinct + (caseITransformedLocalAuxiliaryFamily u v rho h k A) ∧ + (∀ i, rho.order ≤ + (caseITransformedLocalAuxiliaryFamily u v rho h k A i).order) ∧ + (∀ rs, caseITransformedLocalAuxiliaryFamily u v rho h k A (Sum.inr rs) = + localAuxiliaryFamily u v rho h k (Sum.inr rs)) := by + let first : Fin k → LaurentSeries K := + fun i => localAuxiliaryFamily u v rho h k (Sum.inl i) + have hfirstOrder : ∀ i, (first i).order = rho.order := by + intro i + simp only [first, localAuxiliaryFamily] + rw [HahnSeries.order_mul (pow_ne_zero _ hu) hrhoNe, HahnSeries.order_pow, + huOrder] + simp + have hfirstLower : ∀ i, rho.order ≤ (first i).order := by + intro i + rw [hfirstOrder i] + obtain ⟨A, hAdet, hdistinct, hlower⟩ := + exists_det_one_columnMatrix_negativeOrdersPairwiseDistinct + rho.order hrhoOrder first hfirstLower + refine ⟨A, hAdet, ?_, ?_, ?_⟩ + · intro x y hx hy hxy + cases x with + | inl i => + cases y with + | inl j => + apply congrArg Sum.inl + apply hdistinct + · simpa [first] using hx + · simpa [first] using hy + · simpa [first] using hxy + | inr rs => + rw [caseITransformedLocalAuxiliaryFamily_inr] at hy + exact (not_lt_of_ge (hgridRegular rs)) hy |>.elim + | inr rs => + rw [caseITransformedLocalAuxiliaryFamily_inr] at hx + exact (not_lt_of_ge (hgridRegular rs)) hx |>.elim + · intro i + cases i with + | inl j => + simpa [first] using hlower j + | inr rs => + rw [caseITransformedLocalAuxiliaryFamily_inr] + exact hrhoOrder.trans (hgridRegular rs) + · intro rs + exact caseITransformedLocalAuxiliaryFamily_inr u v rho h k A rs + +/-- Full source case (i) for the exact Sum-indexed auxiliary family: the +first-block elimination preserves the original Wronskian determinant and +gives the `q * order rho` lower bound. -/ +theorem exists_localAuxiliaryFamily_caseI_q_wronskian_bound + (u v rho : LaurentSeries K) (h k : ℕ) + (epsilonOrder : Sum (Fin k) (Fin (k + 1) × Fin h) → ℕ) + (epsilon q : ℕ) + (hu : u ≠ 0) (hrhoNe : rho ≠ 0) + (huOrder : u.order = 0) (hrhoOrder : rho.order ≤ 0) + (hgridRegular : ∀ rs : Fin (k + 1) × Fin h, + 0 ≤ (u ^ (rs.1 : ℕ) * v ^ (rs.2 : ℕ)).order) + (hepsilonInjective : Function.Injective epsilonOrder) + (hepsilonMax : ∀ i, epsilonOrder i ≤ epsilon) + (hk : k ≤ epsilon + 1) (hepsilonQ : epsilon + 1 ≤ q) : + ∃ A : Matrix (Fin k) (Fin k) K, + A.det = 1 ∧ + (indexedLaurentSeriesWronskian epsilonOrder + (caseITransformedLocalAuxiliaryFamily u v rho h k A)).det = + (indexedLaurentSeriesWronskian epsilonOrder + (localAuxiliaryFamily u v rho h k)).det ∧ + (((q : ℤ) * rho.order : ℤ) : WithTop ℤ) ≤ + (indexedLaurentSeriesWronskian epsilonOrder + (localAuxiliaryFamily u v rho h k)).det.orderTop := by + obtain ⟨A, hAdet, hdistinct, hlower, hgrid⟩ := + exists_localAuxiliaryFamily_caseI_columnMatrix + u v rho h k hu hrhoNe huOrder hrhoOrder hgridRegular + let f := localAuxiliaryFamily u v rho h k + let B := caseIColumnMatrix h k A + let g := caseITransformedLocalAuxiliaryFamily u v rho h k A + have hBdet : B.det = 1 := by + rw [caseIColumnMatrix_det, hAdet] + have hdet : + (indexedLaurentSeriesWronskian epsilonOrder g).det = + (indexedLaurentSeriesWronskian epsilonOrder f).det := by + exact indexedLaurentSeriesWronskian_det_columnCombination_of_det_eq_one + epsilonOrder f B hBdet + have hcardRho : + rho.order ≤ -((Finset.univ.filter fun i => (g i).order < 0).card : ℤ) := + card_negativeOrders_le_neg g rho.order hrhoOrder hdistinct hlower + let firstPoles : Finset (Fin k) := Finset.univ.filter fun i => + (g (Sum.inl i)).order < 0 + have hpoles : + (Finset.univ.filter fun i => (g i).order < 0) = + firstPoles.map ⟨Sum.inl, Sum.inl_injective⟩ := by + ext x + cases x with + | inl i => simp [firstPoles] + | inr rs => + have hregg : 0 ≤ (g (Sum.inr rs)).order := by + change 0 ≤ (caseITransformedLocalAuxiliaryFamily u v rho h k A + (Sum.inr rs)).order + rw [hgrid rs] + simpa [localAuxiliaryFamily] using hgridRegular rs + have hrs : ¬(g (Sum.inr rs)).order < 0 := + not_lt_of_ge hregg + simp [firstPoles, hrs] + have hcardEpsilon : + (Finset.univ.filter fun i => (g i).order < 0).card ≤ epsilon + 1 := by + rw [hpoles, Finset.card_map] + exact (Finset.card_filter_le _ _).trans (by simpa using hk) + have hbound := orderTop_indexedWronskian_det_caseI_q_lower_bound + epsilonOrder g rho.order epsilon q hdistinct hlower hepsilonInjective + hepsilonMax hcardRho hcardEpsilon hrhoOrder hepsilonQ + refine ⟨A, hAdet, ?_, ?_⟩ + · exact hdet + · rw [← hdet] + exact hbound + +/-- The same case-(i) endpoint for the source `auxiliaryFamily`, obtained by +specializing `rho = (1-u)/(1-v)`. -/ +theorem exists_auxiliaryFamily_caseI_q_wronskian_bound + (u v : LaurentSeries K) (h k : ℕ) + (epsilonOrder : Sum (Fin k) (Fin (k + 1) × Fin h) → ℕ) + (epsilon q : ℕ) + (hu : u ≠ 0) (hrhoNe : (1 - u) / (1 - v) ≠ 0) + (huOrder : u.order = 0) (hrhoOrder : ((1 - u) / (1 - v)).order ≤ 0) + (hgridRegular : ∀ rs : Fin (k + 1) × Fin h, + 0 ≤ (u ^ (rs.1 : ℕ) * v ^ (rs.2 : ℕ)).order) + (hepsilonInjective : Function.Injective epsilonOrder) + (hepsilonMax : ∀ i, epsilonOrder i ≤ epsilon) + (hk : k ≤ epsilon + 1) (hepsilonQ : epsilon + 1 ≤ q) : + ∃ A : Matrix (Fin k) (Fin k) K, + A.det = 1 ∧ + (indexedLaurentSeriesWronskian epsilonOrder + (indexedLaurentSeriesColumnCombination (auxiliaryFamily u v h k) + (caseIColumnMatrix h k A))).det = + (indexedLaurentSeriesWronskian epsilonOrder + (auxiliaryFamily u v h k)).det ∧ + (((q : ℤ) * ((1 - u) / (1 - v)).order : ℤ) : WithTop ℤ) ≤ + (indexedLaurentSeriesWronskian epsilonOrder + (auxiliaryFamily u v h k)).det.orderTop := by + simpa only [caseITransformedLocalAuxiliaryFamily, + localAuxiliaryFamily_div_eq_auxiliaryFamily] using + (exists_localAuxiliaryFamily_caseI_q_wronskian_bound + u v ((1 - u) / (1 - v)) h k epsilonOrder epsilon q hu hrhoNe + huOrder hrhoOrder hgridRegular hepsilonInjective hepsilonMax hk hepsilonQ) + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/LocalAuxiliaryWronskian.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/LocalAuxiliaryWronskian.lean new file mode 100644 index 0000000000..f0c1302ee6 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/LocalAuxiliaryWronskian.lean @@ -0,0 +1,549 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.AuxiliaryFamily +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.LocalWronskian +public import Mathlib.LinearAlgebra.Matrix.Determinant.Basic + +/-! +# Local auxiliary-family Wronskian estimates + +This file formalizes completion-level parts of the four local cases in the +proof of Corvaja--Zannier's Proposition 2. The functions are Laurent series, +and every order hypothesis is stated explicitly. No assertion is made here +about embeddings of a global function field into its completions or about +summing orders over all places. + +The main new ingredients are: + +* an indexed ordinary-derivative Wronskian, allowing the source's exact index + type `Fin k ⊕ (Fin (k + 1) × Fin h)`; +* the regular-family estimate used in case (ii); +* the explicit lower-unitriangular column matrix used in case (iii), together + with its determinant-one proof; and +* the geometric-series identity which improves the first `k` columns from + `u ^ j * ρ` to `u ^ j * v ^ h * ρ`. + +Source provenance: published pages 1935--1936; checked semantic reconstruction +`Papers/CorvajaZannier2013/CorvajaZannier2013.tex`, lines 636--732. Case (ii) +is lines 689--691, and the case-(iii) column operation is lines 694--719. +-/ + +@[expose] public section + +namespace BGS.CorvajaZannier + +noncomputable section + +open scoped Matrix BigOperators + +open HahnSeries LaurentSeries + +variable {K : Type*} [Field K] + +/-- An ordinary-derivative Wronskian whose rows and columns have an arbitrary +common finite index type. The function `ε` specifies the derivative order of +each row. -/ +def indexedLaurentSeriesWronskian {ι : Type*} [Fintype ι] + (ε : ι → ℕ) (f : ι → LaurentSeries K) : + Matrix ι ι (LaurentSeries K) := + fun i j => ((LaurentSeries.derivative K)^[ε i]) (f j) + +/-- Apply a constant scalar matrix to an indexed Laurent-series family. -/ +def indexedLaurentSeriesColumnCombination {ι : Type*} [Fintype ι] + (f : ι → LaurentSeries K) (A : Matrix ι ι K) : + ι → LaurentSeries K := + fun j => ∑ i, A i j • f i + +private theorem indexed_derivative_iterate_sum_smul {ι : Type*} [Fintype ι] + (r : ℕ) (a : ι → K) (f : ι → LaurentSeries K) : + ((LaurentSeries.derivative K)^[r]) (∑ i, a i • f i) = + ∑ i, a i • ((LaurentSeries.derivative K)^[r]) (f i) := by + induction r with + | zero => simp + | succ r ih => + simp_rw [Function.iterate_succ_apply'] + rw [ih, map_sum] + simp + +/-- Constant column operations commute with the indexed ordinary Wronskian. -/ +theorem indexedLaurentSeriesWronskian_columnCombination + {ι : Type*} [Fintype ι] + (ε : ι → ℕ) (f : ι → LaurentSeries K) (A : Matrix ι ι K) : + indexedLaurentSeriesWronskian ε + (indexedLaurentSeriesColumnCombination f A) = + indexedLaurentSeriesWronskian ε f * + A.map (algebraMap K (LaurentSeries K)) := by + classical + apply Matrix.ext + intro i j + rw [Matrix.mul_apply] + simp only [indexedLaurentSeriesWronskian, + indexedLaurentSeriesColumnCombination, Matrix.map_apply] + rw [indexed_derivative_iterate_sum_smul] + have halgebraMap (a : K) : + algebraMap K (LaurentSeries K) a = HahnSeries.single 0 a := by + change ((algebraMap K (PowerSeries K) a : PowerSeries K) : + LaurentSeries K) = HahnSeries.single 0 a + rw [← PowerSeries.C_eq_algebraMap, PowerSeries.coe_C] + rfl + have hscalar (a : K) (x : LaurentSeries K) : + a • x = algebraMap K (LaurentSeries K) a * x := by + rw [halgebraMap] + exact HahnSeries.single_zero_mul_eq_smul.symm + simp_rw [hscalar] + apply Finset.sum_congr rfl + intro i _ + exact mul_comm _ _ + +/-- A determinant-one constant column operation preserves an indexed local +Wronskian determinant. -/ +theorem indexedLaurentSeriesWronskian_det_columnCombination_of_det_eq_one + {ι : Type*} [Fintype ι] [DecidableEq ι] + (ε : ι → ℕ) (f : ι → LaurentSeries K) (A : Matrix ι ι K) + (hA : A.det = 1) : + (indexedLaurentSeriesWronskian ε + (indexedLaurentSeriesColumnCombination f A)).det = + (indexedLaurentSeriesWronskian ε f).det := by + rw [indexedLaurentSeriesWronskian_columnCombination, Matrix.det_mul] + have hdetmap : + (A.map (algebraMap K (LaurentSeries K))).det = 1 := by + calc + (A.map (algebraMap K (LaurentSeries K))).det = + algebraMap K (LaurentSeries K) A.det := by + simpa using ((algebraMap K (LaurentSeries K)).map_det A).symm + _ = 1 := by rw [hA, map_one] + rw [hdetmap, mul_one] + +private theorem indexed_addVal_prod {ι : Type*} + (s : Finset ι) (g : ι → LaurentSeries K) : + HahnSeries.addVal ℤ K (∏ i ∈ s, g i) = + ∑ i ∈ s, HahnSeries.addVal ℤ K (g i) := by + classical + induction s using Finset.induction_on with + | empty => simp + | @insert a s ha ih => simp [ha, ih, AddValuation.map_mul] + +private theorem indexed_coe_sum_int_finset {ι : Type*} + (s : Finset ι) (g : ι → ℤ) : + (((∑ i ∈ s, g i : ℤ) : ℤ) : WithTop ℤ) = + ∑ i ∈ s, ((g i : ℤ) : WithTop ℤ) := by + classical + induction s using Finset.induction_on with + | empty => simp + | @insert a s ha ih => simp [ha, ih, WithTop.coe_add] + +private theorem indexed_coe_sum_int {ι : Type*} [Fintype ι] (g : ι → ℤ) : + (((∑ i, g i : ℤ) : ℤ) : WithTop ℤ) = + ∑ i, ((g i : ℤ) : WithTop ℤ) := by + classical + exact indexed_coe_sum_int_finset Finset.univ g + +/-- The indexed ordinary Wronskian has order at least the sum of its column +orders minus the sum of its row derivative orders. -/ +theorem orderTop_indexedLaurentSeriesWronskian_det_lower_bound + {ι : Type*} [Fintype ι] [DecidableEq ι] + (ε : ι → ℕ) (f : ι → LaurentSeries K) : + (((∑ j, (f j).order) - ∑ i, (ε i : ℤ) : ℤ) : WithTop ℤ) ≤ + (indexedLaurentSeriesWronskian ε f).det.orderTop := by + rw [Matrix.det_apply] + change (((∑ j, (f j).order) - ∑ i, (ε i : ℤ) : ℤ) : WithTop ℤ) ≤ + HahnSeries.addVal ℤ K + (∑ σ, Equiv.Perm.sign σ • + ∏ i, indexedLaurentSeriesWronskian ε f (σ i) i) + apply AddValuation.map_le_sum + intro σ _ + calc + (((∑ j, (f j).order) - ∑ i, (ε i : ℤ) : ℤ) : WithTop ℤ) = + ∑ j, (((f j).order - (ε (σ j) : ℤ) : ℤ) : WithTop ℤ) := by + rw [← Equiv.sum_comp σ (fun i => (ε i : ℤ))] + rw [← indexed_coe_sum_int] + congr 1 + rw [Finset.sum_sub_distrib] + _ ≤ ∑ j, + ((((LaurentSeries.derivative K)^[ε (σ j)]) (f j)).orderTop) := by + gcongr with j + exact order_sub_le_orderTop_derivative_iterate (ε (σ j)) (f j) + _ = (∏ i, indexedLaurentSeriesWronskian ε f (σ i) i).orderTop := by + rw [← HahnSeries.addVal_apply, indexed_addVal_prod] + simp only [HahnSeries.addVal_apply] + rfl + _ ≤ (Equiv.Perm.sign σ • + ∏ i, indexedLaurentSeriesWronskian ε f (σ i) i).orderTop := by + exact orderTop_le_orderTop_smul _ _ + +/-- Ordinary differentiation preserves Laurent-series integrality. -/ +theorem orderTop_derivative_iterate_nonnegative_of_order_nonnegative + (r : ℕ) (f : LaurentSeries K) (hf : 0 ≤ f.order) : + (0 : WithTop ℤ) ≤ (((LaurentSeries.derivative K)^[r]) f).orderTop := by + rw [le_orderTop_iff_forall] + intro j hj + rw [LaurentSeries.derivative_iterate_coeff] + by_cases hsum : j + (r : ℤ) < 0 + · rw [coeff_eq_zero_of_lt_order (hsum.trans_le hf), smul_zero] + · have hnonneg : 0 ≤ j + (r : ℤ) := le_of_not_gt hsum + obtain ⟨m, hm⟩ := Int.eq_ofNat_of_zero_le hnonneg + have hj' : j < 0 := by exact_mod_cast hj + have hm_lt_int : (m : ℤ) < (r : ℤ) := by omega + have hm_lt : m < r := by exact_mod_cast hm_lt_int + rw [hm, Polynomial.descPochhammer_smeval_eq_descFactorial] + rw [Nat.descFactorial_eq_zero_iff_lt.mpr hm_lt, Nat.cast_zero, zero_smul] + +/-- Case (ii), at the completion level: if every column is regular, then the +ordinary-derivative Wronskian determinant is regular. -/ +theorem orderTop_indexedLaurentSeriesWronskian_det_nonnegative_of_regular + {ι : Type*} [Fintype ι] [DecidableEq ι] + (ε : ι → ℕ) (f : ι → LaurentSeries K) + (hf : ∀ i, 0 ≤ (f i).order) : + (0 : WithTop ℤ) ≤ (indexedLaurentSeriesWronskian ε f).det.orderTop := by + rw [Matrix.det_apply] + change (0 : WithTop ℤ) ≤ HahnSeries.addVal ℤ K + (∑ σ, Equiv.Perm.sign σ • + ∏ i, indexedLaurentSeriesWronskian ε f (σ i) i) + apply AddValuation.map_le_sum + intro σ _ + calc + (0 : WithTop ℤ) = ∑ _i : ι, (0 : WithTop ℤ) := by simp + _ ≤ ∑ i, + (((LaurentSeries.derivative K)^[ε (σ i)]) (f i)).orderTop := by + gcongr with i + exact orderTop_derivative_iterate_nonnegative_of_order_nonnegative + (ε (σ i)) (f i) (hf i) + _ = (∏ i, indexedLaurentSeriesWronskian ε f (σ i) i).orderTop := by + rw [← HahnSeries.addVal_apply, indexed_addVal_prod] + simp only [HahnSeries.addVal_apply] + rfl + _ ≤ (Equiv.Perm.sign σ • + ∏ i, indexedLaurentSeriesWronskian ε f (σ i) i).orderTop := by + exact orderTop_le_orderTop_smul _ _ + +/-- Case (ii) connected to the exact auxiliary family. Outside the support +of `u` and `v`, both have order zero; if the ratio `(1-u)/(1-v)` is regular, +then every auxiliary column is regular and so is its Wronskian determinant. -/ +theorem orderTop_auxiliaryFamily_caseII_nonnegative + (h k : ℕ) (ε : Sum (Fin k) (Fin (k + 1) × Fin h) → ℕ) + (u v : LaurentSeries K) + (hu0 : u ≠ 0) (hv0 : v ≠ 0) (hu1 : u ≠ 1) (hv1 : v ≠ 1) + (huOrder : u.order = 0) (hvOrder : v.order = 0) + (hratio : 0 ≤ ((1 - u) / (1 - v)).order) : + (0 : WithTop ℤ) ≤ + (indexedLaurentSeriesWronskian ε + (auxiliaryFamily u v h k)).det.orderTop := by + apply orderTop_indexedLaurentSeriesWronskian_det_nonnegative_of_regular + intro i + have hnum : 1 - u ≠ 0 := sub_ne_zero.mpr hu1.symm + have hden : 1 - v ≠ 0 := sub_ne_zero.mpr hv1.symm + have hratio0 : (1 - u) / (1 - v) ≠ 0 := div_ne_zero hnum hden + cases i with + | inl i => + change 0 ≤ (u ^ (i : ℕ) * ((1 - u) / (1 - v))).order + rw [HahnSeries.order_mul (pow_ne_zero _ hu0) hratio0, + HahnSeries.order_pow, huOrder] + simpa using hratio + | inr rs => + change 0 ≤ (u ^ (rs.1 : ℕ) * v ^ (rs.2 : ℕ)).order + rw [HahnSeries.order_mul (pow_ne_zero _ hu0) (pow_ne_zero _ hv0), + HahnSeries.order_pow, HahnSeries.order_pow, huOrder, hvOrder] + simp + +/-- The lower-left block of the case-(iii) column operation. For each first +column `i`, it subtracts every grid column `(i,s)` and adds every grid column +`(i+1,s)`. -/ +def caseIIIGridCorrection (h k : ℕ) : + Matrix (Fin (k + 1) × Fin h) (Fin k) K := + fun rs i => + if rs.1 = i.castSucc then -1 + else if rs.1 = i.succ then 1 + else 0 + +/-- The exact lower-unitriangular constant column matrix used in case (iii). -/ +def caseIIIColumnMatrix (h k : ℕ) : + Matrix (Sum (Fin k) (Fin (k + 1) × Fin h)) + (Sum (Fin k) (Fin (k + 1) × Fin h)) K := + Matrix.fromBlocks 1 0 (caseIIIGridCorrection h k) 1 + +/-- The case-(iii) column matrix has determinant one. -/ +theorem caseIIIColumnMatrix_det (h k : ℕ) : + (caseIIIColumnMatrix (K := K) h k).det = 1 := by + rw [caseIIIColumnMatrix, Matrix.det_fromBlocks_zero₁₂] + simp + +/-- The geometric-series identity behind the case-(iii) column operation. +The hypothesis is the denominator-cleared identity `(1-v)ρ = 1-u`. -/ +theorem caseIII_geometricSeries_column_identity + (u v ρ : LaurentSeries K) (h j : ℕ) + (hρ : (1 - v) * ρ = 1 - u) : + u ^ j * ρ - u ^ j * (1 - u) * (∑ s ∈ Finset.range h, v ^ s) = + u ^ j * v ^ h * ρ := by + rw [← hρ] + calc + u ^ j * ρ - u ^ j * ((1 - v) * ρ) * + (∑ s ∈ Finset.range h, v ^ s) = + u ^ j * ρ - u ^ j * ρ * + ((1 - v) * ∑ s ∈ Finset.range h, v ^ s) := by ring + _ = u ^ j * ρ - u ^ j * ρ * (1 - v ^ h) := by + rw [mul_neg_geom_sum] + _ = u ^ j * v ^ h * ρ := by ring + +/-- The source auxiliary family written with `ρ` as an explicit parameter. +This separates the local column algebra from the later specialization +`ρ = (1-u)/(1-v)`. -/ +def localAuxiliaryFamily (u v ρ : LaurentSeries K) (h k : ℕ) : + Sum (Fin k) (Fin (k + 1) × Fin h) → LaurentSeries K + | Sum.inl i => u ^ (i : ℕ) * ρ + | Sum.inr rs => u ^ (rs.1 : ℕ) * v ^ (rs.2 : ℕ) + +/-- Specializing the explicit ratio parameter recovers the auxiliary family +from `AuxiliaryFamily`. -/ +@[simp] +theorem localAuxiliaryFamily_div_eq_auxiliaryFamily + (u v : LaurentSeries K) (h k : ℕ) : + localAuxiliaryFamily u v ((1 - u) / (1 - v)) h k = + auxiliaryFamily u v h k := by + rfl + +/-- The case-(iii) family after replacing its first `k` columns. -/ +def caseIIIImprovedAuxiliaryFamily (u v ρ : LaurentSeries K) (h k : ℕ) : + Sum (Fin k) (Fin (k + 1) × Fin h) → LaurentSeries K + | Sum.inl i => u ^ (i : ℕ) * v ^ h * ρ + | Sum.inr rs => u ^ (rs.1 : ℕ) * v ^ (rs.2 : ℕ) + +private theorem caseIIIGridCorrection_sum_smul + (u v : LaurentSeries K) (h k : ℕ) (i : Fin k) : + (∑ rs : Fin (k + 1) × Fin h, + caseIIIGridCorrection (K := K) h k rs i • + (u ^ (rs.1 : ℕ) * v ^ (rs.2 : ℕ))) = + -(u ^ (i : ℕ) * ∑ s : Fin h, v ^ (s : ℕ)) + + u ^ (i.succ : ℕ) * ∑ s : Fin h, v ^ (s : ℕ) := by + rw [Fintype.sum_prod_type_right] + rw [Finset.mul_sum, Finset.mul_sum, ← Finset.sum_neg_distrib, + ← Finset.sum_add_distrib] + apply Finset.sum_congr rfl + intro s _ + have hne : i.castSucc ≠ i.succ := i.castSucc_lt_succ.ne + simp only [caseIIIGridCorrection] + calc + (∑ r : Fin (k + 1), + (if r = i.castSucc then (-1 : K) + else if r = i.succ then 1 else 0) • + (u ^ (r : ℕ) * v ^ (s : ℕ))) = + (∑ r : Fin (k + 1), + if r = i.castSucc then -(u ^ (r : ℕ) * v ^ (s : ℕ)) else 0) + + ∑ r : Fin (k + 1), + if r = i.succ then u ^ (r : ℕ) * v ^ (s : ℕ) else 0 := by + rw [← Finset.sum_add_distrib] + apply Finset.sum_congr rfl + intro r _ + by_cases hr0 : r = i.castSucc + · simp [hr0, hne] + · by_cases hr1 : r = i.succ + · simp [hr1, hne.symm] + · simp [hr0, hr1] + _ = -(u ^ (i : ℕ) * v ^ (s : ℕ)) + + u ^ (i.succ : ℕ) * v ^ (s : ℕ) := by + rw [Fintype.sum_ite_eq', Fintype.sum_ite_eq'] + simp + +/-- The explicit determinant-one matrix performs exactly the column +replacement from case (iii). -/ +theorem indexedColumnCombination_caseIIIColumnMatrix + (u v ρ : LaurentSeries K) (h k : ℕ) + (hρ : (1 - v) * ρ = 1 - u) : + indexedLaurentSeriesColumnCombination (localAuxiliaryFamily u v ρ h k) + (caseIIIColumnMatrix (K := K) h k) = + caseIIIImprovedAuxiliaryFamily u v ρ h k := by + classical + funext j + cases j with + | inl i => + rw [indexedLaurentSeriesColumnCombination, Fintype.sum_sum_type] + simp only [caseIIIColumnMatrix, Matrix.fromBlocks_apply₁₁, + Matrix.fromBlocks_apply₂₁, localAuxiliaryFamily, + caseIIIImprovedAuxiliaryFamily] + have hleft : + (∑ x : Fin k, (1 : Matrix (Fin k) (Fin k) K) x i • + (u ^ (x : ℕ) * ρ)) = u ^ (i : ℕ) * ρ := by + simp [Matrix.one_apply] + rw [hleft] + rw [caseIIIGridCorrection_sum_smul] + rw [Fin.sum_univ_eq_sum_range] + simp only [Fin.val_succ, pow_succ] + convert caseIII_geometricSeries_column_identity u v ρ h (i : ℕ) hρ using 1; + ring + | inr rs => + rw [indexedLaurentSeriesColumnCombination, Fintype.sum_sum_type] + simp [caseIIIColumnMatrix, localAuxiliaryFamily, + caseIIIImprovedAuxiliaryFamily, Matrix.one_apply] + +/-- Case (iii), completion-level determinant identity: the Wronskian is +unchanged after replacing `u^j ρ` by `u^j v^h ρ` in its first `k` columns. -/ +theorem indexedWronskian_det_caseIII_columnReplacement + (h k : ℕ) (ε : Sum (Fin k) (Fin (k + 1) × Fin h) → ℕ) + (u v ρ : LaurentSeries K) + (hρ : (1 - v) * ρ = 1 - u) : + (indexedLaurentSeriesWronskian ε + (caseIIIImprovedAuxiliaryFamily u v ρ h k)).det = + (indexedLaurentSeriesWronskian ε + (localAuxiliaryFamily u v ρ h k)).det := by + rw [← indexedColumnCombination_caseIIIColumnMatrix u v ρ h k hρ] + exact indexedLaurentSeriesWronskian_det_columnCombination_of_det_eq_one + ε (localAuxiliaryFamily u v ρ h k) (caseIIIColumnMatrix h k) + (caseIIIColumnMatrix_det h k) + +/-- Case (iii), completion-level order estimate after the exact source column +replacement. The right side retains the column orders explicitly; evaluating +those orders from `ν(u)`, `ν(v)`, and `ν(ρ)` is a separate elementary step. -/ +theorem orderTop_indexedWronskian_det_caseIII_lower_bound + (h k : ℕ) (ε : Sum (Fin k) (Fin (k + 1) × Fin h) → ℕ) + (u v ρ : LaurentSeries K) + (hρ : (1 - v) * ρ = 1 - u) : + (((∑ j, (caseIIIImprovedAuxiliaryFamily u v ρ h k j).order) - + ∑ i, (ε i : ℤ) : ℤ) : WithTop ℤ) ≤ + (indexedLaurentSeriesWronskian ε + (localAuxiliaryFamily u v ρ h k)).det.orderTop := by + rw [← indexedWronskian_det_caseIII_columnReplacement h k ε u v ρ hρ] + exact orderTop_indexedLaurentSeriesWronskian_det_lower_bound ε + (caseIIIImprovedAuxiliaryFamily u v ρ h k) + +private theorem order_caseIIIImprovedAuxiliaryFamily_inl + (u v ρ : LaurentSeries K) (h k : ℕ) (i : Fin k) + (hu : u ≠ 0) (hv : v ≠ 0) (hρ0 : ρ ≠ 0) : + (caseIIIImprovedAuxiliaryFamily u v ρ h k (Sum.inl i)).order = + (i : ℕ) • u.order + h • v.order + ρ.order := by + simp only [caseIIIImprovedAuxiliaryFamily] + rw [HahnSeries.order_mul + (mul_ne_zero (pow_ne_zero _ hu) (pow_ne_zero _ hv)) hρ0, + HahnSeries.order_mul (pow_ne_zero _ hu) (pow_ne_zero _ hv), + HahnSeries.order_pow, HahnSeries.order_pow] + +private theorem order_localAuxiliaryFamily_inl + (u v ρ : LaurentSeries K) (h k : ℕ) (i : Fin k) + (hu : u ≠ 0) (hρ0 : ρ ≠ 0) : + (localAuxiliaryFamily u v ρ h k (Sum.inl i)).order = + (i : ℕ) • u.order + ρ.order := by + simp only [localAuxiliaryFamily] + rw [HahnSeries.order_mul (pow_ne_zero _ hu) hρ0, + HahnSeries.order_pow] + +private theorem sum_fin_cast_int (k : ℕ) : + (∑ i : Fin k, (i : ℤ)) = (k * (k - 1) / 2 : ℕ) := by + rw [Fin.sum_univ_eq_sum_range, ← Nat.cast_sum, Finset.sum_range_id] + +private theorem sum_caseIIIImprovedAuxiliaryFamily_inl_orders + (u v ρ : LaurentSeries K) (h k : ℕ) + (hu : u ≠ 0) (hv : v ≠ 0) (hρ0 : ρ ≠ 0) : + (∑ i : Fin k, + (caseIIIImprovedAuxiliaryFamily u v ρ h k (Sum.inl i)).order) = + (k * (k - 1) / 2 : ℕ) • u.order + + (h * k) • v.order + k • ρ.order := by + simp_rw [order_caseIIIImprovedAuxiliaryFamily_inl u v ρ h k _ hu hv hρ0] + simp only [Finset.sum_add_distrib, Finset.sum_const, + Finset.card_univ, Fintype.card_fin] + simp_rw [nsmul_eq_mul] + rw [← Finset.sum_mul] + rw [sum_fin_cast_int] + simp only [Nat.cast_mul] + ring + +private theorem sum_localAuxiliaryFamily_inl_orders + (u v ρ : LaurentSeries K) (h k : ℕ) + (hu : u ≠ 0) (hρ0 : ρ ≠ 0) : + (∑ i : Fin k, + (localAuxiliaryFamily u v ρ h k (Sum.inl i)).order) = + (k * (k - 1) / 2 : ℕ) • u.order + k • ρ.order := by + simp_rw [order_localAuxiliaryFamily_inl u v ρ h k _ hu hρ0] + simp only [Finset.sum_add_distrib, Finset.sum_const, Finset.card_univ, + Fintype.card_fin] + simp_rw [nsmul_eq_mul] + rw [← Finset.sum_mul, sum_fin_cast_int] + +/-- Case (iii) in the displayed source form. The grid-column contribution is +left as the exact sum appearing in the paper; it is the part that cancels by +the global product formula after summing over places. -/ +theorem orderTop_indexedWronskian_det_caseIII_source_lower_bound + (h k : ℕ) (ε : Sum (Fin k) (Fin (k + 1) × Fin h) → ℕ) + (u v ρ : LaurentSeries K) + (hρ : (1 - v) * ρ = 1 - u) + (hu : u ≠ 0) (hv : v ≠ 0) (hρ0 : ρ ≠ 0) : + (((k * (k - 1) / 2 : ℕ) • u.order + + (h * k) • v.order + k • ρ.order + + ∑ rs : Fin (k + 1) × Fin h, + (u ^ (rs.1 : ℕ) * v ^ (rs.2 : ℕ)).order - + ∑ i, (ε i : ℤ) : ℤ) : WithTop ℤ) ≤ + (indexedLaurentSeriesWronskian ε + (localAuxiliaryFamily u v ρ h k)).det.orderTop := by + have hbound := orderTop_indexedWronskian_det_caseIII_lower_bound + h k ε u v ρ hρ + rw [Fintype.sum_sum_type] at hbound + rw [sum_caseIIIImprovedAuxiliaryFamily_inl_orders u v ρ h k hu hv hρ0] + at hbound + exact hbound + +/-- Case (iv), completion-level displayed source estimate: no column operation +is made, so the first `k` columns contribute the triangular `u` term and the +`kρ` term directly. -/ +theorem orderTop_indexedWronskian_det_caseIV_source_lower_bound + (h k : ℕ) (ε : Sum (Fin k) (Fin (k + 1) × Fin h) → ℕ) + (u v ρ : LaurentSeries K) (hu : u ≠ 0) (hρ0 : ρ ≠ 0) : + (((k * (k - 1) / 2 : ℕ) • u.order + k • ρ.order + + ∑ rs : Fin (k + 1) × Fin h, + (u ^ (rs.1 : ℕ) * v ^ (rs.2 : ℕ)).order - + ∑ i, (ε i : ℤ) : ℤ) : WithTop ℤ) ≤ + (indexedLaurentSeriesWronskian ε + (localAuxiliaryFamily u v ρ h k)).det.orderTop := by + have hbound := orderTop_indexedLaurentSeriesWronskian_det_lower_bound ε + (localAuxiliaryFamily u v ρ h k) + rw [Fintype.sum_sum_type] at hbound + rw [sum_localAuxiliaryFamily_inl_orders u v ρ h k hu hρ0] at hbound + exact hbound + +/-- Case (iii) connected to the exact auxiliary family defined earlier in the +formalization. The hypotheses `u ≠ 1` and `v ≠ 1` ensure that the ratio column +is nonzero and that clearing its denominator is sound. -/ +theorem orderTop_auxiliaryFamily_caseIII_source_lower_bound + (h k : ℕ) (ε : Sum (Fin k) (Fin (k + 1) × Fin h) → ℕ) + (u v : LaurentSeries K) + (hu0 : u ≠ 0) (hv0 : v ≠ 0) (hu1 : u ≠ 1) (hv1 : v ≠ 1) : + (((k * (k - 1) / 2 : ℕ) • u.order + + (h * k) • v.order + + k • ((1 - u) / (1 - v)).order + + ∑ rs : Fin (k + 1) × Fin h, + (u ^ (rs.1 : ℕ) * v ^ (rs.2 : ℕ)).order - + ∑ i, (ε i : ℤ) : ℤ) : WithTop ℤ) ≤ + (indexedLaurentSeriesWronskian ε + (auxiliaryFamily u v h k)).det.orderTop := by + have hden : 1 - v ≠ 0 := sub_ne_zero.mpr hv1.symm + have hnum : 1 - u ≠ 0 := sub_ne_zero.mpr hu1.symm + have hratio : (1 - u) / (1 - v) ≠ 0 := div_ne_zero hnum hden + have hclear : (1 - v) * ((1 - u) / (1 - v)) = 1 - u := by + field_simp + simpa only [localAuxiliaryFamily_div_eq_auxiliaryFamily] using + orderTop_indexedWronskian_det_caseIII_source_lower_bound + h k ε u v ((1 - u) / (1 - v)) hclear hu0 hv0 hratio + +/-- Case (iv) connected to the exact auxiliary family. -/ +theorem orderTop_auxiliaryFamily_caseIV_source_lower_bound + (h k : ℕ) (ε : Sum (Fin k) (Fin (k + 1) × Fin h) → ℕ) + (u v : LaurentSeries K) (hu0 : u ≠ 0) (hu1 : u ≠ 1) (hv1 : v ≠ 1) : + (((k * (k - 1) / 2 : ℕ) • u.order + + k • ((1 - u) / (1 - v)).order + + ∑ rs : Fin (k + 1) × Fin h, + (u ^ (rs.1 : ℕ) * v ^ (rs.2 : ℕ)).order - + ∑ i, (ε i : ℤ) : ℤ) : WithTop ℤ) ≤ + (indexedLaurentSeriesWronskian ε + (auxiliaryFamily u v h k)).det.orderTop := by + have hden : 1 - v ≠ 0 := sub_ne_zero.mpr hv1.symm + have hnum : 1 - u ≠ 0 := sub_ne_zero.mpr hu1.symm + have hratio : (1 - u) / (1 - v) ≠ 0 := div_ne_zero hnum hden + simpa only [localAuxiliaryFamily_div_eq_auxiliaryFamily] using + orderTop_indexedWronskian_det_caseIV_source_lower_bound + h k ε u v ((1 - u) / (1 - v)) hu0 hratio + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/LocalDerivative.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/LocalDerivative.lean new file mode 100644 index 0000000000..c077876898 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/LocalDerivative.lean @@ -0,0 +1,55 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import Mathlib.RingTheory.LaurentSeries + +/-! +# Local derivative estimates for Corvaja--Zannier + +The local Wronskian argument is carried out after expanding a rational +function in a Laurent series at a point of the curve. This file proves the +completion-level estimate that an `r`-th derivative lowers the Laurent-series +order by at most `r`. + +The statements use `HahnSeries.orderTop`, rather than `HahnSeries.order`, so +that they remain valid when the derivative vanishes. +-/ + +@[expose] public section + +namespace BGS.CorvajaZannier + +open HahnSeries LaurentSeries + +variable {K : Type*} [Ring K] + +/-- The `r`-th Hasse derivative lowers Laurent-series order by at most `r`. + +The `orderTop` formulation also covers the case in which the Hasse derivative +is zero. -/ +theorem order_sub_le_orderTop_hasseDeriv (r : ℕ) (f : LaurentSeries K) : + ((f.order - (r : ℤ) : ℤ) : WithTop ℤ) ≤ (hasseDeriv K r f).orderTop := by + rw [le_orderTop_iff_forall] + intro j hj + have hj' : j < f.order - (r : ℤ) := by + exact_mod_cast hj + have hjr : j + (r : ℤ) < f.order := (lt_sub_iff_add_lt).mp hj' + rw [hasseDeriv_coeff, coeff_eq_zero_of_lt_order hjr, smul_zero] + +/-- Every ordinary iterated derivative lowers Laurent-series order by at most +its iteration count. + +The `orderTop` formulation also covers the case in which the iterated +derivative is zero. -/ +theorem order_sub_le_orderTop_derivative_iterate (r : ℕ) (f : LaurentSeries K) : + ((f.order - (r : ℤ) : ℤ) : WithTop ℤ) ≤ (((derivative K)^[r]) f).orderTop := by + rw [derivative_iterate] + refine (order_sub_le_orderTop_hasseDeriv r f).trans ?_ + exact orderTop_le_orderTop_smul _ _ + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/LocalMonogenicity.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/LocalMonogenicity.lean new file mode 100644 index 0000000000..44bc1f5b90 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/LocalMonogenicity.lean @@ -0,0 +1,383 @@ +/- +Copyright (c) 2026 University of Washington Math AI Lab. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Bianca Viray, Bryan Boehnke, Grant Yang, George Peykanu, Tianshuo Wang +-/ +module + + +public import Mathlib.RingTheory.LocalRing.Etale +public import Mathlib.RingTheory.RingHom.Etale +public import Mathlib.RingTheory.Ideal.Height + +/-! +# Monogenicity from étale height-one quotients + +If `R` and `S` are local integral domains with `S` a finite extension of `R`, `R` integrally +closed, `S` a UFD, and there exists a height-one prime `q ⊆ S` such that `R/(q ∩ R) → S/q` is +étale, then `S ≅ R[X]/(f)` for some monic `f`. This file proves a generalization of Lemma 3.1 +of [Balçık et al.](https://arxiv.org/html/2503.07846v2). The cited lemma assumes that both +rings are regular local; the proof here uses the displayed integral-closedness and UFD +hypotheses instead, while retaining the local-domain and finite-extension assumptions. + +## Main results + +* `Monogenic.exists_isAdjoinRootMonic_of_quotientMap_etale`: a generalization of Lemma 3.1. + +## Auxiliary lemmas + +* `Ideal.exists_span_singleton_eq_of_prime_of_height_one`: in a UFD, a height-one prime ideal + is principal. +* `Monogenic.exists_aeval_add_eq`: Taylor expansion `f(x + h) = f(x) + f'(x)·h + h²·c`. +* `Monogenic.maximalIdeal_eq_sup_of_etale_quotient`: when `R/p → S/q` is étale, + `m_S = q + m_R·S`. +* `Monogenic.exists_isAdjoinRootMonic_of_principal_adjust`: adjusting a generator by adding + a generator of `q` via Taylor expansion when `f₁(B) = q₀ · a` with `a ∈ m_S`. + +## References + +* Irmak Balçık, Stephanie Chan, Yuan Liu, and Bianca Viray, + [*Number fields generated by points in linear systems on + curves*](https://arxiv.org/html/2503.07846v2), Lemma 3.1. + +## Tags + +étale, monogenic, local ring, height one, UFD +-/ + +@[expose] public section + +open Polynomial Function RingHom IsLocalRing + +namespace BGS.CorvajaZannier.LocalMonogenic + +variable {R S : Type*} [CommRing R] [CommRing S] [IsLocalRing R] [IsLocalRing S] + +section SubLemmas + +omit [IsLocalRing R] [IsLocalRing S] in +/- Can be placed in `Height.lean` with no additional imports. -/ +/-- In a UFD, a height one prime ideal is principal. -/ +lemma Ideal.exists_span_singleton_eq_of_prime_of_height_one {S : Type*} [CommRing S] [IsDomain S] + [UniqueFactorizationMonoid S] + (q : Ideal S) [hq_prime : q.IsPrime] (hq_height : q.height = 1) : + ∃ q₀ : S, q = Ideal.span {q₀} := by + have hq_ne_bot : q ≠ ⊥ := by rintro rfl; simp at hq_height + obtain ⟨p, hp_mem, hp_prime⟩ := hq_prime.exists_mem_prime_of_ne_bot hq_ne_bot + exact ⟨p, q.eq_span_singleton_of_height_eq_one hq_height hp_mem hp_prime⟩ + +/- Can be placed in `Taylor.lean` with no additional imports. -/ +/-- Taylor expansion: for any polynomial `f` and elements `x`, `h`, +there exists `c` such that `f(x + h) = f(x) + f'(x) · h + h² · c`. +Proved by lifting `Polynomial.aeval_add_of_sq_eq_zero` from `S ⧸ ⟨h²⟩`. -/ +lemma exists_aeval_add_eq {R S : Type*} [CommRing R] [CommRing S] [Algebra R S] + (f : R[X]) (x h : S) : + ∃ c : S, f.aeval (x + h) = f.aeval x + f.derivative.aeval x * h + h ^ 2 * c := by + set π := Ideal.Quotient.mkₐ R (Ideal.span ({h ^ 2} : Set S)) + have hsq : (π h) ^ 2 = 0 := by + rw [← map_pow]; exact Ideal.Quotient.eq_zero_iff_mem.mpr (Ideal.subset_span rfl) + have key : π (f.aeval (x + h) - (f.aeval x + f.derivative.aeval x * h)) = 0 := by + simp only [map_sub, map_add, map_mul, ← Polynomial.aeval_algHom_apply] + exact sub_eq_zero.mpr (Polynomial.aeval_add_of_sq_eq_zero f _ _ hsq) + obtain ⟨c, hc⟩ := Ideal.mem_span_singleton.mp (Ideal.Quotient.eq_zero_iff_mem.mp key) + exact ⟨c, by linear_combination hc⟩ + +/-- When the quotient map `R/p → S/q` is étale and both rings are local, +the maximal ideal of `S` decomposes as `m_S = q + m_R·S`. -/ +lemma maximalIdeal_eq_sup_of_etale_quotient + [Algebra R S] [Module.Finite R S] + (q : Ideal S) [hq_prime : q.IsPrime] + (hétale : (Ideal.quotientMap q (algebraMap R S) le_rfl).Etale) : + IsLocalRing.maximalIdeal S = + q ⊔ Ideal.map (algebraMap R S) (IsLocalRing.maximalIdeal R) := by + set p := q.comap (algebraMap R S) + set φ₀ : R ⧸ p →+* S ⧸ q := Ideal.quotientMap q (algebraMap R S) le_rfl + let : Algebra (R ⧸ p) (S ⧸ q) := φ₀.toAlgebra + have hφ₀_eq : algebraMap (R ⧸ p) (S ⧸ q) = φ₀ := RingHom.algebraMap_toAlgebra φ₀ + have hp : p.IsPrime := Ideal.IsPrime.comap (algebraMap R S) + have : IsLocalRing (R ⧸ p) := .of_surjective' _ Ideal.Quotient.mk_surjective + have : IsLocalRing (S ⧸ q) := .of_surjective' _ Ideal.Quotient.mk_surjective + have : Algebra.FormallyUnramified (R ⧸ p) (S ⧸ q) := by + have := ((RingHom.etale_iff_formallyUnramified_and_smooth φ₀).mp hétale).1 + rwa [← hφ₀_eq] at this + have : IsScalarTower R (R ⧸ p) (S ⧸ q) := .of_algebraMap_eq' rfl + have : Module.Finite (R ⧸ p) (S ⧸ q) := Module.Finite.of_restrictScalars_finite R _ _ + have : IsLocalHom (algebraMap (R ⧸ p) (S ⧸ q)) := by + rw [hφ₀_eq]; exact RingHom.IsIntegral.isLocalHom (.of_finite + (RingHom.finite_algebraMap.mpr ‹_›)) Ideal.quotientMap_injective + have mk_max_R : (IsLocalRing.maximalIdeal R).map (Ideal.Quotient.mk p) = + IsLocalRing.maximalIdeal (R ⧸ p) := by + have := IsLocalHom.of_surjective (Ideal.Quotient.mk p) Ideal.Quotient.mk_surjective + ext x; obtain ⟨x, rfl⟩ := Ideal.Quotient.mk_surjective x + simp [sup_eq_left.mpr (IsLocalRing.le_maximalIdeal hp.ne_top)] + have mk_max_S : (IsLocalRing.maximalIdeal S).map (Ideal.Quotient.mk q) = + IsLocalRing.maximalIdeal (S ⧸ q) := by + have := IsLocalHom.of_surjective (Ideal.Quotient.mk q) Ideal.Quotient.mk_surjective + ext x; obtain ⟨x, rfl⟩ := Ideal.Quotient.mk_surjective x + simp [sup_eq_left.mpr (IsLocalRing.le_maximalIdeal hq_prime.ne_top)] + have key : (IsLocalRing.maximalIdeal S).map (Ideal.Quotient.mk q) = + (Ideal.map (algebraMap R S) (IsLocalRing.maximalIdeal R)).map (Ideal.Quotient.mk q) := by + rw [mk_max_S, ← (by rw [← hφ₀_eq]; exact Algebra.FormallyUnramified.map_maximalIdeal : + Ideal.map φ₀ (IsLocalRing.maximalIdeal (R ⧸ p)) = IsLocalRing.maximalIdeal (S ⧸ q)), + ← mk_max_R, Ideal.map_map, Ideal.map_map]; congr 1 + rwa [Ideal.map_eq_iff_sup_ker_eq_of_surjective _ Ideal.Quotient.mk_surjective, + Ideal.mk_ker, sup_eq_left.mpr (IsLocalRing.le_maximalIdeal hq_prime.ne_top), + sup_comm] at key + +lemma cofactor_mem_maximalIdeal_of_not_generator + [Algebra R S] + (f₁_B : S) (q : Ideal S) [hq_prime : q.IsPrime] + (h_f₁B_in_q : f₁_B ∈ q) + (h_gen : ¬ (f₁_B ∈ IsLocalRing.maximalIdeal S ∧ Ideal.span {f₁_B} ⊔ Ideal.map (algebraMap R S) + (IsLocalRing.maximalIdeal R) • ⊤ = IsLocalRing.maximalIdeal S)) + (q₀ : S) (hq₀ : q = Ideal.span {q₀}) + (a : S) (ha : f₁_B = q₀ * a) + (h_ms_eq : IsLocalRing.maximalIdeal S = + q ⊔ Ideal.map (algebraMap R S) (IsLocalRing.maximalIdeal R)) : + a ∈ IsLocalRing.maximalIdeal S := by + by_contra ha_not_in_ms + exact h_gen ⟨IsLocalRing.le_maximalIdeal hq_prime.ne_top h_f₁B_in_q, by + rw [show Ideal.span {f₁_B} = q from by + rw [ha, hq₀] + exact Ideal.span_singleton_mul_right_unit + (IsLocalRing.notMem_maximalIdeal.mp ha_not_in_ms) q₀] + rw [h_ms_eq, Ideal.smul_eq_mul, Ideal.mul_top]⟩ + +-- private lemma? +omit [IsLocalRing R] [IsLocalRing S] in +lemma Ideal.quotient_adjust (q : Ideal S) (q₀ : S) (hq₀ : q = Ideal.span {q₀}) (B : S) : + Ideal.Quotient.mk q (B + q₀) = Ideal.Quotient.mk q B := + Ideal.Quotient.eq.mpr <| by + simp only [add_sub_cancel_left] + exact hq₀ ▸ Ideal.mem_span_singleton_self q₀ + +omit [IsLocalRing R] [IsLocalRing S] in +lemma Ideal.quotient_comp_map [Algebra R S] (q : Ideal S) : (Ideal.Quotient.mk q).comp + (algebraMap R S) = (Ideal.quotientMap q (algebraMap R S) (le_refl (q.comap + (algebraMap R S)))).comp (Ideal.Quotient.mk (q.comap (algebraMap R S))) := by + ext r; exact (Ideal.quotientMap_mk (I := q) (f := algebraMap R S) (H := le_rfl)).symm + +omit [IsLocalRing R] [IsLocalRing S] in +/-- If `I = ⟨π⟩ + J`, then `I ^ k ≤ ⟨π ^ k⟩ + J`. -/ +lemma Ideal.pow_le_span_pow_sup {I J : Ideal S} {π : S} + (h : I = Ideal.span {π} ⊔ J) (k : ℕ) : + I ^ k ≤ Ideal.span {π ^ k} ⊔ J := by + induction k with + | zero => simp [Ideal.span_singleton_one] + | succ k ih => + rw [pow_succ] + refine (Ideal.mul_mono ih h.le).trans ?_ + rw [Ideal.sup_mul, Ideal.mul_sup, Ideal.mul_sup] + refine sup_le (sup_le ?_ (Ideal.mul_le_right.trans le_sup_right)) + (sup_le (Ideal.mul_le_left.trans le_sup_right) + (Ideal.mul_le_left.trans le_sup_right)) + rw [Ideal.span_singleton_mul_span_singleton, pow_succ] + exact le_sup_left + +omit [IsLocalRing R] [IsLocalRing S] in +/-- If the residue of `β` generates `S / q`, every element of `S` is congruent modulo `q` +to an element of `R[β]`. -/ +lemma exists_adjoin_sub_mem [Algebra R S] + (β : S) (q : Ideal S) + (h_gen : Algebra.adjoin (R ⧸ q.comap (algebraMap R S)) + {Ideal.Quotient.mk q β} = ⊤) (s : S) : + ∃ t ∈ Algebra.adjoin R {β}, s - t ∈ q := by + rw [Algebra.adjoin_singleton_eq_range_aeval, AlgHom.range_eq_top] at h_gen + obtain ⟨p, hp⟩ := h_gen (Ideal.Quotient.mk q s) + obtain ⟨r, rfl⟩ := Polynomial.map_surjective _ Ideal.Quotient.mk_surjective p + refine ⟨aeval β r, ?_, Ideal.Quotient.eq.mp ?_⟩ + · rw [Algebra.adjoin_singleton_eq_range_aeval] + exact ⟨r, rfl⟩ + · rw [map_aeval_eq_aeval_map (ψ := Ideal.Quotient.mk q) + (φ := Ideal.Quotient.mk (q.comap (algebraMap R S))) + (by ext; exact (Ideal.quotientMap_mk (I := q) (f := algebraMap R S) + (H := le_rfl)).symm), hp] + +omit [IsLocalRing R] [IsLocalRing S] in +/-- Iteratively approximate elements by `A` modulo `⟨π ^ k⟩ + m_R S`. -/ +lemma exists_sub_mem_adjoin_of_pow [Algebra R S] + {A : Subalgebra R S} {q ms mR_S : Ideal S} {π : S} + (h_lift : ∀ s : S, ∃ t ∈ A, s - t ∈ q) + (hπ_mem : π ∈ A) (hπ_ms : π ∈ ms) (hq_le : q ≤ ms) + (h_ms : ms = Ideal.span {π} ⊔ mR_S) + (k : ℕ) (x : S) : + ∃ a ∈ A.toSubmodule, x - a ∈ (Ideal.span {π ^ k} ⊔ mR_S : Ideal S) := by + induction k with + | zero => exact ⟨0, Subalgebra.zero_mem A, by simp [Ideal.span_singleton_one]⟩ + | succ k ih => + obtain ⟨a₀, ha₀, hz⟩ := ih + obtain ⟨y, hy, r, hr, hyr⟩ := Submodule.mem_sup.mp hz + obtain ⟨c, rfl⟩ := Ideal.mem_span_singleton.mp hy + obtain ⟨a₁, ha₁, hc⟩ := h_lift c + refine ⟨a₀ + a₁ * π ^ k, Subalgebra.add_mem A ha₀ + (Subalgebra.mul_mem A ha₁ (Subalgebra.pow_mem A hπ_mem k)), ?_⟩ + rw [show x - (a₀ + a₁ * π ^ k) = π ^ k * (c - a₁) + r + by linear_combination hyr.symm] + exact Ideal.add_mem _ + (Ideal.pow_le_span_pow_sup h_ms (k + 1) <| by + rw [pow_succ] + exact Ideal.mul_mem_mul (Ideal.pow_mem_pow hπ_ms k) (hq_le hc)) + (Ideal.mem_sup_right hr) + +omit [IsLocalRing R] [IsLocalRing S] in +/-- Lift a monogenic quotient across a height-one direction whose generator lies in the +adjoined algebra. The Artinian descent supplies the finite approximation needed by Nakayama. -/ +lemma adjoin_eq_top_of_quotient [Algebra R S] [IsLocalRing R] [IsLocalRing S] + [Module.Finite R S] + (β : S) (q : Ideal S) [q.IsPrime] + (h_gen : Algebra.adjoin (R ⧸ q.comap (algebraMap R S)) + {Ideal.Quotient.mk q β} = ⊤) + (π : S) (hπ_mem : π ∈ Algebra.adjoin R {β}) + (h_ms : IsLocalRing.maximalIdeal S = + Ideal.span {π} ⊔ Ideal.map (algebraMap R S) (IsLocalRing.maximalIdeal R)) : + Algebra.adjoin R {β} = ⊤ := by + set A := Algebra.adjoin R {β} + set mR := IsLocalRing.maximalIdeal R + set mS := IsLocalRing.maximalIdeal S + set mR_S := Ideal.map (algebraMap R S) mR + have : IsArtinianRing (S ⧸ mR_S) := by + let := Ideal.Quotient.field mR + have := Module.Finite.of_restrictScalars_finite R (R ⧸ mR) (S ⧸ mR_S) + exact IsArtinianRing.of_finite (R ⧸ mR) (S ⧸ mR_S) + obtain ⟨n, hn⟩ := IsLocalRing.exists_maximalIdeal_pow_le_of_isArtinianRing_quotient mR_S + have h_lift := exists_adjoin_sub_mem β q h_gen + have hπ_ms : π ∈ mS := h_ms ▸ Ideal.mem_sup_left (Ideal.mem_span_singleton_self π) + have hq_le : q ≤ mS := IsLocalRing.le_maximalIdeal (Ideal.IsPrime.ne_top inferInstance) + have h_q : (q.restrictScalars R : Submodule R S) ≤ A.toSubmodule ⊔ mR • ⊤ := by + intro x hx + obtain ⟨a, ha, hxa⟩ := + exists_sub_mem_adjoin_of_pow h_lift hπ_mem hπ_ms hq_le h_ms n x + rw [Ideal.smul_top_eq_map] + exact Submodule.mem_sup.mpr ⟨a, ha, x - a, + show x - a ∈ mR_S.restrictScalars R from + (sup_le (Ideal.span_le.mpr (Set.singleton_subset_iff.mpr + (hn (Ideal.pow_mem_pow hπ_ms n)))) le_rfl) hxa, + by ring⟩ + refine eq_top_iff.mpr (Submodule.le_of_le_smul_of_le_jacobson_bot + (Module.finite_def.mp inferInstance) (IsLocalRing.maximalIdeal_le_jacobson ⊥) + (?_ : ⊤ ≤ A.toSubmodule ⊔ mR • ⊤)) + intro s _ + obtain ⟨t, ht, hst⟩ := h_lift s + rw [show s = t + (s - t) by ring] + exact Submodule.add_mem _ (Submodule.mem_sup_left ht) (h_q hst) + + +end SubLemmas + + +/-- When `q` is principal, `f₁(B) = q₀ · a` with `a ∈ m_S`, and `f₁'(B) ∉ m_S`, +adjusting `B` to `B + q₀` yields a monogenic extension via Taylor expansion. -/ +lemma exists_isAdjoinRootMonic_of_principal_adjust + [IsDomain R] [IsDomain S] [IsIntegrallyClosed R] [Algebra R S] + [FaithfulSMul R S] [Module.Finite R S] + (q : Ideal S) [hq_prime : q.IsPrime] + (q₀ : S) (hq₀ : q = Ideal.span {q₀}) + (B : S) (f₁ : R[X]) + (a : S) (ha : Polynomial.aeval B f₁ = q₀ * a) + (ha_mem : a ∈ IsLocalRing.maximalIdeal S) + (h_deriv_not_in_ms : f₁.derivative.aeval B ∉ IsLocalRing.maximalIdeal S) + (h_ms_eq : IsLocalRing.maximalIdeal S = + q ⊔ Ideal.map (algebraMap R S) (IsLocalRing.maximalIdeal R)) + (h_adj : Algebra.adjoin (R ⧸ q.comap (algebraMap R S)) + {Ideal.Quotient.mk q B} = ⊤) : + ∃ f : R[X], Nonempty (IsAdjoinRootMonic S f) := by + set ms := IsLocalRing.maximalIdeal S + set B' := B + q₀ + have hq_le_ms : q ≤ ms := IsLocalRing.le_maximalIdeal hq_prime.ne_top + obtain ⟨b, hb⟩ : ∃ b : S, Polynomial.aeval B' f₁ = + q₀ * (a + f₁.derivative.aeval B + q₀ * b) := by + obtain ⟨c, hc⟩ := exists_aeval_add_eq f₁ B q₀ + exact ⟨c, by rw [hc, show (aeval B) f₁ = q₀ * a from ha]; ring⟩ + have h_cofactor_unit : IsUnit (a + f₁.derivative.aeval B + q₀ * b) := by + rw [show a + f₁.derivative.aeval B + q₀ * b = + f₁.derivative.aeval B + (a + q₀ * b) by ring, ← IsLocalRing.notMem_maximalIdeal] + refine fun h => h_deriv_not_in_ms ?_ + have : a + q₀ * b ∈ ms := + Ideal.add_mem ms ha_mem + (mul_comm q₀ b ▸ + Ideal.mul_mem_left ms b (hq_le_ms (hq₀ ▸ Ideal.mem_span_singleton_self q₀))) + convert Ideal.sub_mem ms h this using 1; ring + have h_span_eq : Ideal.span {Polynomial.aeval B' f₁} = q := by + rw [hb, hq₀]; exact Ideal.span_singleton_mul_right_unit h_cofactor_unit q₀ + exact ⟨minpoly R B', ⟨IsAdjoinRootMonic.mkOfAdjoinEqTop + (Algebra.IsIntegral.isIntegral (R := R) B') + (adjoin_eq_top_of_quotient B' q + (by rw [Ideal.quotient_adjust q q₀ hq₀ B]; exact h_adj) + (Polynomial.aeval B' f₁) + (by rw [Algebra.adjoin_singleton_eq_range_aeval]; exact ⟨f₁, rfl⟩) + (by rw [h_span_eq]; exact h_ms_eq))⟩⟩ + + +/-- A generalization of **Lemma 3.1** of +[Balçık et al.](https://arxiv.org/html/2503.07846v2), proved here under weaker hypotheses +than the regular-local assumptions in the source. +If `R` and `S` are local integral domains with `R` integrally closed, +`S` a UFD, and `R → S` finite and injective, and there exists a +height-one prime `q ⊆ S` such that `R/(q ∩ R) → S/q` is étale, then +there exists a monic `f` with `S ≅ R[X]/(f)`. -/ +theorem exists_isAdjoinRootMonic_of_quotientMap_etale + [IsDomain R] [IsDomain S] [IsIntegrallyClosed R] [UniqueFactorizationMonoid S] [Algebra R S] + [FaithfulSMul R S] [Module.Finite R S] + (q : Ideal S) + [hq_prime : q.IsPrime] (hq_height : q.height = 1) + (hétale : (Ideal.quotientMap q (algebraMap R S) le_rfl).Etale) : + ∃ f : R[X], Nonempty (IsAdjoinRootMonic S f) := by + by_cases hφ_etale : Algebra.Etale R S + · obtain ⟨β, adj⟩ := exists_adjoin_eq_top (R := R) (S := S) + have : Module.Free R S := Module.free_of_flat_of_isLocalRing + exact ⟨minpoly R β, ⟨IsAdjoinRootMonic.mkOfAdjoinEqTop' adj⟩⟩ + set p := q.comap (algebraMap R S) + set φ₀ := Ideal.quotientMap q (algebraMap R S) (le_refl p) + have : IsLocalRing (R ⧸ p) := .of_surjective' _ Ideal.Quotient.mk_surjective + have : IsLocalRing (S ⧸ q) := .of_surjective' _ Ideal.Quotient.mk_surjective + have : Module.Finite (R ⧸ p) (S ⧸ q) := Module.Finite.of_restrictScalars_finite R _ _ + have : Algebra.Etale (R ⧸ p) (S ⧸ q) := RingHom.etale_algebraMap.mp hétale + obtain ⟨B₀, adj⟩ := exists_adjoin_eq_top (R := R ⧸ p) (S := S ⧸ q) + obtain ⟨B, hB⟩ := Ideal.Quotient.mk_surjective B₀ + obtain ⟨f₁, hf₁_map, hf₁_monic⟩ : + ∃ f₁ : R[X], f₁.map (Ideal.Quotient.mk p) = minpoly (R ⧸ p) B₀ ∧ f₁.Monic := by + have h_lifts : (minpoly (R ⧸ p) B₀) ∈ Polynomial.lifts (Ideal.Quotient.mk p) := + (Polynomial.mem_lifts _).mpr + (Polynomial.map_surjective _ Ideal.Quotient.mk_surjective _) + obtain ⟨f₁, hf₁_eq, _, hf₁_monic⟩ := Polynomial.lifts_and_degree_eq_and_monic + h_lifts (minpoly.monic (Algebra.IsIntegral.isIntegral B₀)) + exact ⟨f₁, hf₁_eq, hf₁_monic⟩ + set ms := IsLocalRing.maximalIdeal S + have h_ms_eq := maximalIdeal_eq_sup_of_etale_quotient q hétale + obtain ⟨q₀, hq₀⟩ := Ideal.exists_span_singleton_eq_of_prime_of_height_one q hq_height + set f₁_B := Polynomial.aeval B f₁ + have h_f₁B_in_q : f₁_B ∈ q := by + rw [← Ideal.Quotient.eq_zero_iff_mem] + change Ideal.Quotient.mk q (Polynomial.aeval B f₁) = 0 + simp only [Polynomial.aeval_def] + rw [Polynomial.hom_eval₂, hB, Ideal.quotient_comp_map, ← Polynomial.eval₂_map, hf₁_map] + exact minpoly.aeval (R ⧸ p) B₀ + have h_adj_quot : Algebra.adjoin (R ⧸ q.comap (algebraMap R S)) + {Ideal.Quotient.mk q B} = ⊤ := by + simpa only [hB] using adj + by_cases h_gen : f₁_B ∈ ms ∧ Ideal.span {f₁_B} ⊔ Ideal.map (algebraMap R S) + (IsLocalRing.maximalIdeal R) • ⊤ = ms + · exact ⟨minpoly R B, ⟨IsAdjoinRootMonic.mkOfAdjoinEqTop + (Algebra.IsIntegral.isIntegral (R := R) B) + (adjoin_eq_top_of_quotient B q h_adj_quot + f₁_B (by rw [Algebra.adjoin_singleton_eq_range_aeval]; exact ⟨f₁, rfl⟩) + (by simpa [Ideal.smul_eq_mul, Ideal.mul_top] using h_gen.2.symm))⟩⟩ + · obtain ⟨a, ha⟩ : ∃ a : S, f₁_B = q₀ * a := by + rw [hq₀] at h_f₁B_in_q; exact Ideal.mem_span_singleton.mp h_f₁B_in_q + have h_deriv_not_in_ms : f₁.derivative.aeval B ∉ ms := by + intro h_in_ms + have : IsLocalHom (Ideal.Quotient.mk q) := + IsLocalHom.of_surjective _ Ideal.Quotient.mk_surjective + refine (IsLocalRing.mem_maximalIdeal _).mp h_in_ms + (isUnit_of_map_unit (Ideal.Quotient.mk q) _ ?_) + have h_deriv_comm : Ideal.Quotient.mk q (f₁.derivative.aeval B) = + (minpoly (R ⧸ p) B₀).derivative.aeval B₀ := by + simp only [Polynomial.aeval_def] + rw [Polynomial.hom_eval₂, hB, Ideal.quotient_comp_map, ← Polynomial.eval₂_map] + congr 1; rw [← Polynomial.derivative_map, hf₁_map] + exact h_deriv_comm ▸ isUnit_aeval_derivative_minpoly_of_adjoin_eq_top adj + exact exists_isAdjoinRootMonic_of_principal_adjust q q₀ hq₀ B f₁ a ha + (cofactor_mem_maximalIdeal_of_not_generator f₁_B q h_f₁B_in_q h_gen q₀ hq₀ a ha h_ms_eq) + h_deriv_not_in_ms h_ms_eq (by rw [hB]; exact adj) + +end BGS.CorvajaZannier.LocalMonogenic diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/LocalReciprocalDiscriminant.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/LocalReciprocalDiscriminant.lean new file mode 100644 index 0000000000..204f703ecd --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/LocalReciprocalDiscriminant.lean @@ -0,0 +1,836 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.DedekindDifferentDivisor +public import Mathlib.Algebra.Polynomial.Reverse +public import Mathlib.RingTheory.Polynomial.Resultant.Basic + +/-! +# Reciprocal normalization at a finite base place + +This file supplies the local algebraic bridge used in the Corvaja--Zannier +middle game. If a polynomial relation `f(v) = 0` has unit value `f(c)`, the +reciprocal parameter `z = (v-c)⁻¹` satisfies a monic integral equation. The +normalization preserves primitive generation, becomes the minimal polynomial +under the full-degree hypothesis, and changes the discriminant only by a unit. +Consequently its discriminant has exactly the same order at every finite base +place as the discriminant of `f`. + +The fixed-degree reflection/resultant identities are proved here because the +coefficient-reversal discriminant formula needed for a nonmonic relation was +not previously available in Mathlib in this form. +-/ + +@[expose] public section + +namespace BGS.CorvajaZannier + +open IsDedekindDomain Polynomial + +noncomputable section + +variable {R : Type*} [CommRing R] + +/-- Reverse and exchange the two index blocks of a Sylvester matrix. -/ +def reflectSylvesterEquiv (m n : ℕ) : Fin (n + m) ≃ Fin (m + n) := + (finCongr (Nat.add_comm n m)).trans Fin.revPerm + +@[simp] +private theorem reflectSylvesterEquiv_symm_left (m n : ℕ) (j : Fin m) : + (reflectSylvesterEquiv m n).symm (j.castAdd n) = + (Fin.rev j).natAdd n := by + ext + simp [reflectSylvesterEquiv, Fin.rev] + omega + +@[simp] +private theorem reflectSylvesterEquiv_symm_right (m n : ℕ) (j : Fin n) : + (reflectSylvesterEquiv m n).symm (j.natAdd m) = + (Fin.rev j).castAdd m := by + ext + simp [reflectSylvesterEquiv, Fin.rev] + omega + +@[simp] +private theorem reflectSylvesterEquiv_symm_val (m n : ℕ) (i : Fin (m + n)) : + ((reflectSylvesterEquiv m n).symm i : ℕ) = m + n - (i + 1) := by + simp [reflectSylvesterEquiv, Fin.rev] + +private theorem reflected_row_sub_reflected_shift + (m n i j : ℕ) (_hi : i < m + n) (hj : j < m) + (hji : j ≤ i) (hij : i ≤ j + n) : + m + n - (i + 1) - (m - (j + 1)) = n - (i - j) := by + omega + +theorem sylvester_reflect (f g : R[X]) (m n : ℕ) : + sylvester (reflect m f) (reflect n g) m n = + (sylvester g f n m).reindex + (reflectSylvesterEquiv m n) (reflectSylvesterEquiv m n) := by + ext i j + induction j using Fin.addCases with + | left j => + simp only [sylvester, Matrix.of_apply, Fin.addCases_left, + Matrix.reindex_apply, Matrix.submatrix_apply, + reflectSylvesterEquiv_symm_left, Fin.addCases_right, + reflectSylvesterEquiv_symm_val] + simp only [coeff_reflect] + split_ifs <;> simp_all [revAt] <;> try omega + congr 1 + change revAtFun n ((i : ℕ) - j) = _ + rw [revAtFun, ite_eq_left (by omega)] + exact (reflected_row_sub_reflected_shift m n i j i.isLt j.isLt + (by omega) (by omega)).symm + | right j => + simp only [sylvester, Matrix.of_apply, Fin.addCases_right, + Matrix.reindex_apply, Matrix.submatrix_apply, + reflectSylvesterEquiv_symm_right, Fin.addCases_left, + reflectSylvesterEquiv_symm_val] + simp only [coeff_reflect] + split_ifs <;> simp_all [revAt] <;> try omega + congr 1 + change revAtFun m ((i : ℕ) - j) = _ + rw [revAtFun, ite_eq_left (by omega)] + simpa [Nat.add_comm] using + (reflected_row_sub_reflected_shift n m i j (by omega) j.isLt + (by omega) (by omega)).symm + +/-- Reversing both coefficient lists changes the fixed-degree resultant only +by the standard interchange sign. -/ +theorem resultant_reflect (f g : R[X]) (m n : ℕ) : + resultant (reflect m f) (reflect n g) m n = + (-1) ^ (m * n) * resultant f g m n := by + rw [resultant, sylvester_reflect, Matrix.det_reindex_self, ← resultant] + simpa [Nat.mul_comm] using resultant_comm g f n m + +theorem reflect_derivative_relation (f : R[X]) (n : ℕ) + (hf : f.natDegree ≤ n) : + reflect (n - 1) f.derivative = + C (n : R) * reflect n f - X * (reflect n f).derivative := by + ext k + by_cases hk0 : k = 0 + · subst k + simp only [coeff_reflect, coeff_derivative, revAt_zero, coeff_sub, + coeff_C_mul, coeff_X_mul_zero, sub_zero] + by_cases hn : n = 0 + · subst n + have hcoeff : f.coeff 1 = 0 := coeff_eq_zero_of_natDegree_lt (by omega) + simp [hcoeff] + · have hnsub : n - 1 + 1 = n := by omega + have hncast : ((n - 1 : ℕ) : R) + 1 = (n : R) := by + simpa only [Nat.cast_add, Nat.cast_one] using + congrArg (fun x : ℕ => (x : R)) hnsub + rw [hnsub, hncast] + exact mul_comm _ _ + · obtain ⟨l, rfl⟩ := Nat.exists_eq_succ_of_ne_zero hk0 + simp only [coeff_reflect, coeff_derivative, coeff_sub, coeff_C_mul, + coeff_X_mul] + rcases lt_trichotomy (l + 1) n with hlt | heq | hgt + · rw [revAt_le (by omega : l + 1 ≤ n - 1), revAt_le hlt.le] + have hindex : n - 1 - (l + 1) + 1 = n - (l + 1) := by omega + have hcast : ((n - 1 - (l + 1) : ℕ) : R) + 1 = + ((n - (l + 1) : ℕ) : R) := by + simpa only [Nat.cast_add, Nat.cast_one] using + congrArg (fun x : ℕ => (x : R)) hindex + rw [hindex, hcast] + rw [Nat.cast_sub hlt.le] + push_cast + ring + · rw [← heq, revAt_le le_rfl, + revAt_eq_self_of_lt (by omega : l + 1 - 1 < l + 1)] + have hcoeff : f.coeff (l + 1 + 1) = 0 := + coeff_eq_zero_of_natDegree_lt (by omega) + rw [hcoeff, zero_mul] + push_cast + ring + · rw [revAt_eq_self_of_lt hgt, + revAt_eq_self_of_lt (by omega : n - 1 < l + 1)] + have hcoeff : f.coeff (l + 1) = 0 := + coeff_eq_zero_of_natDegree_lt (by omega) + have hcoeff' : f.coeff (l + 1 + 1) = 0 := + coeff_eq_zero_of_natDegree_lt (by omega) + rw [hcoeff, hcoeff'] + simp + +section Field + +variable {F : Type*} [Field F] + +theorem natDegree_reflect_eq (f : F[X]) (n : ℕ) + (hf : f.natDegree ≤ n) (hzero : f.coeff 0 ≠ 0) : + (reflect n f).natDegree = n := by + apply le_antisymm + · exact natDegree_reflect_le.trans (max_le le_rfl hf) + · apply le_natDegree_of_ne_zero + simpa [coeff_reflect, revAt_le le_rfl] using hzero + +private theorem resultant_reflect_derivative_balance_of_splits + (f : F[X]) (n : ℕ) (hf : f.natDegree ≤ n) + (hzero : f.coeff 0 ≠ 0) (hs : (reflect n f).Splits) : + (reflect n f).leadingCoeff * + resultant (reflect n f) (reflect (n - 1) f.derivative) n (n - 1) = + (reflect n f).coeff 0 * + resultant (reflect n f) (reflect n f).derivative n (n - 1) := by + let h := reflect n f + let q := reflect (n - 1) f.derivative + have hhdeg : h.natDegree = n := natDegree_reflect_eq f n hf hzero + have hqdeg : q.natDegree ≤ n - 1 := by + apply natDegree_reflect_le.trans + rw [max_le_iff] + exact ⟨le_rfl, + (natDegree_derivative_le f).trans (Nat.sub_le_sub_right hf 1)⟩ + have hh'deg : h.derivative.natDegree ≤ n - 1 := by + rw [← hhdeg] + exact natDegree_derivative_le h + rw [show resultant h q n (n - 1) = resultant h q h.natDegree (n - 1) by rw [hhdeg], + resultant_eq_prod_eval h q (n - 1) hqdeg hs] + rw [show resultant h h.derivative n (n - 1) = + resultant h h.derivative h.natDegree (n - 1) by rw [hhdeg], + resultant_eq_prod_eval h h.derivative (n - 1) hh'deg hs] + have hhne : h ≠ 0 := by + intro hh + apply hzero + have hreflect : reflect n f = 0 := by simpa [h] using hh + have : f = 0 := (reflect_eq_zero_iff (N := n) (f := f)).mp hreflect + simp [this] + have hqeval : ∀ r ∈ h.roots, q.eval r = -r * h.derivative.eval r := by + intro r hr + have hroot : h.eval r = 0 := (mem_roots hhne).mp hr + have hrel : q = C (n : F) * h - X * h.derivative := by + simpa [h, q] using reflect_derivative_relation f n hf + rw [hrel] + simp [eval_mul, hroot] + have hprod : (h.roots.map q.eval).prod = + (-1 : F) ^ n * h.roots.prod * (h.roots.map h.derivative.eval).prod := by + calc + (h.roots.map q.eval).prod = + (h.roots.map (fun r => -r * h.derivative.eval r)).prod := by + congr 1 + exact Multiset.map_congr rfl hqeval + _ = (h.roots.map (fun r => (-1 : F))).prod * + h.roots.prod * (h.roots.map h.derivative.eval).prod := by + have hpoint : (h.roots.map (fun r => -r * h.derivative.eval r)) = + h.roots.map (fun r => (((-1 : F) * r) * h.derivative.eval r)) := by + apply Multiset.map_congr rfl + intro r hr + ring + rw [hpoint, Multiset.prod_map_mul, Multiset.prod_map_mul] + simp + _ = (-1 : F) ^ n * h.roots.prod * + (h.roots.map h.derivative.eval).prod := by + have hconst : (h.roots.map (fun _ => (-1 : F))).prod = + (-1 : F) ^ h.roots.card := by + induction h.roots using Multiset.induction_on with + | empty => simp + | cons a s _ => simp [pow_succ] + rw [hconst, ← hs.natDegree_eq_card_roots, hhdeg] + rw [hprod, hs.coeff_zero_eq_leadingCoeff_mul_prod_roots, hhdeg] + ring + +theorem resultant_reflect_derivative_balance + (f : F[X]) (n : ℕ) (hf : f.natDegree ≤ n) + (hzero : f.coeff 0 ≠ 0) : + (reflect n f).leadingCoeff * + resultant (reflect n f) (reflect (n - 1) f.derivative) n (n - 1) = + (reflect n f).coeff 0 * + resultant (reflect n f) (reflect n f).derivative n (n - 1) := by + let h := reflect n f + let E := h.SplittingField + let φ : F →+* E := algebraMap F E + have hφ : Function.Injective φ := (algebraMap F E).injective + apply hφ + have hsplit : (reflect n (f.map φ)).Splits := by + rw [reflect_map] + exact SplittingField.splits h + have hzeroMap : (f.map φ).coeff 0 ≠ 0 := by + simpa [coeff_map] using hφ.ne hzero + have hbalance := resultant_reflect_derivative_balance_of_splits + (f.map φ) n (by simpa [natDegree_map_eq_of_injective hφ] using hf) + hzeroMap hsplit + rw [reflect_map, derivative_map, reflect_map, derivative_map] at hbalance + simpa only [map_mul, resultant_map_map, coeff_map, + leadingCoeff_map_of_injective hφ] using hbalance + +/-- Reversing a polynomial of positive degree with nonzero constant term +preserves its discriminant. -/ +theorem discr_reflect_eq (f : F[X]) (hzero : f.coeff 0 ≠ 0) : + (reflect f.natDegree f).discr = f.discr := by + let n := f.natDegree + by_cases hn : n = 0 + · have hfdeg : f.natDegree = 0 := hn + obtain ⟨a, rfl⟩ := natDegree_eq_zero.mp hfdeg + simp [reflect] + have hnpos : 0 < n := Nat.pos_of_ne_zero hn + let h := reflect n f + have hfne : f ≠ 0 := by + intro hf + apply hzero + simp [hf] + have hhdeg : h.natDegree = n := natDegree_reflect_eq f n le_rfl hzero + have hhne : h ≠ 0 := by + intro hh + apply hfne + apply (reflect_eq_zero_iff (N := n) (f := f)).mp + simpa [h] using hh + have hfDegreePos : 0 < f.degree := by + rw [← natDegree_pos_iff_degree_pos] + exact hnpos + have hhDegreePos : 0 < h.degree := by + rw [← natDegree_pos_iff_degree_pos, hhdeg] + exact hnpos + have hbalance := resultant_reflect_derivative_balance f n le_rfl hzero + have hreflect := resultant_reflect f f.derivative n (n - 1) + have heven : (-1 : F) ^ (n * (n - 1)) = 1 := + n.even_mul_pred_self.neg_one_pow + rw [heven, one_mul] at hreflect + rw [hreflect] at hbalance + have hfResultant := resultant_deriv (f := f) hfDegreePos + have hhResultant := resultant_deriv (f := h) hhDegreePos + rw [show f.natDegree = n from rfl] at hfResultant + rw [hhdeg] at hhResultant + rw [hfResultant, hhResultant] at hbalance + have hhLeading : h.leadingCoeff = f.coeff 0 := by + rw [leadingCoeff, hhdeg, coeff_reflect, revAt_le le_rfl] + simp + have hhCoeffZero : h.coeff 0 = f.leadingCoeff := by + change (reflect n f).coeff 0 = f.leadingCoeff + rw [coeff_reflect, revAt_zero] + change f.coeff f.natDegree = f.coeff f.natDegree + rfl + rw [hhLeading, hhCoeffZero] at hbalance + let s : F := (-1) ^ (n * (n - 1) / 2) + have hs : s ≠ 0 := pow_ne_zero _ (neg_ne_zero.mpr one_ne_zero) + have hlc : f.leadingCoeff ≠ 0 := leadingCoeff_ne_zero.mpr hfne + have hfactor : f.coeff 0 * f.leadingCoeff * s ≠ 0 := + mul_ne_zero (mul_ne_zero hzero hlc) hs + apply mul_left_cancel₀ hfactor + change (f.coeff 0 * f.leadingCoeff * s) * h.discr = + (f.coeff 0 * f.leadingCoeff * s) * f.discr + change f.coeff 0 * (s * f.leadingCoeff * f.discr) = + f.leadingCoeff * (s * f.coeff 0 * h.discr) at hbalance + calc + (f.coeff 0 * f.leadingCoeff * s) * h.discr = + f.leadingCoeff * (s * f.coeff 0 * h.discr) := by ring + _ = f.coeff 0 * (s * f.leadingCoeff * f.discr) := hbalance.symm + _ = (f.coeff 0 * f.leadingCoeff * s) * f.discr := by ring + +/-- Translation of the variable preserves the discriminant. -/ +theorem discr_taylor_eq (f : F[X]) (c : F) : + (f.taylor c).discr = f.discr := by + by_cases hn : f.natDegree = 0 + · obtain ⟨a, rfl⟩ := natDegree_eq_zero.mp hn + simp + let n := f.natDegree + let d := f.derivative.natDegree + let k := n - 1 - d + have hnpos : 0 < n := Nat.pos_of_ne_zero hn + have hdle : d ≤ n - 1 := natDegree_derivative_le f + have hsum : d + k = n - 1 := by omega + have htder : (f.taylor c).derivative = f.derivative.taylor c := by + simp [taylor_apply, derivative_comp] + have htdeg : (f.taylor c).natDegree = n := natDegree_taylor f c + have htderdeg : (f.taylor c).derivative.natDegree = d := by + rw [htder, natDegree_taylor] + have hordinary : + resultant (f.taylor c) (f.taylor c).derivative n d = + resultant f f.derivative n d := by + have ht := resultant_taylor f f.derivative c + rw [← htder] at ht + simpa [n, d, natDegree_taylor, htderdeg] using ht + have hfixedF := resultant_add_right_deg f f.derivative n d k le_rfl + have hfixedT := resultant_add_right_deg + (f.taylor c) (f.taylor c).derivative n d k htderdeg.le + rw [hsum] at hfixedF hfixedT + have hfixed : + resultant (f.taylor c) (f.taylor c).derivative n (n - 1) = + resultant f f.derivative n (n - 1) := by + rw [hfixedT, hfixedF, hordinary] + rw [coeff_natDegree, ← htdeg, coeff_natDegree, leadingCoeff_taylor] + have hfDegreePos : 0 < f.degree := by + rw [← natDegree_pos_iff_degree_pos] + exact hnpos + have htDegreePos : 0 < (f.taylor c).degree := by + rw [← natDegree_pos_iff_degree_pos, htdeg] + exact hnpos + have hfResultant := resultant_deriv (f := f) hfDegreePos + have htResultant := resultant_deriv (f := f.taylor c) htDegreePos + rw [show f.natDegree = n from rfl] at hfResultant + rw [htdeg] at htResultant + rw [htResultant, hfResultant] at hfixed + have hfne : f ≠ 0 := by + intro hf + subst f + simp at hn + have hlc : f.leadingCoeff ≠ 0 := leadingCoeff_ne_zero.mpr hfne + have hs : ((-1 : F) ^ (n * (n - 1) / 2)) ≠ 0 := + pow_ne_zero _ (neg_ne_zero.mpr one_ne_zero) + have hfactor : ((-1 : F) ^ (n * (n - 1) / 2)) * f.leadingCoeff ≠ 0 := + mul_ne_zero hs hlc + rw [leadingCoeff_taylor] at hfixed + exact mul_left_cancel₀ hfactor hfixed + +/-- Scaling every coefficient by `b` scales the discriminant by +`b^(2 * degree - 2)`. -/ +theorem discr_C_mul (f : F[X]) (b : F) (hb : b ≠ 0) : + (C b * f).discr = b ^ (2 * f.natDegree - 2) * f.discr := by + by_cases hn : f.natDegree = 0 + · obtain ⟨a, rfl⟩ := natDegree_eq_zero.mp hn + rw [show b ^ (2 * (C a).natDegree - 2) * (C a).discr = 1 by simp] + simpa only [C_mul] using (discr_C (b * a) : (C (b * a) : F[X]).discr = 1) + let n := f.natDegree + have hnpos : 0 < n := Nat.pos_of_ne_zero hn + have hfne : f ≠ 0 := by + intro hf + subst f + simp at hn + have hgdeg : (C b * f).natDegree = n := by + rw [natDegree_C_mul hb] + have hgder : (C b * f).derivative = C b * f.derivative := by simp + have hres : + resultant (C b * f) (C b * f.derivative) n (n - 1) = + b ^ (n - 1) * b ^ n * resultant f f.derivative n (n - 1) := by + rw [resultant_C_mul_left, resultant_C_mul_right] + ring + have hpow : b ^ (n - 1) * b ^ n = + b * b ^ (2 * n - 2) := by + rw [← pow_add, ← pow_succ'] + congr 1 + omega + rw [hpow] at hres + have hfDegreePos : 0 < f.degree := by + rw [← natDegree_pos_iff_degree_pos] + exact hnpos + have hgDegreePos : 0 < (C b * f).degree := by + rw [← natDegree_pos_iff_degree_pos, hgdeg] + exact hnpos + have hfResultant := resultant_deriv (f := f) hfDegreePos + have hgResultant := resultant_deriv (f := C b * f) hgDegreePos + rw [show f.natDegree = n from rfl] at hfResultant + rw [hgdeg, hgder] at hgResultant + rw [hgResultant, hfResultant] at hres + have hlc : f.leadingCoeff ≠ 0 := leadingCoeff_ne_zero.mpr hfne + have hleading : (C b * f).leadingCoeff = b * f.leadingCoeff := by + rw [leadingCoeff_mul' (mul_ne_zero (by simpa) hlc)] + simp + rw [hleading] at hres + let s : F := (-1) ^ (n * (n - 1) / 2) + have hs : s ≠ 0 := pow_ne_zero _ (neg_ne_zero.mpr one_ne_zero) + have hfactor : s * b * f.leadingCoeff ≠ 0 := + mul_ne_zero (mul_ne_zero hs hb) hlc + apply mul_left_cancel₀ hfactor + change s * (b * f.leadingCoeff) * (C b * f).discr = + b * b ^ (2 * n - 2) * (s * f.leadingCoeff * f.discr) at hres + rw [show f.natDegree = n from rfl] + calc + (s * b * f.leadingCoeff) * (C b * f).discr = + s * (b * f.leadingCoeff) * (C b * f).discr := by ring + _ = b * b ^ (2 * n - 2) * (s * f.leadingCoeff * f.discr) := hres + _ = (s * b * f.leadingCoeff) * + (b ^ (2 * n - 2) * f.discr) := by ring + +end Field + +/-- The reciprocal translate `Z^deg(f) * f(c + Z⁻¹)`, represented without +Laurent polynomials as the reflection of the Taylor translate. -/ +def reciprocalTranslate (f : R[X]) (c : R) : R[X] := + reflect f.natDegree (f.taylor c) + +theorem reciprocalTranslate_natDegree_eq (f : R[X]) (c : R) + (heval : f.eval c ≠ 0) : + (reciprocalTranslate f c).natDegree = f.natDegree := by + apply le_antisymm + · exact natDegree_reflect_le.trans (by simp [natDegree_taylor]) + · apply le_natDegree_of_ne_zero + simpa [reciprocalTranslate, coeff_reflect, revAt_le le_rfl, + taylor_coeff_zero] using heval + +theorem reciprocalTranslate_leadingCoeff (f : R[X]) (c : R) + (heval : f.eval c ≠ 0) : + (reciprocalTranslate f c).leadingCoeff = f.eval c := by + rw [leadingCoeff, reciprocalTranslate_natDegree_eq f c heval] + simp [reciprocalTranslate, coeff_reflect, revAt_le le_rfl, + taylor_coeff_zero] + +section DiscriminantMap + +variable {S : Type*} [CommRing S] [IsDomain S] + +/-- Discriminants commute with an injective coefficient map. -/ +theorem discr_map_of_injective (φ : R →+* S) (hφ : Function.Injective φ) + (f : R[X]) : + (f.map φ).discr = φ f.discr := by + by_cases hn : f.natDegree = 0 + · obtain ⟨a, rfl⟩ := natDegree_eq_zero.mp hn + simp + let n := f.natDegree + have hnpos : 0 < n := Nat.pos_of_ne_zero hn + have hfDegreePos : 0 < f.degree := by + rw [← natDegree_pos_iff_degree_pos] + exact hnpos + have hmapdeg : (f.map φ).natDegree = n := + natDegree_map_eq_of_injective hφ f + have hmapDegreePos : 0 < (f.map φ).degree := by + rw [← natDegree_pos_iff_degree_pos, hmapdeg] + exact hnpos + have hres := resultant_map_map f f.derivative n (n - 1) φ + have hfResultant := resultant_deriv (f := f) hfDegreePos + have hmapResultant := resultant_deriv (f := f.map φ) hmapDegreePos + rw [show f.natDegree = n from rfl] at hfResultant + rw [hmapdeg, derivative_map] at hmapResultant + rw [hmapResultant, hfResultant, map_mul, map_mul, map_pow, + map_neg, map_one, leadingCoeff_map_of_injective hφ] at hres + have hfne : f ≠ 0 := by + intro hf + subst f + simp at hn + have hlc : φ f.leadingCoeff ≠ 0 := + by simpa using hφ.ne (leadingCoeff_ne_zero.mpr hfne) + have hs : ((-1 : S) ^ (n * (n - 1) / 2)) ≠ 0 := + pow_ne_zero _ (neg_ne_zero.mpr one_ne_zero) + exact mul_left_cancel₀ (mul_ne_zero hs hlc) hres + +end DiscriminantMap + +section ReciprocalField + +variable {F : Type*} [Field F] + +theorem reciprocalTranslate_discr (f : F[X]) (c : F) + (heval : f.eval c ≠ 0) : + (reciprocalTranslate f c).discr = f.discr := by + calc + (reciprocalTranslate f c).discr = (f.taylor c).discr := by + simpa [reciprocalTranslate, natDegree_taylor] using + discr_reflect_eq (f.taylor c) (by simpa using heval) + _ = f.discr := discr_taylor_eq f c + +end ReciprocalField + +section ReciprocalRoot + +variable {A L : Type*} [CommRing A] [Field L] [Algebra A L] + +theorem aeval_reciprocalTranslate_inv_sub_eq_zero + (f : A[X]) (c : A) (v : L) + (hvc : v ≠ algebraMap A L c) (hv : aeval v f = 0) : + aeval ((v - algebraMap A L c)⁻¹) (reciprocalTranslate f c) = 0 := by + let x : L := v - algebraMap A L c + have hx : x ≠ 0 := sub_ne_zero.mpr hvc + let : Invertible x := invertibleOfNonzero hx + have htaylor : eval₂ (algebraMap A L) x (f.taylor c) = 0 := by + rw [taylor_apply, eval₂_comp] + simpa [x, aeval_def] using hv + have hreflect := (eval₂_reflect_eq_zero_iff + (algebraMap A L) x f.natDegree (f.taylor c) + (by simp [natDegree_taylor])).2 htaylor + simpa [reciprocalTranslate, aeval_def, x, invOf_eq_inv] using hreflect + +end ReciprocalRoot + +section ReciprocalPrimitiveElement + +variable {K L : Type*} [Field K] [Field L] [Algebra K L] + [Algebra.IsAlgebraic K L] + +/-- Replacing a primitive element `v` by `(v - c)⁻¹` preserves primitive +generation. This is the field-theoretic half of the reciprocal local +normalization used below. -/ +theorem adjoin_inv_sub_eq_top_of_adjoin_eq_top + (c : K) (v : L) (hv : Algebra.adjoin K {v} = ⊤) : + Algebra.adjoin K {(v - algebraMap K L c)⁻¹} = ⊤ := by + apply (IntermediateField.adjoin_eq_top_iff).mp + have hv' : IntermediateField.adjoin K {v} = + (⊤ : IntermediateField K L) := + (IntermediateField.adjoin_eq_top_iff).mpr hv + apply top_unique + rw [← hv'] + apply IntermediateField.adjoin_simple_le_iff.mpr + let z : L := (v - algebraMap K L c)⁻¹ + change v ∈ IntermediateField.adjoin K {z} + have hz : z ∈ IntermediateField.adjoin K {z} := + IntermediateField.mem_adjoin_simple_self K z + rw [show v = z⁻¹ + algebraMap K L c by simp [z]] + exact add_mem (inv_mem hz) (IntermediateField.algebraMap_mem _ c) + +end ReciprocalPrimitiveElement + +section UnitNormalization + +variable {A L : Type*} [CommRing A] [Nontrivial A] [Field L] [Algebra A L] + +/-- Divide a reciprocal translate by its unit leading coefficient. -/ +def unitNormalizedReciprocalTranslate + (f : A[X]) (c : A) (u : Aˣ) : A[X] := + C (↑(u⁻¹) : A) * reciprocalTranslate f c + +omit [Nontrivial A] in +theorem unitNormalizedReciprocalTranslate_map + {S : Type*} [CommRing S] (φ : A →+* S) (hφ : Function.Injective φ) + (f : A[X]) (c : A) (u : Aˣ) : + (unitNormalizedReciprocalTranslate f c u).map φ = + unitNormalizedReciprocalTranslate (f.map φ) (φ c) (Units.map φ u) := by + rw [unitNormalizedReciprocalTranslate, unitNormalizedReciprocalTranslate, + Polynomial.map_mul, Polynomial.map_C] + simp only [Units.coe_map_inv] + congr 1 + rw [reciprocalTranslate, reciprocalTranslate, ← reflect_map, + map_taylor, natDegree_map_eq_of_injective hφ] + +theorem unitNormalizedReciprocalTranslate_monic + (f : A[X]) (c : A) (u : Aˣ) (hu : f.eval c = u) : + (unitNormalizedReciprocalTranslate f c u).Monic := by + apply monic_C_mul_of_mul_leadingCoeff_eq_one + have heval : f.eval c ≠ 0 := by + rw [hu] + exact Units.ne_zero u + rw [reciprocalTranslate_leadingCoeff f c heval] + rw [hu] + simp + +omit [Nontrivial A] in +theorem aeval_unitNormalizedReciprocalTranslate_inv_sub_eq_zero + (f : A[X]) (c : A) (u : Aˣ) (v : L) + (hvc : v ≠ algebraMap A L c) (hv : aeval v f = 0) : + aeval ((v - algebraMap A L c)⁻¹) + (unitNormalizedReciprocalTranslate f c u) = 0 := by + simp [unitNormalizedReciprocalTranslate, + aeval_reciprocalTranslate_inv_sub_eq_zero f c v hvc hv] + +/-- If `f(c)` is a unit, the reciprocal local parameter `(v-c)⁻¹` is +integral over the coefficient ring. -/ +theorem isIntegral_inv_sub_of_eval_eq_unit + (f : A[X]) (c : A) (u : Aˣ) (v : L) + (hu : f.eval c = u) + (hvc : v ≠ algebraMap A L c) (hv : aeval v f = 0) : + IsIntegral A ((v - algebraMap A L c)⁻¹) := by + refine ⟨unitNormalizedReciprocalTranslate f c u, + unitNormalizedReciprocalTranslate_monic f c u hu, ?_⟩ + exact aeval_unitNormalizedReciprocalTranslate_inv_sub_eq_zero + f c u v hvc hv + +end UnitNormalization + +section UnitNormalizationField + +variable {F : Type*} [Field F] + +theorem unitNormalizedReciprocalTranslate_discr + (f : F[X]) (c : F) (u : Fˣ) (hu : f.eval c = u) : + (unitNormalizedReciprocalTranslate f c u).discr = + (↑(u⁻¹) : F) ^ (2 * f.natDegree - 2) * f.discr := by + have heval : f.eval c ≠ 0 := by + rw [hu] + exact Units.ne_zero u + rw [unitNormalizedReciprocalTranslate, + discr_C_mul _ _ (Units.ne_zero (u⁻¹)), + reciprocalTranslate_natDegree_eq f c heval, + reciprocalTranslate_discr f c heval] + +end UnitNormalizationField + +section UnitNormalizationBaseChange + +variable {A K : Type*} [CommRing A] [Nontrivial A] + [Field K] [Algebra A K] + +omit [Nontrivial A] in +/-- After embedding the coefficient ring in a field, normalization changes +the discriminant only by the displayed unit power. -/ +theorem map_unitNormalizedReciprocalTranslate_discr + (hAK : Function.Injective (algebraMap A K)) + (f : A[X]) (c : A) (u : Aˣ) (hu : f.eval c = u) : + algebraMap A K (unitNormalizedReciprocalTranslate f c u).discr = + algebraMap A K (↑(u⁻¹) : A) ^ (2 * f.natDegree - 2) * + algebraMap A K f.discr := by + let φ : A →+* K := algebraMap A K + let uK : Kˣ := Units.map φ u + have huK : (f.map φ).eval (φ c) = uK := by + simpa [φ, uK, hu] using eval_map_apply (p := f) φ c + rw [← discr_map_of_injective φ hAK + (unitNormalizedReciprocalTranslate f c u)] + rw [unitNormalizedReciprocalTranslate_map φ hAK] + rw [unitNormalizedReciprocalTranslate_discr (f.map φ) (φ c) uK huK] + rw [natDegree_map_eq_of_injective hAK] + rw [discr_map_of_injective φ hAK f] + simp [φ, uK] + +end UnitNormalizationBaseChange + +section ReciprocalMinpoly + +variable {A K L : Type*} + [CommRing A] [IsDomain A] [Field K] [Field L] + [Algebra A K] [Algebra K L] [Algebra A L] + [IsScalarTower A K L] [IsFractionRing A K] + [FiniteDimensional K L] + +/-- If the original equation has the full extension degree, then its monic +reciprocal normalization is exactly the minimal polynomial of `(v-c)⁻¹` over +the fraction field. -/ +theorem minpoly_inv_sub_eq_map_unitNormalizedReciprocalTranslate + (f : A[X]) (c : A) (u : Aˣ) (v : L) + (hu : f.eval c = u) + (hvc : v ≠ algebraMap A L c) (hv : aeval v f = 0) + (hprimitive : Algebra.adjoin K {v} = ⊤) + (hdegree : f.natDegree = Module.finrank K L) : + minpoly K ((v - algebraMap A L c)⁻¹) = + (unitNormalizedReciprocalTranslate f c u).map (algebraMap A K) := by + let z : L := (v - algebraMap A L c)⁻¹ + let q : A[X] := unitNormalizedReciprocalTranslate f c u + have hq_monic_A : q.Monic := + unitNormalizedReciprocalTranslate_monic f c u hu + have hq_monic_K : (q.map (algebraMap A K)).Monic := + hq_monic_A.map (algebraMap A K) + have hq_root_A : aeval z q = 0 := by + exact aeval_unitNormalizedReciprocalTranslate_inv_sub_eq_zero + f c u v hvc hv + have hq_root_K : aeval z (q.map (algebraMap A K)) = 0 := by + rw [aeval_map_algebraMap] + exact hq_root_A + have hdvd : minpoly K z ∣ q.map (algebraMap A K) := + minpoly.dvd K z hq_root_K + have hz_primitive_algebra : Algebra.adjoin K {z} = ⊤ := by + simpa [z, IsScalarTower.algebraMap_apply A K L] using + (adjoin_inv_sub_eq_top_of_adjoin_eq_top + (algebraMap A K c) v hprimitive) + have hz_primitive : + IntermediateField.adjoin K {z} = (⊤ : IntermediateField K L) := + (IntermediateField.adjoin_eq_top_iff).mpr hz_primitive_algebra + have hmin_degree : (minpoly K z).natDegree = Module.finrank K L := + (Field.primitive_element_iff_minpoly_natDegree_eq K z).mp hz_primitive + have heval : f.eval c ≠ 0 := by + rw [hu] + exact Units.ne_zero u + have hq_degree : + (q.map (algebraMap A K)).natDegree = (minpoly K z).natDegree := by + rw [natDegree_map_eq_of_injective (IsFractionRing.injective A K)] + change (C ((↑u⁻¹ : A)) * reciprocalTranslate f c).natDegree = _ + rw [natDegree_C_mul (Units.ne_zero (u⁻¹)), + reciprocalTranslate_natDegree_eq f c heval, hdegree, hmin_degree] + have hq_eq : q.map (algebraMap A K) = minpoly K z := + eq_of_monic_of_dvd_of_natDegree_le + (minpoly.monic (Algebra.IsIntegral.isIntegral z)) hq_monic_K hdvd + hq_degree.le + exact hq_eq.symm + +end ReciprocalMinpoly + +section ReciprocalPrimitiveDifferent + +variable {A K L B : Type*} + [CommRing A] [Field K] [CommRing B] [Field L] + [Algebra A K] [Algebra A B] [Algebra B L] + [Algebra K L] [Algebra A L] + [IsScalarTower A K L] [IsScalarTower A B L] + [IsDomain A] [IsIntegrallyClosed A] [IsFractionRing A K] + [FiniteDimensional K L] [Algebra.IsSeparable K L] + [IsIntegralClosure B A L] [IsDedekindDomain B] + [Module.IsTorsionFree A B] + +/-- A reciprocal translate whose value at the center is a unit gives an +integral primitive element, and its minimal-polynomial derivative bounds the +different at every finite prime. -/ +theorem exists_reciprocal_integral_primitive_and_different_bound + (f : A[X]) (c : A) (u : Aˣ) (v : L) + (hu : f.eval c = u) + (hvc : v ≠ algebraMap A L c) (hv : aeval v f = 0) + (hprimitive : Algebra.adjoin K {v} = ⊤) + (w : HeightOneSpectrum B) : + ∃ z : B, + algebraMap B L z = (v - algebraMap A L c)⁻¹ ∧ + Algebra.adjoin K {algebraMap B L z} = ⊤ ∧ + multiplicity w.asIdeal (differentIdeal A B) ≤ + multiplicity w.asIdeal + (Ideal.span {aeval z (derivative (minpoly A z))}) := by + have hz_integral : IsIntegral A ((v - algebraMap A L c)⁻¹) := + isIntegral_inv_sub_of_eval_eq_unit f c u v hu hvc hv + let z : B := + IsIntegralClosure.mk' B ((v - algebraMap A L c)⁻¹) hz_integral + have hz_map : algebraMap B L z = (v - algebraMap A L c)⁻¹ := by + simp [z] + have hz_primitive : Algebra.adjoin K {algebraMap B L z} = ⊤ := by + rw [hz_map] + simpa only [IsScalarTower.algebraMap_apply A K L] using + (adjoin_inv_sub_eq_top_of_adjoin_eq_top + (algebraMap A K c) v hprimitive) + refine ⟨z, hz_map, hz_primitive, ?_⟩ + exact differentIdeal_multiplicity_le_minpolyDerivativeSpan z hz_primitive w + +end ReciprocalPrimitiveDifferent + +section UnitNormalizationFinitePlace + +variable {A K : Type*} [CommRing A] [IsDedekindDomain A] + [Field K] [Algebra A K] [IsFractionRing A K] + +/-- A base-ring unit has order zero at every finite place. -/ +@[simp] +theorem finitePlaceOrderTop_algebraMap_unit + (v : HeightOneSpectrum A) (u : Aˣ) : + finitePlaceOrderTop v (algebraMap A K (u : A)) = 0 := by + have hu_nonnegative : + (0 : WithTop ℤ) ≤ finitePlaceOrderTop v (algebraMap A K (u : A)) := + finitePlaceOrderTop_algebraMap_nonnegative v (u : A) + have hu_inv_nonnegative : + (0 : WithTop ℤ) ≤ finitePlaceOrderTop v (algebraMap A K ((↑u⁻¹ : A))) := + finitePlaceOrderTop_algebraMap_nonnegative v (↑u⁻¹ : A) + have hsum : + finitePlaceOrderTop v (algebraMap A K (u : A)) + + finitePlaceOrderTop v (algebraMap A K ((↑u⁻¹ : A))) = 0 := by + rw [← finitePlaceOrderTop_mul] + simp + apply le_antisymm + · calc + finitePlaceOrderTop v (algebraMap A K (u : A)) ≤ + finitePlaceOrderTop v (algebraMap A K (u : A)) + + finitePlaceOrderTop v (algebraMap A K ((↑u⁻¹ : A))) := + le_add_of_nonneg_right hu_inv_nonnegative + _ = 0 := hsum + · exact hu_nonnegative + +/-- Unit-normalizing a reciprocal translate preserves the discriminant order +at every finite place of the coefficient ring. -/ +theorem finitePlaceOrderTop_map_unitNormalizedReciprocalTranslate_discr + (v : HeightOneSpectrum A) + (f : A[X]) (c : A) (u : Aˣ) (hu : f.eval c = u) : + finitePlaceOrderTop v + (algebraMap A K (unitNormalizedReciprocalTranslate f c u).discr) = + finitePlaceOrderTop v (algebraMap A K f.discr) := by + rw [map_unitNormalizedReciprocalTranslate_discr + (IsFractionRing.injective A K) f c u hu] + rw [finitePlaceOrderTop_mul, finitePlaceOrderTop_pow, + finitePlaceOrderTop_algebraMap_unit] + simp + +/-- Under the full-degree primitive-element hypothesis, the discriminant of +the reciprocal element's minimal polynomial has exactly the order of the +original equation's discriminant at every finite base place. -/ +theorem finitePlaceOrderTop_minpoly_inv_sub_discr + {L : Type*} [Field L] [Algebra K L] [Algebra A L] + [IsScalarTower A K L] [FiniteDimensional K L] + (v₀ : HeightOneSpectrum A) + (f : A[X]) (c : A) (u : Aˣ) (v : L) + (hu : f.eval c = u) + (hvc : v ≠ algebraMap A L c) (hv : aeval v f = 0) + (hprimitive : Algebra.adjoin K {v} = ⊤) + (hdegree : f.natDegree = Module.finrank K L) : + finitePlaceOrderTop v₀ + (minpoly K ((v - algebraMap A L c)⁻¹)).discr = + finitePlaceOrderTop v₀ (algebraMap A K f.discr) := by + rw [minpoly_inv_sub_eq_map_unitNormalizedReciprocalTranslate + f c u v hu hvc hv hprimitive hdegree] + rw [discr_map_of_injective (algebraMap A K) + (IsFractionRing.injective A K)] + exact finitePlaceOrderTop_map_unitNormalizedReciprocalTranslate_discr + v₀ f c u hu + +end UnitNormalizationFinitePlace + + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/LocalWronskian.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/LocalWronskian.lean new file mode 100644 index 0000000000..41c68d74d0 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/LocalWronskian.lean @@ -0,0 +1,193 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.LocalDerivative +public import Mathlib.LinearAlgebra.Matrix.Determinant.Basic +public import Mathlib.RingTheory.HahnSeries.Valuation + +/-! +# Local Wronskian order estimates + +After choosing a local parameter, the Corvaja--Zannier Wronskian becomes a +Wronskian of Laurent series. This file proves the determinant-level local +estimate: the order of an `n × n` ordinary Wronskian is at least the sum of +the column orders minus `n * (n - 1) / 2`. + +The theorem uses `orderTop`, so it also covers a vanishing determinant. It is +the completion-level inequality in the source argument; embedding a curve's +function field in these completions and summing the resulting orders remain +separate global geometric obligations. +-/ + +@[expose] public section + +namespace BGS.CorvajaZannier + +noncomputable section + +open scoped Matrix BigOperators + +open HahnSeries LaurentSeries + +variable {K : Type*} [Field K] + +/-- The ordinary Wronskian matrix of Laurent series with respect to the local +parameter. -/ +def laurentSeriesWronskian {n : ℕ} (f : Fin n → LaurentSeries K) : + Matrix (Fin n) (Fin n) (LaurentSeries K) := + fun i j ↦ ((LaurentSeries.derivative K)^[i.1]) (f j) + +/-- Apply a constant scalar matrix to the columns of a Laurent-series family. -/ +def laurentSeriesColumnCombination {n : ℕ} + (f : Fin n → LaurentSeries K) (A : Matrix (Fin n) (Fin n) K) : + Fin n → LaurentSeries K := + fun j ↦ ∑ i, A i j • f i + +private theorem derivative_iterate_sum_smul {ι : Type*} [Fintype ι] + (r : ℕ) (a : ι → K) (f : ι → LaurentSeries K) : + ((LaurentSeries.derivative K)^[r]) (∑ i, a i • f i) = + ∑ i, a i • ((LaurentSeries.derivative K)^[r]) (f i) := by + induction r with + | zero => simp + | succ r ih => + simp_rw [Function.iterate_succ_apply'] + rw [ih, map_sum] + simp + +/-- A constant change of columns commutes with formation of the local +Wronskian. -/ +theorem laurentSeriesWronskian_columnCombination {n : ℕ} + (f : Fin n → LaurentSeries K) (A : Matrix (Fin n) (Fin n) K) : + laurentSeriesWronskian (laurentSeriesColumnCombination f A) = + laurentSeriesWronskian f * A.map (algebraMap K (LaurentSeries K)) := by + apply Matrix.ext + intro i j + rw [Matrix.mul_apply] + simp only [laurentSeriesWronskian, laurentSeriesColumnCombination, + Matrix.map_apply] + rw [derivative_iterate_sum_smul] + have halgebraMap (a : K) : + algebraMap K (LaurentSeries K) a = HahnSeries.single 0 a := by + change ((algebraMap K (PowerSeries K) a : PowerSeries K) : + LaurentSeries K) = HahnSeries.single 0 a + rw [← PowerSeries.C_eq_algebraMap, PowerSeries.coe_C] + rfl + have hscalar (a : K) (x : LaurentSeries K) : + a • x = algebraMap K (LaurentSeries K) a * x := by + rw [halgebraMap] + exact HahnSeries.single_zero_mul_eq_smul.symm + simp_rw [hscalar] + apply Finset.sum_congr rfl + intro k _ + exact mul_comm _ _ + +/-- A determinant-one constant column operation leaves the local Wronskian +determinant unchanged. This is the formal column-operation principle used in +the source's local cases. -/ +theorem laurentSeriesWronskian_det_columnCombination_of_det_eq_one {n : ℕ} + (f : Fin n → LaurentSeries K) (A : Matrix (Fin n) (Fin n) K) + (hA : A.det = 1) : + (laurentSeriesWronskian (laurentSeriesColumnCombination f A)).det = + (laurentSeriesWronskian f).det := by + rw [laurentSeriesWronskian_columnCombination, Matrix.det_mul] + have hdetmap : + (A.map (algebraMap K (LaurentSeries K))).det = 1 := by + calc + (A.map (algebraMap K (LaurentSeries K))).det = + algebraMap K (LaurentSeries K) A.det := by + simpa using ((algebraMap K (LaurentSeries K)).map_det A).symm + _ = 1 := by rw [hA, map_one] + rw [hdetmap, mul_one] + +private theorem addVal_prod {ι : Type*} + (s : Finset ι) (g : ι → LaurentSeries K) : + HahnSeries.addVal ℤ K (∏ i ∈ s, g i) = + ∑ i ∈ s, HahnSeries.addVal ℤ K (g i) := by + classical + induction s using Finset.induction_on with + | empty => simp + | @insert a s ha ih => simp [ha, ih, AddValuation.map_mul] + +private theorem coe_sum_int_finset {ι : Type*} + (s : Finset ι) (g : ι → ℤ) : + (((∑ i ∈ s, g i : ℤ) : ℤ) : WithTop ℤ) = + ∑ i ∈ s, ((g i : ℤ) : WithTop ℤ) := by + classical + induction s using Finset.induction_on with + | empty => simp + | @insert a s ha ih => simp [ha, ih, WithTop.coe_add] + +private theorem coe_sum_int {ι : Type*} [Fintype ι] (g : ι → ℤ) : + (((∑ i, g i : ℤ) : ℤ) : WithTop ℤ) = + ∑ i, ((g i : ℤ) : WithTop ℤ) := by + classical + exact coe_sum_int_finset Finset.univ g + +/-- Before evaluating the triangular number, the local Wronskian determinant +has order at least the sum of the column orders minus the sum of the derivative +orders `0, ..., n - 1`. -/ +theorem orderTop_laurentSeriesWronskian_det_lower_bound {n : ℕ} + (f : Fin n → LaurentSeries K) : + (((∑ j, (f j).order) - ∑ j : Fin n, (j : ℤ) : ℤ) : WithTop ℤ) ≤ + (laurentSeriesWronskian f).det.orderTop := by + rw [Matrix.det_apply] + change (((∑ j, (f j).order) - ∑ j : Fin n, (j : ℤ) : ℤ) : WithTop ℤ) ≤ + HahnSeries.addVal ℤ K + (∑ σ, Equiv.Perm.sign σ • ∏ i, laurentSeriesWronskian f (σ i) i) + apply AddValuation.map_le_sum + intro σ _ + calc + (((∑ j, (f j).order) - ∑ j : Fin n, (j : ℤ) : ℤ) : WithTop ℤ) = + ∑ j : Fin n, (((f j).order - (σ j : ℕ) : ℤ) : WithTop ℤ) := by + rw [← Equiv.sum_comp σ (fun j : Fin n ↦ (j : ℤ))] + rw [← coe_sum_int] + congr 1 + rw [Finset.sum_sub_distrib] + _ ≤ ∑ j : Fin n, + ((((LaurentSeries.derivative K)^[((σ j : Fin n) : ℕ)]) + (f j)).orderTop) := by + gcongr with j + exact order_sub_le_orderTop_derivative_iterate + ((σ j : Fin n) : ℕ) (f j) + _ = (∏ i, laurentSeriesWronskian f (σ i) i).orderTop := by + rw [← HahnSeries.addVal_apply, addVal_prod] + simp only [HahnSeries.addVal_apply] + rfl + _ ≤ (Equiv.Perm.sign σ • + ∏ i, laurentSeriesWronskian f (σ i) i).orderTop := by + exact orderTop_le_orderTop_smul _ _ + +/-- The local Wronskian determinant loses at most the triangular number +`n * (n - 1) / 2` from the sum of its column orders. -/ +theorem orderTop_laurentSeriesWronskian_det_lower_bound_closed {n : ℕ} + (f : Fin n → LaurentSeries K) : + (((∑ j, (f j).order) - (n * (n - 1) / 2 : ℕ) : ℤ) : WithTop ℤ) ≤ + (laurentSeriesWronskian f).det.orderTop := by + convert orderTop_laurentSeriesWronskian_det_lower_bound f using 1 + congr 1 + apply congrArg (fun x : ℤ ↦ (∑ j, (f j).order) - x) + rw [Fin.sum_univ_eq_sum_range] + rw [← Nat.cast_sum] + exact congrArg (fun x : ℕ ↦ (x : ℤ)) (Finset.sum_range_id n).symm + +/-- The determinant order can be estimated after any determinant-one constant +column operation. This is the form used when the source separates repeated +pole orders or replaces columns by better local approximations. -/ +theorem orderTop_laurentSeriesWronskian_det_lower_bound_after_columnCombination + {n : ℕ} (f : Fin n → LaurentSeries K) + (A : Matrix (Fin n) (Fin n) K) (hA : A.det = 1) : + (((∑ j, (laurentSeriesColumnCombination f A j).order) - + (n * (n - 1) / 2 : ℕ) : ℤ) : WithTop ℤ) ≤ + (laurentSeriesWronskian f).det.orderTop := by + rw [← laurentSeriesWronskian_det_columnCombination_of_det_eq_one f A hA] + exact orderTop_laurentSeriesWronskian_det_lower_bound_closed + (laurentSeriesColumnCombination f A) + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/NumericalCorollary.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/NumericalCorollary.lean new file mode 100644 index 0000000000..e2bcd56d01 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/NumericalCorollary.lean @@ -0,0 +1,56 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.ParameterizedBound +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.NumericalOptimization + +/-! +# The numerical Corvaja--Zannier Theorem 2 bound + +This file composes the floor-parameter proof of Theorem 4 with the corrected +one-parameter optimization in `NumericalOptimization`. Its only substantive +hypothesis is the ordinary Proposition 2 alternative for every admissible +pair of natural parameters. +-/ + +@[expose] public section + +namespace BGS.CorvajaZannier + +noncomputable section + +/-- The exact numerical maximum in Corvaja--Zannier Theorem 2, deduced from +the numerical alternatives in Proposition 2. + +The final optimization uses the corrected split recorded in +`theoremTwo_bound_of_theoremFour_bound`; it does not use the incompatible +parameter choices printed in the last paragraph of the source proof. -/ +theorem theoremTwo_maxBound_of_propositionTwo + (a b chi p : ℕ) (G : ℝ) + (ha : 0 < a) (hab : a ≤ b) (hchi : 0 < chi) (hp : 0 < p) + (hGNonneg : 0 ≤ G) (hGTrivial : G ≤ (a : ℝ)) + (hPropositionTwo : PropositionTwoNumericalAlternatives a b p chi G) : + G ≤ max + (3 * (2 * ((a : ℝ) * (b : ℝ) * (chi : ℝ))) ^ ((1 : ℝ) / 3)) + (12 * ((a : ℝ) * (b : ℝ)) / (p : ℝ)) := by + have haReal : 0 < (a : ℝ) := by exact_mod_cast ha + have hbReal : 0 < (b : ℝ) := by exact_mod_cast (lt_of_lt_of_le ha hab) + have hchiReal : 0 < (chi : ℝ) := by exact_mod_cast hchi + have hpReal : 0 < (p : ℝ) := by exact_mod_cast hp + apply theoremTwo_bound_of_theoremFour_bound + (p : ℝ) (a : ℝ) (b : ℝ) (chi : ℝ) G + hpReal haReal hbReal hchiReal + intro t ht hAdmissible + apply theoremFour_parameterizedBound_of_propositionTwo + a b chi p G t ha hab hchi hp hGNonneg hGTrivial ht hPropositionTwo + apply (lt_div_iff₀ (by positivity : 0 < 8 * t ^ 3)).2 + simpa [mul_comm, mul_left_comm, mul_assoc] using hAdmissible + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/NumericalOptimization.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/NumericalOptimization.lean new file mode 100644 index 0000000000..cc0b57844d --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/NumericalOptimization.lean @@ -0,0 +1,223 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import Mathlib.Analysis.SpecialFunctions.Pow.Real +public import Mathlib.Tactic.FieldSimp +public import Mathlib.Tactic.Linarith +public import Mathlib.Tactic.NormNum +public import Mathlib.Tactic.Positivity +public import Mathlib.Tactic.Ring + +/-! +# Numerical optimization in Corvaja--Zannier Theorem 2 + +The last step in the proof of Corvaja--Zannier's Theorem 2 optimizes the +parameterized estimate of their Theorem 4. The split printed in the paper is +not compatible with the strict hypothesis of Theorem 4: if + +`Q = p^3 * chi / (degreeU * degreeV)^2`, + +then the fixed choice `t = 4^(1/3)` requires `Q >= 32`, not `Q >= 4`. +For `Q < 32`, the valid choice is `t = Q^(1/3) / 2`. These two choices give +exactly the maximum displayed in Theorem 2. + +This file isolates that corrected real-arithmetic argument. Its theorem takes +the parameterized Theorem-4 estimate as an ordinary hypothesis, so it can be +applied directly once the curve-theoretic part of Theorem 4 is formalized. +-/ + +@[expose] public section + +namespace BGS.CorvajaZannier + +noncomputable section + +/-- The dimensionless ratio used in the final optimization of +Corvaja--Zannier Theorem 2. -/ +def optimizationRatio + (p degreeProduct eulerCharacteristic : ℝ) : ℝ := + p ^ 3 * eulerCharacteristic / degreeProduct ^ 2 + +private theorem rpow_one_third_cube {x : ℝ} (hx : 0 ≤ x) : + (x ^ ((1 : ℝ) / 3)) ^ (3 : ℕ) = x := by + rw [← Real.rpow_mul_natCast hx] + norm_num + +private theorem fixed_parameter_coefficient_identity : + let t : ℝ := (4 : ℝ) ^ ((1 : ℝ) / 3) + 4 / t + t ^ 2 / 2 = 3 * (2 : ℝ) ^ ((1 : ℝ) / 3) := by + dsimp only + let t : ℝ := (4 : ℝ) ^ ((1 : ℝ) / 3) + let twoRoot : ℝ := (2 : ℝ) ^ ((1 : ℝ) / 3) + have htPos : 0 < t := by + dsimp [t] + positivity + have htCube : t ^ 3 = 4 := by + simpa [t] using rpow_one_third_cube (show (0 : ℝ) ≤ 4 by norm_num) + have htwoRootNonneg : 0 ≤ twoRoot := by + dsimp [twoRoot] + positivity + have htwoRootCube : twoRoot ^ 3 = 2 := by + simpa [twoRoot] using rpow_one_third_cube (show (0 : ℝ) ≤ 2 by norm_num) + have hscaledCube : (t ^ 2 / 2) ^ 3 = 2 := by + calc + (t ^ 2 / 2) ^ 3 = (t ^ 3) ^ 2 / 8 := by ring + _ = 2 := by rw [htCube]; norm_num + have hscaled : t ^ 2 / 2 = twoRoot := by + apply (pow_left_inj₀ (by positivity) htwoRootNonneg (by norm_num : (3 : ℕ) ≠ 0)).mp + exact hscaledCube.trans htwoRootCube.symm + have hfourDiv : 4 / t = t ^ 2 := by + apply (div_eq_iff htPos.ne').2 + nlinarith [htCube] + change 4 / t + t ^ 2 / 2 = 3 * twoRoot + rw [hfourDiv, ← hscaled] + ring + +/-- The corrected numerical deduction of Corvaja--Zannier Theorem 2 from the +parameterized estimate in Theorem 4. + +The hypothesis `hTheoremFour` is precisely the real-valued part of Theorem 4: +for every positive parameter satisfying its strict size condition, it supplies +the parameterized gcd bound. The proof uses the valid split `Q ≥ 32` and +`Q < 32`; it does not use the erroneous `Q = 4` split printed in the final +paragraph of the paper. -/ +theorem theoremTwo_bound_of_theoremFour_bound + (p degreeU degreeV eulerCharacteristic gcdValue : ℝ) + (hp : 0 < p) (hdegreeU : 0 < degreeU) (hdegreeV : 0 < degreeV) + (hEuler : 0 < eulerCharacteristic) + (hTheoremFour : ∀ t : ℝ, 0 < t → + 8 * t ^ 3 * (degreeU * degreeV) ^ 2 < + (p + degreeU + degreeV) ^ 3 * eulerCharacteristic → + gcdValue ≤ + (4 / t + t ^ 2 / 2) * + (degreeU * degreeV * eulerCharacteristic) ^ ((1 : ℝ) / 3)) : + gcdValue ≤ max + (3 * (2 * (degreeU * degreeV * eulerCharacteristic)) ^ ((1 : ℝ) / 3)) + (12 * (degreeU * degreeV) / p) := by + let degreeProduct : ℝ := degreeU * degreeV + let base : ℝ := degreeProduct * eulerCharacteristic + let Q : ℝ := optimizationRatio p degreeProduct eulerCharacteristic + have hdegreeProduct : 0 < degreeProduct := by + dsimp [degreeProduct] + positivity + have hbase : 0 < base := by + dsimp [base] + positivity + have hQ : 0 < Q := by + dsimp [Q, optimizationRatio] + positivity + have hQProduct : Q * degreeProduct ^ 2 = p ^ 3 * eulerCharacteristic := by + dsimp [Q, optimizationRatio] + field_simp [hdegreeProduct.ne'] + have hpSum : p < p + degreeU + degreeV := by linarith + have hpCube : p ^ 3 < (p + degreeU + degreeV) ^ 3 := + pow_lt_pow_left₀ hpSum hp.le (by norm_num) + have hpEuler : + p ^ 3 * eulerCharacteristic < + (p + degreeU + degreeV) ^ 3 * eulerCharacteristic := + mul_lt_mul_of_pos_right hpCube hEuler + by_cases hlarge : (32 : ℝ) ≤ Q + · let t : ℝ := (4 : ℝ) ^ ((1 : ℝ) / 3) + have htPos : 0 < t := by + dsimp [t] + positivity + have htCube : t ^ 3 = 4 := by + simpa [t] using rpow_one_third_cube (show (0 : ℝ) ≤ 4 by norm_num) + have hthreshold : + 32 * degreeProduct ^ 2 ≤ p ^ 3 * eulerCharacteristic := by + calc + 32 * degreeProduct ^ 2 ≤ Q * degreeProduct ^ 2 := by + exact mul_le_mul_of_nonneg_right hlarge (sq_nonneg degreeProduct) + _ = p ^ 3 * eulerCharacteristic := hQProduct + have htAdmissible : + 8 * t ^ 3 * (degreeU * degreeV) ^ 2 < + (p + degreeU + degreeV) ^ 3 * eulerCharacteristic := by + calc + 8 * t ^ 3 * (degreeU * degreeV) ^ 2 = + 32 * degreeProduct ^ 2 := by + rw [htCube] + simp only [degreeProduct] + ring + _ ≤ p ^ 3 * eulerCharacteristic := hthreshold + _ < (p + degreeU + degreeV) ^ 3 * eulerCharacteristic := hpEuler + have hBound := hTheoremFour t htPos htAdmissible + have hfixed : + (4 / t + t ^ 2 / 2) * base ^ ((1 : ℝ) / 3) = + 3 * (2 * base) ^ ((1 : ℝ) / 3) := by + rw [show 4 / t + t ^ 2 / 2 = + 3 * (2 : ℝ) ^ ((1 : ℝ) / 3) by + simpa [t] using fixed_parameter_coefficient_identity] + rw [Real.mul_rpow (show (0 : ℝ) ≤ 2 by norm_num) hbase.le] + ring + apply hBound.trans + rw [show degreeU * degreeV * eulerCharacteristic = base by + simp [base, degreeProduct]] + rw [hfixed] + exact le_max_left _ _ + · have hsmall : Q < 32 := lt_of_not_ge hlarge + let qRoot : ℝ := Q ^ ((1 : ℝ) / 3) + let t : ℝ := qRoot / 2 + let baseRoot : ℝ := base ^ ((1 : ℝ) / 3) + have hqRootPos : 0 < qRoot := by + dsimp [qRoot] + positivity + have hqRootCube : qRoot ^ 3 = Q := by + simpa [qRoot] using rpow_one_third_cube hQ.le + have htPos : 0 < t := by + dsimp [t] + positivity + have htCube : 8 * t ^ 3 = Q := by + dsimp [t] + nlinarith [hqRootCube] + have htAdmissible : + 8 * t ^ 3 * (degreeU * degreeV) ^ 2 < + (p + degreeU + degreeV) ^ 3 * eulerCharacteristic := by + change 8 * t ^ 3 * degreeProduct ^ 2 < + (p + degreeU + degreeV) ^ 3 * eulerCharacteristic + rw [htCube, hQProduct] + exact hpEuler + have hBound := hTheoremFour t htPos htAdmissible + have hcoefficient : 4 / t + t ^ 2 / 2 ≤ 12 / qRoot := by + dsimp [t] + apply (le_div_iff₀ hqRootPos).2 + field_simp [hqRootPos.ne'] + nlinarith [hqRootCube] + have hbaseRootNonneg : 0 ≤ baseRoot := by + dsimp [baseRoot] + positivity + have hbaseRootCube : baseRoot ^ 3 = base := by + simpa [baseRoot] using rpow_one_third_cube hbase.le + have hrootRatio : baseRoot / qRoot = degreeProduct / p := by + apply (pow_left_inj₀ (by positivity) (by positivity) + (by norm_num : (3 : ℕ) ≠ 0)).mp + rw [div_pow, div_pow, hbaseRootCube, hqRootCube] + dsimp [base, Q, optimizationRatio] + field_simp [hp.ne', hdegreeProduct.ne', hEuler.ne'] + have hsecond : + (12 / qRoot) * baseRoot = 12 * degreeProduct / p := by + calc + (12 / qRoot) * baseRoot = 12 * (baseRoot / qRoot) := by ring + _ = 12 * (degreeProduct / p) := by rw [hrootRatio] + _ = 12 * degreeProduct / p := by ring + apply hBound.trans + rw [show degreeU * degreeV * eulerCharacteristic = base by + simp [base, degreeProduct]] + change (4 / t + t ^ 2 / 2) * baseRoot ≤ _ + calc + (4 / t + t ^ 2 / 2) * baseRoot ≤ + (12 / qRoot) * baseRoot := + mul_le_mul_of_nonneg_right hcoefficient hbaseRootNonneg + _ = 12 * degreeProduct / p := hsecond + _ ≤ max + (3 * (2 * (degreeU * degreeV * eulerCharacteristic)) ^ ((1 : ℝ) / 3)) + (12 * (degreeU * degreeV) / p) := by + simp [degreeProduct] + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/ParameterizedBound.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/ParameterizedBound.lean new file mode 100644 index 0000000000..c2a55c3c61 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/ParameterizedBound.lean @@ -0,0 +1,506 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import Mathlib.Analysis.SpecialFunctions.Pow.Real +public import Mathlib.Tactic + +/-! +# The parameterized numerical bound in Corvaja--Zannier Theorem 4 + +This file isolates the real and natural-number optimization in the proof of +Corvaja--Zannier, JEMS 15 (2013), Theorem 4. The curve-theoretic content of +their Proposition 2 is an ordinary proposition-valued hypothesis below. No +function-field or valuation statement is assumed through a typeclass. + +The source chooses + +`h = floor (t * (b^2 / (a * chi))^(1/3)) - 1` and +`k = floor (t * (a^2 / (b * chi))^(1/3)) - 1`. + +The proof below retains that choice and checks the small-`k`, degree- +alternative, parameter-admissibility, and numerical-bound cases separately. +-/ + +@[expose] public section + +namespace BGS.CorvajaZannier + +noncomputable section + +/-- The natural parameters to which the numerical form of Corvaja--Zannier +Proposition 2 applies. Positivity of `h * k + h + k` records that the +denominator in Proposition 2 is meaningful. -/ +def PropositionTwoParametersAreAdmissible + (a b p h k : ℕ) : Prop := + 0 < h * k + h + k ∧ a * h + b * k < p + +/-- The two alternatives supplied by the numerical part of +Corvaja--Zannier Proposition 2. + +Here `a = deg(v)`, `b = deg(u)`, `chi` is the Euler characteristic, and `G` +is the gcd sum. This is deliberately an ordinary `Prop`, not a structure, +class, or axiom. -/ +def PropositionTwoNumericalAlternatives + (a b p chi : ℕ) (G : ℝ) : Prop := + ∀ h k : ℕ, + PropositionTwoParametersAreAdmissible a b p h k → + (a ≤ k ∧ b ≤ h) ∨ + G ≤ + (((h + 2 * k : ℕ) : ℝ) / ((h * k + h + k : ℕ) : ℝ)) * (a : ℝ) + + ((k : ℝ) / ((h * k + h + k : ℕ) : ℝ)) * (b : ℝ) + + ((((h * k + h + k : ℕ) : ℝ) - 1) / 2) * (chi : ℝ) + +private theorem rpow_one_third_cube {x : ℝ} (hx : 0 ≤ x) : + (x ^ ((1 : ℝ) / 3)) ^ (3 : ℕ) = x := by + rw [← Real.rpow_mul_natCast hx] + norm_num + +private theorem lt_natFloor_sub_one_add_two (x : ℝ) : + x < ((⌊x⌋₊ - 1 : ℕ) : ℝ) + 2 := by + have hfloor := Nat.lt_floor_add_one x + have hnat : ⌊x⌋₊ + 1 ≤ (⌊x⌋₊ - 1) + 2 := by omega + exact hfloor.trans_le (by exact_mod_cast hnat) + +private theorem natFloor_sub_one_add_one_le + {x : ℝ} (hx : 0 ≤ x) (hfloor : 1 ≤ ⌊x⌋₊) : + (((⌊x⌋₊ - 1 : ℕ) : ℝ) + 1) ≤ x := by + have hnat : ⌊x⌋₊ - 1 + 1 = ⌊x⌋₊ := Nat.sub_add_cancel hfloor + have hcast : (((⌊x⌋₊ - 1 : ℕ) : ℝ) + 1) = (⌊x⌋₊ : ℝ) := by + exact_mod_cast hnat + rw [hcast] + exact Nat.floor_le hx + +private theorem propositionTwo_first_coefficient_le + {h k : ℝ} (hkPos : 0 < k) (hk : k ≤ h) : + (h + 2 * k) / (h * k + h + k) ≤ 3 / (k + 2) := by + have hhPos : 0 < h := lt_of_lt_of_le hkPos hk + have hnPos : 0 < h * k + h + k := by positivity + have hkTwoPos : 0 < k + 2 := by positivity + rw [div_le_div_iff₀ hnPos hkTwoPos] + nlinarith [mul_nonneg (sub_nonneg.mpr hk) (by positivity : 0 ≤ 2 * k + 1)] + +private theorem propositionTwo_second_coefficient_le + {h k : ℝ} (hkPos : 0 < k) (hk : k ≤ h) : + k / (h * k + h + k) ≤ 1 / (h + 2) := by + have hhPos : 0 < h := lt_of_lt_of_le hkPos hk + have hnPos : 0 < h * k + h + k := by positivity + have hhTwoPos : 0 < h + 2 := by positivity + rw [div_le_div_iff₀ hnPos hhTwoPos] + nlinarith + +private theorem sqrt_le_theoremFour_coefficient {t : ℝ} (ht : 0 < t) : + Real.sqrt t ≤ 4 / t + t ^ 2 / 2 := by + have hsqrtNonneg : 0 ≤ Real.sqrt t := Real.sqrt_nonneg _ + have hsqrtSq : (Real.sqrt t) ^ 2 = t := Real.sq_sqrt ht.le + apply (mul_le_mul_iff_right₀ ht).mp + have hfour : t * (4 / t) = 4 := by field_simp [ht.ne'] + rw [mul_add, hfour] + have htsqrt : t * Real.sqrt t = (Real.sqrt t) ^ 3 := by + calc + t * Real.sqrt t = (Real.sqrt t) ^ 2 * Real.sqrt t := by rw [hsqrtSq] + _ = (Real.sqrt t) ^ 3 := by ring + have htquadratic : t * (t ^ 2 / 2) = (Real.sqrt t) ^ 6 / 2 := by + calc + t * (t ^ 2 / 2) = t ^ 3 / 2 := by ring + _ = ((Real.sqrt t) ^ 2) ^ 3 / 2 := by rw [hsqrtSq] + _ = (Real.sqrt t) ^ 6 / 2 := by ring + rw [htsqrt, htquadratic] + nlinarith [sq_nonneg ((Real.sqrt t) ^ 3 - 1)] + +private theorem degree_le_theoremFour_bound_of_sq_le_cube + {degree root t : ℝ} (hdegree : 0 ≤ degree) (hroot : 0 ≤ root) + (ht : 0 < t) (hSq : degree ^ 2 ≤ root ^ 3) (hrootLe : root ≤ t) : + degree ≤ (4 / t + t ^ 2 / 2) * root := by + have hrootCube : 0 ≤ root ^ 3 := pow_nonneg hroot _ + have hdegreeLeSqrt : degree ≤ Real.sqrt (root ^ 3) := by + exact (sq_le_sq₀ hdegree (Real.sqrt_nonneg _)).mp + (hSq.trans_eq (Real.sq_sqrt hrootCube).symm) + have hsqrtCube : Real.sqrt (root ^ 3) = root * Real.sqrt root := by + have hproductNonneg : 0 ≤ root * Real.sqrt root := + mul_nonneg hroot (Real.sqrt_nonneg _) + apply (sq_eq_sq₀ (Real.sqrt_nonneg _) hproductNonneg).mp + calc + (Real.sqrt (root ^ 3)) ^ 2 = root ^ 3 := Real.sq_sqrt hrootCube + _ = (root * Real.sqrt root) ^ 2 := by + rw [mul_pow, Real.sq_sqrt hroot] + ring + have hsqrtRootLe : Real.sqrt root ≤ Real.sqrt t := Real.sqrt_le_sqrt hrootLe + have hsqrtTCoefficient := sqrt_le_theoremFour_coefficient ht + calc + degree ≤ Real.sqrt (root ^ 3) := hdegreeLeSqrt + _ = root * Real.sqrt root := hsqrtCube + _ ≤ root * Real.sqrt t := mul_le_mul_of_nonneg_left hsqrtRootLe hroot + _ ≤ root * (4 / t + t ^ 2 / 2) := + mul_le_mul_of_nonneg_left hsqrtTCoefficient hroot + _ = (4 / t + t ^ 2 / 2) * root := mul_comm _ _ + +private theorem propositionTwo_numerical_bound + {a b chi : ℕ} {t G : ℝ} + (ha : 0 < a) (hb : 0 < b) (hchi : 0 < chi) (ht : 0 < t) : + let A : ℝ := a + let B : ℝ := b + let C : ℝ := chi + let base : ℝ := A * B * C + let baseRoot : ℝ := base ^ ((1 : ℝ) / 3) + let hScale : ℝ := (B ^ 2 / (A * C)) ^ ((1 : ℝ) / 3) + let kScale : ℝ := (A ^ 2 / (B * C)) ^ ((1 : ℝ) / 3) + let xH : ℝ := t * hScale + let xK : ℝ := t * kScale + let h : ℕ := ⌊xH⌋₊ - 1 + let k : ℕ := ⌊xK⌋₊ - 1 + 0 < k → k ≤ h → + G ≤ (((h + 2 * k : ℕ) : ℝ) / ((h * k + h + k : ℕ) : ℝ)) * A + + ((k : ℝ) / ((h * k + h + k : ℕ) : ℝ)) * B + + ((((h * k + h + k : ℕ) : ℝ) - 1) / 2) * C → + G ≤ (4 / t + t ^ 2 / 2) * baseRoot := by + intro A B C base baseRoot hScale kScale xH xK h k hkPos hkh hNumerical + have hAPos : 0 < A := by dsimp [A]; exact_mod_cast ha + have hBPos : 0 < B := by + dsimp [B] + exact_mod_cast hb + have hCPos : 0 < C := by dsimp [C]; exact_mod_cast hchi + have hbasePos : 0 < base := by dsimp [base]; positivity + have hbaseRootPos : 0 < baseRoot := by dsimp [baseRoot]; positivity + have hbaseRootCube : baseRoot ^ 3 = base := by + simpa [baseRoot] using rpow_one_third_cube hbasePos.le + have hhRadicandPos : 0 < B ^ 2 / (A * C) := by positivity + have hkRadicandPos : 0 < A ^ 2 / (B * C) := by positivity + have hhScalePos : 0 < hScale := by dsimp [hScale]; positivity + have hkScalePos : 0 < kScale := by dsimp [kScale]; positivity + have hhScaleCube : hScale ^ 3 = B ^ 2 / (A * C) := by + simpa [hScale] using rpow_one_third_cube hhRadicandPos.le + have hkScaleCube : kScale ^ 3 = A ^ 2 / (B * C) := by + simpa [kScale] using rpow_one_third_cube hkRadicandPos.le + have hxHPos : 0 < xH := by dsimp [xH]; positivity + have hxKPos : 0 < xK := by dsimp [xK]; positivity + have hAdivKScale : A / kScale = baseRoot := by + apply (pow_left_inj₀ (by positivity) hbaseRootPos.le + (by norm_num : (3 : ℕ) ≠ 0)).mp + rw [div_pow, hkScaleCube, hbaseRootCube] + dsimp [base] + field_simp [hAPos.ne', hBPos.ne', hCPos.ne'] + have hBdivHScale : B / hScale = baseRoot := by + apply (pow_left_inj₀ (by positivity) hbaseRootPos.le + (by norm_num : (3 : ℕ) ≠ 0)).mp + rw [div_pow, hhScaleCube, hbaseRootCube] + dsimp [base] + field_simp [hAPos.ne', hBPos.ne', hCPos.ne'] + have hscaleProduct : hScale * kScale * C = baseRoot := by + apply (pow_left_inj₀ (by positivity) hbaseRootPos.le + (by norm_num : (3 : ℕ) ≠ 0)).mp + rw [mul_pow, mul_pow, hhScaleCube, hkScaleCube, hbaseRootCube] + dsimp [base] + field_simp [hAPos.ne', hBPos.ne', hCPos.ne'] + have hhPos : 0 < h := lt_of_lt_of_le hkPos hkh + have hkFloorOne : 1 ≤ ⌊xK⌋₊ := by + dsimp [k] at hkPos + omega + have hhFloorOne : 1 ≤ ⌊xH⌋₊ := by + dsimp [h] at hhPos + omega + have hkFloorUpper : ((k : ℝ) + 1) ≤ xK := by + simpa [k] using natFloor_sub_one_add_one_le hxKPos.le hkFloorOne + have hhFloorUpper : ((h : ℝ) + 1) ≤ xH := by + simpa [h] using natFloor_sub_one_add_one_le hxHPos.le hhFloorOne + have hnPos : 0 < h * k + h + k := by omega + let H : ℝ := h + let K : ℝ := k + let N : ℝ := h * k + h + k + have hKPos : 0 < K := by dsimp [K]; exact_mod_cast hkPos + have hKLeH : K ≤ H := by dsimp [K, H]; exact_mod_cast hkh + have hNPos : 0 < N := by dsimp [N]; exact_mod_cast hnPos + have hFirstCoefficient : (H + 2 * K) / N ≤ 3 / (K + 2) := by + simpa [H, K, N, Nat.cast_add, Nat.cast_mul] using + propositionTwo_first_coefficient_le hKPos hKLeH + have hSecondCoefficient : K / N ≤ 1 / (H + 2) := by + simpa [H, K, N, Nat.cast_add, Nat.cast_mul] using + propositionTwo_second_coefficient_le hKPos hKLeH + have hxKDenominator : xK ≤ K + 2 := by + simpa [K, k] using (lt_natFloor_sub_one_add_two xK).le + have hxHDenominator : xH ≤ H + 2 := by + simpa [H, h] using (lt_natFloor_sub_one_add_two xH).le + have hADiv : A / (K + 2) ≤ baseRoot / t := by + calc + A / (K + 2) ≤ A / xK := + div_le_div_of_nonneg_left hAPos.le hxKPos hxKDenominator + _ = baseRoot / t := by + dsimp [xK] + rw [show A / (t * kScale) = (A / kScale) / t by + field_simp [ht.ne', hkScalePos.ne']] + rw [hAdivKScale] + have hBDiv : B / (H + 2) ≤ baseRoot / t := by + calc + B / (H + 2) ≤ B / xH := + div_le_div_of_nonneg_left hBPos.le hxHPos hxHDenominator + _ = baseRoot / t := by + dsimp [xH] + rw [show B / (t * hScale) = (B / hScale) / t by + field_simp [ht.ne', hhScalePos.ne']] + rw [hBdivHScale] + have hFirstTerm : ((H + 2 * K) / N) * A ≤ (3 / t) * baseRoot := by + calc + ((H + 2 * K) / N) * A ≤ (3 / (K + 2)) * A := + mul_le_mul_of_nonneg_right hFirstCoefficient hAPos.le + _ = 3 * (A / (K + 2)) := by ring + _ ≤ 3 * (baseRoot / t) := + mul_le_mul_of_nonneg_left hADiv (by norm_num) + _ = (3 / t) * baseRoot := by ring + have hSecondTerm : (K / N) * B ≤ (1 / t) * baseRoot := by + calc + (K / N) * B ≤ (1 / (H + 2)) * B := + mul_le_mul_of_nonneg_right hSecondCoefficient hBPos.le + _ = B / (H + 2) := by ring + _ ≤ baseRoot / t := hBDiv + _ = (1 / t) * baseRoot := by ring + have hFloorProduct : (H + 1) * (K + 1) ≤ xH * xK := by + have hhFloorUpper' : H + 1 ≤ xH := by simpa [H] using hhFloorUpper + have hkFloorUpper' : K + 1 ≤ xK := by simpa [K] using hkFloorUpper + exact mul_le_mul hhFloorUpper' hkFloorUpper' (by positivity) (by positivity) + have hThirdNumerator : N - 1 ≤ (H + 1) * (K + 1) := by + dsimp [N, H, K] + ring_nf + norm_num + have hThirdTerm : ((N - 1) / 2) * C ≤ (t ^ 2 / 2) * baseRoot := by + calc + ((N - 1) / 2) * C ≤ (((H + 1) * (K + 1)) / 2) * C := by + gcongr + _ ≤ ((xH * xK) / 2) * C := by + gcongr + _ = (t ^ 2 / 2) * baseRoot := by + dsimp [xH, xK] + rw [← hscaleProduct] + ring + have hNumerical' : + G ≤ ((H + 2 * K) / N) * A + (K / N) * B + ((N - 1) / 2) * C := by + simpa only [H, K, N, A, B, C, Nat.cast_add, Nat.cast_mul, Nat.cast_ofNat] using hNumerical + calc + G ≤ ((H + 2 * K) / N) * A + (K / N) * B + ((N - 1) / 2) * C := + hNumerical' + _ ≤ (3 / t) * baseRoot + (1 / t) * baseRoot + + (t ^ 2 / 2) * baseRoot := + add_le_add (add_le_add hFirstTerm hSecondTerm) hThirdTerm + _ = (4 / t + t ^ 2 / 2) * baseRoot := by ring + +/-- The floor-parameter optimization in Corvaja--Zannier Theorem 4. + +The hypothesis `hPropositionTwo` is exactly the numerical alternative of +Proposition 2, supplied for every admissible pair of natural parameters. +All remaining hypotheses are elementary: positive natural degrees and Euler +characteristic, positive characteristic and real parameter, a nonnegative gcd +quantity, and its trivial upper bound by the smaller degree. -/ +theorem theoremFour_parameterizedBound_of_propositionTwo + (a b chi p : ℕ) (G t : ℝ) + (ha : 0 < a) (hab : a ≤ b) (hchi : 0 < chi) (hp : 0 < p) + (hGNonneg : 0 ≤ G) (hGTrivial : G ≤ (a : ℝ)) (ht : 0 < t) + (hPropositionTwo : PropositionTwoNumericalAlternatives a b p chi G) + (hSize : + ((a : ℝ) * (b : ℝ)) ^ 2 < + (((p : ℝ) + (a : ℝ) + (b : ℝ)) ^ 3 * (chi : ℝ)) / + (8 * t ^ 3)) : + G ≤ (4 / t + t ^ 2 / 2) * + ((a : ℝ) * (b : ℝ) * (chi : ℝ)) ^ ((1 : ℝ) / 3) := by + let A : ℝ := a + let B : ℝ := b + let C : ℝ := chi + let P : ℝ := p + let base : ℝ := A * B * C + let baseRoot : ℝ := base ^ ((1 : ℝ) / 3) + let hScale : ℝ := (B ^ 2 / (A * C)) ^ ((1 : ℝ) / 3) + let kScale : ℝ := (A ^ 2 / (B * C)) ^ ((1 : ℝ) / 3) + let xH : ℝ := t * hScale + let xK : ℝ := t * kScale + let h : ℕ := ⌊xH⌋₊ - 1 + let k : ℕ := ⌊xK⌋₊ - 1 + have hAPos : 0 < A := by dsimp [A]; exact_mod_cast ha + have hANonnegFromG : 0 ≤ A := hGNonneg.trans (by simpa [A] using hGTrivial) + have hBPos : 0 < B := by + dsimp [B] + exact_mod_cast (lt_of_lt_of_le ha hab) + have hCPos : 0 < C := by dsimp [C]; exact_mod_cast hchi + have hPPos : 0 < P := by dsimp [P]; exact_mod_cast hp + have hAB : A ≤ B := by dsimp [A, B]; exact_mod_cast hab + have hCOne : 1 ≤ C := by + dsimp [C] + exact_mod_cast (show 1 ≤ chi by omega) + have hbasePos : 0 < base := by dsimp [base]; positivity + have hbaseRootPos : 0 < baseRoot := by dsimp [baseRoot]; positivity + have hbaseRootCube : baseRoot ^ 3 = base := by + simpa [baseRoot] using rpow_one_third_cube hbasePos.le + have hhRadicandPos : 0 < B ^ 2 / (A * C) := by positivity + have hkRadicandPos : 0 < A ^ 2 / (B * C) := by positivity + have hhScalePos : 0 < hScale := by dsimp [hScale]; positivity + have hkScalePos : 0 < kScale := by dsimp [kScale]; positivity + have hhScaleCube : hScale ^ 3 = B ^ 2 / (A * C) := by + simpa [hScale] using rpow_one_third_cube hhRadicandPos.le + have hkScaleCube : kScale ^ 3 = A ^ 2 / (B * C) := by + simpa [kScale] using rpow_one_third_cube hkRadicandPos.le + have hxHPos : 0 < xH := by dsimp [xH]; positivity + have hxKPos : 0 < xK := by dsimp [xK]; positivity + have hscaledDegrees : A * hScale = B * kScale := by + apply (pow_left_inj₀ (by positivity) (by positivity) (by norm_num : (3 : ℕ) ≠ 0)).mp + rw [mul_pow, mul_pow, hhScaleCube, hkScaleCube] + field_simp [hAPos.ne', hBPos.ne', hCPos.ne'] + have hAhScaleCube : (A * hScale) ^ 3 = (A * B) ^ 2 / C := by + rw [mul_pow, hhScaleCube] + field_simp [hAPos.ne', hCPos.ne'] + have hBdivHScale : B / hScale = baseRoot := by + apply (pow_left_inj₀ (by positivity) hbaseRootPos.le + (by norm_num : (3 : ℕ) ≠ 0)).mp + rw [div_pow, hhScaleCube, hbaseRootCube] + dsimp [base] + field_simp [hAPos.ne', hBPos.ne', hCPos.ne'] + have hkScaleLeHScale : kScale ≤ hScale := by + apply le_of_pow_le_pow_left₀ (by norm_num : (3 : ℕ) ≠ 0) hhScalePos.le + rw [hkScaleCube, hhScaleCube] + apply (div_le_div_iff₀ (by positivity : 0 < B * C) + (by positivity : 0 < A * C)).2 + nlinarith [mul_nonneg (sub_nonneg.mpr hAB) + (by positivity : 0 ≤ A ^ 2 + A * B + B ^ 2)] + have hxKLeXH : xK ≤ xH := + mul_le_mul_of_nonneg_left hkScaleLeHScale ht.le + have hkh : k ≤ h := by + dsimp [h, k] + exact Nat.sub_le_sub_right (Nat.floor_mono hxKLeXH) 1 + have hSizeCross : + ((A * B) ^ 2) * (8 * t ^ 3) < (P + A + B) ^ 3 * C := by + have hdenPos : 0 < 8 * t ^ 3 := by positivity + exact (lt_div_iff₀ hdenPos).mp (by simpa [A, B, C, P] using hSize) + have hCommonCubeLt : (2 * t * (A * hScale)) ^ 3 < (P + A + B) ^ 3 := by + have hdiv : 8 * t ^ 3 * (A * B) ^ 2 / C < (P + A + B) ^ 3 := by + apply (div_lt_iff₀ hCPos).2 + nlinarith [hSizeCross] + calc + (2 * t * (A * hScale)) ^ 3 = + 8 * t ^ 3 * (A * B) ^ 2 / C := by + rw [mul_pow, mul_pow, hAhScaleCube] + norm_num + ring + _ < (P + A + B) ^ 3 := hdiv + have hCommonLt : 2 * t * (A * hScale) < P + A + B := + lt_of_pow_lt_pow_left₀ 3 (by positivity) hCommonCubeLt + by_cases hkSmall : k < 1 + · have hkZero : k = 0 := by omega + have hxKTwo : xK < 2 := by + simpa [k, hkZero] using lt_natFloor_sub_one_add_two xK + have hxKCubeLt : xK ^ 3 < (2 : ℝ) ^ 3 := + pow_lt_pow_left₀ hxKTwo hxKPos.le (by norm_num) + have htkCube : t ^ 3 * A ^ 2 / (B * C) < 8 := by + calc + t ^ 3 * A ^ 2 / (B * C) = xK ^ 3 := by + dsimp [xK] + rw [mul_pow, hkScaleCube] + ring + _ < (2 : ℝ) ^ 3 := hxKCubeLt + _ = 8 := by norm_num + have htA : t ^ 3 * A ^ 2 < 8 * (B * C) := + (div_lt_iff₀ (by positivity : 0 < B * C)).mp htkCube + have htACube : t ^ 3 * A ^ 3 < 8 * base := by + have := mul_lt_mul_of_pos_left htA hAPos + dsimp [base] + nlinarith + have hACube : A ^ 3 < 8 * base / t ^ 3 := by + apply (lt_div_iff₀ (by positivity : 0 < t ^ 3)).2 + simpa [mul_comm] using htACube + have hsmallCube : (2 / t * baseRoot) ^ 3 = 8 * base / t ^ 3 := by + rw [mul_pow, div_pow, hbaseRootCube] + norm_num + field_simp [ht.ne'] + have hASmall : A < 2 / t * baseRoot := by + have hsmallNonneg : 0 ≤ 2 / t * baseRoot := by positivity + apply lt_of_pow_lt_pow_left₀ 3 hsmallNonneg + rwa [hsmallCube] + calc + G ≤ A := by simpa [A] using hGTrivial + _ ≤ 2 / t * baseRoot := hASmall.le + _ ≤ (4 / t + t ^ 2 / 2) * baseRoot := by + apply mul_le_mul_of_nonneg_right _ hbaseRootPos.le + calc + 2 / t ≤ 4 / t := + div_le_div_of_nonneg_right (by norm_num) ht.le + _ ≤ 4 / t + t ^ 2 / 2 := le_add_of_nonneg_right (by positivity) + _ = (4 / t + t ^ 2 / 2) * + ((a : ℝ) * (b : ℝ) * (chi : ℝ)) ^ ((1 : ℝ) / 3) := by + simp [baseRoot, base, A, B, C] + · have hkPos : 0 < k := by omega + have hhPos : 0 < h := lt_of_lt_of_le hkPos hkh + have hkFloorOne : 1 ≤ ⌊xK⌋₊ := by + dsimp [k] at hkPos + omega + have hhFloorOne : 1 ≤ ⌊xH⌋₊ := by + dsimp [h] at hhPos + omega + have hkFloorUpper : ((k : ℝ) + 1) ≤ xK := by + simpa [k] using natFloor_sub_one_add_one_le hxKPos.le hkFloorOne + have hhFloorUpper : ((h : ℝ) + 1) ≤ xH := by + simpa [h] using natFloor_sub_one_add_one_le hxHPos.le hhFloorOne + have hParameterReal : A * (h : ℝ) + B * (k : ℝ) < P := by + have hhUpper : (h : ℝ) ≤ xH - 1 := by linarith + have hkUpper : (k : ℝ) ≤ xK - 1 := by linarith + have hweighted : + A * (h : ℝ) + B * (k : ℝ) ≤ + A * (xH - 1) + B * (xK - 1) := by + exact add_le_add + (mul_le_mul_of_nonneg_left hhUpper hAPos.le) + (mul_le_mul_of_nonneg_left hkUpper hBPos.le) + have hweightedIdentity : + A * (xH - 1) + B * (xK - 1) = + 2 * t * (A * hScale) - A - B := by + dsimp [xH, xK] + calc + A * (t * hScale - 1) + B * (t * kScale - 1) = + t * (A * hScale) + t * (B * kScale) - A - B := by ring + _ = 2 * t * (A * hScale) - A - B := by + rw [← hscaledDegrees] + ring + rw [hweightedIdentity] at hweighted + linarith + have hParameterNat : a * h + b * k < p := by + dsimp [A, B, P] at hParameterReal + exact_mod_cast hParameterReal + have hnPos : 0 < h * k + h + k := by omega + have hAlternative := hPropositionTwo h k ⟨hnPos, hParameterNat⟩ + rcases hAlternative with hDegrees | hNumerical + · have hbLeH : b ≤ h := hDegrees.2 + have hBLtXH : B < xH := by + have hbCast : B ≤ (h : ℝ) := by + dsimp [B] + exact_mod_cast hbLeH + calc + B ≤ (h : ℝ) := hbCast + _ < (h : ℝ) + 1 := by norm_num + _ ≤ xH := hhFloorUpper + have hrootLtT : baseRoot < t := by + rw [← hBdivHScale] + apply (div_lt_iff₀ hhScalePos).2 + simpa [xH, mul_comm] using hBLtXH + have hASqLeBase : A ^ 2 ≤ base := by + dsimp [base] + calc + A ^ 2 ≤ A * B := by + rw [pow_two] + exact mul_le_mul_of_nonneg_left hAB hAPos.le + _ = A * B * 1 := (mul_one _).symm + _ ≤ A * B * C := mul_le_mul_of_nonneg_left hCOne (by positivity) + have hASqLeRootCube : A ^ 2 ≤ baseRoot ^ 3 := + hASqLeBase.trans_eq hbaseRootCube.symm + have hADegreeBound : + A ≤ (4 / t + t ^ 2 / 2) * baseRoot := + degree_le_theoremFour_bound_of_sq_le_cube (degree := A) (root := baseRoot) (t := t) + hANonnegFromG hbaseRootPos.le ht hASqLeRootCube hrootLtT.le + calc + G ≤ A := by change G ≤ (a : ℝ); exact hGTrivial + _ ≤ (4 / t + t ^ 2 / 2) * baseRoot := hADegreeBound + _ = (4 / t + t ^ 2 / 2) * + ((a : ℝ) * (b : ℝ) * (chi : ℝ)) ^ ((1 : ℝ) / 3) := by + rfl + · exact propositionTwo_numerical_bound ha (lt_of_lt_of_le ha hab) hchi ht + hkPos hkh hNumerical + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/PerfectConstants.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/PerfectConstants.lean new file mode 100644 index 0000000000..a791f464f9 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/PerfectConstants.lean @@ -0,0 +1,57 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FrobeniusSubfield +public import Mathlib.FieldTheory.Perfect + +/-! +# Perfect constants inside the Frobenius subfield + +The Section 5 specialization of Corvaja--Zannier works over a perfect +constant field. Consequently every constant, after embedding in the curve +function field, is a `p`-th power and belongs to the Frobenius subfield. +This file records that compatibility without identifying the two fields. +-/ + +@[expose] public section + +namespace BGS.CorvajaZannier + +noncomputable section + +variable {K L : Type*} [Field K] [Field L] {p : ℕ} + [Fact p.Prime] [CharP K p] [CharP L p] [PerfectField K] [Algebra K L] + +/-- Constants from a perfect field land in the Frobenius subfield of every +field extension of the same prime characteristic. -/ +theorem algebraMap_mem_frobeniusSubfield (c : K) : + algebraMap K L c ∈ frobeniusSubfield L p := by + refine ⟨algebraMap K L ((frobeniusEquiv K p).symm c), ?_⟩ + simp only [frobenius_def] + rw [← map_pow, frobeniusEquiv_symm_pow_p] + +/-- The constant-field embedding, with codomain restricted to the Frobenius +subfield. -/ +def perfectConstantsToFrobeniusSubfield : K →+* frobeniusSubfield L p := + (algebraMap K L).codRestrict (frobeniusSubfield L p) + (fun c ↦ algebraMap_mem_frobeniusSubfield c) + +@[simp] +theorem coe_perfectConstantsToFrobeniusSubfield (c : K) : + ((perfectConstantsToFrobeniusSubfield (K := K) (L := L) (p := p) c : + frobeniusSubfield L p) : L) = algebraMap K L c := + rfl + +theorem perfectConstantsToFrobeniusSubfield_injective : + Function.Injective + (perfectConstantsToFrobeniusSubfield (K := K) (L := L) (p := p)) := + (perfectConstantsToFrobeniusSubfield (K := K) (L := L) (p := p)).injective + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurveAuxiliaryFinitePlace.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurveAuxiliaryFinitePlace.lean new file mode 100644 index 0000000000..24507788e6 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurveAuxiliaryFinitePlace.lean @@ -0,0 +1,597 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.DedekindAuxiliaryLocalCases +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.DedekindLocalDerivationExtension +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.DedekindLocalizationOrder +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveLocalReciprocalDiscriminant +public import Mathlib.NumberTheory.FunctionField + +/-! +# Auxiliary Wronskian bounds at finite plane-curve places + +This file connects the uniformizer-free local Corvaja--Zannier estimates to +the actual finite primes of the integral closure in a finite extension of +`K(X)`. The constants used for the local derivation-extension step are the +ground field `K`; the Wronskian derivation may subsequently be obtained by +restricting scalars from the Frobenius constant field. Thus no algebra map +from the Frobenius constant field to a nontrivial DVR is required. +-/ + +@[expose] public section + +open scoped nonZeroDivisors Polynomial BigOperators +open IsDedekindDomain + +namespace BGS.CorvajaZannier + +noncomputable section + +attribute [local instance] FractionRing.liftAlgebra + FractionRing.isScalarTower_liftAlgebra + +/-! ## The unramified local-preservation bridge -/ + +/-- Outside the different, the ambient derivation preserves the selected +extension DVR. This is the existential-preservation form consumed by the +uniformizer-free Wronskian estimates. In the plane-curve application `C` is +the ground field `K` (after restricting scalars from `L^p`), so all local +algebra structures here are genuine; no map `L^p → B_Q` is requested. -/ +theorem dedekindLocal_ambientDerivation_preserves_of_not_dvd_different + {A B C U : Type*} + [CommRing A] [CommRing B] [CommRing C] [CommRing U] + [IsDedekindDomain A] [IsDedekindDomain B] + [Algebra A B] [Module.IsTorsionFree A B] [Module.Finite A B] + [Algebra.IsSeparable (FractionRing A) (FractionRing B)] + (p : Ideal A) (Q : Ideal B) [p.IsPrime] [Q.IsPrime] [Q.LiesOver p] + [Algebra (Localization.AtPrime p) (Localization.AtPrime Q)] + [IsScalarTower A (Localization.AtPrime p) (Localization.AtPrime Q)] + [Algebra C (Localization.AtPrime p)] + [Algebra C (Localization.AtPrime Q)] + [Algebra C U] + [Algebra (Localization.AtPrime p) U] + [Algebra (Localization.AtPrime Q) U] + [IsScalarTower C (Localization.AtPrime p) (Localization.AtPrime Q)] + [IsScalarTower C (Localization.AtPrime p) U] + [IsScalarTower C (Localization.AtPrime Q) U] + [IsScalarTower (Localization.AtPrime p) (Localization.AtPrime Q) U] + (hQ : ¬ Q ∣ differentIdeal A B) + (D : Derivation C (Localization.AtPrime p) (Localization.AtPrime p)) + (E : Derivation C U U) + (hE : ∀ s : Localization.AtPrime p, + E (algebraMap (Localization.AtPrime p) U s) = + algebraMap (Localization.AtPrime p) U (D s)) : + ∀ t : Localization.AtPrime Q, ∃ t' : Localization.AtPrime Q, + E (algebraMap (Localization.AtPrime Q) U t) = + algebraMap (Localization.AtPrime Q) U t' := by + obtain ⟨D', _hD', hpres⟩ := + dedekindLocal_derivation_preserves_of_not_dvd_different + p Q hQ D E hE + intro t + exact ⟨D' t, hpres t⟩ + +variable (K : Type*) [Field K] [DecidableEq K] [DecidableEq (RatFunc K)] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +local instance (priority := 10) auxiliaryFinitePlacePolynomialAlgebra : + Algebra K[X] L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K[X] (RatFunc K))) + +local instance auxiliaryFinitePlacePolynomialScalarTower : + IsScalarTower K[X] (RatFunc K) L := + .of_algebraMap_eq' rfl + +local instance auxiliaryFinitePlaceFiniteIntegralClosureIsIntegral : + Algebra.IsIntegral K[X] (FunctionField.ringOfIntegers K L) := + IsIntegralClosure.isIntegral_algebra K[X] L + +local instance auxiliaryFinitePlaceFiniteIntegralClosureModuleFinite : + Module.Finite K[X] (FunctionField.ringOfIntegers K L) := + Module.IsNoetherian.finite K[X] (FunctionField.ringOfIntegers K L) + +local instance auxiliaryFinitePlacePolynomialTorsionFreeTop : + Module.IsTorsionFree K[X] L := + Module.IsTorsionFree.trans_faithfulSMul K[X] (RatFunc K) L + +local instance auxiliaryFinitePlaceFiniteIntegralClosureIsTorsionFree : + Module.IsTorsionFree K[X] (FunctionField.ringOfIntegers K L) := + IsIntegralClosure.isTorsionFree K[X] L + +local instance auxiliaryFinitePlaceFiniteIntegralClosureIsDedekindDomain : + IsDedekindDomain (FunctionField.ringOfIntegers K L) := + IsIntegralClosure.isDedekindDomain K[X] (RatFunc K) L + (FunctionField.ringOfIntegers K L) + +/-- The actual finite places of `L / K(X)`, before adjoining the places over +infinity. This is definitionally the finite summand used by the exhaustive +place infrastructure. -/ +abbrev PlaneCurveExtensionFinitePlace := + HeightOneSpectrum (FunctionField.ringOfIntegers K L) + +abbrev FiniteExtensionFinitePlaceBaseLocalRing + (q : PlaneCurveExtensionFinitePlace K L) := + Localization.AtPrime (HeightOneSpectrum.under K[X] q).asIdeal + +abbrev FiniteExtensionFinitePlaceLocalRing + (q : PlaneCurveExtensionFinitePlace K L) := + Localization.AtPrime q.asIdeal + +section LocalOrder + +variable {K L} + +/-- Canonical inclusion of the localization at an actual finite extension +place into the ambient function field. -/ +noncomputable def finiteExtensionFinitePlaceLocalizationToField + (q : PlaneCurveExtensionFinitePlace K L) : + FiniteExtensionFinitePlaceLocalRing K L q →+* L := + IsLocalization.lift + (S := FiniteExtensionFinitePlaceLocalRing K L q) + (M := q.asIdeal.primeCompl) + (g := algebraMap (FunctionField.ringOfIntegers K L) L) fun y => + IsLocalization.map_units L + ⟨y.1, q.asIdeal.primeCompl_le_nonZeroDivisors y.2⟩ + +omit [DecidableEq K] [DecidableEq (RatFunc K)] + [Algebra.IsSeparable (RatFunc K) L] in +@[simp] theorem finiteExtensionFinitePlaceLocalizationToField_comp_algebraMap + (q : PlaneCurveExtensionFinitePlace K L) : + (finiteExtensionFinitePlaceLocalizationToField (K := K) (L := L) q).comp + (algebraMap (FunctionField.ringOfIntegers K L) + (FiniteExtensionFinitePlaceLocalRing K L q)) = + algebraMap (FunctionField.ringOfIntegers K L) L := by + exact IsLocalization.lift_comp _ + +/-- The canonical algebra structure on the ambient function field from the +localized finite-place DVR. -/ +@[reducible] noncomputable def finiteExtensionFinitePlaceLocalAlgebra + (q : PlaneCurveExtensionFinitePlace K L) : + Algebra (FiniteExtensionFinitePlaceLocalRing K L q) L := + (finiteExtensionFinitePlaceLocalizationToField (K := K) (L := L) q).toAlgebra + +omit [DecidableEq K] [DecidableEq (RatFunc K)] + [Algebra.IsSeparable (RatFunc K) L] in +/-- The ambient function field is the fraction field of every finite-place +localization. -/ +theorem finiteExtensionFinitePlaceLocalIsFractionRing + (q : PlaneCurveExtensionFinitePlace K L) : + letI := finiteExtensionFinitePlaceLocalAlgebra (K := K) (L := L) q + IsFractionRing (FiniteExtensionFinitePlaceLocalRing K L q) L := by + let := finiteExtensionFinitePlaceLocalAlgebra (K := K) (L := L) q + let : IsScalarTower (FunctionField.ringOfIntegers K L) + (FiniteExtensionFinitePlaceLocalRing K L q) L := by + apply IsScalarTower.of_algebraMap_eq' + exact (finiteExtensionFinitePlaceLocalizationToField_comp_algebraMap + (K := K) (L := L) q).symm + exact IsFractionRing.isFractionRing_of_isDomain_of_isLocalization + q.asIdeal.primeCompl (FiniteExtensionFinitePlaceLocalRing K L q) L + +/-- The normalized order on the localization at an actual finite place of +`L / K(X)`. Keeping this definition attached to `q` avoids introducing a +spurious algebra structure from the Frobenius constant field to the DVR. -/ +noncomputable def finiteExtensionFinitePlaceLocalOrderTop + (q : PlaneCurveExtensionFinitePlace K L) + (x : L) : WithTop ℤ := by + letI := finiteExtensionFinitePlaceLocalAlgebra (K := K) (L := L) q + letI := finiteExtensionFinitePlaceLocalIsFractionRing (K := K) (L := L) q + letI : IsDiscreteValuationRing + (FiniteExtensionFinitePlaceLocalRing K L q) := + IsLocalization.AtPrime.isDiscreteValuationRing_of_dedekind_domain + (FunctionField.ringOfIntegers K L) q.ne_bot + (FiniteExtensionFinitePlaceLocalRing K L q) + exact finitePlaceOrderTop + (IsDiscreteValuationRing.maximalIdeal + (FiniteExtensionFinitePlaceLocalRing K L q)) x + +/-- Integer-valued form of the localized order. -/ +noncomputable def finiteExtensionFinitePlaceLocalOrder + (q : PlaneCurveExtensionFinitePlace K L) + (x : L) : ℤ := by + letI := finiteExtensionFinitePlaceLocalAlgebra (K := K) (L := L) q + letI := finiteExtensionFinitePlaceLocalIsFractionRing (K := K) (L := L) q + letI : IsDiscreteValuationRing + (FiniteExtensionFinitePlaceLocalRing K L q) := + IsLocalization.AtPrime.isDiscreteValuationRing_of_dedekind_domain + (FunctionField.ringOfIntegers K L) q.ne_bot + (FiniteExtensionFinitePlaceLocalRing K L q) + exact finitePlaceOrder + (IsDiscreteValuationRing.maximalIdeal + (FiniteExtensionFinitePlaceLocalRing K L q)) x + +omit [DecidableEq K] [DecidableEq (RatFunc K)] in +/-- The order used by the actual localized DVR bound is exactly the global +height-one order of the same finite place. -/ +theorem finiteExtensionFinitePlaceLocalOrder_eq_globalOrder + (q : PlaneCurveExtensionFinitePlace K L) (x : L) : + finiteExtensionFinitePlaceLocalOrder (K := K) (L := L) q x = + finitePlaceOrder q x := by + let := finiteExtensionFinitePlaceLocalAlgebra (K := K) (L := L) q + let := finiteExtensionFinitePlaceLocalIsFractionRing (K := K) (L := L) q + let : IsDiscreteValuationRing + (FiniteExtensionFinitePlaceLocalRing K L q) := + IsLocalization.AtPrime.isDiscreteValuationRing_of_dedekind_domain + (FunctionField.ringOfIntegers K L) q.ne_bot + (FiniteExtensionFinitePlaceLocalRing K L q) + let : IsScalarTower (FunctionField.ringOfIntegers K L) + (FiniteExtensionFinitePlaceLocalRing K L q) L := by + apply IsScalarTower.of_algebraMap_eq' + exact (finiteExtensionFinitePlaceLocalizationToField_comp_algebraMap + (K := K) (L := L) q).symm + change finitePlaceOrder + (IsDiscreteValuationRing.maximalIdeal + (FiniteExtensionFinitePlaceLocalRing K L q)) x = _ + exact localizationAtPrime_finitePlaceOrder_eq q x + +omit [DecidableEq K] [DecidableEq (RatFunc K)] in +/-- Nonzero localized `WithTop` orders are the corresponding global +height-one orders. -/ +theorem finiteExtensionFinitePlaceLocalOrderTop_eq_globalOrder + (q : PlaneCurveExtensionFinitePlace K L) (x : L) (hx : x ≠ 0) : + finiteExtensionFinitePlaceLocalOrderTop (K := K) (L := L) q x = + (finitePlaceOrder q x : WithTop ℤ) := by + let := finiteExtensionFinitePlaceLocalAlgebra (K := K) (L := L) q + let := finiteExtensionFinitePlaceLocalIsFractionRing (K := K) (L := L) q + let : IsDiscreteValuationRing + (FiniteExtensionFinitePlaceLocalRing K L q) := + IsLocalization.AtPrime.isDiscreteValuationRing_of_dedekind_domain + (FunctionField.ringOfIntegers K L) q.ne_bot + (FiniteExtensionFinitePlaceLocalRing K L q) + simp only [finiteExtensionFinitePlaceLocalOrderTop] + rw [finitePlaceOrderTop_eq_coe _ _ hx] + exact_mod_cast + finiteExtensionFinitePlaceLocalOrder_eq_globalOrder + (K := K) (L := L) q x + +omit [DecidableEq K] [DecidableEq (RatFunc K)] in +@[simp] theorem finiteExtensionFinitePlaceLocalOrderTop_mul + (q : PlaneCurveExtensionFinitePlace K L) (x y : L) : + finiteExtensionFinitePlaceLocalOrderTop (K := K) (L := L) q (x * y) = + finiteExtensionFinitePlaceLocalOrderTop (K := K) (L := L) q x + + finiteExtensionFinitePlaceLocalOrderTop (K := K) (L := L) q y := by + simp only [finiteExtensionFinitePlaceLocalOrderTop, + finitePlaceOrderTop_mul] + +omit [DecidableEq K] [DecidableEq (RatFunc K)] in +@[simp] theorem finiteExtensionFinitePlaceLocalOrderTop_pow + (q : PlaneCurveExtensionFinitePlace K L) (x : L) (n : ℕ) : + finiteExtensionFinitePlaceLocalOrderTop (K := K) (L := L) q (x ^ n) = + n • finiteExtensionFinitePlaceLocalOrderTop (K := K) (L := L) q x := by + simp only [finiteExtensionFinitePlaceLocalOrderTop, + finitePlaceOrderTop_pow] + +variable {C : Type*} [Field C] [Algebra C L] + +omit [DecidableEq K] [DecidableEq (RatFunc K)] in +/-- Source case (iii), now indexed by an actual finite place of the integral +closure. The sole local hypothesis says that the derivation preserves the +localized DVR; it does not ask for an algebra map `C → R_q`. -/ +theorem finiteExtensionFinitePlace_auxiliaryFamily_caseIII_source_lower_bound_of_preserves + (q : PlaneCurveExtensionFinitePlace K L) + (D : Derivation C L L) + (hDIntegral : ∀ r : FiniteExtensionFinitePlaceLocalRing K L q, + ∃ s : FiniteExtensionFinitePlaceLocalRing K L q, + D (finiteExtensionFinitePlaceLocalizationToField + (K := K) (L := L) q r) = + finiteExtensionFinitePlaceLocalizationToField + (K := K) (L := L) q s) + (h k : ℕ) (epsilon : Sum (Fin k) (Fin (k + 1) × Fin h) → ℕ) + (u v : L) (hu : u ≠ 0) (hv : v ≠ 0) + (hu1 : u ≠ 1) (hv1 : v ≠ 1) : + (((k * (k - 1) / 2 : ℕ) • + finiteExtensionFinitePlaceLocalOrder (K := K) (L := L) q u + + (h * k) • finiteExtensionFinitePlaceLocalOrder (K := K) (L := L) q v + + k • finiteExtensionFinitePlaceLocalOrder (K := K) (L := L) q + ((1 - u) / (1 - v)) + + ∑ rs : Fin (k + 1) × Fin h, + finiteExtensionFinitePlaceLocalOrder (K := K) (L := L) q + (u ^ (rs.1 : ℕ) * v ^ (rs.2 : ℕ)) - + ∑ i, (epsilon i : ℤ) : ℤ) : WithTop ℤ) ≤ + finiteExtensionFinitePlaceLocalOrderTop (K := K) (L := L) q + (indexedDedekindLocalWronskian D epsilon + (auxiliaryFamily u v h k)).det := by + let := finiteExtensionFinitePlaceLocalAlgebra (K := K) (L := L) q + let := finiteExtensionFinitePlaceLocalIsFractionRing (K := K) (L := L) q + let : IsDiscreteValuationRing + (FiniteExtensionFinitePlaceLocalRing K L q) := + IsLocalization.AtPrime.isDiscreteValuationRing_of_dedekind_domain + (FunctionField.ringOfIntegers K L) q.ne_bot + (FiniteExtensionFinitePlaceLocalRing K L q) + have hDIntegral' : ∀ r : FiniteExtensionFinitePlaceLocalRing K L q, + ∃ s : FiniteExtensionFinitePlaceLocalRing K L q, + D (algebraMap (FiniteExtensionFinitePlaceLocalRing K L q) L r) = + algebraMap (FiniteExtensionFinitePlaceLocalRing K L q) L s := by + intro r + obtain ⟨s, hs⟩ := hDIntegral r + exact ⟨s, hs⟩ + exact finitePlaceOrderTop_auxiliaryFamily_caseIII_source_lower_bound_of_preserves + (IsDiscreteValuationRing.maximalIdeal + (FiniteExtensionFinitePlaceLocalRing K L q)) + D hDIntegral' h k epsilon u v hu hv hu1 hv1 + +omit [DecidableEq K] [DecidableEq (RatFunc K)] in +/-- Source case (iv), indexed by an actual finite place of the integral +closure and requiring only preservation of its localized DVR. -/ +theorem finiteExtensionFinitePlace_auxiliaryFamily_caseIV_source_lower_bound_of_preserves + (q : PlaneCurveExtensionFinitePlace K L) + (D : Derivation C L L) + (hDIntegral : ∀ r : FiniteExtensionFinitePlaceLocalRing K L q, + ∃ s : FiniteExtensionFinitePlaceLocalRing K L q, + D (finiteExtensionFinitePlaceLocalizationToField + (K := K) (L := L) q r) = + finiteExtensionFinitePlaceLocalizationToField + (K := K) (L := L) q s) + (h k : ℕ) (epsilon : Sum (Fin k) (Fin (k + 1) × Fin h) → ℕ) + (u v : L) (hu : u ≠ 0) (hv : v ≠ 0) + (hu1 : u ≠ 1) (hv1 : v ≠ 1) : + (((k * (k - 1) / 2 : ℕ) • + finiteExtensionFinitePlaceLocalOrder (K := K) (L := L) q u + + k • finiteExtensionFinitePlaceLocalOrder (K := K) (L := L) q + ((1 - u) / (1 - v)) + + ∑ rs : Fin (k + 1) × Fin h, + finiteExtensionFinitePlaceLocalOrder (K := K) (L := L) q + (u ^ (rs.1 : ℕ) * v ^ (rs.2 : ℕ)) - + ∑ i, (epsilon i : ℤ) : ℤ) : WithTop ℤ) ≤ + finiteExtensionFinitePlaceLocalOrderTop (K := K) (L := L) q + (indexedDedekindLocalWronskian D epsilon + (auxiliaryFamily u v h k)).det := by + let := finiteExtensionFinitePlaceLocalAlgebra (K := K) (L := L) q + let := finiteExtensionFinitePlaceLocalIsFractionRing (K := K) (L := L) q + let : IsDiscreteValuationRing + (FiniteExtensionFinitePlaceLocalRing K L q) := + IsLocalization.AtPrime.isDiscreteValuationRing_of_dedekind_domain + (FunctionField.ringOfIntegers K L) q.ne_bot + (FiniteExtensionFinitePlaceLocalRing K L q) + have hDIntegral' : ∀ r : FiniteExtensionFinitePlaceLocalRing K L q, + ∃ s : FiniteExtensionFinitePlaceLocalRing K L q, + D (algebraMap (FiniteExtensionFinitePlaceLocalRing K L q) L r) = + algebraMap (FiniteExtensionFinitePlaceLocalRing K L q) L s := by + intro r + obtain ⟨s, hs⟩ := hDIntegral r + exact ⟨s, hs⟩ + exact finitePlaceOrderTop_auxiliaryFamily_caseIV_source_lower_bound_of_preserves + (IsDiscreteValuationRing.maximalIdeal + (FiniteExtensionFinitePlaceLocalRing K L q)) + D hDIntegral' h k epsilon u v hu hv hu1 hv1 + +omit [DecidableEq K] [DecidableEq (RatFunc K)] in +/-- Source case (iii) for a global derivation after multiplying it by the +local correction factor `c`. The displayed right side has been transported +back to the original global Wronskian and records the exact triangular +correction `choose(n,2) * ord_q(c)`. -/ +theorem finiteExtensionFinitePlace_auxiliaryFamily_caseIII_source_lower_bound_of_scaled_preserves + (q : PlaneCurveExtensionFinitePlace K L) + (h k : ℕ) + {n : ℕ} (e : Sum (Fin k) (Fin (k + 1) × Fin h) ≃ Fin n) + (epsilon : Sum (Fin k) (Fin (k + 1) × Fin h) → ℕ) + (hepsilon : ∀ i, epsilon i = (e i : ℕ)) + (D : Derivation C L L) (c : L) + (hScaledIntegral : + ∀ r : FiniteExtensionFinitePlaceLocalRing K L q, + ∃ s : FiniteExtensionFinitePlaceLocalRing K L q, + (c • D) (finiteExtensionFinitePlaceLocalizationToField + (K := K) (L := L) q r) = + finiteExtensionFinitePlaceLocalizationToField + (K := K) (L := L) q s) + (u v : L) (hu : u ≠ 0) (hv : v ≠ 0) + (hu1 : u ≠ 1) (hv1 : v ≠ 1) : + (((k * (k - 1) / 2 : ℕ) • + finiteExtensionFinitePlaceLocalOrder (K := K) (L := L) q u + + (h * k) • finiteExtensionFinitePlaceLocalOrder (K := K) (L := L) q v + + k • finiteExtensionFinitePlaceLocalOrder (K := K) (L := L) q + ((1 - u) / (1 - v)) + + ∑ rs : Fin (k + 1) × Fin h, + finiteExtensionFinitePlaceLocalOrder (K := K) (L := L) q + (u ^ (rs.1 : ℕ) * v ^ (rs.2 : ℕ)) - + ∑ i, (epsilon i : ℤ) : ℤ) : WithTop ℤ) ≤ + n.choose 2 • + finiteExtensionFinitePlaceLocalOrderTop (K := K) (L := L) q c + + finiteExtensionFinitePlaceLocalOrderTop (K := K) (L := L) q + (indexedDedekindLocalWronskian D epsilon + (auxiliaryFamily u v h k)).det := by + have hbound := + finiteExtensionFinitePlace_auxiliaryFamily_caseIII_source_lower_bound_of_preserves + (K := K) (L := L) q (c • D) hScaledIntegral + h k epsilon u v hu hv hu1 hv1 + have hchange := indexedDedekindLocalWronskian_det_changeParameter + e epsilon hepsilon (c • D) D c rfl (auxiliaryFamily u v h k) + rw [hchange, finiteExtensionFinitePlaceLocalOrderTop_mul, + finiteExtensionFinitePlaceLocalOrderTop_pow] at hbound + exact hbound + +omit [DecidableEq K] [DecidableEq (RatFunc K)] in +/-- Source case (iv) with the same exact local correction term. -/ +theorem finiteExtensionFinitePlace_auxiliaryFamily_caseIV_source_lower_bound_of_scaled_preserves + (q : PlaneCurveExtensionFinitePlace K L) + (h k : ℕ) + {n : ℕ} (e : Sum (Fin k) (Fin (k + 1) × Fin h) ≃ Fin n) + (epsilon : Sum (Fin k) (Fin (k + 1) × Fin h) → ℕ) + (hepsilon : ∀ i, epsilon i = (e i : ℕ)) + (D : Derivation C L L) (c : L) + (hScaledIntegral : + ∀ r : FiniteExtensionFinitePlaceLocalRing K L q, + ∃ s : FiniteExtensionFinitePlaceLocalRing K L q, + (c • D) (finiteExtensionFinitePlaceLocalizationToField + (K := K) (L := L) q r) = + finiteExtensionFinitePlaceLocalizationToField + (K := K) (L := L) q s) + (u v : L) (hu : u ≠ 0) (hv : v ≠ 0) + (hu1 : u ≠ 1) (hv1 : v ≠ 1) : + (((k * (k - 1) / 2 : ℕ) • + finiteExtensionFinitePlaceLocalOrder (K := K) (L := L) q u + + k • finiteExtensionFinitePlaceLocalOrder (K := K) (L := L) q + ((1 - u) / (1 - v)) + + ∑ rs : Fin (k + 1) × Fin h, + finiteExtensionFinitePlaceLocalOrder (K := K) (L := L) q + (u ^ (rs.1 : ℕ) * v ^ (rs.2 : ℕ)) - + ∑ i, (epsilon i : ℤ) : ℤ) : WithTop ℤ) ≤ + n.choose 2 • + finiteExtensionFinitePlaceLocalOrderTop (K := K) (L := L) q c + + finiteExtensionFinitePlaceLocalOrderTop (K := K) (L := L) q + (indexedDedekindLocalWronskian D epsilon + (auxiliaryFamily u v h k)).det := by + have hbound := + finiteExtensionFinitePlace_auxiliaryFamily_caseIV_source_lower_bound_of_preserves + (K := K) (L := L) q (c • D) hScaledIntegral + h k epsilon u v hu hv hu1 hv1 + have hchange := indexedDedekindLocalWronskian_det_changeParameter + e epsilon hepsilon (c • D) D c rfl (auxiliaryFamily u v h k) + rw [hchange, finiteExtensionFinitePlaceLocalOrderTop_mul, + finiteExtensionFinitePlaceLocalOrderTop_pow] at hbound + exact hbound + +section RestrictConstants + +variable [Algebra K C] [Algebra K L] [IsScalarTower K C L] + +omit [DecidableEq K] [DecidableEq (RatFunc K)] in +/-- Case (iii) for a derivation over a larger constant field (in the +application, `C = L^p`). The proof restricts scalars to `K` before invoking +the local DVR theorem, while the displayed Wronskian is still the original +`C`-derivation Wronskian because restriction does not change its function. -/ +theorem + finiteExtensionFinitePlace_auxiliaryFamily_caseIII_source_lower_bound_of_restrictScalars_preserves + (q : PlaneCurveExtensionFinitePlace K L) + (D : Derivation C L L) + (hDIntegral : ∀ r : FiniteExtensionFinitePlaceLocalRing K L q, + ∃ s : FiniteExtensionFinitePlaceLocalRing K L q, + D (finiteExtensionFinitePlaceLocalizationToField + (K := K) (L := L) q r) = + finiteExtensionFinitePlaceLocalizationToField + (K := K) (L := L) q s) + (h k : ℕ) (epsilon : Sum (Fin k) (Fin (k + 1) × Fin h) → ℕ) + (u v : L) (hu : u ≠ 0) (hv : v ≠ 0) + (hu1 : u ≠ 1) (hv1 : v ≠ 1) : + (((k * (k - 1) / 2 : ℕ) • + finiteExtensionFinitePlaceLocalOrder (K := K) (L := L) q u + + (h * k) • finiteExtensionFinitePlaceLocalOrder (K := K) (L := L) q v + + k • finiteExtensionFinitePlaceLocalOrder (K := K) (L := L) q + ((1 - u) / (1 - v)) + + ∑ rs : Fin (k + 1) × Fin h, + finiteExtensionFinitePlaceLocalOrder (K := K) (L := L) q + (u ^ (rs.1 : ℕ) * v ^ (rs.2 : ℕ)) - + ∑ i, (epsilon i : ℤ) : ℤ) : WithTop ℤ) ≤ + finiteExtensionFinitePlaceLocalOrderTop (K := K) (L := L) q + (indexedDedekindLocalWronskian D epsilon + (auxiliaryFamily u v h k)).det := by + have hbound := + finiteExtensionFinitePlace_auxiliaryFamily_caseIII_source_lower_bound_of_preserves + (K := K) (L := L) q (D.restrictScalars K) hDIntegral + h k epsilon u v hu hv hu1 hv1 + have hmatrix : + indexedDedekindLocalWronskian (D.restrictScalars K) epsilon + (auxiliaryFamily u v h k) = + indexedDedekindLocalWronskian D epsilon + (auxiliaryFamily u v h k) := by + ext i j + rfl + rw [hmatrix] at hbound + exact hbound + +omit [DecidableEq K] [DecidableEq (RatFunc K)] in +/-- Case (iv) after the same honest restriction of constants from `C` to +the ground field `K`. -/ +theorem + finiteExtensionFinitePlace_auxiliaryFamily_caseIV_source_lower_bound_of_restrictScalars_preserves + (q : PlaneCurveExtensionFinitePlace K L) + (D : Derivation C L L) + (hDIntegral : ∀ r : FiniteExtensionFinitePlaceLocalRing K L q, + ∃ s : FiniteExtensionFinitePlaceLocalRing K L q, + D (finiteExtensionFinitePlaceLocalizationToField + (K := K) (L := L) q r) = + finiteExtensionFinitePlaceLocalizationToField + (K := K) (L := L) q s) + (h k : ℕ) (epsilon : Sum (Fin k) (Fin (k + 1) × Fin h) → ℕ) + (u v : L) (hu : u ≠ 0) (hv : v ≠ 0) + (hu1 : u ≠ 1) (hv1 : v ≠ 1) : + (((k * (k - 1) / 2 : ℕ) • + finiteExtensionFinitePlaceLocalOrder (K := K) (L := L) q u + + k • finiteExtensionFinitePlaceLocalOrder (K := K) (L := L) q + ((1 - u) / (1 - v)) + + ∑ rs : Fin (k + 1) × Fin h, + finiteExtensionFinitePlaceLocalOrder (K := K) (L := L) q + (u ^ (rs.1 : ℕ) * v ^ (rs.2 : ℕ)) - + ∑ i, (epsilon i : ℤ) : ℤ) : WithTop ℤ) ≤ + finiteExtensionFinitePlaceLocalOrderTop (K := K) (L := L) q + (indexedDedekindLocalWronskian D epsilon + (auxiliaryFamily u v h k)).det := by + have hbound := + finiteExtensionFinitePlace_auxiliaryFamily_caseIV_source_lower_bound_of_preserves + (K := K) (L := L) q (D.restrictScalars K) hDIntegral + h k epsilon u v hu hv hu1 hv1 + have hmatrix : + indexedDedekindLocalWronskian (D.restrictScalars K) epsilon + (auxiliaryFamily u v h k) = + indexedDedekindLocalWronskian D epsilon + (auxiliaryFamily u v h k) := by + ext i j + rfl + rw [hmatrix] at hbound + exact hbound + +end RestrictConstants + +end LocalOrder + +/-! ## Plane-curve reciprocal normalization at a selected extension place -/ + +section PlaneCurve + +variable {K : Type*} [Field K] [Fintype K] [DecidableEq K] + [DecidableEq (RatFunc K)] + +omit [DecidableEq K] [DecidableEq (RatFunc K)] in +/-- The reciprocal minimal-polynomial normalization, with the base prime +selected as the prime lying below an actual finite place of the plane-curve +function field. This is the local primitive-element/different certificate +paired with the Wronskian estimates above. -/ +theorem planeCurve_minpoly_reciprocal_local_normalization_at_finiteExtensionPlace + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (hcardK : MvPolynomial.degreeOf 1 f < Fintype.card K) : + letI := planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + letI := planeCurveFirstCoordinateRatFuncAlgebra f hx + letI := finiteDimensional_planeCurveFunctionField_over_ratFunc + hf hpartialSecond + letI := separable_planeCurveFunctionField_over_ratFunc + hf hpartialSecond + ∀ q : PlaneCurveExtensionFinitePlace K (PlaneCurveFunctionField f), + let p := HeightOneSpectrum.under K[X] q + let A := Localization.AtPrime p.asIdeal + let ι := localizationAtPrimeToRatFunc p + ∃ (a : Polynomial K) (u : Aˣ), + let c := algebraMap (Polynomial K) A a + let G := (planeCurvePolynomialInSecondCoordinate f).map + (algebraMap (Polynomial K) A) + minpoly (RatFunc K) + ((planeCurveFunction f 1 - + algebraMap (RatFunc K) (PlaneCurveFunctionField f) (ι c))⁻¹) = + (unitNormalizedReciprocalTranslate G c u).map ι := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let : Algebra (RatFunc K) (PlaneCurveFunctionField f) := + planeCurveFirstCoordinateRatFuncAlgebra f hx + let : FiniteDimensional (RatFunc K) (PlaneCurveFunctionField f) := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : Algebra.IsSeparable (RatFunc K) (PlaneCurveFunctionField f) := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + exact fun q => + planeCurve_minpoly_reciprocal_local_normalization_of_degreeOf_second_lt_fintypeCard + hf hpartialSecond hcardK (HeightOneSpectrum.under K[X] q) + +end PlaneCurve + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurveAuxiliaryFinitePlaceCases.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurveAuxiliaryFinitePlaceCases.lean new file mode 100644 index 0000000000..c3e35c96e9 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurveAuxiliaryFinitePlaceCases.lean @@ -0,0 +1,352 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveAuxiliaryFinitePlace +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.DedekindPerfectResidueCaseI +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.RatFuncExhaustiveProductFormula + +/-! +# Cases I and II at actual finite extension places + +This file supplies the regular-element lifting, finite/perfect residue-field +bridge, and scaled-derivation forms of the first two local +Corvaja--Zannier Wronskian estimates. +-/ + +@[expose] public section + +open scoped nonZeroDivisors Polynomial BigOperators +open IsDedekindDomain + +namespace BGS.CorvajaZannier + +noncomputable section + +variable (K : Type*) [Field K] [DecidableEq K] [DecidableEq (RatFunc K)] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +local instance (priority := 10) tempPolynomialAlgebra : Algebra K[X] L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K[X] (RatFunc K))) + +local instance tempPolynomialScalarTower : + IsScalarTower K[X] (RatFunc K) L := .of_algebraMap_eq' rfl + +local instance tempFiniteIntegralClosureIsIntegral : + Algebra.IsIntegral K[X] (FunctionField.ringOfIntegers K L) := + IsIntegralClosure.isIntegral_algebra K[X] L + +local instance tempFiniteIntegralClosureModuleFinite : + Module.Finite K[X] (FunctionField.ringOfIntegers K L) := + Module.IsNoetherian.finite K[X] (FunctionField.ringOfIntegers K L) + +local instance tempPolynomialTorsionFreeTop : Module.IsTorsionFree K[X] L := + Module.IsTorsionFree.trans_faithfulSMul K[X] (RatFunc K) L + +local instance tempFiniteIntegralClosureIsTorsionFree : + Module.IsTorsionFree K[X] (FunctionField.ringOfIntegers K L) := + IsIntegralClosure.isTorsionFree K[X] L + +local instance tempFiniteIntegralClosureIsDedekindDomain : + IsDedekindDomain (FunctionField.ringOfIntegers K L) := + IsIntegralClosure.isDedekindDomain K[X] (RatFunc K) L + (FunctionField.ringOfIntegers K L) + +variable {K L} + +omit [DecidableEq K] [DecidableEq (RatFunc K)] in +theorem finiteExtensionFinitePlace_exists_local_lift_of_orderTop_nonnegative + (q : PlaneCurveExtensionFinitePlace K L) (x : L) + (hx : (0 : WithTop ℤ) ≤ + finiteExtensionFinitePlaceLocalOrderTop (K := K) (L := L) q x) : + ∃ x₀ : FiniteExtensionFinitePlaceLocalRing K L q, + x = finiteExtensionFinitePlaceLocalizationToField + (K := K) (L := L) q x₀ := by + let := finiteExtensionFinitePlaceLocalAlgebra (K := K) (L := L) q + let := finiteExtensionFinitePlaceLocalIsFractionRing (K := K) (L := L) q + let : IsDiscreteValuationRing + (FiniteExtensionFinitePlaceLocalRing K L q) := + IsLocalization.AtPrime.isDiscreteValuationRing_of_dedekind_domain + (FunctionField.ringOfIntegers K L) q.ne_bot + (FiniteExtensionFinitePlaceLocalRing K L q) + by_cases hx0 : x = 0 + · exact ⟨0, by simp [hx0]⟩ + have horder : 0 ≤ finitePlaceOrder + (IsDiscreteValuationRing.maximalIdeal + (FiniteExtensionFinitePlaceLocalRing K L q)) x := by + simpa only [finiteExtensionFinitePlaceLocalOrderTop, + finitePlaceOrderTop_eq_coe _ _ hx0, WithTop.coe_nonneg] using hx + have hval : + (IsDiscreteValuationRing.maximalIdeal + (FiniteExtensionFinitePlaceLocalRing K L q)).valuation L x ≤ 1 := by + rw [valuation_eq_exp_neg_finitePlaceOrder _ x hx0] + simpa only [← WithZero.exp_zero] using + (WithZero.exp_le_exp.mpr (by omega : + -finitePlaceOrder + (IsDiscreteValuationRing.maximalIdeal + (FiniteExtensionFinitePlaceLocalRing K L q)) x ≤ 0)) + obtain ⟨x₀, hx₀⟩ := IsDiscreteValuationRing.exists_lift_of_le_one hval + exact ⟨x₀, hx₀.symm⟩ + +variable {C : Type*} [Field C] [Algebra C L] + +omit [DecidableEq K] [DecidableEq (RatFunc K)] in +theorem ratFuncFinitePlace_residueField_finite [Finite K] + (p : HeightOneSpectrum K[X]) : + Finite p.asIdeal.ResidueField := by + classical + let r := finitePlaceNormalizedPrime p + have hr0 : (r : K[X]) ≠ 0 := r.property.1.ne_zero + have hrmonic : (r : K[X]).Monic := + (Polynomial.normalize_eq_self_iff_monic hr0).mp r.property.2 + have hp : p.asIdeal = Ideal.span ({(r : K[X])} : Set K[X]) := by + calc + p.asIdeal = (normalizedPrimeFinitePlace (K := K) r).asIdeal := by + rw [normalizedPrimeFinitePlace_finitePlaceNormalizedPrime] + _ = Ideal.span ({(r : K[X])} : Set K[X]) := rfl + let : Module.Finite K + (HasQuotient.Quotient K[X] p.asIdeal) := by + rw [hp] + exact hrmonic.finite_quotient + let : Finite (HasQuotient.Quotient K[X] p.asIdeal) := + Module.finite_of_finite K + infer_instance + +omit [DecidableEq K] [DecidableEq (RatFunc K)] in +theorem finiteExtensionFinitePlace_residueField_finite [Finite K] + (q : PlaneCurveExtensionFinitePlace K L) : + Finite q.asIdeal.ResidueField := by + classical + let p := HeightOneSpectrum.under K[X] q + let : Finite p.asIdeal.ResidueField := + ratFuncFinitePlace_residueField_finite p + let : q.asIdeal.LiesOver p.asIdeal := ⟨rfl⟩ + let hLocalAlg := + Localization.AtPrime.algebraOfLiesOver p.asIdeal q.asIdeal + have : IsScalarTower K[X] (Localization.AtPrime p.asIdeal) + (Localization.AtPrime q.asIdeal) := inferInstance + let : Algebra.QuasiFiniteAt K[X] q.asIdeal := inferInstance + let : Module.Finite p.asIdeal.ResidueField q.asIdeal.ResidueField := + inferInstance + exact Module.finite_of_finite p.asIdeal.ResidueField + +omit [DecidableEq K] [DecidableEq (RatFunc K)] in +theorem finiteExtensionFinitePlaceLocal_residueField_perfect [Finite K] + (q : PlaneCurveExtensionFinitePlace K L) : + letI : IsDiscreteValuationRing + (FiniteExtensionFinitePlaceLocalRing K L q) := + IsLocalization.AtPrime.isDiscreteValuationRing_of_dedekind_domain + (FunctionField.ringOfIntegers K L) q.ne_bot + (FiniteExtensionFinitePlaceLocalRing K L q) + PerfectField + (IsDiscreteValuationRing.maximalIdeal + (FiniteExtensionFinitePlaceLocalRing K L q)).asIdeal.ResidueField := by + classical + let : Finite q.asIdeal.ResidueField := + finiteExtensionFinitePlace_residueField_finite q + let : Finite (HasQuotient.Quotient + (FunctionField.ringOfIntegers K L) q.asIdeal) := + Finite.of_injective + (algebraMap + (HasQuotient.Quotient (FunctionField.ringOfIntegers K L) q.asIdeal) + q.asIdeal.ResidueField) + q.asIdeal.injective_algebraMap_quotient_residueField + let : IsDiscreteValuationRing + (FiniteExtensionFinitePlaceLocalRing K L q) := + IsLocalization.AtPrime.isDiscreteValuationRing_of_dedekind_domain + (FunctionField.ringOfIntegers K L) q.ne_bot + (FiniteExtensionFinitePlaceLocalRing K L q) + let e := IsLocalization.AtPrime.equivQuotMaximalIdeal q.asIdeal + (FiniteExtensionFinitePlaceLocalRing K L q) + let : Finite (HasQuotient.Quotient + (FiniteExtensionFinitePlaceLocalRing K L q) + (IsDiscreteValuationRing.maximalIdeal + (FiniteExtensionFinitePlaceLocalRing K L q)).asIdeal) := + Finite.of_injective e.symm e.symm.injective + let Rq := HasQuotient.Quotient + (FiniteExtensionFinitePlaceLocalRing K L q) + (IsDiscreteValuationRing.maximalIdeal + (FiniteExtensionFinitePlaceLocalRing K L q)).asIdeal + let : Finite + (IsDiscreteValuationRing.maximalIdeal + (FiniteExtensionFinitePlaceLocalRing K L q)).asIdeal.ResidueField := + IsLocalization.finite Rq (nonZeroDivisors Rq) + exact PerfectField.ofFinite + +omit [DecidableEq K] [DecidableEq (RatFunc K)] in +theorem finiteExtensionFinitePlace_auxiliaryFamily_caseII_nonnegative_of_preserves + (q : PlaneCurveExtensionFinitePlace K L) + (D : Derivation C L L) + (hDIntegral : ∀ r : FiniteExtensionFinitePlaceLocalRing K L q, + ∃ s : FiniteExtensionFinitePlaceLocalRing K L q, + D (finiteExtensionFinitePlaceLocalizationToField + (K := K) (L := L) q r) = + finiteExtensionFinitePlaceLocalizationToField + (K := K) (L := L) q s) + (h k : ℕ) (epsilon : Sum (Fin k) (Fin (k + 1) × Fin h) → ℕ) + (u v : L) + (hu : (0 : WithTop ℤ) ≤ + finiteExtensionFinitePlaceLocalOrderTop (K := K) (L := L) q u) + (hv : (0 : WithTop ℤ) ≤ + finiteExtensionFinitePlaceLocalOrderTop (K := K) (L := L) q v) + (hrho : (0 : WithTop ℤ) ≤ + finiteExtensionFinitePlaceLocalOrderTop (K := K) (L := L) q + ((1 - u) / (1 - v))) : + (0 : WithTop ℤ) ≤ + finiteExtensionFinitePlaceLocalOrderTop (K := K) (L := L) q + (indexedDedekindLocalWronskian D epsilon + (auxiliaryFamily u v h k)).det := by + let := finiteExtensionFinitePlaceLocalAlgebra (K := K) (L := L) q + let := finiteExtensionFinitePlaceLocalIsFractionRing (K := K) (L := L) q + let : IsDiscreteValuationRing + (FiniteExtensionFinitePlaceLocalRing K L q) := + IsLocalization.AtPrime.isDiscreteValuationRing_of_dedekind_domain + (FunctionField.ringOfIntegers K L) q.ne_bot + (FiniteExtensionFinitePlaceLocalRing K L q) + apply finitePlaceOrderTop_auxiliaryFamily_caseII_nonnegative_of_integral + (IsDiscreteValuationRing.maximalIdeal + (FiniteExtensionFinitePlaceLocalRing K L q)) D hDIntegral h k epsilon u v + · obtain ⟨u₀, hu₀⟩ := + finiteExtensionFinitePlace_exists_local_lift_of_orderTop_nonnegative q u hu + exact ⟨u₀, hu₀⟩ + · obtain ⟨v₀, hv₀⟩ := + finiteExtensionFinitePlace_exists_local_lift_of_orderTop_nonnegative q v hv + exact ⟨v₀, hv₀⟩ + · obtain ⟨rho₀, hrho₀⟩ := + finiteExtensionFinitePlace_exists_local_lift_of_orderTop_nonnegative + q ((1 - u) / (1 - v)) hrho + exact ⟨rho₀, hrho₀⟩ + +omit [DecidableEq K] [DecidableEq (RatFunc K)] in +theorem finiteExtensionFinitePlace_auxiliaryFamily_caseII_nonnegative_of_scaled_preserves + (q : PlaneCurveExtensionFinitePlace K L) + (h k : ℕ) {n : ℕ} + (e : Sum (Fin k) (Fin (k + 1) × Fin h) ≃ Fin n) + (epsilon : Sum (Fin k) (Fin (k + 1) × Fin h) → ℕ) + (hepsilon : ∀ i, epsilon i = (e i : ℕ)) + (D : Derivation C L L) (c : L) + (hScaledIntegral : + ∀ r : FiniteExtensionFinitePlaceLocalRing K L q, + ∃ s : FiniteExtensionFinitePlaceLocalRing K L q, + (c • D) (finiteExtensionFinitePlaceLocalizationToField + (K := K) (L := L) q r) = + finiteExtensionFinitePlaceLocalizationToField + (K := K) (L := L) q s) + (u v : L) + (hu : (0 : WithTop ℤ) ≤ + finiteExtensionFinitePlaceLocalOrderTop (K := K) (L := L) q u) + (hv : (0 : WithTop ℤ) ≤ + finiteExtensionFinitePlaceLocalOrderTop (K := K) (L := L) q v) + (hrho : (0 : WithTop ℤ) ≤ + finiteExtensionFinitePlaceLocalOrderTop (K := K) (L := L) q + ((1 - u) / (1 - v))) : + (0 : WithTop ℤ) ≤ + n.choose 2 • + finiteExtensionFinitePlaceLocalOrderTop (K := K) (L := L) q c + + finiteExtensionFinitePlaceLocalOrderTop (K := K) (L := L) q + (indexedDedekindLocalWronskian D epsilon + (auxiliaryFamily u v h k)).det := by + have hbound := + finiteExtensionFinitePlace_auxiliaryFamily_caseII_nonnegative_of_preserves + q (c • D) hScaledIntegral h k epsilon u v hu hv hrho + have hchange := indexedDedekindLocalWronskian_det_changeParameter + e epsilon hepsilon (c • D) D c rfl (auxiliaryFamily u v h k) + rw [hchange, finiteExtensionFinitePlaceLocalOrderTop_mul, + finiteExtensionFinitePlaceLocalOrderTop_pow] at hbound + exact hbound + +variable {p : ℕ} [Fact p.Prime] [CharP L p] + +omit [DecidableEq K] [DecidableEq (RatFunc K)] in +theorem finiteExtensionFinitePlace_auxiliaryFamily_caseI_q_wronskian_bound_of_scaled_preserves + [Finite K] + (q : PlaneCurveExtensionFinitePlace K L) + (h k : ℕ) {n : ℕ} + (e : Sum (Fin k) (Fin (k + 1) × Fin h) ≃ Fin n) + (epsilonOrder : Sum (Fin k) (Fin (k + 1) × Fin h) → ℕ) + (hepsilon : ∀ i, epsilonOrder i = (e i : ℕ)) + (epsilon qBound : ℕ) + (D : Derivation (frobeniusSubfield L p) L L) (c : L) + (hScaledIntegral : + ∀ r : FiniteExtensionFinitePlaceLocalRing K L q, + ∃ s : FiniteExtensionFinitePlaceLocalRing K L q, + (c • D) (finiteExtensionFinitePlaceLocalizationToField + (K := K) (L := L) q r) = + finiteExtensionFinitePlaceLocalizationToField + (K := K) (L := L) q s) + (u v : L) + (hrhoNe : (1 - u) / (1 - v) ≠ 0) + (huOrder : + finiteExtensionFinitePlaceLocalOrderTop (K := K) (L := L) q u = 0) + (hrhoOrder : + finiteExtensionFinitePlaceLocalOrder (K := K) (L := L) q + ((1 - u) / (1 - v)) < 0) + (hgridRegular : ∀ rs : Fin (k + 1) × Fin h, + (0 : WithTop ℤ) ≤ + finiteExtensionFinitePlaceLocalOrderTop (K := K) (L := L) q + (u ^ (rs.1 : ℕ) * v ^ (rs.2 : ℕ))) + (hepsilonInjective : Function.Injective epsilonOrder) + (hepsilonMax : ∀ i, epsilonOrder i ≤ epsilon) + (hk : k ≤ epsilon + 1) (hepsilonQ : epsilon + 1 ≤ qBound) : + (((qBound : ℤ) * + finiteExtensionFinitePlaceLocalOrder (K := K) (L := L) q + ((1 - u) / (1 - v)) : ℤ) : WithTop ℤ) ≤ + n.choose 2 • + finiteExtensionFinitePlaceLocalOrderTop (K := K) (L := L) q c + + finiteExtensionFinitePlaceLocalOrderTop (K := K) (L := L) q + (indexedDedekindLocalWronskian D epsilonOrder + (auxiliaryFamily u v h k)).det := by + classical + let := finiteExtensionFinitePlaceLocalAlgebra (K := K) (L := L) q + let := finiteExtensionFinitePlaceLocalIsFractionRing (K := K) (L := L) q + let : IsDiscreteValuationRing + (FiniteExtensionFinitePlaceLocalRing K L q) := + IsLocalization.AtPrime.isDiscreteValuationRing_of_dedekind_domain + (FunctionField.ringOfIntegers K L) q.ne_bot + (FiniteExtensionFinitePlaceLocalRing K L q) + let : CharP (FiniteExtensionFinitePlaceLocalRing K L q) p := ⟨by + intro n + rw [← map_eq_zero_iff + (finiteExtensionFinitePlaceLocalizationToField + (K := K) (L := L) q) + (by + change Function.Injective + (algebraMap (FiniteExtensionFinitePlaceLocalRing K L q) L) + exact IsFractionRing.injective + (FiniteExtensionFinitePlaceLocalRing K L q) L), + map_natCast, CharP.cast_eq_zero_iff L p]⟩ + let : PerfectField + (IsDiscreteValuationRing.maximalIdeal + (FiniteExtensionFinitePlaceLocalRing K L q)).asIdeal.ResidueField := + finiteExtensionFinitePlaceLocal_residueField_perfect q + obtain ⟨A, hAdet, hdet, hbound⟩ := + exists_frobeniusSubfield_dedekindAuxiliaryFamily_caseI_q_wronskian_bound_of_perfect_residue + (p := p) + (IsDiscreteValuationRing.maximalIdeal + (FiniteExtensionFinitePlaceLocalRing K L q)) + (c • D) hScaledIntegral u v h k epsilonOrder epsilon qBound + hrhoNe huOrder hrhoOrder hgridRegular hepsilonInjective + hepsilonMax hk hepsilonQ + have hchange := indexedDedekindLocalWronskian_det_changeParameter + e epsilonOrder hepsilon (c • D) D c rfl (auxiliaryFamily u v h k) + rw [hchange, finitePlaceOrderTop_mul, finitePlaceOrderTop_pow] at hbound + change (((qBound : ℤ) * + finiteExtensionFinitePlaceLocalOrder (K := K) (L := L) q + ((1 - u) / (1 - v)) : ℤ) : WithTop ℤ) ≤ + n.choose 2 • + finiteExtensionFinitePlaceLocalOrderTop (K := K) (L := L) q c + + finiteExtensionFinitePlaceLocalOrderTop (K := K) (L := L) q + (indexedDedekindLocalWronskian D epsilonOrder + (auxiliaryFamily u v h k)).det at hbound + exact hbound + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurveAuxiliaryFinitePlacePrincipalDivisor.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurveAuxiliaryFinitePlacePrincipalDivisor.lean new file mode 100644 index 0000000000..4bcd6a3c9d --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurveAuxiliaryFinitePlacePrincipalDivisor.lean @@ -0,0 +1,77 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionPrincipalDivisor +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveAuxiliaryFinitePlace + +/-! +# Actual finite-place auxiliary orders in the exhaustive divisor model + +This file keeps the local DVR construction independent of the heavier +exhaustive-place infrastructure, then identifies its normalized order with +the coefficient used by the global principal divisor. +-/ + +@[expose] public section + +open scoped Polynomial +open IsDedekindDomain + +namespace BGS.CorvajaZannier + +noncomputable section + +variable (K : Type*) [Field K] [DecidableEq K] [DecidableEq (RatFunc K)] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +local instance (priority := 10) auxiliaryFinitePlaceBridgePolynomialAlgebra : + Algebra K[X] L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K[X] (RatFunc K))) + +local instance auxiliaryFinitePlaceBridgePolynomialScalarTower : + IsScalarTower K[X] (RatFunc K) L := + .of_algebraMap_eq' rfl + +local instance auxiliaryFinitePlaceBridgeIntegralClosureIsDedekindDomain : + IsDedekindDomain (FunctionField.ringOfIntegers K L) := + IsIntegralClosure.isDedekindDomain K[X] (RatFunc K) L + (FunctionField.ringOfIntegers K L) + +omit [DecidableEq K] [DecidableEq (RatFunc K)] in +/-- The actual localized finite-place order is exactly the coefficient in +the exhaustive finite principal divisor. -/ +theorem finiteExtensionFinitePlaceLocalOrder_eq_principalDivisor + (q : PlaneCurveExtensionFinitePlace K L) (x : L) : + finiteExtensionFinitePlaceLocalOrder (K := K) (L := L) q x = + finiteExtensionFinitePrincipalDivisor K L x q := by + rw [finiteExtensionFinitePlaceLocalOrder_eq_globalOrder, + finiteExtensionFinitePrincipalDivisor_apply] + have h := fractionRingAlgEquiv_finitePlaceOrder_eq + (L := L) q + ((ratFuncFiniteIntegralClosureFractionRingEquiv K L).symm x) + simpa [ratFuncFiniteIntegralClosureFractionRingEquiv] using h + +omit [DecidableEq K] [DecidableEq (RatFunc K)] in +/-- For a nonzero element, the `WithTop` order appearing in the local +Wronskian inequality is the exhaustive principal-divisor coefficient. -/ +theorem finiteExtensionFinitePlaceLocalOrderTop_eq_principalDivisor + (q : PlaneCurveExtensionFinitePlace K L) (x : L) (hx : x ≠ 0) : + finiteExtensionFinitePlaceLocalOrderTop (K := K) (L := L) q x = + (finiteExtensionFinitePrincipalDivisor K L x q : WithTop ℤ) := by + rw [finiteExtensionFinitePlaceLocalOrderTop_eq_globalOrder q x hx] + have horder := + finiteExtensionFinitePlaceLocalOrder_eq_principalDivisor K L q x + rw [finiteExtensionFinitePlaceLocalOrder_eq_globalOrder] at horder + exact_mod_cast horder + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurveAuxiliaryIndependence.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurveAuxiliaryIndependence.lean new file mode 100644 index 0000000000..7b8507ca2e --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurveAuxiliaryIndependence.lean @@ -0,0 +1,558 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.BivariateGauss +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.AbsoluteIrreducibilityBaseChange +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PerfectConstants +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveSeparability +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.SeparatingCoordinateNotFrobenius + +/-! +# The plane-curve auxiliary family over the Frobenius subfield + +This file specializes the algebraic resultant argument in +`BivariateGauss.lean` to the function field of an irreducible affine plane +curve over a perfect field of prime characteristic. Constants are embedded +in the Frobenius subfield `L^p`, and separability over a coordinate rational +subfield is promoted to separability over `L^p` adjoined with that coordinate. + +The only irreducibility hypothesis retained at the final boundary is the +literal base change of the defining equation from the constant field to +`L^p`. This is the precise consequence of absolute irreducibility used in +Corvaja--Zannier's Proposition 1; it is not replaced by an unrelated +typeclass or by an axiom. + +Source provenance: published pages 1933--1934; checked semantic reconstruction +`Papers/CorvajaZannier2013/CorvajaZannier2013.tex`, lines 486--571. The +specialization with Frobenius exponent `p` and no auxiliary twists is the +linear-independence input cited on published page 1940. +-/ + +@[expose] public section + +namespace BGS.CorvajaZannier + +noncomputable section + +/-- View a polynomial in affine coordinates `0,1` as a polynomial in +coordinate `0` whose coefficients are ordinary polynomials in coordinate +`1`. -/ +def planeCurveToBivariate (K : Type*) [Field K] : + MvPolynomial (Fin 2) K ≃ₐ[K] Polynomial (Polynomial K) := + (MvPolynomial.finSuccEquiv K 1).trans + (Polynomial.mapAlgEquiv (MvPolynomial.uniqueAlgEquiv K (Fin 1))) + +@[simp] +theorem planeCurveToBivariate_X_zero + (K : Type*) [Field K] : + planeCurveToBivariate K (MvPolynomial.X 0) = Polynomial.X := by + have hinner : + MvPolynomial.finSuccEquiv K 1 (MvPolynomial.X 0) = + (Polynomial.X : Polynomial (MvPolynomial (Fin 1) K)) := by + rw [MvPolynomial.finSuccEquiv_apply] + simp + rw [planeCurveToBivariate] + change Polynomial.map (MvPolynomial.uniqueAlgEquiv K (Fin 1)).toRingHom + (MvPolynomial.finSuccEquiv K 1 (MvPolynomial.X 0)) = Polynomial.X + rw [hinner] + simp + +@[simp] +theorem planeCurveToBivariate_X_one + (K : Type*) [Field K] : + planeCurveToBivariate K (MvPolynomial.X 1) = + Polynomial.C Polynomial.X := by + have hinner : + MvPolynomial.finSuccEquiv K 1 (MvPolynomial.X 1) = + Polynomial.C (MvPolynomial.X (0 : Fin 1)) := by + rw [MvPolynomial.finSuccEquiv_apply] + simp only [MvPolynomial.coe_eval₂Hom, MvPolynomial.eval₂_X] + rw [show (1 : Fin 2) = Fin.succ (0 : Fin 1) by decide] + rfl + rw [planeCurveToBivariate] + change Polynomial.map (MvPolynomial.uniqueAlgEquiv K (Fin 1)).toRingHom + (MvPolynomial.finSuccEquiv K 1 (MvPolynomial.X 1)) = + Polynomial.C Polynomial.X + rw [hinner] + simp [MvPolynomial.uniqueAlgEquiv] + +@[simp] +theorem planeCurveToBivariate_C + (K : Type*) [Field K] (c : K) : + planeCurveToBivariate K (MvPolynomial.C c) = + Polynomial.C (Polynomial.C c) := by + have hinner : + MvPolynomial.finSuccEquiv K 1 (MvPolynomial.C c) = + Polynomial.C (MvPolynomial.C c) := by + rw [MvPolynomial.finSuccEquiv_apply] + simp + rw [planeCurveToBivariate] + change Polynomial.map (MvPolynomial.uniqueAlgEquiv K (Fin 1)).toRingHom + (MvPolynomial.finSuccEquiv K 1 (MvPolynomial.C c)) = + Polynomial.C (Polynomial.C c) + rw [hinner] + simp [MvPolynomial.uniqueAlgEquiv] + +/-- The outer degree of the source-oriented iterated presentation is exactly +the degree in coordinate `0`. -/ +theorem planeCurveToBivariate_natDegree_eq_degreeOf_zero + (K : Type*) [Field K] (f : MvPolynomial (Fin 2) K) : + (planeCurveToBivariate K f).natDegree = + MvPolynomial.degreeOf 0 f := by + rw [planeCurveToBivariate] + change + ((MvPolynomial.finSuccEquiv K 1 f).map + (MvPolynomial.uniqueAlgEquiv K (Fin 1)).toRingHom).natDegree = _ + rw [Polynomial.natDegree_map_eq_of_injective + (MvPolynomial.uniqueAlgEquiv K (Fin 1)).injective] + exact MvPolynomial.natDegree_finSuccEquiv f + +/-- Transposing the source-oriented iterated presentation gives the standard +bivariate-polynomial presentation. -/ +theorem transposeBivariate_planeCurveToBivariate + (K : Type*) [Field K] (f : MvPolynomial (Fin 2) K) : + transposeBivariate (planeCurveToBivariate K f) = + (Polynomial.Bivariate.equivMvPolynomial K).symm f := by + let lhs : MvPolynomial (Fin 2) K →+* Polynomial (Polynomial K) := + transposeBivariate.comp + (planeCurveToBivariate K).toRingEquiv.toRingHom + let rhs : MvPolynomial (Fin 2) K →+* Polynomial (Polynomial K) := + (Polynomial.Bivariate.equivMvPolynomial K).symm.toRingEquiv.toRingHom + change lhs f = rhs f + congr 1 + apply MvPolynomial.ringHom_ext + · intro c + simp [lhs, rhs] + · intro i + fin_cases i <;> simp [lhs, rhs] + +/-- The outer degree in the standard bivariate presentation is exactly the +degree in coordinate `1`. -/ +theorem bivariateEquiv_symm_natDegree_eq_degreeOf_one + (K : Type*) [Field K] (f : MvPolynomial (Fin 2) K) : + ((Polynomial.Bivariate.equivMvPolynomial K).symm f).natDegree = + MvPolynomial.degreeOf 1 f := by + let remaining := {i : Fin 2 // i ≠ 1} + let i0 : remaining := ⟨0, by decide⟩ + let : Unique remaining := + { default := i0 + uniq := by + intro i + apply Subtype.ext + omega } + let q : MvPolynomial (Fin 2) K →+* + Polynomial (MvPolynomial remaining K) := + (MvPolynomial.optionEquivLeft K remaining).toRingEquiv.toRingHom.comp + (MvPolynomial.rename + (Equiv.optionSubtypeNe (1 : Fin 2)).symm).toRingHom + let e : MvPolynomial remaining K ≃ₐ[K] Polynomial K := + MvPolynomial.uniqueAlgEquiv K remaining + let lhs : MvPolynomial (Fin 2) K →+* Polynomial (Polynomial K) := + (Polynomial.Bivariate.equivMvPolynomial K).symm.toRingEquiv.toRingHom + let rhs : MvPolynomial (Fin 2) K →+* Polynomial (Polynomial K) := + (Polynomial.mapRingHom e.toRingHom).comp q + have hhom : lhs = rhs := by + apply MvPolynomial.ringHom_ext + · intro c + simp [lhs, rhs, q, e] + · intro i + fin_cases i <;> simp [lhs, rhs, q, e, remaining] + change (lhs f).natDegree = _ + rw [hhom] + change ((q f).map e.toRingHom).natDegree = _ + rw [Polynomial.natDegree_map_eq_of_injective e.injective] + exact (MvPolynomial.degreeOf_eq_natDegree (1 : Fin 2) f).symm + +/-- An injective change of coefficients preserves every coordinate degree. -/ +theorem degreeOf_map_eq_of_injective + {R S σ : Type*} [CommSemiring R] [CommSemiring S] + (ι : R →+* S) (hι : Function.Injective ι) (i : σ) + (f : MvPolynomial σ R) : + MvPolynomial.degreeOf i (MvPolynomial.map ι f) = + MvPolynomial.degreeOf i f := by + rw [MvPolynomial.degreeOf_eq_sup, MvPolynomial.degreeOf_eq_sup, + MvPolynomial.support_map_of_injective f hι] + +variable {K L : Type*} [Field K] [Field L] {p : ℕ} + [Fact p.Prime] [CharP K p] [CharP L p] [PerfectField K] [Algebra K L] + +/-- The defining plane equation after extension of constants from `K` to the +Frobenius subfield `L^p`, in the iterated-polynomial orientation used by the +resultant proof. -/ +def planeCurveFrobeniusRelation (f : MvPolynomial (Fin 2) K) : + Polynomial (Polynomial (frobeniusSubfield L p)) := + planeCurveToBivariate (frobeniusSubfield L p) + (MvPolynomial.map + (perfectConstantsToFrobeniusSubfield (K := K) (L := L) (p := p)) f) + +/-- The first exact bidegree of the Frobenius-base-changed relation. -/ +theorem planeCurveFrobeniusRelation_natDegree + (f : MvPolynomial (Fin 2) K) : + (planeCurveFrobeniusRelation (L := L) (p := p) f).natDegree = + MvPolynomial.degreeOf 0 f := by + rw [planeCurveFrobeniusRelation, + planeCurveToBivariate_natDegree_eq_degreeOf_zero, + degreeOf_map_eq_of_injective] + exact (perfectConstantsToFrobeniusSubfield + (K := K) (L := L) (p := p)).injective + +/-- The second exact bidegree of the Frobenius-base-changed relation. -/ +theorem transposeBivariate_planeCurveFrobeniusRelation_natDegree + (f : MvPolynomial (Fin 2) K) : + (transposeBivariate + (planeCurveFrobeniusRelation (L := L) (p := p) f)).natDegree = + MvPolynomial.degreeOf 1 f := by + rw [planeCurveFrobeniusRelation, + transposeBivariate_planeCurveToBivariate, + bivariateEquiv_symm_natDegree_eq_degreeOf_one, + degreeOf_map_eq_of_injective] + exact (perfectConstantsToFrobeniusSubfield + (K := K) (L := L) (p := p)).injective + +/-- Evaluation of the Frobenius-base-changed relation agrees with direct +evaluation of the original plane equation. -/ +theorem evalBivariate_planeCurveFrobeniusRelation + (f : MvPolynomial (Fin 2) K) (x y : L) : + evalBivariate y x + (planeCurveFrobeniusRelation (L := L) (p := p) f) = + MvPolynomial.eval₂ (algebraMap K L) ![x, y] f := by + let F := frobeniusSubfield L p + let ι : K →+* F := + perfectConstantsToFrobeniusSubfield (K := K) (L := L) (p := p) + let evalIterated : Polynomial (Polynomial F) →+* L := + Polynomial.eval₂RingHom + (Polynomial.eval₂RingHom (algebraMap F L) y) x + let lhs : MvPolynomial (Fin 2) K →+* L := + evalIterated.comp + ((planeCurveToBivariate F).toRingEquiv.toRingHom.comp + (MvPolynomial.map ι)) + let rhs : MvPolynomial (Fin 2) K →+* L := + MvPolynomial.eval₂Hom (algebraMap K L) ![x, y] + have hhom : lhs = rhs := by + apply MvPolynomial.ringHom_ext + · intro c + dsimp only [lhs, RingHom.comp_apply] + rw [MvPolynomial.map_C] + change evalIterated + (planeCurveToBivariate F (MvPolynomial.C (ι c))) = + rhs (MvPolynomial.C c) + rw [planeCurveToBivariate_C] + simp only [Polynomial.coe_eval₂RingHom, Polynomial.eval₂_C, MvPolynomial.eval₂Hom_C, F, + evalIterated, ι, rhs] + change + (((perfectConstantsToFrobeniusSubfield + (K := K) (L := L) (p := p) c : frobeniusSubfield L p) : L)) = + algebraMap K L c + exact coe_perfectConstantsToFrobeniusSubfield + (K := K) (L := L) (p := p) c + · intro i + fin_cases i <;> + simp [lhs, rhs, evalIterated, ι, RingHom.comp_apply] + change lhs f = rhs f + rw [hhom] + +/-- Irreducibility after the precise constant-field extension to `L^p` +implies irreducibility in the iterated-polynomial presentation. -/ +theorem planeCurveFrobeniusRelation_irreducible + {f : MvPolynomial (Fin 2) K} + (hbaseChange : Irreducible + (MvPolynomial.map + (perfectConstantsToFrobeniusSubfield + (K := K) (L := L) (p := p)) f)) : + Irreducible (planeCurveFrobeniusRelation (L := L) (p := p) f) := by + exact hbaseChange.map + (planeCurveToBivariate (frobeniusSubfield L p)).toMulEquiv + +/-- Extending the base from the perfect constant field to the Frobenius +subfield preserves separability of the remaining top extension. -/ +theorem isSeparable_over_frobeniusAdjoin_of_isSeparable_over_constantAdjoin + (z : L) + [Algebra.IsSeparable (IntermediateField.adjoin K {z}) L] : + Algebra.IsSeparable + (IntermediateField.adjoin (frobeniusSubfield L p) {z}) L := by + let F := frobeniusSubfield L p + let : Algebra K F := + (perfectConstantsToFrobeniusSubfield + (K := K) (L := L) (p := p)).toAlgebra + let : IsScalarTower K F L := by + apply IsScalarTower.of_algebraMap_eq' + ext c + exact (coe_perfectConstantsToFrobeniusSubfield + (K := K) (L := L) (p := p) c).symm + let A : IntermediateField K L := IntermediateField.adjoin K {z} + let E : IntermediateField F L := IntermediateField.adjoin F {z} + have hAE : A ≤ E.restrictScalars K := by + apply IntermediateField.adjoin_le_iff.mpr + intro x hx + rw [Set.mem_singleton_iff] at hx + subst x + exact IntermediateField.subset_adjoin F {z} (Set.mem_singleton z) + let : Algebra A E := (IntermediateField.inclusion hAE).toAlgebra + let : IsScalarTower A E L := IsScalarTower.of_algebraMap_eq' rfl + exact Algebra.isSeparable_tower_top_of_isSeparable A E L + +/-- A separating element has minimal polynomial of exact degree `p` over the +Frobenius subfield. -/ +theorem minpoly_natDegree_over_frobeniusSubfield_eq_char + (z : L) (hz : z ∉ frobeniusSubfield L p) + [Algebra.IsSeparable + (IntermediateField.adjoin (frobeniusSubfield L p) {z}) L] : + (minpoly (frobeniusSubfield L p) z).natDegree = p := by + let F := frobeniusSubfield L p + let : IsPurelyInseparable F L := frobeniusSubfield_isPurelyInseparable p + have hzIntegral : IsIntegral F z := IsPurelyInseparable.isIntegral' F z + calc + (minpoly F z).natDegree = + Module.finrank F (IntermediateField.adjoin F {z}) := + (IntermediateField.adjoin.finrank hzIntegral).symm + _ = Module.finrank F L := by + rw [adjoin_frobeniusSubfield_eq_top (p := p) z, + IntermediateField.finrank_top'] + _ = p := finrank_frobeniusSubfield_eq_char (p := p) z hz + +/-- **Plane-curve form of the Corvaja--Zannier auxiliary-family +linear-independence proposition (the `q = p`, `z = w = 1` specialization).** + +The two nonzero partial derivatives are the source's two separating-coordinate +hypotheses. For the displayed orientation, separability over the field +generated by coordinate `1` is the one used to prove that this coordinate has +minimal-polynomial degree `p` over `L^p`; the symmetric partial is retained +because the source proposition assumes both coordinates separating. + +Two hypotheses mark exact geometric boundaries rather than hiding them: + +* `hbaseChange` is irreducibility after the literal extension of constants + `K → L^p`, the consequence of absolute irreducibility needed by Gauss + descent; +* `hsecondNotFrobenius` says that the separating second coordinate is not a + `p`-th power in `L`. Equivalently, it is the missing differential/basis + compatibility needed to turn separability into degree exactly `p`. + +All remaining assumptions are the printed positivity, exact bidegree, +size, and excluded-degree-alternative hypotheses. -/ +theorem planeCurve_auxiliaryFamily_linearIndependent + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (_hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) : + letI := planeCurveCoordinateRing_isDomain hf + letI : CharP (PlaneCurveFunctionField f) p := + charP_of_injective_algebraMap + (algebraMap K (PlaneCurveFunctionField f)).injective p + ∀ (a b h k : ℕ), + 0 < a → 0 < h → 0 < k → + Irreducible + (MvPolynomial.map + (perfectConstantsToFrobeniusSubfield + (K := K) (L := PlaneCurveFunctionField f) (p := p)) f) → + (planeCurveFrobeniusRelation + (K := K) (L := PlaneCurveFunctionField f) (p := p) f).natDegree = a → + (transposeBivariate + (planeCurveFrobeniusRelation + (K := K) (L := PlaneCurveFunctionField f) (p := p) f)).natDegree = b → + planeCurveFunction f 1 ∉ + frobeniusSubfield (PlaneCurveFunctionField f) p → + a * h + b * k < p → + ¬ (a ≤ k ∧ b ≤ h) → + LinearIndependent (frobeniusSubfield (PlaneCurveFunctionField f) p) + (auxiliaryFamily + (planeCurveFunction f 0) (planeCurveFunction f 1) h k) := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let : CharP (PlaneCurveFunctionField f) p := + charP_of_injective_algebraMap + (algebraMap K (PlaneCurveFunctionField f)).injective p + intro a b h k ha hh hk hbaseChange hdegreeFirst hdegreeSecond + hsecondNotFrobenius hsize hdegreeAlternativeExcluded + let L := PlaneCurveFunctionField f + let F := frobeniusSubfield L p + let x : L := planeCurveFunction f 0 + let y : L := planeCurveFunction f 1 + let g : Polynomial (Polynomial F) := + planeCurveFrobeniusRelation (K := K) (L := L) (p := p) f + have hseparableOverSecond := + finiteSeparable_over_secondCoordinate_of_irreducible hf hpartialFirst + let : Algebra.IsSeparable (SecondCoordinateSubfield f) L := + hseparableOverSecond.2 + let : Algebra.IsSeparable (IntermediateField.adjoin F {y}) L := by + exact isSeparable_over_frobeniusAdjoin_of_isSeparable_over_constantAdjoin + (K := K) (L := L) (p := p) y + have hminpoly : (minpoly F y).natDegree = p := + minpoly_natDegree_over_frobeniusSubfield_eq_char + (p := p) y hsecondNotFrobenius + have hyTranscendental : Transcendental K y := by + exact secondCoordinate_transcendental hf + (degreeOf_first_pos_of_pderiv_ne_zero hpartialFirst) + have hyOne : y ≠ 1 := by + intro hy + apply hyTranscendental + rw [hy] + exact isAlgebraic_one + have hgIrreducible : Irreducible g := by + exact planeCurveFrobeniusRelation_irreducible hbaseChange + have hgCoefficientDegree : ∀ i, (g.coeff i).natDegree ≤ b := by + intro i + have hbound := transposeBivariate_coeff_natDegree_le + (transposeBivariate g) b hdegreeSecond.le i + simpa only [transposeBivariate_transposeBivariate] using hbound + have hgZero : evalBivariate y x g = 0 := by + rw [evalBivariate_planeCurveFrobeniusRelation] + have hcoordinates : ![x, y] = planeCurveFunction f := by + funext i + fin_cases i <;> rfl + rw [hcoordinates] + exact eval₂_planeCurveFunction_eq_zero f + exact auxiliaryFamily_linearIndependent_of_irreducible_bidegree + g a b h k p ha hh hk hgIrreducible hdegreeFirst hdegreeSecond + hgCoefficientDegree x y hyOne hminpoly hgZero hsize + hdegreeAlternativeExcluded + +/-- Plane-curve auxiliary-family linear independence with the Frobenius +exclusion discharged from the separating-coordinate hypothesis. -/ +theorem planeCurve_auxiliaryFamily_linearIndependent_of_nonzero_partials + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) : + letI := planeCurveCoordinateRing_isDomain hf + letI : CharP (PlaneCurveFunctionField f) p := + charP_of_injective_algebraMap + (algebraMap K (PlaneCurveFunctionField f)).injective p + ∀ (a b h k : ℕ), + 0 < a → 0 < h → 0 < k → + Irreducible + (MvPolynomial.map + (perfectConstantsToFrobeniusSubfield + (K := K) (L := PlaneCurveFunctionField f) (p := p)) f) → + (planeCurveFrobeniusRelation + (K := K) (L := PlaneCurveFunctionField f) (p := p) f).natDegree = a → + (transposeBivariate + (planeCurveFrobeniusRelation + (K := K) (L := PlaneCurveFunctionField f) (p := p) f)).natDegree = b → + a * h + b * k < p → + ¬ (a ≤ k ∧ b ≤ h) → + LinearIndependent (frobeniusSubfield (PlaneCurveFunctionField f) p) + (auxiliaryFamily + (planeCurveFunction f 0) (planeCurveFunction f 1) h k) := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let : CharP (PlaneCurveFunctionField f) p := + charP_of_injective_algebraMap + (algebraMap K (PlaneCurveFunctionField f)).injective p + intro a b h k ha hh hk hbaseChange hdegreeFirst hdegreeSecond + hsize hdegreeAlternativeExcluded + exact planeCurve_auxiliaryFamily_linearIndependent + (p := p) hf hpartialFirst hpartialSecond a b h k ha hh hk + hbaseChange hdegreeFirst hdegreeSecond + (secondCoordinate_not_mem_frobeniusSubfield + (p := p) hf hpartialFirst) + hsize hdegreeAlternativeExcluded + +/-- Plane-curve auxiliary-family linear independence from absolute +irreducibility and the two separating-coordinate hypotheses. Absolute +irreducibility supplies both irreducibility over the constant field and the +literal base change to the Frobenius subfield used by the resultant proof. -/ +theorem planeCurve_auxiliaryFamily_linearIndependent_of_absoluteIrreducible + {f : MvPolynomial (Fin 2) K} + (habsolute : Irreducible + (MvPolynomial.map (algebraMap K (AlgebraicClosure K)) f)) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) : + let hf : Irreducible f := by + simpa only [MvPolynomial.map_id] using + irreducible_map_of_irreducible_map_algebraicClosure + (RingHom.id K) f habsolute + letI := planeCurveCoordinateRing_isDomain hf + letI : CharP (PlaneCurveFunctionField f) p := + charP_of_injective_algebraMap + (algebraMap K (PlaneCurveFunctionField f)).injective p + ∀ (a b h k : ℕ), + 0 < a → 0 < h → 0 < k → + (planeCurveFrobeniusRelation + (K := K) (L := PlaneCurveFunctionField f) (p := p) f).natDegree = a → + (transposeBivariate + (planeCurveFrobeniusRelation + (K := K) (L := PlaneCurveFunctionField f) (p := p) f)).natDegree = b → + a * h + b * k < p → + ¬ (a ≤ k ∧ b ≤ h) → + LinearIndependent (frobeniusSubfield (PlaneCurveFunctionField f) p) + (auxiliaryFamily + (planeCurveFunction f 0) (planeCurveFunction f 1) h k) := by + let hf : Irreducible f := by + simpa only [MvPolynomial.map_id] using + irreducible_map_of_irreducible_map_algebraicClosure + (RingHom.id K) f habsolute + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let : CharP (PlaneCurveFunctionField f) p := + charP_of_injective_algebraMap + (algebraMap K (PlaneCurveFunctionField f)).injective p + dsimp only + intro a b h k ha hh hk hdegreeFirst hdegreeSecond hsize + hdegreeAlternativeExcluded + apply planeCurve_auxiliaryFamily_linearIndependent_of_nonzero_partials + (p := p) hf hpartialFirst hpartialSecond a b h k ha hh hk + · exact irreducible_map_perfectConstantsToFrobeniusSubfield + (K := K) (L := PlaneCurveFunctionField f) (p := p) f habsolute + · exact hdegreeFirst + · exact hdegreeSecond + · exact hsize + · exact hdegreeAlternativeExcluded + +/-- The strongest plane-curve auxiliary-family theorem at the present +algebraic boundary: the bidegrees are the actual coordinate degrees of the +defining equation, so no degree-identification hypotheses remain. -/ +theorem planeCurve_auxiliaryFamily_linearIndependent_of_absoluteIrreducible_coordinateDegrees + {f : MvPolynomial (Fin 2) K} + (habsolute : Irreducible + (MvPolynomial.map (algebraMap K (AlgebraicClosure K)) f)) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) : + let hf : Irreducible f := by + simpa only [MvPolynomial.map_id] using + irreducible_map_of_irreducible_map_algebraicClosure + (RingHom.id K) f habsolute + letI := planeCurveCoordinateRing_isDomain hf + letI : CharP (PlaneCurveFunctionField f) p := + charP_of_injective_algebraMap + (algebraMap K (PlaneCurveFunctionField f)).injective p + ∀ (h k : ℕ), + 0 < h → 0 < k → + MvPolynomial.degreeOf 0 f * h + + MvPolynomial.degreeOf 1 f * k < p → + ¬ (MvPolynomial.degreeOf 0 f ≤ k ∧ + MvPolynomial.degreeOf 1 f ≤ h) → + LinearIndependent + (frobeniusSubfield (PlaneCurveFunctionField f) p) + (auxiliaryFamily + (planeCurveFunction f 0) (planeCurveFunction f 1) h k) := by + let hf : Irreducible f := by + simpa only [MvPolynomial.map_id] using + irreducible_map_of_irreducible_map_algebraicClosure + (RingHom.id K) f habsolute + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let : CharP (PlaneCurveFunctionField f) p := + charP_of_injective_algebraMap + (algebraMap K (PlaneCurveFunctionField f)).injective p + dsimp only + intro h k hh hk hsize hdegreeAlternativeExcluded + apply planeCurve_auxiliaryFamily_linearIndependent_of_absoluteIrreducible + (p := p) habsolute hpartialFirst hpartialSecond + (MvPolynomial.degreeOf 0 f) (MvPolynomial.degreeOf 1 f) h k + · exact degreeOf_first_pos_of_pderiv_ne_zero hpartialFirst + · exact hh + · exact hk + · exact planeCurveFrobeniusRelation_natDegree + (K := K) (L := PlaneCurveFunctionField f) (p := p) f + · exact transposeBivariate_planeCurveFrobeniusRelation_natDegree + (K := K) (L := PlaneCurveFunctionField f) (p := p) f + · exact hsize + · exact hdegreeAlternativeExcluded + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurveBidegreeBridge.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurveBidegreeBridge.lean new file mode 100644 index 0000000000..85a90c02c7 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurveBidegreeBridge.lean @@ -0,0 +1,103 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.AbsoluteIrreducibilityBaseChange +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveSeparability +public import LeanPool.MarkoffModP.BGS.External.GeneralCurveTheorems + +/-! +# From the public bidegree interface to function-field degrees + +The finite-field Corvaja--Zannier endpoint states its degree hypothesis +support-wise, through `BGS.External.HasBidegreeAtMost`. The function-field +development uses `MvPolynomial.degreeOf` and the degrees of the two coordinate +projections. This file records the exact, assumption-free bridge between +those two presentations. +-/ + +@[expose] public section + +namespace BGS.CorvajaZannier + +noncomputable section + +variable {K : Type*} [Field K] + +/-- The first coordinate degree is bounded by the first component of a +support-wise bidegree bound. -/ +theorem degreeOf_first_le_of_hasBidegreeAtMost + {f : MvPolynomial (Fin 2) K} {firstDegree secondDegree : ℕ} + (hdegree : BGS.External.HasBidegreeAtMost f firstDegree secondDegree) : + MvPolynomial.degreeOf 0 f ≤ firstDegree := by + rw [MvPolynomial.degreeOf_le_iff] + intro monomial hmonomial + exact (hdegree monomial hmonomial).1 + +/-- The second coordinate degree is bounded by the second component of a +support-wise bidegree bound. -/ +theorem degreeOf_second_le_of_hasBidegreeAtMost + {f : MvPolynomial (Fin 2) K} {firstDegree secondDegree : ℕ} + (hdegree : BGS.External.HasBidegreeAtMost f firstDegree secondDegree) : + MvPolynomial.degreeOf 1 f ≤ secondDegree := by + rw [MvPolynomial.degreeOf_le_iff] + intro monomial hmonomial + exact (hdegree monomial hmonomial).2 + +/-- Absolute irreducibility in the public plane-curve interface implies +irreducibility over the original constant field. -/ +theorem irreducible_of_irreducible_map_algebraicClosure + {f : MvPolynomial (Fin 2) K} + (habsolute : Irreducible + (MvPolynomial.map (algebraMap K (AlgebraicClosure K)) f)) : + Irreducible f := by + have h := irreducible_map_of_irreducible_map_algebraicClosure + (RingHom.id K) f habsolute + rw [MvPolynomial.map_id] at h + exact h + +/-- The degree of the first-coordinate projection of the plane-curve +function field is bounded by the supplied second bidegree. -/ +theorem finrank_over_firstCoordinate_le_of_hasBidegreeAtMost + {f : MvPolynomial (Fin 2) K} {firstDegree secondDegree : ℕ} + (habsolute : Irreducible + (MvPolynomial.map (algebraMap K (AlgebraicClosure K)) f)) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (hdegree : BGS.External.HasBidegreeAtMost f firstDegree secondDegree) : + letI := planeCurveCoordinateRing_isDomain + (irreducible_of_irreducible_map_algebraicClosure habsolute) + Module.finrank (FirstCoordinateSubfield f) (PlaneCurveFunctionField f) ≤ + secondDegree := by + let hf := irreducible_of_irreducible_map_algebraicClosure habsolute + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + exact (finrank_over_firstCoordinate_eq_degreeOf_second_of_irreducible + hf hpartialSecond).le.trans + (degreeOf_second_le_of_hasBidegreeAtMost hdegree) + +/-- The degree of the second-coordinate projection of the plane-curve +function field is bounded by the supplied first bidegree. -/ +theorem finrank_over_secondCoordinate_le_of_hasBidegreeAtMost + {f : MvPolynomial (Fin 2) K} {firstDegree secondDegree : ℕ} + (habsolute : Irreducible + (MvPolynomial.map (algebraMap K (AlgebraicClosure K)) f)) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (hdegree : BGS.External.HasBidegreeAtMost f firstDegree secondDegree) : + letI := planeCurveCoordinateRing_isDomain + (irreducible_of_irreducible_map_algebraicClosure habsolute) + Module.finrank (SecondCoordinateSubfield f) (PlaneCurveFunctionField f) ≤ + firstDegree := by + let hf := irreducible_of_irreducible_map_algebraicClosure habsolute + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + exact (finrank_over_secondCoordinate_eq_degreeOf_first_of_irreducible + hf hpartialFirst).le.trans + (degreeOf_first_le_of_hasBidegreeAtMost hdegree) + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurveBoundarySupport.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurveBoundarySupport.lean new file mode 100644 index 0000000000..0d29dd90e5 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurveBoundarySupport.lean @@ -0,0 +1,1020 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionPrincipalDivisor +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.InfinityInertiaDegree +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.DedekindLocalizationOrder +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveCoordinatePowerHeight +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveAuxiliaryFinitePlaceCases +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionOneSubGcdHeight +public import Mathlib.Tactic + +/-! +# Weighted boundary support for a plane curve + +This file proves the sharp coordinate-boundary estimate needed in the +Corvaja--Zannier middle game. The exhaustive places are defined using the +first-coordinate `RatFunc` model. To bound the positive divisor of the +second coordinate, each positive place is transported to the finite chart +of the second-coordinate model. The transport preserves both the normalized +valuation and the residue degree; injectivity then compares the two weighted +positive-divisor sums. + +The final theorem is stated directly for the zero/pole boundary +`propositionTwoExceptionalPlaces` of positive coordinate powers. +-/ + +@[expose] public section + +open scoped Polynomial +open IsDedekindDomain Multiplicative WithZero + +namespace BGS.CorvajaZannier + +universe u v + +noncomputable section + + +attribute [local instance high] Module.Free.of_divisionRing + +variable (K : Type u) [Field K] [DecidableEq K] [DecidableEq (RatFunc K)] +variable (L : Type v) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +local instance (priority := 10) probePolynomialAlgebra : Algebra K[X] L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K[X] (RatFunc K))) + +local instance probePolynomialScalarTower : IsScalarTower K[X] (RatFunc K) L := + .of_algebraMap_eq' rfl + +local instance probeFiniteConstantAlgebra : + Algebra K (RatFuncFiniteIntegralClosure K L) := + RingHom.toAlgebra ((algebraMap K[X] (RatFuncFiniteIntegralClosure K L)).comp + (algebraMap K K[X])) + +local instance probeFiniteConstantTower : + IsScalarTower K K[X] (RatFuncFiniteIntegralClosure K L) := + .of_algebraMap_eq' rfl + +local instance probeInfinityConstantAlgebra : + Algebra K (RatFuncInfinityIntegers K) := + (ratFuncInfinityConstantRingHom K).toAlgebra + +local instance probeInfinityConstantTower : + IsScalarTower K (RatFuncInfinityIntegers K) (RatFunc K) := + .of_algebraMap_eq' rfl + +local instance probeInfinityClosureConstantAlgebra : + Algebra K (RatFuncInfinityIntegralClosure K L) := + RingHom.toAlgebra + ((algebraMap (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L)).comp + (algebraMap K (RatFuncInfinityIntegers K))) + +local instance probeInfinityClosureConstantTower : + IsScalarTower K (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) := + .of_algebraMap_eq' rfl + +local instance probeFiniteIntegralClosureIsDedekindDomain : + IsDedekindDomain (RatFuncFiniteIntegralClosure K L) := + integralClosure.isDedekindDomain K[X] (RatFunc K) L + +local instance probeFiniteIntegralClosureIsFractionRing : + IsFractionRing (RatFuncFiniteIntegralClosure K L) L := + integralClosure.isFractionRing_of_finite_extension (RatFunc K) L + +local instance probeInfinityIntegralClosureIsDedekindDomain : + IsDedekindDomain (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.isDedekindDomain + (RatFuncInfinityIntegers K) (RatFunc K) L + (RatFuncInfinityIntegralClosure K L) + +local instance probeInfinityIntegralClosureIsFractionRing : + IsFractionRing (RatFuncInfinityIntegralClosure K L) L := + integralClosure.isFractionRing_of_finite_extension (RatFunc K) L + +/-- The normalized valuation on `L` represented by an exhaustive place. -/ +private noncomputable def probeFiniteExtensionPlaceValuation + (w : FiniteExtensionPlace K L) : + Valuation L (WithZero (Multiplicative ℤ)) := + match w with + | .inl q => q.valuation L + | .inr P => (primeOverHeightOne (ratFuncInfinityPlace K) P).valuation L + +omit [DecidableEq K] in +private theorem probeFiniteExtensionPlaceValuation_surjective + (w : FiniteExtensionPlace K L) : + Function.Surjective (probeFiniteExtensionPlaceValuation K L w) := by + intro z + cases w with + | inl q => + exact q.valuation_surjective L z + | inr P => + exact (primeOverHeightOne + (ratFuncInfinityPlace K) P).valuation_surjective L z + +omit [DecidableEq K] in +private theorem probeFiniteExtensionPlaceValuation_eq_exp_neg_order + (w : FiniteExtensionPlace K L) (x : L) (hx : x ≠ 0) : + probeFiniteExtensionPlaceValuation K L w x = + exp (-finiteExtensionPrincipalDivisor K L x w) := by + cases w with + | inl q => + have hord := fractionRingAlgEquiv_finitePlaceOrder_eq + (L := L) q + ((ratFuncFiniteIntegralClosureFractionRingEquiv K L).symm x) + have hord' : finitePlaceOrder q x = finitePlaceOrder q + ((ratFuncFiniteIntegralClosureFractionRingEquiv K L).symm x) := by + simpa [ratFuncFiniteIntegralClosureFractionRingEquiv] using hord + rw [finiteExtensionPrincipalDivisor_inl, ← hord'] + exact valuation_eq_exp_neg_finitePlaceOrder q x hx + | inr P => + have hord := fractionRingAlgEquiv_finitePlaceOrder_eq + (L := L) (primeOverHeightOne (ratFuncInfinityPlace K) P) + ((ratFuncInfinityIntegralClosureFractionRingEquiv K L).symm x) + have hord' : finitePlaceOrder + (primeOverHeightOne (ratFuncInfinityPlace K) P) x = + finitePlaceOrder (primeOverHeightOne (ratFuncInfinityPlace K) P) + ((ratFuncInfinityIntegralClosureFractionRingEquiv K L).symm x) := by + simpa [ratFuncInfinityIntegralClosureFractionRingEquiv] using hord + rw [finiteExtensionPrincipalDivisor_inr, ← hord'] + exact valuation_eq_exp_neg_finitePlaceOrder + (primeOverHeightOne (ratFuncInfinityPlace K) P) x hx + +omit [DecidableEq K] [DecidableEq (RatFunc K)] in +private theorem probe_finiteExtensionFinitePlace_X_le_one + (q : FiniteExtensionFinitePlace K L) : + q.valuation L (algebraMap (RatFunc K) L RatFunc.X) ≤ 1 := by + change q.valuation L (algebraMap K[X] L Polynomial.X) ≤ 1 + rw [IsScalarTower.algebraMap_apply K[X] + (RatFuncFiniteIntegralClosure K L) L] + exact q.valuation_le_one _ + +omit [DecidableEq K] in +private theorem probe_finiteExtensionInfinityPlace_X_gt_one + (P : FiniteExtensionInfinityPlace K L) : + 1 < (primeOverHeightOne (ratFuncInfinityPlace K) P).valuation L + (algebraMap (RatFunc K) L RatFunc.X) := by + let q := primeOverHeightOne (ratFuncInfinityPlace K) P + let pi := ratFuncInfinityUniformizer K + have hpiBase : pi ∈ (ratFuncInfinityPlace K).asIdeal := by + rw [ratFuncInfinityPlace_span_uniformizer] + exact Ideal.mem_span_singleton_self pi + have hpiP : algebraMap (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) pi ∈ P.1 := by + have hover : (ratFuncInfinityPlace K).asIdeal = Ideal.comap + (algebraMap (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L)) P.1 := by + exact Ideal.over_def P.1 (ratFuncInfinityPlace K).asIdeal + exact Ideal.mem_comap.mp (hover ▸ hpiBase) + have hpiLt : q.valuation L + (algebraMap (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) pi) < 1 := + (q.valuation_lt_one_iff_mem + (algebraMap (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) pi)).mpr hpiP + have hpiImage : algebraMap + (RatFuncInfinityIntegralClosure K L) L + (algebraMap (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) pi) = + (algebraMap (RatFunc K) L RatFunc.X)⁻¹ := by + change algebraMap (RatFunc K) L (1 / RatFunc.X) = + (algebraMap (RatFunc K) L RatFunc.X)⁻¹ + simp + have hxinverse : q.valuation L + (algebraMap (RatFunc K) L RatFunc.X)⁻¹ < 1 := by + rw [← hpiImage] + exact hpiLt + exact ((q.valuation L).one_lt_val_iff + (by + simpa using + (algebraMap (RatFunc K) L).injective.ne RatFunc.X_ne_zero)).mpr hxinverse + +omit [DecidableEq K] in +private theorem probeFiniteExtensionPlaceValuation_injective : + Function.Injective (probeFiniteExtensionPlaceValuation K L) := by + intro w₁ w₂ h + cases w₁ with + | inl q₁ => + cases w₂ with + | inl q₂ => + apply congrArg Sum.inl + apply HeightOneSpectrum.eq_of_valuation_isEquiv_valuation (K := L) + have hval : q₁.valuation L = q₂.valuation L := by + simpa [probeFiniteExtensionPlaceValuation] using h + rw [hval] + | inr P₂ => + exfalso + have hle := probe_finiteExtensionFinitePlace_X_le_one K L q₁ + have hgt := probe_finiteExtensionInfinityPlace_X_gt_one K L P₂ + have hval : q₁.valuation L = + (primeOverHeightOne (ratFuncInfinityPlace K) P₂).valuation L := by + simpa [probeFiniteExtensionPlaceValuation] using h + rw [← hval] at hgt + exact (not_lt_of_ge hle) hgt + | inr P₁ => + cases w₂ with + | inl q₂ => + exfalso + have hgt := probe_finiteExtensionInfinityPlace_X_gt_one K L P₁ + have hle := probe_finiteExtensionFinitePlace_X_le_one K L q₂ + have hval : + (primeOverHeightOne (ratFuncInfinityPlace K) P₁).valuation L = + q₂.valuation L := by + simpa [probeFiniteExtensionPlaceValuation] using h + rw [hval] at hgt + exact (not_lt_of_ge hle) hgt + | inr P₂ => + apply congrArg Sum.inr + apply Subtype.ext + have hval : + (primeOverHeightOne (ratFuncInfinityPlace K) P₁).valuation L = + (primeOverHeightOne (ratFuncInfinityPlace K) P₂).valuation L := by + simpa [probeFiniteExtensionPlaceValuation] using h + have hprime : + primeOverHeightOne (ratFuncInfinityPlace K) P₁ = + primeOverHeightOne (ratFuncInfinityPlace K) P₂ := by + apply HeightOneSpectrum.eq_of_valuation_isEquiv_valuation (K := L) + rw [hval] + exact congrArg HeightOneSpectrum.asIdeal hprime + +private theorem probeFiniteExtensionPlaceValuation_constant_le_one + [Algebra K L] [IsScalarTower K (RatFunc K) L] + (w : FiniteExtensionPlace K L) (c : K) : + probeFiniteExtensionPlaceValuation K L w (algebraMap K L c) ≤ 1 := by + cases w with + | inl q => + have hrepr : algebraMap K L c = + algebraMap (RatFuncFiniteIntegralClosure K L) L + (algebraMap K (RatFuncFiniteIntegralClosure K L) c) := by + rw [IsScalarTower.algebraMap_apply K (RatFunc K) L] + rfl + rw [hrepr] + exact q.valuation_le_one _ + | inr P => + have hrepr : algebraMap K L c = + algebraMap (RatFuncInfinityIntegralClosure K L) L + (algebraMap K (RatFuncInfinityIntegralClosure K L) c) := by + rw [IsScalarTower.algebraMap_apply K (RatFunc K) L] + rfl + rw [hrepr] + exact (primeOverHeightOne (ratFuncInfinityPlace K) P).valuation_le_one _ + +private noncomputable def residueFieldAlgEquivOfIdealEq + {I J : Ideal K[X]} [I.IsPrime] [J.IsPrime] (h : I = J) : + I.ResidueField ≃ₐ[K] J.ResidueField := by + subst J + exact AlgEquiv.refl + +section ResidueTransport + +variable {R F S E : Type*} + [CommRing R] [IsDedekindDomain R] [Field F] [Algebra R F] [IsFractionRing R F] + [CommRing S] [IsDedekindDomain S] [Field E] [Algebra S E] [IsFractionRing S E] + +private noncomputable def valuationSubringRingEquivOfComapEq + (V : ValuationSubring F) (W : ValuationSubring E) (e : F ≃+* E) + (h : W.comap e.toRingHom = V) : V ≃+* W where + toFun x := ⟨e x, by + change (x : F) ∈ W.comap e.toRingHom + rw [h] + exact x.2⟩ + invFun y := ⟨e.symm y, by + rw [← h] + change e (e.symm (y : E)) ∈ W + simp⟩ + left_inv x := Subtype.ext (e.symm_apply_apply x) + right_inv y := Subtype.ext (e.apply_symm_apply y) + map_mul' x y := Subtype.ext (map_mul e (x : F) (y : F)) + map_add' x y := Subtype.ext (map_add e (x : F) (y : F)) + +private noncomputable def heightOneSpectrumResidueFieldToValuationSubring + (q : HeightOneSpectrum R) : + q.asIdeal.ResidueField ≃+* + IsLocalRing.ResidueField + (IsDedekindDomain.HeightOneSpectrum.valuationSubringAtPrime F q) := + IsLocalRing.ResidueField.mapEquiv + (IsLocalization.algEquiv q.asIdeal.primeCompl + (Localization.AtPrime q.asIdeal) + (IsDedekindDomain.HeightOneSpectrum.valuationSubringAtPrime F q)).toRingEquiv + +private noncomputable def heightOneSpectrumResidueFieldRingEquivOfComapEq + (q : HeightOneSpectrum R) (r : HeightOneSpectrum S) (e : F ≃+* E) + (h : (IsDedekindDomain.HeightOneSpectrum.valuationSubringAtPrime E r).comap + e.toRingHom = + IsDedekindDomain.HeightOneSpectrum.valuationSubringAtPrime F q) : + q.asIdeal.ResidueField ≃+* r.asIdeal.ResidueField := + (heightOneSpectrumResidueFieldToValuationSubring q).trans <| + (IsLocalRing.ResidueField.mapEquiv + (valuationSubringRingEquivOfComapEq + (IsDedekindDomain.HeightOneSpectrum.valuationSubringAtPrime F q) + (IsDedekindDomain.HeightOneSpectrum.valuationSubringAtPrime E r) + e h)).trans + (heightOneSpectrumResidueFieldToValuationSubring r).symm + +end ResidueTransport + +private theorem finrank_eq_of_ringEquiv_of_finite_base + {k E F : Type*} [Field k] [Finite k] + [Field E] [Field F] [Algebra k E] [Algebra k F] + [FiniteDimensional k E] [FiniteDimensional k F] + (e : E ≃+* F) : Module.finrank k E = Module.finrank k F := by + let : Fintype k := Fintype.ofFinite k + apply Nat.pow_right_injective (a := Nat.card k) (by + rw [Nat.card_eq_fintype_card] + exact Nat.succ_le_iff.mpr Fintype.one_lt_card) + change Nat.card k ^ Module.finrank k E = + Nat.card k ^ Module.finrank k F + rw [← Module.natCard_eq_pow_finrank, + ← Module.natCard_eq_pow_finrank] + exact Nat.card_congr e.toEquiv + +/-- Equal normalized valuations have residue fields of the same degree over a finite base. -/ +private theorem residueFinrank_eq_of_valuation_eq + {k R S F : Type*} [Field k] [Finite k] + [CommRing R] [IsDedekindDomain R] [CommRing S] [IsDedekindDomain S] + [Field F] [Algebra R F] [IsFractionRing R F] + [Algebra S F] [IsFractionRing S F] + (q : HeightOneSpectrum R) (r : HeightOneSpectrum S) + [Algebra k q.asIdeal.ResidueField] [Algebra k r.asIdeal.ResidueField] + [Finite r.asIdeal.ResidueField] + (h : r.valuation F = q.valuation F) : + Module.finrank k r.asIdeal.ResidueField = Module.finrank k q.asIdeal.ResidueField := by + let e := heightOneSpectrumResidueFieldRingEquivOfComapEq q r (RingEquiv.refl F) (by + rw [IsDedekindDomain.HeightOneSpectrum.valuationSubringAtPrime_eq_valuationSubring, + IsDedekindDomain.HeightOneSpectrum.valuationSubringAtPrime_eq_valuationSubring] + ext z + change r.valuation F z ≤ 1 ↔ q.valuation F z ≤ 1 + rw [h]) + let : Finite q.asIdeal.ResidueField := Finite.of_injective e e.injective + let : FiniteDimensional k r.asIdeal.ResidueField := inferInstance + let : FiniteDimensional k q.asIdeal.ResidueField := inferInstance + exact (finrank_eq_of_ringEquiv_of_finite_base e).symm + +section ValuationCenter + +variable {R S F : Type*} [CommRing R] [IsDomain R] + [CommRing S] [Field F] + [Algebra R F] [Algebra R S] [Algebra S F] + [IsScalarTower R S F] [IsIntegralClosure S R F] + [IsDedekindDomain S] [IsFractionRing S F] + +private noncomputable def integralClosureToValuationSubring + (V : ValuationSubring F) + (hbase : ∀ r : R, algebraMap R F r ∈ V) : + S →+* V := by + letI : IsIntegrallyClosedIn V.toSubring F := + inferInstanceAs (IsIntegrallyClosedIn V F) + exact (Subring.inclusion ((Subring.integralClosure_le_iff).2 hbase)).comp + (IsIntegralClosure.equiv R S F (integralClosure R F)).toRingEquiv.toRingHom + +private def valuationCenterIdeal + (V : ValuationSubring F) + (hbase : ∀ r : R, algebraMap R F r ∈ V) : + Ideal S := + Ideal.comap (integralClosureToValuationSubring (S := S) V hbase) + (IsLocalRing.maximalIdeal V) + +omit [IsDomain R] [IsDedekindDomain S] [IsFractionRing S F] in +private theorem valuationCenterIdeal_isPrime + (V : ValuationSubring F) + (hbase : ∀ r : R, algebraMap R F r ∈ V) : + (valuationCenterIdeal (S := S) V hbase).IsPrime := by + exact Ideal.comap_isPrime _ _ + +omit [IsDomain R] [IsDedekindDomain S] in +private theorem valuationCenterIdeal_ne_bot_of_mem_nonunits + (V : ValuationSubring F) + (hbase : ∀ r : R, algebraMap R F r ∈ V) + (r : R) (hr0 : algebraMap R F r ≠ 0) + (hr : algebraMap R F r ∈ V.nonunits) : + valuationCenterIdeal (S := S) V hbase ≠ ⊥ := by + intro hbot + let a : S := algebraMap R S r + have ha0 : a ≠ 0 := by + intro ha + apply hr0 + have hval : algebraMap S F a = algebraMap S F 0 := + congrArg (fun z : S => algebraMap S F z) ha + rw [IsScalarTower.algebraMap_apply R S F] + simpa [a] using hval + have ha : a ∈ valuationCenterIdeal (S := S) V hbase := by + change integralClosureToValuationSubring (S := S) V hbase a ∈ + IsLocalRing.maximalIdeal V + rw [IsLocalRing.mem_maximalIdeal] + apply ValuationSubring.coe_mem_nonunits_iff.mp + all_goals + have hφa : + ((integralClosureToValuationSubring (S := S) V hbase a : V) : F) = + algebraMap S F a := + IsIntegralClosure.algebraMap_equiv R S F (integralClosure R F) a + have hSR : algebraMap S F a = algebraMap R F r := by + rw [IsScalarTower.algebraMap_apply R S F] + simpa only [hφa.trans hSR] using hr + rw [hbot] at ha + exact ha0 (Ideal.mem_bot.mp ha) + +private noncomputable def valuationCenterPlace + (V : ValuationSubring F) + (hbase : ∀ r : R, algebraMap R F r ∈ V) + (hne : valuationCenterIdeal (S := S) V hbase ≠ ⊥) : + HeightOneSpectrum S := + ⟨valuationCenterIdeal (S := S) V hbase, + valuationCenterIdeal_isPrime (S := S) V hbase, hne⟩ + +omit [IsDomain R] in +private theorem valuationSubringAt_valuationCenterPlace_le + (V : ValuationSubring F) + (hbase : ∀ r : R, algebraMap R F r ∈ V) + (hne : valuationCenterIdeal (S := S) V hbase ≠ ⊥) : + IsDedekindDomain.HeightOneSpectrum.valuationSubringAtPrime F + (valuationCenterPlace (S := S) V hbase hne) ≤ V := by + let q := valuationCenterPlace (S := S) V hbase hne + let φ : S →+* V := + integralClosureToValuationSubring (S := S) V hbase + rintro x ⟨a, s, hs, rfl⟩ + have hsNotMem : s ∉ q.asIdeal := hs + have hsUnit : IsUnit (φ s) := by + rw [← IsLocalRing.notMem_maximalIdeal] + exact hsNotMem + obtain ⟨u, hu⟩ := hsUnit + let t : V := φ a * ↑(u⁻¹) + have ht : algebraMap S F a * (algebraMap S F s)⁻¹ = (t : F) := by + dsimp only [t] + have hφa : ((φ a : V) : F) = algebraMap S F a := by + exact IsIntegralClosure.algebraMap_equiv R S F + (integralClosure R F) a + have hφs : ((φ s : V) : F) = algebraMap S F s := by + exact IsIntegralClosure.algebraMap_equiv R S F + (integralClosure R F) s + rw [← hφa, ← hφs, ← hu] + change ((φ a : V) : F) * ((((u : V) : F))⁻¹) = + ((φ a : V) : F) * (((↑(u⁻¹) : V) : F)) + congr 1 + exact (map_units_inv V.toSubring.subtype u).symm + rw [ht] + exact t.property + +omit [IsDomain R] in +private theorem valuationSubringAt_valuationCenterPlace_eq + (V : ValuationSubring F) + (hbase : ∀ r : R, algebraMap R F r ∈ V) + (hne : valuationCenterIdeal (S := S) V hbase ≠ ⊥) + (hV : V ≠ ⊤) : + IsDedekindDomain.HeightOneSpectrum.valuationSubringAtPrime F + (valuationCenterPlace (S := S) V hbase hne) = V := by + exact ValuationSubring.eq_of_le_of_ne_top _ + (valuationSubringAt_valuationCenterPlace_le (S := S) V hbase hne) hV + +end ValuationCenter + +include L in +omit [DecidableEq (RatFunc K)] [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] [Algebra.IsSeparable (RatFunc K) L] in +private theorem probe_ratFuncFinitePlaceDegree_eq_finrank_residue + (p : HeightOneSpectrum K[X]) : + Module.finrank K p.asIdeal.ResidueField = ratFuncFinitePlaceDegree p := by + let r := finitePlaceNormalizedPrime p + have hp : normalizedPrimeFinitePlace (K := K) r = p := by + exact normalizedPrimeFinitePlace_finitePlaceNormalizedPrime p + have hpIdeal : p.asIdeal = Ideal.span {(r : K[X])} := by + rw [← show (normalizedPrimeFinitePlace (K := K) r).asIdeal = p.asIdeal by + exact congrArg HeightOneSpectrum.asIdeal hp] + rfl + let : (Ideal.span {(r : K[X])}).IsPrime := + (normalizedPrimeFinitePlace (K := K) r).isPrime + let : (Ideal.span {(r : K[X])}).IsMaximal := + (inferInstance : (Ideal.span {(r : K[X])}).IsPrime).isMaximal (by + simpa only [ne_eq, Ideal.span_singleton_eq_bot] using r.property.1.ne_zero) + let ep := residueFieldAlgEquivOfIdealEq (K := K) hpIdeal + let e : (K[X] ⧸ Ideal.span {(r : K[X])}) ≃ₐ[K] + (Ideal.span {(r : K[X])}).ResidueField := + AlgEquiv.ofBijective + (IsScalarTower.toAlgHom K + (K[X] ⧸ Ideal.span {(r : K[X])}) + (Ideal.span {(r : K[X])}).ResidueField) + (Ideal.bijective_algebraMap_quotient_residueField _) + calc + Module.finrank K p.asIdeal.ResidueField = + Module.finrank K (Ideal.span {(r : K[X])}).ResidueField := + ep.toLinearEquiv.finrank_eq + _ = Module.finrank K (K[X] ⧸ Ideal.span {(r : K[X])}) := + e.toLinearEquiv.finrank_eq.symm + _ = (r : K[X]).natDegree := + (AdjoinRoot.powerBasis r.property.1.ne_zero).finrank + _ = ratFuncFinitePlaceDegree p := by + rw [ratFuncFinitePlaceDegree] + +private theorem probe_finiteExtensionPlaceDegree_inl_eq_finrank_residue + (q : FiniteExtensionFinitePlace K L) : + finiteExtensionPlaceDegree K L (.inl q) = + Module.finrank K q.asIdeal.ResidueField := by + let p := HeightOneSpectrum.under K[X] q + let : q.asIdeal.LiesOver p.asIdeal := ⟨rfl⟩ + let hLocalAlg := + Localization.AtPrime.algebraOfLiesOver p.asIdeal q.asIdeal + have : IsScalarTower K[X] (Localization.AtPrime p.asIdeal) + (Localization.AtPrime q.asIdeal) := inferInstance + rw [finiteExtensionPlaceDegree, Ideal.inertiaDeg_eq p.asIdeal q.asIdeal] + rw [← probe_ratFuncFinitePlaceDegree_eq_finrank_residue K L p] + rw [mul_comm, Module.finrank_mul_finrank] + +omit [FiniteDimensional (RatFunc K) L] [Algebra.IsSeparable (RatFunc K) L] in +private theorem probe_finiteExtensionPlaceDegree_inr_eq_finrank_residue + (P : FiniteExtensionInfinityPlace K L) : + finiteExtensionPlaceDegree K L (.inr P) = + Module.finrank K P.1.ResidueField := by + let p := (ratFuncInfinityPlace K).asIdeal + let hLocalAlg := Localization.AtPrime.algebraOfLiesOver p P.1 + have : IsScalarTower (RatFuncInfinityIntegers K) (Localization.AtPrime p) + (Localization.AtPrime P.1) := inferInstance + let : Algebra p.ResidueField P.1.ResidueField := + IsLocalRing.ResidueField.instAlgebra + let : IsScalarTower K p.ResidueField P.1.ResidueField := inferInstance + rw [finiteExtensionPlaceDegree, Ideal.inertiaDeg_eq p P.1] + have hbase : Module.finrank K p.ResidueField = 1 := + by simpa [p] using + (ratFuncInfinityPlaceResidueEquiv K).toLinearEquiv.finrank_eq + calc + Module.finrank p.ResidueField P.1.ResidueField = + 1 * Module.finrank p.ResidueField P.1.ResidueField := by simp + _ = Module.finrank K p.ResidueField * + Module.finrank p.ResidueField P.1.ResidueField := by rw [hbase] + _ = Module.finrank K P.1.ResidueField := + Module.finrank_mul_finrank K p.ResidueField P.1.ResidueField + +/-- The place degree is determined by any finite residue field with the same valuation. -/ +private theorem probe_placeDegree_eq_of_valuation_eq [Fintype K] + {S : Type*} [CommRing S] [IsDedekindDomain S] + [Algebra S L] [IsFractionRing S L] + (w : FiniteExtensionPlace K L) (q : HeightOneSpectrum S) + [Algebra K q.asIdeal.ResidueField] [Finite q.asIdeal.ResidueField] + (hq : q.valuation L = probeFiniteExtensionPlaceValuation K L w) : + finiteExtensionPlaceDegree K L w = Module.finrank K q.asIdeal.ResidueField := by + cases w with + | inl r => + rw [probe_finiteExtensionPlaceDegree_inl_eq_finrank_residue K L r] + exact (residueFinrank_eq_of_valuation_eq (k := K) r q hq).symm + | inr P => + rw [probe_finiteExtensionPlaceDegree_inr_eq_finrank_residue K L P] + exact (residueFinrank_eq_of_valuation_eq (k := K) + (primeOverHeightOne (ratFuncInfinityPlace K) P) q hq).symm + +private theorem weightedSum_le_of_injective + {α β : Type*} [DecidableEq α] [DecidableEq β] + (source : Finset α) (target : Finset β) (map : ↥source → β) + (sourceWeight : α → ℕ) (targetWeight : β → ℕ) + (injective : Function.Injective map) + (weight : ∀ x, targetWeight (map x) = sourceWeight x) + (membership : ∀ x, map x ∈ target) : + ∑ x ∈ source, sourceWeight x ≤ ∑ y ∈ target, targetWeight y := by + have imageSubset : source.attach.image map ⊆ target := by + intro y hy + obtain ⟨x, _, rfl⟩ := Finset.mem_image.mp hy + exact membership x + have imageSum : ∑ y ∈ source.attach.image map, targetWeight y = + ∑ x ∈ source, sourceWeight x := by + rw [Finset.sum_image] + · simp only [weight, Finset.sum_attach] + · intro x hx y hy hxy + exact injective hxy + rw [← imageSum] + exact Finset.sum_le_sum_of_subset imageSubset + +omit [DecidableEq K] [DecidableEq (RatFunc K)] in +private theorem finitePlace_of_valuation_positive + [Algebra K L] [IsScalarTower K (RatFunc K) L] + (y : L) (hy0 : y ≠ 0) (hpolyX : algebraMap K[X] L Polynomial.X = y) + (v : Valuation L (WithZero (Multiplicative ℤ))) + (hvsurj : Function.Surjective v) + (hvconst : ∀ c : K, v (algebraMap K L c) ≤ 1) + (hvylt : v y < 1) : + ∃ q : FiniteExtensionFinitePlace K L, q.valuation L = v := by + let V := v.valuationSubring + have hyV : y ∈ V := by + change v y ≤ 1 + exact le_of_lt hvylt + have hconstV : ∀ c : K, algebraMap K L c ∈ V := by + intro c + change v (algebraMap K L c) ≤ 1 + exact hvconst c + have hbase : ∀ P : K[X], algebraMap K[X] L P ∈ V := by + intro P + induction P using Polynomial.induction_on' with + | add P Q hP hQ => + rw [map_add] + exact add_mem hP hQ + | monomial n c => + rw [← Polynomial.C_mul_X_pow_eq_monomial, map_mul, map_pow, + hpolyX] + have hC : algebraMap K[X] L (Polynomial.C c) = + algebraMap K L c := by + change algebraMap (RatFunc K) L + (algebraMap K[X] (RatFunc K) (Polynomial.C c)) = + algebraMap K L c + rw [show algebraMap K[X] (RatFunc K) (Polynomial.C c) = + algebraMap K (RatFunc K) c by simp, + IsScalarTower.algebraMap_apply K (RatFunc K) L] + rw [hC] + exact mul_mem (hconstV c) (pow_mem hyV n) + have hyNonunit : algebraMap K[X] L Polynomial.X ∈ V.nonunits := by + rw [hpolyX, ValuationSubring.mem_nonunits_iff_exists_mem_maximalIdeal] + exact ⟨hyV, (Valuation.mem_maximalIdeal_iff (v := v)).mpr hvylt⟩ + have hcenterNe : valuationCenterIdeal + (S := RatFuncFiniteIntegralClosure K L) V hbase ≠ ⊥ := + valuationCenterIdeal_ne_bot_of_mem_nonunits + (S := RatFuncFiniteIntegralClosure K L) V hbase + Polynomial.X (by + rw [hpolyX] + exact hy0) hyNonunit + let q : FiniteExtensionFinitePlace K L := + valuationCenterPlace (S := RatFuncFiniteIntegralClosure K L) + V hbase hcenterNe + have hvNontrivial : v.IsNontrivial := + (Valuation.isNontrivial_iff_exists_lt_one v).mpr + ⟨y, hy0, hvylt⟩ + have hVne : V ≠ ⊤ := by + rw [ne_eq, Valuation.valuationSubring_eq_top_iff] + exact not_not_intro hvNontrivial + have hsubring : + IsDedekindDomain.HeightOneSpectrum.valuationSubringAtPrime L q = V := + valuationSubringAt_valuationCenterPlace_eq + (S := RatFuncFiniteIntegralClosure K L) + V hbase hcenterNe hVne + have hequiv : (q.valuation L).IsEquiv v := by + rw [Valuation.isEquiv_iff_valuationSubring, + ← IsDedekindDomain.HeightOneSpectrum.valuationSubringAtPrime_eq_valuationSubring] + exact hsubring + have hqval : q.valuation L = v := + valuation_eq_of_isEquiv_of_surjective hequiv + (q.valuation_surjective L) hvsurj + exact ⟨q, hqval⟩ + + +/-- An injective, degree-preserving transport of positive places bounds the positive degree. -/ +private theorem positiveDegree_le_of_valuation_transport + [Algebra K L] [IsScalarTower K (RatFunc K) L] + {W : Type*} (divisor : W →₀ ℤ) (degree₁ : W → ℕ) + (v₁ : W → Valuation L (WithZero (Multiplicative ℤ))) + (y : L) (hy0 : y ≠ 0) (hpolyX : algebraMap K[X] L Polynomial.X = y) + (hv₁surj : ∀ w, Function.Surjective (v₁ w)) + (hv₁y : ∀ w, v₁ w y = exp (-divisor w)) + (hv₁const : ∀ w c, v₁ w (algebraMap K L c) ≤ 1) + (hv₁inj : Function.Injective v₁) + (hdegree : ∀ w (q : FiniteExtensionFinitePlace K L), q.valuation L = v₁ w → + finiteExtensionPlaceDegree K L (.inl q) = degree₁ w) : + ∑ w ∈ divisor.support.filter (fun w => 0 < divisor w), + (divisor w).toNat * degree₁ w ≤ finiteExtensionPositiveDegree K L y := by + classical + let D₁ : W → ℤ := divisor + let S₁ := divisor.support.filter (fun w => 0 < D₁ w) + have hcenter : ∀ (w : W), 0 < D₁ w → + ∃ q : FiniteExtensionFinitePlace K L, + q.valuation L = v₁ w ∧ + finiteExtensionPlaceDegree K L (.inl q) = degree₁ w ∧ + finiteExtensionPrincipalDivisor K L y (.inl q) = D₁ w := by + intro w hw + change 0 < divisor w at hw + let v := v₁ w + have hvylt : v y < 1 := by + rw [hv₁y w, ← exp_zero, exp_lt_exp] + omega + obtain ⟨q, hqval⟩ := finitePlace_of_valuation_positive K L y hy0 hpolyX + v (hv₁surj w) (hv₁const w) hvylt + have hqOrderVal := probeFiniteExtensionPlaceValuation_eq_exp_neg_order + K L (.inl q) y hy0 + have horder : finiteExtensionPrincipalDivisor K L y (.inl q) = + D₁ w := by + change q.valuation L y = + exp (-finiteExtensionPrincipalDivisor K L y (.inl q)) at hqOrderVal + rw [hqval, hv₁y w] at hqOrderVal + have hneg := exp_injective hqOrderVal + change -D₁ w = _ at hneg + omega + refine ⟨q, hqval, ?_, horder⟩ + exact hdegree w q hqval + let T₁ := {w : W // w ∈ S₁} + let centerFinite : T₁ → FiniteExtensionFinitePlace K L := + fun w => Classical.choose + (hcenter w.1 (Finset.mem_filter.mp w.2).2) + have hcenterFiniteVal (w : T₁) : + (centerFinite w).valuation L = v₁ w.1 := by + exact (Classical.choose_spec + (hcenter w.1 (Finset.mem_filter.mp w.2).2)).1 + have hcenterFiniteDegree (w : T₁) : + finiteExtensionPlaceDegree K L (.inl (centerFinite w)) = + degree₁ w.1 := by + exact (Classical.choose_spec + (hcenter w.1 (Finset.mem_filter.mp w.2).2)).2.1 + have hcenterFiniteOrder (w : T₁) : + finiteExtensionPrincipalDivisor K L y + (.inl (centerFinite w)) = D₁ w.1 := by + exact (Classical.choose_spec + (hcenter w.1 (Finset.mem_filter.mp w.2).2)).2.2 + let W₂ := FiniteExtensionPlace K L + let D₂ : W₂ → ℤ := fun w => + finiteExtensionPrincipalDivisor K L y w + let degree₂ : W₂ → ℕ := fun w => + finiteExtensionPlaceDegree K L w + let center : T₁ → W₂ := fun w => .inl (centerFinite w) + have hcenterOrder (w : T₁) : D₂ (center w) = D₁ w.1 := by + exact hcenterFiniteOrder w + have hcenterDegree (w : T₁) : + degree₂ (center w) = degree₁ w.1 := by + exact hcenterFiniteDegree w + have hcenterInj : Function.Injective center := by + intro a b hab + have hcf : centerFinite a = centerFinite b := by + change Sum.inl (centerFinite a) = Sum.inl (centerFinite b) at hab + exact Sum.inl.inj hab + apply Subtype.ext + apply hv₁inj + rw [← hcenterFiniteVal a, ← hcenterFiniteVal b, hcf] + let S₂ := (finiteExtensionPrincipalDivisor K L y).support.filter + (fun w => 0 < D₂ w) + have hsource_le : + (∑ w ∈ S₁, (D₁ w).toNat * degree₁ w) ≤ + finiteExtensionPositiveDegree K L y := by + change _ ≤ ∑ z ∈ S₂, (D₂ z).toNat * degree₂ z + apply weightedSum_le_of_injective S₁ S₂ center + (fun w => (D₁ w).toNat * degree₁ w) + (fun z => (D₂ z).toNat * degree₂ z) hcenterInj + · intro w + rw [hcenterOrder, hcenterDegree] + · intro w + apply Finset.mem_filter.mpr + have hpos : 0 < D₁ w.1 := (Finset.mem_filter.mp w.2).2 + constructor + · apply Finsupp.mem_support_iff.mpr + change D₂ (center w) ≠ 0 + rw [hcenterOrder] + exact ne_of_gt hpos + · rw [hcenterOrder] + exact hpos + exact hsource_le + + + +/-- Passing to a second rational-function model cannot decrease the positive degree. -/ +private theorem positiveDegree_le_in_secondModel [Fintype K] + [Algebra K L] [IsScalarTower K (RatFunc K) L] + (second : RatFunc K →+* L) (y : L) (hy0 : y ≠ 0) : + let source := finiteExtensionPositiveDegree K L y + let : Algebra (RatFunc K) L := second.toAlgebra + ∀ (_ : FiniteDimensional (RatFunc K) L) (_ : Algebra.IsSeparable (RatFunc K) L) + (_ : IsScalarTower K (RatFunc K) L), + algebraMap K[X] L Polynomial.X = y → source ≤ finiteExtensionPositiveDegree K L y := by + classical + let W₁ := FiniteExtensionPlace K L + let divisor₁ : W₁ →₀ ℤ := + finiteExtensionPrincipalDivisor K L y + let D₁ : W₁ → ℤ := fun w => + divisor₁ w + let S₁ : Finset W₁ := divisor₁.support.filter + (fun w => 0 < D₁ w) + let degree₁ : W₁ → ℕ := fun w => + finiteExtensionPlaceDegree K L w + let v₁ : W₁ → Valuation L (WithZero (Multiplicative ℤ)) := + probeFiniteExtensionPlaceValuation K L + have hdegree₁ {S : Type v} [CommRing S] [IsDedekindDomain S] + [Algebra S L] [IsFractionRing S L] + (w : W₁) (q : HeightOneSpectrum S) + [Algebra K q.asIdeal.ResidueField] [Finite q.asIdeal.ResidueField] + (hq : q.valuation L = v₁ w) : + degree₁ w = Module.finrank K q.asIdeal.ResidueField := + probe_placeDegree_eq_of_valuation_eq K L w q hq + have hv₁surj : ∀ w : W₁, Function.Surjective (v₁ w) := by + intro w + exact probeFiniteExtensionPlaceValuation_surjective K L w + have hv₁y : ∀ w : W₁, + v₁ w y = exp (-D₁ w) := by + intro w + exact probeFiniteExtensionPlaceValuation_eq_exp_neg_order + K L w y hy0 + have hv₁const : ∀ (w : W₁) (c : K), + v₁ w (algebraMap K L c) ≤ 1 := by + intro w c + exact probeFiniteExtensionPlaceValuation_constant_le_one K L w c + have hv₁inj : Function.Injective v₁ := by + change Function.Injective + (probeFiniteExtensionPlaceValuation K L) + exact probeFiniteExtensionPlaceValuation_injective K L + intro source secondAlgebra finiteDimension separable tower hpolyX + have hdegreeCompare (w : W₁) (q : FiniteExtensionFinitePlace K L) + (hqval : q.valuation L = v₁ w) : + finiteExtensionPlaceDegree K L (.inl q) = degree₁ w := by + let : Finite q.asIdeal.ResidueField := + finiteExtensionFinitePlace_residueField_finite (K := K) (L := L) q + rw [probe_finiteExtensionPlaceDegree_inl_eq_finrank_residue K L q] + exact (hdegree₁ w q hqval).symm + have hsource_le : + (∑ w ∈ S₁, (D₁ w).toNat * degree₁ w) ≤ finiteExtensionPositiveDegree K L y := + positiveDegree_le_of_valuation_transport K L divisor₁ degree₁ v₁ y hy0 hpolyX + hv₁surj hv₁y hv₁const hv₁inj hdegreeCompare + change (∑ w ∈ S₁, (D₁ w).toNat * degree₁ w) ≤ _ + exact hsource_le + + + +end + +noncomputable section + +section PlaneBoundaryProbe + + +variable {K₀ : Type*} [Field K₀] [Fintype K₀] [DecidableEq K₀] + [DecidableEq (RatFunc K₀)] + +theorem finiteExtensionPositiveDegree_planeCurveSecondCoordinate_le_degreeOf_first + {f : MvPolynomial (Fin 2) K₀} (hf : Irreducible f) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) : + let := planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let := planeCurveFirstCoordinateRatFuncAlgebra f hx + let : FiniteDimensional (RatFunc K₀) (PlaneCurveFunctionField f) := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : Algebra.IsSeparable (RatFunc K₀) (PlaneCurveFunctionField f) := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + finiteExtensionPositiveDegree K₀ (PlaneCurveFunctionField f) + (planeCurveFunction f 1) ≤ MvPolynomial.degreeOf 0 f := by + intro domain hxTrans firstAlg finiteDimension separable + classical + let L₀ := PlaneCurveFunctionField f + let x : L₀ := planeCurveFunction f 0 + let y : L₀ := planeCurveFunction f 1 + have hyTrans : Transcendental K₀ y := + secondCoordinate_transcendental hf + (degreeOf_first_pos_of_pderiv_ne_zero hpartialFirst) + have hy0 : y ≠ 0 := by + intro h + apply hyTrans + rw [h] + exact isAlgebraic_zero + let : IsScalarTower K₀ (RatFunc K₀) L₀ := by + apply IsScalarTower.of_algebraMap_eq' + ext c + change algebraMap K₀ L₀ c = + ratFuncSpecialization x hxTrans (RatFunc.C c) + have h := DFunLike.congr_fun + (ratFuncSpecialization_comp_polynomial_algebraMap x hxTrans) + (Polynomial.C c) + simpa using h.symm + let secondHom : RatFunc K₀ →+* L₀ := ratFuncSpecialization y hyTrans + let sourceDegree := finiteExtensionPositiveDegree K₀ L₀ y + have hcompare := positiveDegree_le_in_secondModel K₀ L₀ secondHom y hy0 + let : Algebra (RatFunc K₀) L₀ := secondHom.toAlgebra + let : FiniteDimensional (RatFunc K₀) L₀ := + finiteDimensional_planeCurveFunctionField_over_secondRatFunc + hf hpartialFirst + let : Algebra.IsSeparable (RatFunc K₀) L₀ := + separable_planeCurveFunctionField_over_secondRatFunc hf hpartialFirst + let : IsScalarTower K₀ (RatFunc K₀) L₀ := by + apply IsScalarTower.of_algebraMap_eq' + ext c + change algebraMap K₀ L₀ c = + ratFuncSpecialization y hyTrans (RatFunc.C c) + have h := DFunLike.congr_fun + (ratFuncSpecialization_comp_polynomial_algebraMap y hyTrans) + (Polynomial.C c) + simpa using h.symm + let : Algebra K₀[X] L₀ := + RingHom.toAlgebra ((algebraMap (RatFunc K₀) L₀).comp + (algebraMap K₀[X] (RatFunc K₀))) + have hpolyX : algebraMap K₀[X] L₀ Polynomial.X = y := by + change ratFuncSpecialization y hyTrans RatFunc.X = y + simp [ratFuncSpecialization, RatFunc.algEquivOfTranscendental_X] + have hsource_le : sourceDegree ≤ finiteExtensionPositiveDegree K₀ L₀ y := + hcompare inferInstance inferInstance inferInstance hpolyX + have hySecondDegree : + finiteExtensionPositiveDegree K₀ L₀ y = + MvPolynomial.degreeOf 0 f := by + have hheight := finiteExtensionPositiveDegree_polynomial + K₀ L₀ Polynomial.X Polynomial.X_ne_zero + change finiteExtensionPositiveDegree K₀ L₀ + (algebraMap K₀[X] L₀ Polynomial.X) = + Module.finrank (RatFunc K₀) L₀ * + Polynomial.X.natDegree at hheight + rw [hpolyX, + finrank_planeCurveFunctionField_over_secondRatFunc_eq_degreeOf_first + hf hpartialFirst] at hheight + simpa using hheight + exact hsource_le.trans_eq hySecondDegree + +/-- The zero/pole boundary of positive powers of the two plane-curve +coordinates has degree at most twice the sum of the two coordinate degrees. -/ +theorem planeCurve_propositionTwoExceptionalPlaces_weightedDegree_le + {f : MvPolynomial (Fin 2) K₀} (hf : Irreducible f) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (m n : ℕ) (hm : 0 < m) (hn : 0 < n) : + let := planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let := planeCurveFirstCoordinateRatFuncAlgebra f hx + let := finiteDimensional_planeCurveFunctionField_over_ratFunc + hf hpartialSecond + let := separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + ∑ w ∈ propositionTwoExceptionalPlaces K₀ (PlaneCurveFunctionField f) + ((planeCurveFunction f 0) ^ m) ((planeCurveFunction f 1) ^ n), + finiteExtensionPlaceDegree K₀ (PlaneCurveFunctionField f) w ≤ + 2 * (MvPolynomial.degreeOf 0 f + MvPolynomial.degreeOf 1 f) := by + intro domain hxTrans ratFuncAlgebra finiteDimension separable + classical + let L₀ := PlaneCurveFunctionField f + let x : L₀ := planeCurveFunction f 0 + let y : L₀ := planeCurveFunction f 1 + have hyTrans : Transcendental K₀ y := + secondCoordinate_transcendental hf + (degreeOf_first_pos_of_pderiv_ne_zero hpartialFirst) + have hx0 : x ≠ 0 := by + intro h + apply hxTrans + change IsAlgebraic K₀ x + rw [h] + exact isAlgebraic_zero + have hy0 : y ≠ 0 := by + intro h + apply hyTrans + rw [h] + exact isAlgebraic_zero + have hxDegree : finiteExtensionPositiveDegree K₀ L₀ x = + MvPolynomial.degreeOf 1 f := by + have hheight := finiteExtensionPositiveDegree_polynomial + K₀ L₀ Polynomial.X Polynomial.X_ne_zero + have hmap : algebraMap (RatFunc K₀) L₀ + (algebraMap K₀[X] (RatFunc K₀) Polynomial.X) = x := by + change ratFuncSpecialization x hxTrans RatFunc.X = x + exact planeCurveFirstCoordinateRatFuncAlgebra_X f hxTrans + rw [hmap, + finrank_planeCurveFunctionField_over_ratFunc_eq_degreeOf_second + hf hpartialSecond] at hheight + simpa using hheight + have hyDegree : finiteExtensionPositiveDegree K₀ L₀ y ≤ + MvPolynomial.degreeOf 0 f := by + exact finiteExtensionPositiveDegree_planeCurveSecondCoordinate_le_degreeOf_first + hf hpartialFirst hpartialSecond + let _ : DecidableEq (FiniteExtensionPlace K₀ L₀) := fun a b => instDecidableEqSum a b + have hsupportX : + (finiteExtensionPrincipalDivisor K₀ L₀ (x ^ m)).support = + (finiteExtensionPrincipalDivisor K₀ L₀ x).support := by + rw [finiteExtensionPrincipalDivisor_pow K₀ L₀ x hx0 m] + ext w + simp [Finsupp.mem_support_iff, hm.ne'] + have hsupportY : + (finiteExtensionPrincipalDivisor K₀ L₀ (y ^ n)).support = + (finiteExtensionPrincipalDivisor K₀ L₀ y).support := by + rw [finiteExtensionPrincipalDivisor_pow K₀ L₀ y hy0 n] + ext w + simp [Finsupp.mem_support_iff, hn.ne'] + dsimp only [propositionTwoExceptionalPlaces] + change (∑ w ∈ + (finiteExtensionPrincipalDivisor K₀ L₀ (x ^ m)).support ∪ + (finiteExtensionPrincipalDivisor K₀ L₀ (y ^ n)).support, + finiteExtensionPlaceDegree K₀ L₀ w) ≤ + 2 * (MvPolynomial.degreeOf 0 f + MvPolynomial.degreeOf 1 f) + rw [hsupportX, hsupportY] + calc + _ ≤ + (∑ w ∈ (finiteExtensionPrincipalDivisor K₀ L₀ x).support, + finiteExtensionPlaceDegree K₀ L₀ w) + + ∑ w ∈ (finiteExtensionPrincipalDivisor K₀ L₀ y).support, + finiteExtensionPlaceDegree K₀ L₀ w := by + let s := (finiteExtensionPrincipalDivisor K₀ L₀ x).support + let t := (finiteExtensionPrincipalDivisor K₀ L₀ y).support + let g := fun w => finiteExtensionPlaceDegree K₀ L₀ w + calc + ∑ w ∈ s ∪ t, g w = + (∑ w ∈ s, g w) + ∑ w ∈ t \ s, g w := by + rw [show s ∪ t = s ∪ (t \ s) by ext i; simp, + Finset.sum_union Finset.disjoint_sdiff] + _ ≤ (∑ w ∈ s, g w) + ∑ w ∈ t, g w := by + exact Nat.add_le_add_left + (Finset.sum_le_sum_of_subset Finset.sdiff_subset) _ + _ ≤ 2 * finiteExtensionPositiveDegree K₀ L₀ x + + 2 * finiteExtensionPositiveDegree K₀ L₀ y := + Nat.add_le_add + (finiteExtensionPrincipalDivisor_supportDegree_le_two_mul_height + K₀ L₀ x hx0) + (finiteExtensionPrincipalDivisor_supportDegree_le_two_mul_height + K₀ L₀ y hy0) + _ ≤ 2 * (MvPolynomial.degreeOf 0 f + + MvPolynomial.degreeOf 1 f) := by + rw [hxDegree] + omega + +end PlaneBoundaryProbe + +end +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurveCanonicalDegreeBound.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurveCanonicalDegreeBound.lean new file mode 100644 index 0000000000..f9d01ce6de --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurveCanonicalDegreeBound.lean @@ -0,0 +1,238 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveFiniteDifferentBound +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveInfinityComplement +public import Mathlib.Tactic + +/-! +# The canonical different degree of a plane function field + +This module combines the sharp finite different bound with the complementary +bound above infinity. Keeping the actual polynomial discriminant as the +intermediate budget makes its degree cancel between the two contributions. +The result is the expected first-projection canonical bound + +`2 * degreeOf 0 f * degreeOf 1 f - 2 * degreeOf 0 f - 2 * degreeOf 1 f`. + +No algebraic closure of the constant field is assumed. +-/ + +@[expose] public section + +open scoped Polynomial nonZeroDivisors BigOperators +open Polynomial IsDedekindDomain + +namespace BGS.CorvajaZannier + +noncomputable section + +variable {K : Type*} [Field K] + +/-- Every bivariate polynomial has its tautological support-wise bidegree +bound given by its two `degreeOf` values. -/ +theorem hasBidegreeAtMost_degreeOf + (f : MvPolynomial (Fin 2) K) : + BGS.External.HasBidegreeAtMost f + (MvPolynomial.degreeOf 0 f) (MvPolynomial.degreeOf 1 f) := by + intro m hm + exact ⟨MvPolynomial.monomial_le_degreeOf 0 hm, + MvPolynomial.monomial_le_degreeOf 1 hm⟩ + +/-- The second-coordinate equation's discriminant satisfies the sharp +bidegree estimate at the curve's actual coordinate degrees. -/ +theorem planeCurvePolynomialInSecondCoordinate_discr_natDegree_le_degreeOf + (f : MvPolynomial (Fin 2) K) : + (planeCurvePolynomialInSecondCoordinate f).discr.natDegree ≤ + (2 * MvPolynomial.degreeOf 1 f - 2) * + MvPolynomial.degreeOf 0 f := by + exact planeCurvePolynomialInSecondCoordinate_discr_natDegree_le + (hasBidegreeAtMost_degreeOf f) + +variable [Fintype K] [DecidableEq K] [DecidableEq (RatFunc K)] + +omit [DecidableEq (RatFunc K)] in +/-- The sharp finite-different estimate implies the usual bidegree-only +finite discriminant budget. The canonical theorem below retains the sharper +intermediate discriminant so that it cancels against the infinity +complement. -/ +theorem planeCurve_finiteDifferentDegree_le_bidegreeDiscriminantBudget + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (hcardK : MvPolynomial.degreeOf 1 f < Fintype.card K) : + letI := planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + letI := planeCurveFirstCoordinateRatFuncAlgebra f hx + letI := finiteDimensional_planeCurveFunctionField_over_ratFunc + hf hpartialSecond + letI := separable_planeCurveFunctionField_over_ratFunc + hf hpartialSecond + finiteExtensionFiniteDifferentDegree K (PlaneCurveFunctionField f) + (finiteExtensionFiniteDifferentIdeal_ne_bot K + (PlaneCurveFunctionField f)) ≤ + (2 * MvPolynomial.degreeOf 1 f - 2) * + MvPolynomial.degreeOf 0 f := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let : Algebra (RatFunc K) (PlaneCurveFunctionField f) := + planeCurveFirstCoordinateRatFuncAlgebra f hx + let : FiniteDimensional (RatFunc K) (PlaneCurveFunctionField f) := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : Algebra.IsSeparable (RatFunc K) (PlaneCurveFunctionField f) := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + exact (planeCurve_finiteDifferentDegree_le_discrNatDegree + hf hpartialSecond hcardK).trans + (planeCurvePolynomialInSecondCoordinate_discr_natDegree_le_degreeOf f) + +/-- The canonical different divisor of the first-coordinate plane function +field has the sharp bidegree bound. -/ +theorem planeCurve_canonicalDifferentDivisor_degree_le + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (hcardK : MvPolynomial.degreeOf 1 f < Fintype.card K) : + let := planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let := planeCurveFirstCoordinateRatFuncAlgebra f hx + let := finiteDimensional_planeCurveFunctionField_over_ratFunc + hf hpartialSecond + let := separable_planeCurveFunctionField_over_ratFunc + hf hpartialSecond + finiteExtensionDivisorDegree K (PlaneCurveFunctionField f) + (finiteExtensionCanonicalDifferentDivisor K + (PlaneCurveFunctionField f) + (finiteExtensionFiniteDifferentIdeal_ne_bot K + (PlaneCurveFunctionField f))) ≤ + 2 * (MvPolynomial.degreeOf 0 f : ℤ) * + (MvPolynomial.degreeOf 1 f : ℤ) - + 2 * (MvPolynomial.degreeOf 0 f : ℤ) - + 2 * (MvPolynomial.degreeOf 1 f : ℤ) := by + intro domain hx ratFuncAlgebra finiteDimension separable + let L := PlaneCurveFunctionField f + let F : K[X][X] := planeCurvePolynomialInSecondCoordinate f + let firstDegree := MvPolynomial.degreeOf 0 f + let secondDegree := MvPolynomial.degreeOf 1 f + have hFne : F ≠ 0 := by + dsimp only [F] + simpa only [map_zero] using + (planeCurvePolynomialInSecondCoordinate (K := K)).injective.ne hf.ne_zero + have hsupport : F.support.Nonempty := + Polynomial.nonempty_support_iff.mpr hFne + let localFirstDegree : ℕ := + F.support.sup (fun i => (F.coeff i).natDegree) + obtain ⟨i, hiSupport, hiMax⟩ := Finset.exists_mem_eq_sup + F.support hsupport (fun i => (F.coeff i).natDegree) + have hFi : F.coeff i ≠ 0 := Polynomial.mem_support_iff.mp hiSupport + have hiDegree : (F.coeff i).natDegree = localFirstDegree := by + simpa only [localFirstDegree] using hiMax.symm + have hcoeff : ∀ j, (F.coeff j).natDegree ≤ localFirstDegree := by + intro j + by_cases hj : F.coeff j = 0 + · simp [hj] + · change (F.coeff j).natDegree ≤ + F.support.sup (fun i => (F.coeff i).natDegree) + exact Finset.le_sup (s := F.support) + (f := fun i : ℕ => (F.coeff i).natDegree) + (Polynomial.mem_support_iff.mpr hj) + have hlocalFirstDegree_le : localFirstDegree ≤ firstDegree := by + rw [← hiDegree] + exact planeCurvePolynomialInSecondCoordinate_coeff_natDegree_le_degreeOf_first + f i + let v : L := planeCurveFunction f 1 + have hrootF : Polynomial.aeval v + (F.map (algebraMap K[X] (RatFunc K))) = 0 := by + simpa only [F, v] using + aeval_planeCurvePolynomialInSecondCoordinate_ratFunc_eq_zero + hf hpartialSecond + have hrootNormalized : Polynomial.aeval v + (infinityNormalizedPolynomial K localFirstDegree F) = 0 := by + rw [infinityNormalizedPolynomial] + simp only [map_mul, aeval_C, hrootF, mul_zero] + let _ : SMul (RatFunc K) L := Algebra.toSMul + let _ : MulAction (RatFunc K) L := + (Algebra.toModule : Module (RatFunc K) L).toMulAction + have hrootIntegral : Polynomial.aeval v + (infinityNormalizedIntegralPolynomial K localFirstDegree F hcoeff) = 0 := by + have hmap := Polynomial.aeval_map_algebraMap (RatFunc K) v + (infinityNormalizedIntegralPolynomial K localFirstDegree F hcoeff) + rw [← hmap] + rw [infinityNormalizedIntegralPolynomial_map] + exact hrootNormalized + have hprimitive : Algebra.adjoin (RatFunc K) {v} = ⊤ := by + exact adjoin_secondCoordinate_over_firstRatFunc_eq_top + hf hpartialSecond + have hFnatDegree : F.natDegree = secondDegree := by + simp [F, secondDegree] + have hfinrank : Module.finrank (RatFunc K) L = secondDegree := + finrank_planeCurveFunctionField_over_ratFunc_eq_degreeOf_second + hf hpartialSecond + have hFdegree : F.natDegree = Module.finrank (RatFunc K) L := + hFnatDegree.trans hfinrank.symm + have hFdiscr : F.discr ≠ 0 := by + simpa only [F] using + planeCurvePolynomialInSecondCoordinate_discr_ne_zero + hf hpartialSecond + have hcard : (F.natDegree : Cardinal) < Cardinal.mk K := by + have hdegree : F.natDegree = secondDegree := by + simp [F, secondDegree] + rw [hdegree] + simpa only [secondDegree, Cardinal.mk_fintype, Nat.cast_lt] using hcardK + have hFinite : finiteExtensionFiniteDifferentDegree K L + (finiteExtensionFiniteDifferentIdeal_ne_bot K L) ≤ F.discr.natDegree := by + simpa only [F] using + planeCurve_finiteDifferentDegree_le_discrNatDegree + hf hpartialSecond hcardK + have hInfinity : (infinityDifferentDegree K L : ℤ) ≤ + (localFirstDegree * (2 * F.natDegree - 2) : ℕ) - + (F.discr.natDegree : ℤ) := + planeCurveInfinityDifferentDegree_le_bidegreeComplement + K L localFirstDegree F hcoeff i hFi hiDegree v + hrootIntegral hprimitive hFdegree hFdiscr hcard + have hCanonical := finiteExtensionCanonicalDifferentDivisor_degree_le_of_bounds + K L F.discr.natDegree + (localFirstDegree * (2 * F.natDegree - 2)) hFinite hInfinity + have hsecondPos : 0 < secondDegree := by + exact degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond + have htwo_le : 2 ≤ 2 * secondDegree := by omega + have hlocalFirstDegreeInt : (localFirstDegree : ℤ) ≤ firstDegree := by + exact_mod_cast hlocalFirstDegree_le + have hfactorNonneg : (0 : ℤ) ≤ 2 * (secondDegree : ℤ) - 2 := by + omega + have hmul : (localFirstDegree : ℤ) * + (2 * (secondDegree : ℤ) - 2) ≤ + (firstDegree : ℤ) * (2 * (secondDegree : ℤ) - 2) := + mul_le_mul_of_nonneg_right hlocalFirstDegreeInt hfactorNonneg + have hbudgetCast : + ((localFirstDegree * (2 * secondDegree - 2) : ℕ) : ℤ) = + (localFirstDegree : ℤ) * (2 * (secondDegree : ℤ) - 2) := by + rw [Nat.cast_mul, Nat.cast_sub htwo_le] + push_cast + rfl + calc + finiteExtensionDivisorDegree K L + (finiteExtensionCanonicalDifferentDivisor K L + (finiteExtensionFiniteDifferentIdeal_ne_bot K L)) ≤ + ((localFirstDegree * (2 * secondDegree - 2) : ℕ) : ℤ) - + 2 * (secondDegree : ℤ) := by + simpa only [hFnatDegree, hfinrank] using hCanonical + _ = (localFirstDegree : ℤ) * (2 * (secondDegree : ℤ) - 2) - + 2 * (secondDegree : ℤ) := by rw [hbudgetCast] + _ ≤ (firstDegree : ℤ) * (2 * (secondDegree : ℤ) - 2) - + 2 * (secondDegree : ℤ) := sub_le_sub_right hmul _ + _ = 2 * (MvPolynomial.degreeOf 0 f : ℤ) * + (MvPolynomial.degreeOf 1 f : ℤ) - + 2 * (MvPolynomial.degreeOf 0 f : ℤ) - + 2 * (MvPolynomial.degreeOf 1 f : ℤ) := by + dsimp only [firstDegree, secondDegree] + ring + +end +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurveCanonicalEulerBound.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurveCanonicalEulerBound.lean new file mode 100644 index 0000000000..125006cee6 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurveCanonicalEulerBound.lean @@ -0,0 +1,86 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveCanonicalDegreeBound +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveBoundarySupport +public import Mathlib.Tactic + +/-! +# The log-canonical degree budget for a plane curve + +This module combines the canonical-different estimate with the weighted +zero/pole boundary estimate. It is the exact geometric input `chi = 2ab` +used by the exhaustive-place form of Corvaja--Zannier Proposition 2. +-/ + +@[expose] public section + +open scoped Polynomial BigOperators + +namespace BGS.CorvajaZannier + +noncomputable section + +variable {K : Type*} [Field K] [Fintype K] [DecidableEq K] + [DecidableEq (RatFunc K)] + +/-- The canonical divisor together with the actual weighted zero/pole +boundary of positive coordinate powers has degree at most twice the product +of the two coordinate degrees. -/ +theorem planeCurve_canonicalDifferent_add_propositionTwoExceptional_weightedDegree_le + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (hcardK : MvPolynomial.degreeOf 1 f < Fintype.card K) + (m n : ℕ) (hm : 0 < m) (hn : 0 < n) : + letI := planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + letI := planeCurveFirstCoordinateRatFuncAlgebra f hx + letI := finiteDimensional_planeCurveFunctionField_over_ratFunc + hf hpartialSecond + letI := separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + finiteExtensionDivisorDegree K (PlaneCurveFunctionField f) + (finiteExtensionCanonicalDifferentDivisor K + (PlaneCurveFunctionField f) + (finiteExtensionFiniteDifferentIdeal_ne_bot K + (PlaneCurveFunctionField f))) + + (∑ w ∈ propositionTwoExceptionalPlaces K + (PlaneCurveFunctionField f) + ((planeCurveFunction f 0) ^ m) ((planeCurveFunction f 1) ^ n), + finiteExtensionPlaceDegree K (PlaneCurveFunctionField f) w : ℤ) ≤ + (2 * MvPolynomial.degreeOf 0 f * MvPolynomial.degreeOf 1 f : ℕ) := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let : Algebra (RatFunc K) (PlaneCurveFunctionField f) := + planeCurveFirstCoordinateRatFuncAlgebra f hx + let : FiniteDimensional (RatFunc K) (PlaneCurveFunctionField f) := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : Algebra.IsSeparable (RatFunc K) (PlaneCurveFunctionField f) := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + have hcanonical := planeCurve_canonicalDifferentDivisor_degree_le + hf hpartialSecond hcardK + have hboundary := + planeCurve_propositionTwoExceptionalPlaces_weightedDegree_le + hf hpartialFirst hpartialSecond m n hm hn + have hboundaryInt : + (∑ w ∈ propositionTwoExceptionalPlaces K + (PlaneCurveFunctionField f) + ((planeCurveFunction f 0) ^ m) ((planeCurveFunction f 1) ^ n), + finiteExtensionPlaceDegree K (PlaneCurveFunctionField f) w : ℤ) ≤ + 2 * ((MvPolynomial.degreeOf 0 f : ℤ) + + MvPolynomial.degreeOf 1 f) := by + exact_mod_cast hboundary + norm_num at hcanonical hboundaryInt ⊢ + omega + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurveCanonicalGcdBound.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurveCanonicalGcdBound.lean new file mode 100644 index 0000000000..e07d4c5cb1 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurveCanonicalGcdBound.lean @@ -0,0 +1,332 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionCanonicalGlobalNormalizedAutomatic +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurvePoweredHeightBounds +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PoweredCoordinates +public import Mathlib.Tactic + +/-! +# The canonical Corvaja--Zannier bound for powered plane coordinates + +This module composes the automatic canonical placewise estimate with the +first-coordinate model of a plane function field. Linear independence of +the auxiliary family supplies the Wronskian nonvanishing, while the two +powered-coordinate height theorems replace abstract positive divisor degrees +by the actual bidegree budgets. +-/ + +@[expose] public section + +namespace BGS.CorvajaZannier + +noncomputable section + +open scoped BigOperators Polynomial + +/-- The automatic canonical placewise estimate, specialized to +`u = x^m`, `v = y^n` on a plane curve and expressed using the actual +coordinate degrees. -/ +theorem finiteExtensionGcdBound_planeCurvePowers_of_auxiliaryFamily_linearIndependent + {K : Type*} [Field K] [Fintype K] [DecidableEq K] + {p : ℕ} [Fact p.Prime] [CharP K p] + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (m n : ℕ) (hm : 0 < m) (hn : 0 < n) + (h k : ℕ) (hcard : 0 < h * k + h + k) (chi : ℕ) : + letI : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + letI : DecidableEq (RatFunc K) := Classical.decEq _ + letI : Algebra (RatFunc K) (PlaneCurveFunctionField f) := + planeCurveFirstCoordinateRatFuncAlgebra f hx + letI : FiniteDimensional (RatFunc K) (PlaneCurveFunctionField f) := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + letI : Algebra.IsSeparable (RatFunc K) (PlaneCurveFunctionField f) := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + letI : CharP (PlaneCurveFunctionField f) p := + charP_of_injective_algebraMap + (algebraMap K (PlaneCurveFunctionField f)).injective p + LinearIndependent + (frobeniusSubfield (PlaneCurveFunctionField f) p) + (auxiliaryFamily ((planeCurveFunction f 0) ^ m) + ((planeCurveFunction f 1) ^ n) h k) → + finiteExtensionDivisorDegree K (PlaneCurveFunctionField f) + (finiteExtensionCanonicalDifferentDivisor K + (PlaneCurveFunctionField f) + (finiteExtensionFiniteDifferentIdeal_ne_bot K + (PlaneCurveFunctionField f))) + + (∑ P ∈ propositionTwoExceptionalPlaces K (PlaneCurveFunctionField f) + ((planeCurveFunction f 0) ^ m) ((planeCurveFunction f 1) ^ n), + finiteExtensionPlaceDegree K (PlaneCurveFunctionField f) P : ℤ) ≤ + (chi : ℤ) → + (finiteExtensionGcdWeightedDegree K (PlaneCurveFunctionField f) + (1 - (planeCurveFunction f 0) ^ m) + (1 - (planeCurveFunction f 1) ^ n) : ℝ) ≤ + ((h + 2 * k : ℕ) : ℝ) / ((h * k + h + k : ℕ) : ℝ) * + ((n * MvPolynomial.degreeOf 0 f : ℕ) : ℝ) + + (k : ℝ) / ((h * k + h + k : ℕ) : ℝ) * + ((m * MvPolynomial.degreeOf 1 f : ℕ) : ℝ) + + ((((h * k + h + k : ℕ) : ℝ) - 1) / 2) * (chi : ℝ) := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let : DecidableEq (RatFunc K) := Classical.decEq _ + let L := PlaneCurveFunctionField f + let x : L := planeCurveFunction f 0 + let y : L := planeCurveFunction f 1 + let : Algebra (RatFunc K) L := + planeCurveFirstCoordinateRatFuncAlgebra f hx + let : FiniteDimensional (RatFunc K) L := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : Algebra.IsSeparable (RatFunc K) L := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : CharP L p := charP_of_injective_algebraMap + (algebraMap K L).injective p + dsimp only + intro hLI hEuler + let F := frobeniusSubfield L p + have hxTrans : Transcendental K x := hx + have hyTrans : Transcendental K y := + secondCoordinate_transcendental hf + (degreeOf_first_pos_of_pderiv_ne_zero hpartialFirst) + have hx0 : x ≠ 0 := by + intro hzero + apply hxTrans + rw [hzero] + exact isAlgebraic_zero + have hy0 : y ≠ 0 := by + intro hzero + apply hyTrans + rw [hzero] + exact isAlgebraic_zero + have hxm0 : x ^ m ≠ 0 := pow_ne_zero m hx0 + have hyn0 : y ^ n ≠ 0 := pow_ne_zero n hy0 + have hxm1 : x ^ m ≠ 1 := by + intro hone + apply hxTrans.pow hm + rw [hone] + exact isAlgebraic_one + have hyn1 : y ^ n ≠ 1 := by + intro hone + apply hyTrans.pow hn + rw [hone] + exact isAlgebraic_one + have hsepX := + (finiteSeparable_over_firstCoordinate_of_irreducible + hf hpartialSecond).2 + let : Algebra.IsSeparable (FirstCoordinateSubfield f) L := hsepX + let : Algebra.IsSeparable (IntermediateField.adjoin F {x}) L := + isSeparable_over_frobeniusAdjoin_of_isSeparable_over_constantAdjoin + (K := K) (L := L) (p := p) x + have hxNot : x ∉ F := + firstCoordinate_not_mem_frobeniusSubfield hf hpartialSecond + obtain ⟨D, hDx, hconstants⟩ := + exists_derivation_with_exact_frobenius_constants (p := p) x hxNot + have hmapX : algebraMap (RatFunc K) L RatFunc.X = x := by + change ratFuncSpecialization x hx RatFunc.X = x + exact planeCurveFirstCoordinateRatFuncAlgebra_X f hx + have hDX : D (algebraMap (RatFunc K) L RatFunc.X) = 1 := by + rw [hmapX] + exact hDx + have hWronskian : + (indexedDedekindLocalWronskian D + (auxiliaryFamilyDerivativeOrder h k) + (auxiliaryFamily (x ^ m) (y ^ n) h k)).det ≠ 0 := by + exact indexedAuxiliaryWronskian_det_ne_zero_of_linearIndependent D + (fun z hz ↦ (hconstants z).mp hz) h k + (auxiliaryFamily (x ^ m) (y ^ n) h k) hLI + have hcanonical := + finiteExtensionGcdBound_of_normalizedCanonicalPlacewiseBounds + K L D hDX (x ^ m) (y ^ n) hxm0 hyn0 hxm1 hyn1 + h k hcard chi hWronskian hEuler + have hxDegree : finiteExtensionPositiveDegree K L (x ^ m) = + m * MvPolynomial.degreeOf 1 f := by + simpa only [L, x] using + finiteExtensionPositiveDegree_planeCurveFirstCoordinate_pow + hf hpartialSecond m hm + have hyDegree : finiteExtensionPositiveDegree K L (y ^ n) ≤ + n * MvPolynomial.degreeOf 0 f := by + simpa only [L, y] using + finiteExtensionPositiveDegree_planeCurveSecondCoordinate_pow_le + hf hpartialFirst hpartialSecond n + have hdenom : (0 : ℝ) < (h * k + h + k : ℕ) := by + exact_mod_cast hcard + have hfirstCoeff : + (0 : ℝ) ≤ ((h + 2 * k : ℕ) : ℝ) / + ((h * k + h + k : ℕ) : ℝ) := by positivity + calc + (finiteExtensionGcdWeightedDegree K L (1 - x ^ m) (1 - y ^ n) : ℝ) ≤ + ((h + 2 * k : ℕ) : ℝ) / ((h * k + h + k : ℕ) : ℝ) * + (finiteExtensionPositiveDegree K L (y ^ n) : ℝ) + + (k : ℝ) / ((h * k + h + k : ℕ) : ℝ) * + (finiteExtensionPositiveDegree K L (x ^ m) : ℝ) + + ((((h * k + h + k : ℕ) : ℝ) - 1) / 2) * (chi : ℝ) := hcanonical + _ ≤ ((h + 2 * k : ℕ) : ℝ) / ((h * k + h + k : ℕ) : ℝ) * + ((n * MvPolynomial.degreeOf 0 f : ℕ) : ℝ) + + (k : ℝ) / ((h * k + h + k : ℕ) : ℝ) * + ((m * MvPolynomial.degreeOf 1 f : ℕ) : ℝ) + + ((((h * k + h + k : ℕ) : ℝ) - 1) / 2) * (chi : ℝ) := by + rw [hxDegree] + gcongr + +/-- The companion specialization with the powered coordinates exchanged. +Here the leading coefficient multiplies the exact height of `x^m`, while the +second coefficient multiplies the degree budget for `y^n`. -/ +theorem finiteExtensionGcdBound_planeCurvePowers_swapped_of_auxiliaryFamily_linearIndependent + {K : Type*} [Field K] [Fintype K] [DecidableEq K] + {p : ℕ} [Fact p.Prime] [CharP K p] + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (m n : ℕ) (hm : 0 < m) (hn : 0 < n) + (h k : ℕ) (hcard : 0 < h * k + h + k) (chi : ℕ) : + letI : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + letI : DecidableEq (RatFunc K) := Classical.decEq _ + letI : Algebra (RatFunc K) (PlaneCurveFunctionField f) := + planeCurveFirstCoordinateRatFuncAlgebra f hx + letI : FiniteDimensional (RatFunc K) (PlaneCurveFunctionField f) := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + letI : Algebra.IsSeparable (RatFunc K) (PlaneCurveFunctionField f) := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + letI : CharP (PlaneCurveFunctionField f) p := + charP_of_injective_algebraMap + (algebraMap K (PlaneCurveFunctionField f)).injective p + LinearIndependent + (frobeniusSubfield (PlaneCurveFunctionField f) p) + (auxiliaryFamily ((planeCurveFunction f 1) ^ n) + ((planeCurveFunction f 0) ^ m) h k) → + finiteExtensionDivisorDegree K (PlaneCurveFunctionField f) + (finiteExtensionCanonicalDifferentDivisor K + (PlaneCurveFunctionField f) + (finiteExtensionFiniteDifferentIdeal_ne_bot K + (PlaneCurveFunctionField f))) + + (∑ P ∈ propositionTwoExceptionalPlaces K (PlaneCurveFunctionField f) + ((planeCurveFunction f 1) ^ n) ((planeCurveFunction f 0) ^ m), + finiteExtensionPlaceDegree K (PlaneCurveFunctionField f) P : ℤ) ≤ + (chi : ℤ) → + (finiteExtensionGcdWeightedDegree K (PlaneCurveFunctionField f) + (1 - (planeCurveFunction f 1) ^ n) + (1 - (planeCurveFunction f 0) ^ m) : ℝ) ≤ + ((h + 2 * k : ℕ) : ℝ) / ((h * k + h + k : ℕ) : ℝ) * + ((m * MvPolynomial.degreeOf 1 f : ℕ) : ℝ) + + (k : ℝ) / ((h * k + h + k : ℕ) : ℝ) * + ((n * MvPolynomial.degreeOf 0 f : ℕ) : ℝ) + + ((((h * k + h + k : ℕ) : ℝ) - 1) / 2) * (chi : ℝ) := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let : DecidableEq (RatFunc K) := Classical.decEq _ + let L := PlaneCurveFunctionField f + let x : L := planeCurveFunction f 0 + let y : L := planeCurveFunction f 1 + let : Algebra (RatFunc K) L := + planeCurveFirstCoordinateRatFuncAlgebra f hx + let : FiniteDimensional (RatFunc K) L := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : Algebra.IsSeparable (RatFunc K) L := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : CharP L p := charP_of_injective_algebraMap + (algebraMap K L).injective p + dsimp only + intro hLI hEuler + let F := frobeniusSubfield L p + have hxTrans : Transcendental K x := hx + have hyTrans : Transcendental K y := + secondCoordinate_transcendental hf + (degreeOf_first_pos_of_pderiv_ne_zero hpartialFirst) + have hx0 : x ≠ 0 := by + intro hzero + apply hxTrans + rw [hzero] + exact isAlgebraic_zero + have hy0 : y ≠ 0 := by + intro hzero + apply hyTrans + rw [hzero] + exact isAlgebraic_zero + have hxm0 : x ^ m ≠ 0 := pow_ne_zero m hx0 + have hyn0 : y ^ n ≠ 0 := pow_ne_zero n hy0 + have hxm1 : x ^ m ≠ 1 := by + intro hone + apply hxTrans.pow hm + rw [hone] + exact isAlgebraic_one + have hyn1 : y ^ n ≠ 1 := by + intro hone + apply hyTrans.pow hn + rw [hone] + exact isAlgebraic_one + have hsepX := + (finiteSeparable_over_firstCoordinate_of_irreducible + hf hpartialSecond).2 + let : Algebra.IsSeparable (FirstCoordinateSubfield f) L := hsepX + let : Algebra.IsSeparable (IntermediateField.adjoin F {x}) L := + isSeparable_over_frobeniusAdjoin_of_isSeparable_over_constantAdjoin + (K := K) (L := L) (p := p) x + have hxNot : x ∉ F := + firstCoordinate_not_mem_frobeniusSubfield hf hpartialSecond + obtain ⟨D, hDx, hconstants⟩ := + exists_derivation_with_exact_frobenius_constants (p := p) x hxNot + have hmapX : algebraMap (RatFunc K) L RatFunc.X = x := by + change ratFuncSpecialization x hx RatFunc.X = x + exact planeCurveFirstCoordinateRatFuncAlgebra_X f hx + have hDX : D (algebraMap (RatFunc K) L RatFunc.X) = 1 := by + rw [hmapX] + exact hDx + have hWronskian : + (indexedDedekindLocalWronskian D + (auxiliaryFamilyDerivativeOrder h k) + (auxiliaryFamily (y ^ n) (x ^ m) h k)).det ≠ 0 := by + exact indexedAuxiliaryWronskian_det_ne_zero_of_linearIndependent D + (fun z hz ↦ (hconstants z).mp hz) h k + (auxiliaryFamily (y ^ n) (x ^ m) h k) hLI + have hcanonical := + finiteExtensionGcdBound_of_normalizedCanonicalPlacewiseBounds + K L D hDX (y ^ n) (x ^ m) hyn0 hxm0 hyn1 hxm1 + h k hcard chi hWronskian hEuler + have hxDegree : finiteExtensionPositiveDegree K L (x ^ m) = + m * MvPolynomial.degreeOf 1 f := by + simpa only [L, x] using + finiteExtensionPositiveDegree_planeCurveFirstCoordinate_pow + hf hpartialSecond m hm + have hyDegree : finiteExtensionPositiveDegree K L (y ^ n) ≤ + n * MvPolynomial.degreeOf 0 f := by + simpa only [L, y] using + finiteExtensionPositiveDegree_planeCurveSecondCoordinate_pow_le + hf hpartialFirst hpartialSecond n + have hdenom : (0 : ℝ) < (h * k + h + k : ℕ) := by + exact_mod_cast hcard + have hsecondCoeff : + (0 : ℝ) ≤ (k : ℝ) / ((h * k + h + k : ℕ) : ℝ) := by + positivity + calc + (finiteExtensionGcdWeightedDegree K L (1 - y ^ n) (1 - x ^ m) : ℝ) ≤ + ((h + 2 * k : ℕ) : ℝ) / ((h * k + h + k : ℕ) : ℝ) * + (finiteExtensionPositiveDegree K L (x ^ m) : ℝ) + + (k : ℝ) / ((h * k + h + k : ℕ) : ℝ) * + (finiteExtensionPositiveDegree K L (y ^ n) : ℝ) + + ((((h * k + h + k : ℕ) : ℝ) - 1) / 2) * (chi : ℝ) := hcanonical + _ ≤ ((h + 2 * k : ℕ) : ℝ) / ((h * k + h + k : ℕ) : ℝ) * + ((m * MvPolynomial.degreeOf 1 f : ℕ) : ℝ) + + (k : ℝ) / ((h * k + h + k : ℕ) : ℝ) * + ((n * MvPolynomial.degreeOf 0 f : ℕ) : ℝ) + + ((((h * k + h + k : ℕ) : ℝ) - 1) / 2) * (chi : ℝ) := by + rw [hxDegree] + gcongr + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurveCharacteristicCardinality.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurveCharacteristicCardinality.lean new file mode 100644 index 0000000000..d77dba61a7 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurveCharacteristicCardinality.lean @@ -0,0 +1,99 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveSeparability +public import Mathlib.Algebra.CharP.CharAndCard +public import Mathlib.Tactic + +/-! +# Plane-curve degrees versus finite-field cardinality + +This file converts the characteristic bound used in the +Corvaja--Zannier argument into the finite-field cardinality bounds required +by the local reciprocal-discriminant and canonical Euler estimates. +-/ + +@[expose] public section + +namespace BGS.CorvajaZannier + +/-- The prime characteristic of a finite field is at most its cardinality. -/ +theorem prime_le_fintype_card_of_charP + {K : Type*} [Field K] [Fintype K] + (p : ℕ) [Fact p.Prime] [CharP K p] : + p ≤ Fintype.card K := by + apply Nat.le_of_dvd Fintype.card_pos + apply (prime_dvd_char_iff_dvd_card p).mp + rw [ringChar.eq K p] + +/-- If twelve times the product of the two coordinate degrees is smaller +than `p`, and both coordinate partial derivatives are nonzero, then each +coordinate degree is smaller than `p`. -/ +theorem planeCurve_coordinateDegrees_lt_char_of_twelve_mul_degrees_lt_char + {K : Type*} [Field K] + {f : MvPolynomial (Fin 2) K} {p : ℕ} + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (hbound : 12 * MvPolynomial.degreeOf 0 f * + MvPolynomial.degreeOf 1 f < p) : + MvPolynomial.degreeOf 0 f < p ∧ + MvPolynomial.degreeOf 1 f < p := by + have hfirst : 0 < MvPolynomial.degreeOf 0 f := + degreeOf_first_pos_of_pderiv_ne_zero hpartialFirst + have hsecond : 0 < MvPolynomial.degreeOf 1 f := + degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond + constructor <;> nlinarith + +/-- Under the characteristic-size hypothesis of the Corvaja--Zannier +application, both coordinate degrees are strictly smaller than the cardinality +of the finite constant field. -/ +theorem planeCurve_coordinateDegrees_lt_card_of_twelve_mul_degrees_lt_char + {K : Type*} [Field K] [Fintype K] + {f : MvPolynomial (Fin 2) K} {p : ℕ} + [Fact p.Prime] [CharP K p] + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (hbound : 12 * MvPolynomial.degreeOf 0 f * + MvPolynomial.degreeOf 1 f < p) : + MvPolynomial.degreeOf 0 f < Fintype.card K ∧ + MvPolynomial.degreeOf 1 f < Fintype.card K := by + have hpCard : p ≤ Fintype.card K := + prime_le_fintype_card_of_charP (K := K) p + exact And.imp (fun h => h.trans_le hpCard) (fun h => h.trans_le hpCard) + (planeCurve_coordinateDegrees_lt_char_of_twelve_mul_degrees_lt_char + hpartialFirst hpartialSecond hbound) + +/-- First-coordinate specialization of +`planeCurve_coordinateDegrees_lt_card_of_twelve_mul_degrees_lt_char`. -/ +theorem planeCurve_degreeOf_first_lt_card_of_twelve_mul_degrees_lt_char + {K : Type*} [Field K] [Fintype K] + {f : MvPolynomial (Fin 2) K} {p : ℕ} + [Fact p.Prime] [CharP K p] + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (hbound : 12 * MvPolynomial.degreeOf 0 f * + MvPolynomial.degreeOf 1 f < p) : + MvPolynomial.degreeOf 0 f < Fintype.card K := + (planeCurve_coordinateDegrees_lt_card_of_twelve_mul_degrees_lt_char + hpartialFirst hpartialSecond hbound).1 + +/-- Second-coordinate specialization of +`planeCurve_coordinateDegrees_lt_card_of_twelve_mul_degrees_lt_char`. -/ +theorem planeCurve_degreeOf_second_lt_card_of_twelve_mul_degrees_lt_char + {K : Type*} [Field K] [Fintype K] + {f : MvPolynomial (Fin 2) K} {p : ℕ} + [Fact p.Prime] [CharP K p] + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (hbound : 12 * MvPolynomial.degreeOf 0 f * + MvPolynomial.degreeOf 1 f < p) : + MvPolynomial.degreeOf 1 f < Fintype.card K := + (planeCurve_coordinateDegrees_lt_card_of_twelve_mul_degrees_lt_char + hpartialFirst hpartialSecond hbound).2 + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurveCoordinatePowerHeight.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurveCoordinatePowerHeight.lean new file mode 100644 index 0000000000..857e446a6e --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurveCoordinatePowerHeight.lean @@ -0,0 +1,133 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionPolynomialHeight +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveRatFuncModel + +/-! +# Exact heights of powered plane-curve coordinates + +The two rational-function-field models of a plane curve identify the base +variable `RatFunc.X` with the corresponding coordinate function. Combining +those models with the polynomial-height formula computes the positive degree +of the principal divisor of `x ^ m - 1` and `y ^ n - 1` exactly. +-/ + +@[expose] public section + +namespace BGS.CorvajaZannier + +noncomputable section + +variable {K : Type*} [Field K] [DecidableEq K] + [DecidableEq (RatFunc K)] + +/-- In the first-coordinate `RatFunc K` model, the positive principal-divisor +degree of `x ^ m - 1` is `m` times the degree of the curve equation in the +second coordinate. -/ +theorem finiteExtensionPositiveDegree_planeCurveFirstCoordinate_pow_sub_one + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (m : ℕ) (hm : 0 < m) : + letI := planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + letI := planeCurveFirstCoordinateRatFuncAlgebra f hx + letI := finiteDimensional_planeCurveFunctionField_over_ratFunc + hf hpartialSecond + letI := separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + finiteExtensionPositiveDegree K (PlaneCurveFunctionField f) + ((planeCurveFunction f 0) ^ m - 1) = + MvPolynomial.degreeOf 1 f * m := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let : Algebra (RatFunc K) (PlaneCurveFunctionField f) := + planeCurveFirstCoordinateRatFuncAlgebra f hx + let : FiniteDimensional (RatFunc K) (PlaneCurveFunctionField f) := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : Algebra.IsSeparable (RatFunc K) (PlaneCurveFunctionField f) := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + classical + let P : Polynomial K := Polynomial.X ^ m - 1 + have hP : P ≠ 0 := by + simpa [P] using + (Polynomial.X_pow_sub_C_ne_zero (R := K) hm (1 : K)) + have hheight := finiteExtensionPositiveDegree_polynomial + K (PlaneCurveFunctionField f) P hP + have hmap : + algebraMap (RatFunc K) (PlaneCurveFunctionField f) + (algebraMap (Polynomial K) (RatFunc K) P) = + (planeCurveFunction f 0) ^ m - 1 := by + simp only [map_sub, map_pow, RatFunc.algebraMap_X, map_one, + planeCurveFirstCoordinateRatFuncAlgebra_algebraMap_apply, Fin.isValue, sub_left_inj, P] + rw [show ratFuncSpecialization (planeCurveFunction f 0) hx RatFunc.X = + planeCurveFunction f 0 by + exact planeCurveFirstCoordinateRatFuncAlgebra_X f hx] + rw [hmap, + finrank_planeCurveFunctionField_over_ratFunc_eq_degreeOf_second + hf hpartialSecond, + show P.natDegree = m by + simpa [P] using (Polynomial.natDegree_X_pow_sub_C + (R := K) (n := m) (r := 1))] + at hheight + exact hheight + +/-- In the second-coordinate `RatFunc K` model, the positive +principal-divisor degree of `y ^ n - 1` is `n` times the degree of the curve +equation in the first coordinate. -/ +theorem finiteExtensionPositiveDegree_planeCurveSecondCoordinate_pow_sub_one + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (n : ℕ) (hn : 0 < n) : + letI := planeCurveCoordinateRing_isDomain hf + let hy := secondCoordinate_transcendental hf + (degreeOf_first_pos_of_pderiv_ne_zero hpartialFirst) + letI := planeCurveSecondCoordinateRatFuncAlgebra f hy + letI := finiteDimensional_planeCurveFunctionField_over_secondRatFunc + hf hpartialFirst + letI := separable_planeCurveFunctionField_over_secondRatFunc hf hpartialFirst + finiteExtensionPositiveDegree K (PlaneCurveFunctionField f) + ((planeCurveFunction f 1) ^ n - 1) = + MvPolynomial.degreeOf 0 f * n := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let hy := secondCoordinate_transcendental hf + (degreeOf_first_pos_of_pderiv_ne_zero hpartialFirst) + let : Algebra (RatFunc K) (PlaneCurveFunctionField f) := + planeCurveSecondCoordinateRatFuncAlgebra f hy + let : FiniteDimensional (RatFunc K) (PlaneCurveFunctionField f) := + finiteDimensional_planeCurveFunctionField_over_secondRatFunc + hf hpartialFirst + let : Algebra.IsSeparable (RatFunc K) (PlaneCurveFunctionField f) := + separable_planeCurveFunctionField_over_secondRatFunc hf hpartialFirst + classical + let P : Polynomial K := Polynomial.X ^ n - 1 + have hP : P ≠ 0 := by + simpa [P] using + (Polynomial.X_pow_sub_C_ne_zero (R := K) hn (1 : K)) + have hheight := finiteExtensionPositiveDegree_polynomial + K (PlaneCurveFunctionField f) P hP + have hmap : + algebraMap (RatFunc K) (PlaneCurveFunctionField f) + (algebraMap (Polynomial K) (RatFunc K) P) = + (planeCurveFunction f 1) ^ n - 1 := by + simp [P] + rw [hmap, + finrank_planeCurveFunctionField_over_secondRatFunc_eq_degreeOf_first + hf hpartialFirst, + show P.natDegree = n by + simpa [P] using (Polynomial.natDegree_X_pow_sub_C + (R := K) (n := n) (r := 1))] + at hheight + exact hheight + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurveDiagonalStabilizer.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurveDiagonalStabilizer.lean new file mode 100644 index 0000000000..d06e1bf29e --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurveDiagonalStabilizer.lean @@ -0,0 +1,199 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.TorusCharacterKernelBound +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveLogarithmicGauss +public import Mathlib.Tactic + +/-! +# Diagonal stabilizers of plane curves + +Describe diagonal scaling through polynomial coefficients and relate curve stabilizers to +characters of the support. +-/ + +@[expose] public section + +namespace BGS.CorvajaZannier +noncomputable section + +/-- Scale the two variables of a bivariate polynomial by a pair of units. -/ +def diagonalScale {F : Type*} [Field F] + (z : Fˣ × Fˣ) (f : MvPolynomial (Fin 2) F) := + f.support.sum fun m => + MvPolynomial.monomial m + (f.coeff m * (z.1 : F) ^ m 0 * (z.2 : F) ^ m 1) + +theorem coeff_diagonalScale {F : Type*} [Field F] + (z : Fˣ × Fˣ) (f : MvPolynomial (Fin 2) F) + (m : Fin 2 →₀ ℕ) : + (diagonalScale z f).coeff m = + f.coeff m * (z.1 : F) ^ m 0 * (z.2 : F) ^ m 1 := by + classical + by_cases hm : m ∈ f.support + · simp [diagonalScale, + MvPolynomial.coeff_monomial, hm] + · have hcoeff : f.coeff m = 0 := + MvPolynomial.notMem_support_iff.mp hm + simp [diagonalScale, + MvPolynomial.coeff_monomial, hm, hcoeff] + +theorem support_diagonalScale {F : Type*} [Field F] + (z : Fˣ × Fˣ) (f : MvPolynomial (Fin 2) F) : + (diagonalScale z f).support = f.support := by + ext m + simp only [MvPolynomial.mem_support_iff, coeff_diagonalScale] + constructor + · exact fun h => left_ne_zero_of_mul (left_ne_zero_of_mul h) + · intro h + exact mul_ne_zero + (mul_ne_zero h (pow_ne_zero _ (Units.ne_zero z.1))) + (pow_ne_zero _ (Units.ne_zero z.2)) + +theorem eval₂_diagonalScale {F L : Type*} [Field F] [Field L] + (φ : F →+* L) (z : Fˣ × Fˣ) + (x y : L) (f : MvPolynomial (Fin 2) F) : + MvPolynomial.eval₂ φ ![x, y] (diagonalScale z f) = + MvPolynomial.eval₂ φ ![φ z.1 * x, φ z.2 * y] f := by + classical + change (MvPolynomial.eval₂Hom φ ![x, y]) (diagonalScale z f) = + (MvPolynomial.eval₂Hom φ ![φ z.1 * x, φ z.2 * y]) f + rw [diagonalScale, map_sum] + conv_rhs => rw [f.as_sum, map_sum] + apply Finset.sum_congr rfl + intro m hm + have hprod (v : Fin 2 → L) : + m.prod (fun i k => v i ^ k) = v 0 ^ m 0 * v 1 ^ m 1 := by + rw [m.prod_fintype (fun i k => v i ^ k) (fun _ => pow_zero _), + Fin.prod_univ_two] + simp only [MvPolynomial.eval₂Hom_monomial, map_mul, map_pow, + hprod, Matrix.cons_val_zero, Matrix.cons_val_one, mul_pow] + ring + +private theorem eq_C_coeff_zero_of_bidegree_zero + {F : Type*} [Field F] (g : MvPolynomial (Fin 2) F) + (h0 : MvPolynomial.degreeOf 0 g = 0) + (h1 : MvPolynomial.degreeOf 1 g = 0) : + g = MvPolynomial.C (g.coeff 0) := by + ext m + by_cases hm : m = 0 + · subst m + simp + · have hcoordinate : m 0 ≠ 0 ∨ m 1 ≠ 0 := by + by_contra h + push Not at h + apply hm + ext i + fin_cases i <;> simp_all + have hmnot : m ∉ g.support := by + intro hmem + rcases hcoordinate with hm0 | hm1 + · have := MvPolynomial.le_degreeOf_of_mem_support 0 hmem + omega + · have := MvPolynomial.le_degreeOf_of_mem_support 1 hmem + omega + rw [MvPolynomial.notMem_support_iff.mp hmnot] + have hm' : (0 : Fin 2 →₀ ℕ) ≠ m := Ne.symm hm + simp [hm'] + +/-- A diagonal scaling divisible by the original polynomial differs from it by +a scalar. Equality of supports is what rules out a nonconstant quotient. -/ +theorem diagonalScale_eq_C_mul_of_dvd + {F : Type*} [Field F] {f : MvPolynomial (Fin 2) F} + (hf : f ≠ 0) (z : Fˣ × Fˣ) + (hdvd : f ∣ diagonalScale z f) : + ∃ c : F, diagonalScale z f = MvPolynomial.C c * f := by + obtain ⟨g, hg⟩ := hdvd + have hscale : diagonalScale z f ≠ 0 := by + intro h + have hs := support_diagonalScale z f + rw [h, MvPolynomial.support_zero] at hs + exact hf (MvPolynomial.support_eq_empty.mp hs.symm) + have hg0 : g ≠ 0 := by + intro h + apply hscale + rw [hg, h, mul_zero] + have hdegree (i : Fin 2) : + MvPolynomial.degreeOf i (diagonalScale z f) = + MvPolynomial.degreeOf i f := by + apply le_antisymm <;> rw [MvPolynomial.degreeOf_le_iff] + · intro m hm + exact MvPolynomial.le_degreeOf_of_mem_support i + (support_diagonalScale z f ▸ hm) + · intro m hm + exact MvPolynomial.le_degreeOf_of_mem_support i + (support_diagonalScale z f ▸ hm) + have hgDegree0 : MvPolynomial.degreeOf 0 g = 0 := by + have h := hdegree 0 + rw [hg, MvPolynomial.degreeOf_mul_eq hf hg0] at h + omega + have hgDegree1 : MvPolynomial.degreeOf 1 g = 0 := by + have h := hdegree 1 + rw [hg, MvPolynomial.degreeOf_mul_eq hf hg0] at h + omega + let c := g.coeff 0 + have hgC : g = MvPolynomial.C c := + eq_C_coeff_zero_of_bidegree_zero g hgDegree0 hgDegree1 + refine ⟨c, ?_⟩ + rw [hg, hgC, mul_comm] + +/-- If a diagonal scaling of an irreducible plane curve vanishes at its generic +point, the scaling lies in the character stabilizer detected by its support. -/ +theorem planeCurveSupportCharacterStabilizer_of_diagonalScale_eval_zero + {F : Type*} [Field F] {f : MvPolynomial (Fin 2) F} + (hf : Irreducible f) (z : Fˣ × Fˣ) + (heval : + letI := planeCurveCoordinateRing_isDomain hf + MvPolynomial.eval₂ (algebraMap F (PlaneCurveFunctionField f)) + (planeCurveFunction f) (diagonalScale z f) = 0) : + ∀ r ∈ f.support, ∀ s ∈ f.support, + z.1 ^ ((s 0 : ℤ) - (r 0 : ℤ)) * + z.2 ^ ((s 1 : ℤ) - (r 1 : ℤ)) = 1 := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + have hquotient : planeCurveQuotientMap f (diagonalScale z f) = 0 := by + apply IsFractionRing.injective + (PlaneCurveCoordinateRing f) (PlaneCurveFunctionField f) + rw [map_zero] + change ((algebraMap (PlaneCurveCoordinateRing f) + (PlaneCurveFunctionField f)).comp (planeCurveQuotientMap f)) + (diagonalScale z f) = 0 + rw [← eval₂_planeCurveFunction f] + exact heval + have hdvd : f ∣ diagonalScale z f := + Ideal.mem_span_singleton.mp + (Ideal.Quotient.eq_zero_iff_mem.mp hquotient) + obtain ⟨c, hc⟩ := diagonalScale_eq_C_mul_of_dvd hf.ne_zero z hdvd + intro r hr s hs + have hweight (m : Fin 2 →₀ ℕ) (hm : m ∈ f.support) : + (z.1 : F) ^ m 0 * (z.2 : F) ^ m 1 = c := by + have hcoeff := congrArg (fun p ↦ p.coeff m) hc + rw [coeff_diagonalScale] at hcoeff + simp only [MvPolynomial.coeff_C_mul] at hcoeff + have hm0 : f.coeff m ≠ 0 := + MvPolynomial.mem_support_iff.mp hm + exact mul_left_cancel₀ hm0 + (by simpa [mul_comm, mul_left_comm, mul_assoc] using hcoeff) + have hwField : + (z.1 : F) ^ s 0 * (z.2 : F) ^ s 1 = + (z.1 : F) ^ r 0 * (z.2 : F) ^ r 1 := by + rw [hweight s hs, hweight r hr] + have hwUnits : z.1 ^ s 0 * z.2 ^ s 1 = z.1 ^ r 0 * z.2 ^ r 1 := by + apply Units.ext + exact hwField + calc + z.1 ^ ((s 0 : ℤ) - (r 0 : ℤ)) * + z.2 ^ ((s 1 : ℤ) - (r 1 : ℤ)) = + (z.1 ^ s 0 * z.2 ^ s 1) * + (z.1 ^ r 0 * z.2 ^ r 1)⁻¹ := by + simp only [zpow_sub, zpow_natCast, mul_inv_rev] + ac_rfl + _ = 1 := by rw [hwUnits]; simp + +end +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurveDiscriminantBound.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurveDiscriminantBound.lean new file mode 100644 index 0000000000..76d20a42cc --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurveDiscriminantBound.lean @@ -0,0 +1,225 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.BivariateResultant +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveBidegreeBridge + +/-! +# A sharp degree bound for a bivariate discriminant + +For a polynomial `F` in one variable whose coefficients are polynomials of degree at most +`a`, this file proves that the discriminant of `F` has degree at most +`(2 * F.natDegree - 2) * a` in the coefficient variable. The missing two copies of `a` +relative to the naive Sylvester-determinant estimate come from the constant bottom row in +Mathlib's modified Sylvester matrix for the derivative. + +This is the algebraic degree estimate needed in the Corvaja--Zannier canonical/divisor +calculation. +-/ + +@[expose] public section + +namespace BGS.CorvajaZannier + +noncomputable section + +variable {K : Type*} [Field K] + +theorem natDegree_sylvesterDeriv_apply_le_of_row_ne + (F : Polynomial (Polynomial K)) (a : ℕ) + (hcoeff : ∀ i, (F.coeff i).natDegree ≤ a) + (i j : Fin (F.natDegree - 1 + F.natDegree)) + (hi : (i : ℕ) ≠ 2 * F.natDegree - 2) : + (F.sylvesterDeriv i j).natDegree ≤ a := by + rw [Polynomial.sylvesterDeriv] + split_ifs with hn + · simp + · rw [Matrix.updateRow_ne (Fin.ne_of_val_ne hi)] + induction j using Fin.addCases with + | left j => + simp only [Polynomial.sylvester, Matrix.of_apply, Fin.addCases_left] + split_ifs + · exact hcoeff _ + · simp + | right j => + simp only [Polynomial.sylvester, Matrix.of_apply, Fin.addCases_right] + split_ifs + · rw [Polynomial.coeff_derivative] + have hconstant : + ((↑((i : ℕ) - (j : ℕ)) : Polynomial K) + 1).natDegree = 0 := by + apply Nat.eq_zero_of_le_zero + exact (Polynomial.natDegree_add_le _ _).trans (by simp) + calc + (F.coeff ((i : ℕ) - (j : ℕ) + 1) * + ((↑((i : ℕ) - (j : ℕ)) : Polynomial K) + 1)).natDegree ≤ + (F.coeff ((i : ℕ) - (j : ℕ) + 1)).natDegree + + ((↑((i : ℕ) - (j : ℕ)) : Polynomial K) + 1).natDegree := + Polynomial.natDegree_mul_le + _ ≤ a + 0 := add_le_add (hcoeff _) hconstant.le + _ = a := by omega + · simp + +theorem natDegree_sylvesterDeriv_apply_bottom + (F : Polynomial (Polynomial K)) (hF : 0 < F.natDegree) + (j : Fin (F.natDegree - 1 + F.natDegree)) : + (F.sylvesterDeriv ⟨2 * F.natDegree - 2, by omega⟩ j).natDegree = 0 := by + rw [Polynomial.sylvesterDeriv, dite_eq_right hF.ne'] + rw [Matrix.updateRow_self] + split_ifs <;> simp + +/-- The discriminant of a degree-`b` polynomial whose coefficients have degree at most +`a` has degree at most `(2 * b - 2) * a`. -/ +theorem natDegree_discr_le + (F : Polynomial (Polynomial K)) (a : ℕ) + (hcoeff : ∀ i, (F.coeff i).natDegree ≤ a) : + F.discr.natDegree ≤ (2 * F.natDegree - 2) * a := by + by_cases hF : F.natDegree = 0 + · rw [Polynomial.eq_C_of_natDegree_eq_zero hF, Polynomial.discr_C] + simp + have hFpos : 0 < F.natDegree := Nat.pos_of_ne_zero hF + let bottom : Fin (F.natDegree - 1 + F.natDegree) := + ⟨2 * F.natDegree - 2, by omega⟩ + let rowDegree : Fin (F.natDegree - 1 + F.natDegree) → ℕ := fun i => + if i = bottom then 0 else a + have hmatrix : ∀ i j, + ((F.sylvesterDeriv.transpose) i j).natDegree ≤ rowDegree j := by + intro i j + simp only [Matrix.transpose_apply] + by_cases hj : j = bottom + · subst j + simp only [rowDegree, ↓reduceIte] + exact (natDegree_sylvesterDeriv_apply_bottom F hFpos i).le + · rw [show rowDegree j = a by simp [rowDegree, hj]] + exact natDegree_sylvesterDeriv_apply_le_of_row_ne F a hcoeff j i (by + intro heq + apply hj + apply Fin.ext + simpa [bottom] using heq) + have hdet : F.sylvesterDeriv.det.natDegree ≤ ∑ j, rowDegree j := by + rw [← Matrix.det_transpose] + exact Matrix.natDegree_det_le_sum_columnDegree _ rowDegree hmatrix + have hsum : ∑ j, rowDegree j = + (F.natDegree - 1 + F.natDegree - 1) * a := by + rw [← Finset.sum_erase_add _ _ (Finset.mem_univ bottom)] + have hbottom : rowDegree bottom = 0 := by simp [rowDegree] + rw [hbottom, add_zero] + calc + ∑ x ∈ Finset.univ.erase bottom, rowDegree x = + ∑ x ∈ Finset.univ.erase bottom, a := by + apply Finset.sum_congr rfl + intro x hx + have hne : x ≠ bottom := (Finset.mem_erase.mp hx).1 + simp [rowDegree, hne] + _ = (F.natDegree - 1 + F.natDegree - 1) * a := by + rw [Finset.sum_const, nsmul_eq_mul, + Finset.card_erase_of_mem (Finset.mem_univ bottom)] + simp + have hindex : F.natDegree - 1 + F.natDegree - 1 = + 2 * F.natDegree - 2 := by omega + rw [Polynomial.discr] + calc + (F.sylvesterDeriv.det * + (-1) ^ (F.natDegree * (F.natDegree - 1) / 2)).natDegree ≤ + F.sylvesterDeriv.det.natDegree + + ((-1 : Polynomial K) ^ + (F.natDegree * (F.natDegree - 1) / 2)).natDegree := + Polynomial.natDegree_mul_le + _ ≤ (∑ j, rowDegree j) + 0 := add_le_add hdet (by simp) + _ = (F.natDegree - 1 + F.natDegree - 1) * a := by rw [hsum]; omega + _ = (2 * F.natDegree - 2) * a := by rw [hindex] + +/-- View a bivariate polynomial as a polynomial in coordinate `1`, with ordinary +polynomial coefficients in coordinate `0`. -/ +def planeCurvePolynomialInSecondCoordinate : + MvPolynomial (Fin 2) K ≃ₐ[K] Polynomial (Polynomial K) := + (MvPolynomial.renameEquiv K (Equiv.swap (0 : Fin 2) 1)).trans + ((MvPolynomial.finSuccEquiv K 1).trans + (Polynomial.mapAlgEquiv (MvPolynomial.uniqueAlgEquiv K (Fin 1)))) + +theorem natDegree_uniqueAlgEquiv_le_degreeOf + {σ : Type*} [Unique σ] (P : MvPolynomial σ K) : + (MvPolynomial.uniqueAlgEquiv K σ P).natDegree ≤ + MvPolynomial.degreeOf default P := by + rw [Polynomial.natDegree_le_iff_coeff_eq_zero] + intro N hN + rw [MvPolynomial.coeff_uniqueAlgEquiv] + by_contra hcoeff + have hmem : Finsupp.single (default : σ) N ∈ P.support := + MvPolynomial.mem_support_iff.mpr hcoeff + have hle := MvPolynomial.monomial_le_degreeOf (default : σ) hmem + exact (not_le_of_gt hN) (by simpa using hle) + +@[simp] +theorem planeCurvePolynomialInSecondCoordinate_natDegree + (f : MvPolynomial (Fin 2) K) : + (planeCurvePolynomialInSecondCoordinate f).natDegree = + MvPolynomial.degreeOf 1 f := by + rw [planeCurvePolynomialInSecondCoordinate] + change (Polynomial.map (MvPolynomial.uniqueAlgEquiv K (Fin 1)).toRingHom + (MvPolynomial.finSuccEquiv K 1 + (MvPolynomial.rename (Equiv.swap (0 : Fin 2) 1) f))).natDegree = _ + rw [Polynomial.natDegree_map_eq_of_injective + (MvPolynomial.uniqueAlgEquiv K (Fin 1)).injective] + rw [MvPolynomial.natDegree_finSuccEquiv] + simpa using MvPolynomial.degreeOf_rename_of_injective + (Equiv.swap (0 : Fin 2) 1).injective (1 : Fin 2) (p := f) + +theorem planeCurvePolynomialInSecondCoordinate_coeff_natDegree_le_degreeOf_first + (f : MvPolynomial (Fin 2) K) (i : ℕ) : + ((planeCurvePolynomialInSecondCoordinate f).coeff i).natDegree ≤ + MvPolynomial.degreeOf 0 f := by + rw [planeCurvePolynomialInSecondCoordinate] + change ((Polynomial.map (MvPolynomial.uniqueAlgEquiv K (Fin 1)).toRingHom + (MvPolynomial.finSuccEquiv K 1 + (MvPolynomial.rename (Equiv.swap (0 : Fin 2) 1) f))).coeff i).natDegree ≤ _ + rw [Polynomial.coeff_map] + calc + (MvPolynomial.uniqueAlgEquiv K (Fin 1) + ((MvPolynomial.finSuccEquiv K 1 + (MvPolynomial.rename (Equiv.swap (0 : Fin 2) 1) f)).coeff i)).natDegree ≤ + MvPolynomial.degreeOf (0 : Fin 1) + ((MvPolynomial.finSuccEquiv K 1 + (MvPolynomial.rename (Equiv.swap (0 : Fin 2) 1) f)).coeff i) := + natDegree_uniqueAlgEquiv_le_degreeOf _ + _ ≤ MvPolynomial.degreeOf (Fin.succ (0 : Fin 1)) + (MvPolynomial.rename (Equiv.swap (0 : Fin 2) 1) f) := + MvPolynomial.degreeOf_coeff_finSuccEquiv _ _ _ + _ = MvPolynomial.degreeOf 0 f := by + simpa using MvPolynomial.degreeOf_rename_of_injective + (Equiv.swap (0 : Fin 2) 1).injective (0 : Fin 2) (p := f) + +theorem planeCurvePolynomialInSecondCoordinate_coeff_natDegree_le + {f : MvPolynomial (Fin 2) K} {firstDegree secondDegree : ℕ} + (hdegree : BGS.External.HasBidegreeAtMost f firstDegree secondDegree) + (i : ℕ) : + ((planeCurvePolynomialInSecondCoordinate f).coeff i).natDegree ≤ firstDegree := + (planeCurvePolynomialInSecondCoordinate_coeff_natDegree_le_degreeOf_first f i).trans + (degreeOf_first_le_of_hasBidegreeAtMost hdegree) + +/-- The discriminant in the first coordinate of a plane curve of bidegree at most +`(firstDegree, secondDegree)` has the sharp degree bound +`(2 * secondDegree - 2) * firstDegree`. -/ +theorem planeCurvePolynomialInSecondCoordinate_discr_natDegree_le + {f : MvPolynomial (Fin 2) K} {firstDegree secondDegree : ℕ} + (hdegree : BGS.External.HasBidegreeAtMost f firstDegree secondDegree) : + (planeCurvePolynomialInSecondCoordinate f).discr.natDegree ≤ + (2 * secondDegree - 2) * firstDegree := by + calc + (planeCurvePolynomialInSecondCoordinate f).discr.natDegree ≤ + (2 * (planeCurvePolynomialInSecondCoordinate f).natDegree - 2) * + firstDegree := + natDegree_discr_le _ _ + (planeCurvePolynomialInSecondCoordinate_coeff_natDegree_le hdegree) + _ ≤ (2 * secondDegree - 2) * firstDegree := by + gcongr + rw [planeCurvePolynomialInSecondCoordinate_natDegree] + exact degreeOf_second_le_of_hasBidegreeAtMost hdegree + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurveExhaustiveGcdEndpoint.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurveExhaustiveGcdEndpoint.lean new file mode 100644 index 0000000000..68a945c517 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurveExhaustiveGcdEndpoint.lean @@ -0,0 +1,84 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.EndpointComposition +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.TorsionExhaustiveGcdDivisorBound + +/-! +# Exhaustive gcd divisor at the plane-curve endpoint + +This module converts the exhaustive, degree-weighted gcd divisor into the +certificate expected by the public Corvaja--Zannier endpoint. The sharp +bidegree fiber count supplies the certificate's elementary upper bound, while +the injection of rational torsion points into the exhaustive divisor lets us +transfer Proposition 2 downward to the actual torsion-point cardinality. +-/ + +@[expose] public section + +namespace BGS.CorvajaZannier + +noncomputable section + +/-- The exhaustive weighted gcd divisor supplies a Proposition 2 certificate. + +The certificate uses the actual torsion-point cardinality as its gcd quantity. +The bidegree estimate gives its trivial bound, and monotonicity transfers the +Proposition 2 alternatives from the larger exhaustive weighted gcd degree. -/ +theorem planeCurvePropositionTwoCertificate_of_exhaustiveGcdWeightedDegree_and_bidegree + {K : Type*} [Field K] [Fintype K] [DecidableEq K] + {f : MvPolynomial (Fin 2) K} + (p firstDegree secondDegree firstOrder secondOrder : ℕ) + (hf : Irreducible f) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (hbidegree : BGS.External.HasBidegreeAtMost + f firstDegree secondDegree) + (hcurve : BGS.External.IsCorvajaZannierPlaneCurve f) + (hfirstOrder : 0 < firstOrder) (hsecondOrder : 0 < secondOrder) + (hfirstNonzero : planeCurveFunction f 0 ^ firstOrder - 1 ≠ 0) + (hsecondNonzero : planeCurveFunction f 1 ^ secondOrder - 1 ≠ 0) + (hpropositionTwo : PropositionTwoNumericalAlternatives + (planeCurveTorsionLowerDegree + firstDegree secondDegree firstOrder secondOrder) + (planeCurveTorsionUpperDegree + firstDegree secondDegree firstOrder secondOrder) + p (2 * firstDegree * secondDegree) + (planeCurveExhaustiveTorsionGcdWeightedDegree + hf hpartialSecond firstOrder secondOrder : ℝ)) : + PlaneCurvePropositionTwoCertificate + p K f firstDegree secondDegree firstOrder secondOrder := by + let card : ℕ := + (BGS.External.torusCurveTorsionIntersection + K f firstOrder secondOrder).card + let gcdDegree : ℕ := + planeCurveExhaustiveTorsionGcdWeightedDegree + hf hpartialSecond firstOrder secondOrder + have hcardTrivial : card ≤ planeCurveTorsionLowerDegree + firstDegree secondDegree firstOrder secondOrder := by + dsimp only [card, planeCurveTorsionLowerDegree] + simpa only [min_comm] using + torusCurveTorsionIntersection_card_le_min_bidegree_order + f firstDegree secondDegree firstOrder secondOrder + hbidegree hcurve hfirstOrder hsecondOrder + have hcardGcd : card ≤ gcdDegree := by + dsimp only [card, gcdDegree] + rw [torusCurveTorsionIntersection_card_eq_torsionPoint_card] + exact torsionPoint_card_le_planeCurveExhaustiveTorsionGcdWeightedDegree + hf hpartialSecond firstOrder secondOrder + hfirstNonzero hsecondNonzero + refine ⟨(card : ℝ), le_rfl, ?_, ?_⟩ + · exact_mod_cast hcardTrivial + · apply propositionTwoNumericalAlternatives_mono + (G := (card : ℝ)) (H := (gcdDegree : ℝ)) + · exact_mod_cast hcardGcd + · simpa only [gcdDegree] using hpropositionTwo + +end + + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurveFiniteDifferentBound.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurveFiniteDifferentBound.lean new file mode 100644 index 0000000000..c794a25fc5 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurveFiniteDifferentBound.lean @@ -0,0 +1,820 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionCanonicalDifferentDivisor +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveAuxiliaryFinitePlace +public import Mathlib.RingTheory.Localization.Integral +public import Mathlib.Tactic + +/-! +# The sharp finite different bound for a plane curve + +This file bounds the residue-weighted finite different of the plane function +field by the discriminant degree of the original second-coordinate equation. +The key local step chooses a reciprocal primitive element separately at each +base prime; a prime-unit denominator-clearing argument then compares its +minimal-polynomial discriminant with the global different. +-/ + +@[expose] public section + +open scoped Polynomial nonZeroDivisors BigOperators +open Polynomial IsDedekindDomain + +namespace BGS.CorvajaZannier + +noncomputable section + +theorem adjoin_smul_eq_top_of_adjoin_eq_top + {K L : Type*} [Field K] [Field L] [Algebra K L] + [Algebra.IsAlgebraic K L] + (r : K) (hr : r ≠ 0) (z : L) + (hz : Algebra.adjoin K {z} = ⊤) : + Algebra.adjoin K {r • z} = ⊤ := by + apply (IntermediateField.adjoin_eq_top_iff).mp + have hz' : IntermediateField.adjoin K {z} = + (⊤ : IntermediateField K L) := + (IntermediateField.adjoin_eq_top_iff).mpr hz + apply top_unique + rw [← hz'] + apply IntermediateField.adjoin_simple_le_iff.mpr + let H := IntermediateField.adjoin K {r • z} + have hxmem : r • z ∈ H := + IntermediateField.mem_adjoin_simple_self K (r • z) + have hmem : algebraMap K L (r⁻¹) * (r • z) ∈ H := + mul_mem (IntermediateField.algebraMap_mem H (r⁻¹)) hxmem + have heq : z = algebraMap K L (r⁻¹) * (r • z) := by + simp [Algebra.smul_def, hr] + exact Eq.mpr (congrArg (fun x : L => x ∈ H) heq) hmem + +theorem minpoly_discr_ne_zero_of_adjoin_eq_top + {K L : Type*} [Field K] [Field L] [Algebra K L] + [FiniteDimensional K L] [Algebra.IsSeparable K L] + (z : L) (hz : Algebra.adjoin K {z} = ⊤) : + (minpoly K z).discr ≠ 0 := by + let pb : PowerBasis K L := + PowerBasis.ofAdjoinEqTop' (Algebra.IsIntegral.isIntegral z) hz + have hgen : pb.gen = z := PowerBasis.ofAdjoinEqTop'_gen _ _ + have hdisc := discr_powerBasis_eq_minpoly_discr pb + rw [hgen] at hdisc + rw [← hdisc] + exact Algebra.discr_not_zero_of_basis K pb.basis + +theorem powerBasis_discr_smul_eq_diagonal_det_sq_mul + {K L : Type*} [Field K] [Field L] [Algebra K L] + (r : K) (z : L) (pbz pbx : PowerBasis K L) + (hgenZ : pbz.gen = z) (hgenX : pbx.gen = r • z) : + Algebra.discr K pbx.basis = + (Matrix.diagonal (fun i : Fin pbx.dim => r ^ (i : ℕ))).det ^ 2 * + Algebra.discr K pbz.basis := by + have hdim : pbx.dim = pbz.dim := pbx.finrank.symm.trans pbz.finrank + let e : Fin pbx.dim ≃ Fin pbz.dim := finCongr hdim + let P : Matrix (Fin pbx.dim) (Fin pbx.dim) K := + Matrix.diagonal (fun i => r ^ (i : ℕ)) + have hbasis : (fun i => pbx.basis i) = + (P.map (algebraMap K L)).mulVec (fun i => pbz.basis (e i)) := by + funext i + rw [show pbx.basis i = pbx.gen ^ (i : ℕ) by + simp only [PowerBasis.coe_basis]] + rw [show P.map (algebraMap K L) = + Matrix.diagonal (fun i : Fin pbx.dim => + algebraMap K L (r ^ (i : ℕ))) by + ext i j + simp only [P, Matrix.map_apply, Matrix.diagonal_apply] + split <;> simp_all] + rw [Matrix.mulVec_diagonal] + rw [show pbz.basis (e i) = pbz.gen ^ ((e i : Fin pbz.dim) : ℕ) by + simp only [PowerBasis.coe_basis]] + rw [hgenX, hgenZ] + have hei : ((e i : Fin pbz.dim) : ℕ) = (i : ℕ) := by simp [e] + rw [hei] + simp [Algebra.smul_def, mul_pow] + have hreindex : Algebra.discr K (fun i => pbz.basis (e i)) = + Algebra.discr K pbz.basis := by + simpa [Function.comp_def] using Algebra.discr_reindex K pbz.basis e.symm + have hchange := Algebra.discr_of_matrix_mulVec + (fun i => pbz.basis (e i)) P + rw [← hbasis, hreindex] at hchange + exact hchange + +theorem exists_minpoly_discr_smul_eq_pow_mul + {K L : Type*} [Field K] [Field L] [Algebra K L] + [FiniteDimensional K L] [Algebra.IsSeparable K L] + (r : K) (hr : r ≠ 0) (z : L) + (hz : Algebra.adjoin K {z} = ⊤) : + ∃ N : ℕ, (minpoly K (r • z)).discr = + r ^ N * (minpoly K z).discr := by + let pbz : PowerBasis K L := + PowerBasis.ofAdjoinEqTop' (Algebra.IsIntegral.isIntegral z) hz + have hgenZ : pbz.gen = z := by + exact PowerBasis.ofAdjoinEqTop'_gen _ _ + have hx : Algebra.adjoin K {r • z} = ⊤ := + adjoin_smul_eq_top_of_adjoin_eq_top r hr z hz + let pbx : PowerBasis K L := + PowerBasis.ofAdjoinEqTop' (Algebra.IsIntegral.isIntegral (r • z)) hx + have hgenX : pbx.gen = r • z := by + exact PowerBasis.ofAdjoinEqTop'_gen _ _ + have hdiscX := discr_powerBasis_eq_minpoly_discr pbx + have hdiscZ := discr_powerBasis_eq_minpoly_discr pbz + rw [hgenX] at hdiscX + rw [hgenZ] at hdiscZ + have hchange := powerBasis_discr_smul_eq_diagonal_det_sq_mul + r z pbz pbx hgenZ hgenX + let P : Matrix (Fin pbx.dim) (Fin pbx.dim) K := + Matrix.diagonal (fun i => r ^ (i : ℕ)) + have hdisc : (minpoly K (r • z)).discr = + P.det ^ 2 * (minpoly K z).discr := by + exact hdiscX.symm.trans (hchange.trans + (congrArg (P.det ^ 2 * ·) hdiscZ)) + let d : ℕ := ∑ i : Fin pbx.dim, (i : ℕ) + have hdet : P.det = r ^ d := by + rw [show P.det = ∏ i : Fin pbx.dim, r ^ (i : ℕ) by + simp [P, Matrix.det_diagonal]] + simpa [d] using + (Finset.prod_pow_eq_pow_sum Finset.univ + (fun i : Fin pbx.dim => (i : ℕ)) r) + refine ⟨2 * d, ?_⟩ + rw [hdisc, hdet] + congr 1 + rw [← pow_mul] + congr 1 + omega + +theorem finitePlaceOrder_mul_of_ne_zero + {R F : Type*} [CommRing R] [IsDedekindDomain R] + [Field F] [Algebra R F] [IsFractionRing R F] + (v : HeightOneSpectrum R) (x y : F) (hx : x ≠ 0) (hy : y ≠ 0) : + finitePlaceOrder v (x * y) = + finitePlaceOrder v x + finitePlaceOrder v y := by + have h := finitePlaceOrderTop_mul v x y + rw [finitePlaceOrderTop_eq_coe v (x * y) (mul_ne_zero hx hy), + finitePlaceOrderTop_eq_coe v x hx, + finitePlaceOrderTop_eq_coe v y hy] at h + exact_mod_cast h + +theorem finitePlaceOrder_pow_of_ne_zero + {R F : Type*} [CommRing R] [IsDedekindDomain R] + [Field F] [Algebra R F] [IsFractionRing R F] + (v : HeightOneSpectrum R) (x : F) (hx : x ≠ 0) (n : ℕ) : + finitePlaceOrder v (x ^ n) = n • finitePlaceOrder v x := by + have h := finitePlaceOrderTop_pow v x n + rw [finitePlaceOrderTop_eq_coe v (x ^ n) (pow_ne_zero n hx), + finitePlaceOrderTop_eq_coe v x hx] at h + exact_mod_cast h + +theorem finitePlaceOrder_algebraMap_unit_eq_zero + {R F : Type*} [CommRing R] [IsDedekindDomain R] + [Field F] [Algebra R F] [IsFractionRing R F] + (v : HeightOneSpectrum R) (u : Rˣ) : + finitePlaceOrder v (algebraMap R F (u : R)) = 0 := by + have h := finitePlaceOrderTop_algebraMap_unit (A := R) (K := F) v u + have hu : algebraMap R F (u : R) ≠ 0 := + by simp + rw [finitePlaceOrderTop_eq_coe v _ hu] at h + exact_mod_cast h + +/-- The discriminant of the second-coordinate plane equation is nonzero +under the separating-coordinate hypothesis. -/ +theorem planeCurvePolynomialInSecondCoordinate_discr_ne_zero + {K : Type*} [Field K] {f : MvPolynomial (Fin 2) K} + (hf : Irreducible f) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) : + (planeCurvePolynomialInSecondCoordinate f).discr ≠ 0 := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let : Algebra (RatFunc K) (PlaneCurveFunctionField f) := + planeCurveFirstCoordinateRatFuncAlgebra f hx + let : FiniteDimensional (RatFunc K) (PlaneCurveFunctionField f) := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : Algebra.IsSeparable (RatFunc K) (PlaneCurveFunctionField f) := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let F : (RatFunc K)[X] := + (planeCurvePolynomialInSecondCoordinate f).map + (algebraMap K[X] (RatFunc K)) + have hFirreducible : Irreducible F := + planeCurvePolynomialInSecondCoordinate_ratFunc_irreducible + hf hpartialSecond + have hFroot : Polynomial.aeval (planeCurveFunction f 1) F = 0 := + aeval_planeCurvePolynomialInSecondCoordinate_ratFunc_eq_zero + hf hpartialSecond + have heq := minpoly.eq_of_irreducible hFirreducible hFroot + have hprimitive := adjoin_secondCoordinate_over_firstRatFunc_eq_top + hf hpartialSecond + have hminNe : + (minpoly (RatFunc K) (planeCurveFunction f 1)).discr ≠ 0 := + minpoly_discr_ne_zero_of_adjoin_eq_top + (planeCurveFunction f 1) hprimitive + have hinvNe : F.leadingCoeff⁻¹ ≠ 0 := + inv_ne_zero (leadingCoeff_ne_zero.mpr hFirreducible.ne_zero) + have hscaledNe : (Polynomial.C F.leadingCoeff⁻¹ * F).discr ≠ 0 := by + simpa only [mul_comm] using (heq ▸ hminNe) + rw [discr_C_mul F F.leadingCoeff⁻¹ hinvNe] at hscaledNe + have hFdiscrNe : F.discr ≠ 0 := by + intro hzero + exact hscaledNe (by rw [hzero, mul_zero]) + have hmap := discr_map_of_injective + (algebraMap K[X] (RatFunc K)) + (IsFractionRing.injective K[X] (RatFunc K)) + (planeCurvePolynomialInSecondCoordinate f) + intro hzero + apply hFdiscrNe + rw [show F.discr = algebraMap K[X] (RatFunc K) + (planeCurvePolynomialInSecondCoordinate f).discr by + exact hmap] + rw [hzero, map_zero] + +section FiniteDifferentBelow + +variable (K : Type*) [Field K] [DecidableEq K] [DecidableEq (RatFunc K)] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +local instance (priority := 10) finiteDifferentBoundPolynomialAlgebra : + Algebra K[X] L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K[X] (RatFunc K))) + +local instance finiteDifferentBoundPolynomialScalarTower : + IsScalarTower K[X] (RatFunc K) L := + ⟨fun r s x => by + simp only [Algebra.smul_def] + rw [map_mul] + change (algebraMap (RatFunc K) L (algebraMap K[X] (RatFunc K) r) * + algebraMap (RatFunc K) L s) * x = + algebraMap K[X] L r * (algebraMap (RatFunc K) L s * x) + rw [show algebraMap K[X] L r = + algebraMap (RatFunc K) L (algebraMap K[X] (RatFunc K) r) by rfl] + ring⟩ + +local instance finiteDifferentBoundFiniteIntegralClosureModuleFinite : + Module.Finite K[X] (RatFuncFiniteIntegralClosure K L) := + Module.IsNoetherian.finite K[X] (RatFuncFiniteIntegralClosure K L) + +local instance finiteDifferentBoundFiniteIntegralClosureIsIntegral : + Algebra.IsIntegral K[X] (RatFuncFiniteIntegralClosure K L) := + IsIntegralClosure.isIntegral_algebra K[X] L + +local instance finiteDifferentBoundPolynomialTorsionFreeTop : + Module.IsTorsionFree K[X] L := + Module.IsTorsionFree.trans_faithfulSMul K[X] (RatFunc K) L + +local instance finiteDifferentBoundFiniteIntegralClosureIsTorsionFree : + Module.IsTorsionFree K[X] (RatFuncFiniteIntegralClosure K L) := + IsIntegralClosure.isTorsionFree K[X] L + +/-- The finite different, weighted by residue degree but not yet by the +degree of the base prime. -/ +def finiteExtensionFiniteDifferentResidueWeightedDivisor + (hDifferent : differentIdeal K[X] + (RatFuncFiniteIntegralClosure K L) ≠ ⊥) : + FiniteExtensionFinitePlace K L →₀ ℕ := + (differentMultiplicityDivisor K[X] + (RatFuncFiniteIntegralClosure K L) hDifferent).sum (fun q e => + Finsupp.single q (e * q.asIdeal.inertiaDeg K[X])) + +omit [DecidableEq K] [DecidableEq (RatFunc K)] in +@[simp] theorem finiteExtensionFiniteDifferentResidueWeightedDivisor_apply + (hDifferent : differentIdeal K[X] + (RatFuncFiniteIntegralClosure K L) ≠ ⊥) + (q : FiniteExtensionFinitePlace K L) : + finiteExtensionFiniteDifferentResidueWeightedDivisor K L hDifferent q = + multiplicity q.asIdeal + (differentIdeal K[X] (RatFuncFiniteIntegralClosure K L)) * + q.asIdeal.inertiaDeg K[X] := by + classical + let D := differentMultiplicityDivisor K[X] + (RatFuncFiniteIntegralClosure K L) hDifferent + rw [finiteExtensionFiniteDifferentResidueWeightedDivisor, Finsupp.sum_apply] + unfold Finsupp.sum + by_cases hq : q ∈ D.support + · rw [Finset.sum_eq_single q] + · simp [differentMultiplicityDivisor_apply] + · intro b hb hbq + simp [hbq] + · exact fun hnot => (hnot hq).elim + · rw [Finset.sum_eq_zero] + · change 0 = multiplicity q.asIdeal + (differentIdeal K[X] (RatFuncFiniteIntegralClosure K L)) * + q.asIdeal.inertiaDeg K[X] + have hzero : D q = 0 := Finsupp.notMem_support_iff.mp hq + simpa [D, differentMultiplicityDivisor_apply] using + congrArg (fun n => n * q.asIdeal.inertiaDeg K[X]) hzero.symm + · intro b hb + have hbq : b ≠ q := by + intro h + subst h + exact hq hb + simp [hbq] + +/-- Push the residue-weighted finite different down to the finite primes of +`K[X]`. -/ +def finiteExtensionFiniteDifferentDivisorBelow + (hDifferent : differentIdeal K[X] + (RatFuncFiniteIntegralClosure K L) ≠ ⊥) : + HeightOneSpectrum K[X] →₀ ℕ := + (finiteExtensionFiniteDifferentResidueWeightedDivisor K L hDifferent).mapDomain + (HeightOneSpectrum.under K[X]) + +omit [DecidableEq K] [DecidableEq (RatFunc K)] in +theorem finiteExtensionFiniteDifferentDivisorBelow_apply + (hDifferent : differentIdeal K[X] + (RatFuncFiniteIntegralClosure K L) ≠ ⊥) + (p : HeightOneSpectrum K[X]) : + finiteExtensionFiniteDifferentDivisorBelow K L hDifferent p = + ∑ P : p.asIdeal.primesOver (RatFuncFiniteIntegralClosure K L), + P.1.inertiaDeg K[X] * + multiplicity P.1 + (differentIdeal K[X] (RatFuncFiniteIntegralClosure K L)) := by + classical + let e := finitePlaceFiberEquivPrimesOver K L p + let : Fintype {q : FiniteExtensionFinitePlace K L // + HeightOneSpectrum.under K[X] q = p} := + Fintype.ofEquiv (p.asIdeal.primesOver (RatFuncFiniteIntegralClosure K L)) e.symm + let P₀ : p.asIdeal.primesOver (RatFuncFiniteIntegralClosure K L) := + Classical.choice (Set.nonempty_coe_sort.mpr + (Set.nonempty_iff_ne_empty.mpr (by + intro hempty + have hncard := IsDedekindDomain.primesOver_ncard_ne_zero p.asIdeal + (RatFuncFiniteIntegralClosure K L) + exact hncard (by simp [hempty])))) + let q₀ : FiniteExtensionFinitePlace K L := primeOverHeightOne p P₀ + have hq₀ : HeightOneSpectrum.under K[X] q₀ = p := by + apply HeightOneSpectrum.ext + exact (Ideal.over_def P₀.1 p.asIdeal).symm + rw [finiteExtensionFiniteDifferentDivisorBelow, show p = + HeightOneSpectrum.under K[X] q₀ from hq₀.symm, + Finsupp.mapDomain_apply_eq_sum] + let D := finiteExtensionFiniteDifferentResidueWeightedDivisor K L hDifferent + have hfilter : + (∑ q ∈ D.support with HeightOneSpectrum.under K[X] q = + HeightOneSpectrum.under K[X] q₀, D q) = + ∑ q : {q : FiniteExtensionFinitePlace K L // + HeightOneSpectrum.under K[X] q = p}, D q := by + rw [hq₀] + calc + _ = ∑ q ∈ Finset.subtype + (fun q => HeightOneSpectrum.under K[X] q = p) D.support, + D q := (Finset.sum_subtype_eq_sum_filter (s := D.support) + (fun q => D q)).symm + _ = ∑ q : {q : FiniteExtensionFinitePlace K L // + HeightOneSpectrum.under K[X] q = p}, D q := by + apply Finset.sum_subset (Finset.subset_univ _) + intro q _ hq + have hnot : q.1 ∉ D.support := by + intro hmem + exact hq (Finset.mem_subtype.mpr hmem) + exact Finsupp.notMem_support_iff.mp hnot + rw [hfilter, hq₀] + apply Fintype.sum_equiv e + intro q + rw [finiteExtensionFiniteDifferentResidueWeightedDivisor_apply] + change multiplicity q.1.asIdeal + (differentIdeal K[X] (RatFuncFiniteIntegralClosure K L)) * + q.1.asIdeal.inertiaDeg K[X] = + q.1.asIdeal.inertiaDeg K[X] * + multiplicity q.1.asIdeal + (differentIdeal K[X] (RatFuncFiniteIntegralClosure K L)) + ring + +omit [DecidableEq (RatFunc K)] in +/-- Pushing the residue-weighted different down to the base does not change +its degree-weighted sum. -/ +theorem finiteExtensionFiniteDifferentDegree_eq_belowWeightedDegree + (hDifferent : differentIdeal K[X] + (RatFuncFiniteIntegralClosure K L) ≠ ⊥) : + finiteExtensionFiniteDifferentDegree K L hDifferent = + (finiteExtensionFiniteDifferentDivisorBelow K L hDifferent).sum + (fun p e => e * ratFuncFinitePlaceDegree p) := by + classical + let D := differentMultiplicityDivisor K[X] + (RatFuncFiniteIntegralClosure K L) hDifferent + let DW := finiteExtensionFiniteDifferentResidueWeightedDivisor + K L hDifferent + let DB := finiteExtensionFiniteDifferentDivisorBelow K L hDifferent + calc + finiteExtensionFiniteDifferentDegree K L hDifferent = + DW.sum (fun q e => e * + ratFuncFinitePlaceDegree (HeightOneSpectrum.under K[X] q)) := by + rw [finiteExtensionFiniteDifferentDegree] + change D.sum _ = DW.sum _ + dsimp only [DW] + rw [finiteExtensionFiniteDifferentResidueWeightedDivisor, + Finsupp.sum_sum_index (fun _ => by simp) + (fun _ _ _ => by ring)] + apply Finsupp.sum_congr + intro q _ + rw [Finsupp.sum_single_index] + · ring + _ = DB.sum (fun p e => e * ratFuncFinitePlaceDegree p) := by + dsimp only [DB, DW] + rw [finiteExtensionFiniteDifferentDivisorBelow] + symm + apply Finsupp.sum_mapDomain_index + · intro + simp + · intro _ _ _ + ring + +omit [DecidableEq (RatFunc K)] in +/-- A coefficientwise finite-place discriminant bound sums to the corresponding +degree bound. -/ +theorem finiteExtensionFiniteDifferentDegree_le_polynomialDegree_of_localBounds + (hDifferent : differentIdeal K[X] + (RatFuncFiniteIntegralClosure K L) ≠ ⊥) + (Δ : K[X]) (hΔ : Δ ≠ 0) + (hlocal : ∀ p : HeightOneSpectrum K[X], + (finiteExtensionFiniteDifferentDivisorBelow K L hDifferent p : ℤ) ≤ + ratFuncFiniteOrder p (algebraMap K[X] (RatFunc K) Δ)) : + finiteExtensionFiniteDifferentDegree K L hDifferent ≤ Δ.natDegree := by + classical + let DB := finiteExtensionFiniteDifferentDivisorBelow K L hDifferent + let DBZ : HeightOneSpectrum K[X] →₀ ℤ := + DB.mapRange (fun n : ℕ => (n : ℤ)) (by simp) + let P := ratFuncFiniteDivisor (algebraMap K[X] (RatFunc K) Δ) + have hpoint : DBZ ≤ P := by + intro p + dsimp only [DBZ, P] + rw [Finsupp.mapRange_apply, ratFuncFiniteDivisor_apply] + exact hlocal p + have hsum : + DBZ.sum (fun p e => e * (ratFuncFinitePlaceDegree p : ℤ)) ≤ + P.sum (fun p e => e * (ratFuncFinitePlaceDegree p : ℤ)) := by + apply Finsupp.sum_le_sum_index hpoint + · intro p _ a b hab + exact mul_le_mul_of_nonneg_right hab (Int.natCast_nonneg _) + · intro p _ + simp + have hcast : (finiteExtensionFiniteDifferentDegree K L hDifferent : ℤ) ≤ + (Δ.natDegree : ℤ) := by + calc + (finiteExtensionFiniteDifferentDegree K L hDifferent : ℤ) = + DBZ.sum (fun p e => e * + (ratFuncFinitePlaceDegree p : ℤ)) := by + rw [finiteExtensionFiniteDifferentDegree_eq_belowWeightedDegree] + rw [Nat.cast_finsupp_sum] + dsimp only [DBZ, DB] + rw [Finsupp.sum_mapRange_index (fun _ => by simp)] + apply Finsupp.sum_congr + intro p _ + push_cast + rfl + _ ≤ P.sum (fun p e => e * + (ratFuncFinitePlaceDegree p : ℤ)) := hsum + _ = ratFuncExhaustiveFinitePlaceDegreeSum + (algebraMap K[X] (RatFunc K) Δ) := by rfl + _ = (algebraMap K[X] (RatFunc K) Δ).intDegree := + ratFuncExhaustiveFinitePlaceDegreeSum_eq_intDegree _ + (RatFunc.algebraMap_ne_zero hΔ) + _ = (Δ.natDegree : ℤ) := RatFunc.intDegree_polynomial + exact_mod_cast hcast + +omit [DecidableEq K] [DecidableEq (RatFunc K)] in +theorem finiteExtensionFiniteDifferentDivisorBelow_apply_le_minpolyDiscr_of_localPrimitive + (hDifferent : differentIdeal K[X] + (RatFuncFiniteIntegralClosure K L) ≠ ⊥) + (p : HeightOneSpectrum K[X]) + [Algebra (Localization.AtPrime p.asIdeal) L] + [IsScalarTower K[X] (Localization.AtPrime p.asIdeal) L] + (z : L) (hzIntegral : IsIntegral (Localization.AtPrime p.asIdeal) z) + (hzPrimitive : Algebra.adjoin (RatFunc K) {z} = ⊤) : + (finiteExtensionFiniteDifferentDivisorBelow K L hDifferent p : ℤ) ≤ + ratFuncFiniteOrder p (minpoly (RatFunc K) z).discr := by + let A := Localization.AtPrime p.asIdeal + let B := RatFuncFiniteIntegralClosure K L + obtain ⟨m, hmIntegral⟩ := + IsIntegral.exists_multiple_integral_of_isLocalization + p.asIdeal.primeCompl z hzIntegral + have hm_ne : (m : K[X]) ≠ 0 := by + intro hm + exact m.property (hm ▸ p.asIdeal.zero_mem) + let r : RatFunc K := algebraMap K[X] (RatFunc K) (m : K[X]) + have hr : r ≠ 0 := RatFunc.algebraMap_ne_zero hm_ne + let x : B := IsIntegralClosure.mk' B ((m : K[X]) • z) hmIntegral + have hxMap : algebraMap B L x = (m : K[X]) • z := by + simp [x] + have hxScale : algebraMap B L x = r • z := by + rw [hxMap] + simp only [Algebra.smul_def, r] + rw [IsScalarTower.algebraMap_apply K[X] (RatFunc K) L] + have hxPrimitive : Algebra.adjoin (RatFunc K) + {algebraMap B L x} = ⊤ := by + rw [hxScale] + exact adjoin_smul_eq_top_of_adjoin_eq_top r hr z hzPrimitive + let d : B := aeval x (derivative (minpoly K[X] x)) + have hd : d ≠ 0 := by + simpa [d] using minpolyDerivative_ne_zero + (A := K[X]) (K := RatFunc K) (L := L) x + let dL : L := algebraMap B L d + have hdL : dL ≠ 0 := (IsFractionRing.injective B L).ne hd + have hrepr : + (ratFuncFiniteIntegralClosureFractionRingEquiv K L).symm dL = + algebraMap B (FractionRing B) d := by + apply (ratFuncFiniteIntegralClosureFractionRingEquiv K L).injective + rw [(ratFuncFiniteIntegralClosureFractionRingEquiv K L).apply_symm_apply] + exact (ratFuncFiniteIntegralClosureFractionRingEquiv K L).commutes d |>.symm + have hpoint : ∀ P : p.asIdeal.primesOver B, + ((P.1.inertiaDeg K[X] * + multiplicity P.1 (differentIdeal K[X] B) : ℕ) : ℤ) ≤ + (P.1.inertiaDeg K[X] : ℤ) * + finitePlaceOrder (primeOverHeightOne p P) + ((ratFuncFiniteIntegralClosureFractionRingEquiv K L).symm dL) := by + intro P + have hmul := differentIdeal_multiplicity_le_minpolyDerivativeSpan + (A := K[X]) (K := RatFunc K) (L := L) (B := B) + x hxPrimitive (primeOverHeightOne p P) + have horder : + finitePlaceOrder (primeOverHeightOne p P) + ((ratFuncFiniteIntegralClosureFractionRingEquiv K L).symm dL) = + (multiplicity P.1 (Ideal.span {d}) : ℤ) := by + rw [hrepr] + simpa using finitePlaceOrder_algebraMap_eq_multiplicity + (primeOverHeightOne p P) d hd + rw [horder] + exact_mod_cast Nat.mul_le_mul_left (P.1.inertiaDeg K[X]) hmul + have hsum : + (finiteExtensionFiniteDifferentDivisorBelow K L hDifferent p : ℤ) ≤ + ∑ P : p.asIdeal.primesOver B, + (P.1.inertiaDeg K[X] : ℤ) * + finitePlaceOrder (primeOverHeightOne p P) + ((ratFuncFiniteIntegralClosureFractionRingEquiv K L).symm dL) := by + rw [finiteExtensionFiniteDifferentDivisorBelow_apply, Nat.cast_sum] + exact Finset.sum_le_sum fun P _ => hpoint P + rw [finitePrimesAbove_weightedOrder_eq_normOrder K L p dL hdL] at hsum + let pb : PowerBasis (RatFunc K) L := + PowerBasis.ofAdjoinEqTop' + (Algebra.IsIntegral.isIntegral (algebraMap B L x)) hxPrimitive + have hdiscNorm := discr_powerBasisOfPrimitiveElement_eq_norm_minpolyDerivative + (A := K[X]) (K := RatFunc K) (L := L) (B := B) x hxPrimitive + have hpb : Algebra.discr (RatFunc K) pb.basis = + (minpoly (RatFunc K) (algebraMap B L x)).discr := by + have hpbg : pb.gen = algebraMap B L x := by simp [pb] + simpa only [hpbg] using discr_powerBasis_eq_minpoly_discr pb + change Algebra.discr (RatFunc K) pb.basis = + (-1) ^ (Module.finrank (RatFunc K) L * + (Module.finrank (RatFunc K) L - 1) / 2) * + Algebra.norm (RatFunc K) dL at hdiscNorm + rw [hpb] at hdiscNorm + have hnormNe : Algebra.norm (RatFunc K) dL ≠ 0 := + Algebra.norm_ne_zero_iff.mpr hdL + have hsignNe : + ((-1 : RatFunc K) ^ (Module.finrank (RatFunc K) L * + (Module.finrank (RatFunc K) L - 1) / 2)) ≠ 0 := by simp + have hminXNe : + (minpoly (RatFunc K) (algebraMap B L x)).discr ≠ 0 := by + rw [hdiscNorm] + exact mul_ne_zero hsignNe hnormNe + have hnormOrder : + ratFuncFiniteOrder p (Algebra.norm (RatFunc K) dL) = + ratFuncFiniteOrder p + (minpoly (RatFunc K) (algebraMap B L x)).discr := by + have horder := congrArg (finitePlaceOrder p) hdiscNorm + rw [finitePlaceOrder_mul_of_ne_zero p _ _ hsignNe hnormNe] at horder + have hsignOrder : finitePlaceOrder p + ((-1 : RatFunc K) ^ (Module.finrank (RatFunc K) L * + (Module.finrank (RatFunc K) L - 1) / 2)) = 0 := by + rw [finitePlaceOrder_pow_of_ne_zero p (-1 : RatFunc K) (by simp)] + have hminus := finitePlaceOrder_algebraMap_unit_eq_zero + (R := K[X]) (F := RatFunc K) p (-1 : K[X]ˣ) + have hminus' : finitePlaceOrder p (-1 : RatFunc K) = 0 := by + simpa using hminus + rw [hminus', smul_zero] + rw [hsignOrder, zero_add] at horder + exact horder.symm + have hmMultiplicity : + multiplicity p.asIdeal (Ideal.span {(m : K[X])}) = 0 := by + apply multiplicity_eq_zero_of_not_dvd + rw [Ideal.dvd_span_singleton] + exact m.property + have hrOrder : ratFuncFiniteOrder p r = 0 := by + change finitePlaceOrder p (algebraMap K[X] (RatFunc K) (m : K[X])) = 0 + rw [finitePlaceOrder_algebraMap_eq_multiplicity p (m : K[X]) hm_ne] + exact_mod_cast hmMultiplicity + obtain ⟨N, hscaleDisc⟩ := + exists_minpoly_discr_smul_eq_pow_mul r hr z hzPrimitive + rw [← hxScale] at hscaleDisc + have hminZNe : (minpoly (RatFunc K) z).discr ≠ 0 := by + intro hzero + rw [hzero, mul_zero] at hscaleDisc + exact hminXNe hscaleDisc + have hscaleOrder : + ratFuncFiniteOrder p + (minpoly (RatFunc K) (algebraMap B L x)).discr = + ratFuncFiniteOrder p (minpoly (RatFunc K) z).discr := by + have horder := congrArg (finitePlaceOrder p) hscaleDisc + rw [finitePlaceOrder_mul_of_ne_zero p _ _ + (pow_ne_zero N hr) hminZNe, + finitePlaceOrder_pow_of_ne_zero p r hr N] at horder + have hrOrder' : finitePlaceOrder p r = 0 := hrOrder + rw [hrOrder', smul_zero, zero_add] at horder + exact horder + exact hsum.trans_eq (hnormOrder.trans hscaleOrder) + +end FiniteDifferentBelow + +section PlaneCurveFiniteDifferentBound + +variable {K : Type*} [Field K] [Fintype K] [DecidableEq K] + [DecidableEq (RatFunc K)] + +omit [DecidableEq K] [DecidableEq (RatFunc K)] in +/-- At each finite first-coordinate prime, the residue-weighted different is +bounded by the order of the discriminant of the original plane equation. -/ +theorem planeCurve_finiteDifferentDivisorBelow_apply_le_discrOrder + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (hcardK : MvPolynomial.degreeOf 1 f < Fintype.card K) + (p : HeightOneSpectrum K[X]) : + letI := planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + letI := planeCurveFirstCoordinateRatFuncAlgebra f hx + letI := finiteDimensional_planeCurveFunctionField_over_ratFunc + hf hpartialSecond + letI := separable_planeCurveFunctionField_over_ratFunc + hf hpartialSecond + (finiteExtensionFiniteDifferentDivisorBelow K + (PlaneCurveFunctionField f) + (finiteExtensionFiniteDifferentIdeal_ne_bot K + (PlaneCurveFunctionField f)) p : ℤ) ≤ + ratFuncFiniteOrder p (algebraMap K[X] (RatFunc K) + (planeCurvePolynomialInSecondCoordinate f).discr) := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let L := PlaneCurveFunctionField f + let algRL : Algebra (RatFunc K) L := + planeCurveFirstCoordinateRatFuncAlgebra f hx + let : Algebra (RatFunc K) L := algRL + let : FiniteDimensional (RatFunc K) L := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : Algebra.IsSeparable (RatFunc K) L := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let A := Localization.AtPrime p.asIdeal + let ι := localizationAtPrimeToRatFunc p + obtain ⟨a, u, hu, hroot, hvc, hprimitive, hdegree⟩ := + planeCurve_local_reciprocal_certificate_of_degreeOf_second_lt_fintypeCard + hf hpartialSecond hcardK p + let c : A := algebraMap K[X] A a + let G : A[X] := (planeCurvePolynomialInSecondCoordinate f).map + (algebraMap K[X] A) + let algRA : Algebra K[X] A := inferInstance + let algRR : Algebra K[X] (RatFunc K) := inferInstance + let algAR : Algebra A (RatFunc K) := ι.toAlgebra + let algPL : Algebra K[X] L := RingHom.toAlgebra + ((algebraMap (RatFunc K) L).comp (algebraMap K[X] (RatFunc K))) + let : Algebra K[X] A := algRA + let : Algebra K[X] (RatFunc K) := algRR + let : Algebra A (RatFunc K) := algAR + let : Algebra K[X] L := algPL + let : SMul K[X] A := algRA.toSMul + let : SMul K[X] (RatFunc K) := algRR.toSMul + let : SMul A (RatFunc K) := algAR.toSMul + let : SMul K[X] L := algPL.toSMul + let : IsScalarTower K[X] A (RatFunc K) := by + apply IsScalarTower.of_algebraMap_eq' + exact (localizationAtPrimeToRatFunc_comp_algebraMap p).symm + let : IsFractionRing A (RatFunc K) := + IsFractionRing.isFractionRing_of_isDomain_of_isLocalization + p.asIdeal.primeCompl A (RatFunc K) + let algAL : Algebra A L := + ((algebraMap (RatFunc K) L).comp ι).toAlgebra + let : SMul (RatFunc K) L := algRL.toSMul + let : Algebra A L := algAL + let : SMul A L := algAL.toSMul + let : IsScalarTower A (RatFunc K) L := by + apply IsScalarTower.of_algebraMap_eq' + rfl + let : IsScalarTower K[X] A L := by + apply IsScalarTower.of_algebraMap_eq' + apply DFunLike.ext _ _ + intro r + change algebraMap (RatFunc K) L (algebraMap K[X] (RatFunc K) r) = + algebraMap (RatFunc K) L (ι (algebraMap K[X] A r)) + exact (congrArg (algebraMap (RatFunc K) L) + (DFunLike.congr_fun + (localizationAtPrimeToRatFunc_comp_algebraMap p) r)).symm + let : IsDiscreteValuationRing A := + IsLocalization.AtPrime.isDiscreteValuationRing_of_dedekind_domain + K[X] p.ne_bot A + let v : L := planeCurveFunction f 1 + let z : L := (v - algebraMap A L c)⁻¹ + have hroot' : Polynomial.aeval v G = 0 := by + simpa [Polynomial.aeval_def, algAL, RingHom.algebraMap_toAlgebra, + G, v] using hroot + have hvc' : v ≠ algebraMap A L c := by + simpa [algAL, RingHom.algebraMap_toAlgebra, RingHom.comp_apply, + c, v] using hvc + have hzIntegral : IsIntegral A z := by + exact isIntegral_inv_sub_of_eval_eq_unit + G c u v hu hvc' hroot' + have hzPrimitive : Algebra.adjoin (RatFunc K) {z} = ⊤ := by + change Algebra.adjoin (RatFunc K) + {(v - algebraMap A L c)⁻¹} = ⊤ + have hmap : algebraMap A L c = + algebraMap (RatFunc K) L (ι c) := by rfl + rw [hmap] + exact adjoin_inv_sub_eq_top_of_adjoin_eq_top (ι c) v hprimitive + have hbound := + finiteExtensionFiniteDifferentDivisorBelow_apply_le_minpolyDiscr_of_localPrimitive + K L (finiteExtensionFiniteDifferentIdeal_ne_bot K L) p + z hzIntegral hzPrimitive + have htop := finitePlaceOrderTop_minpoly_inv_sub_discr + (A := A) (K := RatFunc K) (L := L) + (IsDiscreteValuationRing.maximalIdeal A) + G c u v hu hvc' hroot' hprimitive hdegree + change finitePlaceOrderTop (IsDiscreteValuationRing.maximalIdeal A) + (minpoly (RatFunc K) z).discr = + finitePlaceOrderTop (IsDiscreteValuationRing.maximalIdeal A) + (algebraMap A (RatFunc K) G.discr) at htop + rw [localizationAtPrime_finitePlaceOrderTop_eq p, + localizationAtPrime_finitePlaceOrderTop_eq p] at htop + have hminNe : (minpoly (RatFunc K) z).discr ≠ 0 := + minpoly_discr_ne_zero_of_adjoin_eq_top z hzPrimitive + have hFdiscr : (planeCurvePolynomialInSecondCoordinate f).discr ≠ 0 := + planeCurvePolynomialInSecondCoordinate_discr_ne_zero + hf hpartialSecond + have hGdiscEq : G.discr = algebraMap K[X] A + (planeCurvePolynomialInSecondCoordinate f).discr := by + exact discr_map_of_injective (algebraMap K[X] A) + (IsLocalization.injective A + p.asIdeal.primeCompl_le_nonZeroDivisors) + (planeCurvePolynomialInSecondCoordinate f) + have hGdiscr : G.discr ≠ 0 := by + rw [hGdiscEq] + simpa only [map_zero] using (IsLocalization.injective A + p.asIdeal.primeCompl_le_nonZeroDivisors).ne hFdiscr + have hmapGdiscr : algebraMap A (RatFunc K) G.discr ≠ 0 := + by simpa only [map_zero] using + (IsFractionRing.injective A (RatFunc K)).ne hGdiscr + rw [finitePlaceOrderTop_eq_coe p _ hminNe, + finitePlaceOrderTop_eq_coe p _ hmapGdiscr] at htop + have hmapEq : algebraMap A (RatFunc K) G.discr = + algebraMap K[X] (RatFunc K) + (planeCurvePolynomialInSecondCoordinate f).discr := by + rw [hGdiscEq] + exact (IsScalarTower.algebraMap_apply K[X] A (RatFunc K) _).symm + have horderEq : ratFuncFiniteOrder p (minpoly (RatFunc K) z).discr = + ratFuncFiniteOrder p (algebraMap K[X] (RatFunc K) + (planeCurvePolynomialInSecondCoordinate f).discr) := by + change finitePlaceOrder p (minpoly (RatFunc K) z).discr = + finitePlaceOrder p (algebraMap K[X] (RatFunc K) + (planeCurvePolynomialInSecondCoordinate f).discr) + rw [← hmapEq] + exact_mod_cast htop + exact hbound.trans_eq horderEq + +omit [DecidableEq (RatFunc K)] in +/-- The sharp finite different contribution for the plane function field is +bounded by the discriminant degree of the original second-coordinate +equation. -/ +theorem planeCurve_finiteDifferentDegree_le_discrNatDegree + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (hcardK : MvPolynomial.degreeOf 1 f < Fintype.card K) : + letI := planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + letI := planeCurveFirstCoordinateRatFuncAlgebra f hx + letI := finiteDimensional_planeCurveFunctionField_over_ratFunc + hf hpartialSecond + letI := separable_planeCurveFunctionField_over_ratFunc + hf hpartialSecond + finiteExtensionFiniteDifferentDegree K (PlaneCurveFunctionField f) + (finiteExtensionFiniteDifferentIdeal_ne_bot K + (PlaneCurveFunctionField f)) ≤ + (planeCurvePolynomialInSecondCoordinate f).discr.natDegree := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let : Algebra (RatFunc K) (PlaneCurveFunctionField f) := + planeCurveFirstCoordinateRatFuncAlgebra f hx + let : FiniteDimensional (RatFunc K) (PlaneCurveFunctionField f) := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : Algebra.IsSeparable (RatFunc K) (PlaneCurveFunctionField f) := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + apply finiteExtensionFiniteDifferentDegree_le_polynomialDegree_of_localBounds + K (PlaneCurveFunctionField f) + (finiteExtensionFiniteDifferentIdeal_ne_bot K + (PlaneCurveFunctionField f)) + (planeCurvePolynomialInSecondCoordinate f).discr + (planeCurvePolynomialInSecondCoordinate_discr_ne_zero + hf hpartialSecond) + intro p + exact planeCurve_finiteDifferentDivisorBelow_apply_le_discrOrder + hf hpartialSecond hcardK p + +end PlaneCurveFiniteDifferentBound + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurveFunctionField.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurveFunctionField.lean new file mode 100644 index 0000000000..c460b2f44c --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurveFunctionField.lean @@ -0,0 +1,549 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import Mathlib.Algebra.MvPolynomial.Equiv +public import Mathlib.Algebra.MvPolynomial.PDeriv +public import Mathlib.FieldTheory.IntermediateField.Adjoin.Algebra +public import Mathlib.FieldTheory.IntermediateField.Adjoin.Basic +public import Mathlib.FieldTheory.Minpoly.Field +public import Mathlib.RingTheory.Localization.FractionRing +public import Mathlib.Algebra.MvPolynomial.NoZeroDivisors +public import Mathlib.RingTheory.AlgebraicIndependent.Transcendental + +/-! +# Function fields of irreducible affine plane curves + +This file constructs the affine coordinate domain and its fraction field directly from an +irreducible polynomial in two variables. It also records the two coordinate functions and their +defining relation. These are the algebraic objects used in the plane-curve specialization of the +Corvaja--Zannier argument. +-/ + +@[expose] public section + +namespace BGS.CorvajaZannier + +noncomputable section + +variable {K : Type*} [Field K] + +/-- The affine coordinate ring of the plane curve cut out by `f`. -/ +abbrev PlaneCurveCoordinateRing (f : MvPolynomial (Fin 2) K) := + MvPolynomial (Fin 2) K ⧸ Ideal.span {f} + +/-- The quotient map from the polynomial ring to the affine coordinate ring. -/ +abbrev planeCurveQuotientMap (f : MvPolynomial (Fin 2) K) : + MvPolynomial (Fin 2) K →+* PlaneCurveCoordinateRing f := + Ideal.Quotient.mk (Ideal.span {f}) + +/-- The two affine coordinate classes in the coordinate ring. -/ +def planeCurveCoordinate (f : MvPolynomial (Fin 2) K) (i : Fin 2) : + PlaneCurveCoordinateRing f := + planeCurveQuotientMap f (MvPolynomial.X i) + +/-- Evaluation at the coordinate classes is the quotient map. -/ +theorem eval₂_planeCurveCoordinate (f : MvPolynomial (Fin 2) K) : + MvPolynomial.eval₂Hom + (algebraMap K (PlaneCurveCoordinateRing f)) (planeCurveCoordinate f) = + planeCurveQuotientMap f := by + apply MvPolynomial.ringHom_ext + · intro c + rw [MvPolynomial.eval₂Hom_C] + change algebraMap K (PlaneCurveCoordinateRing f) c = + Ideal.Quotient.mk (Ideal.span {f}) (MvPolynomial.C c) + rw [← MvPolynomial.algebraMap_eq, Ideal.Quotient.mk_algebraMap] + · intro i + simp [planeCurveCoordinate, planeCurveQuotientMap] + +/-- The coordinate classes satisfy the equation defining the curve. -/ +theorem eval₂_planeCurveCoordinate_eq_zero (f : MvPolynomial (Fin 2) K) : + MvPolynomial.eval₂ (algebraMap K (PlaneCurveCoordinateRing f)) + (planeCurveCoordinate f) f = 0 := by + change (MvPolynomial.eval₂Hom + (algebraMap K (PlaneCurveCoordinateRing f)) (planeCurveCoordinate f)) f = 0 + rw [eval₂_planeCurveCoordinate] + exact Ideal.Quotient.eq_zero_iff_mem.mpr (Ideal.subset_span (Set.mem_singleton f)) + +/-- Irreducibility of the equation makes its affine coordinate ring a domain. -/ +theorem planeCurveCoordinateRing_isDomain + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) : + IsDomain (PlaneCurveCoordinateRing f) := by + have hprime : (Ideal.span {f} : Ideal (MvPolynomial (Fin 2) K)).IsPrime := + (Ideal.span_singleton_prime hf.ne_zero).mpr hf.prime + exact (Ideal.Quotient.isDomain_iff_prime (Ideal.span {f})).mpr hprime + +/-- The rational function field of the affine plane curve. -/ +abbrev PlaneCurveFunctionField (f : MvPolynomial (Fin 2) K) := + FractionRing (PlaneCurveCoordinateRing f) + +/-- A coordinate function in the fraction field of the curve. -/ +def planeCurveFunction (f : MvPolynomial (Fin 2) K) (i : Fin 2) : + PlaneCurveFunctionField f := + algebraMap (PlaneCurveCoordinateRing f) (PlaneCurveFunctionField f) + (planeCurveCoordinate f i) + +/-- The quotient map followed by passage to the fraction field is evaluation at the two +coordinate functions. -/ +theorem eval₂_planeCurveFunction + (f : MvPolynomial (Fin 2) K) : + MvPolynomial.eval₂Hom + (algebraMap K (PlaneCurveFunctionField f)) (planeCurveFunction f) = + (algebraMap (PlaneCurveCoordinateRing f) (PlaneCurveFunctionField f)).comp + (planeCurveQuotientMap f) := by + apply MvPolynomial.ringHom_ext + · intro c + rw [MvPolynomial.eval₂Hom_C, RingHom.comp_apply] + change algebraMap K (PlaneCurveFunctionField f) c = + algebraMap (PlaneCurveCoordinateRing f) (PlaneCurveFunctionField f) + (Ideal.Quotient.mk (Ideal.span {f}) (MvPolynomial.C c)) + rw [← MvPolynomial.algebraMap_eq, Ideal.Quotient.mk_algebraMap, + ← IsScalarTower.algebraMap_apply] + · intro i + simp [planeCurveFunction, planeCurveCoordinate, planeCurveQuotientMap] + +/-- The two rational coordinate functions satisfy the equation of the curve. -/ +theorem eval₂_planeCurveFunction_eq_zero + (f : MvPolynomial (Fin 2) K) : + MvPolynomial.eval₂ (algebraMap K (PlaneCurveFunctionField f)) + (planeCurveFunction f) f = 0 := by + change (MvPolynomial.eval₂Hom + (algebraMap K (PlaneCurveFunctionField f)) (planeCurveFunction f)) f = 0 + rw [eval₂_planeCurveFunction f, RingHom.comp_apply] + rw [Ideal.Quotient.eq_zero_iff_mem.mpr (Ideal.subset_span (Set.mem_singleton f)), map_zero] + +/-- Every affine regular function, viewed in the fraction field, belongs to the field generated by +the two coordinate functions. -/ +theorem algebraMap_coordinateRing_mem_adjoin_coordinates + {f : MvPolynomial (Fin 2) K} [IsDomain (PlaneCurveCoordinateRing f)] + (a : PlaneCurveCoordinateRing f) : + algebraMap (PlaneCurveCoordinateRing f) (PlaneCurveFunctionField f) a ∈ + IntermediateField.adjoin K (Set.range (planeCurveFunction f)) := by + obtain ⟨p, rfl⟩ := Ideal.Quotient.mk_surjective a + change + ((algebraMap (PlaneCurveCoordinateRing f) (PlaneCurveFunctionField f)).comp + (planeCurveQuotientMap f)) p ∈ + IntermediateField.adjoin K (Set.range (planeCurveFunction f)) + rw [← eval₂_planeCurveFunction f] + exact MvPolynomial.eval₂_mem + (fun _ _ ↦ (IntermediateField.adjoin K + (Set.range (planeCurveFunction f))).algebraMap_mem _) + (fun i ↦ IntermediateField.subset_adjoin K _ ⟨i, rfl⟩) + +/-- The fraction field is generated, as a field over `K`, by its two coordinate functions. -/ +theorem adjoin_planeCurveFunctions_eq_top + {f : MvPolynomial (Fin 2) K} [IsDomain (PlaneCurveCoordinateRing f)] : + IntermediateField.adjoin K (Set.range (planeCurveFunction f)) = ⊤ := by + apply top_unique + intro z _ + obtain ⟨a, b, _hb, hz⟩ := + IsFractionRing.div_surjective (PlaneCurveCoordinateRing f) z + rw [← hz] + exact div_mem (algebraMap_coordinateRing_mem_adjoin_coordinates a) + (algebraMap_coordinateRing_mem_adjoin_coordinates b) + +/-- Irreducibility supplies the domain instance needed by +`adjoin_planeCurveFunctions_eq_top`. -/ +theorem adjoin_planeCurveFunctions_eq_top_of_irreducible + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) : + letI := planeCurveCoordinateRing_isDomain hf + IntermediateField.adjoin K (Set.range (planeCurveFunction f)) = ⊤ := by + let : IsDomain (PlaneCurveCoordinateRing f) := planeCurveCoordinateRing_isDomain hf + exact adjoin_planeCurveFunctions_eq_top + +/-- Embed a univariate polynomial in the first coordinate of the affine plane. -/ +def polynomialInFirstCoordinate (P : Polynomial K) : MvPolynomial (Fin 2) K := + P.sum fun n c ↦ MvPolynomial.C c * MvPolynomial.X 0 ^ n + +/-- Evaluating a polynomial embedded in the first coordinate is ordinary univariate evaluation. -/ +theorem eval₂_polynomialInFirstCoordinate + {S : Type*} [CommSemiring S] (P : Polynomial K) (phi : K →+* S) (x y : S) : + MvPolynomial.eval₂ phi ![x, y] (polynomialInFirstCoordinate P) = + P.eval₂ phi x := by + classical + simp [polynomialInFirstCoordinate, Polynomial.sum_def, Polynomial.eval₂_eq_sum] + +/-- The embedding in the first coordinate is injective. -/ +theorem polynomialInFirstCoordinate_ne_zero {P : Polynomial K} (hP : P ≠ 0) : + polynomialInFirstCoordinate P ≠ 0 := by + intro hzero + have heval := eval₂_polynomialInFirstCoordinate P Polynomial.C + Polynomial.X (0 : Polynomial K) + rw [hzero, MvPolynomial.eval₂_zero] at heval + apply hP + simpa using heval.symm + +private theorem planeCurve_degreeOf_finset_sum_le + {R ι : Type*} [CommSemiring R] + (coordinate : Fin 2) (terms : ι → MvPolynomial (Fin 2) R) + (indices : Finset ι) (bound : ℕ) + (hterms : ∀ i ∈ indices, MvPolynomial.degreeOf coordinate (terms i) ≤ bound) : + MvPolynomial.degreeOf coordinate (∑ i ∈ indices, terms i) ≤ bound := by + classical + induction indices using Finset.induction_on with + | empty => simp + | @insert i indices hi ih => + rw [Finset.sum_insert hi] + exact (MvPolynomial.degreeOf_add_le _ _ _).trans + (max_le (hterms i (Finset.mem_insert_self i indices)) + (ih fun j hj ↦ hterms j (Finset.mem_insert_of_mem hj))) + +/-- A polynomial embedded in the first coordinate has degree zero in the second coordinate. -/ +theorem polynomialInFirstCoordinate_degreeOf_second_le (P : Polynomial K) : + MvPolynomial.degreeOf (1 : Fin 2) (polynomialInFirstCoordinate P) ≤ 0 := by + classical + rw [polynomialInFirstCoordinate, Polynomial.sum_def] + apply planeCurve_degreeOf_finset_sum_le (1 : Fin 2) _ P.support 0 + intro n _hn + calc + MvPolynomial.degreeOf (1 : Fin 2) + (MvPolynomial.C (P.coeff n) * MvPolynomial.X 0 ^ n) ≤ + MvPolynomial.degreeOf (1 : Fin 2) (MvPolynomial.C (P.coeff n)) + + MvPolynomial.degreeOf (1 : Fin 2) (MvPolynomial.X 0 ^ n) := + MvPolynomial.degreeOf_mul_le _ _ _ + _ ≤ 0 := by + have hpow : MvPolynomial.degreeOf (1 : Fin 2) + (MvPolynomial.X 0 ^ n : MvPolynomial (Fin 2) K) ≤ 0 := by + calc + _ ≤ n * MvPolynomial.degreeOf (1 : Fin 2) (MvPolynomial.X 0) := + MvPolynomial.degreeOf_pow_le _ _ _ + _ = 0 := by rw [MvPolynomial.degreeOf_X]; norm_num + rw [MvPolynomial.degreeOf_C] + simpa using hpow + +/-- On an irreducible plane curve of positive second-coordinate degree, the first coordinate +function is transcendental over the constant field. -/ +theorem firstCoordinate_transcendental + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hsecond : 0 < MvPolynomial.degreeOf 1 f) : + letI := planeCurveCoordinateRing_isDomain hf + Transcendental K (planeCurveFunction f 0) := by + let : IsDomain (PlaneCurveCoordinateRing f) := planeCurveCoordinateRing_isDomain hf + rw [transcendental_iff] + intro P hPzero + by_contra hP + have hembedded : polynomialInFirstCoordinate P ≠ 0 := + polynomialInFirstCoordinate_ne_zero hP + have hquotient : planeCurveQuotientMap f (polynomialInFirstCoordinate P) = 0 := by + apply IsFractionRing.injective (PlaneCurveCoordinateRing f) (PlaneCurveFunctionField f) + rw [map_zero] + change + ((algebraMap (PlaneCurveCoordinateRing f) (PlaneCurveFunctionField f)).comp + (planeCurveQuotientMap f)) (polynomialInFirstCoordinate P) = 0 + rw [← eval₂_planeCurveFunction f] + have hcoordinates : planeCurveFunction f = + ![planeCurveFunction f 0, planeCurveFunction f 1] := by + funext i + fin_cases i <;> rfl + rw [hcoordinates] + change MvPolynomial.eval₂ (algebraMap K (PlaneCurveFunctionField f)) + ![planeCurveFunction f 0, planeCurveFunction f 1] + (polynomialInFirstCoordinate P) = 0 + rw [eval₂_polynomialInFirstCoordinate] + simpa [Polynomial.aeval_def] using hPzero + have hdvd : f ∣ polynomialInFirstCoordinate P := + Ideal.mem_span_singleton.mp (Ideal.Quotient.eq_zero_iff_mem.mp hquotient) + obtain ⟨g, hg⟩ := hdvd + have hgzero : g ≠ 0 := by + intro hzero + apply hembedded + rw [hg, hzero, mul_zero] + have hdegree : MvPolynomial.degreeOf 1 f ≤ + MvPolynomial.degreeOf 1 (polynomialInFirstCoordinate P) := by + rw [hg, MvPolynomial.degreeOf_mul_eq hf.ne_zero hgzero] + exact Nat.le_add_right _ _ + have hzeroDegree := polynomialInFirstCoordinate_degreeOf_second_le P + omega + +/-- The intermediate field generated by the first coordinate function. -/ +abbrev FirstCoordinateSubfield + (f : MvPolynomial (Fin 2) K) [IsDomain (PlaneCurveCoordinateRing f)] := + IntermediateField.adjoin K ({planeCurveFunction f 0} : Set (PlaneCurveFunctionField f)) + +/-- The first coordinate function, regarded as an element of its generated subfield. -/ +def firstCoordinateInSubfield + (f : MvPolynomial (Fin 2) K) [IsDomain (PlaneCurveCoordinateRing f)] : + FirstCoordinateSubfield f := + ⟨planeCurveFunction f 0, + IntermediateField.mem_adjoin_simple_self K (planeCurveFunction f 0)⟩ + +/-- Regard the plane equation as a polynomial in the second coordinate, with coefficients in the +field generated by the first coordinate. -/ +def polynomialOverFirstCoordinate + (f : MvPolynomial (Fin 2) K) [IsDomain (PlaneCurveCoordinateRing f)] : + Polynomial (FirstCoordinateSubfield f) := + MvPolynomial.eval₂ (algebraMap K (Polynomial (FirstCoordinateSubfield f))) + ![Polynomial.C (firstCoordinateInSubfield f), Polynomial.X] f + +/-- The same change of viewpoint before specializing the remaining coefficient variable. The +outer polynomial variable is the original second coordinate. -/ +def polynomialInSecondCoordinate (f : MvPolynomial (Fin 2) K) : + Polynomial (MvPolynomial {i : Fin 2 // i ≠ 1} K) := + MvPolynomial.optionEquivLeft K {i : Fin 2 // i ≠ 1} + (MvPolynomial.rename (Equiv.optionSubtypeNe (1 : Fin 2)).symm f) + +/-- The iterated-polynomial presentation preserves nonzeroness. -/ +theorem polynomialInSecondCoordinate_ne_zero + {f : MvPolynomial (Fin 2) K} (hf : f ≠ 0) : + polynomialInSecondCoordinate f ≠ 0 := by + intro hzero + apply hf + apply MvPolynomial.rename_injective + (Equiv.optionSubtypeNe (1 : Fin 2)).symm + (Equiv.optionSubtypeNe (1 : Fin 2)).symm.injective + apply (MvPolynomial.optionEquivLeft K {i : Fin 2 // i ≠ 1}).injective + simpa [polynomialInSecondCoordinate] using hzero + +/-- Evaluate the sole coefficient variable at the first coordinate function. -/ +def firstCoordinateCoefficientEval + (f : MvPolynomial (Fin 2) K) [IsDomain (PlaneCurveCoordinateRing f)] : + MvPolynomial {i : Fin 2 // i ≠ 1} K →+* FirstCoordinateSubfield f := + MvPolynomial.eval₂Hom (algebraMap K (FirstCoordinateSubfield f)) + (fun _ ↦ firstCoordinateInSubfield f) + +/-- Positive degree in the second coordinate makes coefficient evaluation at the first coordinate +injective. -/ +theorem firstCoordinateCoefficientEval_injective + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hsecond : 0 < MvPolynomial.degreeOf 1 f) : + letI := planeCurveCoordinateRing_isDomain hf + Function.Injective (firstCoordinateCoefficientEval f) := by + let : IsDomain (PlaneCurveCoordinateRing f) := planeCurveCoordinateRing_isDomain hf + let remaining := {i : Fin 2 // i ≠ 1} + have remaining_value_zero (i : remaining) : i.1 = 0 := by + omega + let : Subsingleton remaining := + ⟨fun i j ↦ Subtype.ext ((remaining_value_zero i).trans (remaining_value_zero j).symm)⟩ + let i0 : remaining := ⟨0, by decide⟩ + have hIndependent : AlgebraicIndependent K + (fun _ : remaining ↦ planeCurveFunction f 0) := by + rw [algebraicIndependent_singleton_iff i0] + exact firstCoordinate_transcendental hf hsecond + let composed : MvPolynomial remaining K →+* PlaneCurveFunctionField f := + (algebraMap (FirstCoordinateSubfield f) (PlaneCurveFunctionField f)).comp + (firstCoordinateCoefficientEval f) + let evaluated : MvPolynomial remaining K →+* PlaneCurveFunctionField f := + MvPolynomial.eval₂Hom (algebraMap K (PlaneCurveFunctionField f)) + (fun _ ↦ planeCurveFunction f 0) + have hhom : composed = evaluated := by + apply MvPolynomial.ringHom_ext + · intro c + simp [composed, evaluated, firstCoordinateCoefficientEval] + · intro i + simp [composed, evaluated, firstCoordinateCoefficientEval, + firstCoordinateInSubfield] + intro a b hab + apply (algebraicIndependent_iff_injective_aeval.mp hIndependent) + change evaluated a = evaluated b + rw [← hhom] + exact congrArg (algebraMap (FirstCoordinateSubfield f) (PlaneCurveFunctionField f)) hab + +/-- The direct two-variable specialization agrees with the standard +`MvPolynomial.optionEquivLeft` presentation. -/ +theorem polynomialOverFirstCoordinate_eq_map_polynomialInSecondCoordinate + (f : MvPolynomial (Fin 2) K) [IsDomain (PlaneCurveCoordinateRing f)] : + polynomialOverFirstCoordinate f = + (polynomialInSecondCoordinate f).map (firstCoordinateCoefficientEval f) := by + let lhs : MvPolynomial (Fin 2) K →+* Polynomial (FirstCoordinateSubfield f) := + MvPolynomial.eval₂Hom (algebraMap K (Polynomial (FirstCoordinateSubfield f))) + ![Polynomial.C (firstCoordinateInSubfield f), Polynomial.X] + let rhs : MvPolynomial (Fin 2) K →+* Polynomial (FirstCoordinateSubfield f) := + (Polynomial.mapRingHom (firstCoordinateCoefficientEval f)).comp + ((MvPolynomial.optionEquivLeft K {i : Fin 2 // i ≠ 1}).toRingEquiv.toRingHom.comp + (MvPolynomial.rename (Equiv.optionSubtypeNe (1 : Fin 2)).symm).toRingHom) + change lhs f = rhs f + congr 1 + apply MvPolynomial.ringHom_ext + · intro c + simp [lhs, rhs, firstCoordinateCoefficientEval] + · intro i + fin_cases i <;> + simp [lhs, rhs, firstCoordinateCoefficientEval, firstCoordinateInSubfield] + +/-- Irreducibility and positive degree in the second variable ensure that the equation remains +nonzero after passing to the field generated by the first coordinate. -/ +theorem polynomialOverFirstCoordinate_ne_zero_of_irreducible + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hsecond : 0 < MvPolynomial.degreeOf 1 f) : + letI := planeCurveCoordinateRing_isDomain hf + polynomialOverFirstCoordinate f ≠ 0 := by + let : IsDomain (PlaneCurveCoordinateRing f) := planeCurveCoordinateRing_isDomain hf + rw [polynomialOverFirstCoordinate_eq_map_polynomialInSecondCoordinate] + exact (Polynomial.map_ne_zero_iff + (firstCoordinateCoefficientEval_injective hf hsecond)).mpr + (polynomialInSecondCoordinate_ne_zero hf.ne_zero) + +/-- Specializing the coefficient variable cannot increase the degree in the second coordinate. -/ +theorem natDegree_polynomialOverFirstCoordinate_le_degreeOf_second + (f : MvPolynomial (Fin 2) K) [IsDomain (PlaneCurveCoordinateRing f)] : + (polynomialOverFirstCoordinate f).natDegree ≤ MvPolynomial.degreeOf 1 f := by + rw [polynomialOverFirstCoordinate_eq_map_polynomialInSecondCoordinate] + calc + ((polynomialInSecondCoordinate f).map + (firstCoordinateCoefficientEval f)).natDegree ≤ + (polynomialInSecondCoordinate f).natDegree := Polynomial.natDegree_map_le + _ = MvPolynomial.degreeOf 1 f := + (MvPolynomial.degreeOf_eq_natDegree (1 : Fin 2) f).symm + +/-- Substituting the second coordinate function into `polynomialOverFirstCoordinate` recovers the +defining plane-curve relation. -/ +theorem eval₂_polynomialOverFirstCoordinate_eq_zero + (f : MvPolynomial (Fin 2) K) [IsDomain (PlaneCurveCoordinateRing f)] : + Polynomial.eval₂ + (algebraMap (FirstCoordinateSubfield f) (PlaneCurveFunctionField f)) + (planeCurveFunction f 1) (polynomialOverFirstCoordinate f) = 0 := by + let lhs : MvPolynomial (Fin 2) K →+* PlaneCurveFunctionField f := + (Polynomial.eval₂RingHom + (algebraMap (FirstCoordinateSubfield f) (PlaneCurveFunctionField f)) + (planeCurveFunction f 1)).comp + (MvPolynomial.eval₂Hom + (algebraMap K (Polynomial (FirstCoordinateSubfield f))) + ![Polynomial.C (firstCoordinateInSubfield f), Polynomial.X]) + let rhs : MvPolynomial (Fin 2) K →+* PlaneCurveFunctionField f := + MvPolynomial.eval₂Hom (algebraMap K (PlaneCurveFunctionField f)) + (planeCurveFunction f) + have hhom : lhs = rhs := by + apply MvPolynomial.ringHom_ext + · intro c + simp [lhs, rhs] + · intro i + fin_cases i <;> + simp [lhs, rhs, firstCoordinateInSubfield] + change lhs f = 0 + rw [hhom] + exact eval₂_planeCurveFunction_eq_zero f + +/-- If the specialized equation is nonzero, the second coordinate is algebraic over the field +generated by the first coordinate. -/ +theorem secondCoordinate_isAlgebraic_over_first + (f : MvPolynomial (Fin 2) K) [IsDomain (PlaneCurveCoordinateRing f)] + (hpoly : polynomialOverFirstCoordinate f ≠ 0) : + IsAlgebraic (FirstCoordinateSubfield f) (planeCurveFunction f 1) := by + refine ⟨polynomialOverFirstCoordinate f, hpoly, ?_⟩ + simpa [Polynomial.aeval_def] using eval₂_polynomialOverFirstCoordinate_eq_zero f + +/-- The range of the coordinate-function family is exactly the two-element set of affine +coordinates. -/ +theorem range_planeCurveFunction + (f : MvPolynomial (Fin 2) K) : + Set.range (planeCurveFunction f) = + ({planeCurveFunction f 0, planeCurveFunction f 1} : + Set (PlaneCurveFunctionField f)) := by + ext z + constructor + · rintro ⟨i, rfl⟩ + fin_cases i <;> simp + · intro hz + rcases hz with (rfl | rfl) + · exact ⟨0, rfl⟩ + · exact ⟨1, rfl⟩ + +/-- After adjoining the first coordinate to `K`, adjoining the second coordinate generates the +entire plane-curve function field. -/ +theorem adjoin_secondCoordinate_over_first_eq_top + (f : MvPolynomial (Fin 2) K) [IsDomain (PlaneCurveCoordinateRing f)] : + IntermediateField.adjoin (FirstCoordinateSubfield f) {planeCurveFunction f 1} = ⊤ := by + have hpair : + IntermediateField.adjoin K + ({planeCurveFunction f 0, planeCurveFunction f 1} : + Set (PlaneCurveFunctionField f)) = ⊤ := by + rw [← range_planeCurveFunction f] + exact adjoin_planeCurveFunctions_eq_top + apply IntermediateField.restrictScalars_injective K + rw [IntermediateField.restrictScalars_top] + change + (IntermediateField.adjoin + (IntermediateField.adjoin K {planeCurveFunction f 0}) + {planeCurveFunction f 1}).restrictScalars K = ⊤ + rw [IntermediateField.adjoin_adjoin_left] + simpa only [Set.singleton_union] using hpair + +/-- A nonzero specialization of the plane equation makes the function field finite-dimensional +over the field generated by the first coordinate. -/ +theorem finiteDimensional_over_firstCoordinate + (f : MvPolynomial (Fin 2) K) [IsDomain (PlaneCurveCoordinateRing f)] + (hpoly : polynomialOverFirstCoordinate f ≠ 0) : + FiniteDimensional (FirstCoordinateSubfield f) (PlaneCurveFunctionField f) := by + have halg := secondCoordinate_isAlgebraic_over_first f hpoly + let : FiniteDimensional (FirstCoordinateSubfield f) + (IntermediateField.adjoin (FirstCoordinateSubfield f) {planeCurveFunction f 1}) := + IntermediateField.adjoin.finiteDimensional halg.isIntegral + let : FiniteDimensional (FirstCoordinateSubfield f) + (⊤ : IntermediateField (FirstCoordinateSubfield f) (PlaneCurveFunctionField f)) := by + rw [← adjoin_secondCoordinate_over_first_eq_top f] + infer_instance + exact IntermediateField.topEquiv.toLinearEquiv.finiteDimensional + +/-- The extension degree over the first-coordinate field is at most the degree of the plane +equation in the second coordinate. -/ +theorem finrank_over_firstCoordinate_le_degreeOf_second + (f : MvPolynomial (Fin 2) K) [IsDomain (PlaneCurveCoordinateRing f)] + (hpoly : polynomialOverFirstCoordinate f ≠ 0) : + Module.finrank (FirstCoordinateSubfield f) (PlaneCurveFunctionField f) ≤ + MvPolynomial.degreeOf 1 f := by + let : FiniteDimensional (FirstCoordinateSubfield f) (PlaneCurveFunctionField f) := + finiteDimensional_over_firstCoordinate f hpoly + have halg := secondCoordinate_isAlgebraic_over_first f hpoly + have hroot : Polynomial.aeval (planeCurveFunction f 1) + (polynomialOverFirstCoordinate f) = 0 := by + simpa [Polynomial.aeval_def] using eval₂_polynomialOverFirstCoordinate_eq_zero f + calc + Module.finrank (FirstCoordinateSubfield f) (PlaneCurveFunctionField f) = + Module.finrank (FirstCoordinateSubfield f) + (⊤ : IntermediateField (FirstCoordinateSubfield f) + (PlaneCurveFunctionField f)) := + by rw [IntermediateField.finrank_top'] + _ = Module.finrank (FirstCoordinateSubfield f) + (IntermediateField.adjoin (FirstCoordinateSubfield f) + {planeCurveFunction f 1}) := by + rw [adjoin_secondCoordinate_over_first_eq_top f] + _ = (minpoly (FirstCoordinateSubfield f) (planeCurveFunction f 1)).natDegree := + IntermediateField.adjoin.finrank halg.isIntegral + _ ≤ (polynomialOverFirstCoordinate f).natDegree := + Polynomial.natDegree_le_of_dvd + (minpoly.dvd (FirstCoordinateSubfield f) (planeCurveFunction f 1) hroot) hpoly + _ ≤ MvPolynomial.degreeOf 1 f := + natDegree_polynomialOverFirstCoordinate_le_degreeOf_second f + +/-- A nonzero partial derivative in the second coordinate forces positive degree in that +coordinate. -/ +theorem degreeOf_second_pos_of_pderiv_ne_zero + {f : MvPolynomial (Fin 2) K} (hderiv : MvPolynomial.pderiv 1 f ≠ 0) : + 0 < MvPolynomial.degreeOf 1 f := by + apply Nat.pos_of_ne_zero + apply MvPolynomial.mem_vars_iff_degreeOf_ne_zero.mp + by_contra hmem + exact hderiv (MvPolynomial.pderiv_eq_zero_of_notMem_vars hmem) + +/-- For an irreducible plane equation depending on the second coordinate, the function field is +finite over the field generated by the first coordinate. -/ +theorem finiteDimensional_over_firstCoordinate_of_irreducible + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hderiv : MvPolynomial.pderiv 1 f ≠ 0) : + letI := planeCurveCoordinateRing_isDomain hf + FiniteDimensional (FirstCoordinateSubfield f) (PlaneCurveFunctionField f) := by + let : IsDomain (PlaneCurveCoordinateRing f) := planeCurveCoordinateRing_isDomain hf + exact finiteDimensional_over_firstCoordinate f + (polynomialOverFirstCoordinate_ne_zero_of_irreducible hf + (degreeOf_second_pos_of_pderiv_ne_zero hderiv)) + +/-- The degree of the plane-curve function field over the first-coordinate rational subfield is +bounded by the degree of the defining equation in the second coordinate. -/ +theorem finrank_over_firstCoordinate_le_degreeOf_second_of_irreducible + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hderiv : MvPolynomial.pderiv 1 f ≠ 0) : + letI := planeCurveCoordinateRing_isDomain hf + Module.finrank (FirstCoordinateSubfield f) (PlaneCurveFunctionField f) ≤ + MvPolynomial.degreeOf 1 f := by + let : IsDomain (PlaneCurveCoordinateRing f) := planeCurveCoordinateRing_isDomain hf + exact finrank_over_firstCoordinate_le_degreeOf_second f + (polynomialOverFirstCoordinate_ne_zero_of_irreducible hf + (degreeOf_second_pos_of_pderiv_ne_zero hderiv)) + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurveInfinityComplement.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurveInfinityComplement.lean new file mode 100644 index 0000000000..53d56fe6b1 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurveInfinityComplement.lean @@ -0,0 +1,117 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveInfinityDifferentDegree + +/-! +# The complementary different bound above infinity + +For a primitive infinity-chart equation of bidegree at most `(a,b)`, the +weighted different contribution above infinity is bounded by + +`a * (2 * b - 2) - degree(discriminant)`. + +Together with the finite-place discriminant bound, this gives the sharp total +different budget used in the Corvaja--Zannier plane-curve estimate. +-/ + +@[expose] public section + +open scoped Polynomial nonZeroDivisors +open Multiplicative WithZero Polynomial IsDedekindDomain + +namespace BGS.CorvajaZannier + +noncomputable section + +variable (K : Type*) [Field K] [DecidableEq K] [DecidableEq (RatFunc K)] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +local instance infinityComplementConstantAlgebra : + Algebra K (RatFuncInfinityIntegers K) := + (ratFuncInfinityConstantRingHom K).toAlgebra + +local instance infinityComplementConstantTower : + IsScalarTower K (RatFuncInfinityIntegers K) (RatFunc K) := + .of_algebraMap_eq' rfl + +local instance infinityComplementTopIsTorsionFree : + Module.IsTorsionFree (RatFuncInfinityIntegers K) L := + Module.IsTorsionFree.trans_faithfulSMul + (RatFuncInfinityIntegers K) (RatFunc K) L + +/-- The residue-degree-weighted different above infinity is bounded by the +complement of the finite discriminant degree in the full bidegree budget. -/ +theorem planeCurveInfinityDifferentDegree_le_bidegreeComplement + (a : ℕ) (F : K[X][X]) + (hcoeff : ∀ i, (F.coeff i).natDegree ≤ a) + (i : ℕ) (hFi : F.coeff i ≠ 0) + (hi : (F.coeff i).natDegree = a) + (v : L) + (hv : aeval v (infinityNormalizedIntegralPolynomial K a F hcoeff) = 0) + (hprimitive : Algebra.adjoin (RatFunc K) {v} = ⊤) + (hdegree : F.natDegree = Module.finrank (RatFunc K) L) + (hFdiscr : F.discr ≠ 0) + (hcard : (F.natDegree : Cardinal) < Cardinal.mk K) : + (infinityDifferentDegree K L : ℤ) ≤ + (a * (2 * F.natDegree - 2) : ℕ) - (F.discr.natDegree : ℤ) := by + let A := RatFuncInfinityIntegers K + let G : A[X] := infinityNormalizedIntegralPolynomial K a F hcoeff + have hGprimitive : G.IsPrimitive := by + exact infinityNormalizedIntegralPolynomial_isPrimitive K a F hcoeff i hFi hi + have hmapG : G.map (algebraMap A (RatFunc K)) = + infinityNormalizedPolynomial K a F := by + exact infinityNormalizedIntegralPolynomial_map K a F hcoeff + have hGdegree : G.natDegree = F.natDegree := by + have h := congrArg Polynomial.natDegree hmapG + rw [natDegree_map_eq_of_injective + (IsFractionRing.injective A (RatFunc K)), + infinityNormalizedPolynomial_natDegree] at h + exact h + obtain ⟨c, hc⟩ := + exists_local_center_eval_isUnit_of_isPrimitive_natDegree_lt_card + G hGprimitive (by simpa [hGdegree] using hcard) + have hcunit := hc + obtain ⟨u, hu⟩ := hc + have hvc : v ≠ algebraMap A L c := by + intro heq + have hzero : algebraMap A L (G.eval c) = 0 := by + simpa [G, heq] using hv + exact (IsUnit.map (algebraMap A L) hcunit).ne_zero hzero + have hdiscrMap : algebraMap A (RatFunc K) G.discr = + (infinityNormalizedPolynomial K a F).discr := by + rw [← hmapG] + exact (discr_map_of_injective (algebraMap A (RatFunc K)) + (IsFractionRing.injective A (RatFunc K)) G).symm + have hnormDiscr : (infinityNormalizedPolynomial K a F).discr ≠ 0 := by + rw [infinityNormalizedPolynomial_discr] + exact mul_ne_zero + (pow_ne_zero _ (pow_ne_zero _ (inv_ne_zero RatFunc.X_ne_zero))) + (RatFunc.algebraMap_ne_zero hFdiscr) + have hGdiscr : G.discr ≠ 0 := by + intro hzero + apply hnormDiscr + rw [← hdiscrMap, hzero, map_zero] + have hbound := + infinityDifferentDegree_le_discriminantOrder_of_primitiveElement + K L G c u v hu.symm hvc hv hprimitive + (hGdegree.trans hdegree) hGdiscr + calc + (infinityDifferentDegree K L : ℤ) ≤ + ratFuncInfinityOrder (algebraMap A (RatFunc K) G.discr) := hbound + _ = ratFuncInfinityOrder (infinityNormalizedPolynomial K a F).discr := by + rw [hdiscrMap] + _ = (a * (2 * F.natDegree - 2) : ℕ) - + (F.discr.natDegree : ℤ) := + ratFuncInfinityOrder_infinityNormalizedPolynomial_discr K a F hFdiscr + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurveInfinityDifferentBound.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurveInfinityDifferentBound.lean new file mode 100644 index 0000000000..fe36cd4599 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurveInfinityDifferentBound.lean @@ -0,0 +1,244 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionExhaustiveProductFormula +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.InfinityInertiaDegree +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.LocalReciprocalDiscriminant +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveDiscriminantBound +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveLocalReciprocalDiscriminant +public import Mathlib.Tactic + +/-! +# The discriminant budget at infinity for a plane curve + +Let `F` be a polynomial in `Y` with coefficients in `K[X]`, and suppose that +every coefficient has `X`-degree at most `a`. On the infinity chart of the +first projection the integral normalization of the equation is obtained by +multiplying by `X⁻ᵃ`. Its discriminant is therefore + +`X⁻ᵃ⁽²ᵇ⁻²⁾ * discr(F)`. + +The order of this element at infinity is exactly + +`a * (2 * b - 2) - degree(discr(F))`. + +This is the key complementarity needed for a Riemann--Hurwitz-free proof: +the finite discriminant contribution is at most `degree(discr(F))`, while the +above-infinity contribution is at most the displayed complementary order. +In particular, one must not bound the finite and infinity contributions +independently by `a * (2 * b - 2)`. + +The module also constructs the coefficientwise integral polynomial over the +infinity valuation ring. Identifying a reciprocal translate of that +polynomial with a primitive element of the plane-curve function field is the +remaining local normalization step. +-/ + +@[expose] public section + +open scoped Polynomial nonZeroDivisors +open Multiplicative WithZero Polynomial IsDedekindDomain + +namespace BGS.CorvajaZannier + +noncomputable section + +universe u + +/-- A primitive polynomial over a local ring has a unit value at some center +as soon as its degree is smaller than the cardinality of a coefficient field. +The coefficient field and local ring are kept in the same universe, which is +the case needed for the infinity valuation ring of `K(X)`. -/ +theorem exists_local_center_eval_isUnit_of_isPrimitive_natDegree_lt_card + {K A : Type u} [Field K] [CommRing A] [IsLocalRing A] + [IsBezout A] [Algebra K A] + (F : A[X]) (hF : F.IsPrimitive) + (hcardK : (F.natDegree : Cardinal) < Cardinal.mk K) : + ∃ c : A, IsUnit (F.eval c) := by + let m := IsLocalRing.maximalIdeal A + let k := A ⧸ m + let π : A →+* k := Ideal.Quotient.mk m + have hFbar : F.map π ≠ 0 := by + intro hzero + have hcoeff : ∀ i, F.coeff i ∈ m := by + intro i + have hi := congrArg (fun q : k[X] => q.coeff i) hzero + rw [Polynomial.coeff_map, Polynomial.coeff_zero] at hi + exact Ideal.Quotient.eq_zero_iff_mem.mp hi + have hcontent : F.contentIdeal ≤ m := by + rw [Polynomial.contentIdeal_def, Ideal.span_le] + intro x hx + obtain ⟨i, _hi, rfl⟩ := Polynomial.mem_coeffs_iff.mp hx + exact hcoeff i + have htop : F.contentIdeal = ⊤ := + (Polynomial.isPrimitive_iff_contentIdeal_eq_top F).mp hF + apply (IsLocalRing.maximalIdeal.isMaximal A).ne_top + apply top_unique + simpa [htop] using hcontent + have hcard : (F.map π).natDegree < Cardinal.mk k := by + have hdegree : ((F.map π).natDegree : Cardinal) ≤ F.natDegree := by + exact_mod_cast Polynomial.natDegree_map_le + exact (hdegree.trans_lt hcardK).trans_le + (Cardinal.mk_le_of_injective + (RingHom.injective (algebraMap K k))) + obtain ⟨c, hc⟩ := + Polynomial.exists_eval_ne_zero_of_natDegree_lt_card (F.map π) hFbar hcard + obtain ⟨a, rfl⟩ := Ideal.Quotient.mk_surjective c + refine ⟨a, IsLocalRing.notMem_maximalIdeal.mp ?_⟩ + intro hmem + apply hc + rw [Polynomial.eval_map_apply] + change π (F.eval a) = 0 + exact Ideal.Quotient.eq_zero_iff_mem.mpr hmem + +variable (K : Type*) [Field K] [DecidableEq K] [DecidableEq (RatFunc K)] + +/-! ## The normalized equation over `K(X)` -/ + +/-- Multiply an equation over `K[X]` by `X⁻ᵃ` on the infinity chart of the +first projection. -/ +def infinityNormalizedPolynomial (a : ℕ) (F : K[X][X]) : (RatFunc K)[X] := + C ((RatFunc.X⁻¹) ^ a) * F.map (algebraMap K[X] (RatFunc K)) + +omit [DecidableEq K] [DecidableEq (RatFunc K)] in +private theorem ratFunc_intDegree_pow (x : RatFunc K) (hx : x ≠ 0) (n : ℕ) : + (x ^ n).intDegree = (n : ℤ) * x.intDegree := by + induction n with + | zero => simp + | succ n ih => + rw [pow_succ, RatFunc.intDegree_mul (pow_ne_zero n hx) hx, ih] + push_cast + ring + +omit [DecidableEq K] [DecidableEq (RatFunc K)] in +/-- Scaling by `X⁻ᵃ` does not change the degree in the second variable. -/ +theorem infinityNormalizedPolynomial_natDegree + (a : ℕ) (F : K[X][X]) : + (infinityNormalizedPolynomial K a F).natDegree = F.natDegree := by + rw [infinityNormalizedPolynomial] + rw [natDegree_C_mul + (pow_ne_zero a (inv_ne_zero RatFunc.X_ne_zero))] + exact natDegree_map_eq_of_injective + (RatFunc.algebraMap_injective K) F + +omit [DecidableEq K] [DecidableEq (RatFunc K)] in +/-- Exact discriminant formula for the infinity-normalized equation. -/ +theorem infinityNormalizedPolynomial_discr + (a : ℕ) (F : K[X][X]) : + (infinityNormalizedPolynomial K a F).discr = + ((RatFunc.X⁻¹) ^ a) ^ (2 * F.natDegree - 2) * + algebraMap K[X] (RatFunc K) F.discr := by + rw [infinityNormalizedPolynomial, + discr_C_mul _ _ (pow_ne_zero a (inv_ne_zero RatFunc.X_ne_zero)), + natDegree_map_eq_of_injective + (RatFunc.algebraMap_injective K), + discr_map_of_injective (algebraMap K[X] (RatFunc K)) + (RatFunc.algebraMap_injective K)] + +omit [DecidableEq K] [DecidableEq (RatFunc K)] in +/-- The infinity order of the normalized discriminant is the complement of +the finite polynomial discriminant degree in the full bidegree budget. -/ +theorem ratFuncInfinityOrder_infinityNormalizedPolynomial_discr + (a : ℕ) (F : K[X][X]) (hdiscr : F.discr ≠ 0) : + ratFuncInfinityOrder (infinityNormalizedPolynomial K a F).discr = + (a * (2 * F.natDegree - 2) : ℕ) - (F.discr.natDegree : ℤ) := by + rw [infinityNormalizedPolynomial_discr] + have hXinv : RatFunc.X⁻¹ ≠ (0 : RatFunc K) := inv_ne_zero RatFunc.X_ne_zero + have hpow : ((RatFunc.X⁻¹) ^ a) ^ (2 * F.natDegree - 2) ≠ + (0 : RatFunc K) := pow_ne_zero _ (pow_ne_zero _ hXinv) + have hmap : algebraMap K[X] (RatFunc K) F.discr ≠ 0 := + RatFunc.algebraMap_ne_zero hdiscr + rw [ratFuncInfinityOrder, + RatFunc.intDegree_mul hpow hmap, + ratFunc_intDegree_pow K ((RatFunc.X⁻¹) ^ a) + (pow_ne_zero _ hXinv) (2 * F.natDegree - 2), + ratFunc_intDegree_pow K (RatFunc.X⁻¹) hXinv a, + RatFunc.intDegree_inv, RatFunc.intDegree_X, + RatFunc.intDegree_polynomial] + push_cast + ring + +/-! ## The normalized equation over the infinity valuation ring -/ + +/-- A polynomial of degree at most `a`, multiplied by `X⁻ᵃ`, is integral at +infinity. -/ +theorem infinityNormalizedCoefficient_mem + (a : ℕ) (P : K[X]) (hdegree : P.natDegree ≤ a) : + RatFunc.inftyValuation K + ((RatFunc.X⁻¹) ^ a * algebraMap K[X] (RatFunc K) P) ≤ 1 := by + by_cases hP : P = 0 + · simp [hP] + have hXinv : RatFunc.X⁻¹ ≠ (0 : RatFunc K) := inv_ne_zero RatFunc.X_ne_zero + have hleft : (RatFunc.X⁻¹) ^ a ≠ (0 : RatFunc K) := pow_ne_zero _ hXinv + have hright : algebraMap K[X] (RatFunc K) P ≠ 0 := + RatFunc.algebraMap_ne_zero hP + rw [RatFunc.inftyValuation_apply, + RatFunc.inftyValuation_of_nonzero (F := K) (mul_ne_zero hleft hright), + RatFunc.intDegree_mul hleft hright, + ratFunc_intDegree_pow K (RatFunc.X⁻¹) hXinv a, + RatFunc.intDegree_inv, RatFunc.intDegree_X, + RatFunc.intDegree_polynomial] + rw [← exp_zero, exp_le_exp] + have hdegree' : (P.natDegree : ℤ) ≤ (a : ℤ) := by + exact_mod_cast hdegree + omega + +/-- The coefficient `X⁻ᵃ P(X)` as an element of the infinity valuation +ring. -/ +def infinityNormalizedCoefficient + (a : ℕ) (P : K[X]) (hdegree : P.natDegree ≤ a) : + RatFuncInfinityIntegers K := + ⟨(RatFunc.X⁻¹) ^ a * algebraMap K[X] (RatFunc K) P, + infinityNormalizedCoefficient_mem K a P hdegree⟩ + +@[simp] theorem infinityNormalizedCoefficient_coe + (a : ℕ) (P : K[X]) (hdegree : P.natDegree ≤ a) : + ((infinityNormalizedCoefficient K a P hdegree : + RatFuncInfinityIntegers K) : RatFunc K) = + (RatFunc.X⁻¹) ^ a * algebraMap K[X] (RatFunc K) P := + rfl + +/-- The coefficientwise integral infinity-chart equation. -/ +def infinityNormalizedIntegralPolynomial + (a : ℕ) (F : K[X][X]) + (hcoeff : ∀ i, (F.coeff i).natDegree ≤ a) : + (RatFuncInfinityIntegers K)[X] := + F.sum fun i _ => monomial i + (infinityNormalizedCoefficient K a (F.coeff i) (hcoeff i)) + +/-- Extending the integral infinity-chart equation to `K(X)` recovers the +field-valued normalization. -/ +theorem infinityNormalizedIntegralPolynomial_map + (a : ℕ) (F : K[X][X]) + (hcoeff : ∀ i, (F.coeff i).natDegree ≤ a) : + (infinityNormalizedIntegralPolynomial K a F hcoeff).map + (algebraMap (RatFuncInfinityIntegers K) (RatFunc K)) = + infinityNormalizedPolynomial K a F := by + ext i + rw [coeff_map] + simp only [infinityNormalizedIntegralPolynomial, coeff_sum, + coeff_monomial] + simp only [sum, Finset.sum_ite_eq', mem_support_iff, ne_eq, ite_not] + by_cases hzero : F.coeff i = 0 + · simp [hzero, infinityNormalizedPolynomial, coeff_C_mul] + · rw [ite_eq_right hzero] + have hrhs : (infinityNormalizedPolynomial K a F).coeff i = + (RatFunc.X⁻¹) ^ a * + algebraMap K[X] (RatFunc K) (F.coeff i) := by + simp [infinityNormalizedPolynomial, coeff_C_mul] + rw [hrhs] + change algebraMap (RatFuncInfinityIntegers K) (RatFunc K) + (infinityNormalizedCoefficient K a (F.coeff i) (hcoeff i)) = + (RatFunc.X⁻¹) ^ a * algebraMap K[X] (RatFunc K) (F.coeff i) + change ((infinityNormalizedCoefficient K a (F.coeff i) (hcoeff i) : + RatFuncInfinityIntegers K) : RatFunc K) = _ + exact infinityNormalizedCoefficient_coe K a (F.coeff i) (hcoeff i) + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurveInfinityDifferentDegree.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurveInfinityDifferentDegree.lean new file mode 100644 index 0000000000..57a6f8ebe0 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurveInfinityDifferentDegree.lean @@ -0,0 +1,440 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveInfinityDifferentBound + +/-! +# The degree of the different at infinity + +Bound the different at infinity using a primitive element, its discriminant, and the normalized +reciprocal polynomial. +-/ + +@[expose] public section + +open Polynomial + +namespace BGS.CorvajaZannier + +noncomputable section + +theorem discr_powerBasis_eq_minpoly_discr + {K L : Type*} [Field K] [Field L] [Algebra K L] + [FiniteDimensional K L] [Algebra.IsSeparable K L] + (pb : PowerBasis K L) : + Algebra.discr K pb.basis = (minpoly K pb.gen).discr := by + let E := AlgebraicClosure L + let := fun a b : E => Classical.propDecidable (Eq a b) + let f := minpoly K pb.gen + have hfmonic : f.Monic := minpoly.monic pb.isIntegral_gen + have hfne : f ≠ 0 := hfmonic.ne_zero + have hfpos : 0 < f.degree := by + rw [← natDegree_pos_iff_degree_pos] + change 0 < (minpoly K pb.gen).natDegree + rw [pb.natDegree_minpoly] + rw [← pb.finrank] + exact Module.finrank_pos_iff.mpr inferInstance + have hsep : f.Separable := Algebra.IsSeparable.isSeparable K pb.gen + have hsplit : (f.map (algebraMap K E)).Splits := IsAlgClosed.splits _ + have hrootsNodup : (f.aroots E).Nodup := + nodup_roots (show (f.map (algebraMap K E)).Separable from hsep.map) + apply (algebraMap K E).injective + rw [Algebra.discr_powerBasis_eq_norm] + rw [map_mul, map_pow, map_neg, map_one, + Algebra.norm_eq_prod_embeddings K E] + have hprod : + (∏ σ : L →ₐ[K] E, σ (aeval pb.gen f.derivative)) = + ((f.aroots E).map + ((f.derivative.map (algebraMap K E)).eval)).prod := by + let e : (L →ₐ[K] E) ≃ {x : E // x ∈ f.aroots E} := by + simpa [f] using + (pb.liftEquiv' : (L →ₐ[K] E) ≃ + {x : E // x ∈ (minpoly K pb.gen).aroots E}) + calc + _ = ∏ x : {x : E // x ∈ f.aroots E}, + (f.derivative.map (algebraMap K E)).eval x.1 := by + apply Fintype.prod_equiv e + intro σ + have he : (e σ).1 = σ pb.gen := by + simp [e, f] + rw [he, ← aeval_algHom_apply, ← eval_map_algebraMap] + _ = _ := by + rw [Finset.prod_mem_multiset, Finset.prod_eq_multiset_prod, + Multiset.toFinset_val, Multiset.dedup_eq_self.mpr hrootsNodup] + intro x + rfl + rw [hprod] + have hres := resultant_deriv (f := f) hfpos + have hresMap : + (f.map (algebraMap K E)).resultant + (f.derivative.map (algebraMap K E)) f.natDegree + (f.natDegree - 1) = + (algebraMap K E) + ((-1) ^ (f.natDegree * (f.natDegree - 1) / 2) * + f.leadingCoeff * f.discr) := by + rw [resultant_map_map] + exact congrArg (algebraMap K E) hres + have hfmapDegree : (f.map (algebraMap K E)).natDegree = f.natDegree := + natDegree_map_eq_of_injective (algebraMap K E).injective f + have hresEval : + (f.map (algebraMap K E)).resultant + (f.derivative.map (algebraMap K E)) f.natDegree + (f.natDegree - 1) = + (f.map (algebraMap K E)).leadingCoeff ^ (f.natDegree - 1) * + (((f.map (algebraMap K E)).roots).map + ((f.derivative.map (algebraMap K E)).eval)).prod := by + convert resultant_eq_prod_eval + (f.map (algebraMap K E)) + (f.derivative.map (algebraMap K E)) + (f.natDegree - 1) + (natDegree_map_le.trans (natDegree_derivative_le f)) hsplit using 1 + rw [hfmapDegree] + rw [hresEval, + leadingCoeff_map_of_injective (algebraMap K E).injective, + hfmonic.leadingCoeff, map_one, one_pow, one_mul] at hresMap + simp only [map_mul, map_pow, map_neg, map_one] at hresMap + have hdegree : f.natDegree = Module.finrank K L := by + calc + f.natDegree = pb.dim := by simp [f, pb.natDegree_minpoly] + _ = Module.finrank K L := pb.finrank.symm + rw [hdegree] at hresMap + change ((f.aroots E).map + ((f.derivative.map (algebraMap K E)).eval)).prod = _ at hresMap + rw [hresMap] + let N := Module.finrank K L * (Module.finrank K L - 1) / 2 + have hsign : ((-1 : E) ^ N) * ((-1 : E) ^ N) = 1 := by + rw [← pow_add, show N + N = 2 * N by omega, pow_mul] + norm_num + dsimp only [N, f] at hsign ⊢ + rw [mul_one, ← mul_assoc, hsign, one_mul] + +open scoped nonZeroDivisors +open IsDedekindDomain Multiplicative WithZero + +section + +variable (K : Type*) [Field K] [DecidableEq K] [DecidableEq (RatFunc K)] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +local instance infinityDifferentIntegralClosureModuleFinite : + Module.Finite (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.finite (RatFuncInfinityIntegers K) (RatFunc K) L + (RatFuncInfinityIntegralClosure K L) + +local instance infinityDifferentIntegralClosureIsIntegral : + Algebra.IsIntegral (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.isIntegral_algebra (RatFuncInfinityIntegers K) L + +local instance infinityDifferentTopIsTorsionFree : + Module.IsTorsionFree (RatFuncInfinityIntegers K) L := + Module.IsTorsionFree.trans_faithfulSMul + (RatFuncInfinityIntegers K) (RatFunc K) L + +local instance infinityDifferentIntegralClosureIsTorsionFree : + Module.IsTorsionFree (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.isTorsionFree (RatFuncInfinityIntegers K) L + +local instance infinityDifferentIntegralClosureIsDedekindDomain : + IsDedekindDomain (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.isDedekindDomain + (RatFuncInfinityIntegers K) (RatFunc K) L + (RatFuncInfinityIntegralClosure K L) + +local instance infinityDifferentIntegralClosureIsFractionRing : + IsFractionRing (RatFuncInfinityIntegralClosure K L) L := + IsIntegralClosure.isFractionRing_of_finite_extension + (RatFuncInfinityIntegers K) (RatFunc K) L + (RatFuncInfinityIntegralClosure K L) + +local instance infinityDifferentPlaceFintype : + Fintype ((ratFuncInfinityPlace K).asIdeal.primesOver + (RatFuncInfinityIntegralClosure K L)) := + Set.Finite.fintype + (IsDedekindDomain.primesOver_finite + (ratFuncInfinityPlace K).asIdeal + (RatFuncInfinityIntegralClosure K L)) + +/-- The residue-degree-weighted multiplicity of the different above the +infinity place of `K(X)`. -/ +def infinityDifferentDegree : ℕ := + ∑ P : (ratFuncInfinityPlace K).asIdeal.primesOver + (RatFuncInfinityIntegralClosure K L), + P.1.inertiaDeg (RatFuncInfinityIntegers K) * + multiplicity P.1 + (differentIdeal (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L)) + +omit [DecidableEq K] in +theorem ratFuncInfinityIntegralClosureFractionRingEquiv_valuation + (q : HeightOneSpectrum (RatFuncInfinityIntegralClosure K L)) + (x : FractionRing (RatFuncInfinityIntegralClosure K L)) : + q.valuation L + (ratFuncInfinityIntegralClosureFractionRingEquiv K L x) = + q.valuation (FractionRing (RatFuncInfinityIntegralClosure K L)) x := by + obtain ⟨a, b, hb, rfl⟩ := + IsFractionRing.div_surjective + (RatFuncInfinityIntegralClosure K L) x + rw [map_div₀, + (ratFuncInfinityIntegralClosureFractionRingEquiv K L).commutes a, + (ratFuncInfinityIntegralClosureFractionRingEquiv K L).commutes b, + Valuation.map_div, Valuation.map_div, + q.valuation_of_algebraMap, q.valuation_of_algebraMap, + q.valuation_of_algebraMap, q.valuation_of_algebraMap] + +omit [DecidableEq K] in +theorem ratFuncInfinityIntegralClosureFractionRingEquiv_order_eq + (q : HeightOneSpectrum (RatFuncInfinityIntegralClosure K L)) + (x : FractionRing (RatFuncInfinityIntegralClosure K L)) (hx : x ≠ 0) : + finitePlaceOrder q x = + finitePlaceOrder q + (ratFuncInfinityIntegralClosureFractionRingEquiv K L x) := by + let e := ratFuncInfinityIntegralClosureFractionRingEquiv K L + have hcanon := valuation_eq_exp_neg_finitePlaceOrder q x hx + have he_ne : e x ≠ 0 := by simpa using e.injective.ne hx + have hactual := valuation_eq_exp_neg_finitePlaceOrder q (e x) he_ne + have hval := + ratFuncInfinityIntegralClosureFractionRingEquiv_valuation K L q x + have hexp : exp (-finitePlaceOrder q x) = + exp (-finitePlaceOrder q (e x)) := by + rw [← hcanon, ← hactual] + exact hval.symm + rw [exp_inj] at hexp + change finitePlaceOrder q x = finitePlaceOrder q (e x) + omega + +omit [DecidableEq K] in +/-- The different contribution above infinity is bounded by the infinity +order of the discriminant of any integral primitive-element equation having +a unit value at a center. The inverse translate of the primitive element is +integral and realizes the complementary reciprocal-discriminant estimate. -/ +theorem infinityDifferentDegree_le_discriminantOrder_of_primitiveElement + (G : (RatFuncInfinityIntegers K)[X]) + (c : RatFuncInfinityIntegers K) (u : (RatFuncInfinityIntegers K)ˣ) + (v : L) + (hu : G.eval c = u) + (hvc : v ≠ algebraMap (RatFuncInfinityIntegers K) L c) + (hv : aeval v G = 0) + (hprimitive : Algebra.adjoin (RatFunc K) {v} = ⊤) + (hdegree : G.natDegree = Module.finrank (RatFunc K) L) + (hGdiscr : G.discr ≠ 0) : + (infinityDifferentDegree K L : ℤ) ≤ + ratFuncInfinityOrder + (algebraMap (RatFuncInfinityIntegers K) (RatFunc K) G.discr) := by + let A := RatFuncInfinityIntegers K + let B := RatFuncInfinityIntegralClosure K L + have hzIntegral : IsIntegral A + ((v - algebraMap A L c)⁻¹) := + isIntegral_inv_sub_of_eval_eq_unit G c u v hu hvc hv + let z : B := IsIntegralClosure.mk' B + ((v - algebraMap A L c)⁻¹) hzIntegral + have hzMap : algebraMap B L z = + (v - algebraMap A L c)⁻¹ := by + simp [z] + have hzPrimitive : Algebra.adjoin (RatFunc K) + {algebraMap B L z} = ⊤ := by + rw [hzMap] + simpa only [IsScalarTower.algebraMap_apply A (RatFunc K) L] using + (adjoin_inv_sub_eq_top_of_adjoin_eq_top + (algebraMap A (RatFunc K) c) v hprimitive) + let d : B := aeval z (derivative (minpoly A z)) + have hd : d ≠ 0 := by + simpa [d] using minpolyDerivative_ne_zero + (A := A) (K := RatFunc K) (L := L) z + let dL : L := algebraMap B L d + have hdL : dL ≠ 0 := by + exact (IsFractionRing.injective B L).ne hd + have hrepr : + (ratFuncInfinityIntegralClosureFractionRingEquiv K L).symm dL = + algebraMap B (FractionRing B) d := by + apply (ratFuncInfinityIntegralClosureFractionRingEquiv K L).injective + rw [(ratFuncInfinityIntegralClosureFractionRingEquiv K L).apply_symm_apply] + exact (ratFuncInfinityIntegralClosureFractionRingEquiv K L).commutes d |>.symm + have hpoint : ∀ P : (ratFuncInfinityPlace K).asIdeal.primesOver B, + ((P.1.inertiaDeg A * + multiplicity P.1 (differentIdeal A B) : ℕ) : ℤ) ≤ + (P.1.inertiaDeg A : ℤ) * + finitePlaceOrder + (primeOverHeightOne (ratFuncInfinityPlace K) P) + ((ratFuncInfinityIntegralClosureFractionRingEquiv K L).symm dL) := by + intro P + have hmul := differentIdeal_multiplicity_le_finitePlaceOrder_minpolyDerivative + (A := A) (K := RatFunc K) (L := L) (B := B) + z hzPrimitive (primeOverHeightOne (ratFuncInfinityPlace K) P) + change (multiplicity P.1 (differentIdeal A B) : ℤ) ≤ + finitePlaceOrder (primeOverHeightOne (ratFuncInfinityPlace K) P) + (algebraMap B L d) at hmul + have horder : + finitePlaceOrder (primeOverHeightOne (ratFuncInfinityPlace K) P) + (algebraMap B L d) = + finitePlaceOrder (primeOverHeightOne (ratFuncInfinityPlace K) P) + ((ratFuncInfinityIntegralClosureFractionRingEquiv K L).symm dL) := by + rw [hrepr] + have hne : algebraMap B (FractionRing B) d ≠ 0 := + by + have hinj : Function.Injective + (algebraMap B (FractionRing B)) := + IsFractionRing.injective B (FractionRing B) + intro hzero + apply hd + apply hinj + rw [hzero, map_zero] + have heq := ratFuncInfinityIntegralClosureFractionRingEquiv_order_eq + K L (primeOverHeightOne (ratFuncInfinityPlace K) P) + (algebraMap B (FractionRing B) d) hne + calc + finitePlaceOrder (primeOverHeightOne (ratFuncInfinityPlace K) P) + (algebraMap B L d) = + finitePlaceOrder (primeOverHeightOne (ratFuncInfinityPlace K) P) + (ratFuncInfinityIntegralClosureFractionRingEquiv K L + (algebraMap B (FractionRing B) d)) := by + rw [(ratFuncInfinityIntegralClosureFractionRingEquiv K L).commutes d] + _ = finitePlaceOrder + (primeOverHeightOne (ratFuncInfinityPlace K) P) + (algebraMap B (FractionRing B) d) := heq.symm + rw [horder] at hmul + simpa only [Nat.cast_mul] using + mul_le_mul_of_nonneg_left hmul (Int.natCast_nonneg _) + have hsum : (infinityDifferentDegree K L : ℤ) ≤ + ∑ P : (ratFuncInfinityPlace K).asIdeal.primesOver B, + (P.1.inertiaDeg A : ℤ) * + finitePlaceOrder + (primeOverHeightOne (ratFuncInfinityPlace K) P) + ((ratFuncInfinityIntegralClosureFractionRingEquiv K L).symm dL) := by + rw [infinityDifferentDegree, Nat.cast_sum] + exact Finset.sum_le_sum fun P _ => hpoint P + rw [primesAboveInfinity_weightedOrder_eq_normInfinityOrder K L dL hdL] at hsum + let pb : PowerBasis (RatFunc K) L := + PowerBasis.ofAdjoinEqTop' + (Algebra.IsIntegral.isIntegral (algebraMap B L z)) hzPrimitive + have hdiscNorm := discr_powerBasisOfPrimitiveElement_eq_norm_minpolyDerivative + (A := A) (K := RatFunc K) (L := L) (B := B) z hzPrimitive + have hpb : Algebra.discr (RatFunc K) pb.basis = + (minpoly (RatFunc K) (algebraMap B L z)).discr := + by + have hpbg : pb.gen = algebraMap B L z := by simp [pb] + simpa only [hpbg] using discr_powerBasis_eq_minpoly_discr pb + change Algebra.discr (RatFunc K) pb.basis = + (-1) ^ (Module.finrank (RatFunc K) L * + (Module.finrank (RatFunc K) L - 1) / 2) * + Algebra.norm (RatFunc K) dL at hdiscNorm + rw [hpb] at hdiscNorm + have hnormOrder : + ratFuncInfinityOrder (Algebra.norm (RatFunc K) dL) = + ratFuncInfinityOrder + (minpoly (RatFunc K) (algebraMap B L z)).discr := by + have hsign : + (-1 : RatFunc K) ^ (Module.finrank (RatFunc K) L * + (Module.finrank (RatFunc K) L - 1) / 2) ≠ 0 := by simp + have hnorm : Algebra.norm (RatFunc K) dL ≠ 0 := + Algebra.norm_ne_zero_iff.mpr hdL + have hdegreeEq := congrArg RatFunc.intDegree hdiscNorm + rw [RatFunc.intDegree_mul hsign hnorm] at hdegreeEq + have hsignDegree : RatFunc.intDegree + ((-1 : RatFunc K) ^ (Module.finrank (RatFunc K) L * + (Module.finrank (RatFunc K) L - 1) / 2)) = 0 := by + induction (Module.finrank (RatFunc K) L * + (Module.finrank (RatFunc K) L - 1) / 2) with + | zero => simp + | succ n ih => + rw [pow_succ, RatFunc.intDegree_mul (pow_ne_zero n (by simp)) (by simp), ih] + simp + rw [hsignDegree, zero_add] at hdegreeEq + exact congrArg Neg.neg hdegreeEq |>.symm + rw [hnormOrder] at hsum + have htop := finitePlaceOrderTop_minpoly_inv_sub_discr + (A := A) (K := RatFunc K) (L := L) + (ratFuncInfinityPlace K) G c u v hu hvc hv hprimitive hdegree + rw [← hzMap] at htop + have hminNe : (minpoly (RatFunc K) (algebraMap B L z)).discr ≠ 0 := by + intro hzero + rw [hzero] at hdiscNorm + exact (mul_ne_zero (by simp) (Algebra.norm_ne_zero_iff.mpr hdL)) hdiscNorm.symm + have hmapNe : algebraMap A (RatFunc K) G.discr ≠ 0 := + (IsFractionRing.injective A (RatFunc K)).ne hGdiscr + rw [finitePlaceOrderTop_eq_coe _ _ hminNe, + finitePlaceOrderTop_eq_coe _ _ hmapNe] at htop + have horderEq : ratFuncInfinityOrder + (minpoly (RatFunc K) (algebraMap B L z)).discr = + ratFuncInfinityOrder (algebraMap A (RatFunc K) G.discr) := by + have hfinite : finitePlaceOrder (ratFuncInfinityPlace K) + (minpoly (RatFunc K) (algebraMap B L z)).discr = + finitePlaceOrder (ratFuncInfinityPlace K) + (algebraMap A (RatFunc K) G.discr) := by + exact_mod_cast htop + simpa only [ratFuncInfinityPlace_order_eq K _ hminNe, + ratFuncInfinityPlace_order_eq K _ hmapNe] using hfinite + exact hsum.trans_eq horderEq + +end + +end + +end BGS.CorvajaZannier + +namespace BGS.CorvajaZannier + +open scoped Polynomial +open Multiplicative WithZero Polynomial + +variable (K : Type*) [Field K] [DecidableEq K] [DecidableEq (RatFunc K)] + +theorem infinityNormalizedCoefficient_isUnit_of_natDegree_eq + (a : ℕ) (P : K[X]) (hP : P ≠ 0) (hdegree : P.natDegree = a) : + IsUnit (infinityNormalizedCoefficient K a P hdegree.le) := by + rw [Valuation.Integers.isUnit_iff_valuation_eq_one + (Valuation.integer.integers (RatFunc.inftyValuation K))] + change RatFunc.inftyValuation K + ((RatFunc.X⁻¹) ^ a * algebraMap K[X] (RatFunc K) P) = 1 + have hXinv : RatFunc.X⁻¹ ≠ (0 : RatFunc K) := + inv_ne_zero RatFunc.X_ne_zero + have hleft : (RatFunc.X⁻¹) ^ a ≠ (0 : RatFunc K) := + pow_ne_zero _ hXinv + have hright : algebraMap K[X] (RatFunc K) P ≠ 0 := + RatFunc.algebraMap_ne_zero hP + have hpow : ((((RatFunc.X : RatFunc K)⁻¹) ^ a) : RatFunc K).intDegree = + (a : ℤ) * ((RatFunc.X : RatFunc K)⁻¹).intDegree := by + clear hdegree hleft + induction a with + | zero => simp + | succ n ih => + rw [pow_succ, RatFunc.intDegree_mul + (pow_ne_zero n hXinv) hXinv, ih] + push_cast + ring + rw [RatFunc.inftyValuation_apply, + RatFunc.inftyValuation_of_nonzero (F := K) (mul_ne_zero hleft hright), + RatFunc.intDegree_mul hleft hright, + hpow, + RatFunc.intDegree_inv, RatFunc.intDegree_X, + RatFunc.intDegree_polynomial, hdegree] + simp + +theorem infinityNormalizedIntegralPolynomial_isPrimitive + (a : ℕ) (F : K[X][X]) + (hcoeff : ∀ i, (F.coeff i).natDegree ≤ a) + (i : ℕ) (hFi : F.coeff i ≠ 0) + (hi : (F.coeff i).natDegree = a) : + (infinityNormalizedIntegralPolynomial K a F hcoeff).IsPrimitive := by + rw [Polynomial.isPrimitive_iff_contentIdeal_eq_top] + let G := infinityNormalizedIntegralPolynomial K a F hcoeff + have hcoeffG : G.coeff i = + infinityNormalizedCoefficient K a (F.coeff i) (hcoeff i) := by + simp only [G, infinityNormalizedIntegralPolynomial, coeff_sum, + coeff_monomial] + simp [Polynomial.sum, hFi] + apply G.contentIdeal.eq_top_of_isUnit_mem (G.coeff_mem_contentIdeal i) + rw [hcoeffG] + exact infinityNormalizedCoefficient_isUnit_of_natDegree_eq + K a (F.coeff i) hFi hi + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurveLocalReciprocalDiscriminant.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurveLocalReciprocalDiscriminant.lean new file mode 100644 index 0000000000..1e6097224e --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurveLocalReciprocalDiscriminant.lean @@ -0,0 +1,643 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.LocalReciprocalDiscriminant +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveRatFuncModel +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveDiscriminantBound +public import Mathlib.Algebra.Polynomial.Roots +public import Mathlib.RingTheory.Localization.LocalizationLocalization +public import Mathlib.RingTheory.Polynomial.ContentIdeal + +/-! +# Local reciprocal normalization for an irreducible plane curve + +This file specializes `LocalReciprocalDiscriminant` to the first-coordinate +model of an irreducible plane curve. When the second-coordinate degree is +smaller than the cardinality of the constant field, at each finite prime of +`K[X]` it selects a local center at which the defining polynomial has unit +value. This includes explicit finite-field and infinite-field interfaces. It +also proves the defining relation, primitive generation, and the exact +extension degree over `K(X)`. The final theorem identifies the minimal +polynomial of the reciprocal local parameter with the unit-normalized +reciprocal translate of the localized plane equation. +-/ + +@[expose] public section + +namespace BGS.CorvajaZannier + +noncomputable section + +variable {K : Type*} [Field K] + +/-- Coordinate `0` becomes the coefficient variable in the iterated plane +curve presentation. -/ +@[simp] theorem planeCurvePolynomialInSecondCoordinate_X_zero : + planeCurvePolynomialInSecondCoordinate (K := K) (MvPolynomial.X 0) = + Polynomial.C Polynomial.X := by + rw [planeCurvePolynomialInSecondCoordinate] + change Polynomial.map (MvPolynomial.uniqueAlgEquiv K (Fin 1)).toRingHom + (MvPolynomial.finSuccEquiv K 1 + (MvPolynomial.rename (Equiv.swap (0 : Fin 2) 1) (MvPolynomial.X 0))) = _ + rw [MvPolynomial.rename_X] + have hswap : Equiv.swap (0 : Fin 2) 1 0 = 1 := by decide + rw [hswap] + have hinner : + MvPolynomial.finSuccEquiv K 1 (MvPolynomial.X 1) = + Polynomial.C (MvPolynomial.X (0 : Fin 1)) := by + rw [MvPolynomial.finSuccEquiv_apply] + simp only [MvPolynomial.coe_eval₂Hom, MvPolynomial.eval₂_X] + rw [show (1 : Fin 2) = Fin.succ (0 : Fin 1) by decide] + rfl + rw [hinner] + simp [MvPolynomial.uniqueAlgEquiv] + +/-- Coordinate `1` becomes the outer polynomial variable. -/ +@[simp] theorem planeCurvePolynomialInSecondCoordinate_X_one : + planeCurvePolynomialInSecondCoordinate (K := K) (MvPolynomial.X 1) = + Polynomial.X := by + rw [planeCurvePolynomialInSecondCoordinate] + change Polynomial.map (MvPolynomial.uniqueAlgEquiv K (Fin 1)).toRingHom + (MvPolynomial.finSuccEquiv K 1 + (MvPolynomial.rename (Equiv.swap (0 : Fin 2) 1) (MvPolynomial.X 1))) = _ + rw [MvPolynomial.rename_X] + have hswap : Equiv.swap (0 : Fin 2) 1 1 = 0 := by decide + rw [hswap] + have hinner : + MvPolynomial.finSuccEquiv K 1 (MvPolynomial.X 0) = + (Polynomial.X : Polynomial (MvPolynomial (Fin 1) K)) := by + rw [MvPolynomial.finSuccEquiv_apply] + simp + rw [hinner] + simp + +/-- Constants remain constants in both polynomial variables. -/ +@[simp] theorem planeCurvePolynomialInSecondCoordinate_C (c : K) : + planeCurvePolynomialInSecondCoordinate (MvPolynomial.C c) = + Polynomial.C (Polynomial.C c) := by + rw [planeCurvePolynomialInSecondCoordinate] + change Polynomial.map (MvPolynomial.uniqueAlgEquiv K (Fin 1)).toRingHom + (MvPolynomial.finSuccEquiv K 1 + (MvPolynomial.rename (Equiv.swap (0 : Fin 2) 1) (MvPolynomial.C c))) = _ + rw [MvPolynomial.rename_C] + have hinner : + MvPolynomial.finSuccEquiv K 1 (MvPolynomial.C c) = + Polynomial.C (MvPolynomial.C c) := by + rw [MvPolynomial.finSuccEquiv_apply] + simp + rw [hinner] + simp [MvPolynomial.uniqueAlgEquiv] + +/-- The plane-curve presentation agrees with Mathlib's standard bivariate +polynomial equivalence. -/ +theorem planeCurvePolynomialInSecondCoordinate_eq_bivariateEquiv + (f : MvPolynomial (Fin 2) K) : + planeCurvePolynomialInSecondCoordinate f = + (Polynomial.Bivariate.equivMvPolynomial K).symm f := by + change planeCurvePolynomialInSecondCoordinate.toAlgHom f = + (Polynomial.Bivariate.equivMvPolynomial K).symm.toAlgHom f + congr 1 + apply MvPolynomial.algHom_ext + intro i + fin_cases i + · simp + · simp + +/-- Evaluation of the iterated polynomial is ordinary two-coordinate +evaluation of the original multivariate polynomial. -/ +theorem eval₂_planeCurvePolynomialInSecondCoordinate + {A : Type*} [CommSemiring A] [Algebra K A] + (f : MvPolynomial (Fin 2) K) (x y : A) : + Polynomial.eval₂ (Polynomial.eval₂RingHom (algebraMap K A) x) y + (planeCurvePolynomialInSecondCoordinate f) = + MvPolynomial.eval₂ (algebraMap K A) ![x, y] f := by + let lhs : MvPolynomial (Fin 2) K →+* A := + (Polynomial.eval₂RingHom + (Polynomial.eval₂RingHom (algebraMap K A) x) y).comp + planeCurvePolynomialInSecondCoordinate.toRingEquiv.toRingHom + let rhs : MvPolynomial (Fin 2) K →+* A := + MvPolynomial.eval₂Hom (algebraMap K A) ![x, y] + change lhs f = rhs f + congr 1 + apply MvPolynomial.ringHom_ext + · intro c + simp [lhs, rhs, planeCurvePolynomialInSecondCoordinate_C] + · intro i + fin_cases i + · simp [lhs, rhs, + planeCurvePolynomialInSecondCoordinate_X_zero] + · simp [lhs, rhs, + planeCurvePolynomialInSecondCoordinate_X_one] + +open IsDedekindDomain Polynomial +open scoped nonZeroDivisors + +/-- The canonical inclusion of the local ring of `K[X]` at a finite prime +into its fraction field `K(X)`. -/ +noncomputable def localizationAtPrimeToRatFunc + (p : HeightOneSpectrum (Polynomial K)) : + Localization.AtPrime p.asIdeal →+* RatFunc K := + IsLocalization.lift (S := Localization.AtPrime p.asIdeal) + (M := p.asIdeal.primeCompl) + (g := algebraMap (Polynomial K) (RatFunc K)) fun + (y : p.asIdeal.primeCompl) => + IsLocalization.map_units (RatFunc K) + ⟨y.1, p.asIdeal.primeCompl_le_nonZeroDivisors y.2⟩ + +/-- The local inclusion extends the standard polynomial inclusion in +`RatFunc K`. -/ +@[simp] theorem localizationAtPrimeToRatFunc_comp_algebraMap + (p : HeightOneSpectrum (Polynomial K)) : + (localizationAtPrimeToRatFunc p).comp + (algebraMap (Polynomial K) (Localization.AtPrime p.asIdeal)) = + algebraMap (Polynomial K) (RatFunc K) := by + simp only [localizationAtPrimeToRatFunc] + exact IsLocalization.lift_comp _ + +/-- A primitive polynomial over `K[X]` has a unit value at some center in +every finite localization when its degree is smaller than the cardinality of +the constant field. -/ +theorem exists_localized_center_eval_isUnit_of_natDegree_lt_card + (F : Polynomial (Polynomial K)) (hF : F.IsPrimitive) + (hcardK : (F.natDegree : Cardinal) < Cardinal.mk K) + (p : HeightOneSpectrum (Polynomial K)) : + ∃ a : Polynomial K, + IsUnit ((F.map + (algebraMap (Polynomial K) (Localization.AtPrime p.asIdeal))).eval + (algebraMap (Polynomial K) (Localization.AtPrime p.asIdeal) a)) := by + let k := (Polynomial K) ⧸ p.asIdeal + let π : Polynomial K →+* k := Ideal.Quotient.mk p.asIdeal + have hFbar : F.map π ≠ 0 := by + intro hzero + have hcoeff : ∀ i, F.coeff i ∈ p.asIdeal := by + intro i + have hi := congrArg (fun q : Polynomial k => q.coeff i) hzero + rw [Polynomial.coeff_map, Polynomial.coeff_zero] at hi + exact Ideal.Quotient.eq_zero_iff_mem.mp hi + have hcontent : F.contentIdeal ≤ p.asIdeal := by + rw [Polynomial.contentIdeal_def, Ideal.span_le] + intro x hx + obtain ⟨i, _hi, rfl⟩ := Polynomial.mem_coeffs_iff.mp hx + exact hcoeff i + have htop : F.contentIdeal = ⊤ := + (Polynomial.isPrimitive_iff_contentIdeal_eq_top F).mp hF + apply p.isPrime.ne_top + apply top_unique + simpa [htop] using hcontent + have hcard : (F.map π).natDegree < Cardinal.mk k := by + have hdegree : ((F.map π).natDegree : Cardinal) ≤ F.natDegree := by + exact_mod_cast Polynomial.natDegree_map_le + exact (hdegree.trans_lt hcardK).trans_le + (Cardinal.mk_le_of_injective + (RingHom.injective (algebraMap K k))) + obtain ⟨c, hc⟩ := + Polynomial.exists_eval_ne_zero_of_natDegree_lt_card (F.map π) hFbar hcard + obtain ⟨a, rfl⟩ := Ideal.Quotient.mk_surjective c + refine ⟨a, ?_⟩ + rw [Polynomial.eval_map_apply] + apply (IsLocalization.AtPrime.isUnit_to_map_iff + (Localization.AtPrime p.asIdeal) p.asIdeal (F.eval a)).2 + change F.eval a ∉ p.asIdeal + intro hmem + apply hc + rw [Polynomial.eval_map_apply] + change π (F.eval a) = 0 + exact Ideal.Quotient.eq_zero_iff_mem.mpr hmem + +/-- Infinite constant fields automatically satisfy the cardinality hypothesis +for a primitive polynomial of finite degree. -/ +theorem exists_localized_center_eval_isUnit + [Infinite K] (F : Polynomial (Polynomial K)) (hF : F.IsPrimitive) + (p : HeightOneSpectrum (Polynomial K)) : + ∃ a : Polynomial K, + IsUnit ((F.map + (algebraMap (Polynomial K) (Localization.AtPrime p.asIdeal))).eval + (algebraMap (Polynomial K) (Localization.AtPrime p.asIdeal) a)) := by + apply exists_localized_center_eval_isUnit_of_natDegree_lt_card F hF + exact (show (F.natDegree : Cardinal) < Cardinal.aleph0 from + Cardinal.natCast_lt_aleph0).trans_le (Cardinal.aleph0_le_mk K) + +/-- Finite constant fields satisfy the local center hypothesis as soon as the +polynomial degree is smaller than the field cardinality. -/ +theorem exists_localized_center_eval_isUnit_of_natDegree_lt_fintypeCard + [Fintype K] (F : Polynomial (Polynomial K)) (hF : F.IsPrimitive) + (hcardK : F.natDegree < Fintype.card K) + (p : HeightOneSpectrum (Polynomial K)) : + ∃ a : Polynomial K, + IsUnit ((F.map + (algebraMap (Polynomial K) (Localization.AtPrime p.asIdeal))).eval + (algebraMap (Polynomial K) (Localization.AtPrime p.asIdeal) a)) := by + apply exists_localized_center_eval_isUnit_of_natDegree_lt_card F hF + simpa only [Cardinal.mk_fintype, Nat.cast_lt] using hcardK + +/-- The irreducible plane equation admits a unit-valued center at every +finite first-coordinate prime when its second-coordinate degree is smaller +than the cardinality of the constant field. -/ +theorem exists_planeCurve_localized_center_eval_isUnit_of_degreeOf_second_lt_card + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hsecond : 0 < MvPolynomial.degreeOf 1 f) + (hcardK : (MvPolynomial.degreeOf 1 f : Cardinal) < Cardinal.mk K) + (p : HeightOneSpectrum (Polynomial K)) : + ∃ a : Polynomial K, + IsUnit (((planeCurvePolynomialInSecondCoordinate f).map + (algebraMap (Polynomial K) (Localization.AtPrime p.asIdeal))).eval + (algebraMap (Polynomial K) (Localization.AtPrime p.asIdeal) a)) := by + let F : Polynomial (Polynomial K) := + planeCurvePolynomialInSecondCoordinate f + have hFirreducible : Irreducible F := + hf.map planeCurvePolynomialInSecondCoordinate + have hFdegree : F.natDegree ≠ 0 := by + simpa [F] using hsecond.ne' + apply exists_localized_center_eval_isUnit_of_natDegree_lt_card F + (hFirreducible.isPrimitive hFdegree) _ p + simpa [F] using hcardK + +/-- Over an infinite constant field, every finite first-coordinate prime has +a unit-valued plane-curve center. -/ +theorem exists_planeCurve_localized_center_eval_isUnit + [Infinite K] {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hsecond : 0 < MvPolynomial.degreeOf 1 f) + (p : HeightOneSpectrum (Polynomial K)) : + ∃ a : Polynomial K, + IsUnit (((planeCurvePolynomialInSecondCoordinate f).map + (algebraMap (Polynomial K) (Localization.AtPrime p.asIdeal))).eval + (algebraMap (Polynomial K) (Localization.AtPrime p.asIdeal) a)) := by + apply exists_planeCurve_localized_center_eval_isUnit_of_degreeOf_second_lt_card + hf hsecond + exact (show (MvPolynomial.degreeOf 1 f : Cardinal) < Cardinal.aleph0 from + Cardinal.natCast_lt_aleph0).trans_le (Cardinal.aleph0_le_mk K) + +/-- Over a finite constant field, the plane-curve center exists under the +literal degree-versus-cardinality inequality. -/ +theorem exists_planeCurve_localized_center_eval_isUnit_of_degreeOf_second_lt_fintypeCard + [Fintype K] {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hsecond : 0 < MvPolynomial.degreeOf 1 f) + (hcardK : MvPolynomial.degreeOf 1 f < Fintype.card K) + (p : HeightOneSpectrum (Polynomial K)) : + ∃ a : Polynomial K, + IsUnit (((planeCurvePolynomialInSecondCoordinate f).map + (algebraMap (Polynomial K) (Localization.AtPrime p.asIdeal))).eval + (algebraMap (Polynomial K) (Localization.AtPrime p.asIdeal) a)) := by + apply exists_planeCurve_localized_center_eval_isUnit_of_degreeOf_second_lt_card + hf hsecond _ p + simpa only [Cardinal.mk_fintype, Nat.cast_lt] using hcardK + +/-- The second coordinate is a root of the defining equation after extending +the first-coordinate coefficients to `K(X)`. -/ +theorem aeval_planeCurvePolynomialInSecondCoordinate_ratFunc_eq_zero + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) : + letI := planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + letI := planeCurveFirstCoordinateRatFuncAlgebra f hx + Polynomial.aeval (planeCurveFunction f 1) + ((planeCurvePolynomialInSecondCoordinate f).map + (algebraMap (Polynomial K) (RatFunc K))) = 0 := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let : Algebra (RatFunc K) (PlaneCurveFunctionField f) := + planeCurveFirstCoordinateRatFuncAlgebra f hx + have hcoeff : + (algebraMap (RatFunc K) (PlaneCurveFunctionField f)).comp + (algebraMap (Polynomial K) (RatFunc K)) = + Polynomial.eval₂RingHom + (algebraMap K (PlaneCurveFunctionField f)) + (planeCurveFunction f 0) := by + exact ratFuncSpecialization_comp_polynomial_algebraMap + (planeCurveFunction f 0) hx + calc + Polynomial.aeval (planeCurveFunction f 1) + ((planeCurvePolynomialInSecondCoordinate f).map + (algebraMap (Polynomial K) (RatFunc K))) = + Polynomial.eval₂ + ((algebraMap (RatFunc K) (PlaneCurveFunctionField f)).comp + (algebraMap (Polynomial K) (RatFunc K))) + (planeCurveFunction f 1) + (planeCurvePolynomialInSecondCoordinate f) := by + rw [Polynomial.aeval_def, Polynomial.eval₂_map] + _ = Polynomial.eval₂ + (Polynomial.eval₂RingHom + (algebraMap K (PlaneCurveFunctionField f)) + (planeCurveFunction f 0)) + (planeCurveFunction f 1) + (planeCurvePolynomialInSecondCoordinate f) := by rw [hcoeff] + _ = MvPolynomial.eval₂ + (algebraMap K (PlaneCurveFunctionField f)) + ![planeCurveFunction f 0, planeCurveFunction f 1] f := + eval₂_planeCurvePolynomialInSecondCoordinate f + (planeCurveFunction f 0) (planeCurveFunction f 1) + _ = 0 := by + have hcoordinates : planeCurveFunction f = + ![planeCurveFunction f 0, planeCurveFunction f 1] := by + funext i + fin_cases i <;> rfl + rw [← hcoordinates] + exact eval₂_planeCurveFunction_eq_zero f + +/-- The defining equation remains irreducible over `K(X)`. -/ +theorem planeCurvePolynomialInSecondCoordinate_ratFunc_irreducible + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) : + Irreducible ((planeCurvePolynomialInSecondCoordinate f).map + (algebraMap (Polynomial K) (RatFunc K))) := by + let F : Polynomial (Polynomial K) := + planeCurvePolynomialInSecondCoordinate f + have hFirreducible : Irreducible F := + hf.map planeCurvePolynomialInSecondCoordinate + have hFdegree : F.natDegree ≠ 0 := by + simpa [F] using + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond).ne' + exact (hFirreducible.isPrimitive hFdegree + |>.irreducible_iff_irreducible_map_fraction_map).mp hFirreducible + +/-- The second coordinate primitively generates the plane function field over +the first-coordinate copy of `K(X)`. -/ +theorem adjoin_secondCoordinate_over_firstRatFunc_eq_top + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) : + letI := planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + letI := planeCurveFirstCoordinateRatFuncAlgebra f hx + Algebra.adjoin (RatFunc K) {planeCurveFunction f 1} = ⊤ := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let : Algebra (RatFunc K) (PlaneCurveFunctionField f) := + planeCurveFirstCoordinateRatFuncAlgebra f hx + let : FiniteDimensional (RatFunc K) (PlaneCurveFunctionField f) := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let F : Polynomial (RatFunc K) := + (planeCurvePolynomialInSecondCoordinate f).map + (algebraMap (Polynomial K) (RatFunc K)) + have hFirreducible : Irreducible F := + planeCurvePolynomialInSecondCoordinate_ratFunc_irreducible + hf hpartialSecond + have hFroot : Polynomial.aeval (planeCurveFunction f 1) F = 0 := + aeval_planeCurvePolynomialInSecondCoordinate_ratFunc_eq_zero + hf hpartialSecond + have heq := minpoly.eq_of_irreducible hFirreducible hFroot + have hminDegree : + (minpoly (RatFunc K) (planeCurveFunction f 1)).natDegree = + F.natDegree := by + calc + (minpoly (RatFunc K) (planeCurveFunction f 1)).natDegree = + (F * Polynomial.C F.leadingCoeff⁻¹).natDegree := by rw [heq] + _ = F.natDegree := Polynomial.natDegree_mul_C + (inv_ne_zero (Polynomial.leadingCoeff_ne_zero.mpr + hFirreducible.ne_zero)) + have hFdegree : F.natDegree = + MvPolynomial.degreeOf 1 f := by + change ((planeCurvePolynomialInSecondCoordinate f).map + (algebraMap (Polynomial K) (RatFunc K))).natDegree = _ + rw [Polynomial.natDegree_map_eq_of_injective + (IsFractionRing.injective (Polynomial K) (RatFunc K)), + planeCurvePolynomialInSecondCoordinate_natDegree] + have hfinrank : Module.finrank (RatFunc K) + (PlaneCurveFunctionField f) = MvPolynomial.degreeOf 1 f := + finrank_planeCurveFunctionField_over_ratFunc_eq_degreeOf_second + hf hpartialSecond + have hprimitiveField : + IntermediateField.adjoin (RatFunc K) {planeCurveFunction f 1} = + (⊤ : IntermediateField (RatFunc K) (PlaneCurveFunctionField f)) := + (Field.primitive_element_iff_minpoly_natDegree_eq + (RatFunc K) (planeCurveFunction f 1)).mpr (by + rw [hminDegree, hFdegree, hfinrank]) + exact (IntermediateField.adjoin_eq_top_iff).mp hprimitiveField + +/-- All local hypotheses for reciprocal normalization, packaged with an +explicit center and unit, under the exact cardinality hypothesis needed for +center selection. -/ +theorem planeCurve_local_reciprocal_certificate_of_degreeOf_second_lt_card + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (hcardK : (MvPolynomial.degreeOf 1 f : Cardinal) < Cardinal.mk K) + (p : HeightOneSpectrum (Polynomial K)) : + letI := planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + letI := planeCurveFirstCoordinateRatFuncAlgebra f hx + let A := Localization.AtPrime p.asIdeal + let ι := localizationAtPrimeToRatFunc p + let G := (planeCurvePolynomialInSecondCoordinate f).map + (algebraMap (Polynomial K) A) + ∃ (a : Polynomial K) (u : Aˣ), + let c := algebraMap (Polynomial K) A a + G.eval c = (u : A) ∧ + G.eval₂ ((algebraMap (RatFunc K) + (PlaneCurveFunctionField f)).comp ι) + (planeCurveFunction f 1) = 0 ∧ + planeCurveFunction f 1 ≠ + algebraMap (RatFunc K) (PlaneCurveFunctionField f) (ι c) ∧ + Algebra.adjoin (RatFunc K) {planeCurveFunction f 1} = ⊤ ∧ + G.natDegree = Module.finrank (RatFunc K) + (PlaneCurveFunctionField f) := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let : Algebra (RatFunc K) (PlaneCurveFunctionField f) := + planeCurveFirstCoordinateRatFuncAlgebra f hx + let A := Localization.AtPrime p.asIdeal + let ι := localizationAtPrimeToRatFunc p + let F := planeCurvePolynomialInSecondCoordinate f + let G := F.map (algebraMap (Polynomial K) A) + have hsecond : 0 < MvPolynomial.degreeOf 1 f := + degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond + obtain ⟨a, haUnit⟩ := + exists_planeCurve_localized_center_eval_isUnit_of_degreeOf_second_lt_card + (K := K) hf hsecond hcardK p + obtain ⟨u, hu⟩ := haUnit + let c : A := algebraMap (Polynomial K) A a + have hrootRat := + aeval_planeCurvePolynomialInSecondCoordinate_ratFunc_eq_zero + hf hpartialSecond + have hroot : + G.eval₂ ((algebraMap (RatFunc K) + (PlaneCurveFunctionField f)).comp ι) + (planeCurveFunction f 1) = 0 := by + change (F.map (algebraMap (Polynomial K) A)).eval₂ + ((algebraMap (RatFunc K) (PlaneCurveFunctionField f)).comp ι) + (planeCurveFunction f 1) = 0 + rw [Polynomial.eval₂_map] + rw [RingHom.comp_assoc, + localizationAtPrimeToRatFunc_comp_algebraMap] + rw [← Polynomial.eval₂_map] + simpa [Polynomial.aeval_def, F] using hrootRat + have hvc : planeCurveFunction f 1 ≠ + algebraMap (RatFunc K) (PlaneCurveFunctionField f) (ι c) := by + intro heq + have hzeroMap : + ((algebraMap (RatFunc K) (PlaneCurveFunctionField f)).comp ι) + (G.eval c) = 0 := by + rw [← Polynomial.eval₂_at_apply] + change planeCurveFunction f 1 = + ((algebraMap (RatFunc K) (PlaneCurveFunctionField f)).comp ι) c at heq + rw [← heq] + exact hroot + have hmapUnit : IsUnit + (((algebraMap (RatFunc K) (PlaneCurveFunctionField f)).comp ι) + (G.eval c)) := by + rw [← hu] + exact u.isUnit.map _ + exact hmapUnit.ne_zero hzeroMap + have hprimitive := + adjoin_secondCoordinate_over_firstRatFunc_eq_top + hf hpartialSecond + have hdegree : G.natDegree = Module.finrank (RatFunc K) + (PlaneCurveFunctionField f) := by + have hmapDegree : G.natDegree = F.natDegree := by + change (F.map (algebraMap (Polynomial K) A)).natDegree = F.natDegree + exact Polynomial.natDegree_map_eq_of_injective + (IsLocalization.injective A p.asIdeal.primeCompl_le_nonZeroDivisors) F + calc + G.natDegree = F.natDegree := hmapDegree + _ = MvPolynomial.degreeOf 1 f := by simp [F] + _ = Module.finrank (RatFunc K) (PlaneCurveFunctionField f) := + (finrank_planeCurveFunctionField_over_ratFunc_eq_degreeOf_second + hf hpartialSecond).symm + refine ⟨a, u, ?_, hroot, hvc, hprimitive, hdegree⟩ + exact hu.symm + +/-- Finite-field form of the full reciprocal-normalization certificate. -/ +theorem planeCurve_local_reciprocal_certificate_of_degreeOf_second_lt_fintypeCard + [Fintype K] {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (hcardK : MvPolynomial.degreeOf 1 f < Fintype.card K) + (p : HeightOneSpectrum (Polynomial K)) : + letI := planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + letI := planeCurveFirstCoordinateRatFuncAlgebra f hx + let A := Localization.AtPrime p.asIdeal + let ι := localizationAtPrimeToRatFunc p + let G := (planeCurvePolynomialInSecondCoordinate f).map + (algebraMap (Polynomial K) A) + ∃ (a : Polynomial K) (u : Aˣ), + let c := algebraMap (Polynomial K) A a + G.eval c = (u : A) ∧ + G.eval₂ ((algebraMap (RatFunc K) + (PlaneCurveFunctionField f)).comp ι) + (planeCurveFunction f 1) = 0 ∧ + planeCurveFunction f 1 ≠ + algebraMap (RatFunc K) (PlaneCurveFunctionField f) (ι c) ∧ + Algebra.adjoin (RatFunc K) {planeCurveFunction f 1} = ⊤ ∧ + G.natDegree = Module.finrank (RatFunc K) + (PlaneCurveFunctionField f) := by + apply planeCurve_local_reciprocal_certificate_of_degreeOf_second_lt_card + hf hpartialSecond _ p + simpa only [Cardinal.mk_fintype, Nat.cast_lt] using hcardK + +/-- At every finite first-coordinate prime, a reciprocal translate of the +localized plane equation is exactly the minimal polynomial of the reciprocal +local parameter, under the exact cardinality hypothesis needed to select its +center. -/ +theorem planeCurve_minpoly_reciprocal_local_normalization_of_degreeOf_second_lt_card + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (hcardK : (MvPolynomial.degreeOf 1 f : Cardinal) < Cardinal.mk K) + (p : HeightOneSpectrum (Polynomial K)) : + letI := planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + letI := planeCurveFirstCoordinateRatFuncAlgebra f hx + let A := Localization.AtPrime p.asIdeal + let ι := localizationAtPrimeToRatFunc p + ∃ (a : Polynomial K) (u : Aˣ), + let c := algebraMap (Polynomial K) A a + let G := (planeCurvePolynomialInSecondCoordinate f).map + (algebraMap (Polynomial K) A) + minpoly (RatFunc K) + ((planeCurveFunction f 1 - + algebraMap (RatFunc K) (PlaneCurveFunctionField f) (ι c))⁻¹) = + (unitNormalizedReciprocalTranslate G c u).map ι := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let algRL : Algebra (RatFunc K) (PlaneCurveFunctionField f) := + planeCurveFirstCoordinateRatFuncAlgebra f hx + let : Algebra (RatFunc K) (PlaneCurveFunctionField f) := algRL + let A := Localization.AtPrime p.asIdeal + let ι := localizationAtPrimeToRatFunc p + obtain ⟨a, u, hu, hroot, hvc, hprimitive, hdegree⟩ := + planeCurve_local_reciprocal_certificate_of_degreeOf_second_lt_card + (K := K) hf hpartialSecond hcardK p + let c : A := algebraMap (Polynomial K) A a + let G : Polynomial A := + (planeCurvePolynomialInSecondCoordinate f).map + (algebraMap (Polynomial K) A) + let algRA : Algebra (Polynomial K) A := inferInstance + let algRR : Algebra (Polynomial K) (RatFunc K) := inferInstance + let algAR : Algebra A (RatFunc K) := ι.toAlgebra + let : Algebra (Polynomial K) A := algRA + let : Algebra (Polynomial K) (RatFunc K) := algRR + let : Algebra A (RatFunc K) := algAR + let : SMul (Polynomial K) A := algRA.toSMul + let : SMul (Polynomial K) (RatFunc K) := algRR.toSMul + let : SMul A (RatFunc K) := algAR.toSMul + let : IsScalarTower (Polynomial K) A (RatFunc K) := by + apply IsScalarTower.of_algebraMap_eq' + exact (localizationAtPrimeToRatFunc_comp_algebraMap p).symm + let : IsFractionRing A (RatFunc K) := + IsFractionRing.isFractionRing_of_isDomain_of_isLocalization + p.asIdeal.primeCompl A (RatFunc K) + let algAL : Algebra A (PlaneCurveFunctionField f) := + ((algebraMap (RatFunc K) (PlaneCurveFunctionField f)).comp ι).toAlgebra + let : SMul (RatFunc K) (PlaneCurveFunctionField f) := algRL.toSMul + let : Algebra A (PlaneCurveFunctionField f) := algAL + let : SMul A (PlaneCurveFunctionField f) := algAL.toSMul + let : IsScalarTower A (RatFunc K) (PlaneCurveFunctionField f) := by + apply IsScalarTower.of_algebraMap_eq' + rfl + let : FiniteDimensional (RatFunc K) (PlaneCurveFunctionField f) := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + have hroot' : Polynomial.aeval (planeCurveFunction f 1) G = 0 := by + simpa [Polynomial.aeval_def, algAL, RingHom.algebraMap_toAlgebra, + G] using hroot + have hvc' : planeCurveFunction f 1 ≠ + algebraMap A (PlaneCurveFunctionField f) c := by + simpa [algAL, RingHom.algebraMap_toAlgebra, RingHom.comp_apply, c] using hvc + have hmin := minpoly_inv_sub_eq_map_unitNormalizedReciprocalTranslate + (A := A) (K := RatFunc K) (L := PlaneCurveFunctionField f) + G c u (planeCurveFunction f 1) hu hvc' hroot' hprimitive hdegree + refine ⟨a, u, ?_⟩ + simpa [c, G, algAL, algAR, RingHom.algebraMap_toAlgebra, + RingHom.comp_apply] using hmin + +/-- Finite-field form of the reciprocal minimal-polynomial normalization. -/ +theorem planeCurve_minpoly_reciprocal_local_normalization_of_degreeOf_second_lt_fintypeCard + [Fintype K] {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (hcardK : MvPolynomial.degreeOf 1 f < Fintype.card K) + (p : HeightOneSpectrum (Polynomial K)) : + letI := planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + letI := planeCurveFirstCoordinateRatFuncAlgebra f hx + let A := Localization.AtPrime p.asIdeal + let ι := localizationAtPrimeToRatFunc p + ∃ (a : Polynomial K) (u : Aˣ), + let c := algebraMap (Polynomial K) A a + let G := (planeCurvePolynomialInSecondCoordinate f).map + (algebraMap (Polynomial K) A) + minpoly (RatFunc K) + ((planeCurveFunction f 1 - + algebraMap (RatFunc K) (PlaneCurveFunctionField f) (ι c))⁻¹) = + (unitNormalizedReciprocalTranslate G c u).map ι := by + apply + planeCurve_minpoly_reciprocal_local_normalization_of_degreeOf_second_lt_card + hf hpartialSecond _ p + simpa only [Cardinal.mk_fintype, Nat.cast_lt] using hcardK + +end +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurveLogarithmicGauss.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurveLogarithmicGauss.lean new file mode 100644 index 0000000000..3978915f9e --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurveLogarithmicGauss.lean @@ -0,0 +1,280 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveSupportDeterminant +public import Mathlib.Tactic + +/-! +# The logarithmic Gauss direction of a plane curve + +The logarithmic partial `X_i * ∂_i f` has exactly the same monomial +support as a subpolynomial of `f`. Consequently a scalar relation between +the two logarithmic partials forces every support exponent to lie on one +affine line in the constant field. + +If the support has a nonzero rank-two determinant and the characteristic is +larger than the public Euler budget, that determinant stays nonzero in the +constant field. Hence the logarithmic Gauss ratio cannot be constant on the +curve. This isolates the high-characteristic input needed by the +logarithmic-Gauss route to the powered-image index bound. +-/ + +@[expose] public section + +namespace BGS.CorvajaZannier + +noncomputable section + +/-- The logarithmic partial derivative `X_i * ∂_i f`. -/ +def planeCurveLogarithmicPDeriv {K : Type*} [Field K] + (i : Fin 2) (f : MvPolynomial (Fin 2) K) := + MvPolynomial.X i * MvPolynomial.pderiv i f + +theorem coeff_planeCurveLogarithmicPDeriv + {K : Type*} [Field K] (i : Fin 2) + (f : MvPolynomial (Fin 2) K) (m : Fin 2 →₀ ℕ) : + (planeCurveLogarithmicPDeriv i f).coeff m = + (m i : K) * f.coeff m := by + induction f using MvPolynomial.induction_on' with + | add p q hp hq => + simp only [planeCurveLogarithmicPDeriv, map_add, mul_add, + AddMonoidAlgebra.coeff_add, Finsupp.add_apply] + change (planeCurveLogarithmicPDeriv i p).coeff m + + (planeCurveLogarithmicPDeriv i q).coeff m = _ + rw [hp, hq] + | monomial n a => + rw [planeCurveLogarithmicPDeriv, + MvPolynomial.X_mul_pderiv_monomial] + simp only [MvPolynomial.coeff_smul, MvPolynomial.coeff_monomial] + split_ifs with h + · subst n + simp [nsmul_eq_mul] + · simp + +/-- A constant linear combination of the two logarithmic partials. -/ +def planeCurveLogarithmicDirection {K : Type*} [Field K] + (a b : K) (f : MvPolynomial (Fin 2) K) := + MvPolynomial.C a * planeCurveLogarithmicPDeriv 0 f + + MvPolynomial.C b * planeCurveLogarithmicPDeriv 1 f + +theorem coeff_planeCurveLogarithmicDirection + {K : Type*} [Field K] (a b : K) + (f : MvPolynomial (Fin 2) K) (m : Fin 2 →₀ ℕ) : + (planeCurveLogarithmicDirection a b f).coeff m = + (a * (m 0 : K) + b * (m 1 : K)) * f.coeff m := by + simp only [planeCurveLogarithmicDirection, AddMonoidAlgebra.coeff_add, Finsupp.add_apply, + MvPolynomial.coeff_C_mul, coeff_planeCurveLogarithmicPDeriv] + ring + +theorem support_planeCurveLogarithmicDirection_subset + {K : Type*} [Field K] (a b : K) + (f : MvPolynomial (Fin 2) K) : + (planeCurveLogarithmicDirection a b f).support ⊆ f.support := by + intro m hm + rw [MvPolynomial.mem_support_iff] at hm ⊢ + rw [coeff_planeCurveLogarithmicDirection] at hm + exact right_ne_zero_of_mul hm + +theorem degreeOf_planeCurveLogarithmicDirection_le + {K : Type*} [Field K] (a b : K) + (f : MvPolynomial (Fin 2) K) (i : Fin 2) : + MvPolynomial.degreeOf i (planeCurveLogarithmicDirection a b f) ≤ + MvPolynomial.degreeOf i f := by + rw [MvPolynomial.degreeOf_le_iff] + intro m hm + exact MvPolynomial.le_degreeOf_of_mem_support i + (support_planeCurveLogarithmicDirection_subset a b f hm) + +private theorem eq_C_coeff_zero_of_degreeOf_zero + {K : Type*} [Field K] (g : MvPolynomial (Fin 2) K) + (h0 : MvPolynomial.degreeOf 0 g = 0) + (h1 : MvPolynomial.degreeOf 1 g = 0) : + g = MvPolynomial.C (g.coeff 0) := by + ext m + by_cases hm : m = 0 + · subst m + simp + · have hcoordinate : m 0 ≠ 0 ∨ m 1 ≠ 0 := by + by_contra h + push Not at h + apply hm + ext i + fin_cases i <;> simp_all + have hmnot : m ∉ g.support := by + intro hmem + rcases hcoordinate with hm0 | hm1 + · have := MvPolynomial.le_degreeOf_of_mem_support 0 hmem + omega + · have := MvPolynomial.le_degreeOf_of_mem_support 1 hmem + omega + rw [MvPolynomial.notMem_support_iff.mp hmnot] + have hm' : (0 : Fin 2 →₀ ℕ) ≠ m := Ne.symm hm + simp [hm'] + +/-- A nonzero logarithmic direction divisible by `f` is only a constant +multiple of `f`; the coordinate degree bounds force the quotient to be +constant. -/ +theorem planeCurveLogarithmicDirection_eq_C_mul_of_dvd + {K : Type*} [Field K] {f : MvPolynomial (Fin 2) K} + (hf : f ≠ 0) (a b : K) + (hQ : planeCurveLogarithmicDirection a b f ≠ 0) + (hdvd : f ∣ planeCurveLogarithmicDirection a b f) : + ∃ d : K, planeCurveLogarithmicDirection a b f = MvPolynomial.C d * f := by + obtain ⟨g, hg⟩ := hdvd + have hg0 : g ≠ 0 := by + intro hzero + apply hQ + rw [hg, hzero, mul_zero] + have hdegree0 := degreeOf_planeCurveLogarithmicDirection_le a b f 0 + have hdegree1 := degreeOf_planeCurveLogarithmicDirection_le a b f 1 + rw [hg, MvPolynomial.degreeOf_mul_eq hf hg0] at hdegree0 hdegree1 + have hgDegree0 : MvPolynomial.degreeOf 0 g = 0 := by omega + have hgDegree1 : MvPolynomial.degreeOf 1 g = 0 := by omega + let d := g.coeff 0 + have hgC : g = MvPolynomial.C d := + eq_C_coeff_zero_of_degreeOf_zero g hgDegree0 hgDegree1 + refine ⟨d, ?_⟩ + rw [hg, hgC, mul_comm] + +private theorem supportDifferenceDet_cast_eq_zero_of_logWeights_eq + {K : Type*} [Field K] {f : MvPolynomial (Fin 2) K} + {r s t : Fin 2 →₀ ℕ} (_hr : r ∈ f.support) + (hs : s ∈ f.support) (ht : t ∈ f.support) + (c : K) + (hweights : ∀ m ∈ f.support, + (m 0 : K) - c * (m 1 : K) = + (r 0 : K) - c * (r 1 : K)) : + (planeCurveSupportDifferenceDet r s t : K) = 0 := by + have hs' := hweights s hs + have ht' := hweights t ht + dsimp only [planeCurveSupportDifferenceDet] + push_cast + linear_combination + ((t 1 : K) - (r 1 : K)) * hs' - + ((s 1 : K) - (r 1 : K)) * ht' + +private theorem logWeights_eq_of_logarithmicPDeriv_eq + {K : Type*} [Field K] {f : MvPolynomial (Fin 2) K} + (c d : K) + (hrelation : planeCurveLogarithmicPDeriv 0 f = + MvPolynomial.C c * planeCurveLogarithmicPDeriv 1 f + + MvPolynomial.C d * f) : + ∀ m ∈ f.support, + (m 0 : K) - c * (m 1 : K) = d := by + intro m hm + have hcoeff := congrArg (fun p ↦ p.coeff m) hrelation + simp only [AddMonoidAlgebra.coeff_add, Finsupp.add_apply, MvPolynomial.coeff_C_mul, + coeff_planeCurveLogarithmicPDeriv] at hcoeff + have hm0 : f.coeff m ≠ 0 := + MvPolynomial.mem_support_iff.mp hm + apply (mul_right_cancel₀ hm0) + linear_combination hcoeff + +theorem planeCurveSupportDifferenceDet_cast_ne_zero_of_lt_char + {K : Type*} [Field K] {p : ℕ} [CharP K p] + {r s t : Fin 2 →₀ ℕ} + (hdet : planeCurveSupportDifferenceDet r s t ≠ 0) + (hlt : (planeCurveSupportDifferenceDet r s t).natAbs < p) : + (planeCurveSupportDifferenceDet r s t : K) ≠ 0 := by + intro hzero + have hdvd : (p : ℤ) ∣ planeCurveSupportDifferenceDet r s t := + (CharP.intCast_eq_zero_iff K p _).mp hzero + have hp0 : (p : ℤ) ≠ 0 := by + intro hp + have : p = 0 := by exact_mod_cast hp + subst p + simp at hlt + have hle := Int.natAbs_le_of_dvd_ne_zero hdvd hdet + simpa using (hle.trans_lt hlt) + +/-- Rank-two support excludes a scalar logarithmic-Gauss relation in +characteristic larger than the support determinant budget. -/ +theorem no_logarithmicPDeriv_scalar_relation_of_supportRankTwo + {K : Type*} [Field K] {p : ℕ} [CharP K p] + {f : MvPolynomial (Fin 2) K} + (hrank : PlaneCurveSupportHasRankTwo f) + (hlarge : 2 * MvPolynomial.degreeOf 0 f * + MvPolynomial.degreeOf 1 f < p) : + ¬ ∃ c d : K, planeCurveLogarithmicPDeriv 0 f = + MvPolynomial.C c * planeCurveLogarithmicPDeriv 1 f + + MvPolynomial.C d * f := by + rintro ⟨c, d, hrelation⟩ + obtain ⟨r, s, t, hr, hs, ht, hdet⟩ := hrank + have hweights := logWeights_eq_of_logarithmicPDeriv_eq c d hrelation + have hcastZero : (planeCurveSupportDifferenceDet r s t : K) = 0 := + supportDifferenceDet_cast_eq_zero_of_logWeights_eq hr hs ht c + (by + intro m hm + rw [hweights m hm, hweights r hr]) + have hdetBound := + natAbs_planeCurveSupportDifferenceDet_le_twice_bidegree hr hs ht + have hcastNe : (planeCurveSupportDifferenceDet r s t : K) ≠ 0 := + planeCurveSupportDifferenceDet_cast_ne_zero_of_lt_char hdet + (hdetBound.trans_lt hlarge) + exact hcastNe hcastZero + +/-- On an irreducible curve with rank-two support, no constant can be the +logarithmic Gauss ratio in the high-characteristic range. -/ +theorem eval_planeCurveLogarithmicDirection_ne_zero_of_supportRankTwo + {K : Type*} [Field K] {p : ℕ} [CharP K p] + {f : MvPolynomial (Fin 2) K} + (hf : Irreducible f) + (hrank : PlaneCurveSupportHasRankTwo f) + (hlarge : 2 * MvPolynomial.degreeOf 0 f * + MvPolynomial.degreeOf 1 f < p) + (c : K) : + letI := planeCurveCoordinateRing_isDomain hf + MvPolynomial.eval₂ (algebraMap K (PlaneCurveFunctionField f)) + (planeCurveFunction f) + (planeCurveLogarithmicDirection 1 (-c) f) ≠ 0 := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let Q := planeCurveLogarithmicDirection 1 (-c) f + have hno := no_logarithmicPDeriv_scalar_relation_of_supportRankTwo + hrank hlarge + have hQ : Q ≠ 0 := by + intro hzero + apply hno + refine ⟨c, 0, ?_⟩ + have hzero' : planeCurveLogarithmicPDeriv 0 f - + MvPolynomial.C c * planeCurveLogarithmicPDeriv 1 f = 0 := by + simpa [Q, planeCurveLogarithmicDirection, sub_eq_add_neg] using hzero + simpa using sub_eq_zero.mp hzero' + intro heval + have hquotient : planeCurveQuotientMap f Q = 0 := by + apply IsFractionRing.injective + (PlaneCurveCoordinateRing f) (PlaneCurveFunctionField f) + rw [map_zero] + change ((algebraMap (PlaneCurveCoordinateRing f) + (PlaneCurveFunctionField f)).comp (planeCurveQuotientMap f)) Q = 0 + rw [← eval₂_planeCurveFunction f] + exact heval + have hdvd : f ∣ Q := + Ideal.mem_span_singleton.mp + (Ideal.Quotient.eq_zero_iff_mem.mp hquotient) + obtain ⟨d, hd⟩ := + planeCurveLogarithmicDirection_eq_C_mul_of_dvd hf.ne_zero + 1 (-c) hQ hdvd + apply hno + refine ⟨c, d, ?_⟩ + have hd' : planeCurveLogarithmicPDeriv 0 f - + MvPolynomial.C c * planeCurveLogarithmicPDeriv 1 f = + MvPolynomial.C d * f := by + simpa [Q, planeCurveLogarithmicDirection, sub_eq_add_neg] using hd + calc + planeCurveLogarithmicPDeriv 0 f = + (planeCurveLogarithmicPDeriv 0 f - + MvPolynomial.C c * planeCurveLogarithmicPDeriv 1 f) + + MvPolynomial.C c * planeCurveLogarithmicPDeriv 1 f := by abel + _ = MvPolynomial.C d * f + + MvPolynomial.C c * planeCurveLogarithmicPDeriv 1 f := by rw [hd'] + _ = MvPolynomial.C c * planeCurveLogarithmicPDeriv 1 f + + MvPolynomial.C d * f := add_comm _ _ + +end +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurvePoweredHeightBounds.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurvePoweredHeightBounds.lean new file mode 100644 index 0000000000..c500df7349 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurvePoweredHeightBounds.lean @@ -0,0 +1,363 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionPositiveDegreePower +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionOneSubGcdHeight +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveBoundarySupport +public import Mathlib.Tactic + +/-! +# Powered coordinate heights in the first-coordinate place model + +The canonical place summation uses the first-coordinate `RatFunc` model. +This module records the exact first-coordinate height and the transported +upper bound for the second-coordinate height, including positive powers. +-/ + +@[expose] public section + +namespace BGS.CorvajaZannier + +noncomputable section + +open scoped Polynomial + +variable {K : Type*} [Field K] [Fintype K] [DecidableEq K] + [DecidableEq (RatFunc K)] + +omit [Fintype K] in +/-- In the first-coordinate place model, `x^m` has its expected exact +positive divisor degree. -/ +theorem finiteExtensionPositiveDegree_planeCurveFirstCoordinate_pow + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (m : ℕ) (_hm : 0 < m) : + letI := planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + letI := planeCurveFirstCoordinateRatFuncAlgebra f hx + letI := finiteDimensional_planeCurveFunctionField_over_ratFunc + hf hpartialSecond + letI := separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + finiteExtensionPositiveDegree K (PlaneCurveFunctionField f) + ((planeCurveFunction f 0) ^ m) = + m * MvPolynomial.degreeOf 1 f := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let L := PlaneCurveFunctionField f + let x : L := planeCurveFunction f 0 + have hx0 : x ≠ 0 := by + change planeCurveFunction f 0 ≠ 0 + intro h + apply hx + rw [h] + exact isAlgebraic_zero + let : Algebra (RatFunc K) L := + planeCurveFirstCoordinateRatFuncAlgebra f hx + let : FiniteDimensional (RatFunc K) L := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : Algebra.IsSeparable (RatFunc K) L := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + change finiteExtensionPositiveDegree K L (x ^ m) = + m * MvPolynomial.degreeOf 1 f + have hxDegree : finiteExtensionPositiveDegree K L x = + MvPolynomial.degreeOf 1 f := by + have hheight := finiteExtensionPositiveDegree_polynomial + K L Polynomial.X Polynomial.X_ne_zero + have hmap : algebraMap (RatFunc K) L + (algebraMap K[X] (RatFunc K) Polynomial.X) = x := by + change ratFuncSpecialization x hx RatFunc.X = x + exact planeCurveFirstCoordinateRatFuncAlgebra_X f hx + rw [hmap, + finrank_planeCurveFunctionField_over_ratFunc_eq_degreeOf_second + hf hpartialSecond] at hheight + simpa using hheight + rw [finiteExtensionPositiveDegree_pow K L x hx0 m, hxDegree] + +/-- In the same first-coordinate place model, the transported second +coordinate power has height at most `n * degreeOf 0 f`. -/ +theorem finiteExtensionPositiveDegree_planeCurveSecondCoordinate_pow_le + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (n : ℕ) : + letI := planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + letI := planeCurveFirstCoordinateRatFuncAlgebra f hx + letI := finiteDimensional_planeCurveFunctionField_over_ratFunc + hf hpartialSecond + letI := separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + finiteExtensionPositiveDegree K (PlaneCurveFunctionField f) + ((planeCurveFunction f 1) ^ n) ≤ + n * MvPolynomial.degreeOf 0 f := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let L := PlaneCurveFunctionField f + let y : L := planeCurveFunction f 1 + have hyTrans : Transcendental K y := + secondCoordinate_transcendental hf + (degreeOf_first_pos_of_pderiv_ne_zero hpartialFirst) + have hy0 : y ≠ 0 := by + intro h + apply hyTrans + rw [h] + exact isAlgebraic_zero + let : Algebra (RatFunc K) L := + planeCurveFirstCoordinateRatFuncAlgebra f hx + let : FiniteDimensional (RatFunc K) L := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : Algebra.IsSeparable (RatFunc K) L := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + change finiteExtensionPositiveDegree K L (y ^ n) ≤ + n * MvPolynomial.degreeOf 0 f + rw [finiteExtensionPositiveDegree_pow K L y hy0 n] + exact Nat.mul_le_mul_left n + (finiteExtensionPositiveDegree_planeCurveSecondCoordinate_le_degreeOf_first + hf hpartialFirst hpartialSecond) + +/-- The exhaustive gcd of `1-u` and `1-v` is bounded by the powered height +of `v`, and hence by its displayed plane-curve degree budget. -/ +theorem finiteExtensionGcdWeightedDegree_one_sub_planeCurvePowers_le + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (m n : ℕ) (hm : 0 < m) (hn : 0 < n) : + letI := planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + letI := planeCurveFirstCoordinateRatFuncAlgebra f hx + letI := finiteDimensional_planeCurveFunctionField_over_ratFunc + hf hpartialSecond + letI := separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + finiteExtensionGcdWeightedDegree K (PlaneCurveFunctionField f) + (1 - (planeCurveFunction f 0) ^ m) + (1 - (planeCurveFunction f 1) ^ n) ≤ + n * MvPolynomial.degreeOf 0 f := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let L := PlaneCurveFunctionField f + let x : L := planeCurveFunction f 0 + let y : L := planeCurveFunction f 1 + have hxTrans : Transcendental K x := hx + have hyTrans : Transcendental K y := + secondCoordinate_transcendental hf + (degreeOf_first_pos_of_pderiv_ne_zero hpartialFirst) + have hx0 : x ≠ 0 := by + intro h + apply hxTrans + rw [h] + exact isAlgebraic_zero + have hy0 : y ≠ 0 := by + intro h + apply hyTrans + rw [h] + exact isAlgebraic_zero + have hxmOne : x ^ m ≠ 1 := by + intro h + apply hxTrans.pow hm + rw [h] + exact isAlgebraic_one + have hynOne : y ^ n ≠ 1 := by + intro h + apply hyTrans.pow hn + rw [h] + exact isAlgebraic_one + let : Algebra (RatFunc K) L := + planeCurveFirstCoordinateRatFuncAlgebra f hx + let : FiniteDimensional (RatFunc K) L := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : Algebra.IsSeparable (RatFunc K) L := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + change finiteExtensionGcdWeightedDegree K L (1 - x ^ m) (1 - y ^ n) ≤ + n * MvPolynomial.degreeOf 0 f + have hgcd := finiteExtensionOneSubGcd_add_outsideHeight_le_positiveDegree_coordinate + K L (x ^ m) (y ^ n) (pow_ne_zero _ hx0) (pow_ne_zero _ hy0) + hxmOne hynOne + have hv : finiteExtensionPositiveDegree K L (y ^ n) ≤ + n * MvPolynomial.degreeOf 0 f := by + simpa only [L, y] using + finiteExtensionPositiveDegree_planeCurveSecondCoordinate_pow_le + hf hpartialFirst hpartialSecond n + omega + +omit [Fintype K] in +/-- The exhaustive gcd degree is symmetric in its two arguments. -/ +theorem finiteExtensionGcdWeightedDegree_comm + {L : Type*} [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] [Algebra.IsSeparable (RatFunc K) L] + (x y : L) : + finiteExtensionGcdWeightedDegree K L x y = + finiteExtensionGcdWeightedDegree K L y x := by + classical + unfold finiteExtensionGcdWeightedDegree finiteExtensionGcdMultiplicity + finiteExtensionGcdSupport + rw [Finset.union_comm] + apply Finset.sum_congr rfl + intro w _hw + rw [min_comm] + +omit [Fintype K] in +/-- Simultaneously changing the signs of the two functions does not change +their exhaustive gcd divisor degree. -/ +theorem finiteExtensionGcdWeightedDegree_neg_neg + {L : Type*} [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] [Algebra.IsSeparable (RatFunc K) L] + (x y : L) (hx : x ≠ 0) (hy : y ≠ 0) : + finiteExtensionGcdWeightedDegree K L (-x) (-y) = + finiteExtensionGcdWeightedDegree K L x y := by + classical + have hdivx : finiteExtensionPrincipalDivisor K L (-x) = + finiteExtensionPrincipalDivisor K L x := by + ext w + exact finiteExtensionPrincipalDivisor_neg_apply K L x hx w + have hdivy : finiteExtensionPrincipalDivisor K L (-y) = + finiteExtensionPrincipalDivisor K L y := by + ext w + exact finiteExtensionPrincipalDivisor_neg_apply K L y hy w + unfold finiteExtensionGcdWeightedDegree finiteExtensionGcdMultiplicity + finiteExtensionGcdSupport + rw [hdivx, hdivy] + +omit [DecidableEq (RatFunc K)] in +omit [Fintype K] in +/-- The torsion gcd used by the endpoint is exactly the `1-u`, `1-v` gcd +used by the canonical Wronskian estimate. -/ +theorem planeCurveExhaustiveTorsionGcdWeightedDegree_eq_one_sub + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (m n : ℕ) (hm : 0 < m) (hn : 0 < n) : + letI := planeCurveCoordinateRing_isDomain hf + letI : DecidableEq (RatFunc K) := Classical.decEq _ + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + letI := planeCurveFirstCoordinateRatFuncAlgebra f hx + letI := finiteDimensional_planeCurveFunctionField_over_ratFunc + hf hpartialSecond + letI := separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + planeCurveExhaustiveTorsionGcdWeightedDegree + hf hpartialSecond m n = + finiteExtensionGcdWeightedDegree K (PlaneCurveFunctionField f) + (1 - (planeCurveFunction f 0) ^ m) + (1 - (planeCurveFunction f 1) ^ n) := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let : DecidableEq (RatFunc K) := Classical.decEq _ + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let L := PlaneCurveFunctionField f + let x : L := planeCurveFunction f 0 + let y : L := planeCurveFunction f 1 + have hxTrans : Transcendental K x := hx + have hyTrans : Transcendental K y := + secondCoordinate_transcendental hf + (degreeOf_first_pos_of_pderiv_ne_zero hpartialFirst) + have hxm : 1 - x ^ m ≠ 0 := by + apply sub_ne_zero.mpr + intro h + apply hxTrans.pow hm + rw [← h] + exact isAlgebraic_one + have hyn : 1 - y ^ n ≠ 0 := by + apply sub_ne_zero.mpr + intro h + apply hyTrans.pow hn + rw [← h] + exact isAlgebraic_one + let : Algebra (RatFunc K) L := + planeCurveFirstCoordinateRatFuncAlgebra f hx + let : FiniteDimensional (RatFunc K) L := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : Algebra.IsSeparable (RatFunc K) L := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + dsimp only [planeCurveExhaustiveTorsionGcdWeightedDegree] + change finiteExtensionGcdWeightedDegree K L (x ^ m - 1) (y ^ n - 1) = + finiteExtensionGcdWeightedDegree K L (1 - x ^ m) (1 - y ^ n) + rw [show x ^ m - 1 = -(1 - x ^ m) by ring, + show y ^ n - 1 = -(1 - y ^ n) by ring] + exact finiteExtensionGcdWeightedDegree_neg_neg + (K := K) (L := L) (1 - x ^ m) (1 - y ^ n) hxm hyn + +omit [Fintype K] in +/-- With the coordinates swapped, the one-minus gcd is bounded by the exact +powered height of the first coordinate. -/ +theorem finiteExtensionGcdWeightedDegree_one_sub_planeCurvePowers_swapped_le + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (m n : ℕ) (hm : 0 < m) (hn : 0 < n) : + letI := planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + letI := planeCurveFirstCoordinateRatFuncAlgebra f hx + letI := finiteDimensional_planeCurveFunctionField_over_ratFunc + hf hpartialSecond + letI := separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + finiteExtensionGcdWeightedDegree K (PlaneCurveFunctionField f) + (1 - (planeCurveFunction f 1) ^ n) + (1 - (planeCurveFunction f 0) ^ m) ≤ + m * MvPolynomial.degreeOf 1 f := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let L := PlaneCurveFunctionField f + let x : L := planeCurveFunction f 0 + let y : L := planeCurveFunction f 1 + have hxTrans : Transcendental K x := hx + have hyTrans : Transcendental K y := + secondCoordinate_transcendental hf + (degreeOf_first_pos_of_pderiv_ne_zero hpartialFirst) + have hx0 : x ≠ 0 := by + intro h + apply hxTrans + rw [h] + exact isAlgebraic_zero + have hy0 : y ≠ 0 := by + intro h + apply hyTrans + rw [h] + exact isAlgebraic_zero + have hxmOne : x ^ m ≠ 1 := by + intro h + apply hxTrans.pow hm + rw [h] + exact isAlgebraic_one + have hynOne : y ^ n ≠ 1 := by + intro h + apply hyTrans.pow hn + rw [h] + exact isAlgebraic_one + let : Algebra (RatFunc K) L := + planeCurveFirstCoordinateRatFuncAlgebra f hx + let : FiniteDimensional (RatFunc K) L := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : Algebra.IsSeparable (RatFunc K) L := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + change finiteExtensionGcdWeightedDegree K L (1 - y ^ n) (1 - x ^ m) ≤ + m * MvPolynomial.degreeOf 1 f + have hgcd := finiteExtensionOneSubGcd_add_outsideHeight_le_positiveDegree_coordinate + K L (y ^ n) (x ^ m) (pow_ne_zero _ hy0) (pow_ne_zero _ hx0) + hynOne hxmOne + have hxPower : finiteExtensionPositiveDegree K L (x ^ m) = + m * MvPolynomial.degreeOf 1 f := by + simpa only [L, x] using + finiteExtensionPositiveDegree_planeCurveFirstCoordinate_pow + hf hpartialSecond m hm + omega + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurvePoweredImageDegreeBudget.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurvePoweredImageDegreeBudget.lean new file mode 100644 index 0000000000..8e43e6fe47 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurvePoweredImageDegreeBudget.lean @@ -0,0 +1,87 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PoweredImageHeightFactor +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PoweredImageIndex +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.TranscendentalPowerDegree + +/-! +# Exact source-height factorization through the powered image + +These identities are the degree bookkeeping used in the two orientations of +Corvaja--Zannier Proposition 2. The first factor is the relevant degree of +the powered-image relation and the second is the common source-to-image +index. +-/ + +@[expose] public section + +namespace BGS.CorvajaZannier + +noncomputable section + + +/-- In the orientation `(u,v)=(x^m,y^n)`, the degree of the image relation in +`u` times the common source-to-image index is the source height `n d₀`. -/ +theorem poweredCoordinateImageRelation_transpose_natDegree_mul_commonIndex + {K : Type*} [Field K] {f : MvPolynomial (Fin 2) K} + (hf : Irreducible f) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (m n : ℕ) (hm : 0 < m) (hn : 0 < n) : + letI := planeCurveCoordinateRing_isDomain hf + (transposeBivariate + (poweredCoordinateImageRelation hf hpartialSecond m hm n)).natDegree * + Module.finrank (PoweredImageOverFirst f m n) + (PlaneCurveFunctionField f) = + n * MvPolynomial.degreeOf 0 f := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let a := (transposeBivariate + (poweredCoordinateImageRelation hf hpartialSecond m hm n)).natDegree + calc + a * Module.finrank (PoweredImageOverFirst f m n) + (PlaneCurveFunctionField f) = + a * Module.finrank (PoweredImageOverSecond f m n) + (PlaneCurveFunctionField f) := by + rw [finrank_poweredImageOverFirst_eq_poweredImageOverSecond] + _ = Module.finrank (SecondPoweredCoordinateSubfield f n) + (PlaneCurveFunctionField f) := by + exact poweredCoordinateImageRelation_transpose_natDegree_mul_imageIndex + hf hpartialFirst hpartialSecond m hm n hn + _ = n * MvPolynomial.degreeOf 0 f := + finrank_over_secondPoweredCoordinate_eq hf hpartialFirst n hn + +/-- In the swapped orientation `(u,v)=(y^n,x^m)`, the degree of the image +relation in `y^n` times the same index is the source height `m d₁`. -/ +theorem poweredCoordinateImageRelation_natDegree_mul_commonIndex + {K : Type*} [Field K] {f : MvPolynomial (Fin 2) K} + (hf : Irreducible f) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (m n : ℕ) (hm : 0 < m) : + letI := planeCurveCoordinateRing_isDomain hf + (poweredCoordinateImageRelation hf hpartialSecond m hm n).natDegree * + Module.finrank (PoweredImageOverFirst f m n) + (PlaneCurveFunctionField f) = + m * MvPolynomial.degreeOf 1 f := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + calc + (poweredCoordinateImageRelation hf hpartialSecond m hm n).natDegree * + Module.finrank (PoweredImageOverFirst f m n) + (PlaneCurveFunctionField f) = + Module.finrank (FirstPoweredCoordinateSubfield f m) + (PlaneCurveFunctionField f) := + poweredCoordinateImageRelation_natDegree_mul_imageIndex + hf hpartialSecond m hm n + _ = m * MvPolynomial.degreeOf 1 f := + finrank_over_firstPoweredCoordinate_eq hf hpartialSecond m hm + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurvePropositionTwoAssembly.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurvePropositionTwoAssembly.lean new file mode 100644 index 0000000000..a77dd6cf95 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurvePropositionTwoAssembly.lean @@ -0,0 +1,278 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurvePoweredImageDegreeBudget +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurvePoweredHeightBounds +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PropositionTwoDegreeMonotonicity +public import Mathlib.Tactic + +/-! +# Numerical assembly of plane-curve Proposition 2 + +This module isolates the final numerical use of the powered-image relation. +The geometric Wronskian estimate is supplied pointwise; the remaining degree, +index, and trivial-gcd bookkeeping is discharged here in both coordinate +orientations. +-/ + +@[expose] public section + +namespace BGS.CorvajaZannier + +noncomputable section + + +variable {K : Type*} [Field K] [Fintype K] [DecidableEq K] + +private theorem propositionTwoAuxiliaryBound_of_zero_parameter + (A B Chi h k : ℕ) (G : ℝ) (hG : G ≤ (A : ℝ)) + (hn : 0 < h * k + h + k) (hzero : h = 0 ∨ k = 0) : + G ≤ + (((h + 2 * k : ℕ) : ℝ) / ((h * k + h + k : ℕ) : ℝ)) * (A : ℝ) + + ((k : ℝ) / ((h * k + h + k : ℕ) : ℝ)) * (B : ℝ) + + ((((h * k + h + k : ℕ) : ℝ) - 1) / 2) * (Chi : ℝ) := by + rcases hzero with rfl | rfl + · have hk : 0 < k := by simpa using hn + have hk0 : (k : ℝ) ≠ 0 := by exact_mod_cast hk.ne' + have heuler : 0 ≤ (((k : ℝ) - 1) / 2) * (Chi : ℝ) := by + have hkOne : (1 : ℝ) ≤ (k : ℝ) := by exact_mod_cast hk + positivity + norm_num [hk0] + have hA0 : 0 ≤ (A : ℝ) := Nat.cast_nonneg A + have hB0 : 0 ≤ (B : ℝ) := Nat.cast_nonneg B + linarith + · have hh : 0 < h := by simpa using hn + have hh0 : (h : ℝ) ≠ 0 := by exact_mod_cast hh.ne' + have heuler : 0 ≤ (((h : ℝ) - 1) / 2) * (Chi : ℝ) := by + have hhOne : (1 : ℝ) ≤ (h : ℝ) := by exact_mod_cast hh + positivity + norm_num [hh0] + linarith + +/-- Proposition 2 in the orientation `(u,v)=(x^m,y^n)`. -/ +theorem planeCurvePropositionTwo_natural_of_auxiliaryBounds + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (m n p Chi : ℕ) (hm : 0 < m) (hn : 0 < n) + (hindex : + letI := planeCurveCoordinateRing_isDomain hf + Module.finrank (PoweredImageOverFirst f m n) + (PlaneCurveFunctionField f) ≤ Chi) + (hauxiliary : ∀ h k : ℕ, 0 < h → 0 < k → + PropositionTwoParametersAreAdmissible + (n * MvPolynomial.degreeOf 0 f) + (m * MvPolynomial.degreeOf 1 f) p h k → + ¬ ((transposeBivariate + (poweredCoordinateImageRelation hf hpartialSecond m hm n)).natDegree ≤ k ∧ + (poweredCoordinateImageRelation hf hpartialSecond m hm n).natDegree ≤ h) → + letI := planeCurveCoordinateRing_isDomain hf + letI : DecidableEq (RatFunc K) := Classical.decEq _ + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + letI := planeCurveFirstCoordinateRatFuncAlgebra f hx + letI := finiteDimensional_planeCurveFunctionField_over_ratFunc + hf hpartialSecond + letI := separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + (finiteExtensionGcdWeightedDegree K (PlaneCurveFunctionField f) + (1 - (planeCurveFunction f 0) ^ m) + (1 - (planeCurveFunction f 1) ^ n) : ℝ) ≤ + (((h + 2 * k : ℕ) : ℝ) / + ((h * k + h + k : ℕ) : ℝ)) * + (n * MvPolynomial.degreeOf 0 f : ℕ) + + ((k : ℝ) / ((h * k + h + k : ℕ) : ℝ)) * + (m * MvPolynomial.degreeOf 1 f : ℕ) + + ((((h * k + h + k : ℕ) : ℝ) - 1) / 2) * (Chi : ℝ)) : + PropositionTwoNumericalAlternatives + (n * MvPolynomial.degreeOf 0 f) + (m * MvPolynomial.degreeOf 1 f) p Chi + (planeCurveExhaustiveTorsionGcdWeightedDegree + hf hpartialSecond m n : ℝ) := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let : DecidableEq (RatFunc K) := Classical.decEq _ + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let : Algebra (RatFunc K) (PlaneCurveFunctionField f) := + planeCurveFirstCoordinateRatFuncAlgebra f hx + let : FiniteDimensional (RatFunc K) (PlaneCurveFunctionField f) := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : Algebra.IsSeparable (RatFunc K) (PlaneCurveFunctionField f) := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let a := (transposeBivariate + (poweredCoordinateImageRelation hf hpartialSecond m hm n)).natDegree + let b := (poweredCoordinateImageRelation hf hpartialSecond m hm n).natDegree + let d := Module.finrank (PoweredImageOverFirst f m n) + (PlaneCurveFunctionField f) + let A := n * MvPolynomial.degreeOf 0 f + let B := m * MvPolynomial.degreeOf 1 f + have ha : 0 < a := by + dsimp only [a] + exact poweredCoordinateImageRelation_transpose_natDegree_pos + hf hpartialFirst hpartialSecond m hm n hn + have hb : 0 < b := by + dsimp only [b] + exact poweredCoordinateImageRelation_natDegree_pos + hf hpartialSecond m hm n + have hfactor : a * d = A := by + simpa only [a, d, A] using + poweredCoordinateImageRelation_transpose_natDegree_mul_commonIndex + hf hpartialFirst hpartialSecond m n hm hn + have hA : A ≤ d * a := by + rw [Nat.mul_comm, hfactor] + have hdChi : d ≤ Chi := by + simpa only [d] using hindex + have hGnat : planeCurveExhaustiveTorsionGcdWeightedDegree + hf hpartialSecond m n ≤ A := by + rw [planeCurveExhaustiveTorsionGcdWeightedDegree_eq_one_sub + hf hpartialFirst hpartialSecond m n hm hn] + exact finiteExtensionGcdWeightedDegree_one_sub_planeCurvePowers_le + hf hpartialFirst hpartialSecond m n hm hn + have hG : (planeCurveExhaustiveTorsionGcdWeightedDegree + hf hpartialSecond m n : ℝ) ≤ (A : ℝ) := by + exact_mod_cast hGnat + apply propositionTwoNumericalAlternatives_of_scaledAuxiliaryDegreeAlternative + a b d A B p Chi + (planeCurveExhaustiveTorsionGcdWeightedDegree + hf hpartialSecond m n : ℝ) + ha hb hA hdChi hG + intro h k hadmissible + by_cases hdegree : a ≤ k ∧ b ≤ h + · exact Or.inl hdegree + · right + by_cases hh : h = 0 + · exact propositionTwoAuxiliaryBound_of_zero_parameter + A B Chi h k + (planeCurveExhaustiveTorsionGcdWeightedDegree + hf hpartialSecond m n : ℝ) hG hadmissible.1 (Or.inl hh) + by_cases hk : k = 0 + · exact propositionTwoAuxiliaryBound_of_zero_parameter + A B Chi h k + (planeCurveExhaustiveTorsionGcdWeightedDegree + hf hpartialSecond m n : ℝ) hG hadmissible.1 (Or.inr hk) + simpa only [a, b, A, B, + planeCurveExhaustiveTorsionGcdWeightedDegree_eq_one_sub + hf hpartialFirst hpartialSecond m n hm hn] using + hauxiliary h k (Nat.pos_of_ne_zero hh) (Nat.pos_of_ne_zero hk) + (by simpa only [A, B] using hadmissible) + (by simpa only [a, b] using hdegree) + +omit [Fintype K] in +/-- Proposition 2 in the swapped orientation `(u,v)=(y^n,x^m)`. -/ +theorem planeCurvePropositionTwo_swapped_of_auxiliaryBounds + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (m n p Chi : ℕ) (hm : 0 < m) (hn : 0 < n) + (hindex : + letI := planeCurveCoordinateRing_isDomain hf + Module.finrank (PoweredImageOverFirst f m n) + (PlaneCurveFunctionField f) ≤ Chi) + (hauxiliary : ∀ h k : ℕ, 0 < h → 0 < k → + PropositionTwoParametersAreAdmissible + (m * MvPolynomial.degreeOf 1 f) + (n * MvPolynomial.degreeOf 0 f) p h k → + ¬ ((poweredCoordinateImageRelation hf hpartialSecond m hm n).natDegree ≤ k ∧ + (transposeBivariate + (poweredCoordinateImageRelation hf hpartialSecond m hm n)).natDegree ≤ h) → + letI := planeCurveCoordinateRing_isDomain hf + letI : DecidableEq (RatFunc K) := Classical.decEq _ + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + letI := planeCurveFirstCoordinateRatFuncAlgebra f hx + letI := finiteDimensional_planeCurveFunctionField_over_ratFunc + hf hpartialSecond + letI := separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + (finiteExtensionGcdWeightedDegree K (PlaneCurveFunctionField f) + (1 - (planeCurveFunction f 1) ^ n) + (1 - (planeCurveFunction f 0) ^ m) : ℝ) ≤ + (((h + 2 * k : ℕ) : ℝ) / + ((h * k + h + k : ℕ) : ℝ)) * + (m * MvPolynomial.degreeOf 1 f : ℕ) + + ((k : ℝ) / ((h * k + h + k : ℕ) : ℝ)) * + (n * MvPolynomial.degreeOf 0 f : ℕ) + + ((((h * k + h + k : ℕ) : ℝ) - 1) / 2) * (Chi : ℝ)) : + PropositionTwoNumericalAlternatives + (m * MvPolynomial.degreeOf 1 f) + (n * MvPolynomial.degreeOf 0 f) p Chi + (planeCurveExhaustiveTorsionGcdWeightedDegree + hf hpartialSecond m n : ℝ) := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let : DecidableEq (RatFunc K) := Classical.decEq _ + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let : Algebra (RatFunc K) (PlaneCurveFunctionField f) := + planeCurveFirstCoordinateRatFuncAlgebra f hx + let : FiniteDimensional (RatFunc K) (PlaneCurveFunctionField f) := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : Algebra.IsSeparable (RatFunc K) (PlaneCurveFunctionField f) := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let a := (poweredCoordinateImageRelation hf hpartialSecond m hm n).natDegree + let b := (transposeBivariate + (poweredCoordinateImageRelation hf hpartialSecond m hm n)).natDegree + let d := Module.finrank (PoweredImageOverFirst f m n) + (PlaneCurveFunctionField f) + let A := m * MvPolynomial.degreeOf 1 f + let B := n * MvPolynomial.degreeOf 0 f + have ha : 0 < a := by + dsimp only [a] + exact poweredCoordinateImageRelation_natDegree_pos + hf hpartialSecond m hm n + have hb : 0 < b := by + dsimp only [b] + exact poweredCoordinateImageRelation_transpose_natDegree_pos + hf hpartialFirst hpartialSecond m hm n hn + have hfactor : a * d = A := by + simpa only [a, d, A] using + poweredCoordinateImageRelation_natDegree_mul_commonIndex + hf hpartialSecond m n hm + have hA : A ≤ d * a := by + rw [Nat.mul_comm, hfactor] + have hdChi : d ≤ Chi := by + simpa only [d] using hindex + have hGnat : planeCurveExhaustiveTorsionGcdWeightedDegree + hf hpartialSecond m n ≤ A := by + rw [planeCurveExhaustiveTorsionGcdWeightedDegree_eq_one_sub + hf hpartialFirst hpartialSecond m n hm hn] + rw [finiteExtensionGcdWeightedDegree_comm] + exact finiteExtensionGcdWeightedDegree_one_sub_planeCurvePowers_swapped_le + hf hpartialFirst hpartialSecond m n hm hn + have hG : (planeCurveExhaustiveTorsionGcdWeightedDegree + hf hpartialSecond m n : ℝ) ≤ (A : ℝ) := by + exact_mod_cast hGnat + apply propositionTwoNumericalAlternatives_of_scaledAuxiliaryDegreeAlternative + a b d A B p Chi + (planeCurveExhaustiveTorsionGcdWeightedDegree + hf hpartialSecond m n : ℝ) + ha hb hA hdChi hG + intro h k hadmissible + by_cases hdegree : a ≤ k ∧ b ≤ h + · exact Or.inl hdegree + · right + by_cases hh : h = 0 + · exact propositionTwoAuxiliaryBound_of_zero_parameter + A B Chi h k + (planeCurveExhaustiveTorsionGcdWeightedDegree + hf hpartialSecond m n : ℝ) hG hadmissible.1 (Or.inl hh) + by_cases hk : k = 0 + · exact propositionTwoAuxiliaryBound_of_zero_parameter + A B Chi h k + (planeCurveExhaustiveTorsionGcdWeightedDegree + hf hpartialSecond m n : ℝ) hG hadmissible.1 (Or.inr hk) + have hbound := hauxiliary h k (Nat.pos_of_ne_zero hh) (Nat.pos_of_ne_zero hk) + (by simpa only [A, B] using hadmissible) + (by simpa only [a, b] using hdegree) + rw [planeCurveExhaustiveTorsionGcdWeightedDegree_eq_one_sub + hf hpartialFirst hpartialSecond m n hm hn] + rw [finiteExtensionGcdWeightedDegree_comm] + simpa only [A, B] using hbound + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurvePropositionTwoDegreeBridge.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurvePropositionTwoDegreeBridge.lean new file mode 100644 index 0000000000..eb0a331c96 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurvePropositionTwoDegreeBridge.lean @@ -0,0 +1,248 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveExhaustiveGcdEndpoint +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveCanonicalDegreeBound +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PropositionTwoDegreeMonotonicity +public import Mathlib.Tactic + +/-! +# From actual plane-curve degrees to the public Proposition 2 certificate + +The canonical divisor argument naturally computes with the actual coordinate +degrees `degreeOf 0 f` and `degreeOf 1 f`. The public theorem instead accepts +arbitrary declared bidegree bounds. This file performs that last change of +degree data without asserting the false monotonicity of Proposition 2's degree +alternative. +-/ + +@[expose] public section + +namespace BGS.CorvajaZannier + +noncomputable section + +/-- The actual lower powered-coordinate degree is bounded by the lower degree +built from any declared bidegree bounds. -/ +theorem planeCurveTorsionLowerDegree_actual_le_public + {K : Type*} [Field K] {f : MvPolynomial (Fin 2) K} + (firstDegree secondDegree firstOrder secondOrder : ℕ) + (hbidegree : BGS.External.HasBidegreeAtMost + f firstDegree secondDegree) : + planeCurveTorsionLowerDegree + (MvPolynomial.degreeOf 0 f) (MvPolynomial.degreeOf 1 f) + firstOrder secondOrder ≤ + planeCurveTorsionLowerDegree + firstDegree secondDegree firstOrder secondOrder := by + unfold planeCurveTorsionLowerDegree + exact min_le_min + (Nat.mul_le_mul_left secondOrder + (degreeOf_first_le_of_hasBidegreeAtMost hbidegree)) + (Nat.mul_le_mul_left firstOrder + (degreeOf_second_le_of_hasBidegreeAtMost hbidegree)) + +/-- The actual upper powered-coordinate degree is bounded by the upper degree +built from any declared bidegree bounds. -/ +theorem planeCurveTorsionUpperDegree_actual_le_public + {K : Type*} [Field K] {f : MvPolynomial (Fin 2) K} + (firstDegree secondDegree firstOrder secondOrder : ℕ) + (hbidegree : BGS.External.HasBidegreeAtMost + f firstDegree secondDegree) : + planeCurveTorsionUpperDegree + (MvPolynomial.degreeOf 0 f) (MvPolynomial.degreeOf 1 f) + firstOrder secondOrder ≤ + planeCurveTorsionUpperDegree + firstDegree secondDegree firstOrder secondOrder := by + unfold planeCurveTorsionUpperDegree + exact max_le_max + (Nat.mul_le_mul_left secondOrder + (degreeOf_first_le_of_hasBidegreeAtMost hbidegree)) + (Nat.mul_le_mul_left firstOrder + (degreeOf_second_le_of_hasBidegreeAtMost hbidegree)) + +/-- The actual bidegree Euler budget is bounded by the public one. -/ +theorem planeCurve_actualEulerBudget_le_public + {K : Type*} [Field K] {f : MvPolynomial (Fin 2) K} + (firstDegree secondDegree : ℕ) + (hbidegree : BGS.External.HasBidegreeAtMost + f firstDegree secondDegree) : + 2 * MvPolynomial.degreeOf 0 f * MvPolynomial.degreeOf 1 f ≤ + 2 * firstDegree * secondDegree := by + exact Nat.mul_le_mul + (Nat.mul_le_mul_left 2 + (degreeOf_first_le_of_hasBidegreeAtMost hbidegree)) + (degreeOf_second_le_of_hasBidegreeAtMost hbidegree) + +/-- Proposition 2 at the actual coordinate degrees supplies the public +certificate at arbitrary declared bidegree bounds. + +The actual Proposition 2 input is allowed to bound the exhaustive gcd degree. +The certificate itself uses the torsion-point cardinality. It is below that +gcd degree, has the required trivial bound at the actual degrees, and can +therefore be transported to the larger public degrees by +`propositionTwoNumericalAlternatives_mono_degreeBounds`. -/ +theorem planeCurvePropositionTwoCertificate_of_actualDegree_exhaustiveGcd + {K : Type*} [Field K] [Fintype K] [DecidableEq K] + {f : MvPolynomial (Fin 2) K} + (p firstDegree secondDegree firstOrder secondOrder : ℕ) + (hf : Irreducible f) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (hbidegree : BGS.External.HasBidegreeAtMost + f firstDegree secondDegree) + (hcurve : BGS.External.IsCorvajaZannierPlaneCurve f) + (hfirstDegree : 0 < firstDegree) + (hsecondDegree : 0 < secondDegree) + (hfirstOrder : 0 < firstOrder) (hsecondOrder : 0 < secondOrder) + (hfirstNonzero : planeCurveFunction f 0 ^ firstOrder - 1 ≠ 0) + (hsecondNonzero : planeCurveFunction f 1 ^ secondOrder - 1 ≠ 0) + (hpropositionTwoActual : PropositionTwoNumericalAlternatives + (planeCurveTorsionLowerDegree + (MvPolynomial.degreeOf 0 f) (MvPolynomial.degreeOf 1 f) + firstOrder secondOrder) + (planeCurveTorsionUpperDegree + (MvPolynomial.degreeOf 0 f) (MvPolynomial.degreeOf 1 f) + firstOrder secondOrder) + p (2 * MvPolynomial.degreeOf 0 f * MvPolynomial.degreeOf 1 f) + (planeCurveExhaustiveTorsionGcdWeightedDegree + hf hpartialSecond firstOrder secondOrder : ℝ)) : + PlaneCurvePropositionTwoCertificate + p K f firstDegree secondDegree firstOrder secondOrder := by + let actualLower : ℕ := planeCurveTorsionLowerDegree + (MvPolynomial.degreeOf 0 f) (MvPolynomial.degreeOf 1 f) + firstOrder secondOrder + let actualUpper : ℕ := planeCurveTorsionUpperDegree + (MvPolynomial.degreeOf 0 f) (MvPolynomial.degreeOf 1 f) + firstOrder secondOrder + let publicLower : ℕ := planeCurveTorsionLowerDegree + firstDegree secondDegree firstOrder secondOrder + let publicUpper : ℕ := planeCurveTorsionUpperDegree + firstDegree secondDegree firstOrder secondOrder + let actualChi : ℕ := + 2 * MvPolynomial.degreeOf 0 f * MvPolynomial.degreeOf 1 f + let publicChi : ℕ := 2 * firstDegree * secondDegree + let card : ℕ := + (BGS.External.torusCurveTorsionIntersection + K f firstOrder secondOrder).card + let gcdDegree : ℕ := planeCurveExhaustiveTorsionGcdWeightedDegree + hf hpartialSecond firstOrder secondOrder + have hfirstActual : 0 < MvPolynomial.degreeOf 0 f := + degreeOf_first_pos_of_pderiv_ne_zero hcurve.2.2.1 + have hsecondActual : 0 < MvPolynomial.degreeOf 1 f := + degreeOf_second_pos_of_pderiv_ne_zero hcurve.2.2.2 + have hactualLowerPos : 0 < actualLower := by + dsimp only [actualLower, planeCurveTorsionLowerDegree] + exact lt_min (Nat.mul_pos hsecondOrder hfirstActual) + (Nat.mul_pos hfirstOrder hsecondActual) + have hactualUpperPos : 0 < actualUpper := by + dsimp only [actualUpper, planeCurveTorsionUpperDegree] + exact lt_of_lt_of_le + (Nat.mul_pos hsecondOrder hfirstActual) (le_max_left _ _) + have hactualLowerPublic : actualLower ≤ publicLower := by + exact planeCurveTorsionLowerDegree_actual_le_public + firstDegree secondDegree firstOrder secondOrder hbidegree + have hactualUpperPublic : actualUpper ≤ publicUpper := by + exact planeCurveTorsionUpperDegree_actual_le_public + firstDegree secondDegree firstOrder secondOrder hbidegree + have hactualChiPublic : actualChi ≤ publicChi := by + exact planeCurve_actualEulerBudget_le_public + firstDegree secondDegree hbidegree + have hpublicChiPos : 0 < publicChi := by + dsimp only [publicChi] + positivity + have hcardActualTrivial : card ≤ actualLower := by + dsimp only [card, actualLower, planeCurveTorsionLowerDegree] + simpa only [min_comm] using + torusCurveTorsionIntersection_card_le_min_bidegree_order + f (MvPolynomial.degreeOf 0 f) (MvPolynomial.degreeOf 1 f) + firstOrder secondOrder (hasBidegreeAtMost_degreeOf f) hcurve + hfirstOrder hsecondOrder + have hcardGcd : card ≤ gcdDegree := by + dsimp only [card, gcdDegree] + rw [torusCurveTorsionIntersection_card_eq_torsionPoint_card] + exact torsionPoint_card_le_planeCurveExhaustiveTorsionGcdWeightedDegree + hf hpartialSecond firstOrder secondOrder + hfirstNonzero hsecondNonzero + have hpropositionTwoCardActual : PropositionTwoNumericalAlternatives + actualLower actualUpper p actualChi (card : ℝ) := by + apply propositionTwoNumericalAlternatives_mono + (G := (card : ℝ)) (H := (gcdDegree : ℝ)) + · exact_mod_cast hcardGcd + · simpa only [actualLower, actualUpper, actualChi, gcdDegree] using + hpropositionTwoActual + have hpropositionTwoCardPublic : PropositionTwoNumericalAlternatives + publicLower publicUpper p publicChi (card : ℝ) := by + exact propositionTwoNumericalAlternatives_mono_degreeBounds + actualLower actualUpper publicLower publicUpper p actualChi publicChi + (card : ℝ) hactualLowerPos hactualUpperPos + hactualLowerPublic hactualUpperPublic hactualChiPublic hpublicChiPos + (by exact_mod_cast hcardActualTrivial) hpropositionTwoCardActual + refine ⟨(card : ℝ), le_rfl, ?_, ?_⟩ + · exact_mod_cast hcardActualTrivial.trans hactualLowerPublic + · simpa only [publicLower, publicUpper, publicChi] using + hpropositionTwoCardPublic + +/-- Pointwise Proposition 2 at the actual source-coordinate heights assembles +the exact universal certificate proposition expected by the public endpoint. + +This theorem is intentionally a composition boundary, not a replacement for +the geometric proof: its hypothesis still asks for the actual-height +Proposition 2 estimate for the exhaustive gcd divisor. -/ +theorem generalPlaneCurvePropositionTwoCertificatesAboveElementaryRange_of_actualDegree + (hactual : ∀ (p : ℕ) [Fact p.Prime] + (K : Type) [Field K] [Fintype K] [DecidableEq K] [CharP K p] + (f : MvPolynomial (Fin 2) K) + (firstDegree secondDegree firstOrder secondOrder : ℕ) + (_hfirstDegree : 0 < firstDegree) + (_hsecondDegree : 0 < secondDegree) + (_hbidegree : BGS.External.HasBidegreeAtMost f firstDegree secondDegree) + (hcurve : BGS.External.IsCorvajaZannierPlaneCurve f) + (_hfirstOrder : 0 < firstOrder) + (_hsecondOrder : 0 < secondOrder) + (_hfirstPrimeToChar : ¬ p ∣ firstOrder) + (_hsecondPrimeToChar : ¬ p ∣ secondOrder) + (_hlarge : 12 * firstDegree * secondDegree < p), + let hf : Irreducible f := + irreducible_of_irreducible_map_algebraicClosure + hcurve.1 + PropositionTwoNumericalAlternatives + (planeCurveTorsionLowerDegree + (MvPolynomial.degreeOf 0 f) (MvPolynomial.degreeOf 1 f) + firstOrder secondOrder) + (planeCurveTorsionUpperDegree + (MvPolynomial.degreeOf 0 f) (MvPolynomial.degreeOf 1 f) + firstOrder secondOrder) + p (2 * MvPolynomial.degreeOf 0 f * MvPolynomial.degreeOf 1 f) + (planeCurveExhaustiveTorsionGcdWeightedDegree + hf hcurve.2.2.2 + firstOrder secondOrder : ℝ)) : + GeneralPlaneCurvePropositionTwoCertificatesAboveElementaryRange := by + unfold GeneralPlaneCurvePropositionTwoCertificatesAboveElementaryRange + intro p _ K _ _ _ _ f firstDegree secondDegree firstOrder secondOrder + hfirstDegree hsecondDegree hbidegree hcurve hfirstOrder hsecondOrder + hfirstPrimeToChar hsecondPrimeToChar hlarge + let hf : Irreducible f := + irreducible_of_irreducible_map_algebraicClosure hcurve.1 + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + have hnonzero : + planeCurveFunction f 0 ^ firstOrder - 1 ≠ 0 ∧ + planeCurveFunction f 1 ^ secondOrder - 1 ≠ 0 := + poweredTorsionFunctions_ne_zero_of_isCorvajaZannierPlaneCurve + hcurve firstOrder secondOrder hfirstOrder hsecondOrder + apply planeCurvePropositionTwoCertificate_of_actualDegree_exhaustiveGcd + p firstDegree secondDegree firstOrder secondOrder hf hcurve.2.2.2 + hbidegree hcurve hfirstDegree hsecondDegree hfirstOrder hsecondOrder + hnonzero.1 hnonzero.2 + simpa only [hf] using hactual p (K := K) f + firstDegree secondDegree firstOrder secondOrder + hfirstDegree hsecondDegree hbidegree hcurve hfirstOrder hsecondOrder + hfirstPrimeToChar hsecondPrimeToChar hlarge + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurvePropositionTwoGeometric.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurvePropositionTwoGeometric.lean new file mode 100644 index 0000000000..153cd74c8a --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurvePropositionTwoGeometric.lean @@ -0,0 +1,236 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurvePropositionTwoAssembly +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveCanonicalGcdBound +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveCanonicalEulerBound +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveCharacteristicCardinality +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.EndpointComposition +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PoweredImageFrobeniusRelation +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PoweredImageFrobeniusRelationSwapped + +/-! +# Geometric Proposition 2 for a plane curve + +The powered-image linear-independence theorem and the canonical global +Wronskian estimate are assembled here. The source-to-image index remains an +explicit premise of the two orientation lemmas; the following endpoint module +discharges it from the non-subtorus hypothesis. +-/ + +@[expose] public section + +namespace BGS.CorvajaZannier + +noncomputable section + + +private theorem exceptionalPlaces_comm + (K : Type*) [Field K] [DecidableEq K] [DecidableEq (RatFunc K)] + (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] [Algebra.IsSeparable (RatFunc K) L] + (u v : L) : propositionTwoExceptionalPlaces K L u v = + propositionTwoExceptionalPlaces K L v u := by + classical + exact Finset.union_comm _ _ + +/-- The natural orientation `(u,v)=(x^m,y^n)` of the geometric Proposition 2 +argument. -/ +theorem planeCurvePropositionTwo_natural_of_poweredImageIndexBound + {K : Type*} [Field K] [Fintype K] [DecidableEq K] + {p : ℕ} [Fact p.Prime] [CharP K p] + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (habsolute : Irreducible + (MvPolynomial.map (algebraMap K (AlgebraicClosure K)) f)) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (m n : ℕ) (hm : 0 < m) (hn : 0 < n) + (hnPrime : ¬ p ∣ n) + (hcardK : MvPolynomial.degreeOf 1 f < Fintype.card K) + (hindex : + let := planeCurveCoordinateRing_isDomain hf + Module.finrank (PoweredImageOverFirst f m n) + (PlaneCurveFunctionField f) ≤ + 2 * MvPolynomial.degreeOf 0 f * MvPolynomial.degreeOf 1 f) : + PropositionTwoNumericalAlternatives + (n * MvPolynomial.degreeOf 0 f) + (m * MvPolynomial.degreeOf 1 f) p + (2 * MvPolynomial.degreeOf 0 f * MvPolynomial.degreeOf 1 f) + (planeCurveExhaustiveTorsionGcdWeightedDegree + hf hpartialSecond m n : ℝ) := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let : DecidableEq (RatFunc K) := Classical.decEq _ + let Chi := 2 * MvPolynomial.degreeOf 0 f * MvPolynomial.degreeOf 1 f + apply planeCurvePropositionTwo_natural_of_auxiliaryBounds + hf hpartialFirst hpartialSecond m n p Chi hm hn hindex + intro h k hh hk hadmissible hexcluded + let L := PlaneCurveFunctionField f + let : CharP L p := charP_of_injective_algebraMap + (algebraMap K L).injective p + let gK := poweredCoordinateImageRelation hf hpartialSecond m hm n + let g := poweredCoordinateFrobeniusImageRelation + (p := p) hf hpartialSecond m hm n + have hbidegree := poweredCoordinateImageRelation_bidegree_le + hf hpartialFirst hpartialSecond m hm n hn + have hdegreeG : g.natDegree ≤ n * MvPolynomial.degreeOf 0 f := by + dsimp only [g] + rw [poweredCoordinateFrobeniusImageRelation_natDegree] + exact hbidegree.2 + have hdegreeTranspose : (transposeBivariate g).natDegree ≤ + m * MvPolynomial.degreeOf 1 f := by + dsimp only [g] + rw [transposeBivariate_poweredCoordinateFrobeniusImageRelation_natDegree] + exact hbidegree.1 + have hsize : g.natDegree * h + (transposeBivariate g).natDegree * k < p := by + apply lt_of_le_of_lt _ hadmissible.2 + exact Nat.add_le_add + (Nat.mul_le_mul_right h hdegreeG) + (Nat.mul_le_mul_right k hdegreeTranspose) + have hexcludedG : ¬ (g.natDegree ≤ k ∧ + (transposeBivariate g).natDegree ≤ h) := by + dsimp only [g, gK] at hexcluded ⊢ + rw [poweredCoordinateFrobeniusImageRelation_natDegree, + transposeBivariate_poweredCoordinateFrobeniusImageRelation_natDegree] + exact hexcluded + have hLI := + poweredCoordinateFrobeniusImage_auxiliaryFamily_linearIndependent + (p := p) habsolute hf hpartialFirst hpartialSecond + m n hm hnPrime h k hh hk hsize hexcludedG + have hEuler := + planeCurve_canonicalDifferent_add_propositionTwoExceptional_weightedDegree_le + hf hpartialFirst hpartialSecond hcardK m n hm hn + exact finiteExtensionGcdBound_planeCurvePowers_of_auxiliaryFamily_linearIndependent + (p := p) hf hpartialFirst hpartialSecond m n hm hn + h k hadmissible.1 Chi hLI hEuler + +/-- The swapped orientation `(u,v)=(y^n,x^m)` of the geometric Proposition 2 +argument. -/ +theorem planeCurvePropositionTwo_swapped_of_poweredImageIndexBound + {K : Type*} [Field K] [Fintype K] [DecidableEq K] + {p : ℕ} [Fact p.Prime] [CharP K p] + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (habsolute : Irreducible + (MvPolynomial.map (algebraMap K (AlgebraicClosure K)) f)) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (m n : ℕ) (hm : 0 < m) (hn : 0 < n) + (hmPrime : ¬ p ∣ m) + (hcardK : MvPolynomial.degreeOf 1 f < Fintype.card K) + (hindex : + let := planeCurveCoordinateRing_isDomain hf + Module.finrank (PoweredImageOverFirst f m n) + (PlaneCurveFunctionField f) ≤ + 2 * MvPolynomial.degreeOf 0 f * MvPolynomial.degreeOf 1 f) : + PropositionTwoNumericalAlternatives + (m * MvPolynomial.degreeOf 1 f) + (n * MvPolynomial.degreeOf 0 f) p + (2 * MvPolynomial.degreeOf 0 f * MvPolynomial.degreeOf 1 f) + (planeCurveExhaustiveTorsionGcdWeightedDegree + hf hpartialSecond m n : ℝ) := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let : DecidableEq (RatFunc K) := Classical.decEq _ + let Chi := 2 * MvPolynomial.degreeOf 0 f * MvPolynomial.degreeOf 1 f + apply planeCurvePropositionTwo_swapped_of_auxiliaryBounds + hf hpartialFirst hpartialSecond m n p Chi hm hn hindex + intro h k hh hk hadmissible hexcluded + let L := PlaneCurveFunctionField f + let : CharP L p := charP_of_injective_algebraMap + (algebraMap K L).injective p + let F := frobeniusSubfield L p + let ι : K →+* F := + perfectConstantsToFrobeniusSubfield (K := K) (L := L) (p := p) + let gK := poweredCoordinateImageRelation hf hpartialSecond m hm n + let g : Polynomial (Polynomial F) := gK.map (Polynomial.mapRingHom ι) + have hι : Function.Injective ι := + perfectConstantsToFrobeniusSubfield_injective + (K := K) (L := L) (p := p) + have hmap : Function.Injective (Polynomial.mapRingHom ι) := + Polynomial.map_injective ι hι + have hdegreeG : g.natDegree = gK.natDegree := by + dsimp only [g] + exact Polynomial.natDegree_map_eq_of_injective hmap _ + have hdegreeTranspose : (transposeBivariate g).natDegree = + (transposeBivariate gK).natDegree := by + dsimp only [g] + rw [transposeBivariate_map] + exact Polynomial.natDegree_map_eq_of_injective hmap _ + have hbidegree := poweredCoordinateImageRelation_bidegree_le + hf hpartialFirst hpartialSecond m hm n hn + have hsize : g.natDegree * h + (transposeBivariate g).natDegree * k < p := by + apply lt_of_le_of_lt _ hadmissible.2 + rw [hdegreeG, hdegreeTranspose] + exact Nat.add_le_add + (Nat.mul_le_mul_right h hbidegree.1) + (Nat.mul_le_mul_right k hbidegree.2) + have hexcludedG : ¬ (g.natDegree ≤ k ∧ + (transposeBivariate g).natDegree ≤ h) := by + rw [hdegreeG, hdegreeTranspose] + exact hexcluded + have hLI := + poweredCoordinateFrobeniusImage_auxiliaryFamily_linearIndependent_swapped + (p := p) habsolute hf hpartialFirst hpartialSecond + m n hm hn hmPrime h k hh hk hsize hexcludedG + have hEulerNatural := + planeCurve_canonicalDifferent_add_propositionTwoExceptional_weightedDegree_le + hf hpartialFirst hpartialSecond hcardK m n hm hn + exact finiteExtensionGcdBound_planeCurvePowers_swapped_of_auxiliaryFamily_linearIndependent + (p := p) hf hpartialFirst hpartialSecond m n hm hn + h k hadmissible.1 Chi hLI (by + erw [exceptionalPlaces_comm] + exact hEulerNatural) + +/-- The two orientations combine to the actual minimum/maximum degree form +needed by the plane-curve endpoint. -/ +theorem planeCurvePropositionTwo_of_poweredImageIndexBound + {K : Type*} [Field K] [Fintype K] [DecidableEq K] + {p : ℕ} [Fact p.Prime] [CharP K p] + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (habsolute : Irreducible + (MvPolynomial.map (algebraMap K (AlgebraicClosure K)) f)) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (m n : ℕ) (hm : 0 < m) (hn : 0 < n) + (hmPrime : ¬ p ∣ m) (hnPrime : ¬ p ∣ n) + (hlarge : 12 * MvPolynomial.degreeOf 0 f * + MvPolynomial.degreeOf 1 f < p) + (hindex : + let := planeCurveCoordinateRing_isDomain hf + Module.finrank (PoweredImageOverFirst f m n) + (PlaneCurveFunctionField f) ≤ + 2 * MvPolynomial.degreeOf 0 f * MvPolynomial.degreeOf 1 f) : + PropositionTwoNumericalAlternatives + (planeCurveTorsionLowerDegree + (MvPolynomial.degreeOf 0 f) (MvPolynomial.degreeOf 1 f) m n) + (planeCurveTorsionUpperDegree + (MvPolynomial.degreeOf 0 f) (MvPolynomial.degreeOf 1 f) m n) + p (2 * MvPolynomial.degreeOf 0 f * MvPolynomial.degreeOf 1 f) + (planeCurveExhaustiveTorsionGcdWeightedDegree + hf hpartialSecond m n : ℝ) := by + have hcardK : MvPolynomial.degreeOf 1 f < Fintype.card K := + planeCurve_degreeOf_second_lt_card_of_twelve_mul_degrees_lt_char + hpartialFirst hpartialSecond hlarge + by_cases horient : n * MvPolynomial.degreeOf 0 f ≤ + m * MvPolynomial.degreeOf 1 f + · have hnatural := planeCurvePropositionTwo_natural_of_poweredImageIndexBound + (p := p) hf habsolute hpartialFirst hpartialSecond + m n hm hn hnPrime hcardK hindex + simpa only [planeCurveTorsionLowerDegree, planeCurveTorsionUpperDegree, + min_eq_left horient, max_eq_right horient] using hnatural + · have horient' : m * MvPolynomial.degreeOf 1 f ≤ + n * MvPolynomial.degreeOf 0 f := Nat.le_of_lt (lt_of_not_ge horient) + have hswapped := planeCurvePropositionTwo_swapped_of_poweredImageIndexBound + (p := p) hf habsolute hpartialFirst hpartialSecond + m n hm hn hmPrime hcardK hindex + simpa only [planeCurveTorsionLowerDegree, planeCurveTorsionUpperDegree, + min_eq_right horient', max_eq_left horient'] using hswapped + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurveRatFuncModel.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurveRatFuncModel.lean new file mode 100644 index 0000000000..33b97631f8 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurveRatFuncModel.lean @@ -0,0 +1,278 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PoweredImageCurve +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveSeparability + +/-! +# A rational-function-field model for a plane curve + +The first coordinate of an irreducible plane curve with nonzero second +partial derivative is separating and transcendental. This file uses that +coordinate to put the function field over the standard field `K(X)`. It +then transports finiteness, separability, and the exact extension degree from +the intrinsic first-coordinate subfield. + +This is the model required by the exhaustive finite-plus-infinity divisor +formalization: its base is literally `RatFunc K`, and `X` specializes to the +first coordinate function. +-/ + +@[expose] public section + +namespace BGS.CorvajaZannier + +noncomputable section + +variable {K : Type*} [Field K] + +/-- The `RatFunc K`-algebra structure obtained by specializing `X` at the +first coordinate of the plane curve. -/ +@[reducible] noncomputable def planeCurveFirstCoordinateRatFuncAlgebra + (f : MvPolynomial (Fin 2) K) [IsDomain (PlaneCurveCoordinateRing f)] + (hx : Transcendental K (planeCurveFunction f 0)) : + Algebra (RatFunc K) (PlaneCurveFunctionField f) := + (ratFuncSpecialization (planeCurveFunction f 0) hx).toAlgebra + +@[simp] theorem planeCurveFirstCoordinateRatFuncAlgebra_algebraMap_apply + (f : MvPolynomial (Fin 2) K) [IsDomain (PlaneCurveCoordinateRing f)] + (hx : Transcendental K (planeCurveFunction f 0)) (z : RatFunc K) : + letI := planeCurveFirstCoordinateRatFuncAlgebra f hx + algebraMap (RatFunc K) (PlaneCurveFunctionField f) z = + ratFuncSpecialization (planeCurveFunction f 0) hx z := + rfl + +@[simp] theorem planeCurveFirstCoordinateRatFuncAlgebra_X + (f : MvPolynomial (Fin 2) K) [IsDomain (PlaneCurveCoordinateRing f)] + (hx : Transcendental K (planeCurveFunction f 0)) : + letI := planeCurveFirstCoordinateRatFuncAlgebra f hx + algebraMap (RatFunc K) (PlaneCurveFunctionField f) RatFunc.X = + planeCurveFunction f 0 := by + let := planeCurveFirstCoordinateRatFuncAlgebra f hx + change ratFuncSpecialization (planeCurveFunction f 0) hx RatFunc.X = _ + simp [ratFuncSpecialization, RatFunc.algEquivOfTranscendental_X] + +private theorem planeCurve_firstCoordinate_changeBase_commutes + {f : MvPolynomial (Fin 2) K} [IsDomain (PlaneCurveCoordinateRing f)] + (hx : Transcendental K (planeCurveFunction f 0)) : + letI := planeCurveFirstCoordinateRatFuncAlgebra f hx + (algebraMap (RatFunc K) (PlaneCurveFunctionField f)).comp + (RatFunc.algEquivOfTranscendental + (planeCurveFunction f 0) hx).symm.toRingEquiv.toRingHom = + (RingEquiv.refl (PlaneCurveFunctionField f)).toRingHom.comp + (algebraMap (FirstCoordinateSubfield f) + (PlaneCurveFunctionField f)) := by + let := planeCurveFirstCoordinateRatFuncAlgebra f hx + ext z + simp [ratFuncSpecialization] + +/-- The plane-curve function field is finite over the standard rational +function field when `X` is specialized to the first coordinate. -/ +theorem finiteDimensional_planeCurveFunctionField_over_ratFunc + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) : + letI := planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + letI := planeCurveFirstCoordinateRatFuncAlgebra f hx + FiniteDimensional (RatFunc K) (PlaneCurveFunctionField f) := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let : Algebra (RatFunc K) (PlaneCurveFunctionField f) := + planeCurveFirstCoordinateRatFuncAlgebra f hx + let : FiniteDimensional (FirstCoordinateSubfield f) + (PlaneCurveFunctionField f) := + (finiteSeparable_over_firstCoordinate_of_irreducible + hf hpartialSecond).1 + exact Module.Finite.of_equiv_equiv + (RatFunc.algEquivOfTranscendental + (planeCurveFunction f 0) hx).symm.toRingEquiv + (RingEquiv.refl (PlaneCurveFunctionField f)) + (planeCurve_firstCoordinate_changeBase_commutes hx) + +/-- The same change of base transports separability. -/ +theorem separable_planeCurveFunctionField_over_ratFunc + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) : + letI := planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + letI := planeCurveFirstCoordinateRatFuncAlgebra f hx + Algebra.IsSeparable (RatFunc K) (PlaneCurveFunctionField f) := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let : Algebra (RatFunc K) (PlaneCurveFunctionField f) := + planeCurveFirstCoordinateRatFuncAlgebra f hx + let : Algebra.IsSeparable (FirstCoordinateSubfield f) + (PlaneCurveFunctionField f) := + (finiteSeparable_over_firstCoordinate_of_irreducible + hf hpartialSecond).2 + exact Algebra.IsSeparable.of_equiv_equiv + (RatFunc.algEquivOfTranscendental + (planeCurveFunction f 0) hx).symm.toRingEquiv + (RingEquiv.refl (PlaneCurveFunctionField f)) + (planeCurve_firstCoordinate_changeBase_commutes hx) + +/-- The extension degree over `K(X)` is exactly the degree of the equation in +the second coordinate. -/ +theorem finrank_planeCurveFunctionField_over_ratFunc_eq_degreeOf_second + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) : + letI := planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + letI := planeCurveFirstCoordinateRatFuncAlgebra f hx + Module.finrank (RatFunc K) (PlaneCurveFunctionField f) = + MvPolynomial.degreeOf 1 f := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let : Algebra (RatFunc K) (PlaneCurveFunctionField f) := + planeCurveFirstCoordinateRatFuncAlgebra f hx + calc + Module.finrank (RatFunc K) (PlaneCurveFunctionField f) = + Module.finrank (FirstCoordinateSubfield f) + (PlaneCurveFunctionField f) := + (Algebra.finrank_eq_of_equiv_equiv + (RatFunc.algEquivOfTranscendental + (planeCurveFunction f 0) hx).symm.toRingEquiv + (RingEquiv.refl (PlaneCurveFunctionField f)) + (planeCurve_firstCoordinate_changeBase_commutes hx)).symm + _ = MvPolynomial.degreeOf 1 f := + finrank_over_firstCoordinate_eq_degreeOf_second_of_irreducible + hf hpartialSecond + +/-! ## The symmetric second-coordinate model -/ + +/-- The `RatFunc K`-algebra structure obtained by specializing `X` at the +second coordinate of the plane curve. -/ +@[reducible] noncomputable def planeCurveSecondCoordinateRatFuncAlgebra + (f : MvPolynomial (Fin 2) K) [IsDomain (PlaneCurveCoordinateRing f)] + (hy : Transcendental K (planeCurveFunction f 1)) : + Algebra (RatFunc K) (PlaneCurveFunctionField f) := + (ratFuncSpecialization (planeCurveFunction f 1) hy).toAlgebra + +@[simp] theorem planeCurveSecondCoordinateRatFuncAlgebra_X + (f : MvPolynomial (Fin 2) K) [IsDomain (PlaneCurveCoordinateRing f)] + (hy : Transcendental K (planeCurveFunction f 1)) : + letI := planeCurveSecondCoordinateRatFuncAlgebra f hy + algebraMap (RatFunc K) (PlaneCurveFunctionField f) RatFunc.X = + planeCurveFunction f 1 := by + let := planeCurveSecondCoordinateRatFuncAlgebra f hy + change ratFuncSpecialization (planeCurveFunction f 1) hy RatFunc.X = _ + simp [ratFuncSpecialization, RatFunc.algEquivOfTranscendental_X] + +private theorem planeCurve_secondCoordinate_changeBase_commutes + {f : MvPolynomial (Fin 2) K} [IsDomain (PlaneCurveCoordinateRing f)] + (hy : Transcendental K (planeCurveFunction f 1)) : + letI := planeCurveSecondCoordinateRatFuncAlgebra f hy + (algebraMap (RatFunc K) (PlaneCurveFunctionField f)).comp + (RatFunc.algEquivOfTranscendental + (planeCurveFunction f 1) hy).symm.toRingEquiv.toRingHom = + (RingEquiv.refl (PlaneCurveFunctionField f)).toRingHom.comp + (algebraMap (SecondCoordinateSubfield f) + (PlaneCurveFunctionField f)) := by + let := planeCurveSecondCoordinateRatFuncAlgebra f hy + ext z + change ratFuncSpecialization (planeCurveFunction f 1) hy + ((RatFunc.algEquivOfTranscendental + (planeCurveFunction f 1) hy).symm z) = + algebraMap (SecondCoordinateSubfield f) (PlaneCurveFunctionField f) z + exact DFunLike.congr_fun + (ratFuncSpecialization_comp_symm_algEquiv + (planeCurveFunction f 1) hy) z + +/-- The second-coordinate specialization also makes the plane-curve function +field finite over the standard rational-function field. -/ +theorem finiteDimensional_planeCurveFunctionField_over_secondRatFunc + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) : + letI := planeCurveCoordinateRing_isDomain hf + let hy := secondCoordinate_transcendental hf + (degreeOf_first_pos_of_pderiv_ne_zero hpartialFirst) + letI := planeCurveSecondCoordinateRatFuncAlgebra f hy + FiniteDimensional (RatFunc K) (PlaneCurveFunctionField f) := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let hy := secondCoordinate_transcendental hf + (degreeOf_first_pos_of_pderiv_ne_zero hpartialFirst) + let : Algebra (RatFunc K) (PlaneCurveFunctionField f) := + planeCurveSecondCoordinateRatFuncAlgebra f hy + let : FiniteDimensional (SecondCoordinateSubfield f) + (PlaneCurveFunctionField f) := + (finiteSeparable_over_secondCoordinate_of_irreducible + hf hpartialFirst).1 + exact Module.Finite.of_equiv_equiv + (RatFunc.algEquivOfTranscendental + (planeCurveFunction f 1) hy).symm.toRingEquiv + (RingEquiv.refl (PlaneCurveFunctionField f)) + (planeCurve_secondCoordinate_changeBase_commutes hy) + +/-- The second-coordinate change of base transports separability. -/ +theorem separable_planeCurveFunctionField_over_secondRatFunc + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) : + letI := planeCurveCoordinateRing_isDomain hf + let hy := secondCoordinate_transcendental hf + (degreeOf_first_pos_of_pderiv_ne_zero hpartialFirst) + letI := planeCurveSecondCoordinateRatFuncAlgebra f hy + Algebra.IsSeparable (RatFunc K) (PlaneCurveFunctionField f) := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let hy := secondCoordinate_transcendental hf + (degreeOf_first_pos_of_pderiv_ne_zero hpartialFirst) + let : Algebra (RatFunc K) (PlaneCurveFunctionField f) := + planeCurveSecondCoordinateRatFuncAlgebra f hy + let : Algebra.IsSeparable (SecondCoordinateSubfield f) + (PlaneCurveFunctionField f) := + (finiteSeparable_over_secondCoordinate_of_irreducible + hf hpartialFirst).2 + exact Algebra.IsSeparable.of_equiv_equiv + (RatFunc.algEquivOfTranscendental + (planeCurveFunction f 1) hy).symm.toRingEquiv + (RingEquiv.refl (PlaneCurveFunctionField f)) + (planeCurve_secondCoordinate_changeBase_commutes hy) + +/-- In the second-coordinate model the extension degree is exactly the degree +of the equation in the first coordinate. -/ +theorem finrank_planeCurveFunctionField_over_secondRatFunc_eq_degreeOf_first + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) : + letI := planeCurveCoordinateRing_isDomain hf + let hy := secondCoordinate_transcendental hf + (degreeOf_first_pos_of_pderiv_ne_zero hpartialFirst) + letI := planeCurveSecondCoordinateRatFuncAlgebra f hy + Module.finrank (RatFunc K) (PlaneCurveFunctionField f) = + MvPolynomial.degreeOf 0 f := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let hy := secondCoordinate_transcendental hf + (degreeOf_first_pos_of_pderiv_ne_zero hpartialFirst) + let : Algebra (RatFunc K) (PlaneCurveFunctionField f) := + planeCurveSecondCoordinateRatFuncAlgebra f hy + calc + Module.finrank (RatFunc K) (PlaneCurveFunctionField f) = + Module.finrank (SecondCoordinateSubfield f) + (PlaneCurveFunctionField f) := + (Algebra.finrank_eq_of_equiv_equiv + (RatFunc.algEquivOfTranscendental + (planeCurveFunction f 1) hy).symm.toRingEquiv + (RingEquiv.refl (PlaneCurveFunctionField f)) + (planeCurve_secondCoordinate_changeBase_commutes hy)).symm + _ = MvPolynomial.degreeOf 0 f := + finrank_over_secondCoordinate_eq_degreeOf_first_of_irreducible + hf hpartialFirst + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurveSeparability.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurveSeparability.lean new file mode 100644 index 0000000000..9793da472d --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurveSeparability.lean @@ -0,0 +1,829 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveFunctionField +public import Mathlib.FieldTheory.Separable +public import Mathlib.FieldTheory.SeparableDegree +public import Mathlib.RingTheory.Polynomial.GaussLemma +public import Mathlib.RingTheory.AlgebraicIndependent.Adjoin + +/-! +# Separability of a plane-curve coordinate extension + +For an irreducible plane equation whose partial derivative in the second coordinate is nonzero, +this file proves that the function field is a finite separable extension of the field generated by +the first coordinate. The proof passes through the iterated-polynomial presentation and Gauss's +lemma. +-/ + +@[expose] public section + +namespace BGS.CorvajaZannier + +noncomputable section + +variable {K : Type*} [Field K] + +private theorem derivative_optionEquivLeft + {σ : Type*} (p : MvPolynomial (Option σ) K) : + (MvPolynomial.optionEquivLeft K σ p).derivative = + MvPolynomial.optionEquivLeft K σ (MvPolynomial.pderiv none p) := by + classical + induction p using MvPolynomial.induction_on with + | C a => simp + | add p q hp hq => simp [hp, hq] + | mul_X p i hp => + cases i <;> simp_all [MvPolynomial.pderiv_X, mul_comm] + +/-- The iterated-polynomial presentation of an irreducible bivariate polynomial is irreducible. -/ +theorem polynomialInSecondCoordinate_irreducible + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) : + Irreducible (polynomialInSecondCoordinate f) := by + let e := Equiv.optionSubtypeNe (1 : Fin 2) + have hrename : Irreducible (MvPolynomial.rename e.symm f) := by + change Irreducible ((MvPolynomial.renameEquiv K e.symm) f) + exact hf.map (MvPolynomial.renameEquiv K e.symm).toMulEquiv + exact hrename.map (MvPolynomial.optionEquivLeft K {i : Fin 2 // i ≠ 1}).toMulEquiv + +/-- Ordinary differentiation of the iterated-polynomial presentation agrees with taking the +partial derivative in the second affine coordinate. -/ +theorem derivative_polynomialInSecondCoordinate + (f : MvPolynomial (Fin 2) K) : + (polynomialInSecondCoordinate f).derivative = + polynomialInSecondCoordinate (MvPolynomial.pderiv 1 f) := by + let e := Equiv.optionSubtypeNe (1 : Fin 2) + rw [polynomialInSecondCoordinate, polynomialInSecondCoordinate, + derivative_optionEquivLeft] + congr 1 + simpa [e] using MvPolynomial.pderiv_rename e.symm.injective (1 : Fin 2) f + +/-- A nonzero second-coordinate partial derivative remains nonzero after rewriting the equation +as a polynomial in the second coordinate over the first-coordinate polynomial ring. -/ +theorem derivative_polynomialInSecondCoordinate_ne_zero + {f : MvPolynomial (Fin 2) K} (hderiv : MvPolynomial.pderiv 1 f ≠ 0) : + (polynomialInSecondCoordinate f).derivative ≠ 0 := by + rw [derivative_polynomialInSecondCoordinate] + exact polynomialInSecondCoordinate_ne_zero hderiv + +/-- The fraction field of the polynomial coefficient ring in the remaining affine coordinate is +the intermediate field generated by the first coordinate function. -/ +def firstCoordinateFractionEquiv + (f : MvPolynomial (Fin 2) K) [IsDomain (PlaneCurveCoordinateRing f)] + (htrans : Transcendental K (planeCurveFunction f 0)) : + FractionRing (MvPolynomial {i : Fin 2 // i ≠ 1} K) ≃ₐ[K] + FirstCoordinateSubfield f := by + let remaining := {i : Fin 2 // i ≠ 1} + have remaining_value_zero (i : remaining) : i.1 = 0 := by omega + letI : Subsingleton remaining := + ⟨fun i j => Subtype.ext ((remaining_value_zero i).trans (remaining_value_zero j).symm)⟩ + let i0 : remaining := ⟨0, by decide⟩ + have hIndependent : AlgebraicIndependent K + (fun _ : remaining => planeCurveFunction f 0) := by + rw [algebraicIndependent_singleton_iff i0] + exact htrans + have hrange : Set.range (fun _ : remaining => planeCurveFunction f 0) = + ({planeCurveFunction f 0} : Set (PlaneCurveFunctionField f)) := by + ext z + constructor + · rintro ⟨i, rfl⟩ + simp + · intro hz + rw [Set.mem_singleton_iff] at hz + subst z + exact ⟨i0, rfl⟩ + have hfield : + IntermediateField.adjoin K + (Set.range (fun _ : remaining => planeCurveFunction f 0)) = + FirstCoordinateSubfield f := by + rw [hrange] + exact hIndependent.aevalEquivField.trans (IntermediateField.equivOfEq hfield) + +/-- The fraction-field equivalence extends the coefficient evaluation homomorphism. -/ +@[simp] +theorem firstCoordinateFractionEquiv_algebraMap + (f : MvPolynomial (Fin 2) K) [IsDomain (PlaneCurveCoordinateRing f)] + (htrans : Transcendental K (planeCurveFunction f 0)) + (p : MvPolynomial {i : Fin 2 // i ≠ 1} K) : + firstCoordinateFractionEquiv f htrans + (algebraMap (MvPolynomial {i : Fin 2 // i ≠ 1} K) + (FractionRing (MvPolynomial {i : Fin 2 // i ≠ 1} K)) p) = + firstCoordinateCoefficientEval f p := by + apply Subtype.ext + · simp [firstCoordinateFractionEquiv, firstCoordinateCoefficientEval, + firstCoordinateInSubfield] + simpa [MvPolynomial.aeval_def, firstCoordinateInSubfield] using + (MvPolynomial.hom_eval₂ p + (algebraMap K (FirstCoordinateSubfield f)) + (FirstCoordinateSubfield f).val.toRingHom + (fun _ => firstCoordinateInSubfield f)).symm + +/-- An irreducible plane equation with nonzero second partial derivative stays irreducible after +passing to the field generated by the first coordinate and viewing it as a polynomial in the +second coordinate. -/ +theorem polynomialOverFirstCoordinate_irreducible + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hderiv : MvPolynomial.pderiv 1 f ≠ 0) : + letI := planeCurveCoordinateRing_isDomain hf + Irreducible (polynomialOverFirstCoordinate f) := by + let : IsDomain (PlaneCurveCoordinateRing f) := planeCurveCoordinateRing_isDomain hf + let R := MvPolynomial {i : Fin 2 // i ≠ 1} K + let F := FractionRing R + let p := polynomialInSecondCoordinate f + have hsecond : 0 < MvPolynomial.degreeOf 1 f := + degreeOf_second_pos_of_pderiv_ne_zero hderiv + have htrans : Transcendental K (planeCurveFunction f 0) := + firstCoordinate_transcendental hf hsecond + have hpIrreducible : Irreducible p := polynomialInSecondCoordinate_irreducible hf + have hpDerivative : p.derivative ≠ 0 := + derivative_polynomialInSecondCoordinate_ne_zero hderiv + have hpDegree : p.natDegree ≠ 0 := by + intro hdegree + exact hpDerivative (Polynomial.derivative_of_natDegree_zero hdegree) + have hpPrimitive : p.IsPrimitive := hpIrreducible.isPrimitive hpDegree + have hFractionIrreducible : + Irreducible (p.map (algebraMap R F)) := + (hpPrimitive.irreducible_iff_irreducible_map_fraction_map (K := F)).mp hpIrreducible + let e := firstCoordinateFractionEquiv f htrans + have hMappedIrreducible : + Irreducible ((p.map (algebraMap R F)).map e.toRingHom) := + hFractionIrreducible.map (Polynomial.mapEquiv e.toRingEquiv).toMulEquiv + have hmap : e.toRingHom.comp (algebraMap R F) = firstCoordinateCoefficientEval f := by + apply DFunLike.ext _ _ + intro q + exact firstCoordinateFractionEquiv_algebraMap f htrans q + rw [polynomialOverFirstCoordinate_eq_map_polynomialInSecondCoordinate] + simpa only [Polynomial.map_map, hmap] using hMappedIrreducible + +/-- The ordinary derivative of the specialized plane equation is nonzero. -/ +theorem derivative_polynomialOverFirstCoordinate_ne_zero + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hderiv : MvPolynomial.pderiv 1 f ≠ 0) : + letI := planeCurveCoordinateRing_isDomain hf + (polynomialOverFirstCoordinate f).derivative ≠ 0 := by + let : IsDomain (PlaneCurveCoordinateRing f) := planeCurveCoordinateRing_isDomain hf + rw [polynomialOverFirstCoordinate_eq_map_polynomialInSecondCoordinate, + Polynomial.derivative_map] + exact (Polynomial.map_ne_zero_iff + (firstCoordinateCoefficientEval_injective hf + (degreeOf_second_pos_of_pderiv_ne_zero hderiv))).mpr + (derivative_polynomialInSecondCoordinate_ne_zero hderiv) + +/-- The specialized defining polynomial over the first-coordinate field is separable. -/ +theorem polynomialOverFirstCoordinate_separable + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hderiv : MvPolynomial.pderiv 1 f ≠ 0) : + letI := planeCurveCoordinateRing_isDomain hf + (polynomialOverFirstCoordinate f).Separable := by + let : IsDomain (PlaneCurveCoordinateRing f) := planeCurveCoordinateRing_isDomain hf + exact (Polynomial.separable_iff_derivative_ne_zero + (polynomialOverFirstCoordinate_irreducible hf hderiv)).mpr + (derivative_polynomialOverFirstCoordinate_ne_zero hf hderiv) + +/-- The second coordinate function is separable over the field generated by the first +coordinate. -/ +theorem secondCoordinate_isSeparable_over_first + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hderiv : MvPolynomial.pderiv 1 f ≠ 0) : + letI := planeCurveCoordinateRing_isDomain hf + IsSeparable (FirstCoordinateSubfield f) (planeCurveFunction f 1) := by + let : IsDomain (PlaneCurveCoordinateRing f) := planeCurveCoordinateRing_isDomain hf + have hroot : Polynomial.aeval (planeCurveFunction f 1) + (polynomialOverFirstCoordinate f) = 0 := by + simpa [Polynomial.aeval_def] using eval₂_polynomialOverFirstCoordinate_eq_zero f + exact (polynomialOverFirstCoordinate_separable hf hderiv).of_dvd + (minpoly.dvd (FirstCoordinateSubfield f) (planeCurveFunction f 1) hroot) + +/-- The plane-curve function field is a finite separable extension of the field generated by its +first coordinate. -/ +theorem finiteSeparable_over_firstCoordinate_of_irreducible + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hderiv : MvPolynomial.pderiv 1 f ≠ 0) : + letI := planeCurveCoordinateRing_isDomain hf + FiniteDimensional (FirstCoordinateSubfield f) (PlaneCurveFunctionField f) ∧ + Algebra.IsSeparable (FirstCoordinateSubfield f) (PlaneCurveFunctionField f) := by + let : IsDomain (PlaneCurveCoordinateRing f) := planeCurveCoordinateRing_isDomain hf + constructor + · exact finiteDimensional_over_firstCoordinate_of_irreducible hf hderiv + · have hAdjoin : Algebra.IsSeparable (FirstCoordinateSubfield f) + (IntermediateField.adjoin (FirstCoordinateSubfield f) + {planeCurveFunction f 1}) := + (IntermediateField.isSeparable_adjoin_simple_iff_isSeparable + (FirstCoordinateSubfield f) (PlaneCurveFunctionField f)).mpr + (secondCoordinate_isSeparable_over_first hf hderiv) + have hTop : Algebra.IsSeparable (FirstCoordinateSubfield f) + (⊤ : IntermediateField (FirstCoordinateSubfield f) + (PlaneCurveFunctionField f)) := by + rw [← adjoin_secondCoordinate_over_first_eq_top f] + exact hAdjoin + exact (IntermediateField.isSeparable_top + (F := FirstCoordinateSubfield f) (E := PlaneCurveFunctionField f)).mp hTop + +/-- Specialization at the transcendental first coordinate preserves the second-coordinate +degree. -/ +theorem natDegree_polynomialOverFirstCoordinate_eq_degreeOf_second + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hderiv : MvPolynomial.pderiv 1 f ≠ 0) : + letI := planeCurveCoordinateRing_isDomain hf + (polynomialOverFirstCoordinate f).natDegree = MvPolynomial.degreeOf 1 f := by + let : IsDomain (PlaneCurveCoordinateRing f) := planeCurveCoordinateRing_isDomain hf + rw [polynomialOverFirstCoordinate_eq_map_polynomialInSecondCoordinate, + Polynomial.natDegree_map_eq_of_injective + (firstCoordinateCoefficientEval_injective hf + (degreeOf_second_pos_of_pderiv_ne_zero hderiv))] + exact (MvPolynomial.degreeOf_eq_natDegree (1 : Fin 2) f).symm + +/-- The minimal polynomial of the second coordinate has the full second-coordinate degree of the +irreducible plane equation. -/ +theorem natDegree_minpoly_secondCoordinate_eq_degreeOf_second + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hderiv : MvPolynomial.pderiv 1 f ≠ 0) : + letI := planeCurveCoordinateRing_isDomain hf + (minpoly (FirstCoordinateSubfield f) (planeCurveFunction f 1)).natDegree = + MvPolynomial.degreeOf 1 f := by + let : IsDomain (PlaneCurveCoordinateRing f) := planeCurveCoordinateRing_isDomain hf + let p := polynomialOverFirstCoordinate f + have hpIrreducible : Irreducible p := + polynomialOverFirstCoordinate_irreducible hf hderiv + have hroot : Polynomial.aeval (planeCurveFunction f 1) p = 0 := by + simpa [p, Polynomial.aeval_def] using eval₂_polynomialOverFirstCoordinate_eq_zero f + have heq := minpoly.eq_of_irreducible hpIrreducible hroot + calc + (minpoly (FirstCoordinateSubfield f) (planeCurveFunction f 1)).natDegree = + (p * Polynomial.C p.leadingCoeff⁻¹).natDegree := by rw [heq] + _ = p.natDegree := Polynomial.natDegree_mul_C + (inv_ne_zero (Polynomial.leadingCoeff_ne_zero.mpr hpIrreducible.ne_zero)) + _ = MvPolynomial.degreeOf 1 f := + natDegree_polynomialOverFirstCoordinate_eq_degreeOf_second hf hderiv + +/-- The extension degree over the first-coordinate field is exactly the degree of the defining +equation in the second coordinate. -/ +theorem finrank_over_firstCoordinate_eq_degreeOf_second_of_irreducible + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hderiv : MvPolynomial.pderiv 1 f ≠ 0) : + letI := planeCurveCoordinateRing_isDomain hf + Module.finrank (FirstCoordinateSubfield f) (PlaneCurveFunctionField f) = + MvPolynomial.degreeOf 1 f := by + let : IsDomain (PlaneCurveCoordinateRing f) := planeCurveCoordinateRing_isDomain hf + let : FiniteDimensional (FirstCoordinateSubfield f) (PlaneCurveFunctionField f) := + finiteDimensional_over_firstCoordinate_of_irreducible hf hderiv + have halg := secondCoordinate_isAlgebraic_over_first f + (polynomialOverFirstCoordinate_ne_zero_of_irreducible hf + (degreeOf_second_pos_of_pderiv_ne_zero hderiv)) + calc + Module.finrank (FirstCoordinateSubfield f) (PlaneCurveFunctionField f) = + Module.finrank (FirstCoordinateSubfield f) + (⊤ : IntermediateField (FirstCoordinateSubfield f) + (PlaneCurveFunctionField f)) := by rw [IntermediateField.finrank_top'] + _ = Module.finrank (FirstCoordinateSubfield f) + (IntermediateField.adjoin (FirstCoordinateSubfield f) + {planeCurveFunction f 1}) := by + rw [adjoin_secondCoordinate_over_first_eq_top f] + _ = (minpoly (FirstCoordinateSubfield f) (planeCurveFunction f 1)).natDegree := + IntermediateField.adjoin.finrank halg.isIntegral + _ = MvPolynomial.degreeOf 1 f := + natDegree_minpoly_secondCoordinate_eq_degreeOf_second hf hderiv + +/-! ## The coordinate-swapped extension -/ + +/-- Embed a univariate polynomial in the second affine coordinate. -/ +def polynomialInSecondCoordinateOnly (P : Polynomial K) : MvPolynomial (Fin 2) K := + P.sum fun n c => MvPolynomial.C c * MvPolynomial.X 1 ^ n + +theorem eval₂_polynomialInSecondCoordinateOnly + {S : Type*} [CommSemiring S] (P : Polynomial K) (phi : K →+* S) (x y : S) : + MvPolynomial.eval₂ phi ![x, y] (polynomialInSecondCoordinateOnly P) = + P.eval₂ phi y := by + classical + simp [polynomialInSecondCoordinateOnly, Polynomial.sum_def, Polynomial.eval₂_eq_sum] + +theorem polynomialInSecondCoordinateOnly_ne_zero {P : Polynomial K} (hP : P ≠ 0) : + polynomialInSecondCoordinateOnly P ≠ 0 := by + intro hzero + have heval := eval₂_polynomialInSecondCoordinateOnly P Polynomial.C + (0 : Polynomial K) Polynomial.X + rw [hzero, MvPolynomial.eval₂_zero] at heval + apply hP + simpa using heval.symm + +private theorem degreeOf_finset_sum_le_for_second + {R ι : Type*} [CommSemiring R] + (coordinate : Fin 2) (terms : ι → MvPolynomial (Fin 2) R) + (indices : Finset ι) (bound : ℕ) + (hterms : ∀ i ∈ indices, MvPolynomial.degreeOf coordinate (terms i) ≤ bound) : + MvPolynomial.degreeOf coordinate (∑ i ∈ indices, terms i) ≤ bound := by + classical + induction indices using Finset.induction_on with + | empty => simp + | @insert i indices hi ih => + rw [Finset.sum_insert hi] + exact (MvPolynomial.degreeOf_add_le _ _ _).trans + (max_le (hterms i (Finset.mem_insert_self i indices)) + (ih fun j hj => hterms j (Finset.mem_insert_of_mem hj))) + +theorem polynomialInSecondCoordinateOnly_degreeOf_first_le (P : Polynomial K) : + MvPolynomial.degreeOf (0 : Fin 2) (polynomialInSecondCoordinateOnly P) ≤ 0 := by + classical + rw [polynomialInSecondCoordinateOnly, Polynomial.sum_def] + apply degreeOf_finset_sum_le_for_second (0 : Fin 2) _ P.support 0 + intro n _hn + calc + MvPolynomial.degreeOf (0 : Fin 2) + (MvPolynomial.C (P.coeff n) * MvPolynomial.X 1 ^ n) ≤ + MvPolynomial.degreeOf (0 : Fin 2) (MvPolynomial.C (P.coeff n)) + + MvPolynomial.degreeOf (0 : Fin 2) (MvPolynomial.X 1 ^ n) := + MvPolynomial.degreeOf_mul_le _ _ _ + _ ≤ 0 := by + have hpow : MvPolynomial.degreeOf (0 : Fin 2) + (MvPolynomial.X 1 ^ n : MvPolynomial (Fin 2) K) ≤ 0 := by + calc + _ ≤ n * MvPolynomial.degreeOf (0 : Fin 2) (MvPolynomial.X 1) := + MvPolynomial.degreeOf_pow_le _ _ _ + _ = 0 := by rw [MvPolynomial.degreeOf_X]; norm_num + rw [MvPolynomial.degreeOf_C] + simpa using hpow + +/-- Positive degree in the first coordinate makes the second coordinate function +transcendental. -/ +theorem secondCoordinate_transcendental + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hfirst : 0 < MvPolynomial.degreeOf 0 f) : + letI := planeCurveCoordinateRing_isDomain hf + Transcendental K (planeCurveFunction f 1) := by + let : IsDomain (PlaneCurveCoordinateRing f) := planeCurveCoordinateRing_isDomain hf + rw [transcendental_iff] + intro P hPzero + by_contra hP + have hembedded : polynomialInSecondCoordinateOnly P ≠ 0 := + polynomialInSecondCoordinateOnly_ne_zero hP + have hquotient : planeCurveQuotientMap f (polynomialInSecondCoordinateOnly P) = 0 := by + apply IsFractionRing.injective (PlaneCurveCoordinateRing f) (PlaneCurveFunctionField f) + rw [map_zero] + change + ((algebraMap (PlaneCurveCoordinateRing f) (PlaneCurveFunctionField f)).comp + (planeCurveQuotientMap f)) (polynomialInSecondCoordinateOnly P) = 0 + rw [← eval₂_planeCurveFunction f] + have hcoordinates : planeCurveFunction f = + ![planeCurveFunction f 0, planeCurveFunction f 1] := by + funext i + fin_cases i <;> rfl + rw [hcoordinates] + change MvPolynomial.eval₂ (algebraMap K (PlaneCurveFunctionField f)) + ![planeCurveFunction f 0, planeCurveFunction f 1] + (polynomialInSecondCoordinateOnly P) = 0 + rw [eval₂_polynomialInSecondCoordinateOnly] + simpa [Polynomial.aeval_def] using hPzero + have hdvd : f ∣ polynomialInSecondCoordinateOnly P := + Ideal.mem_span_singleton.mp (Ideal.Quotient.eq_zero_iff_mem.mp hquotient) + obtain ⟨g, hg⟩ := hdvd + have hgzero : g ≠ 0 := by + intro hzero + apply hembedded + rw [hg, hzero, mul_zero] + have hdegree : MvPolynomial.degreeOf 0 f ≤ + MvPolynomial.degreeOf 0 (polynomialInSecondCoordinateOnly P) := by + rw [hg, MvPolynomial.degreeOf_mul_eq hf.ne_zero hgzero] + exact Nat.le_add_right _ _ + have hzeroDegree := polynomialInSecondCoordinateOnly_degreeOf_first_le P + omega + +/-- The intermediate field generated by the second coordinate function. -/ +abbrev SecondCoordinateSubfield + (f : MvPolynomial (Fin 2) K) [IsDomain (PlaneCurveCoordinateRing f)] := + IntermediateField.adjoin K ({planeCurveFunction f 1} : Set (PlaneCurveFunctionField f)) + +def secondCoordinateInSubfield + (f : MvPolynomial (Fin 2) K) [IsDomain (PlaneCurveCoordinateRing f)] : + SecondCoordinateSubfield f := + ⟨planeCurveFunction f 1, + IntermediateField.mem_adjoin_simple_self K (planeCurveFunction f 1)⟩ + +/-- Regard the plane equation as a polynomial in the first coordinate, with coefficients in the +field generated by the second coordinate. -/ +def polynomialOverSecondCoordinate + (f : MvPolynomial (Fin 2) K) [IsDomain (PlaneCurveCoordinateRing f)] : + Polynomial (SecondCoordinateSubfield f) := + MvPolynomial.eval₂ (algebraMap K (Polynomial (SecondCoordinateSubfield f))) + ![Polynomial.X, Polynomial.C (secondCoordinateInSubfield f)] f + +/-- Iterated-polynomial presentation with the original first coordinate as outer variable. -/ +def polynomialInFirstVariablePresentation (f : MvPolynomial (Fin 2) K) : + Polynomial (MvPolynomial {i : Fin 2 // i ≠ 0} K) := + MvPolynomial.optionEquivLeft K {i : Fin 2 // i ≠ 0} + (MvPolynomial.rename (Equiv.optionSubtypeNe (0 : Fin 2)).symm f) + +theorem polynomialInFirstVariablePresentation_ne_zero + {f : MvPolynomial (Fin 2) K} (hf : f ≠ 0) : + polynomialInFirstVariablePresentation f ≠ 0 := by + intro hzero + apply hf + apply MvPolynomial.rename_injective + (Equiv.optionSubtypeNe (0 : Fin 2)).symm + (Equiv.optionSubtypeNe (0 : Fin 2)).symm.injective + apply (MvPolynomial.optionEquivLeft K {i : Fin 2 // i ≠ 0}).injective + simpa [polynomialInFirstVariablePresentation] using hzero + +def secondCoordinateCoefficientEval + (f : MvPolynomial (Fin 2) K) [IsDomain (PlaneCurveCoordinateRing f)] : + MvPolynomial {i : Fin 2 // i ≠ 0} K →+* SecondCoordinateSubfield f := + MvPolynomial.eval₂Hom (algebraMap K (SecondCoordinateSubfield f)) + (fun _ => secondCoordinateInSubfield f) + +theorem secondCoordinateCoefficientEval_injective + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hfirst : 0 < MvPolynomial.degreeOf 0 f) : + letI := planeCurveCoordinateRing_isDomain hf + Function.Injective (secondCoordinateCoefficientEval f) := by + let : IsDomain (PlaneCurveCoordinateRing f) := planeCurveCoordinateRing_isDomain hf + let remaining := {i : Fin 2 // i ≠ 0} + have remaining_value_one (i : remaining) : i.1 = 1 := by omega + let : Subsingleton remaining := + ⟨fun i j => Subtype.ext ((remaining_value_one i).trans (remaining_value_one j).symm)⟩ + let i1 : remaining := ⟨1, by decide⟩ + have hIndependent : AlgebraicIndependent K + (fun _ : remaining => planeCurveFunction f 1) := by + rw [algebraicIndependent_singleton_iff i1] + exact secondCoordinate_transcendental hf hfirst + let composed : MvPolynomial remaining K →+* PlaneCurveFunctionField f := + (algebraMap (SecondCoordinateSubfield f) (PlaneCurveFunctionField f)).comp + (secondCoordinateCoefficientEval f) + let evaluated : MvPolynomial remaining K →+* PlaneCurveFunctionField f := + MvPolynomial.eval₂Hom (algebraMap K (PlaneCurveFunctionField f)) + (fun _ => planeCurveFunction f 1) + have hhom : composed = evaluated := by + apply MvPolynomial.ringHom_ext + · intro c + simp [composed, evaluated, secondCoordinateCoefficientEval] + · intro i + simp [composed, evaluated, secondCoordinateCoefficientEval, + secondCoordinateInSubfield] + intro a b hab + apply (algebraicIndependent_iff_injective_aeval.mp hIndependent) + change evaluated a = evaluated b + rw [← hhom] + exact congrArg (algebraMap (SecondCoordinateSubfield f) (PlaneCurveFunctionField f)) hab + +theorem polynomialOverSecondCoordinate_eq_map_polynomialInFirstVariablePresentation + (f : MvPolynomial (Fin 2) K) [IsDomain (PlaneCurveCoordinateRing f)] : + polynomialOverSecondCoordinate f = + (polynomialInFirstVariablePresentation f).map (secondCoordinateCoefficientEval f) := by + let lhs : MvPolynomial (Fin 2) K →+* Polynomial (SecondCoordinateSubfield f) := + MvPolynomial.eval₂Hom (algebraMap K (Polynomial (SecondCoordinateSubfield f))) + ![Polynomial.X, Polynomial.C (secondCoordinateInSubfield f)] + let rhs : MvPolynomial (Fin 2) K →+* Polynomial (SecondCoordinateSubfield f) := + (Polynomial.mapRingHom (secondCoordinateCoefficientEval f)).comp + ((MvPolynomial.optionEquivLeft K {i : Fin 2 // i ≠ 0}).toRingEquiv.toRingHom.comp + (MvPolynomial.rename (Equiv.optionSubtypeNe (0 : Fin 2)).symm).toRingHom) + change lhs f = rhs f + congr 1 + apply MvPolynomial.ringHom_ext + · intro c + simp [lhs, rhs, secondCoordinateCoefficientEval] + · intro i + fin_cases i <;> + simp [lhs, rhs, secondCoordinateCoefficientEval, secondCoordinateInSubfield] + +theorem polynomialInFirstVariablePresentation_irreducible + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) : + Irreducible (polynomialInFirstVariablePresentation f) := by + let e := Equiv.optionSubtypeNe (0 : Fin 2) + have hrename : Irreducible (MvPolynomial.rename e.symm f) := by + change Irreducible ((MvPolynomial.renameEquiv K e.symm) f) + exact hf.map (MvPolynomial.renameEquiv K e.symm).toMulEquiv + exact hrename.map (MvPolynomial.optionEquivLeft K {i : Fin 2 // i ≠ 0}).toMulEquiv + +theorem derivative_polynomialInFirstVariablePresentation + (f : MvPolynomial (Fin 2) K) : + (polynomialInFirstVariablePresentation f).derivative = + polynomialInFirstVariablePresentation (MvPolynomial.pderiv 0 f) := by + let e := Equiv.optionSubtypeNe (0 : Fin 2) + rw [polynomialInFirstVariablePresentation, polynomialInFirstVariablePresentation, + derivative_optionEquivLeft] + congr 1 + simpa [e] using MvPolynomial.pderiv_rename e.symm.injective (0 : Fin 2) f + +theorem derivative_polynomialInFirstVariablePresentation_ne_zero + {f : MvPolynomial (Fin 2) K} (hderiv : MvPolynomial.pderiv 0 f ≠ 0) : + (polynomialInFirstVariablePresentation f).derivative ≠ 0 := by + rw [derivative_polynomialInFirstVariablePresentation] + exact polynomialInFirstVariablePresentation_ne_zero hderiv + +theorem degreeOf_first_pos_of_pderiv_ne_zero + {f : MvPolynomial (Fin 2) K} (hderiv : MvPolynomial.pderiv 0 f ≠ 0) : + 0 < MvPolynomial.degreeOf 0 f := by + apply Nat.pos_of_ne_zero + apply MvPolynomial.mem_vars_iff_degreeOf_ne_zero.mp + by_contra hmem + exact hderiv (MvPolynomial.pderiv_eq_zero_of_notMem_vars hmem) + +theorem polynomialOverSecondCoordinate_ne_zero_of_irreducible + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hfirst : 0 < MvPolynomial.degreeOf 0 f) : + letI := planeCurveCoordinateRing_isDomain hf + polynomialOverSecondCoordinate f ≠ 0 := by + let : IsDomain (PlaneCurveCoordinateRing f) := planeCurveCoordinateRing_isDomain hf + rw [polynomialOverSecondCoordinate_eq_map_polynomialInFirstVariablePresentation] + exact (Polynomial.map_ne_zero_iff + (secondCoordinateCoefficientEval_injective hf hfirst)).mpr + (polynomialInFirstVariablePresentation_ne_zero hf.ne_zero) + +theorem natDegree_polynomialOverSecondCoordinate_le_degreeOf_first + (f : MvPolynomial (Fin 2) K) [IsDomain (PlaneCurveCoordinateRing f)] : + (polynomialOverSecondCoordinate f).natDegree ≤ MvPolynomial.degreeOf 0 f := by + rw [polynomialOverSecondCoordinate_eq_map_polynomialInFirstVariablePresentation] + calc + ((polynomialInFirstVariablePresentation f).map + (secondCoordinateCoefficientEval f)).natDegree ≤ + (polynomialInFirstVariablePresentation f).natDegree := Polynomial.natDegree_map_le + _ = MvPolynomial.degreeOf 0 f := + (MvPolynomial.degreeOf_eq_natDegree (0 : Fin 2) f).symm + +theorem eval₂_polynomialOverSecondCoordinate_eq_zero + (f : MvPolynomial (Fin 2) K) [IsDomain (PlaneCurveCoordinateRing f)] : + Polynomial.eval₂ + (algebraMap (SecondCoordinateSubfield f) (PlaneCurveFunctionField f)) + (planeCurveFunction f 0) (polynomialOverSecondCoordinate f) = 0 := by + let lhs : MvPolynomial (Fin 2) K →+* PlaneCurveFunctionField f := + (Polynomial.eval₂RingHom + (algebraMap (SecondCoordinateSubfield f) (PlaneCurveFunctionField f)) + (planeCurveFunction f 0)).comp + (MvPolynomial.eval₂Hom + (algebraMap K (Polynomial (SecondCoordinateSubfield f))) + ![Polynomial.X, Polynomial.C (secondCoordinateInSubfield f)]) + let rhs : MvPolynomial (Fin 2) K →+* PlaneCurveFunctionField f := + MvPolynomial.eval₂Hom (algebraMap K (PlaneCurveFunctionField f)) + (planeCurveFunction f) + have hhom : lhs = rhs := by + apply MvPolynomial.ringHom_ext + · intro c + simp [lhs, rhs] + · intro i + fin_cases i <;> + simp [lhs, rhs, secondCoordinateInSubfield] + change lhs f = 0 + rw [hhom] + exact eval₂_planeCurveFunction_eq_zero f + +theorem firstCoordinate_isAlgebraic_over_second + (f : MvPolynomial (Fin 2) K) [IsDomain (PlaneCurveCoordinateRing f)] + (hpoly : polynomialOverSecondCoordinate f ≠ 0) : + IsAlgebraic (SecondCoordinateSubfield f) (planeCurveFunction f 0) := by + refine ⟨polynomialOverSecondCoordinate f, hpoly, ?_⟩ + simpa [Polynomial.aeval_def] using eval₂_polynomialOverSecondCoordinate_eq_zero f + +theorem adjoin_firstCoordinate_over_second_eq_top + (f : MvPolynomial (Fin 2) K) [IsDomain (PlaneCurveCoordinateRing f)] : + IntermediateField.adjoin (SecondCoordinateSubfield f) {planeCurveFunction f 0} = ⊤ := by + have hpair : + IntermediateField.adjoin K + ({planeCurveFunction f 1, planeCurveFunction f 0} : + Set (PlaneCurveFunctionField f)) = ⊤ := by + have horiginal : + IntermediateField.adjoin K + ({planeCurveFunction f 0, planeCurveFunction f 1} : + Set (PlaneCurveFunctionField f)) = ⊤ := by + rw [← range_planeCurveFunction f] + exact adjoin_planeCurveFunctions_eq_top + simpa [Set.pair_comm] using horiginal + apply IntermediateField.restrictScalars_injective K + rw [IntermediateField.restrictScalars_top] + change + (IntermediateField.adjoin + (IntermediateField.adjoin K {planeCurveFunction f 1}) + {planeCurveFunction f 0}).restrictScalars K = ⊤ + rw [IntermediateField.adjoin_adjoin_left] + simpa only [Set.singleton_union] using hpair + +theorem finiteDimensional_over_secondCoordinate + (f : MvPolynomial (Fin 2) K) [IsDomain (PlaneCurveCoordinateRing f)] + (hpoly : polynomialOverSecondCoordinate f ≠ 0) : + FiniteDimensional (SecondCoordinateSubfield f) (PlaneCurveFunctionField f) := by + have halg := firstCoordinate_isAlgebraic_over_second f hpoly + let : FiniteDimensional (SecondCoordinateSubfield f) + (IntermediateField.adjoin (SecondCoordinateSubfield f) {planeCurveFunction f 0}) := + IntermediateField.adjoin.finiteDimensional halg.isIntegral + let : FiniteDimensional (SecondCoordinateSubfield f) + (⊤ : IntermediateField (SecondCoordinateSubfield f) (PlaneCurveFunctionField f)) := by + rw [← adjoin_firstCoordinate_over_second_eq_top f] + infer_instance + exact IntermediateField.topEquiv.toLinearEquiv.finiteDimensional + +/-- The fraction field of the coefficient polynomial ring in the second affine coordinate is the +field generated by that coordinate function. -/ +def secondCoordinateFractionEquiv + (f : MvPolynomial (Fin 2) K) [IsDomain (PlaneCurveCoordinateRing f)] + (htrans : Transcendental K (planeCurveFunction f 1)) : + FractionRing (MvPolynomial {i : Fin 2 // i ≠ 0} K) ≃ₐ[K] + SecondCoordinateSubfield f := by + let remaining := {i : Fin 2 // i ≠ 0} + have remaining_value_one (i : remaining) : i.1 = 1 := by omega + letI : Subsingleton remaining := + ⟨fun i j => Subtype.ext ((remaining_value_one i).trans (remaining_value_one j).symm)⟩ + let i1 : remaining := ⟨1, by decide⟩ + have hIndependent : AlgebraicIndependent K + (fun _ : remaining => planeCurveFunction f 1) := by + rw [algebraicIndependent_singleton_iff i1] + exact htrans + have hrange : Set.range (fun _ : remaining => planeCurveFunction f 1) = + ({planeCurveFunction f 1} : Set (PlaneCurveFunctionField f)) := by + ext z + constructor + · rintro ⟨i, rfl⟩ + simp + · intro hz + rw [Set.mem_singleton_iff] at hz + subst z + exact ⟨i1, rfl⟩ + have hfield : + IntermediateField.adjoin K + (Set.range (fun _ : remaining => planeCurveFunction f 1)) = + SecondCoordinateSubfield f := by + rw [hrange] + exact hIndependent.aevalEquivField.trans (IntermediateField.equivOfEq hfield) + +/-- The second-coordinate fraction-field equivalence extends coefficient evaluation. -/ +@[simp] +theorem secondCoordinateFractionEquiv_algebraMap + (f : MvPolynomial (Fin 2) K) [IsDomain (PlaneCurveCoordinateRing f)] + (htrans : Transcendental K (planeCurveFunction f 1)) + (p : MvPolynomial {i : Fin 2 // i ≠ 0} K) : + secondCoordinateFractionEquiv f htrans + (algebraMap (MvPolynomial {i : Fin 2 // i ≠ 0} K) + (FractionRing (MvPolynomial {i : Fin 2 // i ≠ 0} K)) p) = + secondCoordinateCoefficientEval f p := by + apply Subtype.ext + · simp [secondCoordinateFractionEquiv, secondCoordinateCoefficientEval, + secondCoordinateInSubfield] + simpa [MvPolynomial.aeval_def, secondCoordinateInSubfield] using + (MvPolynomial.hom_eval₂ p + (algebraMap K (SecondCoordinateSubfield f)) + (SecondCoordinateSubfield f).val.toRingHom + (fun _ => secondCoordinateInSubfield f)).symm + +/-- The plane equation remains irreducible over the field generated by the second coordinate when +viewed as a polynomial in the first coordinate. -/ +theorem polynomialOverSecondCoordinate_irreducible + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hderiv : MvPolynomial.pderiv 0 f ≠ 0) : + letI := planeCurveCoordinateRing_isDomain hf + Irreducible (polynomialOverSecondCoordinate f) := by + let : IsDomain (PlaneCurveCoordinateRing f) := planeCurveCoordinateRing_isDomain hf + let R := MvPolynomial {i : Fin 2 // i ≠ 0} K + let F := FractionRing R + let p := polynomialInFirstVariablePresentation f + have hfirst : 0 < MvPolynomial.degreeOf 0 f := + degreeOf_first_pos_of_pderiv_ne_zero hderiv + have htrans : Transcendental K (planeCurveFunction f 1) := + secondCoordinate_transcendental hf hfirst + have hpIrreducible : Irreducible p := polynomialInFirstVariablePresentation_irreducible hf + have hpDerivative : p.derivative ≠ 0 := + derivative_polynomialInFirstVariablePresentation_ne_zero hderiv + have hpDegree : p.natDegree ≠ 0 := by + intro hdegree + exact hpDerivative (Polynomial.derivative_of_natDegree_zero hdegree) + have hpPrimitive : p.IsPrimitive := hpIrreducible.isPrimitive hpDegree + have hFractionIrreducible : Irreducible (p.map (algebraMap R F)) := + (hpPrimitive.irreducible_iff_irreducible_map_fraction_map (K := F)).mp hpIrreducible + let e := secondCoordinateFractionEquiv f htrans + have hMappedIrreducible : + Irreducible ((p.map (algebraMap R F)).map e.toRingHom) := + hFractionIrreducible.map (Polynomial.mapEquiv e.toRingEquiv).toMulEquiv + have hmap : e.toRingHom.comp (algebraMap R F) = secondCoordinateCoefficientEval f := by + apply DFunLike.ext _ _ + intro q + exact secondCoordinateFractionEquiv_algebraMap f htrans q + rw [polynomialOverSecondCoordinate_eq_map_polynomialInFirstVariablePresentation] + simpa only [Polynomial.map_map, hmap] using hMappedIrreducible + +theorem derivative_polynomialOverSecondCoordinate_ne_zero + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hderiv : MvPolynomial.pderiv 0 f ≠ 0) : + letI := planeCurveCoordinateRing_isDomain hf + (polynomialOverSecondCoordinate f).derivative ≠ 0 := by + let : IsDomain (PlaneCurveCoordinateRing f) := planeCurveCoordinateRing_isDomain hf + rw [polynomialOverSecondCoordinate_eq_map_polynomialInFirstVariablePresentation, + Polynomial.derivative_map] + exact (Polynomial.map_ne_zero_iff + (secondCoordinateCoefficientEval_injective hf + (degreeOf_first_pos_of_pderiv_ne_zero hderiv))).mpr + (derivative_polynomialInFirstVariablePresentation_ne_zero hderiv) + +theorem polynomialOverSecondCoordinate_separable + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hderiv : MvPolynomial.pderiv 0 f ≠ 0) : + letI := planeCurveCoordinateRing_isDomain hf + (polynomialOverSecondCoordinate f).Separable := by + let : IsDomain (PlaneCurveCoordinateRing f) := planeCurveCoordinateRing_isDomain hf + exact (Polynomial.separable_iff_derivative_ne_zero + (polynomialOverSecondCoordinate_irreducible hf hderiv)).mpr + (derivative_polynomialOverSecondCoordinate_ne_zero hf hderiv) + +/-- The first coordinate is separable over the field generated by the second coordinate. -/ +theorem firstCoordinate_isSeparable_over_second + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hderiv : MvPolynomial.pderiv 0 f ≠ 0) : + letI := planeCurveCoordinateRing_isDomain hf + IsSeparable (SecondCoordinateSubfield f) (planeCurveFunction f 0) := by + let : IsDomain (PlaneCurveCoordinateRing f) := planeCurveCoordinateRing_isDomain hf + have hroot : Polynomial.aeval (planeCurveFunction f 0) + (polynomialOverSecondCoordinate f) = 0 := by + simpa [Polynomial.aeval_def] using eval₂_polynomialOverSecondCoordinate_eq_zero f + exact (polynomialOverSecondCoordinate_separable hf hderiv).of_dvd + (minpoly.dvd (SecondCoordinateSubfield f) (planeCurveFunction f 0) hroot) + +/-- The plane-curve function field is finite and separable over the field generated by its second +coordinate. -/ +theorem finiteSeparable_over_secondCoordinate_of_irreducible + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hderiv : MvPolynomial.pderiv 0 f ≠ 0) : + letI := planeCurveCoordinateRing_isDomain hf + FiniteDimensional (SecondCoordinateSubfield f) (PlaneCurveFunctionField f) ∧ + Algebra.IsSeparable (SecondCoordinateSubfield f) (PlaneCurveFunctionField f) := by + let : IsDomain (PlaneCurveCoordinateRing f) := planeCurveCoordinateRing_isDomain hf + have hpoly : polynomialOverSecondCoordinate f ≠ 0 := + polynomialOverSecondCoordinate_ne_zero_of_irreducible hf + (degreeOf_first_pos_of_pderiv_ne_zero hderiv) + constructor + · exact finiteDimensional_over_secondCoordinate f hpoly + · have hAdjoin : Algebra.IsSeparable (SecondCoordinateSubfield f) + (IntermediateField.adjoin (SecondCoordinateSubfield f) + {planeCurveFunction f 0}) := + (IntermediateField.isSeparable_adjoin_simple_iff_isSeparable + (SecondCoordinateSubfield f) (PlaneCurveFunctionField f)).mpr + (firstCoordinate_isSeparable_over_second hf hderiv) + have hTop : Algebra.IsSeparable (SecondCoordinateSubfield f) + (⊤ : IntermediateField (SecondCoordinateSubfield f) + (PlaneCurveFunctionField f)) := by + rw [← adjoin_firstCoordinate_over_second_eq_top f] + exact hAdjoin + exact (IntermediateField.isSeparable_top + (F := SecondCoordinateSubfield f) (E := PlaneCurveFunctionField f)).mp hTop + +theorem natDegree_polynomialOverSecondCoordinate_eq_degreeOf_first + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hderiv : MvPolynomial.pderiv 0 f ≠ 0) : + letI := planeCurveCoordinateRing_isDomain hf + (polynomialOverSecondCoordinate f).natDegree = MvPolynomial.degreeOf 0 f := by + let : IsDomain (PlaneCurveCoordinateRing f) := planeCurveCoordinateRing_isDomain hf + rw [polynomialOverSecondCoordinate_eq_map_polynomialInFirstVariablePresentation, + Polynomial.natDegree_map_eq_of_injective + (secondCoordinateCoefficientEval_injective hf + (degreeOf_first_pos_of_pderiv_ne_zero hderiv))] + exact (MvPolynomial.degreeOf_eq_natDegree (0 : Fin 2) f).symm + +theorem natDegree_minpoly_firstCoordinate_eq_degreeOf_first + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hderiv : MvPolynomial.pderiv 0 f ≠ 0) : + letI := planeCurveCoordinateRing_isDomain hf + (minpoly (SecondCoordinateSubfield f) (planeCurveFunction f 0)).natDegree = + MvPolynomial.degreeOf 0 f := by + let : IsDomain (PlaneCurveCoordinateRing f) := planeCurveCoordinateRing_isDomain hf + let p := polynomialOverSecondCoordinate f + have hpIrreducible : Irreducible p := polynomialOverSecondCoordinate_irreducible hf hderiv + have hroot : Polynomial.aeval (planeCurveFunction f 0) p = 0 := by + simpa [p, Polynomial.aeval_def] using eval₂_polynomialOverSecondCoordinate_eq_zero f + have heq := minpoly.eq_of_irreducible hpIrreducible hroot + calc + (minpoly (SecondCoordinateSubfield f) (planeCurveFunction f 0)).natDegree = + (p * Polynomial.C p.leadingCoeff⁻¹).natDegree := by rw [heq] + _ = p.natDegree := Polynomial.natDegree_mul_C + (inv_ne_zero (Polynomial.leadingCoeff_ne_zero.mpr hpIrreducible.ne_zero)) + _ = MvPolynomial.degreeOf 0 f := + natDegree_polynomialOverSecondCoordinate_eq_degreeOf_first hf hderiv + +/-- The extension degree over the second-coordinate field is the first-coordinate degree of the +plane equation. -/ +theorem finrank_over_secondCoordinate_eq_degreeOf_first_of_irreducible + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hderiv : MvPolynomial.pderiv 0 f ≠ 0) : + letI := planeCurveCoordinateRing_isDomain hf + Module.finrank (SecondCoordinateSubfield f) (PlaneCurveFunctionField f) = + MvPolynomial.degreeOf 0 f := by + let : IsDomain (PlaneCurveCoordinateRing f) := planeCurveCoordinateRing_isDomain hf + have hpoly : polynomialOverSecondCoordinate f ≠ 0 := + polynomialOverSecondCoordinate_ne_zero_of_irreducible hf + (degreeOf_first_pos_of_pderiv_ne_zero hderiv) + let : FiniteDimensional (SecondCoordinateSubfield f) (PlaneCurveFunctionField f) := + finiteDimensional_over_secondCoordinate f hpoly + have halg := firstCoordinate_isAlgebraic_over_second f hpoly + calc + Module.finrank (SecondCoordinateSubfield f) (PlaneCurveFunctionField f) = + Module.finrank (SecondCoordinateSubfield f) + (⊤ : IntermediateField (SecondCoordinateSubfield f) + (PlaneCurveFunctionField f)) := by rw [IntermediateField.finrank_top'] + _ = Module.finrank (SecondCoordinateSubfield f) + (IntermediateField.adjoin (SecondCoordinateSubfield f) + {planeCurveFunction f 0}) := by + rw [adjoin_firstCoordinate_over_second_eq_top f] + _ = (minpoly (SecondCoordinateSubfield f) (planeCurveFunction f 0)).natDegree := + IntermediateField.adjoin.finrank halg.isIntegral + _ = MvPolynomial.degreeOf 0 f := + natDegree_minpoly_firstCoordinate_eq_degreeOf_first hf hderiv + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurveSharedOriginBoundary.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurveSharedOriginBoundary.lean new file mode 100644 index 0000000000..6833fe5be3 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurveSharedOriginBoundary.lean @@ -0,0 +1,271 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveCanonicalEulerBound +public import LeanPool.MarkoffModP.BGS.HasseWeil.AffinePointPlace +public import Mathlib.Tactic + +/-! +# Saving one boundary degree at a shared affine origin + +The degree-only plane-curve estimate bounds the zero/pole support of the two +coordinate functions by adding their two support degrees. If the curve +contains the affine origin, the finite place selected above that point lies +in both supports. Since every place has positive degree, the union estimate +saves at least one. + +This argument does not assert that a branch above an arbitrary singular +rational point has residue degree one. Positivity of the selected place +degree is sufficient for the one-unit saving. +-/ + +@[expose] public section + +open scoped Polynomial BigOperators + +namespace BGS.CorvajaZannier + +noncomputable section + +private theorem sum_union_add_weight_le_sum_add_sum + {ι : Type*} [DecidableEq ι] (s t : Finset ι) (g : ι → ℕ) + {q : ι} (hqs : q ∈ s) (hqt : q ∈ t) : + (∑ i ∈ s ∪ t, g i) + g q ≤ + (∑ i ∈ s, g i) + ∑ i ∈ t, g i := by + have hdisjoint : Disjoint (t \ s) {q} := by + rw [Finset.disjoint_singleton_right] + intro hq + exact (Finset.mem_sdiff.mp hq).2 hqs + have hsubset : (t \ s) ∪ {q} ⊆ t := by + intro i hi + rcases Finset.mem_union.mp hi with hi | hi + · exact (Finset.mem_sdiff.mp hi).1 + · rw [Finset.mem_singleton] at hi + simpa [hi] using hqt + have hremaining : + (∑ i ∈ t \ s, g i) + g q ≤ ∑ i ∈ t, g i := by + have hsum : + (∑ i ∈ (t \ s) ∪ {q}, g i) ≤ ∑ i ∈ t, g i := + Finset.sum_le_sum_of_subset hsubset + rw [Finset.sum_union hdisjoint] at hsum + simpa using hsum + calc + (∑ i ∈ s ∪ t, g i) + g q = + ((∑ i ∈ s, g i) + ∑ i ∈ t \ s, g i) + g q := by + rw [show s ∪ t = s ∪ (t \ s) by ext i; simp, + Finset.sum_union Finset.disjoint_sdiff] + _ = (∑ i ∈ s, g i) + ((∑ i ∈ t \ s, g i) + g q) := by + omega + _ ≤ (∑ i ∈ s, g i) + ∑ i ∈ t, g i := + Nat.add_le_add_left hremaining _ + +variable {K : Type*} [Field K] [Fintype K] [DecidableEq K] + [DecidableEq (RatFunc K)] + +/-- If an irreducible plane curve contains the affine origin, then the +zero/pole boundary of positive powers of its two coordinate functions saves +one degree compared with the disjoint-support estimate. -/ +theorem planeCurve_propositionTwoExceptionalPlaces_weightedDegree_add_one_le + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (origin : AffinePlaneCurvePoint f) + (horiginFirst : origin.1.1 = 0) + (horiginSecond : origin.1.2 = 0) + (m n : ℕ) (hm : 0 < m) (hn : 0 < n) : + letI := planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + letI := planeCurveFirstCoordinateRatFuncAlgebra f hx + letI := finiteDimensional_planeCurveFunctionField_over_ratFunc + hf hpartialSecond + letI := separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + (∑ w ∈ propositionTwoExceptionalPlaces K (PlaneCurveFunctionField f) + ((planeCurveFunction f 0) ^ m) ((planeCurveFunction f 1) ^ n), + finiteExtensionPlaceDegree K (PlaneCurveFunctionField f) w) + 1 ≤ + 2 * (MvPolynomial.degreeOf 0 f + MvPolynomial.degreeOf 1 f) := by + classical + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let L := PlaneCurveFunctionField f + let x : L := planeCurveFunction f 0 + let y : L := planeCurveFunction f 1 + have hxTrans : Transcendental K x := + firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + have hyTrans : Transcendental K y := + secondCoordinate_transcendental hf + (degreeOf_first_pos_of_pderiv_ne_zero hpartialFirst) + have hx0 : x ≠ 0 := by + intro h + apply hxTrans + rw [h] + exact isAlgebraic_zero + have hy0 : y ≠ 0 := by + intro h + apply hyTrans + rw [h] + exact isAlgebraic_zero + let : Algebra (RatFunc K) L := + planeCurveFirstCoordinateRatFuncAlgebra f hxTrans + let : FiniteDimensional (RatFunc K) L := + finiteDimensional_planeCurveFunctionField_over_ratFunc + hf hpartialSecond + let : Algebra.IsSeparable (RatFunc K) L := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : Algebra (Polynomial K) L := + RingHom.toAlgebra + ((algebraMap (RatFunc K) L).comp + (algebraMap (Polynomial K) (RatFunc K))) + let : IsScalarTower (Polynomial K) (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + let q : FiniteExtensionFinitePlace K L := + BGS.HasseWeil.affinePointExhaustiveFinitePlace + hf hpartialFirst hpartialSecond origin + have hqSpec := + BGS.HasseWeil.affinePointExhaustiveFinitePlace_spec + hf hpartialFirst hpartialSecond origin + have hqx : 0 < finitePlaceOrder q x := by + simpa only [q, x, horiginFirst, map_zero, sub_zero] using hqSpec.2.1 + have hqy : 0 < finitePlaceOrder q y := by + simpa only [q, y, horiginSecond, map_zero, sub_zero] using hqSpec.2.2 + have hxDegree : finiteExtensionPositiveDegree K L x = + MvPolynomial.degreeOf 1 f := by + have hheight := finiteExtensionPositiveDegree_polynomial + K L Polynomial.X Polynomial.X_ne_zero + have hmap : algebraMap (RatFunc K) L + (algebraMap K[X] (RatFunc K) Polynomial.X) = x := by + change ratFuncSpecialization x hxTrans RatFunc.X = x + exact planeCurveFirstCoordinateRatFuncAlgebra_X f hxTrans + rw [hmap, + finrank_planeCurveFunctionField_over_ratFunc_eq_degreeOf_second + hf hpartialSecond] at hheight + simpa using hheight + have hyDegree : finiteExtensionPositiveDegree K L y ≤ + MvPolynomial.degreeOf 0 f := + finiteExtensionPositiveDegree_planeCurveSecondCoordinate_le_degreeOf_first + hf hpartialFirst hpartialSecond + have hsupportX : + (finiteExtensionPrincipalDivisor K L (x ^ m)).support = + (finiteExtensionPrincipalDivisor K L x).support := by + rw [finiteExtensionPrincipalDivisor_pow K L x hx0 m] + ext w + simp [Finsupp.mem_support_iff, hm.ne'] + have hsupportY : + (finiteExtensionPrincipalDivisor K L (y ^ n)).support = + (finiteExtensionPrincipalDivisor K L y).support := by + rw [finiteExtensionPrincipalDivisor_pow K L y hy0 n] + ext w + simp [Finsupp.mem_support_iff, hn.ne'] + let v : FiniteExtensionPlace K L := .inl q + let s := (finiteExtensionPrincipalDivisor K L x).support + let t := (finiteExtensionPrincipalDivisor K L y).support + let degree : FiniteExtensionPlace K L → ℕ := + finiteExtensionPlaceDegree K L + have hvs : v ∈ s := by + dsimp only [s, v] + rw [Finsupp.mem_support_iff, + finiteExtensionPrincipalDivisor_inl_eq_finitePlaceOrder] + omega + have hvt : v ∈ t := by + dsimp only [t, v] + rw [Finsupp.mem_support_iff, + finiteExtensionPrincipalDivisor_inl_eq_finitePlaceOrder] + omega + have hvDegree : 1 ≤ degree v := by + dsimp only [degree, v] + exact finiteExtensionPlaceDegree_inl_pos K L q + have hoverlap : + (∑ w ∈ s ∪ t, degree w) + degree v ≤ + (∑ w ∈ s, degree w) + ∑ w ∈ t, degree w := + sum_union_add_weight_le_sum_add_sum s t degree hvs hvt + have hsupportSum : + (∑ w ∈ s, degree w) + ∑ w ∈ t, degree w ≤ + 2 * (MvPolynomial.degreeOf 0 f + MvPolynomial.degreeOf 1 f) := by + have hxSupport : + (∑ w ∈ s, degree w) ≤ + 2 * finiteExtensionPositiveDegree K L x := by + exact finiteExtensionPrincipalDivisor_supportDegree_le_two_mul_height + K L x hx0 + have hySupport : + (∑ w ∈ t, degree w) ≤ + 2 * finiteExtensionPositiveDegree K L y := by + exact finiteExtensionPrincipalDivisor_supportDegree_le_two_mul_height + K L y hy0 + rw [hxDegree] at hxSupport + omega + change + (∑ w ∈ (finiteExtensionPrincipalDivisor K L (x ^ m)).support ∪ + (finiteExtensionPrincipalDivisor K L (y ^ n)).support, + degree w) + 1 ≤ _ + rw [hsupportX, hsupportY] + exact (Nat.add_le_add_left hvDegree _).trans + (hoverlap.trans hsupportSum) + +/-- Adding the canonical divisor preserves the one-unit saving from a common +affine origin. -/ +theorem planeCurve_canonicalDifferent_add_propositionTwoExceptional_add_one_le + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (hcardK : MvPolynomial.degreeOf 1 f < Fintype.card K) + (origin : AffinePlaneCurvePoint f) + (horiginFirst : origin.1.1 = 0) + (horiginSecond : origin.1.2 = 0) + (m n : ℕ) (hm : 0 < m) (hn : 0 < n) : + letI := planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + letI := planeCurveFirstCoordinateRatFuncAlgebra f hx + letI := finiteDimensional_planeCurveFunctionField_over_ratFunc + hf hpartialSecond + letI := separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + finiteExtensionDivisorDegree K (PlaneCurveFunctionField f) + (finiteExtensionCanonicalDifferentDivisor K + (PlaneCurveFunctionField f) + (finiteExtensionFiniteDifferentIdeal_ne_bot K + (PlaneCurveFunctionField f))) + + (∑ w ∈ propositionTwoExceptionalPlaces K + (PlaneCurveFunctionField f) + ((planeCurveFunction f 0) ^ m) ((planeCurveFunction f 1) ^ n), + finiteExtensionPlaceDegree K (PlaneCurveFunctionField f) w : ℤ) + + 1 ≤ + (2 * MvPolynomial.degreeOf 0 f * MvPolynomial.degreeOf 1 f : ℕ) := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let : Algebra (RatFunc K) (PlaneCurveFunctionField f) := + planeCurveFirstCoordinateRatFuncAlgebra f hx + let : FiniteDimensional (RatFunc K) (PlaneCurveFunctionField f) := + finiteDimensional_planeCurveFunctionField_over_ratFunc + hf hpartialSecond + let : Algebra.IsSeparable (RatFunc K) (PlaneCurveFunctionField f) := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + have hcanonical := + planeCurve_canonicalDifferentDivisor_degree_le + hf hpartialSecond hcardK + have hboundary := + planeCurve_propositionTwoExceptionalPlaces_weightedDegree_add_one_le + hf hpartialFirst hpartialSecond origin + horiginFirst horiginSecond m n hm hn + have hboundaryInt : + ((∑ w ∈ propositionTwoExceptionalPlaces K + (PlaneCurveFunctionField f) + ((planeCurveFunction f 0) ^ m) ((planeCurveFunction f 1) ^ n), + finiteExtensionPlaceDegree K (PlaneCurveFunctionField f) w : ℕ) : ℤ) + + 1 ≤ + 2 * ((MvPolynomial.degreeOf 0 f : ℤ) + + MvPolynomial.degreeOf 1 f) := by + exact_mod_cast hboundary + norm_num at hcanonical hboundaryInt ⊢ + omega + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurveSupportDeterminant.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurveSupportDeterminant.lean new file mode 100644 index 0000000000..ff0330b3f5 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurveSupportDeterminant.lean @@ -0,0 +1,126 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveFunctionField +public import Mathlib.Tactic + +/-! +# Rank-two support certificates for a plane curve + +A diagonal stabilizer of a torus curve is controlled by the lattice generated +by differences of exponent vectors in its equation. This file introduces the +two-dimensional determinant used for that lattice and proves the sharp box +bound `|det| ≤ 2 * degreeOf 0 f * degreeOf 1 f`. + +The bound is characteristic-free. In the high-characteristic range used by +the Corvaja--Zannier endpoint, every nonzero such determinant is automatically +nonzero modulo the characteristic. +-/ + +@[expose] public section + +namespace BGS.CorvajaZannier + +noncomputable section + +/-- The oriented lattice area of the two support differences based at `r`. -/ +def planeCurveSupportDifferenceDet + (r s t : Fin 2 →₀ ℕ) : ℤ := + ((s 0 : ℤ) - (r 0 : ℤ)) * ((t 1 : ℤ) - (r 1 : ℤ)) - + ((s 1 : ℤ) - (r 1 : ℤ)) * ((t 0 : ℤ) - (r 0 : ℤ)) + +/-- A polynomial has rank-two support when three of its monomials have +linearly independent exponent differences. -/ +def PlaneCurveSupportHasRankTwo + {K : Type*} [Field K] (f : MvPolynomial (Fin 2) K) : Prop := + ∃ r s t : Fin 2 →₀ ℕ, + r ∈ f.support ∧ s ∈ f.support ∧ t ∈ f.support ∧ + planeCurveSupportDifferenceDet r s t ≠ 0 + +/-- Every support-lattice determinant is bounded by twice the area of the +coordinate-degree box. This is the sharp uniform determinant estimate needed +for the diagonal-stabilizer route to the powered-image index bound. -/ +theorem abs_planeCurveSupportDifferenceDet_le_twice_bidegree + {K : Type*} [Field K] {f : MvPolynomial (Fin 2) K} + {r s t : Fin 2 →₀ ℕ} + (hr : r ∈ f.support) (hs : s ∈ f.support) (ht : t ∈ f.support) : + |planeCurveSupportDifferenceDet r s t| ≤ + 2 * (MvPolynomial.degreeOf 0 f : ℤ) * + (MvPolynomial.degreeOf 1 f : ℤ) := by + have hr0 := MvPolynomial.le_degreeOf_of_mem_support (p := f) 0 hr + have hr1 := MvPolynomial.le_degreeOf_of_mem_support (p := f) 1 hr + have hs0 := MvPolynomial.le_degreeOf_of_mem_support (p := f) 0 hs + have hs1 := MvPolynomial.le_degreeOf_of_mem_support (p := f) 1 hs + have ht0 := MvPolynomial.le_degreeOf_of_mem_support (p := f) 0 ht + have ht1 := MvPolynomial.le_degreeOf_of_mem_support (p := f) 1 ht + have hsr0 : |(s 0 : ℤ) - (r 0 : ℤ)| ≤ + (MvPolynomial.degreeOf 0 f : ℤ) := by + rw [abs_le] + constructor <;> omega + have hsr1 : |(s 1 : ℤ) - (r 1 : ℤ)| ≤ + (MvPolynomial.degreeOf 1 f : ℤ) := by + rw [abs_le] + constructor <;> omega + have htr0 : |(t 0 : ℤ) - (r 0 : ℤ)| ≤ + (MvPolynomial.degreeOf 0 f : ℤ) := by + rw [abs_le] + constructor <;> omega + have htr1 : |(t 1 : ℤ) - (r 1 : ℤ)| ≤ + (MvPolynomial.degreeOf 1 f : ℤ) := by + rw [abs_le] + constructor <;> omega + calc + |planeCurveSupportDifferenceDet r s t| ≤ + |((s 0 : ℤ) - (r 0 : ℤ)) * ((t 1 : ℤ) - (r 1 : ℤ))| + + |((s 1 : ℤ) - (r 1 : ℤ)) * ((t 0 : ℤ) - (r 0 : ℤ))| := by + dsimp only [planeCurveSupportDifferenceDet] + exact abs_sub _ _ + _ = |(s 0 : ℤ) - (r 0 : ℤ)| * |(t 1 : ℤ) - (r 1 : ℤ)| + + |(s 1 : ℤ) - (r 1 : ℤ)| * |(t 0 : ℤ) - (r 0 : ℤ)| := by + rw [abs_mul, abs_mul] + _ ≤ (MvPolynomial.degreeOf 0 f : ℤ) * + (MvPolynomial.degreeOf 1 f : ℤ) + + (MvPolynomial.degreeOf 1 f : ℤ) * + (MvPolynomial.degreeOf 0 f : ℤ) := by + gcongr + _ = 2 * (MvPolynomial.degreeOf 0 f : ℤ) * + (MvPolynomial.degreeOf 1 f : ℤ) := by ring + +/-- Natural-number form of the support determinant bound. -/ +theorem natAbs_planeCurveSupportDifferenceDet_le_twice_bidegree + {K : Type*} [Field K] {f : MvPolynomial (Fin 2) K} + {r s t : Fin 2 →₀ ℕ} + (hr : r ∈ f.support) (hs : s ∈ f.support) (ht : t ∈ f.support) : + (planeCurveSupportDifferenceDet r s t).natAbs ≤ + 2 * MvPolynomial.degreeOf 0 f * MvPolynomial.degreeOf 1 f := by + have h := abs_planeCurveSupportDifferenceDet_le_twice_bidegree hr hs ht + have hcast : + ((planeCurveSupportDifferenceDet r s t).natAbs : ℤ) ≤ + (2 * MvPolynomial.degreeOf 0 f * + MvPolynomial.degreeOf 1 f : ℕ) := by + rw [Int.natCast_natAbs] + exact h + exact_mod_cast hcast + +/-- A rank-two support certificate supplies a positive lattice index bounded +by the public Euler budget. -/ +theorem exists_positive_supportDet_natAbs_le_twice_bidegree + {K : Type*} [Field K] {f : MvPolynomial (Fin 2) K} + (hrank : PlaneCurveSupportHasRankTwo f) : + ∃ r s t : Fin 2 →₀ ℕ, + r ∈ f.support ∧ s ∈ f.support ∧ t ∈ f.support ∧ + 0 < (planeCurveSupportDifferenceDet r s t).natAbs ∧ + (planeCurveSupportDifferenceDet r s t).natAbs ≤ + 2 * MvPolynomial.degreeOf 0 f * MvPolynomial.degreeOf 1 f := by + obtain ⟨r, s, t, hr, hs, ht, hdet⟩ := hrank + exact ⟨r, s, t, hr, hs, ht, Int.natAbs_pos.mpr hdet, + natAbs_planeCurveSupportDifferenceDet_le_twice_bidegree hr hs ht⟩ + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurveSupportRank.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurveSupportRank.lean new file mode 100644 index 0000000000..4a7fbd3afb --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/PlaneCurveSupportRank.lean @@ -0,0 +1,867 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveSupportDeterminant +public import LeanPool.MarkoffModP.BGS.External.GeneralCurveTheorems +public import Mathlib.GroupTheory.Archimedean +public import Mathlib.Algebra.Polynomial.Homogenize +public import Mathlib.Algebra.MvPolynomial.NoZeroDivisors +public import Mathlib.FieldTheory.IsAlgClosed.Basic +public import Mathlib.Tactic + +/-! +# Absolute irreducibility forces rank-two torus support + +This file proves the support-lattice bridge needed by the diagonal-stabilizer +route to the Corvaja--Zannier powered-image index bound. A collinear finite +support lies in a translate of a cyclic subgroup of `ℤ²`; the corresponding +plane polynomial is a monomial times a directional homogenization of a +univariate polynomial. Over an algebraically closed field, irreducibility +forces that univariate polynomial to have degree one, so a nonzero torus +character is constant on the curve. This contradicts the semantic +`TorusCurveNotSubtorusTranslate` hypothesis. +-/ + +@[expose] public section + +namespace BGS.CorvajaZannier + +noncomputable section + +private def integerVectorDet (u v : Fin 2 → ℤ) : ℤ := + u 0 * v 1 - u 1 * v 0 + +private def integerVectorLine (d : Fin 2 → ℤ) : AddSubgroup (Fin 2 → ℤ) where + carrier := {w | integerVectorDet d w = 0} + zero_mem' := by simp [integerVectorDet] + add_mem' := by + intro u v hu hv + simp only [Set.mem_ofPred_eq] at hu hv ⊢ + simp only [integerVectorDet] at hu hv + simp only [integerVectorDet, Pi.add_apply] + linear_combination hu + hv + neg_mem' := by + intro u hu + simp only [Set.mem_ofPred_eq] at hu ⊢ + simp only [integerVectorDet] at hu + simp only [integerVectorDet, Pi.neg_apply] + linear_combination -hu + +private def integerCoordinate (i : Fin 2) : (Fin 2 → ℤ) →+ ℤ where + toFun w := w i + map_zero' := rfl + map_add' _ _ := rfl + +private def integerCoordinateOnLine (d : Fin 2 → ℤ) (i : Fin 2) : + integerVectorLine d →+ (integerVectorLine d).map (integerCoordinate i) where + toFun w := by + refine ⟨integerCoordinate i w.1, ?_⟩ + change ∃ x, x ∈ integerVectorLine d ∧ + integerCoordinate i x = integerCoordinate i w.1 + exact ⟨w.1, w.2, rfl⟩ + map_zero' := by apply Subtype.ext; rfl + map_add' _ _ := by apply Subtype.ext; rfl + +private theorem integerCoordinate_zero_injectiveOn_integerVectorLine + {d : Fin 2 → ℤ} (hi : d 0 ≠ 0) : + Function.Injective + ((integerCoordinate 0).comp (integerVectorLine d).subtype) := by + intro u v huv + apply Subtype.ext + funext j + have hj : j = 0 ∨ j = 1 := by + have hjlt := j.isLt + omega + rcases hj with rfl | rfl + · exact huv + · have hu := u.property + have hv := v.property + change d 0 * u.1 1 - d 1 * u.1 0 = 0 at hu + change d 0 * v.1 1 - d 1 * v.1 0 = 0 at hv + dsimp [integerCoordinate] at huv + have hmul : d 0 * u.1 1 = d 0 * v.1 1 := by + calc + d 0 * u.1 1 = d 1 * u.1 0 := by omega + _ = d 1 * v.1 0 := by rw [huv] + _ = d 0 * v.1 1 := by omega + exact (mul_left_cancel₀ hi hmul) + +private theorem integerCoordinate_one_injectiveOn_integerVectorLine + {d : Fin 2 → ℤ} (hi : d 1 ≠ 0) : + Function.Injective + ((integerCoordinate 1).comp (integerVectorLine d).subtype) := by + intro u v huv + apply Subtype.ext + funext j + have hj : j = 0 ∨ j = 1 := by + have hjlt := j.isLt + omega + rcases hj with rfl | rfl + · have hu := u.property + have hv := v.property + change d 0 * u.1 1 - d 1 * u.1 0 = 0 at hu + change d 0 * v.1 1 - d 1 * v.1 0 = 0 at hv + dsimp [integerCoordinate] at huv + have hmul : d 1 * u.1 0 = d 1 * v.1 0 := by + calc + d 1 * u.1 0 = d 0 * u.1 1 := by omega + _ = d 0 * v.1 1 := by rw [huv] + _ = d 1 * v.1 0 := by omega + exact (mul_left_cancel₀ hi hmul) + · exact huv + +private theorem integerVectorLine_cyclic {d : Fin 2 → ℤ} (hd : d ≠ 0) : + ∃ v : Fin 2 → ℤ, ∀ w : Fin 2 → ℤ, + integerVectorDet d w = 0 → ∃ k : ℤ, w = k • v := by + have hcoord : d 0 ≠ 0 ∨ d 1 ≠ 0 := by + by_cases h0 : d 0 = 0 + · right + intro h1 + apply hd + funext i + have hi : i = 0 ∨ i = 1 := by + have hilt := i.isLt + omega + rcases hi with rfl | rfl + · exact h0 + · exact h1 + · exact Or.inl h0 + obtain ⟨i, hi, hinj⟩ : ∃ i : Fin 2, d i ≠ 0 ∧ + Function.Injective + ((integerCoordinate i).comp (integerVectorLine d).subtype) := by + rcases hcoord with h | h + · exact ⟨0, h, integerCoordinate_zero_injectiveOn_integerVectorLine h⟩ + · exact ⟨1, h, integerCoordinate_one_injectiveOn_integerVectorLine h⟩ + let L := integerVectorLine d + let phi : L →+ L.map (integerCoordinate i) := integerCoordinateOnLine d i + have hphi_inj : Function.Injective phi := by + intro u v huv + apply hinj + exact congrArg Subtype.val huv + have hphi_surj : Function.Surjective phi := by + rintro ⟨z, hz⟩ + obtain ⟨w, hw, hwz⟩ := hz + refine ⟨⟨w, hw⟩, ?_⟩ + apply Subtype.ext + exact hwz + let e : L ≃+ L.map (integerCoordinate i) := + AddEquiv.ofBijective phi ⟨hphi_inj, hphi_surj⟩ + obtain ⟨a, ha⟩ := Int.subgroup_cyclic (L.map (integerCoordinate i)) + have ha_mem : a ∈ L.map (integerCoordinate i) := by + rw [ha] + exact AddSubgroup.subset_closure (Set.mem_singleton a) + let vL : L := e.symm ⟨a, ha_mem⟩ + refine ⟨vL.1, ?_⟩ + intro w hw + have wmem : w ∈ L := hw + let wL : L := ⟨w, wmem⟩ + have hew_mem : (e wL : ℤ) ∈ AddSubgroup.closure {a} := by + rw [← ha] + exact (e wL).property + obtain ⟨k, hk⟩ := AddSubgroup.mem_closure_singleton.mp hew_mem + refine ⟨k, ?_⟩ + have heq : wL = k • vL := by + apply e.injective + apply Subtype.ext + simpa [vL] using hk.symm + exact congrArg Subtype.val heq + +/-- The signed coordinate difference between two plane monomial exponents. -/ +def planeExponentDifference + (r s : Fin 2 →₀ ℕ) : Fin 2 → ℤ := + fun i => (s i : ℤ) - (r i : ℤ) + +private theorem integerVectorDet_planeExponentDifference + (r s t : Fin 2 →₀ ℕ) : + integerVectorDet (planeExponentDifference r s) + (planeExponentDifference r t) = + planeCurveSupportDifferenceDet r s t := by + rfl + +theorem exists_support_direction_of_not_rankTwo + {K : Type*} [Field K] {f : MvPolynomial (Fin 2) K} + {r : Fin 2 →₀ ℕ} (hr : r ∈ f.support) + (hnrank : ¬ PlaneCurveSupportHasRankTwo f) + (hnonsingleton : ∃ s ∈ f.support, s ≠ r) : + ∃ v : Fin 2 → ℤ, v ≠ 0 ∧ + ∀ s ∈ f.support, ∃ k : ℤ, + planeExponentDifference r s = k • v := by + obtain ⟨s, hs, hsr⟩ := hnonsingleton + have hd : planeExponentDifference r s ≠ 0 := by + intro h + apply hsr + apply Finsupp.ext + intro i + have hi := congrFun h i + dsimp [planeExponentDifference] at hi + omega + obtain ⟨v, hv⟩ := integerVectorLine_cyclic hd + have hparam : ∀ t ∈ f.support, ∃ k : ℤ, + planeExponentDifference r t = k • v := by + intro t ht + apply hv + rw [integerVectorDet_planeExponentDifference] + by_contra hdet + exact hnrank ⟨r, s, t, hr, hs, ht, hdet⟩ + have hvne : v ≠ 0 := by + obtain ⟨k, hk⟩ := hparam s hs + intro hv0 + apply hd + simpa [hv0] using hk + exact ⟨v, hvne, hparam⟩ + +private def intVectorPositive (v : Fin 2 → ℤ) : Fin 2 →₀ ℕ := + Finsupp.equivFunOnFinite.symm (fun i => (v i).toNat) + +private def intVectorNegative (v : Fin 2 → ℤ) : Fin 2 →₀ ℕ := + Finsupp.equivFunOnFinite.symm (fun i => (-v i).toNat) + +@[simp] private theorem intVectorPositive_apply (v : Fin 2 → ℤ) (i : Fin 2) : + intVectorPositive v i = (v i).toNat := by + simp [intVectorPositive] + +@[simp] private theorem intVectorNegative_apply (v : Fin 2 → ℤ) (i : Fin 2) : + intVectorNegative v i = (-v i).toNat := by + simp [intVectorNegative] + +private theorem intVectorPositive_sub_negative (v : Fin 2 → ℤ) (i : Fin 2) : + (intVectorPositive v i : ℤ) - (intVectorNegative v i : ℤ) = v i := by + simp only [intVectorPositive_apply, intVectorNegative_apply] + rw [Int.ofNat_toNat, Int.ofNat_toNat] + rcases le_total 0 (v i) with hvi | hvi + · simp [hvi, neg_nonpos.mpr hvi] + · simp [hvi] + +private def directionalHomogenization {A : Type*} [CommSemiring A] + (v : Fin 2 → ℤ) (p : Polynomial A) (n : ℕ) : + MvPolynomial (Fin 2) A := + MvPolynomial.eval₂Hom MvPolynomial.C + ![MvPolynomial.monomial (intVectorPositive v) 1, + MvPolynomial.monomial (intVectorNegative v) 1] + (p.homogenize n) + +private theorem directionalHomogenization_monomial + {A : Type*} [CommSemiring A] (v : Fin 2 → ℤ) + {k n : ℕ} (hkn : k ≤ n) (c : A) : + directionalHomogenization v (Polynomial.monomial k c) n = + MvPolynomial.monomial + (k • intVectorPositive v + (n - k) • intVectorNegative v) c := by + rw [directionalHomogenization, Polynomial.homogenize_monomial hkn] + rw [MvPolynomial.eval₂Hom_monomial] + simp [Finsupp.prod_fintype, Fin.prod_univ_two, + MvPolynomial.monomial_pow, MvPolynomial.monomial_mul_monomial, + MvPolynomial.C_mul_monomial] + +private theorem directionalHomogenization_mul + {A : Type*} [CommSemiring A] (v : Fin 2 → ℤ) + (p q : Polynomial A) {m n : ℕ} + (hp : p.natDegree ≤ m) (hq : q.natDegree ≤ n) : + directionalHomogenization v (p * q) (m + n) = + directionalHomogenization v p m * directionalHomogenization v q n := by + rw [directionalHomogenization, Polynomial.homogenize_mul p q hp hq] + exact map_mul _ _ _ + +private def directionalExponent (v : Fin 2 → ℤ) (N k : ℕ) : Fin 2 →₀ ℕ := + k • intVectorPositive v + (N - k) • intVectorNegative v + +private theorem directionalHomogenization_not_isUnit + {A : Type*} [Field A] {v : Fin 2 → ℤ} (hvne : v ≠ 0) + {q : Polynomial A} {N : ℕ} (hN : 0 < N) + (hqdeg : q.natDegree = N) (hq0 : q.coeff 0 ≠ 0) : + ¬ IsUnit (directionalHomogenization v q N) := by + let H := directionalHomogenization v q N + have hsum : H = ∑ k ∈ Finset.range (N + 1), + MvPolynomial.monomial (directionalExponent v N k) (q.coeff k) := by + have hqsum : q = ∑ k ∈ Finset.range (N + 1), + Polynomial.monomial k (q.coeff k) := by + simpa [hqdeg] using q.as_sum_range + calc + H = directionalHomogenization v q N := rfl + _ = directionalHomogenization v + (∑ k ∈ Finset.range (N + 1), + Polynomial.monomial k (q.coeff k)) N := by rw [← hqsum] + _ = ∑ k ∈ Finset.range (N + 1), + directionalHomogenization v (Polynomial.monomial k (q.coeff k)) N := by + simp only [directionalHomogenization, + Polynomial.homogenize_finsetSum, map_sum] + _ = ∑ k ∈ Finset.range (N + 1), + MvPolynomial.monomial (directionalExponent v N k) (q.coeff k) := by + apply Finset.sum_congr rfl + intro k hk + rw [directionalHomogenization_monomial] + · rfl + · exact Nat.le_of_lt_succ (Finset.mem_range.mp hk) + obtain ⟨i, hi⟩ : ∃ i : Fin 2, v i ≠ 0 := by + by_contra h + apply hvne + funext i + exact Classical.not_not.mp (not_exists.mp h i) + have coeff_sum (e : Fin 2 →₀ ℕ) : + (∑ k ∈ Finset.range (N + 1), + MvPolynomial.monomial (directionalExponent v N k) (q.coeff k)).coeff e = + ∑ k ∈ Finset.range (N + 1), + (MvPolynomial.monomial (directionalExponent v N k) (q.coeff k)).coeff e := by + have coeff_finset_sum (S : Finset ℕ) + (g : ℕ → MvPolynomial (Fin 2) A) : + (∑ k ∈ S, g k).coeff e = ∑ k ∈ S, (g k).coeff e := by + induction S using Finset.induction_on with + | empty => simp + | @insert a S ha ih => simp [ha] + exact coeff_finset_sum _ _ + have htop : q.coeff N ≠ 0 := by + rw [← hqdeg] + rw [Polynomial.coeff_natDegree] + exact Polynomial.leadingCoeff_ne_zero.mpr fun hq => hq0 (by simp [hq]) + rcases lt_or_gt_of_ne hi.symm with hvi | hvi + · have hpos : 0 < intVectorPositive v i := by + simp only [intVectorPositive_apply] + apply Nat.pos_of_ne_zero + intro hz + have := Int.toNat_eq_zero.mp hz + omega + have hneg : intVectorNegative v i = 0 := by + simp [Int.toNat_of_nonpos (neg_nonpos.mpr (le_of_lt hvi))] + let e : Fin 2 →₀ ℕ := N • intVectorPositive v + have hcoeff : H.coeff e = q.coeff N := by + rw [hsum, coeff_sum e, Finset.sum_eq_single N] + · rw [MvPolynomial.coeff_monomial] + simp [e, directionalExponent] + · intro k hk hkN + rw [MvPolynomial.coeff_monomial] + split_ifs with heq + · have hcoord := congrArg (fun d : Fin 2 →₀ ℕ => d i) heq + dsimp [e] at hcoord + simp only [directionalExponent, Finsupp.add_apply, Finsupp.smul_apply, + nsmul_eq_mul] at hcoord + rw [hneg] at hcoord + simp only [mul_zero, add_zero] at hcoord + exact (hkN (Nat.eq_of_mul_eq_mul_right hpos hcoord)).elim + · rfl + · simp + have he_mem : e ∈ H.support := MvPolynomial.mem_support_iff.mpr (hcoeff ▸ htop) + have hei : 0 < e i := by + simp only [e, Finsupp.smul_apply, nsmul_eq_mul] + exact Nat.mul_pos hN hpos + have htotal : 0 < H.totalDegree := + lt_of_lt_of_le hei <| (MvPolynomial.le_degreeOf_of_mem_support i he_mem).trans + (MvPolynomial.degreeOf_le_totalDegree H i) + intro hunit + have hdvd : H ∣ (1 : MvPolynomial (Fin 2) A) := hunit.dvd + have hle := MvPolynomial.totalDegree_le_of_dvd_of_isDomain hdvd one_ne_zero + rw [MvPolynomial.totalDegree_one] at hle + omega + · have hneg : 0 < intVectorNegative v i := by + have hvneg : v i < 0 := hvi + simp only [intVectorNegative_apply] + apply Nat.pos_of_ne_zero + intro hz + have := Int.toNat_eq_zero.mp hz + omega + have hpos : intVectorPositive v i = 0 := by + simp [Int.toNat_of_nonpos (le_of_lt hvi)] + let e : Fin 2 →₀ ℕ := N • intVectorNegative v + have hcoeff : H.coeff e = q.coeff 0 := by + rw [hsum, coeff_sum e, Finset.sum_eq_single 0] + · rw [MvPolynomial.coeff_monomial] + simp [e, directionalExponent] + · intro k hk hk0 + rw [MvPolynomial.coeff_monomial] + split_ifs with heq + · have hcoord := congrArg (fun d : Fin 2 →₀ ℕ => d i) heq + dsimp [e] at hcoord + simp only [directionalExponent, Finsupp.add_apply, Finsupp.smul_apply, + nsmul_eq_mul] at hcoord + rw [hpos] at hcoord + simp only [mul_zero, zero_add] at hcoord + have hk_le : k ≤ N := Nat.le_of_lt_succ (Finset.mem_range.mp hk) + have hsub : N - k = N := Nat.eq_of_mul_eq_mul_right hneg hcoord + have hkzero : k = 0 := by omega + exact (hk0 hkzero).elim + · rfl + · simp + have he_mem : e ∈ H.support := MvPolynomial.mem_support_iff.mpr (hcoeff ▸ hq0) + have hei : 0 < e i := by + simp only [e, Finsupp.smul_apply, nsmul_eq_mul] + exact Nat.mul_pos hN hneg + have htotal : 0 < H.totalDegree := + lt_of_lt_of_le hei <| (MvPolynomial.le_degreeOf_of_mem_support i he_mem).trans + (MvPolynomial.degreeOf_le_totalDegree H i) + intro hunit + have hdvd : H ∣ (1 : MvPolynomial (Fin 2) A) := hunit.dvd + have hle := MvPolynomial.totalDegree_le_of_dvd_of_isDomain hdvd one_ne_zero + rw [MvPolynomial.totalDegree_one] at hle + omega + +private theorem exists_directionalPolynomial_representation + {A : Type*} [Field A] {F : MvPolynomial (Fin 2) A} + {r : Fin 2 →₀ ℕ} (hr : r ∈ F.support) + {v : Fin 2 → ℤ} (_hvne : v ≠ 0) + (hparam : ∀ s ∈ F.support, ∃ k : ℤ, + planeExponentDifference r s = k • v) + (hnonsingleton : ∃ s ∈ F.support, s ≠ r) : + ∃ (q : Polynomial A) (N : ℕ) (w : Fin 2 →₀ ℕ), + 0 < N ∧ q.natDegree = N ∧ q.coeff 0 ≠ 0 ∧ + F = MvPolynomial.monomial w 1 * + directionalHomogenization v q N := by + let parameter : (Fin 2 →₀ ℕ) → ℤ := fun s => + if hs : s ∈ F.support then Classical.choose (hparam s hs) else 0 + have parameter_spec : ∀ s ∈ F.support, + planeExponentDifference r s = parameter s • v := by + intro s hs + simp only [parameter, dite_eq_left hs] + exact Classical.choose_spec (hparam s hs) + have parameter_inj : ∀ {s t}, s ∈ F.support → t ∈ F.support → + parameter s = parameter t → s = t := by + intro s t hs ht heq + have hdiff : planeExponentDifference r s = planeExponentDifference r t := by + rw [parameter_spec s hs, parameter_spec t ht, heq] + apply Finsupp.ext + intro i + have hi := congrFun hdiff i + dsimp [planeExponentDifference] at hi + omega + let P : Finset ℤ := F.support.image parameter + have hP : P.Nonempty := by + rw [Finset.image_nonempty] + exact ⟨r, hr⟩ + let lo : ℤ := P.min' hP + let hi : ℤ := P.max' hP + have hlo_mem : lo ∈ P := Finset.min'_mem P hP + have hhi_mem : hi ∈ P := Finset.max'_mem P hP + obtain ⟨slo, hslo, hslo_param⟩ := Finset.mem_image.mp hlo_mem + obtain ⟨shi, hshi, hshi_param⟩ := Finset.mem_image.mp hhi_mem + have parameter_bounds : ∀ s ∈ F.support, lo ≤ parameter s ∧ parameter s ≤ hi := by + intro s hs + constructor + · exact Finset.min'_le P (parameter s) (Finset.mem_image.mpr ⟨s, hs, rfl⟩) + · exact Finset.le_max' P (parameter s) (Finset.mem_image.mpr ⟨s, hs, rfl⟩) + let index : (Fin 2 →₀ ℕ) → ℕ := fun s => (parameter s - lo).toNat + let N : ℕ := (hi - lo).toNat + have index_cast : ∀ s ∈ F.support, (index s : ℤ) = parameter s - lo := by + intro s hs + rw [show (index s : ℤ) = max (parameter s - lo) 0 by + simp [index]] + simp [parameter_bounds s hs |>.1] + have N_cast : (N : ℤ) = hi - lo := by + rw [show (N : ℤ) = max (hi - lo) 0 by + simp [N]] + have hlohi : lo ≤ hi := Finset.min'_le P hi hhi_mem + simp [hlohi] + have index_le : ∀ s ∈ F.support, index s ≤ N := by + intro s hs + have hcast : (index s : ℤ) ≤ (N : ℤ) := by + rw [index_cast s hs, N_cast] + exact sub_le_sub_right (parameter_bounds s hs).2 lo + exact_mod_cast hcast + have index_inj : ∀ {s t}, s ∈ F.support → t ∈ F.support → + index s = index t → s = t := by + intro s t hs ht heq + apply parameter_inj hs ht + have := congrArg (fun n : ℕ => (n : ℤ)) heq + rw [index_cast s hs, index_cast t ht] at this + omega + have hindex_slo : index slo = 0 := by + simp [index, hslo_param] + have hindex_shi : index shi = N := by + have h := index_cast shi hshi + rw [hshi_param, ← N_cast] at h + exact_mod_cast h + have hlohi : lo < hi := by + obtain ⟨s, hs, hsr⟩ := hnonsingleton + by_contra hnot + have hhile : hi ≤ lo := le_of_not_gt hnot + have hparam_eq : parameter s = parameter r := by + apply le_antisymm + · exact (parameter_bounds s hs).2.trans hhile |>.trans (parameter_bounds r hr).1 + · exact (parameter_bounds r hr).2.trans hhile |>.trans (parameter_bounds s hs).1 + exact hsr (parameter_inj hs hr hparam_eq) + let q : Polynomial A := + ∑ s ∈ F.support, Polynomial.monomial (index s) (F.coeff s) + have coeff_finset_sum (n : ℕ) (S : Finset (Fin 2 →₀ ℕ)) + (g : (Fin 2 →₀ ℕ) → Polynomial A) : + (∑ s ∈ S, g s).coeff n = ∑ s ∈ S, (g s).coeff n := + Polynomial.finsetSum_coeff S g n + have coeff_q_index : ∀ s ∈ F.support, + q.coeff (index s) = F.coeff s := by + intro s hs + rw [show q.coeff (index s) = + ∑ t ∈ F.support, + (Polynomial.monomial (index t) (F.coeff t)).coeff (index s) by + simp [q]] + rw [Finset.sum_eq_single s] + · rw [Polynomial.coeff_monomial, ite_eq_left rfl] + · intro t ht hts + rw [Polynomial.coeff_monomial] + simp only [ite_eq_right_iff] + intro hit + exfalso + exact hts (index_inj ht hs hit) + · intro hnot + exact (hnot hs).elim + have hNpos : 0 < N := by + have hcast : (0 : ℤ) < (N : ℤ) := by + rw [N_cast] + exact sub_pos.mpr hlohi + exact_mod_cast hcast + have hqN : q.coeff N ≠ 0 := by + rw [← hindex_shi, coeff_q_index shi hshi] + exact MvPolynomial.mem_support_iff.mp hshi + have hqdeg_ge : N ≤ q.natDegree := Polynomial.le_natDegree_of_ne_zero hqN + have hqdeg_le : q.natDegree ≤ N := by + rw [Polynomial.natDegree_le_iff_coeff_eq_zero] + intro n hn + rw [show q.coeff n = + ∑ s ∈ F.support, + (Polynomial.monomial (index s) (F.coeff s)).coeff n by + simp [q]] + simp only [Polynomial.coeff_monomial] + apply Finset.sum_eq_zero + intro s hs + simp only [ite_eq_right_iff] + intro hisn + subst n + exact (Nat.not_lt_of_ge (index_le s hs) hn).elim + have hqdeg : q.natDegree = N := Nat.le_antisymm hqdeg_le hqdeg_ge + have hq0 : q.coeff 0 ≠ 0 := by + rw [← hindex_slo, coeff_q_index slo hslo] + exact MvPolynomial.mem_support_iff.mp hslo + have support_coordinate : ∀ s ∈ F.support, ∀ i : Fin 2, + (s i : ℤ) - (slo i : ℤ) = (index s : ℤ) * v i := by + intro s hs i + have hs_eq := congrFun (parameter_spec s hs) i + have hlo_eq := congrFun (parameter_spec slo hslo) i + change (s i : ℤ) - (r i : ℤ) = parameter s * v i at hs_eq + change (slo i : ℤ) - (r i : ℤ) = parameter slo * v i at hlo_eq + rw [hslo_param] at hlo_eq + rw [index_cast s hs] + calc + (s i : ℤ) - (slo i : ℤ) = + ((s i : ℤ) - (r i : ℤ)) - ((slo i : ℤ) - (r i : ℤ)) := by ring + _ = parameter s * v i - lo * v i := by rw [hs_eq, hlo_eq] + _ = (parameter s - lo) * v i := by ring + have negative_le_slo (i : Fin 2) : + N * intVectorNegative v i ≤ slo i := by + by_cases hvi : 0 ≤ v i + · have hneg : (-v i).toNat = 0 := Int.toNat_of_nonpos (neg_nonpos.mpr hvi) + simp [intVectorNegative_apply, hneg] + · have hvineg : v i < 0 := lt_of_not_ge hvi + have hcoord := support_coordinate shi hshi i + rw [hindex_shi] at hcoord + have hnegcast : (intVectorNegative v i : ℤ) = -v i := by + simp only [intVectorNegative_apply] + rw [Int.ofNat_toNat] + simp [le_of_lt hvineg] + have hcast : ((N * intVectorNegative v i : ℕ) : ℤ) ≤ (slo i : ℤ) := by + push_cast + rw [hnegcast] + have hshi_nonneg : (0 : ℤ) ≤ (shi i : ℤ) := by positivity + nlinarith + exact_mod_cast hcast + let w : Fin 2 →₀ ℕ := + Finsupp.equivFunOnFinite.symm + (fun i => slo i - N * intVectorNegative v i) + have w_apply (i : Fin 2) : + w i = slo i - N * intVectorNegative v i := by + simp [w] + have exponent_eq : ∀ s ∈ F.support, + s = w + index s • intVectorPositive v + + (N - index s) • intVectorNegative v := by + intro s hs + apply Finsupp.ext + intro i + have hk := index_le s hs + have hwcast : (w i : ℤ) = + (slo i : ℤ) - (N : ℤ) * (intVectorNegative v i : ℤ) := by + rw [w_apply, Nat.cast_sub (negative_le_slo i)] + push_cast + rfl + have hcoord := support_coordinate s hs i + have hpn := intVectorPositive_sub_negative v i + have hcast : (s i : ℤ) = + (w i : ℤ) + (index s : ℤ) * (intVectorPositive v i : ℤ) + + ((N - index s : ℕ) : ℤ) * (intVectorNegative v i : ℤ) := by + rw [Nat.cast_sub hk] + nlinarith + exact_mod_cast hcast + refine ⟨q, N, w, hNpos, hqdeg, hq0, ?_⟩ + rw [← F.support_sum_monomial_coeff] + have hhomog : directionalHomogenization v q N = + ∑ s ∈ F.support, + directionalHomogenization v + (Polynomial.monomial (index s) (F.coeff s)) N := by + simp only [q, directionalHomogenization, + Polynomial.homogenize_finsetSum, map_sum] + rw [hhomog, Finset.mul_sum] + apply Finset.sum_congr rfl + intro s hs + rw [directionalHomogenization_monomial v (index_le s hs)] + rw [MvPolynomial.monomial_mul_monomial] + simp only [one_mul] + apply congrArg (fun e => MvPolynomial.monomial e (F.coeff s)) + simpa [add_assoc] using exponent_eq s hs + +private theorem directionalPolynomial_degree_eq_one_of_irreducible + {A : Type*} [Field A] [IsAlgClosed A] + {F : MvPolynomial (Fin 2) A} (hF : Irreducible F) + {v : Fin 2 → ℤ} (hvne : v ≠ 0) + {q : Polynomial A} {N : ℕ} {w : Fin 2 →₀ ℕ} + (hN : 0 < N) (hqdeg : q.natDegree = N) (hq0 : q.coeff 0 ≠ 0) + (hrep : F = MvPolynomial.monomial w 1 * + directionalHomogenization v q N) : + N = 1 := by + let H := directionalHomogenization v q N + have hHnonunit : ¬ IsUnit H := + directionalHomogenization_not_isUnit hvne hN hqdeg hq0 + have hwunit : IsUnit (MvPolynomial.monomial w (1 : A)) := + (hF.isUnit_or_isUnit hrep).resolve_right hHnonunit + have hHirr : Irreducible H := by + have hprod : Irreducible (MvPolynomial.monomial w (1 : A) * H) := by + rw [← hrep] + exact hF + exact (irreducible_isUnit_mul hwunit).mp hprod + by_contra hN1 + have hNone : 1 < N := + lt_of_le_of_ne (Nat.succ_le_iff.mpr hN) (Ne.symm hN1) + have hqne : q ≠ 0 := fun hq => hq0 (by simp [hq]) + have hqdegree : q.degree ≠ 0 := by + have hposNat : 0 < q.natDegree := by rw [hqdeg]; exact hN + exact ne_of_gt (Polynomial.natDegree_pos_iff_degree_pos.mp hposNat) + obtain ⟨c, hcroot⟩ := IsAlgClosed.exists_root q hqdegree + obtain ⟨q₂, hqfac⟩ := Polynomial.dvd_iff_isRoot.mpr hcroot + have hlinear_ne : Polynomial.X - Polynomial.C c ≠ (0 : Polynomial A) := + Polynomial.X_sub_C_ne_zero c + have hq₂ne : q₂ ≠ 0 := by + intro hq₂ + apply hqne + rw [hqfac, hq₂, mul_zero] + have hq₂deg : q₂.natDegree = N - 1 := by + have hmul := Polynomial.natDegree_mul hlinear_ne hq₂ne + rw [Polynomial.natDegree_X_sub_C, ← hqfac, hqdeg] at hmul + omega + have hcne : c ≠ 0 := by + intro hc + apply hq0 + rw [hqfac, hc] + simp [Polynomial.coeff_mul] + have hq₂0 : q₂.coeff 0 ≠ 0 := by + intro hq₂zero + apply hq0 + rw [hqfac] + simp [Polynomial.coeff_mul, hq₂zero] + have hlinear0 : (Polynomial.X - Polynomial.C c).coeff 0 ≠ 0 := by + simp [hcne] + have hlinear_deg : (Polynomial.X - Polynomial.C c).natDegree = 1 := + Polynomial.natDegree_X_sub_C c + have hq₂pos : 0 < N - 1 := by omega + have hleft_nonunit : + ¬ IsUnit (directionalHomogenization v (Polynomial.X - Polynomial.C c) 1) := + directionalHomogenization_not_isUnit hvne Nat.zero_lt_one hlinear_deg hlinear0 + have hright_nonunit : + ¬ IsUnit (directionalHomogenization v q₂ (N - 1)) := + directionalHomogenization_not_isUnit hvne hq₂pos hq₂deg hq₂0 + have hHfac : H = + directionalHomogenization v (Polynomial.X - Polynomial.C c) 1 * + directionalHomogenization v q₂ (N - 1) := by + dsimp [H] + rw [hqfac] + have hsumN : 1 + (N - 1) = N := by omega + simpa [hsumN] using + (directionalHomogenization_mul v (Polynomial.X - Polynomial.C c) q₂ + (m := 1) (n := N - 1) (by rw [hlinear_deg]) (by rw [hq₂deg])) + exact (hHirr.isUnit_or_isUnit hHfac).elim hleft_nonunit hright_nonunit + +private theorem directionalHomogenization_natDegree_one + {A : Type*} [Field A] {v : Fin 2 → ℤ} {q : Polynomial A} + (hqdeg : q.natDegree = 1) : + directionalHomogenization v q 1 = + MvPolynomial.monomial (intVectorNegative v) (q.coeff 0) + + MvPolynomial.monomial (intVectorPositive v) (q.coeff 1) := by + have hqsum : q = Polynomial.monomial 0 (q.coeff 0) + + Polynomial.monomial 1 (q.coeff 1) := by + rw [q.as_sum_range, hqdeg] + simp [Finset.sum_range_succ] + calc + directionalHomogenization v q 1 = + directionalHomogenization v + (Polynomial.monomial 0 (q.coeff 0) + + Polynomial.monomial 1 (q.coeff 1)) 1 := by rw [← hqsum] + _ = directionalHomogenization v (Polynomial.monomial 0 (q.coeff 0)) 1 + + directionalHomogenization v (Polynomial.monomial 1 (q.coeff 1)) 1 := by + simp [directionalHomogenization, Polynomial.homogenize_add] + _ = _ := by + rw [directionalHomogenization_monomial v (Nat.zero_le 1), + directionalHomogenization_monomial v le_rfl] + simp + +private theorem eval_monomial_fin_two + {A : Type*} [CommSemiring A] (z : Fin 2 → A) + (e : Fin 2 →₀ ℕ) (c : A) : + MvPolynomial.eval z (MvPolynomial.monomial e c) = + c * z 0 ^ e 0 * z 1 ^ e 1 := by + rw [MvPolynomial.eval_monomial, Finsupp.prod_fintype] + · simp [Fin.prod_univ_two, mul_assoc] + · intro i + simp + +private theorem torusCharacter_eq_of_directional_linear_representation + {A : Type*} [Field A] + {F : MvPolynomial (Fin 2) A} {v : Fin 2 → ℤ} {q : Polynomial A} + {w : Fin 2 →₀ ℕ} (hqdeg : q.natDegree = 1) (hq0 : q.coeff 0 ≠ 0) + (hrep : F = MvPolynomial.monomial w 1 * + directionalHomogenization v q 1) + (x y : Aˣ) + (hzero : MvPolynomial.eval ![(x : A), (y : A)] F = 0) : + x ^ v 0 * y ^ v 1 = + Units.mk0 (-(q.coeff 0 / q.coeff 1)) (by + have hqne : q ≠ 0 := fun hq => hq0 (by simp [hq]) + have hq1 : q.coeff 1 ≠ 0 := by + rw [← hqdeg, Polynomial.coeff_natDegree] + exact Polynomial.leadingCoeff_ne_zero.mpr hqne + exact neg_ne_zero.mpr (div_ne_zero hq0 hq1)) := by + have hqne : q ≠ 0 := fun hq => hq0 (by simp [hq]) + have hq1 : q.coeff 1 ≠ 0 := by + rw [← hqdeg, Polynomial.coeff_natDegree] + exact Polynomial.leadingCoeff_ne_zero.mpr hqne + have hx : (x : A) ≠ 0 := Units.ne_zero x + have hy : (y : A) ≠ 0 := Units.ne_zero y + have hmon : MvPolynomial.eval ![(x : A), (y : A)] + (MvPolynomial.monomial w (1 : A)) ≠ 0 := by + rw [eval_monomial_fin_two] + simp [hx, hy] + have hHzero : MvPolynomial.eval ![(x : A), (y : A)] + (directionalHomogenization v q 1) = 0 := by + rw [hrep, map_mul] at hzero + exact (mul_eq_zero.mp hzero).resolve_left hmon + rw [directionalHomogenization_natDegree_one hqdeg, map_add, + eval_monomial_fin_two, eval_monomial_fin_two] at hHzero + simp only [Matrix.cons_val_zero, Matrix.cons_val_one] at hHzero + let Apos : A := (x : A) ^ intVectorPositive v 0 * + (y : A) ^ intVectorPositive v 1 + let Aneg : A := (x : A) ^ intVectorNegative v 0 * + (y : A) ^ intVectorNegative v 1 + have hAneg : Aneg ≠ 0 := by + dsimp [Aneg] + exact mul_ne_zero (pow_ne_zero _ hx) (pow_ne_zero _ hy) + have hratio : Apos / Aneg = -(q.coeff 0 / q.coeff 1) := by + rw [← neg_div] + apply (div_eq_div_iff hAneg hq1).mpr + dsimp [Apos, Aneg] + linear_combination hHzero + have hvcoord (i : Fin 2) : + v i = (intVectorPositive v i : ℤ) - (intVectorNegative v i : ℤ) := by + exact (intVectorPositive_sub_negative v i).symm + calc + x ^ v 0 * y ^ v 1 = + (x ^ (intVectorPositive v 0 : ℤ) * + (x ^ (intVectorNegative v 0 : ℤ))⁻¹) * + (y ^ (intVectorPositive v 1 : ℤ) * + (y ^ (intVectorNegative v 1 : ℤ))⁻¹) := by + rw [hvcoord 0, hvcoord 1, zpow_sub, zpow_sub] + _ = (x ^ intVectorPositive v 0 * y ^ intVectorPositive v 1) * + (x ^ intVectorNegative v 0 * y ^ intVectorNegative v 1)⁻¹ := by + simp only [zpow_natCast] + simp only [mul_inv_rev] + ac_rfl + _ = Units.mk0 (-(q.coeff 0 / q.coeff 1)) (by + exact neg_ne_zero.mpr (div_ne_zero hq0 hq1)) := by + apply Units.ext + simpa [Apos, Aneg, div_eq_mul_inv] using hratio + +/-- Absolute irreducibility and the semantic non-subtorus condition force the +support lattice of a plane torus curve to have rank two. -/ +theorem planeCurveSupportHasRankTwo_of_absoluteIrreducible_notSubtorusTranslate + {K : Type*} [Field K] {f : MvPolynomial (Fin 2) K} + (hirr : Irreducible + (MvPolynomial.map (algebraMap K (AlgebraicClosure K)) f)) + (hnot : BGS.External.TorusCurveNotSubtorusTranslate f) : + PlaneCurveSupportHasRankTwo f := by + let A := AlgebraicClosure K + let F : MvPolynomial (Fin 2) A := + MvPolynomial.map (algebraMap K A) f + have hsupp : F.support = f.support := by + exact MvPolynomial.support_map_of_injective f + (algebraMap K A).injective + by_contra hnrank + have hnrankF : ¬ PlaneCurveSupportHasRankTwo F := by + intro hrankF + obtain ⟨r, s, t, hr, hs, ht, hdet⟩ := hrankF + apply hnrank + rw [hsupp] at hr hs ht + exact ⟨r, s, t, hr, hs, ht, hdet⟩ + obtain ⟨x₀, y₀, hzero₀, _⟩ := + hnot 1 0 (Or.inl one_ne_zero) (1 : Aˣ) + have hFne : F ≠ 0 := hirr.ne_zero + obtain ⟨r, hr⟩ := MvPolynomial.support_nonempty.mpr hFne + have hnonsingleton : ∃ s ∈ F.support, s ≠ r := by + by_contra hsingle' + have hsingle : ∀ s ∈ F.support, s = r := by + intro s hs + by_contra hsr + exact hsingle' ⟨s, hs, hsr⟩ + have hsupp_single : F.support = {r} := by + apply Finset.eq_singleton_iff_unique_mem.mpr + exact ⟨hr, fun s hs => hsingle s hs⟩ + have hFmono : F = MvPolynomial.monomial r (F.coeff r) := by + rw [← F.support_sum_monomial_coeff, hsupp_single] + simp + have hcoeff : F.coeff r ≠ 0 := + MvPolynomial.mem_support_iff.mp hr + have hx₀ : (x₀ : A) ≠ 0 := Units.ne_zero x₀ + have hy₀ : (y₀ : A) ≠ 0 := Units.ne_zero y₀ + change MvPolynomial.eval ![(x₀ : A), (y₀ : A)] F = 0 at hzero₀ + rw [hFmono, eval_monomial_fin_two] at hzero₀ + exact (mul_ne_zero (mul_ne_zero hcoeff (pow_ne_zero _ hx₀)) + (pow_ne_zero _ hy₀)) hzero₀ + obtain ⟨v, hvne, hparam⟩ := + exists_support_direction_of_not_rankTwo hr hnrankF hnonsingleton + obtain ⟨q, N, w, hN, hqdeg, hq0, hrep⟩ := + exists_directionalPolynomial_representation hr hvne hparam hnonsingleton + have hNone : N = 1 := + directionalPolynomial_degree_eq_one_of_irreducible hirr hvne hN hqdeg hq0 hrep + have hqdeg1 : q.natDegree = 1 := hqdeg.trans hNone + have hrep1 : F = MvPolynomial.monomial w 1 * + directionalHomogenization v q 1 := by simpa [hNone] using hrep + have hvcoords : v 0 ≠ 0 ∨ v 1 ≠ 0 := by + by_cases h0 : v 0 = 0 + · right + intro h1 + apply hvne + funext i + have hi : i = 0 ∨ i = 1 := by + have hilt := i.isLt + omega + rcases hi with rfl | rfl + · exact h0 + · exact h1 + · exact Or.inl h0 + let c : Aˣ := Units.mk0 (-(q.coeff 0 / q.coeff 1)) (by + have hqne : q ≠ 0 := fun hq => hq0 (by simp [hq]) + have hq1 : q.coeff 1 ≠ 0 := by + rw [← hqdeg1, Polynomial.coeff_natDegree] + exact Polynomial.leadingCoeff_ne_zero.mpr hqne + exact neg_ne_zero.mpr (div_ne_zero hq0 hq1)) + obtain ⟨x, y, hzero, hcharacter⟩ := hnot (v 0) (v 1) hvcoords c + apply hcharacter + exact torusCharacter_eq_of_directional_linear_representation hqdeg1 hq0 hrep1 x y hzero + +/-- Injective extension of coefficients preserves a rank-two support +certificate. -/ +theorem planeCurveSupportHasRankTwo_map_of_injective + {K E : Type*} [Field K] [Field E] + (ι : K →+* E) (hι : Function.Injective ι) + {f : MvPolynomial (Fin 2) K} + (hrank : PlaneCurveSupportHasRankTwo f) : + PlaneCurveSupportHasRankTwo (MvPolynomial.map ι f) := by + obtain ⟨r, s, t, hr, hs, ht, hdet⟩ := hrank + have hsupp : (MvPolynomial.map ι f).support = f.support := + MvPolynomial.support_map_of_injective f hι + refine ⟨r, s, t, ?_, ?_, ?_, hdet⟩ <;> simpa only [hsupp] + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/PoweredCoordinateRelation.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/PoweredCoordinateRelation.lean new file mode 100644 index 0000000000..cf8ec32173 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/PoweredCoordinateRelation.lean @@ -0,0 +1,490 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PoweredCoordinates +public import Mathlib.Algebra.Polynomial.RingDivision + +/-! +# An explicit relation between powered plane-curve coordinates + +Let `F = L^p`, `u = x^m`, and `v = y^n`. When `n` is prime to `p`, the +element `v` is a primitive element of `L / F`. Its power basis therefore +writes `u` as a unique polynomial `P(v)` of degree less than `p`. This file +constructs that polynomial and the linear elimination relation + +`G(U,V) = U - P(V)`. + +The relation is irreducible over `F[V]`, has exact bidegree +`(1, degree P)`, satisfies the coefficient-degree bound used by the +Corvaja--Zannier resultant argument, and vanishes at `(u,v)`. The final +theorem feeds these facts into Proposition 1 without leaving an unspecified +relation polynomial as a hypothesis. +-/ + +@[expose] public section + +namespace BGS.CorvajaZannier + +noncomputable section + +variable {F L : Type*} [Field F] [Field L] [Algebra F L] + +/-- The unique bounded-degree coordinate polynomial of `u` in a chosen power +basis generated by `v`. -/ +noncomputable def powerBasisCoordinatePolynomial + (pb : PowerBasis F L) (u : L) : Polynomial F := + Classical.choose (pb.exists_eq_aeval u) + +theorem powerBasisCoordinatePolynomial_natDegree_lt + (pb : PowerBasis F L) (u : L) : + (powerBasisCoordinatePolynomial pb u).natDegree < pb.dim := + (Classical.choose_spec (pb.exists_eq_aeval u)).1 + +theorem powerBasisCoordinatePolynomial_aeval + (pb : PowerBasis F L) (u : L) : + u = Polynomial.aeval pb.gen (powerBasisCoordinatePolynomial pb u) := + (Classical.choose_spec (pb.exists_eq_aeval u)).2 + +theorem powerBasisCoordinatePolynomial_natDegree_pos_of_not_mem_range + (pb : PowerBasis F L) (u : L) + (hu : u ∉ Set.range (algebraMap F L)) : + 0 < (powerBasisCoordinatePolynomial pb u).natDegree := by + apply Nat.pos_of_ne_zero + intro hdegree + have hconstant := Polynomial.eq_C_of_natDegree_eq_zero hdegree + apply hu + refine ⟨(powerBasisCoordinatePolynomial pb u).coeff 0, ?_⟩ + calc + algebraMap F L ((powerBasisCoordinatePolynomial pb u).coeff 0) = + Polynomial.aeval pb.gen + (Polynomial.C ((powerBasisCoordinatePolynomial pb u).coeff 0)) := by simp + _ = Polynomial.aeval pb.gen (powerBasisCoordinatePolynomial pb u) := by + exact congrArg (Polynomial.aeval pb.gen) hconstant.symm + _ = u := (powerBasisCoordinatePolynomial_aeval pb u).symm + +/-- The linear elimination relation `U - P(V)`. -/ +def powerBasisEliminationRelation (pb : PowerBasis F L) (u : L) : + Polynomial (Polynomial F) := + Polynomial.X - Polynomial.C (powerBasisCoordinatePolynomial pb u) + +theorem powerBasisEliminationRelation_irreducible + (pb : PowerBasis F L) (u : L) : + Irreducible (powerBasisEliminationRelation pb u) := by + exact Polynomial.irreducible_X_sub_C _ + +theorem powerBasisEliminationRelation_natDegree + (pb : PowerBasis F L) (u : L) : + (powerBasisEliminationRelation pb u).natDegree = 1 := by + exact Polynomial.natDegree_X_sub_C _ + +theorem transpose_powerBasisEliminationRelation + (pb : PowerBasis F L) (u : L) : + transposeBivariate (powerBasisEliminationRelation pb u) = + Polynomial.C Polynomial.X - + (powerBasisCoordinatePolynomial pb u).map Polynomial.C := by + simp [powerBasisEliminationRelation, transposeBivariate] + +theorem transpose_powerBasisEliminationRelation_natDegree + (pb : PowerBasis F L) (u : L) : + (transposeBivariate (powerBasisEliminationRelation pb u)).natDegree = + (powerBasisCoordinatePolynomial pb u).natDegree := by + rw [transpose_powerBasisEliminationRelation] + let P := powerBasisCoordinatePolynomial pb u + have hmap : (P.map Polynomial.C).natDegree = P.natDegree := by + rw [Polynomial.natDegree_map_eq_of_injective Polynomial.C_injective] + by_cases hP : P.natDegree = 0 + · change (Polynomial.C Polynomial.X - P.map Polynomial.C).natDegree = P.natDegree + rw [hP] + apply Nat.eq_zero_of_le_zero + exact (Polynomial.natDegree_sub_le _ _).trans (by simp [hP, hmap]) + · have hlt : (Polynomial.C Polynomial.X : Polynomial (Polynomial F)).natDegree < + (P.map Polynomial.C).natDegree := by + rw [hmap] + simpa using Nat.pos_of_ne_zero hP + rw [Polynomial.natDegree_sub_eq_right_of_natDegree_lt hlt, hmap] + +theorem powerBasisEliminationRelation_coeff_natDegree_le + (pb : PowerBasis F L) (u : L) (i : ℕ) : + ((powerBasisEliminationRelation pb u).coeff i).natDegree ≤ + (powerBasisCoordinatePolynomial pb u).natDegree := by + by_cases hi : i = 0 + · subst i + simp [powerBasisEliminationRelation] + · rw [powerBasisEliminationRelation, Polynomial.coeff_sub, + Polynomial.coeff_C_of_ne_zero hi] + by_cases hi1 : i = 1 + · subst i + simp + · rw [Polynomial.coeff_X_of_ne_one hi1] + simp + +theorem evalBivariate_powerBasisEliminationRelation + (pb : PowerBasis F L) (u : L) : + evalBivariate pb.gen u (powerBasisEliminationRelation pb u) = 0 := by + rw [powerBasisEliminationRelation] + unfold evalBivariate + rw [Polynomial.eval₂_sub, Polynomial.eval₂_X, Polynomial.eval₂_C] + change u - Polynomial.aeval pb.gen (powerBasisCoordinatePolynomial pb u) = 0 + rw [← powerBasisCoordinatePolynomial_aeval pb u, sub_self] + +/-- The canonical Frobenius power basis generated by the powered second +coordinate of an irreducible plane curve. -/ +noncomputable def secondPoweredCoordinateFrobeniusPowerBasis + {K : Type*} [Field K] [PerfectField K] + {p : ℕ} [Fact p.Prime] [CharP K p] + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (n : ℕ) (hn : ¬ p ∣ n) : + letI := planeCurveCoordinateRing_isDomain hf + letI : CharP (PlaneCurveFunctionField f) p := + charP_of_injective_algebraMap + (algebraMap K (PlaneCurveFunctionField f)).injective p + PowerBasis (frobeniusSubfield (PlaneCurveFunctionField f) p) + (PlaneCurveFunctionField f) := by + letI : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let L := PlaneCurveFunctionField f + letI : CharP L p := charP_of_injective_algebraMap + (algebraMap K L).injective p + let F := frobeniusSubfield L p + letI : IsPurelyInseparable F L := + frobeniusSubfield_isPurelyInseparable p + let v : L := (planeCurveFunction f 1) ^ n + have hvTop : IntermediateField.adjoin F {v} = ⊤ := by + simpa [F, L, v] using + (adjoin_frobeniusSubfield_secondCoordinatePow_eq_top + hf hpartialFirst n hn) + have hvIntegral : IsIntegral F v := + IsPurelyInseparable.isIntegral' F v + let pb : PowerBasis F L := PowerBasis.ofAdjoinEqTop hvIntegral + (Algebra.adjoin_eq_top_of_primitive_element + hvIntegral.isAlgebraic hvTop) + simpa [F, L] using pb + +theorem secondPoweredCoordinateFrobeniusPowerBasis_gen + {K : Type*} [Field K] [PerfectField K] + {p : ℕ} [Fact p.Prime] [CharP K p] + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (n : ℕ) (hn : ¬ p ∣ n) : + letI := planeCurveCoordinateRing_isDomain hf + letI : CharP (PlaneCurveFunctionField f) p := + charP_of_injective_algebraMap + (algebraMap K (PlaneCurveFunctionField f)).injective p + (secondPoweredCoordinateFrobeniusPowerBasis hf hpartialFirst n hn).gen = + (planeCurveFunction f 1) ^ n := by + simp [secondPoweredCoordinateFrobeniusPowerBasis] + +theorem secondPoweredCoordinateFrobeniusPowerBasis_dim + {K : Type*} [Field K] [PerfectField K] + {p : ℕ} [Fact p.Prime] [CharP K p] + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (n : ℕ) (hn : ¬ p ∣ n) : + letI := planeCurveCoordinateRing_isDomain hf + letI : CharP (PlaneCurveFunctionField f) p := + charP_of_injective_algebraMap + (algebraMap K (PlaneCurveFunctionField f)).injective p + (secondPoweredCoordinateFrobeniusPowerBasis hf hpartialFirst n hn).dim = p := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let L := PlaneCurveFunctionField f + let : CharP L p := charP_of_injective_algebraMap + (algebraMap K L).injective p + rw [secondPoweredCoordinateFrobeniusPowerBasis, + PowerBasis.ofAdjoinEqTop_dim] + exact minpoly_secondCoordinatePow_natDegree_eq_char + hf hpartialFirst n hn + +/-- The bounded polynomial in `y^n` representing `x^m` over the Frobenius +subfield. -/ +noncomputable def poweredCoordinateExpansionPolynomial + {K : Type*} [Field K] [PerfectField K] + {p : ℕ} [Fact p.Prime] [CharP K p] + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (m n : ℕ) (hn : ¬ p ∣ n) : + letI := planeCurveCoordinateRing_isDomain hf + letI : CharP (PlaneCurveFunctionField f) p := + charP_of_injective_algebraMap + (algebraMap K (PlaneCurveFunctionField f)).injective p + Polynomial (frobeniusSubfield (PlaneCurveFunctionField f) p) := by + letI : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + letI : CharP (PlaneCurveFunctionField f) p := + charP_of_injective_algebraMap + (algebraMap K (PlaneCurveFunctionField f)).injective p + exact powerBasisCoordinatePolynomial + (secondPoweredCoordinateFrobeniusPowerBasis hf hpartialFirst n hn) + ((planeCurveFunction f 0) ^ m) + +theorem poweredCoordinateExpansionPolynomial_natDegree_lt_char + {K : Type*} [Field K] [PerfectField K] + {p : ℕ} [Fact p.Prime] [CharP K p] + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (m n : ℕ) (hn : ¬ p ∣ n) : + letI := planeCurveCoordinateRing_isDomain hf + letI : CharP (PlaneCurveFunctionField f) p := + charP_of_injective_algebraMap + (algebraMap K (PlaneCurveFunctionField f)).injective p + (poweredCoordinateExpansionPolynomial hf hpartialFirst m n hn).natDegree < p := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let : CharP (PlaneCurveFunctionField f) p := + charP_of_injective_algebraMap + (algebraMap K (PlaneCurveFunctionField f)).injective p + calc + (poweredCoordinateExpansionPolynomial hf hpartialFirst m n hn).natDegree < + (secondPoweredCoordinateFrobeniusPowerBasis hf hpartialFirst n hn).dim := by + exact powerBasisCoordinatePolynomial_natDegree_lt _ _ + _ = p := secondPoweredCoordinateFrobeniusPowerBasis_dim + hf hpartialFirst n hn + +theorem poweredCoordinateExpansionPolynomial_aeval + {K : Type*} [Field K] [PerfectField K] + {p : ℕ} [Fact p.Prime] [CharP K p] + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (m n : ℕ) (hn : ¬ p ∣ n) : + letI := planeCurveCoordinateRing_isDomain hf + letI : CharP (PlaneCurveFunctionField f) p := + charP_of_injective_algebraMap + (algebraMap K (PlaneCurveFunctionField f)).injective p + (planeCurveFunction f 0) ^ m = + Polynomial.aeval ((planeCurveFunction f 1) ^ n) + (poweredCoordinateExpansionPolynomial hf hpartialFirst m n hn) := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let : CharP (PlaneCurveFunctionField f) p := + charP_of_injective_algebraMap + (algebraMap K (PlaneCurveFunctionField f)).injective p + rw [← secondPoweredCoordinateFrobeniusPowerBasis_gen + hf hpartialFirst n hn] + exact powerBasisCoordinatePolynomial_aeval _ _ + +/-- The explicit bivariate elimination relation +`U - P_{m,n}(V)` between `x^m` and `y^n`. -/ +noncomputable def poweredCoordinateEliminationRelation + {K : Type*} [Field K] [PerfectField K] + {p : ℕ} [Fact p.Prime] [CharP K p] + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (m n : ℕ) (hn : ¬ p ∣ n) : + letI := planeCurveCoordinateRing_isDomain hf + letI : CharP (PlaneCurveFunctionField f) p := + charP_of_injective_algebraMap + (algebraMap K (PlaneCurveFunctionField f)).injective p + Polynomial (Polynomial + (frobeniusSubfield (PlaneCurveFunctionField f) p)) := by + letI : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + letI : CharP (PlaneCurveFunctionField f) p := + charP_of_injective_algebraMap + (algebraMap K (PlaneCurveFunctionField f)).injective p + exact powerBasisEliminationRelation + (secondPoweredCoordinateFrobeniusPowerBasis hf hpartialFirst n hn) + ((planeCurveFunction f 0) ^ m) + +theorem poweredCoordinateEliminationRelation_irreducible + {K : Type*} [Field K] [PerfectField K] + {p : ℕ} [Fact p.Prime] [CharP K p] + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (m n : ℕ) (hn : ¬ p ∣ n) : + letI := planeCurveCoordinateRing_isDomain hf + letI : CharP (PlaneCurveFunctionField f) p := + charP_of_injective_algebraMap + (algebraMap K (PlaneCurveFunctionField f)).injective p + Irreducible + (poweredCoordinateEliminationRelation hf hpartialFirst m n hn) := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let : CharP (PlaneCurveFunctionField f) p := + charP_of_injective_algebraMap + (algebraMap K (PlaneCurveFunctionField f)).injective p + exact powerBasisEliminationRelation_irreducible _ _ + +theorem poweredCoordinateEliminationRelation_natDegree + {K : Type*} [Field K] [PerfectField K] + {p : ℕ} [Fact p.Prime] [CharP K p] + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (m n : ℕ) (hn : ¬ p ∣ n) : + letI := planeCurveCoordinateRing_isDomain hf + letI : CharP (PlaneCurveFunctionField f) p := + charP_of_injective_algebraMap + (algebraMap K (PlaneCurveFunctionField f)).injective p + (poweredCoordinateEliminationRelation hf hpartialFirst m n hn).natDegree = 1 := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let : CharP (PlaneCurveFunctionField f) p := + charP_of_injective_algebraMap + (algebraMap K (PlaneCurveFunctionField f)).injective p + exact powerBasisEliminationRelation_natDegree _ _ + +theorem transpose_poweredCoordinateEliminationRelation_natDegree + {K : Type*} [Field K] [PerfectField K] + {p : ℕ} [Fact p.Prime] [CharP K p] + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (m n : ℕ) (hn : ¬ p ∣ n) : + letI := planeCurveCoordinateRing_isDomain hf + letI : CharP (PlaneCurveFunctionField f) p := + charP_of_injective_algebraMap + (algebraMap K (PlaneCurveFunctionField f)).injective p + (transposeBivariate + (poweredCoordinateEliminationRelation hf hpartialFirst m n hn)).natDegree = + (poweredCoordinateExpansionPolynomial hf hpartialFirst m n hn).natDegree := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let : CharP (PlaneCurveFunctionField f) p := + charP_of_injective_algebraMap + (algebraMap K (PlaneCurveFunctionField f)).injective p + exact transpose_powerBasisEliminationRelation_natDegree _ _ + +theorem poweredCoordinateEliminationRelation_coeff_natDegree_le + {K : Type*} [Field K] [PerfectField K] + {p : ℕ} [Fact p.Prime] [CharP K p] + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (m n : ℕ) (hn : ¬ p ∣ n) (i : ℕ) : + letI := planeCurveCoordinateRing_isDomain hf + letI : CharP (PlaneCurveFunctionField f) p := + charP_of_injective_algebraMap + (algebraMap K (PlaneCurveFunctionField f)).injective p + ((poweredCoordinateEliminationRelation hf hpartialFirst m n hn).coeff i).natDegree ≤ + (poweredCoordinateExpansionPolynomial hf hpartialFirst m n hn).natDegree := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let : CharP (PlaneCurveFunctionField f) p := + charP_of_injective_algebraMap + (algebraMap K (PlaneCurveFunctionField f)).injective p + exact powerBasisEliminationRelation_coeff_natDegree_le _ _ i + +theorem evalBivariate_poweredCoordinateEliminationRelation + {K : Type*} [Field K] [PerfectField K] + {p : ℕ} [Fact p.Prime] [CharP K p] + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (m n : ℕ) (hn : ¬ p ∣ n) : + letI := planeCurveCoordinateRing_isDomain hf + letI : CharP (PlaneCurveFunctionField f) p := + charP_of_injective_algebraMap + (algebraMap K (PlaneCurveFunctionField f)).injective p + evalBivariate ((planeCurveFunction f 1) ^ n) + ((planeCurveFunction f 0) ^ m) + (poweredCoordinateEliminationRelation hf hpartialFirst m n hn) = 0 := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let : CharP (PlaneCurveFunctionField f) p := + charP_of_injective_algebraMap + (algebraMap K (PlaneCurveFunctionField f)).injective p + rw [← secondPoweredCoordinateFrobeniusPowerBasis_gen + hf hpartialFirst n hn] + exact evalBivariate_powerBasisEliminationRelation _ _ + +/-- If both powered coordinates are separating, the second bidegree of the +linear elimination relation is positive as well as strictly below `p`. -/ +theorem poweredCoordinateExpansionPolynomial_natDegree_pos + {K : Type*} [Field K] [PerfectField K] + {p : ℕ} [Fact p.Prime] [CharP K p] + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (m n : ℕ) (hm : ¬ p ∣ m) (hn : ¬ p ∣ n) : + letI := planeCurveCoordinateRing_isDomain hf + letI : CharP (PlaneCurveFunctionField f) p := + charP_of_injective_algebraMap + (algebraMap K (PlaneCurveFunctionField f)).injective p + 0 < (poweredCoordinateExpansionPolynomial + hf hpartialFirst m n hn).natDegree := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let L := PlaneCurveFunctionField f + let : CharP L p := charP_of_injective_algebraMap + (algebraMap K L).injective p + let F := frobeniusSubfield L p + let x : L := planeCurveFunction f 0 + have hsep := (finiteSeparable_over_firstCoordinate_of_irreducible + hf hpartialSecond).2 + let : Algebra.IsSeparable (FirstCoordinateSubfield f) L := hsep + let : Algebra.IsSeparable (IntermediateField.adjoin F {x}) L := + isSeparable_over_frobeniusAdjoin_of_isSeparable_over_constantAdjoin + (K := K) (L := L) (p := p) x + have hxTrans : Transcendental K x := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + have hx0 : x ≠ 0 := by + intro hx + apply hxTrans + rw [hx] + exact isAlgebraic_zero + have hxNot : x ∉ F := firstCoordinate_not_mem_frobeniusSubfield + hf hpartialSecond + have hxmNot : x ^ m ∉ F := frobeniusPower_not_mem + x hx0 hxNot m hm + have hxmRange : x ^ m ∉ Set.range (algebraMap F L) := by + rintro ⟨c, hc⟩ + apply hxmNot + rw [← hc] + exact c.property + exact powerBasisCoordinatePolynomial_natDegree_pos_of_not_mem_range + (secondPoweredCoordinateFrobeniusPowerBasis hf hpartialFirst n hn) + (x ^ m) hxmRange + +/-- Proposition 1 for powered plane coordinates with the defining relation +constructed internally. The only remaining numerical hypotheses refer to +the actual second degree of the canonical elimination polynomial. -/ +theorem poweredCoordinates_auxiliaryFamily_linearIndependent_of_elimination + {K : Type*} [Field K] [PerfectField K] + {p : ℕ} [Fact p.Prime] [CharP K p] + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (m n : ℕ) (hn : ¬ p ∣ n) (h k : ℕ) + (hh : 0 < h) (hk : 0 < k) + (hsize : h + + (poweredCoordinateExpansionPolynomial hf hpartialFirst m n hn).natDegree * k < p) + (hdegree : h < + (poweredCoordinateExpansionPolynomial hf hpartialFirst m n hn).natDegree) : + letI := planeCurveCoordinateRing_isDomain hf + letI : CharP (PlaneCurveFunctionField f) p := + charP_of_injective_algebraMap + (algebraMap K (PlaneCurveFunctionField f)).injective p + LinearIndependent + (frobeniusSubfield (PlaneCurveFunctionField f) p) + (auxiliaryFamily ((planeCurveFunction f 0) ^ m) + ((planeCurveFunction f 1) ^ n) h k) := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let : CharP (PlaneCurveFunctionField f) p := + charP_of_injective_algebraMap + (algebraMap K (PlaneCurveFunctionField f)).injective p + exact poweredCoordinates_auxiliaryFamily_linearIndependent_of_relation + hf hpartialFirst m n hn + (poweredCoordinateEliminationRelation hf hpartialFirst m n hn) + 1 + (poweredCoordinateExpansionPolynomial hf hpartialFirst m n hn).natDegree + h k Nat.zero_lt_one hh hk + (poweredCoordinateEliminationRelation_irreducible + hf hpartialFirst m n hn) + (poweredCoordinateEliminationRelation_natDegree + hf hpartialFirst m n hn) + (transpose_poweredCoordinateEliminationRelation_natDegree + hf hpartialFirst m n hn) + (poweredCoordinateEliminationRelation_coeff_natDegree_le + hf hpartialFirst m n hn) + (evalBivariate_poweredCoordinateEliminationRelation + hf hpartialFirst m n hn) + (by simpa using hsize) + (by + intro hdegrees + exact (Nat.not_le_of_lt hdegree) hdegrees.2) + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/PoweredCoordinates.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/PoweredCoordinates.lean new file mode 100644 index 0000000000..8b3b6637b7 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/PoweredCoordinates.lean @@ -0,0 +1,507 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveAuxiliaryIndependence +public import LeanPool.MarkoffModP.BGS.External.GeneralCurveTheorems +public import Mathlib.RingTheory.Coprime.Lemmas + +/-! +# Prime-to-characteristic powers of plane-curve coordinates + +Corvaja--Zannier's plane torsion corollary applies the function-field theorem +to powers of the two coordinate functions. This file makes the algebraic +part of that passage explicit. A positive power preserves the geometric +nonconstancy of every character. If the exponent is prime to the +characteristic, a separating coordinate power generates the function field +over its Frobenius subfield, has nonzero differential, and has minimal +polynomial of degree exactly the characteristic. + +The last theorem applies the already-proved resultant form of Proposition 1 +to powered coordinates once an explicit irreducible relation between those +powers is supplied. Constructing that elimination relation, and controlling +its bidegrees, remains a separate algebraic-geometric step; it is not assumed +implicitly here. +-/ + +@[expose] public section + +namespace BGS.CorvajaZannier + +noncomputable section + +/-- No nontrivial character in the powered coordinates is constant on the +geometric torus curve. -/ +def PoweredTorusCurveNotSubtorusTranslate + {K : Type*} [Field K] (f : MvPolynomial (Fin 2) K) + (m n : ℕ) : Prop := + ∀ (a b : ℤ), (a ≠ 0 ∨ b ≠ 0) → + ∀ c : (AlgebraicClosure K)ˣ, + ∃ x y : (AlgebraicClosure K)ˣ, + MvPolynomial.eval ![(x : AlgebraicClosure K), + (y : AlgebraicClosure K)] + (MvPolynomial.map (algebraMap K (AlgebraicClosure K)) f) = 0 ∧ + (x ^ m) ^ a * (y ^ n) ^ b ≠ c + +/-- Positive coordinate powers preserve the source's multiplicative +independence-modulo-constants condition. -/ +theorem poweredTorusCurveNotSubtorusTranslate + {K : Type*} [Field K] {f : MvPolynomial (Fin 2) K} + {m n : ℕ} (hm : 0 < m) (hn : 0 < n) + (hnot : BGS.External.TorusCurveNotSubtorusTranslate f) : + PoweredTorusCurveNotSubtorusTranslate f m n := by + intro a b hab c + have hm0 : (m : ℤ) ≠ 0 := by exact_mod_cast hm.ne' + have hn0 : (n : ℤ) ≠ 0 := by exact_mod_cast hn.ne' + have hab' : (m : ℤ) * a ≠ 0 ∨ (n : ℤ) * b ≠ 0 := by + rcases hab with ha | hb + · exact Or.inl (mul_ne_zero hm0 ha) + · exact Or.inr (mul_ne_zero hn0 hb) + obtain ⟨x, y, hcurve, hcharacter⟩ := + hnot ((m : ℤ) * a) ((n : ℤ) * b) hab' c + refine ⟨x, y, hcurve, ?_⟩ + simpa only [← zpow_natCast, ← zpow_mul] using hcharacter + +/-- If `m` is coprime to `p`, adjoining `z ^ m` is the same as adjoining +`z`, provided the `p`-th power of `z` is already in the smaller field. + +The reverse inclusion is the explicit Bézout identity +`a * m + b * p = 1`, interpreted using integer powers in the ambient field. -/ +theorem adjoin_pow_eq_adjoin_of_coprime + {F L : Type*} [Field F] [Field L] [Algebra F L] + (z : L) (hz : z ≠ 0) (p m : ℕ) (hcop : Nat.Coprime m p) + (hzp : z ^ p ∈ IntermediateField.adjoin F ({z ^ m} : Set L)) : + IntermediateField.adjoin F ({z ^ m} : Set L) = + IntermediateField.adjoin F ({z} : Set L) := by + apply le_antisymm + · apply IntermediateField.adjoin_le_iff.mpr + intro x hx + rw [Set.mem_singleton_iff] at hx + subst x + exact pow_mem (IntermediateField.subset_adjoin F {z} (Set.mem_singleton z)) m + · apply IntermediateField.adjoin_le_iff.mpr + intro x hx + rw [Set.mem_singleton_iff] at hx + subst x + rcases hcop.isCoprime with ⟨a, b, hab⟩ + have hzm : z ^ m ∈ IntermediateField.adjoin F ({z ^ m} : Set L) := + IntermediateField.subset_adjoin F {z ^ m} (Set.mem_singleton (z ^ m)) + have hprod : (z ^ m) ^ a * (z ^ p) ^ b = z := by + rw [← zpow_natCast, ← zpow_natCast, ← zpow_mul, ← zpow_mul, + ← zpow_add₀ hz] + simpa [mul_comm] using congrArg (fun e : ℤ => z ^ e) hab + have hmem : (z ^ m) ^ a * (z ^ p) ^ b ∈ + IntermediateField.adjoin F ({z ^ m} : Set L) := + mul_mem (zpow_mem hzm a) (zpow_mem hzp b) + rw [hprod] at hmem + exact hmem + +/-- A prime-to-characteristic power of a Frobenius-separating generator is +again a generator over the Frobenius subfield. -/ +theorem adjoin_frobeniusSubfield_pow_eq_top + {L : Type*} [Field L] {p : ℕ} [Fact p.Prime] [CharP L p] + (z : L) (hz : z ≠ 0) (m : ℕ) (hm : ¬ p ∣ m) + [Algebra.IsSeparable + (IntermediateField.adjoin (frobeniusSubfield L p) {z}) L] : + IntermediateField.adjoin (frobeniusSubfield L p) ({z ^ m} : Set L) = ⊤ := by + let F := frobeniusSubfield L p + have hcop : Nat.Coprime m p := + ((Fact.out : p.Prime).coprime_iff_not_dvd.mpr hm).symm + have hzp : z ^ p ∈ IntermediateField.adjoin F ({z ^ m} : Set L) := by + let zp : F := ⟨z ^ p, ⟨z, by simp [frobenius_def]⟩⟩ + change (zp : L) ∈ IntermediateField.adjoin F ({z ^ m} : Set L) + exact (IntermediateField.adjoin F ({z ^ m} : Set L)).algebraMap_mem zp + rw [adjoin_pow_eq_adjoin_of_coprime z hz p m hcop hzp] + exact adjoin_frobeniusSubfield_eq_top p z + +/-- A prime-to-characteristic power of a function with nonzero derivative +again has nonzero derivative. -/ +theorem derivation_pow_ne_zero_of_not_dvd + {C L : Type*} [CommRing C] [Field L] [Algebra C L] + {p : ℕ} [CharP L p] + (D : Derivation C L L) (z : L) (m : ℕ) + (hm : ¬ p ∣ m) (hz : z ≠ 0) (hDz : D z ≠ 0) : + D (z ^ m) ≠ 0 := by + rw [D.leibniz_pow] + rw [← Nat.cast_smul_eq_nsmul L, smul_smul] + exact smul_ne_zero + (mul_ne_zero (by + rw [ne_eq, CharP.cast_eq_zero_iff L p] + exact hm) (pow_ne_zero _ hz)) hDz + +/-- The exact-constants derivation associated to `z` also detects every +prime-to-characteristic power of `z`. -/ +theorem exists_derivation_power_ne_zero_with_exact_frobenius_constants + {L : Type*} [Field L] {p : ℕ} [Fact p.Prime] [CharP L p] + (z : L) (hz : z ≠ 0) (hzNot : z ∉ frobeniusSubfield L p) + (m : ℕ) (hm : ¬ p ∣ m) + [Algebra.IsSeparable + (IntermediateField.adjoin (frobeniusSubfield L p) {z}) L] : + ∃ D : Derivation (frobeniusSubfield L p) L L, + D (z ^ m) ≠ 0 ∧ + ∀ w : L, D w = 0 ↔ + ∃ c : frobeniusSubfield L p, + algebraMap (frobeniusSubfield L p) L c = w := by + obtain ⟨D, hDz, hker⟩ := + exists_derivation_with_exact_frobenius_constants (p := p) z hzNot + refine ⟨D, derivation_pow_ne_zero_of_not_dvd D z m hm hz ?_, hker⟩ + simp [hDz] + +/-- A prime-to-characteristic power of a Frobenius-separating element is not +itself a Frobenius power. -/ +theorem frobeniusPower_not_mem + {L : Type*} [Field L] {p : ℕ} [Fact p.Prime] [CharP L p] + (z : L) (hz : z ≠ 0) (hzNot : z ∉ frobeniusSubfield L p) + (m : ℕ) (hm : ¬ p ∣ m) + [Algebra.IsSeparable + (IntermediateField.adjoin (frobeniusSubfield L p) {z}) L] : + z ^ m ∉ frobeniusSubfield L p := by + obtain ⟨D, hDpow, hker⟩ := + exists_derivation_power_ne_zero_with_exact_frobenius_constants + z hz hzNot m hm + intro hpow + apply hDpow + apply (hker (z ^ m)).2 + exact ⟨⟨z ^ m, hpow⟩, rfl⟩ + +/-- The minimal polynomial of a prime-to-characteristic power of a +Frobenius-separating element still has degree exactly `p` over `L^p`. -/ +theorem frobeniusPower_minpoly_natDegree_eq_char + {L : Type*} [Field L] {p : ℕ} [Fact p.Prime] [CharP L p] + (z : L) (hz : z ≠ 0) (hzNot : z ∉ frobeniusSubfield L p) + (m : ℕ) (hm : ¬ p ∣ m) + [Algebra.IsSeparable + (IntermediateField.adjoin (frobeniusSubfield L p) {z}) L] : + (minpoly (frobeniusSubfield L p) (z ^ m)).natDegree = p := by + let F := frobeniusSubfield L p + have hnot : z ^ m ∉ F := frobeniusPower_not_mem z hz hzNot m hm + have htop : IntermediateField.adjoin F ({z ^ m} : Set L) = ⊤ := + adjoin_frobeniusSubfield_pow_eq_top z hz m hm + let E : IntermediateField F L := IntermediateField.adjoin F {z ^ m} + let : Algebra.IsSeparable E L := by + change Algebra.IsSeparable + (IntermediateField.adjoin F ({z ^ m} : Set L)) L + rw [htop] + refine ⟨fun w ↦ ?_⟩ + let wTop : (⊤ : IntermediateField F L) := ⟨w, trivial⟩ + change IsSeparable (⊤ : IntermediateField F L) w + have hw : algebraMap (⊤ : IntermediateField F L) L wTop = w := rfl + rw [← hw] + exact isSeparable_algebraMap (K := L) wTop + exact minpoly_natDegree_over_frobeniusSubfield_eq_char + (p := p) (z ^ m) hnot + +/-- A positive power of the first coordinate remains transcendental over the +constant field. -/ +theorem firstCoordinatePow_transcendental + {K : Type*} [Field K] {f : MvPolynomial (Fin 2) K} + (hf : Irreducible f) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + {m : ℕ} (hm : 0 < m) : + letI := planeCurveCoordinateRing_isDomain hf + Transcendental K ((planeCurveFunction f 0) ^ m) := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + exact (firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond)).pow hm + +/-- A positive power of the second coordinate remains transcendental over the +constant field. -/ +theorem secondCoordinatePow_transcendental + {K : Type*} [Field K] {f : MvPolynomial (Fin 2) K} + (hf : Irreducible f) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + {n : ℕ} (hn : 0 < n) : + letI := planeCurveCoordinateRing_isDomain hf + Transcendental K ((planeCurveFunction f 1) ^ n) := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + exact (secondCoordinate_transcendental hf + (degreeOf_first_pos_of_pderiv_ne_zero hpartialFirst)).pow hn + +/-- The first powered coordinate alone generates the curve function field +over its Frobenius subfield. -/ +theorem adjoin_frobeniusSubfield_firstCoordinatePow_eq_top + {K : Type*} [Field K] [PerfectField K] + {p : ℕ} [Fact p.Prime] [CharP K p] + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (m : ℕ) (hm : ¬ p ∣ m) : + letI := planeCurveCoordinateRing_isDomain hf + letI : CharP (PlaneCurveFunctionField f) p := + charP_of_injective_algebraMap + (algebraMap K (PlaneCurveFunctionField f)).injective p + IntermediateField.adjoin + (frobeniusSubfield (PlaneCurveFunctionField f) p) + ({(planeCurveFunction f 0) ^ m} : Set (PlaneCurveFunctionField f)) = ⊤ := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let L := PlaneCurveFunctionField f + let : CharP L p := charP_of_injective_algebraMap + (algebraMap K L).injective p + let F := frobeniusSubfield L p + let x : L := planeCurveFunction f 0 + have hsep := (finiteSeparable_over_firstCoordinate_of_irreducible + hf hpartialSecond).2 + let : Algebra.IsSeparable (FirstCoordinateSubfield f) L := hsep + let : Algebra.IsSeparable (IntermediateField.adjoin F {x}) L := + isSeparable_over_frobeniusAdjoin_of_isSeparable_over_constantAdjoin + (K := K) (L := L) (p := p) x + have hxTrans : Transcendental K x := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + have hx0 : x ≠ 0 := by + intro hx + apply hxTrans + rw [hx] + exact isAlgebraic_zero + exact adjoin_frobeniusSubfield_pow_eq_top x hx0 m hm + +/-- The second powered coordinate alone generates the curve function field +over its Frobenius subfield. -/ +theorem adjoin_frobeniusSubfield_secondCoordinatePow_eq_top + {K : Type*} [Field K] [PerfectField K] + {p : ℕ} [Fact p.Prime] [CharP K p] + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (n : ℕ) (hn : ¬ p ∣ n) : + letI := planeCurveCoordinateRing_isDomain hf + letI : CharP (PlaneCurveFunctionField f) p := + charP_of_injective_algebraMap + (algebraMap K (PlaneCurveFunctionField f)).injective p + IntermediateField.adjoin + (frobeniusSubfield (PlaneCurveFunctionField f) p) + ({(planeCurveFunction f 1) ^ n} : Set (PlaneCurveFunctionField f)) = ⊤ := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let L := PlaneCurveFunctionField f + let : CharP L p := charP_of_injective_algebraMap + (algebraMap K L).injective p + let F := frobeniusSubfield L p + let y : L := planeCurveFunction f 1 + have hsep := (finiteSeparable_over_secondCoordinate_of_irreducible + hf hpartialFirst).2 + let : Algebra.IsSeparable (SecondCoordinateSubfield f) L := hsep + let : Algebra.IsSeparable (IntermediateField.adjoin F {y}) L := + isSeparable_over_frobeniusAdjoin_of_isSeparable_over_constantAdjoin + (K := K) (L := L) (p := p) y + have hyTrans : Transcendental K y := secondCoordinate_transcendental hf + (degreeOf_first_pos_of_pderiv_ne_zero hpartialFirst) + have hy0 : y ≠ 0 := by + intro hy + apply hyTrans + rw [hy] + exact isAlgebraic_zero + exact adjoin_frobeniusSubfield_pow_eq_top y hy0 n hn + +/-- Exact Frobenius-subfield degree of the first powered coordinate. -/ +theorem minpoly_firstCoordinatePow_natDegree_eq_char + {K : Type*} [Field K] [PerfectField K] + {p : ℕ} [Fact p.Prime] [CharP K p] + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (m : ℕ) (hm : ¬ p ∣ m) : + letI := planeCurveCoordinateRing_isDomain hf + letI : CharP (PlaneCurveFunctionField f) p := + charP_of_injective_algebraMap + (algebraMap K (PlaneCurveFunctionField f)).injective p + (minpoly (frobeniusSubfield (PlaneCurveFunctionField f) p) + ((planeCurveFunction f 0) ^ m)).natDegree = p := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let L := PlaneCurveFunctionField f + let : CharP L p := charP_of_injective_algebraMap + (algebraMap K L).injective p + let F := frobeniusSubfield L p + let x : L := planeCurveFunction f 0 + have hsep := (finiteSeparable_over_firstCoordinate_of_irreducible + hf hpartialSecond).2 + let : Algebra.IsSeparable (FirstCoordinateSubfield f) L := hsep + let : Algebra.IsSeparable (IntermediateField.adjoin F {x}) L := + isSeparable_over_frobeniusAdjoin_of_isSeparable_over_constantAdjoin + (K := K) (L := L) (p := p) x + have hxTrans : Transcendental K x := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + have hx0 : x ≠ 0 := by + intro hx + apply hxTrans + rw [hx] + exact isAlgebraic_zero + have hxNot : x ∉ F := firstCoordinate_not_mem_frobeniusSubfield + hf hpartialSecond + exact frobeniusPower_minpoly_natDegree_eq_char x hx0 hxNot m hm + +/-- Exact Frobenius-subfield degree of the second powered coordinate. -/ +theorem minpoly_secondCoordinatePow_natDegree_eq_char + {K : Type*} [Field K] [PerfectField K] + {p : ℕ} [Fact p.Prime] [CharP K p] + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (n : ℕ) (hn : ¬ p ∣ n) : + letI := planeCurveCoordinateRing_isDomain hf + letI : CharP (PlaneCurveFunctionField f) p := + charP_of_injective_algebraMap + (algebraMap K (PlaneCurveFunctionField f)).injective p + (minpoly (frobeniusSubfield (PlaneCurveFunctionField f) p) + ((planeCurveFunction f 1) ^ n)).natDegree = p := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let L := PlaneCurveFunctionField f + let : CharP L p := charP_of_injective_algebraMap + (algebraMap K L).injective p + let F := frobeniusSubfield L p + let y : L := planeCurveFunction f 1 + have hsep := (finiteSeparable_over_secondCoordinate_of_irreducible + hf hpartialFirst).2 + let : Algebra.IsSeparable (SecondCoordinateSubfield f) L := hsep + let : Algebra.IsSeparable (IntermediateField.adjoin F {y}) L := + isSeparable_over_frobeniusAdjoin_of_isSeparable_over_constantAdjoin + (K := K) (L := L) (p := p) y + have hyTrans : Transcendental K y := secondCoordinate_transcendental hf + (degreeOf_first_pos_of_pderiv_ne_zero hpartialFirst) + have hy0 : y ≠ 0 := by + intro hy + apply hyTrans + rw [hy] + exact isAlgebraic_zero + have hyNot : y ∉ F := secondCoordinate_not_mem_frobeniusSubfield + hf hpartialFirst + exact frobeniusPower_minpoly_natDegree_eq_char y hy0 hyNot n hn + +/-- One derivation with exact constant field `L^p` detects both powered plane +coordinates. This is the differential hypothesis required by the torsion +specialization. -/ +theorem exists_derivation_coordinatePowers_ne_zero + {K : Type*} [Field K] [PerfectField K] + {p : ℕ} [Fact p.Prime] [CharP K p] + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (m n : ℕ) (hm : ¬ p ∣ m) (hn : ¬ p ∣ n) : + letI := planeCurveCoordinateRing_isDomain hf + letI : CharP (PlaneCurveFunctionField f) p := + charP_of_injective_algebraMap + (algebraMap K (PlaneCurveFunctionField f)).injective p + ∃ D : Derivation + (frobeniusSubfield (PlaneCurveFunctionField f) p) + (PlaneCurveFunctionField f) (PlaneCurveFunctionField f), + D ((planeCurveFunction f 0) ^ m) ≠ 0 ∧ + D ((planeCurveFunction f 1) ^ n) ≠ 0 ∧ + ∀ z : PlaneCurveFunctionField f, D z = 0 ↔ + ∃ c : frobeniusSubfield (PlaneCurveFunctionField f) p, + algebraMap (frobeniusSubfield (PlaneCurveFunctionField f) p) + (PlaneCurveFunctionField f) c = z := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let L := PlaneCurveFunctionField f + let : CharP L p := charP_of_injective_algebraMap + (algebraMap K L).injective p + let F := frobeniusSubfield L p + let x : L := planeCurveFunction f 0 + let y : L := planeCurveFunction f 1 + have hsepX := (finiteSeparable_over_firstCoordinate_of_irreducible + hf hpartialSecond).2 + let : Algebra.IsSeparable (FirstCoordinateSubfield f) L := hsepX + let : Algebra.IsSeparable (IntermediateField.adjoin F {x}) L := + isSeparable_over_frobeniusAdjoin_of_isSeparable_over_constantAdjoin + (K := K) (L := L) (p := p) x + have hsepY := (finiteSeparable_over_secondCoordinate_of_irreducible + hf hpartialFirst).2 + let : Algebra.IsSeparable (SecondCoordinateSubfield f) L := hsepY + let : Algebra.IsSeparable (IntermediateField.adjoin F {y}) L := + isSeparable_over_frobeniusAdjoin_of_isSeparable_over_constantAdjoin + (K := K) (L := L) (p := p) y + have hxTrans : Transcendental K x := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + have hyTrans : Transcendental K y := secondCoordinate_transcendental hf + (degreeOf_first_pos_of_pderiv_ne_zero hpartialFirst) + have hx0 : x ≠ 0 := by + intro hx + apply hxTrans + rw [hx] + exact isAlgebraic_zero + have hy0 : y ≠ 0 := by + intro hy + apply hyTrans + rw [hy] + exact isAlgebraic_zero + have hxNot : x ∉ F := firstCoordinate_not_mem_frobeniusSubfield + hf hpartialSecond + have hyNot : y ∉ F := secondCoordinate_not_mem_frobeniusSubfield + hf hpartialFirst + have hynNot : y ^ n ∉ F := frobeniusPower_not_mem y hy0 hyNot n hn + obtain ⟨D, hDx, hker⟩ := + exists_derivation_power_ne_zero_with_exact_frobenius_constants + x hx0 hxNot m hm + have hDy : D (y ^ n) ≠ 0 := by + intro hzero + obtain ⟨c, hc⟩ := (hker (y ^ n)).mp hzero + apply hynNot + rw [← hc] + exact c.property + exact ⟨D, hDx, hDy, hker⟩ + +/-- Proposition 1 for powered plane coordinates, with all Frobenius and +separability obligations discharged. The remaining polynomial `g` is an +explicit relation between the powers; its irreducibility and bidegrees are +kept visible because constructing it is the genuine elimination frontier. -/ +theorem poweredCoordinates_auxiliaryFamily_linearIndependent_of_relation + {K : Type*} [Field K] [PerfectField K] + {p : ℕ} [Fact p.Prime] [CharP K p] + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (m n : ℕ) (hn : ¬ p ∣ n) : + letI := planeCurveCoordinateRing_isDomain hf + letI : CharP (PlaneCurveFunctionField f) p := + charP_of_injective_algebraMap + (algebraMap K (PlaneCurveFunctionField f)).injective p + ∀ (g : Polynomial (Polynomial + (frobeniusSubfield (PlaneCurveFunctionField f) p))) + (a b h k : ℕ), + 0 < a → 0 < h → 0 < k → + Irreducible g → + g.natDegree = a → + (transposeBivariate g).natDegree = b → + (∀ i, (g.coeff i).natDegree ≤ b) → + evalBivariate ((planeCurveFunction f 1) ^ n) + ((planeCurveFunction f 0) ^ m) g = 0 → + a * h + b * k < p → + ¬ (a ≤ k ∧ b ≤ h) → + LinearIndependent + (frobeniusSubfield (PlaneCurveFunctionField f) p) + (auxiliaryFamily ((planeCurveFunction f 0) ^ m) + ((planeCurveFunction f 1) ^ n) h k) := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let L := PlaneCurveFunctionField f + let : CharP L p := charP_of_injective_algebraMap + (algebraMap K L).injective p + let F := frobeniusSubfield L p + let x : L := planeCurveFunction f 0 + let y : L := planeCurveFunction f 1 + intro g a b h k ha hh hk hg hdegreeU hdegreeV hcoeff hzero hsize hexcluded + have hminpoly : (minpoly F (y ^ n)).natDegree = p := + minpoly_secondCoordinatePow_natDegree_eq_char hf hpartialFirst n hn + have hn0 : n ≠ 0 := by + intro hn0 + apply hn + simp [hn0] + have hnPos : 0 < n := Nat.pos_of_ne_zero hn0 + have hyTrans : Transcendental K y := secondCoordinate_transcendental hf + (degreeOf_first_pos_of_pderiv_ne_zero hpartialFirst) + have hynTrans : Transcendental K (y ^ n) := hyTrans.pow hnPos + have hynOne : y ^ n ≠ 1 := by + intro hyn + apply hynTrans + rw [hyn] + exact isAlgebraic_one + exact auxiliaryFamily_linearIndependent_of_irreducible_bidegree + g a b h k p ha hh hk hg hdegreeU hdegreeV hcoeff + (x ^ m) (y ^ n) hynOne hminpoly hzero hsize hexcluded + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/PoweredImageBaseChange.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/PoweredImageBaseChange.lean new file mode 100644 index 0000000000..692346efc6 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/PoweredImageBaseChange.lean @@ -0,0 +1,319 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PoweredImageFrobeniusRelation +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PoweredImageHeightFactor +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurvePoweredImageDegreeBudget +public import Mathlib.Tactic + +/-! +# Constant-field base change for the powered-image index + +The canonical powered-image relation remains associated to its coefficient +base change. Comparing the exact tower-degree factorizations on the two +curves then shows that the source-to-powered-image finrank is invariant under +extension of constants. This is the descent bridge from the algebraically +closed stabilizer argument to the original constant field. +-/ + +@[expose] public section + +open scoped TensorProduct Polynomial +open Polynomial + +namespace BGS.CorvajaZannier + +noncomputable section + +/-- Bivariate evaluation commutes with an extension of the coefficient +field. -/ +theorem bivariateEvalAlgHom_map_mapRingHom + {K E L : Type*} [Field K] [Field E] [CommRing L] + [Algebra K E] [Algebra K L] [Algebra E L] + [IsScalarTower K E L] + (u v : L) (P : Polynomial (Polynomial K)) : + bivariateEvalAlgHom (K := E) u v + (P.map (Polynomial.mapRingHom (algebraMap K E))) = + bivariateEvalAlgHom (K := K) u v P := by + unfold bivariateEvalAlgHom + simp only [Polynomial.eval₂AlgHom_apply] + rw [Polynomial.eval₂_map] + congr 1 + apply Polynomial.ringHom_ext + · intro c + simp [IsScalarTower.algebraMap_apply K E L] + · simp + +/-- The coefficient-extension map between affine plane-curve coordinate +rings. -/ +noncomputable def planeCurveCoordinateRingMap + {K E : Type*} [Field K] [Field E] [Algebra K E] + (f : MvPolynomial (Fin 2) K) : + PlaneCurveCoordinateRing f →ₐ[K] + PlaneCurveCoordinateRing (MvPolynomial.map (algebraMap K E) f) := by + let ι : MvPolynomial (Fin 2) K →ₐ[K] MvPolynomial (Fin 2) E := + { toRingHom := MvPolynomial.map (algebraMap K E) + commutes' := by + intro c + simp [MvPolynomial.algebraMap_eq] } + apply Ideal.quotientMapₐ + (Ideal.span {MvPolynomial.map (algebraMap K E) f}) ι + intro q hq + obtain ⟨r, rfl⟩ := Ideal.mem_span_singleton.mp hq + apply Ideal.mem_span_singleton.mpr + refine ⟨MvPolynomial.map (algebraMap K E) r, ?_⟩ + change MvPolynomial.map (algebraMap K E) (f * r) = + MvPolynomial.map (algebraMap K E) f * MvPolynomial.map (algebraMap K E) r + exact map_mul _ _ _ + +/-- The coordinate-ring base-change map preserves the two coordinate +classes. -/ +@[simp] theorem planeCurveCoordinateRingMap_coordinate + {K E : Type*} [Field K] [Field E] [Algebra K E] + (f : MvPolynomial (Fin 2) K) (i : Fin 2) : + planeCurveCoordinateRingMap (E := E) f (planeCurveCoordinate f i) = + planeCurveCoordinate (MvPolynomial.map (algebraMap K E) f) i := by + simp [planeCurveCoordinateRingMap, planeCurveCoordinate, + planeCurveQuotientMap] + +/-- The coefficient base change of the canonical powered-image relation +vanishes on the generic powered coordinates of the base-changed curve. -/ +theorem evalBivariate_poweredCoordinateImageRelation_map_eq_zero + {K E : Type*} [Field K] [Field E] [Algebra K E] + {f : MvPolynomial (Fin 2) K} + (hf : Irreducible f) + (hfE : Irreducible (MvPolynomial.map (algebraMap K E) f)) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (m : ℕ) (hm : 0 < m) (n : ℕ) : + let fE := MvPolynomial.map (algebraMap K E) f + letI := planeCurveCoordinateRing_isDomain hfE + let g := poweredCoordinateImageRelation hf hpartialSecond m hm n + evalBivariate + ((planeCurveFunction fE 0) ^ m) + ((planeCurveFunction fE 1) ^ n) + (g.map (Polynomial.mapRingHom (algebraMap K E))) = 0 := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let fE := MvPolynomial.map (algebraMap K E) f + let : IsDomain (PlaneCurveCoordinateRing fE) := + planeCurveCoordinateRing_isDomain hfE + let g := poweredCoordinateImageRelation hf hpartialSecond m hm n + let A := PlaneCurveCoordinateRing f + let AE := PlaneCurveCoordinateRing fE + let L := PlaneCurveFunctionField f + let LE := PlaneCurveFunctionField fE + let xA : A := (planeCurveCoordinate f 0) ^ m + let yA : A := (planeCurveCoordinate f 1) ^ n + let xL : L := (planeCurveFunction f 0) ^ m + let yL : L := (planeCurveFunction f 1) ^ n + let ι : A →ₐ[K] L := IsScalarTower.toAlgHom K A L + let φ : Polynomial (Polynomial K) →ₐ[K] A := + bivariateEvalAlgHom (K := K) xA yA + let ψ : Polynomial (Polynomial K) →ₐ[K] L := + bivariateEvalAlgHom (K := K) xL yL + have hcomp : ι.comp φ = ψ := by + simpa [φ, ψ, xA, xL, yA, yL, ι, planeCurveFunction] using + (bivariateEvalAlgHom_comp (K := K) ι xA yA) + have hzeroL : ψ g = 0 := by + simpa [ψ, xL, yL, g] using + (evalBivariate_poweredCoordinateImageRelation_eq_zero + hf hpartialSecond m hm n) + have hι : Function.Injective ι := by + exact IsFractionRing.injective A L + have hzeroA : φ g = 0 := by + apply hι + rw [map_zero, ← AlgHom.comp_apply, hcomp] + exact hzeroL + let ρ : A →ₐ[K] AE := planeCurveCoordinateRingMap (E := E) f + have hzeroAE : ρ (φ g) = 0 := by rw [hzeroA, map_zero] + have hx : ρ xA = (planeCurveCoordinate fE 0) ^ m := by + dsimp only [ρ, xA] + rw [map_pow, planeCurveCoordinateRingMap_coordinate] + have hy : ρ yA = (planeCurveCoordinate fE 1) ^ n := by + dsimp only [ρ, yA] + rw [map_pow, planeCurveCoordinateRingMap_coordinate] + have hcoord : bivariateEvalAlgHom (K := K) + ((planeCurveCoordinate fE 0) ^ m) + ((planeCurveCoordinate fE 1) ^ n) g = 0 := by + change (ρ.comp φ) g = 0 at hzeroAE + rw [bivariateEvalAlgHom_comp] at hzeroAE + simpa only [hx, hy] using hzeroAE + have hcoordMap : bivariateEvalAlgHom (K := E) + ((planeCurveCoordinate fE 0) ^ m) + ((planeCurveCoordinate fE 1) ^ n) + (g.map (Polynomial.mapRingHom (algebraMap K E))) = 0 := by + rw [bivariateEvalAlgHom_map_mapRingHom] + exact hcoord + let η : AE →ₐ[E] LE := IsScalarTower.toAlgHom E AE LE + have hfun := congrArg η hcoordMap + rw [map_zero] at hfun + change (η.comp (bivariateEvalAlgHom (K := E) + ((planeCurveCoordinate fE 0) ^ m) + ((planeCurveCoordinate fE 1) ^ n))) + (g.map (Polynomial.mapRingHom (algebraMap K E))) = 0 at hfun + rw [bivariateEvalAlgHom_comp] at hfun + change evalBivariate + ((η (planeCurveCoordinate fE 0)) ^ m) + ((η (planeCurveCoordinate fE 1)) ^ n) + (g.map (Polynomial.mapRingHom (algebraMap K E))) = 0 + simpa only [map_pow, bivariateEvalAlgHom_eq_evalBivariate] using hfun + +/-- The canonical powered-image relation of the base-changed curve is +associated to the coefficient base change of the original relation. -/ +theorem poweredCoordinateImageRelation_map_associated_baseChange + {K E : Type*} [Field K] [Field E] [Algebra K E] + {f : MvPolynomial (Fin 2) K} + (habsolute : Irreducible + (MvPolynomial.map (algebraMap K (AlgebraicClosure K)) f)) + (hf : Irreducible f) + (hfE : Irreducible (MvPolynomial.map (algebraMap K E) f)) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (hpartialSecondE : + MvPolynomial.pderiv 1 (MvPolynomial.map (algebraMap K E) f) ≠ 0) + (m : ℕ) (hm : 0 < m) (n : ℕ) : + Associated + (poweredCoordinateImageRelation hfE hpartialSecondE m hm n) + ((poweredCoordinateImageRelation hf hpartialSecond m hm n).map + (Polynomial.mapRingHom (algebraMap K E))) := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let fE := MvPolynomial.map (algebraMap K E) f + let : IsDomain (PlaneCurveCoordinateRing fE) := + planeCurveCoordinateRing_isDomain hfE + let LE := PlaneCurveFunctionField fE + let : FiniteDimensional (FirstPoweredCoordinateSubfield fE m) LE := + finiteDimensional_over_firstPoweredCoordinate hfE hpartialSecondE m hm + have hv : IsIntegral (FirstPoweredCoordinateSubfield fE m) + ((planeCurveFunction fE 1) ^ n) := IsIntegral.of_finite _ _ + have hdvd : + poweredCoordinateImageRelation hfE hpartialSecondE m hm n ∣ + (poweredCoordinateImageRelation hf hpartialSecond m hm n).map + (Polynomial.mapRingHom (algebraMap K E)) := by + change primitiveClearedMinpolyRelation + ((planeCurveFunction fE 0) ^ m) + (firstPoweredCoordinate_transcendental + hfE hpartialSecondE m hm) + ((planeCurveFunction fE 1) ^ n) ∣ _ + exact primitiveClearedMinpolyRelation_dvd_of_evalBivariate_eq_zero + ((planeCurveFunction fE 0) ^ m) + (firstPoweredCoordinate_transcendental hfE hpartialSecondE m hm) + ((planeCurveFunction fE 1) ^ n) hv _ + (evalBivariate_poweredCoordinateImageRelation_map_eq_zero + hf hfE hpartialSecond m hm n) + exact (poweredCoordinateImageRelation_irreducible + hfE hpartialSecondE m hm n).associated_of_dvd + (poweredCoordinateImageRelation_irreducible_map + (E := E) habsolute hf hpartialSecond m hm n) hdvd + +/-- The relevant powered-image relation degree is invariant under extension +of constants. -/ +theorem poweredCoordinateImageRelation_map_natDegree_eq_baseChange + {K E : Type*} [Field K] [Field E] [Algebra K E] + {f : MvPolynomial (Fin 2) K} + (habsolute : Irreducible + (MvPolynomial.map (algebraMap K (AlgebraicClosure K)) f)) + (hf : Irreducible f) + (hfE : Irreducible (MvPolynomial.map (algebraMap K E) f)) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (hpartialSecondE : + MvPolynomial.pderiv 1 (MvPolynomial.map (algebraMap K E) f) ≠ 0) + (m : ℕ) (hm : 0 < m) (n : ℕ) : + (poweredCoordinateImageRelation hfE hpartialSecondE m hm n).natDegree = + (poweredCoordinateImageRelation hf hpartialSecond m hm n).natDegree := by + let gE := poweredCoordinateImageRelation hfE hpartialSecondE m hm n + let gMap := (poweredCoordinateImageRelation hf hpartialSecond m hm n).map + (Polynomial.mapRingHom (algebraMap K E)) + have hassoc : Associated gE gMap := + poweredCoordinateImageRelation_map_associated_baseChange + habsolute hf hfE hpartialSecond hpartialSecondE m hm n + have hgE0 : gE ≠ 0 := (poweredCoordinateImageRelation_irreducible + hfE hpartialSecondE m hm n).ne_zero + have hgMap0 : gMap ≠ 0 := (poweredCoordinateImageRelation_irreducible_map + (E := E) habsolute hf hpartialSecond m hm n).ne_zero + have hle : gE.natDegree ≤ gMap.natDegree := + Polynomial.natDegree_le_of_dvd hassoc.dvd hgMap0 + have hge : gMap.natDegree ≤ gE.natDegree := + Polynomial.natDegree_le_of_dvd hassoc.symm.dvd hgE0 + have hmapDegree : gMap.natDegree = + (poweredCoordinateImageRelation hf hpartialSecond m hm n).natDegree := + Polynomial.natDegree_map_eq_of_injective + (Polynomial.map_injective (algebraMap K E) (algebraMap K E).injective) _ + exact (Nat.le_antisymm hle hge).trans hmapDegree + +/-- Extension of constants preserves the common source-to-powered-image +degree. -/ +theorem finrank_poweredCoordinateImageField_eq_baseChange + {K E : Type*} [Field K] [Field E] [Algebra K E] + {f : MvPolynomial (Fin 2) K} + (habsolute : Irreducible + (MvPolynomial.map (algebraMap K (AlgebraicClosure K)) f)) + (hf : Irreducible f) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (m : ℕ) (hm : 0 < m) (n : ℕ) : + let fE := MvPolynomial.map (algebraMap K E) f + let hfE := irreducible_map_of_irreducible_map_algebraicClosure + (algebraMap K E) f habsolute + letI := planeCurveCoordinateRing_isDomain hf + letI := planeCurveCoordinateRing_isDomain hfE + Module.finrank (PoweredCoordinateImageField f m n) + (PlaneCurveFunctionField f) = + Module.finrank (PoweredCoordinateImageField fE m n) + (PlaneCurveFunctionField fE) := by + let fE := MvPolynomial.map (algebraMap K E) f + let hfE : Irreducible fE := + irreducible_map_of_irreducible_map_algebraicClosure + (algebraMap K E) f habsolute + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let : IsDomain (PlaneCurveCoordinateRing fE) := + planeCurveCoordinateRing_isDomain hfE + have hpartialSecondE : MvPolynomial.pderiv 1 fE ≠ 0 := by + rw [MvPolynomial.pderiv_map] + intro hz + apply hpartialSecond + apply MvPolynomial.map_injective (algebraMap K E) (algebraMap K E).injective + simpa using hz + let aK := (poweredCoordinateImageRelation hf hpartialSecond m hm n).natDegree + let aE := (poweredCoordinateImageRelation hfE hpartialSecondE m hm n).natDegree + let dK := Module.finrank (PoweredImageOverFirst f m n) + (PlaneCurveFunctionField f) + let dE := Module.finrank (PoweredImageOverFirst fE m n) + (PlaneCurveFunctionField fE) + have ha : aE = aK := + poweredCoordinateImageRelation_map_natDegree_eq_baseChange + habsolute hf hfE hpartialSecond hpartialSecondE m hm n + have hK : aK * dK = m * MvPolynomial.degreeOf 1 f := + poweredCoordinateImageRelation_natDegree_mul_commonIndex + hf hpartialSecond m n hm + have hE : aE * dE = m * MvPolynomial.degreeOf 1 fE := + poweredCoordinateImageRelation_natDegree_mul_commonIndex + hfE hpartialSecondE m n hm + have hdegree : MvPolynomial.degreeOf 1 fE = MvPolynomial.degreeOf 1 f := + degreeOf_map_eq_of_injective (algebraMap K E) + (algebraMap K E).injective 1 f + have hprod : aK * dK = aK * dE := by + calc + aK * dK = m * MvPolynomial.degreeOf 1 f := hK + _ = m * MvPolynomial.degreeOf 1 fE := by rw [hdegree] + _ = aE * dE := hE.symm + _ = aK * dE := by rw [ha] + have haPos : 0 < aK := + poweredCoordinateImageRelation_natDegree_pos + hf hpartialSecond m hm n + have hd : dK = dE := Nat.eq_of_mul_eq_mul_left haPos hprod + calc + Module.finrank (PoweredCoordinateImageField f m n) + (PlaneCurveFunctionField f) = dK := + (finrank_poweredImageOverFirst_eq_imageField m n).symm + _ = dE := hd + _ = Module.finrank (PoweredCoordinateImageField fE m n) + (PlaneCurveFunctionField fE) := + finrank_poweredImageOverFirst_eq_imageField m n + +end +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/PoweredImageCurve.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/PoweredImageCurve.lean new file mode 100644 index 0000000000..7d819bf5d6 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/PoweredImageCurve.lean @@ -0,0 +1,927 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PoweredCoordinateRelation +public import Mathlib.FieldTheory.RatFunc.AsPolynomial +public import Mathlib.RingTheory.Polynomial.GaussLemma + +/-! +# The actual powered-coordinate image curve + +For a plane curve with function-field coordinates `x,y`, this file defines +the intermediate field `K(x^m,y^n)` and controls its two projection degrees. +It then transports the minimal polynomial of `y^n` over `K(x^m)` to the +standard rational-function field, clears denominators, takes the primitive +part, and applies Gauss' lemma. The resulting polynomial in `K[U,V]` is +irreducible, vanishes at `(x^m,y^n)`, and has coordinate degrees exactly the +two projection degrees of the powered image. + +Consequently its degree in `y^n` is at most `m * degreeOf 1 f`, while its +degree in `x^m` is at most `n * degreeOf 0 f`. This is the source-sensitive +elimination input needed for the Corvaja--Zannier middle game. +-/ + +@[expose] public section + +namespace BGS.CorvajaZannier + +noncomputable section + +open scoped nonZeroDivisors Polynomial + +variable {K L : Type*} [Field K] [Field L] [Algebra K L] + +theorem adjoin_pow_le_adjoin (z : L) (m : ℕ) : + IntermediateField.adjoin K {z ^ m} ≤ IntermediateField.adjoin K {z} := by + apply IntermediateField.adjoin_le_iff.mpr + intro w hw + rw [Set.mem_singleton_iff] at hw + subst w + exact (IntermediateField.adjoin K {z}).toSubalgebra.pow_mem + (IntermediateField.subset_adjoin K {z} (Set.mem_singleton z)) m + +theorem restrictScalars_adjoin_over_adjoin_pow_eq_adjoin + (z : L) (m : ℕ) : + (IntermediateField.adjoin (IntermediateField.adjoin K {z ^ m}) {z}).restrictScalars K = + IntermediateField.adjoin K {z} := by + rw [IntermediateField.restrictScalars_adjoin_eq_sup] + exact sup_eq_right.mpr (adjoin_pow_le_adjoin z m) + +theorem finrank_adjoin_over_adjoin_pow_le + (z : L) (m : ℕ) (hm : 0 < m) : + Module.finrank (IntermediateField.adjoin K {z ^ m}) + (IntermediateField.adjoin (IntermediateField.adjoin K {z ^ m}) {z}) ≤ m := by + let E0 := IntermediateField.adjoin K {z ^ m} + let c : E0 := + ⟨z ^ m, IntermediateField.subset_adjoin K {z ^ m} (Set.mem_singleton (z ^ m))⟩ + let q : Polynomial E0 := Polynomial.X ^ m - Polynomial.C c + have hqMonic : q.Monic := Polynomial.monic_X_pow_sub_C c hm.ne' + have hqRoot : Polynomial.aeval z q = 0 := by + simp [q, c] + have hzIntegral : IsIntegral E0 z := ⟨q, hqMonic, hqRoot⟩ + have hqNe : q ≠ 0 := hqMonic.ne_zero + calc + Module.finrank E0 (IntermediateField.adjoin E0 {z}) = + (minpoly E0 z).natDegree := + IntermediateField.adjoin.finrank hzIntegral + _ ≤ q.natDegree := + Polynomial.natDegree_le_of_dvd (minpoly.dvd E0 z hqRoot) hqNe + _ = m := by simp [q] + +theorem finiteDimensional_over_adjoin_pow + (z : L) (m : ℕ) (hm : 0 < m) + [FiniteDimensional (IntermediateField.adjoin K {z}) L] : + FiniteDimensional (IntermediateField.adjoin K {z ^ m}) L := by + let E0 := IntermediateField.adjoin K {z ^ m} + let A := IntermediateField.adjoin E0 {z} + let AK : IntermediateField K L := + IntermediateField.restrictScalars (L' := E0) K A + have hA : AK = IntermediateField.adjoin K {z} := by + exact restrictScalars_adjoin_over_adjoin_pow_eq_adjoin z m + let c : E0 := + ⟨z ^ m, IntermediateField.subset_adjoin K {z ^ m} (Set.mem_singleton (z ^ m))⟩ + let q : Polynomial E0 := Polynomial.X ^ m - Polynomial.C c + have hqMonic : q.Monic := Polynomial.monic_X_pow_sub_C c hm.ne' + have hqRoot : Polynomial.aeval z q = 0 := by simp [q, c] + have hzIntegral : IsIntegral E0 z := ⟨q, hqMonic, hqRoot⟩ + let : FiniteDimensional E0 A := + IntermediateField.adjoin.finiteDimensional hzIntegral + let : FiniteDimensional A L := by + change FiniteDimensional AK L + rw [hA] + infer_instance + exact FiniteDimensional.trans E0 A L + +theorem finrank_over_adjoin_pow_le_mul + (z : L) (m d : ℕ) (hm : 0 < m) + [FiniteDimensional (IntermediateField.adjoin K {z}) L] + (hdegree : Module.finrank (IntermediateField.adjoin K {z}) L ≤ d) : + Module.finrank (IntermediateField.adjoin K {z ^ m}) L ≤ m * d := by + let E0 := IntermediateField.adjoin K {z ^ m} + let A := IntermediateField.adjoin E0 {z} + let AK : IntermediateField K L := + IntermediateField.restrictScalars (L' := E0) K A + have hA : AK = IntermediateField.adjoin K {z} := by + exact restrictScalars_adjoin_over_adjoin_pow_eq_adjoin z m + let c : E0 := + ⟨z ^ m, IntermediateField.subset_adjoin K {z ^ m} (Set.mem_singleton (z ^ m))⟩ + let q : Polynomial E0 := Polynomial.X ^ m - Polynomial.C c + have hqMonic : q.Monic := Polynomial.monic_X_pow_sub_C c hm.ne' + have hqRoot : Polynomial.aeval z q = 0 := by simp [q, c] + have hzIntegral : IsIntegral E0 z := ⟨q, hqMonic, hqRoot⟩ + let : FiniteDimensional E0 A := + IntermediateField.adjoin.finiteDimensional hzIntegral + let : FiniteDimensional A L := by + change FiniteDimensional AK L + rw [hA] + infer_instance + have hrelative : Module.finrank E0 A ≤ m := + finrank_adjoin_over_adjoin_pow_le z m hm + have htop : Module.finrank A L ≤ d := by + change Module.finrank AK L ≤ d + rw [hA] + exact hdegree + have : Module.Free A L := Module.Free.of_divisionRing A L + have : Module.Free E0 A := Module.Free.of_divisionRing E0 A + calc + Module.finrank E0 L = Module.finrank E0 A * Module.finrank A L := by + rw [Module.finrank_mul_finrank] + _ ≤ m * d := Nat.mul_le_mul hrelative htop + +/-! ## Clearing the minimal polynomial over a rational coordinate field -/ + +/-- Transport the minimal polynomial of `v` over `K(u)` to the standard +rational-function field `K(X)`. -/ +noncomputable def ratFuncMinpoly + (u : L) (hu : Transcendental K u) (v : L) : Polynomial (RatFunc K) := + (minpoly (IntermediateField.adjoin K {u}) v).map + (RatFunc.algEquivOfTranscendental u hu).symm.toRingEquiv + +/-- Clear the coefficient denominators in the transported minimal +polynomial. This is an iterated polynomial over `K`. -/ +noncomputable def integerClearedMinpoly + (u : L) (hu : Transcendental K u) (v : L) : + Polynomial (Polynomial K) := + IsLocalization.integerNormalization (nonZeroDivisors (Polynomial K)) + (ratFuncMinpoly u hu v) + +/-- The primitive bivariate relation obtained from the minimal polynomial +of `v` over `K(u)`. -/ +noncomputable def primitiveClearedMinpolyRelation + (u : L) (hu : Transcendental K u) (v : L) : + Polynomial (Polynomial K) := by + letI := Classical.arbitrary (NormalizedGCDMonoid K) + exact (integerClearedMinpoly u hu v).primPart + +theorem ratFuncMinpoly_ne_zero + (u : L) (hu : Transcendental K u) (v : L) + (hv : IsIntegral (IntermediateField.adjoin K {u}) v) : + ratFuncMinpoly u hu v ≠ 0 := by + exact Polynomial.map_ne_zero (minpoly.ne_zero hv) + +theorem ratFuncMinpoly_irreducible + (u : L) (hu : Transcendental K u) (v : L) + (hv : IsIntegral (IntermediateField.adjoin K {u}) v) : + Irreducible (ratFuncMinpoly u hu v) := by + let e := RatFunc.algEquivOfTranscendental u hu + have h := (minpoly.irreducible hv).map (Polynomial.mapEquiv e.symm.toRingEquiv) + simpa only [ratFuncMinpoly, e, Polynomial.mapEquiv_apply] using h + +theorem integerClearedMinpoly_ne_zero + (u : L) (hu : Transcendental K u) (v : L) + (hv : IsIntegral (IntermediateField.adjoin K {u}) v) : + integerClearedMinpoly u hu v ≠ 0 := by + exact IsFractionRing.integerNormalization_eq_zero_iff.not.mpr + (ratFuncMinpoly_ne_zero u hu v hv) + +theorem primitiveClearedMinpolyRelation_ne_zero + (u : L) (hu : Transcendental K u) (v : L) : + primitiveClearedMinpolyRelation u hu v ≠ 0 := by + let := Classical.arbitrary (NormalizedGCDMonoid K) + exact (integerClearedMinpoly u hu v).primPart_ne_zero + +theorem primitiveClearedMinpolyRelation_natDegree + (u : L) (hu : Transcendental K u) (v : L) + (hv : IsIntegral (IntermediateField.adjoin K {u}) v) : + (primitiveClearedMinpolyRelation u hu v).natDegree = + (minpoly (IntermediateField.adjoin K {u}) v).natDegree := by + let := Classical.arbitrary (NormalizedGCDMonoid K) + let q := ratFuncMinpoly u hu v + let N := integerClearedMinpoly u hu v + obtain ⟨b, hb, hmap⟩ := + IsLocalization.integerNormalization_spec + (nonZeroDivisors (Polynomial K)) q + have hb0 : b ≠ 0 := nonZeroDivisors.ne_zero hb + have hqb0 : algebraMap (Polynomial K) (RatFunc K) b ≠ 0 := + (FaithfulSMul.algebraMap_eq_zero_iff (Polynomial K) (RatFunc K)).not.mpr hb0 + have hq0 : q ≠ 0 := ratFuncMinpoly_ne_zero u hu v hv + calc + (primitiveClearedMinpolyRelation u hu v).natDegree = N.natDegree := by + exact Polynomial.natDegree_primPart N + _ = (N.map (algebraMap (Polynomial K) (RatFunc K))).natDegree := by + symm + exact Polynomial.natDegree_map_eq_of_injective + (IsFractionRing.injective (Polynomial K) (RatFunc K)) N + _ = q.natDegree := by + change (Polynomial.map (algebraMap (Polynomial K) (RatFunc K)) + (IsLocalization.integerNormalization + (nonZeroDivisors (Polynomial K)) q)).natDegree = q.natDegree + rw [hmap, Algebra.smul_def] + change (Polynomial.C (algebraMap (Polynomial K) (RatFunc K) b) * q).natDegree = + q.natDegree + exact Polynomial.natDegree_C_mul hqb0 + _ = (minpoly (IntermediateField.adjoin K {u}) v).natDegree := by + exact Polynomial.natDegree_map_eq_of_injective + (RatFunc.algEquivOfTranscendental u hu).symm.injective _ + +/-- After embedding the coefficient ring in `K(X)`, the primitive cleared +relation is a nonzero constant multiple of the transported minimal +polynomial. -/ +theorem map_primitiveClearedMinpolyRelation_eq_C_mul + (u : L) (hu : Transcendental K u) (v : L) + (hv : IsIntegral (IntermediateField.adjoin K {u}) v) : + ∃ c : RatFunc K, c ≠ 0 ∧ + (primitiveClearedMinpolyRelation u hu v).map + (algebraMap (Polynomial K) (RatFunc K)) = + Polynomial.C c * ratFuncMinpoly u hu v := by + let := Classical.arbitrary (NormalizedGCDMonoid K) + let q := ratFuncMinpoly u hu v + let N := integerClearedMinpoly u hu v + let g := primitiveClearedMinpolyRelation u hu v + obtain ⟨b, hb, hmap⟩ := + IsLocalization.integerNormalization_spec + (nonZeroDivisors (Polynomial K)) q + have hb0 : b ≠ 0 := nonZeroDivisors.ne_zero hb + have hN0 : N ≠ 0 := integerClearedMinpoly_ne_zero u hu v hv + have hcontent0 : N.content ≠ 0 := + Polynomial.content_eq_zero_iff.not.mpr hN0 + let a : RatFunc K := algebraMap (Polynomial K) (RatFunc K) N.content + let b' : RatFunc K := algebraMap (Polynomial K) (RatFunc K) b + have ha0 : a ≠ 0 := by + exact (FaithfulSMul.algebraMap_eq_zero_iff + (Polynomial K) (RatFunc K)).not.mpr hcontent0 + have hb'0 : b' ≠ 0 := by + exact (FaithfulSMul.algebraMap_eq_zero_iff + (Polynomial K) (RatFunc K)).not.mpr hb0 + have hdecomp : + N.map (algebraMap (Polynomial K) (RatFunc K)) = + Polynomial.C a * g.map (algebraMap (Polynomial K) (RatFunc K)) := by + rw [N.eq_C_content_mul_primPart, Polynomial.map_mul, Polynomial.map_C] + rfl + have hmap' : + N.map (algebraMap (Polynomial K) (RatFunc K)) = + Polynomial.C b' * q := by + change (IsLocalization.integerNormalization + (nonZeroDivisors (Polynomial K)) q).map + (algebraMap (Polynomial K) (RatFunc K)) = Polynomial.C b' * q + rw [hmap, Algebra.smul_def] + rfl + have hab : + Polynomial.C a * g.map (algebraMap (Polynomial K) (RatFunc K)) = + Polynomial.C b' * q := hdecomp.symm.trans hmap' + refine ⟨a⁻¹ * b', mul_ne_zero (inv_ne_zero ha0) hb'0, ?_⟩ + change g.map (algebraMap (Polynomial K) (RatFunc K)) = + Polynomial.C (a⁻¹ * b') * q + calc + g.map (algebraMap (Polynomial K) (RatFunc K)) = + Polynomial.C a⁻¹ * + (Polynomial.C a * + g.map (algebraMap (Polynomial K) (RatFunc K))) := by + rw [← mul_assoc, ← Polynomial.C_mul, inv_mul_cancel₀ ha0, + Polynomial.C_1, one_mul] + _ = Polynomial.C a⁻¹ * (Polynomial.C b' * q) := by rw [hab] + _ = Polynomial.C (a⁻¹ * b') * q := by + rw [← mul_assoc, ← Polynomial.C_mul] + +/-- The cleared minimal-polynomial relation is irreducible in `K[U,V]`. -/ +theorem primitiveClearedMinpolyRelation_irreducible + (u : L) (hu : Transcendental K u) (v : L) + (hv : IsIntegral (IntermediateField.adjoin K {u}) v) : + Irreducible (primitiveClearedMinpolyRelation u hu v) := by + let := Classical.arbitrary (NormalizedGCDMonoid K) + let q := ratFuncMinpoly u hu v + let g := primitiveClearedMinpolyRelation u hu v + obtain ⟨c, hc0, hmap⟩ := + map_primitiveClearedMinpolyRelation_eq_C_mul u hu v hv + have hunit : IsUnit (Polynomial.C c : Polynomial (RatFunc K)) := + Polynomial.isUnit_C.mpr hc0.isUnit + have hassociated : Associated + (g.map (algebraMap (Polynomial K) (RatFunc K))) q := by + rw [hmap] + simpa only [mul_comm] using + associated_mul_unit_left q (Polynomial.C c) hunit + have hmapIrreducible : + Irreducible (g.map (algebraMap (Polynomial K) (RatFunc K))) := + hassociated.symm.irreducible (ratFuncMinpoly_irreducible u hu v hv) + exact (integerClearedMinpoly u hu v).isPrimitive_primPart + |>.irreducible_iff_irreducible_map_fraction_map.mpr hmapIrreducible + +/-- Specialize the rational-function variable `X` at a transcendental +element `u`, then include `K(u)` in the ambient field. -/ +noncomputable def ratFuncSpecialization + (u : L) (hu : Transcendental K u) : RatFunc K →+* L := + (algebraMap (IntermediateField.adjoin K {u}) L).comp + (RatFunc.algEquivOfTranscendental u hu).toRingEquiv.toRingHom + +theorem ratFuncSpecialization_comp_polynomial_algebraMap + (u : L) (hu : Transcendental K u) : + (ratFuncSpecialization u hu).comp + (algebraMap (Polynomial K) (RatFunc K)) = + Polynomial.eval₂RingHom (algebraMap K L) u := by + apply Polynomial.ringHom_ext + · intro c + simp only [ratFuncSpecialization, RingEquiv.toRingHom_eq_coe, AlgEquiv.toRingEquiv_toRingHom, + RingHom.coe_comp, RingHom.coe_coe, Function.comp_apply, RatFunc.algebraMap_C, + IntermediateField.algebraMap_apply, Polynomial.coe_eval₂RingHom, Polynomial.eval₂_C] + rw [← RatFunc.algebraMap_eq_C, + (RatFunc.algEquivOfTranscendental u hu).commutes] + rfl + · simp [ratFuncSpecialization, + RatFunc.algEquivOfTranscendental_X] + +theorem ratFuncSpecialization_comp_symm_algEquiv + (u : L) (hu : Transcendental K u) : + (ratFuncSpecialization u hu).comp + (RatFunc.algEquivOfTranscendental u hu).symm.toRingEquiv.toRingHom = + algebraMap (IntermediateField.adjoin K {u}) L := by + ext z + simp [ratFuncSpecialization] + +/-- Evaluation of an iterated polynomial at `(u,v)` agrees with first +mapping its coefficient polynomials to `K(X)` and then specializing `X` at +`u`. -/ +theorem evalBivariate_eq_eval₂_ratFuncSpecialization_map + (u : L) (hu : Transcendental K u) (v : L) + (P : Polynomial (Polynomial K)) : + evalBivariate u v P = + Polynomial.eval₂ (ratFuncSpecialization u hu) v + (P.map (algebraMap (Polynomial K) (RatFunc K))) := by + rw [Polynomial.eval₂_map, + ratFuncSpecialization_comp_polynomial_algebraMap] + rfl + +/-- The transported minimal polynomial vanishes after specializing the +rational-function variable at `u` and the outer variable at `v`. -/ +theorem eval₂_ratFuncSpecialization_ratFuncMinpoly_eq_zero + (u : L) (hu : Transcendental K u) (v : L) : + Polynomial.eval₂ (ratFuncSpecialization u hu) v + (ratFuncMinpoly u hu v) = 0 := by + rw [ratFuncMinpoly, Polynomial.eval₂_map] + change Polynomial.eval₂ + ((ratFuncSpecialization u hu).comp + (RatFunc.algEquivOfTranscendental u hu).symm.toRingEquiv.toRingHom) + v (minpoly (IntermediateField.adjoin K {u}) v) = 0 + rw [ratFuncSpecialization_comp_symm_algEquiv] + exact minpoly.aeval (IntermediateField.adjoin K {u}) v + +/-- The primitive cleared relation really vanishes at `(u,v)`. -/ +theorem evalBivariate_primitiveClearedMinpolyRelation_eq_zero + (u : L) (hu : Transcendental K u) (v : L) + (hv : IsIntegral (IntermediateField.adjoin K {u}) v) : + evalBivariate u v (primitiveClearedMinpolyRelation u hu v) = 0 := by + rw [evalBivariate_eq_eval₂_ratFuncSpecialization_map u hu v] + obtain ⟨c, hc, hmap⟩ := + map_primitiveClearedMinpolyRelation_eq_C_mul u hu v hv + rw [hmap, Polynomial.eval₂_mul, Polynomial.eval₂_C, + eval₂_ratFuncSpecialization_ratFuncMinpoly_eq_zero u hu v, mul_zero] + +/-- Swapping the two variables preserves irreducibility. -/ +theorem irreducible_transposeBivariate + {P : Polynomial (Polynomial K)} (hP : Irreducible P) : + Irreducible (transposeBivariate P) := by + rw [transposeBivariate_eq_bivariateSwap] + change Irreducible ((Polynomial.Bivariate.swap (R := K)) P) + exact hP.map (Polynomial.Bivariate.swap (R := K)) + +/-- An irreducible relation vanishing at a pair whose first coordinate is +transcendental must genuinely depend on its outer variable. Applied after +swapping, this says the original relation genuinely depends on its inner +variable. -/ +theorem transposeBivariate_natDegree_ne_zero_of_eval_eq_zero + (u v : L) (hv : Transcendental K v) + {P : Polynomial (Polynomial K)} (hP : Irreducible P) + (hzero : evalBivariate u v P = 0) : + (transposeBivariate P).natDegree ≠ 0 := by + let Q := transposeBivariate P + have hzeroQ : evalBivariate v u Q = 0 := by + change evalBivariate v u (transposeBivariate P) = 0 + rw [evalBivariate_transposeBivariate] + exact hzero + intro hdegree + have hQ : Q = Polynomial.C (Q.coeff 0) := + Polynomial.eq_C_of_natDegree_eq_zero hdegree + have hcoeffEval : + Polynomial.eval₂ (algebraMap K L) v (Q.coeff 0) = 0 := by + have hzeroQ' := hzeroQ + rw [hQ] at hzeroQ' + unfold evalBivariate at hzeroQ' + rw [Polynomial.eval₂_C] at hzeroQ' + exact hzeroQ' + have hcoeff : Q.coeff 0 = 0 := by + have hinj : Function.Injective + (Polynomial.aeval (R := K) v : Polynomial K →ₐ[K] L) := + transcendental_iff_injective.mp hv + apply hinj + simpa only [Polynomial.aeval_def, map_zero] using hcoeffEval + have hQzero : Q = 0 := by rw [hQ, hcoeff, map_zero] + apply hP.ne_zero + apply transposeBivariate_injective + have hQzero' : transposeBivariate P = 0 := by + simpa only [Q] using hQzero + simpa only [map_zero] using hQzero' + +/-- For an irreducible bivariate relation at a transcendental pair, the +degree in the first coordinate is exactly the minimal-polynomial degree over +the rational field generated by the second coordinate. -/ +theorem transposeBivariate_natDegree_eq_minpoly + (u v : L) (hvTrans : Transcendental K v) + {P : Polynomial (Polynomial K)} (hP : Irreducible P) + (hzero : evalBivariate u v P = 0) : + (transposeBivariate P).natDegree = + (minpoly (IntermediateField.adjoin K {v}) u).natDegree := by + let := Classical.arbitrary (NormalizedGCDMonoid K) + let Q := transposeBivariate P + let e := RatFunc.algEquivOfTranscendental v hvTrans + let qRat : Polynomial (RatFunc K) := + Q.map (algebraMap (Polynomial K) (RatFunc K)) + let qAdjoin : Polynomial (IntermediateField.adjoin K {v}) := + qRat.map e.toRingEquiv + have hQIrreducible : Irreducible Q := + irreducible_transposeBivariate hP + have hQDegree : Q.natDegree ≠ 0 := + transposeBivariate_natDegree_ne_zero_of_eval_eq_zero + u v hvTrans hP hzero + have hQPrimitive : Q.IsPrimitive := + hQIrreducible.isPrimitive hQDegree + have hqRatIrreducible : Irreducible qRat := by + exact hQPrimitive.irreducible_iff_irreducible_map_fraction_map.mp + hQIrreducible + have hqAdjoinIrreducible : Irreducible qAdjoin := by + have h := hqRatIrreducible.map (Polynomial.mapEquiv e.toRingEquiv) + simpa only [qAdjoin, Polynomial.mapEquiv_apply] using h + have hzeroQ : evalBivariate v u Q = 0 := by + change evalBivariate v u (transposeBivariate P) = 0 + rw [evalBivariate_transposeBivariate] + exact hzero + have hqAdjoinRootEval : + Polynomial.eval₂ + (algebraMap (IntermediateField.adjoin K {v}) L) u qAdjoin = 0 := by + dsimp only [qAdjoin] + rw [Polynomial.eval₂_map] + change Polynomial.eval₂ (ratFuncSpecialization v hvTrans) u qRat = 0 + rw [← evalBivariate_eq_eval₂_ratFuncSpecialization_map v hvTrans u Q] + exact hzeroQ + have hqAdjoinRoot : Polynomial.aeval u qAdjoin = 0 := by + simpa only [Polynomial.aeval_def] using hqAdjoinRootEval + have heq := minpoly.eq_of_irreducible hqAdjoinIrreducible hqAdjoinRoot + have hminDegree : + (minpoly (IntermediateField.adjoin K {v}) u).natDegree = + qAdjoin.natDegree := by + calc + (minpoly (IntermediateField.adjoin K {v}) u).natDegree = + (qAdjoin * Polynomial.C qAdjoin.leadingCoeff⁻¹).natDegree := by + rw [heq] + _ = qAdjoin.natDegree := Polynomial.natDegree_mul_C + (inv_ne_zero + (Polynomial.leadingCoeff_ne_zero.mpr hqAdjoinIrreducible.ne_zero)) + calc + (transposeBivariate P).natDegree = Q.natDegree := rfl + _ = qRat.natDegree := by + symm + exact Polynomial.natDegree_map_eq_of_injective + (IsFractionRing.injective (Polynomial K) (RatFunc K)) Q + _ = qAdjoin.natDegree := by + symm + exact Polynomial.natDegree_map_eq_of_injective e.injective qRat + _ = (minpoly (IntermediateField.adjoin K {v}) u).natDegree := + hminDegree.symm + +/-! ## Powered coordinate fields of a plane curve -/ + +/-- The rational subfield generated by the powered first coordinate. -/ +abbrev FirstPoweredCoordinateSubfield + {K : Type*} [Field K] (f : MvPolynomial (Fin 2) K) + [IsDomain (PlaneCurveCoordinateRing f)] (m : ℕ) := + IntermediateField.adjoin K + ({(planeCurveFunction f 0) ^ m} : Set (PlaneCurveFunctionField f)) + +/-- The rational subfield generated by the powered second coordinate. -/ +abbrev SecondPoweredCoordinateSubfield + {K : Type*} [Field K] (f : MvPolynomial (Fin 2) K) + [IsDomain (PlaneCurveCoordinateRing f)] (n : ℕ) := + IntermediateField.adjoin K + ({(planeCurveFunction f 1) ^ n} : Set (PlaneCurveFunctionField f)) + +/-- The function field of the image of the powered-coordinate map, realized +inside the source function field. -/ +abbrev PoweredCoordinateImageField + {K : Type*} [Field K] (f : MvPolynomial (Fin 2) K) + [IsDomain (PlaneCurveCoordinateRing f)] (m n : ℕ) := + IntermediateField.adjoin K + ({(planeCurveFunction f 0) ^ m, (planeCurveFunction f 1) ^ n} : + Set (PlaneCurveFunctionField f)) + +/-- A positive power of the first coordinate remains transcendental. -/ +theorem firstPoweredCoordinate_transcendental + {K : Type*} [Field K] {f : MvPolynomial (Fin 2) K} + (hf : Irreducible f) (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (m : ℕ) (hm : 0 < m) : + letI := planeCurveCoordinateRing_isDomain hf + Transcendental K ((planeCurveFunction f 0) ^ m) := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + exact (firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond)).pow hm + +/-- A positive power of the second coordinate remains transcendental. -/ +theorem secondPoweredCoordinate_transcendental + {K : Type*} [Field K] {f : MvPolynomial (Fin 2) K} + (hf : Irreducible f) (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (n : ℕ) (hn : 0 < n) : + letI := planeCurveCoordinateRing_isDomain hf + Transcendental K ((planeCurveFunction f 1) ^ n) := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + exact (secondCoordinate_transcendental hf + (degreeOf_first_pos_of_pderiv_ne_zero hpartialFirst)).pow hn + +/-- The canonical irreducible equation of the powered-coordinate image, +obtained by clearing the minimal polynomial over `K(x^m)`. The outer +variable is the powered second coordinate. -/ +noncomputable def poweredCoordinateImageRelation + {K : Type*} [Field K] {f : MvPolynomial (Fin 2) K} + (hf : Irreducible f) (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (m : ℕ) (hm : 0 < m) (n : ℕ) : Polynomial (Polynomial K) := by + letI : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + exact primitiveClearedMinpolyRelation + ((planeCurveFunction f 0) ^ m) + (firstPoweredCoordinate_transcendental hf hpartialSecond m hm) + ((planeCurveFunction f 1) ^ n) + +/-- The source function field is finite over the field generated by a +positive power of its first coordinate. -/ +theorem finiteDimensional_over_firstPoweredCoordinate + {K : Type*} [Field K] {f : MvPolynomial (Fin 2) K} + (hf : Irreducible f) (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (m : ℕ) (hm : 0 < m) : + letI := planeCurveCoordinateRing_isDomain hf + FiniteDimensional (FirstPoweredCoordinateSubfield f m) + (PlaneCurveFunctionField f) := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let : FiniteDimensional (FirstCoordinateSubfield f) + (PlaneCurveFunctionField f) := + finiteDimensional_over_firstCoordinate_of_irreducible hf hpartialSecond + exact finiteDimensional_over_adjoin_pow + (planeCurveFunction f 0) m hm + +/-- Raising the first coordinate to the `m`-th power multiplies the source +degree bound by at most `m`. -/ +theorem finrank_over_firstPoweredCoordinate_le + {K : Type*} [Field K] {f : MvPolynomial (Fin 2) K} + (hf : Irreducible f) (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (m : ℕ) (hm : 0 < m) : + letI := planeCurveCoordinateRing_isDomain hf + Module.finrank (FirstPoweredCoordinateSubfield f m) + (PlaneCurveFunctionField f) ≤ m * MvPolynomial.degreeOf 1 f := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let : FiniteDimensional (FirstCoordinateSubfield f) + (PlaneCurveFunctionField f) := + finiteDimensional_over_firstCoordinate_of_irreducible hf hpartialSecond + exact finrank_over_adjoin_pow_le_mul + (planeCurveFunction f 0) m (MvPolynomial.degreeOf 1 f) hm + (finrank_over_firstCoordinate_le_degreeOf_second_of_irreducible + hf hpartialSecond) + +/-- The source function field is finite over the field generated by a +positive power of its second coordinate. -/ +theorem finiteDimensional_over_secondPoweredCoordinate + {K : Type*} [Field K] {f : MvPolynomial (Fin 2) K} + (hf : Irreducible f) (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (n : ℕ) (hn : 0 < n) : + letI := planeCurveCoordinateRing_isDomain hf + FiniteDimensional (SecondPoweredCoordinateSubfield f n) + (PlaneCurveFunctionField f) := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let : FiniteDimensional (SecondCoordinateSubfield f) + (PlaneCurveFunctionField f) := + (finiteSeparable_over_secondCoordinate_of_irreducible + hf hpartialFirst).1 + exact finiteDimensional_over_adjoin_pow + (planeCurveFunction f 1) n hn + +/-- Raising the second coordinate to the `n`-th power multiplies the source +degree bound by at most `n`. -/ +theorem finrank_over_secondPoweredCoordinate_le + {K : Type*} [Field K] {f : MvPolynomial (Fin 2) K} + (hf : Irreducible f) (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (n : ℕ) (hn : 0 < n) : + letI := planeCurveCoordinateRing_isDomain hf + Module.finrank (SecondPoweredCoordinateSubfield f n) + (PlaneCurveFunctionField f) ≤ n * MvPolynomial.degreeOf 0 f := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let : FiniteDimensional (SecondCoordinateSubfield f) + (PlaneCurveFunctionField f) := + (finiteSeparable_over_secondCoordinate_of_irreducible + hf hpartialFirst).1 + exact finrank_over_adjoin_pow_le_mul + (planeCurveFunction f 1) n (MvPolynomial.degreeOf 0 f) hn + (finrank_over_secondCoordinate_eq_degreeOf_first_of_irreducible + hf hpartialFirst).le + +/-- The powered image field, presented as an extension of the powered first +coordinate field by the powered second coordinate. -/ +abbrev PoweredImageOverFirst + {K : Type*} [Field K] (f : MvPolynomial (Fin 2) K) + [IsDomain (PlaneCurveCoordinateRing f)] (m n : ℕ) := + IntermediateField.adjoin (FirstPoweredCoordinateSubfield f m) + ({(planeCurveFunction f 1) ^ n} : Set (PlaneCurveFunctionField f)) + +/-- The powered image field, presented as an extension of the powered second +coordinate field by the powered first coordinate. -/ +abbrev PoweredImageOverSecond + {K : Type*} [Field K] (f : MvPolynomial (Fin 2) K) + [IsDomain (PlaneCurveCoordinateRing f)] (m n : ℕ) := + IntermediateField.adjoin (SecondPoweredCoordinateSubfield f n) + ({(planeCurveFunction f 0) ^ m} : Set (PlaneCurveFunctionField f)) + +/-- Forgetting the relative base field identifies the first presentation +with `K(x^m,y^n)`. -/ +theorem restrictScalars_poweredImageOverFirst_eq + {K : Type*} [Field K] (f : MvPolynomial (Fin 2) K) + [IsDomain (PlaneCurveCoordinateRing f)] (m n : ℕ) : + (PoweredImageOverFirst f m n).restrictScalars K = + PoweredCoordinateImageField f m n := by + simpa only [Set.singleton_union] using + (IntermediateField.adjoin_adjoin_left K + ({(planeCurveFunction f 0) ^ m} : Set (PlaneCurveFunctionField f)) + ({(planeCurveFunction f 1) ^ n} : Set (PlaneCurveFunctionField f))) + +/-- Forgetting the relative base field identifies the second presentation +with `K(x^m,y^n)`. -/ +theorem restrictScalars_poweredImageOverSecond_eq + {K : Type*} [Field K] (f : MvPolynomial (Fin 2) K) + [IsDomain (PlaneCurveCoordinateRing f)] (m n : ℕ) : + (PoweredImageOverSecond f m n).restrictScalars K = + PoweredCoordinateImageField f m n := by + rw [IntermediateField.adjoin_adjoin_left] + congr 1 + ext z + simp + +/-- The degree of the powered image over `K(x^m)` is bounded by the source +degree over that same rational subfield. -/ +theorem finrank_poweredImageOverFirst_le + {K : Type*} [Field K] {f : MvPolynomial (Fin 2) K} + (hf : Irreducible f) (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (m n : ℕ) (hm : 0 < m) : + letI := planeCurveCoordinateRing_isDomain hf + Module.finrank (FirstPoweredCoordinateSubfield f m) + (PoweredImageOverFirst f m n) ≤ + m * MvPolynomial.degreeOf 1 f := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let : FiniteDimensional (FirstPoweredCoordinateSubfield f m) + (PlaneCurveFunctionField f) := + finiteDimensional_over_firstPoweredCoordinate hf hpartialSecond m hm + exact (PoweredImageOverFirst f m n).toSubalgebra.toSubmodule.finrank_le.trans + (finrank_over_firstPoweredCoordinate_le hf hpartialSecond m hm) + +/-- The degree of the powered image over `K(y^n)` is bounded by the source +degree over that same rational subfield. -/ +theorem finrank_poweredImageOverSecond_le + {K : Type*} [Field K] {f : MvPolynomial (Fin 2) K} + (hf : Irreducible f) (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (m n : ℕ) (hn : 0 < n) : + letI := planeCurveCoordinateRing_isDomain hf + Module.finrank (SecondPoweredCoordinateSubfield f n) + (PoweredImageOverSecond f m n) ≤ + n * MvPolynomial.degreeOf 0 f := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let : FiniteDimensional (SecondPoweredCoordinateSubfield f n) + (PlaneCurveFunctionField f) := + finiteDimensional_over_secondPoweredCoordinate hf hpartialFirst n hn + exact (PoweredImageOverSecond f m n).toSubalgebra.toSubmodule.finrank_le.trans + (finrank_over_secondPoweredCoordinate_le hf hpartialFirst n hn) + +/-- The canonical powered-image equation is irreducible over `K`. -/ +theorem poweredCoordinateImageRelation_irreducible + {K : Type*} [Field K] {f : MvPolynomial (Fin 2) K} + (hf : Irreducible f) (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (m : ℕ) (hm : 0 < m) (n : ℕ) : + Irreducible (poweredCoordinateImageRelation hf hpartialSecond m hm n) := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let : FiniteDimensional (FirstPoweredCoordinateSubfield f m) + (PlaneCurveFunctionField f) := + finiteDimensional_over_firstPoweredCoordinate hf hpartialSecond m hm + have hv : IsIntegral (FirstPoweredCoordinateSubfield f m) + ((planeCurveFunction f 1) ^ n) := IsIntegral.of_finite _ _ + change Irreducible (primitiveClearedMinpolyRelation + ((planeCurveFunction f 0) ^ m) + (firstPoweredCoordinate_transcendental hf hpartialSecond m hm) + ((planeCurveFunction f 1) ^ n)) + exact primitiveClearedMinpolyRelation_irreducible _ _ _ hv + +/-- The canonical equation vanishes on the powered coordinate pair. -/ +theorem evalBivariate_poweredCoordinateImageRelation_eq_zero + {K : Type*} [Field K] {f : MvPolynomial (Fin 2) K} + (hf : Irreducible f) (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (m : ℕ) (hm : 0 < m) (n : ℕ) : + letI := planeCurveCoordinateRing_isDomain hf + evalBivariate ((planeCurveFunction f 0) ^ m) + ((planeCurveFunction f 1) ^ n) + (poweredCoordinateImageRelation hf hpartialSecond m hm n) = 0 := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let : FiniteDimensional (FirstPoweredCoordinateSubfield f m) + (PlaneCurveFunctionField f) := + finiteDimensional_over_firstPoweredCoordinate hf hpartialSecond m hm + have hv : IsIntegral (FirstPoweredCoordinateSubfield f m) + ((planeCurveFunction f 1) ^ n) := IsIntegral.of_finite _ _ + change evalBivariate ((planeCurveFunction f 0) ^ m) + ((planeCurveFunction f 1) ^ n) + (primitiveClearedMinpolyRelation + ((planeCurveFunction f 0) ^ m) + (firstPoweredCoordinate_transcendental hf hpartialSecond m hm) + ((planeCurveFunction f 1) ^ n)) = 0 + exact evalBivariate_primitiveClearedMinpolyRelation_eq_zero _ _ _ hv + +/-- The degree in the powered second coordinate is exactly the projection +degree of the image over `K(x^m)`. -/ +theorem poweredCoordinateImageRelation_natDegree_eq_finrank + {K : Type*} [Field K] {f : MvPolynomial (Fin 2) K} + (hf : Irreducible f) (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (m : ℕ) (hm : 0 < m) (n : ℕ) : + letI := planeCurveCoordinateRing_isDomain hf + (poweredCoordinateImageRelation hf hpartialSecond m hm n).natDegree = + Module.finrank (FirstPoweredCoordinateSubfield f m) + (PoweredImageOverFirst f m n) := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let : FiniteDimensional (FirstPoweredCoordinateSubfield f m) + (PlaneCurveFunctionField f) := + finiteDimensional_over_firstPoweredCoordinate hf hpartialSecond m hm + have hv : IsIntegral (FirstPoweredCoordinateSubfield f m) + ((planeCurveFunction f 1) ^ n) := IsIntegral.of_finite _ _ + calc + (poweredCoordinateImageRelation hf hpartialSecond m hm n).natDegree = + (minpoly (FirstPoweredCoordinateSubfield f m) + ((planeCurveFunction f 1) ^ n)).natDegree := by + change (primitiveClearedMinpolyRelation + ((planeCurveFunction f 0) ^ m) + (firstPoweredCoordinate_transcendental hf hpartialSecond m hm) + ((planeCurveFunction f 1) ^ n)).natDegree = _ + exact primitiveClearedMinpolyRelation_natDegree _ _ _ hv + _ = Module.finrank (FirstPoweredCoordinateSubfield f m) + (PoweredImageOverFirst f m n) := + (IntermediateField.adjoin.finrank hv).symm + +/-- The degree in the powered first coordinate is exactly the projection +degree of the image over `K(y^n)`. -/ +theorem poweredCoordinateImageRelation_transpose_natDegree_eq_finrank + {K : Type*} [Field K] {f : MvPolynomial (Fin 2) K} + (hf : Irreducible f) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (m : ℕ) (hm : 0 < m) (n : ℕ) (hn : 0 < n) : + letI := planeCurveCoordinateRing_isDomain hf + (transposeBivariate + (poweredCoordinateImageRelation hf hpartialSecond m hm n)).natDegree = + Module.finrank (SecondPoweredCoordinateSubfield f n) + (PoweredImageOverSecond f m n) := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let : FiniteDimensional (SecondPoweredCoordinateSubfield f n) + (PlaneCurveFunctionField f) := + finiteDimensional_over_secondPoweredCoordinate hf hpartialFirst n hn + have hu : IsIntegral (SecondPoweredCoordinateSubfield f n) + ((planeCurveFunction f 0) ^ m) := IsIntegral.of_finite _ _ + have hdegree := transposeBivariate_natDegree_eq_minpoly + ((planeCurveFunction f 0) ^ m) ((planeCurveFunction f 1) ^ n) + (secondPoweredCoordinate_transcendental hf hpartialFirst n hn) + (poweredCoordinateImageRelation_irreducible + hf hpartialSecond m hm n) + (evalBivariate_poweredCoordinateImageRelation_eq_zero + hf hpartialSecond m hm n) + calc + (transposeBivariate + (poweredCoordinateImageRelation hf hpartialSecond m hm n)).natDegree = + (minpoly (SecondPoweredCoordinateSubfield f n) + ((planeCurveFunction f 0) ^ m)).natDegree := hdegree + _ = Module.finrank (SecondPoweredCoordinateSubfield f n) + (PoweredImageOverSecond f m n) := + (IntermediateField.adjoin.finrank hu).symm + +/-- Source-degree bounds for both coordinate degrees of the actual powered +image equation. -/ +theorem poweredCoordinateImageRelation_bidegree_le + {K : Type*} [Field K] {f : MvPolynomial (Fin 2) K} + (hf : Irreducible f) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (m : ℕ) (hm : 0 < m) (n : ℕ) (hn : 0 < n) : + letI := planeCurveCoordinateRing_isDomain hf + (poweredCoordinateImageRelation hf hpartialSecond m hm n).natDegree ≤ + m * MvPolynomial.degreeOf 1 f ∧ + (transposeBivariate + (poweredCoordinateImageRelation hf hpartialSecond m hm n)).natDegree ≤ + n * MvPolynomial.degreeOf 0 f := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + constructor + · rw [poweredCoordinateImageRelation_natDegree_eq_finrank + hf hpartialSecond m hm n] + exact finrank_poweredImageOverFirst_le + hf hpartialSecond m n hm + · rw [poweredCoordinateImageRelation_transpose_natDegree_eq_finrank + hf hpartialFirst hpartialSecond m hm n hn] + exact finrank_poweredImageOverSecond_le + hf hpartialFirst m n hn + +/-- Every coefficient of the canonical powered-image equation has degree at +most its first-coordinate degree. -/ +theorem poweredCoordinateImageRelation_coeff_natDegree_le + {K : Type*} [Field K] {f : MvPolynomial (Fin 2) K} + (hf : Irreducible f) (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (m : ℕ) (hm : 0 < m) (n i : ℕ) : + ((poweredCoordinateImageRelation hf hpartialSecond m hm n).coeff i).natDegree ≤ + (transposeBivariate + (poweredCoordinateImageRelation hf hpartialSecond m hm n)).natDegree := by + have h := transposeBivariate_coeff_natDegree_le + (transposeBivariate + (poweredCoordinateImageRelation hf hpartialSecond m hm n)) + (transposeBivariate + (poweredCoordinateImageRelation hf hpartialSecond m hm n)).natDegree + le_rfl i + simpa only [transposeBivariate_transposeBivariate] using h + +/-- The canonical powered-image equation has positive degree in the powered +second coordinate. -/ +theorem poweredCoordinateImageRelation_natDegree_pos + {K : Type*} [Field K] {f : MvPolynomial (Fin 2) K} + (hf : Irreducible f) (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (m : ℕ) (hm : 0 < m) (n : ℕ) : + 0 < (poweredCoordinateImageRelation hf hpartialSecond m hm n).natDegree := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let : FiniteDimensional (FirstPoweredCoordinateSubfield f m) + (PlaneCurveFunctionField f) := + finiteDimensional_over_firstPoweredCoordinate hf hpartialSecond m hm + have hv : IsIntegral (FirstPoweredCoordinateSubfield f m) + ((planeCurveFunction f 1) ^ n) := IsIntegral.of_finite _ _ + rw [poweredCoordinateImageRelation_natDegree_eq_finrank + hf hpartialSecond m hm n, IntermediateField.adjoin.finrank hv] + exact minpoly.natDegree_pos hv + +/-- The canonical powered-image equation has positive degree in the powered +first coordinate. -/ +theorem poweredCoordinateImageRelation_transpose_natDegree_pos + {K : Type*} [Field K] {f : MvPolynomial (Fin 2) K} + (hf : Irreducible f) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (m : ℕ) (hm : 0 < m) (n : ℕ) (hn : 0 < n) : + 0 < (transposeBivariate + (poweredCoordinateImageRelation hf hpartialSecond m hm n)).natDegree := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + apply Nat.pos_of_ne_zero + exact transposeBivariate_natDegree_ne_zero_of_eval_eq_zero + ((planeCurveFunction f 0) ^ m) ((planeCurveFunction f 1) ^ n) + (secondPoweredCoordinate_transcendental hf hpartialFirst n hn) + (poweredCoordinateImageRelation_irreducible + hf hpartialSecond m hm n) + (evalBivariate_poweredCoordinateImageRelation_eq_zero + hf hpartialSecond m hm n) + +/-- A single endpoint collecting the algebraic geometry of the powered +coordinate image: an irreducible equation over `K`, its vanishing, positive +bidegrees, source-degree bounds, and the corresponding coefficient bound. -/ +theorem poweredCoordinateImageRelation_spec + {K : Type*} [Field K] {f : MvPolynomial (Fin 2) K} + (hf : Irreducible f) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (m : ℕ) (hm : 0 < m) (n : ℕ) (hn : 0 < n) : + letI := planeCurveCoordinateRing_isDomain hf + let g := poweredCoordinateImageRelation hf hpartialSecond m hm n + Irreducible g ∧ + evalBivariate ((planeCurveFunction f 0) ^ m) + ((planeCurveFunction f 1) ^ n) g = 0 ∧ + 0 < g.natDegree ∧ + 0 < (transposeBivariate g).natDegree ∧ + g.natDegree ≤ m * MvPolynomial.degreeOf 1 f ∧ + (transposeBivariate g).natDegree ≤ n * MvPolynomial.degreeOf 0 f ∧ + ∀ i, (g.coeff i).natDegree ≤ n * MvPolynomial.degreeOf 0 f := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let g := poweredCoordinateImageRelation hf hpartialSecond m hm n + have hbidegree := poweredCoordinateImageRelation_bidegree_le + hf hpartialFirst hpartialSecond m hm n hn + refine ⟨poweredCoordinateImageRelation_irreducible + hf hpartialSecond m hm n, + evalBivariate_poweredCoordinateImageRelation_eq_zero + hf hpartialSecond m hm n, + poweredCoordinateImageRelation_natDegree_pos + hf hpartialSecond m hm n, + poweredCoordinateImageRelation_transpose_natDegree_pos + hf hpartialFirst hpartialSecond m hm n hn, + hbidegree.1, hbidegree.2, ?_⟩ + intro i + exact (poweredCoordinateImageRelation_coeff_natDegree_le + hf hpartialSecond m hm n i).trans hbidegree.2 + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/PoweredImageExactSupportIndexBound.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/PoweredImageExactSupportIndexBound.lean new file mode 100644 index 0000000000..02cbb68078 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/PoweredImageExactSupportIndexBound.lean @@ -0,0 +1,249 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PoweredImageIndexBound + +/-! +# Powered-image index from an exact support determinant + +The general powered-image theorem replaces a support determinant by its +bidegree-box bound. This module retains a supplied support triple and hence +its exact determinant. It is useful for sparse curves whose support lattice +has much smaller index than the ambient degree box. +-/ + +@[expose] public section + +namespace BGS.CorvajaZannier + +noncomputable section + + +/-- Over algebraically closed constants, the source-to-powered-image degree +is bounded by any nonzero determinant exhibited by three support monomials. -/ +theorem finrank_poweredCoordinateImageField_le_supportDet_isAlgClosed + {F : Type*} [Field F] [IsAlgClosed F] + {f : MvPolynomial (Fin 2) F} + (hf : Irreducible f) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + {r s t : Fin 2 →₀ ℕ} + (hr : r ∈ f.support) (hs : s ∈ f.support) (ht : t ∈ f.support) + (hdet : planeCurveSupportDifferenceDet r s t ≠ 0) + (m n : ℕ) (hm : 0 < m) (hn : 0 < n) + (hmF : (m : F) ≠ 0) (hnF : (n : F) ≠ 0) : + letI := planeCurveCoordinateRing_isDomain hf + Module.finrank (PoweredCoordinateImageField f m n) + (PlaneCurveFunctionField f) ≤ + (planeCurveSupportDifferenceDet r s t).natAbs := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let L := PlaneCurveFunctionField f + let B := PoweredCoordinateImageField f m n + let x : L := planeCurveFunction f 0 + let y : L := planeCurveFunction f 1 + let : FiniteDimensional B L := + finiteDimensional_poweredCoordinateImageField + hf hpartialSecond m n hm + let : IsGalois B L := + isGalois_over_poweredCoordinateImageField + hf hpartialFirst hpartialSecond m n hm hn hmF hnF + have hbasic := + poweredCoordinateImageField_adjoin_coordinates_eq_top_and_ne_zero + hf hpartialFirst hpartialSecond m n + have hgen : IntermediateField.adjoin B ({x, y} : Set L) = ⊤ := + hbasic.1 + have hgenAlg : Algebra.adjoin B ({x, y} : Set L) = ⊤ := by + rw [← IntermediateField.adjoin_toSubalgebra] + rw [hgen] + rfl + let a : ℤ := (s 0 : ℤ) - (r 0 : ℤ) + let b : ℤ := (s 1 : ℤ) - (r 1 : ℤ) + let c : ℤ := (t 0 : ℤ) - (r 0 : ℤ) + let d : ℤ := (t 1 : ℤ) - (r 1 : ℤ) + have hdet' : a * d - b * c ≠ 0 := by + simpa [a, b, c, d, planeCurveSupportDifferenceDet] using hdet + let : Finite (torusCharacterKernel F a b c d) := + finite_torusCharacterKernel_of_det_ne_zero a b c d hdet' + let supportToKernel : planeCurveSupportCharacterStabilizer F f → + torusCharacterKernel F a b c d := fun z => + ⟨z.1, z.2 r hr s hs, z.2 r hr t ht⟩ + have supportToKernel_injective : + Function.Injective supportToKernel := by + intro z w hzw + apply Subtype.ext + exact congrArg + (fun u : torusCharacterKernel F a b c d => u.1) hzw + let : Finite (planeCurveSupportCharacterStabilizer F f) := + Finite.of_injective supportToKernel supportToKernel_injective + have hscale (σ : L ≃ₐ[B] L) := + exists_support_stabilizer_scaling_of_poweredImage_aut + hf hpartialFirst hpartialSecond m n hm hn hmF hnF σ + let scalePair : (L ≃ₐ[B] L) → Fˣ × Fˣ := fun σ => + Classical.choose (hscale σ) + have scalePair_spec (σ : L ≃ₐ[B] L) : + algebraMap F L (scalePair σ).1 * x = σ x ∧ + algebraMap F L (scalePair σ).2 * y = σ y ∧ + ∀ r ∈ f.support, ∀ s ∈ f.support, + (scalePair σ).1 ^ ((s 0 : ℤ) - (r 0 : ℤ)) * + (scalePair σ).2 ^ ((s 1 : ℤ) - (r 1 : ℤ)) = 1 := + Classical.choose_spec (hscale σ) + let e : (L ≃ₐ[B] L) → planeCurveSupportCharacterStabilizer F f := + fun σ => ⟨scalePair σ, (scalePair_spec σ).2.2⟩ + have he : Function.Injective e := by + intro σ τ hστ + have hpairs : scalePair σ = scalePair τ := + congrArg Subtype.val hστ + have hx : σ x = τ x := by + rw [← (scalePair_spec σ).1, ← (scalePair_spec τ).1, hpairs] + have hy : σ y = τ y := by + rw [← (scalePair_spec σ).2.1, ← (scalePair_spec τ).2.1, hpairs] + apply AlgEquiv.ext + have hhom : σ.toAlgHom = τ.toAlgHom := by + apply AlgHom.ext_of_adjoin_eq_top hgenAlg + intro q hq + simp only [Set.mem_insert_iff, Set.mem_singleton_iff] at hq + rcases hq with rfl | rfl + · exact hx + · exact hy + exact fun z => DFunLike.congr_fun hhom z + calc + Module.finrank B L = Nat.card (L ≃ₐ[B] L) := + (IsGalois.card_aut_eq_finrank B L).symm + _ ≤ Nat.card (planeCurveSupportCharacterStabilizer F f) := + Nat.card_le_card_of_injective e he + _ ≤ (planeCurveSupportDifferenceDet r s t).natAbs := + natCard_planeCurveSupportCharacterStabilizer_le_supportDet + hr hs ht hdet + +/-- The determinant-sensitive algebraically closed bound in the +first-coordinate presentation used by Proposition Two. -/ +theorem finrank_poweredImageOverFirst_le_supportDet_isAlgClosed + {F : Type*} [Field F] [IsAlgClosed F] + {f : MvPolynomial (Fin 2) F} + (hf : Irreducible f) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + {r s t : Fin 2 →₀ ℕ} + (hr : r ∈ f.support) (hs : s ∈ f.support) (ht : t ∈ f.support) + (hdet : planeCurveSupportDifferenceDet r s t ≠ 0) + (m n : ℕ) (hm : 0 < m) (hn : 0 < n) + (hmF : (m : F) ≠ 0) (hnF : (n : F) ≠ 0) : + letI := planeCurveCoordinateRing_isDomain hf + Module.finrank (PoweredImageOverFirst f m n) + (PlaneCurveFunctionField f) ≤ + (planeCurveSupportDifferenceDet r s t).natAbs := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + rw [finrank_poweredImageOverFirst_eq_imageField] + exact finrank_poweredCoordinateImageField_le_supportDet_isAlgClosed + hf hpartialFirst hpartialSecond hr hs ht hdet + m n hm hn hmF hnF + +/-- Exact-support index bound over arbitrary constants, obtained by the same +base-change descent as the public bidegree theorem. -/ +theorem finrank_poweredImageOverFirst_le_supportDet_of_nonzero_natCast + {K : Type*} [Field K] {f : MvPolynomial (Fin 2) K} + (habsolute : Irreducible + (MvPolynomial.map (algebraMap K (AlgebraicClosure K)) f)) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + {r s t : Fin 2 →₀ ℕ} + (hr : r ∈ f.support) (hs : s ∈ f.support) (ht : t ∈ f.support) + (hdet : planeCurveSupportDifferenceDet r s t ≠ 0) + (m n : ℕ) (hm : 0 < m) (hn : 0 < n) + (hmK : (m : K) ≠ 0) (hnK : (n : K) ≠ 0) : + let hf : Irreducible f := + irreducible_of_irreducible_map_algebraicClosure habsolute + letI := planeCurveCoordinateRing_isDomain hf + Module.finrank (PoweredImageOverFirst f m n) + (PlaneCurveFunctionField f) ≤ + (planeCurveSupportDifferenceDet r s t).natAbs := by + let A := AlgebraicClosure K + let fA : MvPolynomial (Fin 2) A := + MvPolynomial.map (algebraMap K A) f + let hf : Irreducible f := + irreducible_of_irreducible_map_algebraicClosure habsolute + have hfA : Irreducible fA := habsolute + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let : IsDomain (PlaneCurveCoordinateRing fA) := + planeCurveCoordinateRing_isDomain hfA + have hpartialFirstA : MvPolynomial.pderiv 0 fA ≠ 0 := by + rw [MvPolynomial.pderiv_map] + intro hzero + apply hpartialFirst + exact MvPolynomial.map_injective (algebraMap K A) + (algebraMap K A).injective (by simpa using hzero) + have hpartialSecondA : MvPolynomial.pderiv 1 fA ≠ 0 := by + rw [MvPolynomial.pderiv_map] + intro hzero + apply hpartialSecond + exact MvPolynomial.map_injective (algebraMap K A) + (algebraMap K A).injective (by simpa using hzero) + have hsupp : fA.support = f.support := + MvPolynomial.support_map_of_injective f (algebraMap K A).injective + have hrA : r ∈ fA.support := by rwa [hsupp] + have hsA : s ∈ fA.support := by rwa [hsupp] + have htA : t ∈ fA.support := by rwa [hsupp] + have hmA : (m : A) ≠ 0 := by + rw [← map_natCast (algebraMap K A)] + simpa using (algebraMap K A).injective.ne hmK + have hnA : (n : A) ≠ 0 := by + rw [← map_natCast (algebraMap K A)] + simpa using (algebraMap K A).injective.ne hnK + have hindexBaseChange : + Module.finrank (PoweredCoordinateImageField f m n) + (PlaneCurveFunctionField f) = + Module.finrank (PoweredCoordinateImageField fA m n) + (PlaneCurveFunctionField fA) := + finrank_poweredCoordinateImageField_eq_baseChange + (E := A) habsolute hf hpartialSecond m hm n + change Module.finrank (PoweredImageOverFirst f m n) + (PlaneCurveFunctionField f) ≤ + (planeCurveSupportDifferenceDet r s t).natAbs + rw [finrank_poweredImageOverFirst_eq_imageField] + calc + Module.finrank (PoweredCoordinateImageField f m n) + (PlaneCurveFunctionField f) = + Module.finrank (PoweredCoordinateImageField fA m n) + (PlaneCurveFunctionField fA) := hindexBaseChange + _ ≤ (planeCurveSupportDifferenceDet r s t).natAbs := + finrank_poweredCoordinateImageField_le_supportDet_isAlgClosed + hfA hpartialFirstA hpartialSecondA + hrA hsA htA hdet m n hm hn hmA hnA + +/-- Prime-to-characteristic powers satisfy the exact-support index bound. -/ +theorem finrank_poweredImageOverFirst_le_supportDet + {p : ℕ} [Fact p.Prime] + {K : Type*} [Field K] [CharP K p] + {f : MvPolynomial (Fin 2) K} + (habsolute : Irreducible + (MvPolynomial.map (algebraMap K (AlgebraicClosure K)) f)) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + {r s t : Fin 2 →₀ ℕ} + (hr : r ∈ f.support) (hs : s ∈ f.support) (ht : t ∈ f.support) + (hdet : planeCurveSupportDifferenceDet r s t ≠ 0) + (m n : ℕ) (hm : 0 < m) (hn : 0 < n) + (hmPrime : ¬ p ∣ m) (hnPrime : ¬ p ∣ n) : + let hf : Irreducible f := + irreducible_of_irreducible_map_algebraicClosure habsolute + letI := planeCurveCoordinateRing_isDomain hf + Module.finrank (PoweredImageOverFirst f m n) + (PlaneCurveFunctionField f) ≤ + (planeCurveSupportDifferenceDet r s t).natAbs := by + apply finrank_poweredImageOverFirst_le_supportDet_of_nonzero_natCast + habsolute hpartialFirst hpartialSecond hr hs ht hdet + m n hm hn + · rwa [ne_eq, CharP.cast_eq_zero_iff K p] + · rwa [ne_eq, CharP.cast_eq_zero_iff K p] + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/PoweredImageFrobeniusRelation.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/PoweredImageFrobeniusRelation.lean new file mode 100644 index 0000000000..4d9b0d962e --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/PoweredImageFrobeniusRelation.lean @@ -0,0 +1,721 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PoweredImageCurve +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.AbsoluteIrreducibilityBaseChange +public import Mathlib.RingTheory.TensorProduct.MvPolynomial +public import Mathlib.RingTheory.TensorProduct.Quotient +public import Mathlib.RingTheory.Flat.Basic + +/-! +# Powered-image relations over the Frobenius constant field + +This file proves that the equation of the image of a plane curve under the +coordinate-power map remains irreducible after arbitrary scalar extension. +It then transports that equation to the Frobenius constant field and applies +the relation criterion to obtain the auxiliary-family linear independence +used in the Corvaja--Zannier Wronskian argument. +-/ + +@[expose] public section + +open scoped TensorProduct Polynomial + +namespace BGS.CorvajaZannier + +open Polynomial + +noncomputable section + +variable {K A B : Type*} [Field K] [CommRing A] [CommRing B] + [Algebra K A] [Algebra K B] + +noncomputable def bivariateEvalAlgHom (u v : A) : + Polynomial (Polynomial K) →ₐ[K] A := + Polynomial.eval₂AlgHom (Polynomial.aeval u) v (fun _ ↦ Commute.all _ _) + +theorem bivariateEvalAlgHom_comp (F : A →ₐ[K] B) (u v : A) : + F.comp (bivariateEvalAlgHom (K := K) u v) = + bivariateEvalAlgHom (K := K) (F u) (F v) := by + apply AlgHom.ext + intro P + have hr : + (F.comp (bivariateEvalAlgHom (K := K) u v)).toRingHom = + (bivariateEvalAlgHom (K := K) (F u) (F v)).toRingHom := by + apply Polynomial.ringHom_ext + · intro q + change F (bivariateEvalAlgHom (K := K) u v (Polynomial.C q)) = + bivariateEvalAlgHom (K := K) (F u) (F v) (Polynomial.C q) + simp only [bivariateEvalAlgHom, Polynomial.eval₂AlgHom_apply, + Polynomial.eval₂_C] + induction q using Polynomial.induction_on' with + | add q r hq hr => + simpa only [map_add] using congrArg₂ (fun a b ↦ a + b) hq hr + | monomial j c => simp + · simp [bivariateEvalAlgHom] + exact DFunLike.congr_fun hr P + +theorem bivariateQuotientEvalEmbedding + (u v : A) (g : Polynomial (Polynomial K)) + (hzero : bivariateEvalAlgHom u v g = 0) + (hdiv : ∀ P, bivariateEvalAlgHom u v P = 0 → g ∣ P) : + ∃ F : (Polynomial (Polynomial K) ⧸ Ideal.span {g}) →ₐ[K] A, + Function.Injective F := by + let φ : Polynomial (Polynomial K) →ₐ[K] A := + bivariateEvalAlgHom (K := K) u v + have hspan : ∀ a, a ∈ Ideal.span {g} → φ a = 0 := by + intro a ha + obtain ⟨b, rfl⟩ := Ideal.mem_span_singleton.mp ha + simp [φ, hzero] + let F : (Polynomial (Polynomial K) ⧸ Ideal.span {g}) →ₐ[K] A := + Ideal.Quotient.liftₐ (Ideal.span {g}) φ hspan + refine ⟨F, ?_⟩ + exact RingHom.lift_injective_of_ker_le_ideal (Ideal.span {g}) hspan (by + intro a ha + rw [RingHom.mem_ker] at ha + exact Ideal.mem_span_singleton.mpr (hdiv a (by simpa [φ] using ha))) + +variable {L : Type*} [Field L] [Algebra K L] + +@[simp] +theorem bivariateEvalAlgHom_eq_evalBivariate (u v : L) + (P : Polynomial (Polynomial K)) : + bivariateEvalAlgHom (K := K) u v P = evalBivariate u v P := by + rfl + +theorem primitiveClearedMinpolyRelation_dvd_of_evalBivariate_eq_zero + (u : L) (hu : Transcendental K u) (v : L) + (hv : IsIntegral (IntermediateField.adjoin K {u}) v) + (P : Polynomial (Polynomial K)) + (hP : evalBivariate u v P = 0) : + primitiveClearedMinpolyRelation u hu v ∣ P := by + let := Classical.arbitrary (NormalizedGCDMonoid K) + let e := RatFunc.algEquivOfTranscendental u hu + let P_rat : Polynomial (RatFunc K) := + P.map (algebraMap (Polynomial K) (RatFunc K)) + let P_adjoin : Polynomial (IntermediateField.adjoin K {u}) := + P_rat.map e.toRingEquiv + have hroot_rat : + Polynomial.eval₂ (ratFuncSpecialization u hu) v P_rat = 0 := by + simpa only [P_rat, ← evalBivariate_eq_eval₂_ratFuncSpecialization_map] + using hP + have hroot_adjoin : Polynomial.aeval v P_adjoin = 0 := by + rw [Polynomial.aeval_def] + change Polynomial.eval₂ (algebraMap (IntermediateField.adjoin K {u}) L) v + (P_rat.map e.toRingEquiv.toRingHom) = 0 + rw [Polynomial.eval₂_map] + have hcoeff : + (algebraMap (IntermediateField.adjoin K {u}) L).comp + e.toRingEquiv.toRingHom = ratFuncSpecialization u hu := by + rfl + rw [hcoeff] + exact hroot_rat + obtain ⟨R, hR⟩ := minpoly.dvd (IntermediateField.adjoin K {u}) v hroot_adjoin + have hq_dvd : ratFuncMinpoly u hu v ∣ P_rat := by + refine ⟨R.map e.symm.toRingEquiv.toRingHom, ?_⟩ + have hmapped := congrArg + (fun Q : Polynomial (IntermediateField.adjoin K {u}) ↦ + Q.map e.symm.toRingEquiv.toRingHom) hR + have hcomp : + e.symm.toRingEquiv.toRingHom.comp + (e.toRingEquiv.toRingHom.comp + (algebraMap (Polynomial K) (RatFunc K))) = + algebraMap (Polynomial K) (RatFunc K) := by + apply DFunLike.ext _ _ + intro z + exact e.symm_apply_apply _ + simp only [P_adjoin, P_rat, Polynomial.map_mul, Polynomial.map_map] at hmapped + change Polynomial.map + (e.symm.toRingEquiv.toRingHom.comp + (e.toRingEquiv.toRingHom.comp + (algebraMap (Polynomial K) (RatFunc K)))) P = + Polynomial.map e.symm.toRingEquiv.toRingHom + (minpoly (IntermediateField.adjoin K {u}) v) * + Polynomial.map e.symm.toRingEquiv.toRingHom R at hmapped + rw [hcomp] at hmapped + have hmin : ratFuncMinpoly u hu v = + Polynomial.map e.symm.toRingEquiv.toRingHom + (minpoly (IntermediateField.adjoin K {u}) v) := by + rfl + rw [hmin] + exact hmapped + obtain ⟨c, hc, hgmap⟩ := + map_primitiveClearedMinpolyRelation_eq_C_mul u hu v hv + obtain ⟨R, hR⟩ := hq_dvd + have hgmap_dvd : + (primitiveClearedMinpolyRelation u hu v).map + (algebraMap (Polynomial K) (RatFunc K)) ∣ P_rat := by + refine ⟨Polynomial.C c⁻¹ * R, ?_⟩ + rw [hgmap] + calc + P_rat = ratFuncMinpoly u hu v * R := hR + _ = (Polynomial.C c * ratFuncMinpoly u hu v) * + (Polynomial.C c⁻¹ * R) := by + rw [mul_mul_mul_comm, ← Polynomial.C_mul, mul_inv_cancel₀ hc, + Polynomial.C_1, one_mul] + exact (integerClearedMinpoly u hu v).isPrimitive_primPart + |>.dvd_of_fraction_map_dvd_fraction_map hgmap_dvd + +theorem poweredCoordinateImageRelation_quotient_embeds_source + {f : MvPolynomial (Fin 2) K} + (hf : Irreducible f) (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (m : ℕ) (hm : 0 < m) (n : ℕ) : + letI := planeCurveCoordinateRing_isDomain hf + let g := poweredCoordinateImageRelation hf hpartialSecond m hm n + ∃ F : (Polynomial (Polynomial K) ⧸ Ideal.span {g}) →ₐ[K] + PlaneCurveCoordinateRing f, + Function.Injective F := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let L := PlaneCurveFunctionField f + let A := PlaneCurveCoordinateRing f + let xA : A := (planeCurveCoordinate f 0) ^ m + let yA : A := (planeCurveCoordinate f 1) ^ n + let xL : L := (planeCurveFunction f 0) ^ m + let yL : L := (planeCurveFunction f 1) ^ n + let ι : A →ₐ[K] L := IsScalarTower.toAlgHom K A L + let φA : Polynomial (Polynomial K) →ₐ[K] A := + bivariateEvalAlgHom (K := K) xA yA + let φL : Polynomial (Polynomial K) →ₐ[K] L := + bivariateEvalAlgHom (K := K) xL yL + have hcomp : ι.comp φA = φL := by + simpa [φA, φL, xA, xL, yA, yL, ι, planeCurveFunction] using + (bivariateEvalAlgHom_comp (K := K) ι xA yA) + let : FiniteDimensional (FirstPoweredCoordinateSubfield f m) L := + finiteDimensional_over_firstPoweredCoordinate hf hpartialSecond m hm + have hv : IsIntegral (FirstPoweredCoordinateSubfield f m) yL := + IsIntegral.of_finite _ _ + let g := poweredCoordinateImageRelation hf hpartialSecond m hm n + have hzeroL : φL g = 0 := by + simpa [φL, xL, yL, g] using + (evalBivariate_poweredCoordinateImageRelation_eq_zero + hf hpartialSecond m hm n) + have hι : Function.Injective ι := by + exact IsFractionRing.injective A L + have hzeroA : φA g = 0 := by + apply hι + rw [map_zero, ← AlgHom.comp_apply, hcomp] + exact hzeroL + apply bivariateQuotientEvalEmbedding xA yA g hzeroA + intro P hP + change primitiveClearedMinpolyRelation xL + (firstPoweredCoordinate_transcendental hf hpartialSecond m hm) yL ∣ P + apply primitiveClearedMinpolyRelation_dvd_of_evalBivariate_eq_zero + xL (firstPoweredCoordinate_transcendental hf hpartialSecond m hm) yL hv + change φL P = 0 + rw [← hcomp, AlgHom.comp_apply, hP, map_zero] + +noncomputable def iteratedPolynomialBaseChangeEquiv + (E : Type*) [Field E] [Algebra K E] : + E ⊗[K] Polynomial (Polynomial K) ≃ₐ[E] + Polynomial (Polynomial E) := + (Algebra.TensorProduct.congr (AlgEquiv.refl : E ≃ₐ[E] E) + (Polynomial.Bivariate.equivMvPolynomial K)).trans + ((MvPolynomial.algebraTensorAlgEquiv K E).trans + (Polynomial.Bivariate.equivMvPolynomial E).symm) + +theorem bivariateEquiv_map_commutes + (E : Type*) [Field E] [Algebra K E] + (g : Polynomial (Polynomial K)) : + (Polynomial.Bivariate.equivMvPolynomial E).symm + (MvPolynomial.map (algebraMap K E) + (Polynomial.Bivariate.equivMvPolynomial K g)) = + g.map (Polynomial.mapRingHom (algebraMap K E)) := by + let lhs : Polynomial (Polynomial K) →+* Polynomial (Polynomial E) := + (Polynomial.Bivariate.equivMvPolynomial E).symm.toRingEquiv.toRingHom.comp + ((MvPolynomial.map (algebraMap K E)).comp + (Polynomial.Bivariate.equivMvPolynomial K).toRingEquiv.toRingHom) + let rhs : Polynomial (Polynomial K) →+* Polynomial (Polynomial E) := + Polynomial.mapRingHom (Polynomial.mapRingHom (algebraMap K E)) + change lhs g = rhs g + congr 1 + apply Polynomial.ringHom_ext + · intro q + induction q using Polynomial.induction_on' with + | add q r hq hr => simp only [map_add, hq, hr] + | monomial n c => + rw [← Polynomial.C_mul_X_pow_eq_monomial] + simp [lhs, rhs] + · simp [lhs, rhs] + +theorem iteratedPolynomialBaseChangeEquiv_tmul_one + (E : Type*) [Field E] [Algebra K E] + (g : Polynomial (Polynomial K)) : + iteratedPolynomialBaseChangeEquiv (K := K) E (1 ⊗ₜ[K] g) = + g.map (Polynomial.mapRingHom (algebraMap K E)) := by + change (Polynomial.Bivariate.equivMvPolynomial E).symm + ((MvPolynomial.algebraTensorAlgEquiv K E) + ((Algebra.TensorProduct.congr (AlgEquiv.refl : E ≃ₐ[E] E) + (Polynomial.Bivariate.equivMvPolynomial K)) (1 ⊗ₜ[K] g))) = _ + rw [Algebra.TensorProduct.congr_apply, Algebra.TensorProduct.map_tmul, + MvPolynomial.algebraTensorAlgEquiv_tmul] + change (Polynomial.Bivariate.equivMvPolynomial E).symm + ((1 : E) • MvPolynomial.map (algebraMap K E) + (Polynomial.Bivariate.equivMvPolynomial K g)) = _ + rw [one_smul] + exact bivariateEquiv_map_commutes E g + +noncomputable def bivariateQuotientEquivMvPolynomial + (g : Polynomial (Polynomial K)) : + (Polynomial (Polynomial K) ⧸ Ideal.span {g}) ≃ₐ[K] + PlaneCurveCoordinateRing + (Polynomial.Bivariate.equivMvPolynomial K g) := by + apply Ideal.quotientEquivAlg + (Ideal.span {g}) + (Ideal.span {Polynomial.Bivariate.equivMvPolynomial K g}) + (Polynomial.Bivariate.equivMvPolynomial K) + simp only [Ideal.map_span, Set.image_singleton] + rfl + +theorem tensorProduct_map_id_injective + (E : Type*) [Field E] [Algebra K E] + {A B : Type*} [CommRing A] [CommRing B] + [Algebra K A] [Algebra K B] + (F : A →ₐ[K] B) (hF : Function.Injective F) : + Function.Injective + (Algebra.TensorProduct.map (AlgHom.id E E) F) := by + have heq : + (Algebra.TensorProduct.map (AlgHom.id E E) F).toLinearMap.restrictScalars K = + F.toLinearMap.lTensor E := by + ext e a + simp + rw [← heq] at * + exact Module.Flat.lTensor_preserves_injective_linearMap F.toLinearMap hF + +theorem tensorProduct_isDomain_of_embedding + (E : Type*) [Field E] [Algebra K E] + {A B : Type*} [CommRing A] [CommRing B] + [Algebra K A] [Algebra K B] + (F : A →ₐ[K] B) (hF : Function.Injective F) + (hdom : IsDomain (E ⊗[K] B)) : + IsDomain (E ⊗[K] A) := by + let Φ := Algebra.TensorProduct.map (AlgHom.id E E) F + have hΦ : Function.Injective Φ := + tensorProduct_map_id_injective E F hF + let : IsDomain (E ⊗[K] B) := hdom + apply (isDomain_iff_noZeroDivisors_and_nontrivial _).mpr + constructor + · exact hΦ.noZeroDivisors Φ (map_zero Φ) (map_mul Φ) + · exact domain_nontrivial Φ (map_zero Φ) (map_one Φ) + +noncomputable def planeCurveCoordinateRingBaseChangeEquiv + (E : Type*) [Field E] [Algebra K E] + (f : MvPolynomial (Fin 2) K) : + E ⊗[K] PlaneCurveCoordinateRing f ≃+* + PlaneCurveCoordinateRing + (MvPolynomial.map (algebraMap K E) f) := by + let P := MvPolynomial (Fin 2) K + let PE := MvPolynomial (Fin 2) E + let I : Ideal P := Ideal.span {f} + let eP : E ⊗[K] P ≃ₐ[E] PE := + MvPolynomial.algebraTensorAlgEquiv K E + let IT : Ideal (E ⊗[K] P) := + I.map (Algebra.TensorProduct.includeRight (R := K) (A := E) (B := P)) + let IE : Ideal PE := + Ideal.span {MvPolynomial.map (algebraMap K E) f} + have hideal : IE = IT.map eP.toRingEquiv.toRingHom := by + simp only [IE, IT, I, Ideal.map_span, Set.image_singleton] + congr 2 + symm + change (MvPolynomial.algebraTensorAlgEquiv K E) + (1 ⊗ₜ[K] f) = MvPolynomial.map (algebraMap K E) f + simpa only [one_smul] using + (MvPolynomial.algebraTensorAlgEquiv_tmul + (R := K) (A := E) (a := (1 : E)) f) + exact + (Algebra.TensorProduct.tensorQuotientEquiv + (R := K) E P E I).toRingEquiv.trans + (Ideal.quotientEquiv IT IE eP.toRingEquiv hideal) + +theorem planeCurveCoordinateRingBaseChange_isDomain + (E : Type*) [Field E] [Algebra K E] + (f : MvPolynomial (Fin 2) K) + (hfE : Irreducible (MvPolynomial.map (algebraMap K E) f)) : + IsDomain (E ⊗[K] PlaneCurveCoordinateRing f) := by + let : IsDomain (PlaneCurveCoordinateRing + (MvPolynomial.map (algebraMap K E) f)) := + planeCurveCoordinateRing_isDomain hfE + exact (planeCurveCoordinateRingBaseChangeEquiv E f).toMulEquiv.isDomain_iff.mpr + inferInstance + +theorem irreducible_mvPolynomial_map_of_tensorQuotient_isDomain + (E : Type*) [Field E] [Algebra K E] + (G : MvPolynomial (Fin 2) K) (hG : Irreducible G) + (hdom : IsDomain + (E ⊗[K] PlaneCurveCoordinateRing G)) : + Irreducible (MvPolynomial.map (algebraMap K E) G) := by + let : IsDomain (E ⊗[K] PlaneCurveCoordinateRing G) := hdom + let e := planeCurveCoordinateRingBaseChangeEquiv E G + let : IsDomain (PlaneCurveCoordinateRing + (MvPolynomial.map (algebraMap K E) G)) := by + have hsource := (isDomain_iff_noZeroDivisors_and_nontrivial + (E ⊗[K] PlaneCurveCoordinateRing G)).mp hdom + let : NoZeroDivisors (E ⊗[K] PlaneCurveCoordinateRing G) := hsource.1 + let : Nontrivial (E ⊗[K] PlaneCurveCoordinateRing G) := hsource.2 + apply (isDomain_iff_noZeroDivisors_and_nontrivial _).mpr + constructor + · exact e.symm.injective.noZeroDivisors e.symm + (map_zero e.symm) (map_mul e.symm) + · exact e.symm.surjective.nontrivial + have hmap_ne : MvPolynomial.map (algebraMap K E) G ≠ 0 := by + intro hzero + apply hG.ne_zero + exact MvPolynomial.map_injective (algebraMap K E) + (algebraMap K E).injective (by simpa using hzero) + have hprime : + (Ideal.span {MvPolynomial.map (algebraMap K E) G} : + Ideal (MvPolynomial (Fin 2) E)).IsPrime := + (Ideal.Quotient.isDomain_iff_prime _).mp inferInstance + exact ((Ideal.span_singleton_prime hmap_ne).mp hprime).irreducible + +theorem poweredCoordinateImageRelation_irreducible_map + {E : Type*} [Field E] [Algebra K E] + {f : MvPolynomial (Fin 2) K} + (habsolute : Irreducible + (MvPolynomial.map (algebraMap K (AlgebraicClosure K)) f)) + (hf : Irreducible f) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (m : ℕ) (hm : 0 < m) (n : ℕ) : + Irreducible + ((poweredCoordinateImageRelation hf hpartialSecond m hm n).map + (Polynomial.mapRingHom (algebraMap K E))) := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let g := poweredCoordinateImageRelation hf hpartialSecond m hm n + let G := Polynomial.Bivariate.equivMvPolynomial K g + have hg : Irreducible g := + poweredCoordinateImageRelation_irreducible + hf hpartialSecond m hm n + have hG : Irreducible G := + hg.map (Polynomial.Bivariate.equivMvPolynomial K).toMulEquiv + obtain ⟨F, hF⟩ := + poweredCoordinateImageRelation_quotient_embeds_source + hf hpartialSecond m hm n + let eQ := bivariateQuotientEquivMvPolynomial g + let FMv : PlaneCurveCoordinateRing G →ₐ[K] + PlaneCurveCoordinateRing f := F.comp eQ.symm.toAlgHom + have hFMv : Function.Injective FMv := hF.comp eQ.symm.injective + have hfE : Irreducible (MvPolynomial.map (algebraMap K E) f) := + irreducible_map_of_irreducible_map_algebraicClosure + (algebraMap K E) f habsolute + have htarget : IsDomain (E ⊗[K] PlaneCurveCoordinateRing f) := + planeCurveCoordinateRingBaseChange_isDomain E f hfE + have hsource : IsDomain (E ⊗[K] PlaneCurveCoordinateRing G) := + tensorProduct_isDomain_of_embedding E FMv hFMv htarget + have hGE : Irreducible (MvPolynomial.map (algebraMap K E) G) := + irreducible_mvPolynomial_map_of_tensorQuotient_isDomain + E G hG hsource + have hback := hGE.map + (Polynomial.Bivariate.equivMvPolynomial E).symm.toMulEquiv + change Irreducible + ((Polynomial.Bivariate.equivMvPolynomial E).symm + (MvPolynomial.map (algebraMap K E) + (Polynomial.Bivariate.equivMvPolynomial K g))) at hback + rw [bivariateEquiv_map_commutes E g] at hback + exact hback + +theorem transposeBivariate_map + {E : Type*} [Field E] (i : K →+* E) + (P : Polynomial (Polynomial K)) : + transposeBivariate + (P.map (Polynomial.mapRingHom i)) = + (transposeBivariate P).map (Polynomial.mapRingHom i) := by + let lhs : Polynomial (Polynomial K) →+* Polynomial (Polynomial E) := + transposeBivariate.comp + (Polynomial.mapRingHom (Polynomial.mapRingHom i)) + let rhs : Polynomial (Polynomial K) →+* Polynomial (Polynomial E) := + (Polynomial.mapRingHom (Polynomial.mapRingHom i)).comp transposeBivariate + change lhs P = rhs P + congr 1 + apply Polynomial.ringHom_ext + · intro q + simp only [lhs, rhs, RingHom.comp_apply, transposeBivariate_C] + ext c + simp + · simp [lhs, rhs, transposeBivariate] + +theorem evalBivariate_map_mapRingHom + {E : Type*} [Field E] [Algebra K E] + {L : Type*} [Field L] [Algebra K L] [Algebra E L] + [IsScalarTower K E L] + (u v : L) (P : Polynomial (Polynomial K)) : + evalBivariate u v + (P.map (Polynomial.mapRingHom (algebraMap K E))) = + evalBivariate u v P := by + unfold evalBivariate + rw [Polynomial.eval₂_map] + congr 1 + apply Polynomial.ringHom_ext + · intro c + simp [IsScalarTower.algebraMap_apply K E L] + · simp + +variable {p : ℕ} [Fact p.Prime] [CharP K p] [PerfectField K] + +noncomputable def poweredCoordinateFrobeniusImageRelation + {f : MvPolynomial (Fin 2) K} + (hf : Irreducible f) (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (m : ℕ) (hm : 0 < m) (n : ℕ) : + letI := planeCurveCoordinateRing_isDomain hf + letI : CharP (PlaneCurveFunctionField f) p := + charP_of_injective_algebraMap + (algebraMap K (PlaneCurveFunctionField f)).injective p + Polynomial (Polynomial + (frobeniusSubfield (PlaneCurveFunctionField f) p)) := by + letI : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let L := PlaneCurveFunctionField f + letI : CharP L p := charP_of_injective_algebraMap + (algebraMap K L).injective p + let ι : K →+* frobeniusSubfield L p := + perfectConstantsToFrobeniusSubfield (K := K) (L := L) (p := p) + exact transposeBivariate + ((poweredCoordinateImageRelation hf hpartialSecond m hm n).map + (Polynomial.mapRingHom ι)) + +theorem poweredCoordinateFrobeniusImageRelation_natDegree + {f : MvPolynomial (Fin 2) K} + (hf : Irreducible f) (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (m : ℕ) (hm : 0 < m) (n : ℕ) : + letI := planeCurveCoordinateRing_isDomain hf + letI : CharP (PlaneCurveFunctionField f) p := + charP_of_injective_algebraMap + (algebraMap K (PlaneCurveFunctionField f)).injective p + (poweredCoordinateFrobeniusImageRelation + (p := p) hf hpartialSecond m hm n).natDegree = + (transposeBivariate + (poweredCoordinateImageRelation hf hpartialSecond m hm n)).natDegree := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let L := PlaneCurveFunctionField f + let : CharP L p := charP_of_injective_algebraMap + (algebraMap K L).injective p + let F := frobeniusSubfield L p + let ι : K →+* F := + perfectConstantsToFrobeniusSubfield (K := K) (L := L) (p := p) + have hι : Function.Injective ι := + perfectConstantsToFrobeniusSubfield_injective + (K := K) (L := L) (p := p) + have hmap : Function.Injective (Polynomial.mapRingHom ι) := + Polynomial.map_injective ι hι + change (transposeBivariate + ((poweredCoordinateImageRelation hf hpartialSecond m hm n).map + (Polynomial.mapRingHom ι))).natDegree = _ + rw [transposeBivariate_map] + exact Polynomial.natDegree_map_eq_of_injective hmap _ + +theorem transposeBivariate_poweredCoordinateFrobeniusImageRelation_natDegree + {f : MvPolynomial (Fin 2) K} + (hf : Irreducible f) (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (m : ℕ) (hm : 0 < m) (n : ℕ) : + letI := planeCurveCoordinateRing_isDomain hf + letI : CharP (PlaneCurveFunctionField f) p := + charP_of_injective_algebraMap + (algebraMap K (PlaneCurveFunctionField f)).injective p + (transposeBivariate + (poweredCoordinateFrobeniusImageRelation + (p := p) hf hpartialSecond m hm n)).natDegree = + (poweredCoordinateImageRelation hf hpartialSecond m hm n).natDegree := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let L := PlaneCurveFunctionField f + let : CharP L p := charP_of_injective_algebraMap + (algebraMap K L).injective p + let F := frobeniusSubfield L p + let ι : K →+* F := + perfectConstantsToFrobeniusSubfield (K := K) (L := L) (p := p) + have hι : Function.Injective ι := + perfectConstantsToFrobeniusSubfield_injective + (K := K) (L := L) (p := p) + have hmap : Function.Injective (Polynomial.mapRingHom ι) := + Polynomial.map_injective ι hι + change (transposeBivariate (transposeBivariate + ((poweredCoordinateImageRelation hf hpartialSecond m hm n).map + (Polynomial.mapRingHom ι)))).natDegree = _ + rw [transposeBivariate_transposeBivariate] + exact Polynomial.natDegree_map_eq_of_injective hmap _ + +theorem evalBivariate_poweredCoordinateFrobeniusImageRelation_eq_zero + {f : MvPolynomial (Fin 2) K} + (hf : Irreducible f) (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (m : ℕ) (hm : 0 < m) (n : ℕ) : + letI := planeCurveCoordinateRing_isDomain hf + letI : CharP (PlaneCurveFunctionField f) p := + charP_of_injective_algebraMap + (algebraMap K (PlaneCurveFunctionField f)).injective p + evalBivariate + ((planeCurveFunction f 1) ^ n) + ((planeCurveFunction f 0) ^ m) + (poweredCoordinateFrobeniusImageRelation + (p := p) hf hpartialSecond m hm n) = 0 := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let L := PlaneCurveFunctionField f + let : CharP L p := charP_of_injective_algebraMap + (algebraMap K L).injective p + let F := frobeniusSubfield L p + let ι : K →+* F := + perfectConstantsToFrobeniusSubfield (K := K) (L := L) (p := p) + let : Algebra K F := ι.toAlgebra + let : IsScalarTower K F L := by + apply IsScalarTower.of_algebraMap_eq' + ext c + exact (coe_perfectConstantsToFrobeniusSubfield + (K := K) (L := L) (p := p) c).symm + change evalBivariate + ((planeCurveFunction f 1) ^ n) + ((planeCurveFunction f 0) ^ m) + (transposeBivariate + ((poweredCoordinateImageRelation hf hpartialSecond m hm n).map + (Polynomial.mapRingHom (algebraMap K F)))) = 0 + rw [evalBivariate_transposeBivariate, evalBivariate_map_mapRingHom] + exact evalBivariate_poweredCoordinateImageRelation_eq_zero + hf hpartialSecond m hm n + +theorem poweredCoordinateFrobeniusImageRelation_irreducible + {f : MvPolynomial (Fin 2) K} + (habsolute : Irreducible + (MvPolynomial.map (algebraMap K (AlgebraicClosure K)) f)) + (hf : Irreducible f) (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (m : ℕ) (hm : 0 < m) (n : ℕ) : + letI := planeCurveCoordinateRing_isDomain hf + letI : CharP (PlaneCurveFunctionField f) p := + charP_of_injective_algebraMap + (algebraMap K (PlaneCurveFunctionField f)).injective p + Irreducible + (poweredCoordinateFrobeniusImageRelation + (p := p) hf hpartialSecond m hm n) := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let L := PlaneCurveFunctionField f + let : CharP L p := charP_of_injective_algebraMap + (algebraMap K L).injective p + let F := frobeniusSubfield L p + let ι : K →+* F := + perfectConstantsToFrobeniusSubfield (K := K) (L := L) (p := p) + have hbase : Irreducible + ((poweredCoordinateImageRelation hf hpartialSecond m hm n).map + (Polynomial.mapRingHom ι)) := by + let : Algebra K F := ι.toAlgebra + exact poweredCoordinateImageRelation_irreducible_map + (E := F) habsolute hf hpartialSecond m hm n + exact irreducible_transposeBivariate hbase + +theorem poweredCoordinateFrobeniusImage_auxiliaryFamily_linearIndependent + {f : MvPolynomial (Fin 2) K} + (habsolute : Irreducible + (MvPolynomial.map (algebraMap K (AlgebraicClosure K)) f)) + (hf : Irreducible f) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (m n : ℕ) (hm : 0 < m) (hn : ¬ p ∣ n) + (h k : ℕ) (hh : 0 < h) (hk : 0 < k) + (hsize : + letI := planeCurveCoordinateRing_isDomain hf + letI : CharP (PlaneCurveFunctionField f) p := + charP_of_injective_algebraMap + (algebraMap K (PlaneCurveFunctionField f)).injective p + let g := poweredCoordinateFrobeniusImageRelation + (p := p) hf hpartialSecond m hm n + g.natDegree * h + (transposeBivariate g).natDegree * k < p) + (hexcluded : + letI := planeCurveCoordinateRing_isDomain hf + letI : CharP (PlaneCurveFunctionField f) p := + charP_of_injective_algebraMap + (algebraMap K (PlaneCurveFunctionField f)).injective p + let g := poweredCoordinateFrobeniusImageRelation + (p := p) hf hpartialSecond m hm n + ¬ (g.natDegree ≤ k ∧ (transposeBivariate g).natDegree ≤ h)) : + letI := planeCurveCoordinateRing_isDomain hf + letI : CharP (PlaneCurveFunctionField f) p := + charP_of_injective_algebraMap + (algebraMap K (PlaneCurveFunctionField f)).injective p + LinearIndependent + (frobeniusSubfield (PlaneCurveFunctionField f) p) + (auxiliaryFamily ((planeCurveFunction f 0) ^ m) + ((planeCurveFunction f 1) ^ n) h k) := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let L := PlaneCurveFunctionField f + let : CharP L p := charP_of_injective_algebraMap + (algebraMap K L).injective p + let F := frobeniusSubfield L p + let ι : K →+* F := + perfectConstantsToFrobeniusSubfield (K := K) (L := L) (p := p) + let : Algebra K F := ι.toAlgebra + let : IsScalarTower K F L := by + apply IsScalarTower.of_algebraMap_eq' + ext c + exact (coe_perfectConstantsToFrobeniusSubfield + (K := K) (L := L) (p := p) c).symm + let gK := poweredCoordinateImageRelation hf hpartialSecond m hm n + let gBase : Polynomial (Polynomial F) := + gK.map (Polynomial.mapRingHom ι) + let g : Polynomial (Polynomial F) := transposeBivariate gBase + have hι : Function.Injective ι := + perfectConstantsToFrobeniusSubfield_injective + (K := K) (L := L) (p := p) + have hmap : Function.Injective (Polynomial.mapRingHom ι) := + Polynomial.map_injective ι hι + have hg : Irreducible g := by + exact poweredCoordinateFrobeniusImageRelation_irreducible + (p := p) habsolute hf hpartialSecond m hm n + have hn0 : n ≠ 0 := by + intro hn0 + apply hn + simp [hn0] + have hnPos : 0 < n := Nat.pos_of_ne_zero hn0 + have hdegreeG : g.natDegree = + (transposeBivariate gK).natDegree := by + dsimp [g, gBase] + rw [transposeBivariate_map] + exact Polynomial.natDegree_map_eq_of_injective hmap _ + have ha : 0 < g.natDegree := by + rw [hdegreeG] + exact poweredCoordinateImageRelation_transpose_natDegree_pos + hf hpartialFirst hpartialSecond m hm n hnPos + have hdegreeTranspose : (transposeBivariate g).natDegree = gK.natDegree := by + dsimp [g] + rw [transposeBivariate_transposeBivariate] + dsimp [gBase] + exact Polynomial.natDegree_map_eq_of_injective hmap _ + have hb : 0 < (transposeBivariate g).natDegree := by + rw [hdegreeTranspose] + exact poweredCoordinateImageRelation_natDegree_pos + hf hpartialSecond m hm n + have hcoeff : ∀ i, (g.coeff i).natDegree ≤ + (transposeBivariate g).natDegree := by + intro i + have hcoeffBase := transposeBivariate_coeff_natDegree_le gBase + gBase.natDegree le_rfl i + simpa only [g, transposeBivariate_transposeBivariate] using hcoeffBase + have hzeroBase : evalBivariate + ((planeCurveFunction f 0) ^ m) + ((planeCurveFunction f 1) ^ n) gBase = 0 := by + dsimp [gBase] + change evalBivariate + ((planeCurveFunction f 0) ^ m) + ((planeCurveFunction f 1) ^ n) + (gK.map (Polynomial.mapRingHom (algebraMap K F))) = 0 + rw [evalBivariate_map_mapRingHom] + exact evalBivariate_poweredCoordinateImageRelation_eq_zero + hf hpartialSecond m hm n + have hzero : evalBivariate + ((planeCurveFunction f 1) ^ n) + ((planeCurveFunction f 0) ^ m) g = 0 := by + dsimp [g] + rw [evalBivariate_transposeBivariate] + exact hzeroBase + exact poweredCoordinates_auxiliaryFamily_linearIndependent_of_relation + hf hpartialFirst m n hn g g.natDegree + (transposeBivariate g).natDegree h k ha hh hk hg rfl rfl + hcoeff hzero hsize hexcluded + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/PoweredImageFrobeniusRelationSwapped.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/PoweredImageFrobeniusRelationSwapped.lean new file mode 100644 index 0000000000..9a9ee40ad3 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/PoweredImageFrobeniusRelationSwapped.lean @@ -0,0 +1,164 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PoweredImageFrobeniusRelation +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PoweredCoordinateRelation +public import Mathlib.Tactic + +/-! +# The powered-image auxiliary family with exchanged coordinates + +The existing powered-image theorem orients the auxiliary family as +`(x^m,y^n)`. Proposition 2 is applied with the smaller source height first, +so this module supplies the equally canonical orientation `(y^n,x^m)`. +It uses the untransposed powered-image equation and the first-coordinate +Frobenius power basis. +-/ + +@[expose] public section + +open scoped Polynomial + +namespace BGS.CorvajaZannier + +open Polynomial + +noncomputable section + + +variable {K : Type*} [Field K] [PerfectField K] +variable {p : ℕ} [Fact p.Prime] [CharP K p] + +/-- Proposition 1 for the powered coordinates in the exchanged orientation. +The relation degrees are those of the untransposed powered-image equation. -/ +theorem poweredCoordinateFrobeniusImage_auxiliaryFamily_linearIndependent_swapped + {f : MvPolynomial (Fin 2) K} + (habsolute : Irreducible + (MvPolynomial.map (algebraMap K (AlgebraicClosure K)) f)) + (hf : Irreducible f) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (m n : ℕ) (hm : 0 < m) (hn : 0 < n) (hmPrime : ¬ p ∣ m) + (h k : ℕ) (hh : 0 < h) (hk : 0 < k) + (hsize : + letI := planeCurveCoordinateRing_isDomain hf + letI : CharP (PlaneCurveFunctionField f) p := + charP_of_injective_algebraMap + (algebraMap K (PlaneCurveFunctionField f)).injective p + let F := frobeniusSubfield (PlaneCurveFunctionField f) p + let ι : K →+* F := perfectConstantsToFrobeniusSubfield + (K := K) (L := PlaneCurveFunctionField f) (p := p) + let g := (poweredCoordinateImageRelation hf hpartialSecond m hm n).map + (Polynomial.mapRingHom ι) + g.natDegree * h + (transposeBivariate g).natDegree * k < p) + (hexcluded : + letI := planeCurveCoordinateRing_isDomain hf + letI : CharP (PlaneCurveFunctionField f) p := + charP_of_injective_algebraMap + (algebraMap K (PlaneCurveFunctionField f)).injective p + let F := frobeniusSubfield (PlaneCurveFunctionField f) p + let ι : K →+* F := perfectConstantsToFrobeniusSubfield + (K := K) (L := PlaneCurveFunctionField f) (p := p) + let g := (poweredCoordinateImageRelation hf hpartialSecond m hm n).map + (Polynomial.mapRingHom ι) + ¬ (g.natDegree ≤ k ∧ (transposeBivariate g).natDegree ≤ h)) : + letI := planeCurveCoordinateRing_isDomain hf + letI : CharP (PlaneCurveFunctionField f) p := + charP_of_injective_algebraMap + (algebraMap K (PlaneCurveFunctionField f)).injective p + LinearIndependent + (frobeniusSubfield (PlaneCurveFunctionField f) p) + (auxiliaryFamily ((planeCurveFunction f 1) ^ n) + ((planeCurveFunction f 0) ^ m) h k) := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let L := PlaneCurveFunctionField f + let : CharP L p := charP_of_injective_algebraMap + (algebraMap K L).injective p + let F := frobeniusSubfield L p + let ι : K →+* F := + perfectConstantsToFrobeniusSubfield (K := K) (L := L) (p := p) + let : Algebra K F := ι.toAlgebra + let : IsScalarTower K F L := by + apply IsScalarTower.of_algebraMap_eq' + ext c + exact (coe_perfectConstantsToFrobeniusSubfield + (K := K) (L := L) (p := p) c).symm + let gK := poweredCoordinateImageRelation hf hpartialSecond m hm n + let g : Polynomial (Polynomial F) := + gK.map (Polynomial.mapRingHom ι) + have hι : Function.Injective ι := + perfectConstantsToFrobeniusSubfield_injective + (K := K) (L := L) (p := p) + have hmap : Function.Injective (Polynomial.mapRingHom ι) := + Polynomial.map_injective ι hι + have hg : Irreducible g := by + dsimp only [g, gK] + exact poweredCoordinateImageRelation_irreducible_map + (E := F) habsolute hf hpartialSecond m hm n + have hdegreeG : g.natDegree = gK.natDegree := by + dsimp only [g] + exact Polynomial.natDegree_map_eq_of_injective hmap _ + have ha : 0 < g.natDegree := by + rw [hdegreeG] + exact poweredCoordinateImageRelation_natDegree_pos + hf hpartialSecond m hm n + have hdegreeTranspose : (transposeBivariate g).natDegree = + (transposeBivariate gK).natDegree := by + dsimp only [g] + rw [transposeBivariate_map] + exact Polynomial.natDegree_map_eq_of_injective hmap _ + have hb : 0 < (transposeBivariate g).natDegree := by + rw [hdegreeTranspose] + exact poweredCoordinateImageRelation_transpose_natDegree_pos + hf hpartialFirst hpartialSecond m hm n hn + have hcoeff : ∀ i, (g.coeff i).natDegree ≤ + (transposeBivariate g).natDegree := by + intro i + have hcoeffK := poweredCoordinateImageRelation_coeff_natDegree_le + hf hpartialSecond m hm n i + have hcoeffDegree : (g.coeff i).natDegree = (gK.coeff i).natDegree := by + dsimp only [g] + rw [Polynomial.coeff_map] + exact Polynomial.natDegree_map_eq_of_injective hι _ + rw [hcoeffDegree, hdegreeTranspose] + exact hcoeffK + have hzero : evalBivariate + ((planeCurveFunction f 0) ^ m) + ((planeCurveFunction f 1) ^ n) g = 0 := by + dsimp only [g] + change evalBivariate + ((planeCurveFunction f 0) ^ m) + ((planeCurveFunction f 1) ^ n) + (gK.map (Polynomial.mapRingHom (algebraMap K F))) = 0 + rw [evalBivariate_map_mapRingHom] + exact evalBivariate_poweredCoordinateImageRelation_eq_zero + hf hpartialSecond m hm n + have hminpoly : + (minpoly F ((planeCurveFunction f 0) ^ m)).natDegree = p := + minpoly_firstCoordinatePow_natDegree_eq_char + hf hpartialSecond m hmPrime + have hxTrans : Transcendental K (planeCurveFunction f 0) := + firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + have hxmTrans : Transcendental K ((planeCurveFunction f 0) ^ m) := + hxTrans.pow hm + have hxmOne : (planeCurveFunction f 0) ^ m ≠ 1 := by + intro hxm + apply hxmTrans + rw [hxm] + exact isAlgebraic_one + exact auxiliaryFamily_linearIndependent_of_irreducible_bidegree + g g.natDegree (transposeBivariate g).natDegree h k p + ha hh hk hg rfl rfl hcoeff + ((planeCurveFunction f 1) ^ n) ((planeCurveFunction f 0) ^ m) + hxmOne hminpoly hzero hsize hexcluded + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/PoweredImageGaloisBound.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/PoweredImageGaloisBound.lean new file mode 100644 index 0000000000..ecf7fd7c85 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/PoweredImageGaloisBound.lean @@ -0,0 +1,585 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveDiagonalStabilizer +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PoweredImageIndex +public import Mathlib.FieldTheory.Galois.Basic +public import Mathlib.FieldTheory.KummerExtension +public import Mathlib.RingTheory.RootsOfUnity.AlgebraicallyClosed +public import Mathlib.Tactic + +/-! +# The source-to-powered-image index over algebraically closed constants + +When the power exponents are nonzero in the constant field, the source +function field is a Galois extension of the field generated by the two powered +coordinates. Its automorphisms act diagonally on the two coordinates. The +resulting pair of roots of unity lies in the support-character stabilizer, so +a rank-two support determinant bounds the extension degree. +-/ + +@[expose] public section + +namespace BGS.CorvajaZannier +noncomputable section + +private def autUnitRatio {B L : Type*} [Field B] [Field L] [Algebra B L] + (σ : L ≃ₐ[B] L) (x : L) (hx : x ≠ 0) : Lˣ := + Units.mk0 (σ x / x) (div_ne_zero ((map_ne_zero σ).2 hx) hx) + +private theorem autUnitRatio_pow_eq_one + {B L : Type*} [Field B] [Field L] [Algebra B L] + (σ : L ≃ₐ[B] L) (x : L) (hx : x ≠ 0) (d : ℕ) + (hfix : σ (x ^ d) = x ^ d) : + autUnitRatio σ x hx ^ d = 1 := by + apply Units.ext + change (σ x / x) ^ d = 1 + rw [div_pow, ← map_pow, hfix, div_self (pow_ne_zero d hx)] + +private def descendedRootUnit + {F L : Type*} [Field F] [Field L] [Algebra F L] + {d : ℕ} [NeZero d] + (hμ : (primitiveRoots d F).Nonempty) + (u : Lˣ) (hu : u ^ d = 1) : Fˣ := + ((rootsOfUnityEquivOfPrimitiveRoots (algebraMap F L).injective hμ).symm + (⟨u, hu⟩ : rootsOfUnity d L)).1 + +private theorem algebraMap_descendedRootUnit + {F L : Type*} [Field F] [Field L] [Algebra F L] + {d : ℕ} [NeZero d] + (hμ : (primitiveRoots d F).Nonempty) + (u : Lˣ) (hu : u ^ d = 1) : + algebraMap F L (descendedRootUnit hμ u hu : F) = (u : L) := by + exact rootsOfUnityEquivOfPrimitiveRoots_symm_apply + (algebraMap F L).injective hμ (⟨u, hu⟩ : rootsOfUnity d L) + +theorem poweredCoordinateImageField_adjoin_coordinates_eq_top_and_ne_zero + {F : Type*} [Field F] {f : MvPolynomial (Fin 2) F} + (hf : Irreducible f) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (m n : ℕ) : + letI := planeCurveCoordinateRing_isDomain hf + let L := PlaneCurveFunctionField f + let B := PoweredCoordinateImageField f m n + IntermediateField.adjoin B + ({planeCurveFunction f 0, planeCurveFunction f 1} : Set L) = ⊤ ∧ + planeCurveFunction f 0 ≠ 0 ∧ planeCurveFunction f 1 ≠ 0 := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let L := PlaneCurveFunctionField f + let B := PoweredCoordinateImageField f m n + have hxtrans : Transcendental F (planeCurveFunction f 0) := + firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + have hytrans : Transcendental F (planeCurveFunction f 1) := + secondCoordinate_transcendental hf + (degreeOf_first_pos_of_pderiv_ne_zero hpartialFirst) + have hx0 : planeCurveFunction f 0 ≠ 0 := by + intro hx + apply hxtrans + rw [hx] + exact isAlgebraic_zero + have hy0 : planeCurveFunction f 1 ≠ 0 := by + intro hy + apply hytrans + rw [hy] + exact isAlgebraic_zero + refine ⟨?_, hx0, hy0⟩ + apply IntermediateField.restrictScalars_injective F + rw [IntermediateField.restrictScalars_top] + rw [IntermediateField.restrictScalars_adjoin_eq_sup] + have hxy : IntermediateField.adjoin F + ({planeCurveFunction f 0, planeCurveFunction f 1} : Set L) = ⊤ := by + rw [← range_planeCurveFunction f] + exact adjoin_planeCurveFunctions_eq_top + rw [hxy] + exact sup_eq_right.mpr le_top + +theorem finiteDimensional_poweredCoordinateImageField + {F : Type*} [Field F] {f : MvPolynomial (Fin 2) F} + (hf : Irreducible f) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (m n : ℕ) (hm : 0 < m) : + let := planeCurveCoordinateRing_isDomain hf + FiniteDimensional (PoweredCoordinateImageField f m n) + (PlaneCurveFunctionField f) := by + intro domain + let L := PlaneCurveFunctionField f + let E0 := FirstPoweredCoordinateSubfield f m + let B := PoweredCoordinateImageField f m n + let : FiniteDimensional E0 L := + finiteDimensional_over_firstPoweredCoordinate hf hpartialSecond m hm + have hE0B : E0 ≤ B := by + apply IntermediateField.adjoin.mono F + intro z hz + simp only [Set.mem_singleton_iff] at hz + simp only [Set.mem_insert_iff, Set.mem_singleton_iff] + exact Or.inl hz + let : Algebra E0 B := + (IntermediateField.inclusion hE0B).toRingHom.toAlgebra + let : IsScalarTower E0 B L := by + apply IsScalarTower.of_algebraMap_eq' + ext z + rfl + exact Module.Finite.of_restrictScalars_finite E0 B L + +theorem firstCoordinate_isSeparable_over_poweredCoordinateImageField + {F : Type*} [Field F] {f : MvPolynomial (Fin 2) F} + (hf : Irreducible f) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (m n : ℕ) (hmF : (m : F) ≠ 0) : + letI := planeCurveCoordinateRing_isDomain hf + IsSeparable (PoweredCoordinateImageField f m n) + (planeCurveFunction f 0) := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let L := PlaneCurveFunctionField f + let B := PoweredCoordinateImageField f m n + let x : L := planeCurveFunction f 0 + have hxtrans : Transcendental F x := + firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + have hx0 : x ≠ 0 := by + intro hx + apply hxtrans + rw [hx] + exact isAlgebraic_zero + let bx : B := ⟨x ^ m, by + apply IntermediateField.subset_adjoin F + simp [x]⟩ + let P : Polynomial B := Polynomial.X ^ m - Polynomial.C bx + have hP : Polynomial.aeval x P = 0 := by + simp only [P, map_sub, map_pow, Polynomial.aeval_X, Polynomial.aeval_C] + change x ^ m - (algebraMap B L) bx = 0 + rw [IntermediateField.algebraMap_apply] + simp [bx] + have hdvd : minpoly B x ∣ P := minpoly.dvd B x hP + have hmB : (m : B) ≠ 0 := by + intro h + apply hmF + apply (algebraMap F B).injective + simpa using h + have hbx0 : bx ≠ 0 := by + intro h + apply pow_ne_zero m hx0 + exact congrArg Subtype.val h + exact Polynomial.Separable.of_dvd + (Polynomial.separable_X_pow_sub_C bx hmB hbx0) + hdvd + +theorem firstCoordinate_minpoly_splits_over_poweredCoordinateImageField + {F : Type*} [Field F] [IsAlgClosed F] + {f : MvPolynomial (Fin 2) F} + (hf : Irreducible f) + (m n : ℕ) (hm : 0 < m) (hmF : (m : F) ≠ 0) : + letI := planeCurveCoordinateRing_isDomain hf + (Polynomial.map + (algebraMap (PoweredCoordinateImageField f m n) + (PlaneCurveFunctionField f)) + (minpoly (PoweredCoordinateImageField f m n) + (planeCurveFunction f 0))).Splits := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let L := PlaneCurveFunctionField f + let B := PoweredCoordinateImageField f m n + let x : L := planeCurveFunction f 0 + let bx : B := ⟨x ^ m, by + apply IntermediateField.subset_adjoin F + simp [x]⟩ + let P : Polynomial B := Polynomial.X ^ m - Polynomial.C bx + have hP : Polynomial.aeval x P = 0 := by + simp only [P, map_sub, map_pow, Polynomial.aeval_X, Polynomial.aeval_C] + change x ^ m - (algebraMap B L) bx = 0 + rw [IntermediateField.algebraMap_apply] + simp [bx] + have hdvd : minpoly B x ∣ P := minpoly.dvd B x hP + let : NeZero m := ⟨Nat.ne_of_gt hm⟩ + let : NeZero (m : F) := ⟨hmF⟩ + obtain ⟨ζ, hζ⟩ := HasEnoughRootsOfUnity.exists_primitiveRoot F m + have hζL : IsPrimitiveRoot (algebraMap F L ζ) m := + hζ.map_of_injective (algebraMap F L).injective + have hsplits : (Polynomial.X ^ m - Polynomial.C (x ^ m)).Splits := + X_pow_sub_C_splits_of_isPrimitiveRoot hζL rfl + apply Polynomial.Splits.of_dvd hsplits + (Polynomial.X_pow_sub_C_ne_zero hm (x ^ m)) + have hmap := Polynomial.map_dvd (algebraMap B L) hdvd + have hbx : (algebraMap B L) bx = x ^ m := by + rw [IntermediateField.algebraMap_apply] + rw [show P = Polynomial.X ^ m - Polynomial.C bx from rfl, + Polynomial.map_sub, Polynomial.map_pow, Polynomial.map_X, + Polynomial.map_C, hbx] at hmap + exact hmap + +theorem secondCoordinate_isSeparable_over_poweredCoordinateImageField + {F : Type*} [Field F] {f : MvPolynomial (Fin 2) F} + (hf : Irreducible f) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (m n : ℕ) (hnF : (n : F) ≠ 0) : + letI := planeCurveCoordinateRing_isDomain hf + IsSeparable (PoweredCoordinateImageField f m n) + (planeCurveFunction f 1) := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let L := PlaneCurveFunctionField f + let B := PoweredCoordinateImageField f m n + let y : L := planeCurveFunction f 1 + have hytrans : Transcendental F y := + secondCoordinate_transcendental hf + (degreeOf_first_pos_of_pderiv_ne_zero hpartialFirst) + have hy0 : y ≠ 0 := by + intro hy + apply hytrans + rw [hy] + exact isAlgebraic_zero + let by' : B := ⟨y ^ n, by + apply IntermediateField.subset_adjoin F + simp [y]⟩ + let P : Polynomial B := Polynomial.X ^ n - Polynomial.C by' + have hP : Polynomial.aeval y P = 0 := by + simp only [P, map_sub, map_pow, Polynomial.aeval_X, Polynomial.aeval_C] + change y ^ n - (algebraMap B L) by' = 0 + rw [IntermediateField.algebraMap_apply] + simp [by'] + have hdvd : minpoly B y ∣ P := minpoly.dvd B y hP + have hnB : (n : B) ≠ 0 := by + intro h + apply hnF + apply (algebraMap F B).injective + simpa using h + have hby0 : by' ≠ 0 := by + intro h + apply pow_ne_zero n hy0 + exact congrArg Subtype.val h + exact Polynomial.Separable.of_dvd + (Polynomial.separable_X_pow_sub_C by' hnB hby0) + hdvd + +theorem secondCoordinate_minpoly_splits_over_poweredCoordinateImageField + {F : Type*} [Field F] [IsAlgClosed F] + {f : MvPolynomial (Fin 2) F} + (hf : Irreducible f) + (m n : ℕ) (hn : 0 < n) (hnF : (n : F) ≠ 0) : + letI := planeCurveCoordinateRing_isDomain hf + (Polynomial.map + (algebraMap (PoweredCoordinateImageField f m n) + (PlaneCurveFunctionField f)) + (minpoly (PoweredCoordinateImageField f m n) + (planeCurveFunction f 1))).Splits := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let L := PlaneCurveFunctionField f + let B := PoweredCoordinateImageField f m n + let y : L := planeCurveFunction f 1 + let by' : B := ⟨y ^ n, by + apply IntermediateField.subset_adjoin F + simp [y]⟩ + let P : Polynomial B := Polynomial.X ^ n - Polynomial.C by' + have hP : Polynomial.aeval y P = 0 := by + simp only [P, map_sub, map_pow, Polynomial.aeval_X, Polynomial.aeval_C] + change y ^ n - (algebraMap B L) by' = 0 + rw [IntermediateField.algebraMap_apply] + simp [by'] + have hdvd : minpoly B y ∣ P := minpoly.dvd B y hP + let : NeZero n := ⟨Nat.ne_of_gt hn⟩ + let : NeZero (n : F) := ⟨hnF⟩ + obtain ⟨η, hη⟩ := HasEnoughRootsOfUnity.exists_primitiveRoot F n + have hηL : IsPrimitiveRoot (algebraMap F L η) n := + hη.map_of_injective (algebraMap F L).injective + have hsplits : (Polynomial.X ^ n - Polynomial.C (y ^ n)).Splits := + X_pow_sub_C_splits_of_isPrimitiveRoot hηL rfl + apply Polynomial.Splits.of_dvd hsplits + (Polynomial.X_pow_sub_C_ne_zero hn (y ^ n)) + have hmap := Polynomial.map_dvd (algebraMap B L) hdvd + have hby : (algebraMap B L) by' = y ^ n := by + rw [IntermediateField.algebraMap_apply] + rw [show P = Polynomial.X ^ n - Polynomial.C by' from rfl, + Polynomial.map_sub, Polynomial.map_pow, Polynomial.map_X, + Polynomial.map_C, hby] at hmap + exact hmap + +theorem isGalois_over_poweredCoordinateImageField + {F : Type*} [Field F] [IsAlgClosed F] + {f : MvPolynomial (Fin 2) F} + (hf : Irreducible f) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (m n : ℕ) (hm : 0 < m) (hn : 0 < n) + (hmF : (m : F) ≠ 0) (hnF : (n : F) ≠ 0) : + letI := planeCurveCoordinateRing_isDomain hf + IsGalois (PoweredCoordinateImageField f m n) + (PlaneCurveFunctionField f) := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let L := PlaneCurveFunctionField f + let B := PoweredCoordinateImageField f m n + let E0 := FirstPoweredCoordinateSubfield f m + let : FiniteDimensional E0 L := + finiteDimensional_over_firstPoweredCoordinate hf hpartialSecond m hm + have hE0B : E0 ≤ B := by + apply IntermediateField.adjoin.mono F + intro z hz + simp only [Set.mem_singleton_iff] at hz + simp only [Set.mem_insert_iff, Set.mem_singleton_iff] + exact Or.inl hz + let : Algebra E0 B := + (IntermediateField.inclusion hE0B).toRingHom.toAlgebra + let : IsScalarTower E0 B L := by + apply IsScalarTower.of_algebraMap_eq' + ext z + rfl + let : FiniteDimensional B L := + Module.Finite.of_restrictScalars_finite E0 B L + let x : L := planeCurveFunction f 0 + let y : L := planeCurveFunction f 1 + have hbasic := poweredCoordinateImageField_adjoin_coordinates_eq_top_and_ne_zero hf hpartialFirst + hpartialSecond m n + have hgen : IntermediateField.adjoin B ({x, y} : Set L) = ⊤ := hbasic.1 + have hxsep : IsSeparable B x := + firstCoordinate_isSeparable_over_poweredCoordinateImageField hf hpartialSecond m n hmF + have hysep : IsSeparable B y := + secondCoordinate_isSeparable_over_poweredCoordinateImageField hf hpartialFirst m n hnF + let : Algebra.IsSeparable B L := ⟨fun z => by + let : Algebra.IsSeparable B (IntermediateField.adjoin B ({x, y} : Set L)) := + IntermediateField.isSeparable_adjoin_pair_of_isSeparable B L hxsep hysep + have hz : z ∈ IntermediateField.adjoin B ({x, y} : Set L) := by + rw [hgen] + exact Set.mem_univ z + exact IntermediateField.isSeparable_of_mem_isSeparable B L hz⟩ + have hxsplits : + (Polynomial.map (algebraMap B L) (minpoly B x)).Splits := + firstCoordinate_minpoly_splits_over_poweredCoordinateImageField hf m n hm hmF + have hysplits : + (Polynomial.map (algebraMap B L) (minpoly B y)).Splits := + secondCoordinate_minpoly_splits_over_poweredCoordinateImageField hf m n hn hnF + let : Normal B L := normal_iff.mpr fun z => by + refine ⟨Algebra.IsIntegral.isIntegral z, ?_⟩ + have hz : z ∈ IntermediateField.adjoin B ({x, y} : Set L) := by + rw [hgen] + exact Set.mem_univ z + apply IntermediateField.splits_of_mem_adjoin B L _ hz + intro q hq + simp only [Set.mem_insert_iff, Set.mem_singleton_iff] at hq + rcases hq with rfl | rfl + · exact ⟨IsSeparable.isIntegral hxsep, hxsplits⟩ + · exact ⟨IsSeparable.isIntegral hysep, hysplits⟩ + exact IsGalois.mk + +theorem exists_support_stabilizer_scaling_of_poweredImage_aut + {F : Type*} [Field F] [IsAlgClosed F] + {f : MvPolynomial (Fin 2) F} + (hf : Irreducible f) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (m n : ℕ) (hm : 0 < m) (hn : 0 < n) + (hmF : (m : F) ≠ 0) (hnF : (n : F) ≠ 0) + (σ : + letI := planeCurveCoordinateRing_isDomain hf + (PlaneCurveFunctionField f) ≃ₐ[PoweredCoordinateImageField f m n] + (PlaneCurveFunctionField f)) : + letI := planeCurveCoordinateRing_isDomain hf + ∃ z : Fˣ × Fˣ, + algebraMap F (PlaneCurveFunctionField f) z.1 * planeCurveFunction f 0 = + σ (planeCurveFunction f 0) ∧ + algebraMap F (PlaneCurveFunctionField f) z.2 * planeCurveFunction f 1 = + σ (planeCurveFunction f 1) ∧ + (∀ r ∈ f.support, ∀ s ∈ f.support, + z.1 ^ ((s 0 : ℤ) - (r 0 : ℤ)) * + z.2 ^ ((s 1 : ℤ) - (r 1 : ℤ)) = 1) := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let L := PlaneCurveFunctionField f + let B := PoweredCoordinateImageField f m n + let x : L := planeCurveFunction f 0 + let y : L := planeCurveFunction f 1 + have hbasic := poweredCoordinateImageField_adjoin_coordinates_eq_top_and_ne_zero hf hpartialFirst + hpartialSecond m n + have hx0 : x ≠ 0 := hbasic.2.1 + have hy0 : y ≠ 0 := hbasic.2.2 + let bx : B := ⟨x ^ m, by + apply IntermediateField.subset_adjoin F + simp [x]⟩ + let by' : B := ⟨y ^ n, by + apply IntermediateField.subset_adjoin F + simp [y]⟩ + have hbx : (algebraMap B L) bx = x ^ m := by + rw [IntermediateField.algebraMap_apply] + have hby : (algebraMap B L) by' = y ^ n := by + rw [IntermediateField.algebraMap_apply] + have hfixx : σ (x ^ m) = x ^ m := by + rw [← hbx, σ.commutes] + have hfixy : σ (y ^ n) = y ^ n := by + rw [← hby, σ.commutes] + have hux : autUnitRatio σ x hx0 ^ m = 1 := + autUnitRatio_pow_eq_one σ x hx0 m hfixx + have huy : autUnitRatio σ y hy0 ^ n = 1 := + autUnitRatio_pow_eq_one σ y hy0 n hfixy + let : NeZero m := ⟨Nat.ne_of_gt hm⟩ + let : NeZero n := ⟨Nat.ne_of_gt hn⟩ + let : NeZero (m : F) := ⟨hmF⟩ + let : NeZero (n : F) := ⟨hnF⟩ + obtain ⟨ζ, hζ⟩ := HasEnoughRootsOfUnity.exists_primitiveRoot F m + obtain ⟨η, hη⟩ := HasEnoughRootsOfUnity.exists_primitiveRoot F n + have hμm : (primitiveRoots m F).Nonempty := + ⟨ζ, (mem_primitiveRoots hm).2 hζ⟩ + have hμn : (primitiveRoots n F).Nonempty := + ⟨η, (mem_primitiveRoots hn).2 hη⟩ + let zx : Fˣ := descendedRootUnit hμm (autUnitRatio σ x hx0) hux + let zy : Fˣ := descendedRootUnit hμn (autUnitRatio σ y hy0) huy + have hzxMap : algebraMap F L (zx : F) = (autUnitRatio σ x hx0 : L) := + algebraMap_descendedRootUnit hμm (autUnitRatio σ x hx0) hux + have hzyMap : algebraMap F L (zy : F) = (autUnitRatio σ y hy0 : L) := + algebraMap_descendedRootUnit hμn (autUnitRatio σ y hy0) huy + have hzx : algebraMap F L zx * x = σ x := by + rw [hzxMap] + exact div_mul_cancel₀ (σ x) hx0 + have hzy : algebraMap F L zy * y = σ y := by + rw [hzyMap] + exact div_mul_cancel₀ (σ y) hy0 + refine ⟨(zx, zy), hzx, hzy, ?_⟩ + apply planeCurveSupportCharacterStabilizer_of_diagonalScale_eval_zero hf + have hxyfun : planeCurveFunction f = ![x, y] := by + funext i + fin_cases i <;> rfl + rw [hxyfun] + rw [eval₂_diagonalScale] + have hcoeff : σ.toRingHom.comp (algebraMap F L) = algebraMap F L := by + ext c + rw [RingHom.comp_apply, IsScalarTower.algebraMap_apply F B L] + change σ ((algebraMap B L) ((algebraMap F B) c)) = + (algebraMap B L) ((algebraMap F B) c) + exact σ.commutes ((algebraMap F B) c) + have hmap := MvPolynomial.map_eval₂Hom (algebraMap F L) + (planeCurveFunction f) σ.toRingHom f + rw [hcoeff] at hmap + have hgeneric := eval₂_planeCurveFunction_eq_zero f + have hzero : MvPolynomial.eval₂ (algebraMap F L) + (fun i => σ (planeCurveFunction f i)) f = 0 := by + change (MvPolynomial.eval₂Hom (algebraMap F L) + (fun i => σ.toRingHom (planeCurveFunction f i))) f = 0 + change (MvPolynomial.eval₂Hom (algebraMap F L) + (planeCurveFunction f)) f = 0 at hgeneric + rw [← hmap, hgeneric, map_zero] + have hcoords : ![algebraMap F L zx * x, algebraMap F L zy * y] = + fun i => σ (planeCurveFunction f i) := by + funext i + fin_cases i <;> simp [x, y, hzx, hzy] + rw [hcoords] + exact hzero + +theorem finrank_poweredCoordinateImageField_le_twice_bidegree_isAlgClosed + {F : Type*} [Field F] [IsAlgClosed F] + {f : MvPolynomial (Fin 2) F} + (hf : Irreducible f) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (hrank : PlaneCurveSupportHasRankTwo f) + (m n : ℕ) (hm : 0 < m) (hn : 0 < n) + (hmF : (m : F) ≠ 0) (hnF : (n : F) ≠ 0) : + letI := planeCurveCoordinateRing_isDomain hf + Module.finrank (PoweredCoordinateImageField f m n) + (PlaneCurveFunctionField f) ≤ + 2 * MvPolynomial.degreeOf 0 f * MvPolynomial.degreeOf 1 f := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let L := PlaneCurveFunctionField f + let B := PoweredCoordinateImageField f m n + let x : L := planeCurveFunction f 0 + let y : L := planeCurveFunction f 1 + let : FiniteDimensional B L := + finiteDimensional_poweredCoordinateImageField hf hpartialSecond m n hm + let : IsGalois B L := + isGalois_over_poweredCoordinateImageField hf hpartialFirst hpartialSecond m n hm hn hmF hnF + have hbasic := poweredCoordinateImageField_adjoin_coordinates_eq_top_and_ne_zero hf hpartialFirst + hpartialSecond m n + have hgen : IntermediateField.adjoin B ({x, y} : Set L) = ⊤ := hbasic.1 + have hgenAlg : Algebra.adjoin B ({x, y} : Set L) = ⊤ := by + rw [← IntermediateField.adjoin_toSubalgebra] + rw [hgen] + rfl + have hrank' := hrank + obtain ⟨r₀, s₀, t₀, hr₀, hs₀, ht₀, hdet₀⟩ := hrank' + let a : ℤ := (s₀ 0 : ℤ) - (r₀ 0 : ℤ) + let b : ℤ := (s₀ 1 : ℤ) - (r₀ 1 : ℤ) + let c : ℤ := (t₀ 0 : ℤ) - (r₀ 0 : ℤ) + let d : ℤ := (t₀ 1 : ℤ) - (r₀ 1 : ℤ) + have hdet' : a * d - b * c ≠ 0 := by + simpa [a, b, c, d, planeCurveSupportDifferenceDet] using hdet₀ + let : Finite (torusCharacterKernel F a b c d) := + finite_torusCharacterKernel_of_det_ne_zero a b c d hdet' + let supportToKernel : planeCurveSupportCharacterStabilizer F f → + torusCharacterKernel F a b c d := fun z => + ⟨z.1, z.2 r₀ hr₀ s₀ hs₀, z.2 r₀ hr₀ t₀ ht₀⟩ + have supportToKernel_injective : Function.Injective supportToKernel := by + intro z w hzw + apply Subtype.ext + exact congrArg (fun u : torusCharacterKernel F a b c d => u.1) hzw + let : Finite (planeCurveSupportCharacterStabilizer F f) := + Finite.of_injective supportToKernel supportToKernel_injective + have hscale (σ : L ≃ₐ[B] L) := + exists_support_stabilizer_scaling_of_poweredImage_aut hf hpartialFirst hpartialSecond + m n hm hn hmF hnF σ + let scalePair : (L ≃ₐ[B] L) → Fˣ × Fˣ := fun σ => + Classical.choose (hscale σ) + have scalePair_spec (σ : L ≃ₐ[B] L) : + algebraMap F L (scalePair σ).1 * x = σ x ∧ + algebraMap F L (scalePair σ).2 * y = σ y ∧ + ∀ r ∈ f.support, ∀ s ∈ f.support, + (scalePair σ).1 ^ ((s 0 : ℤ) - (r 0 : ℤ)) * + (scalePair σ).2 ^ ((s 1 : ℤ) - (r 1 : ℤ)) = 1 := + Classical.choose_spec (hscale σ) + let e : (L ≃ₐ[B] L) → planeCurveSupportCharacterStabilizer F f := + fun σ => ⟨scalePair σ, (scalePair_spec σ).2.2⟩ + have he : Function.Injective e := by + intro σ τ hστ + have hpairs : scalePair σ = scalePair τ := + congrArg Subtype.val hστ + have hx : σ x = τ x := by + rw [← (scalePair_spec σ).1, ← (scalePair_spec τ).1, hpairs] + have hy : σ y = τ y := by + rw [← (scalePair_spec σ).2.1, ← (scalePair_spec τ).2.1, hpairs] + apply AlgEquiv.ext + have hhom : σ.toAlgHom = τ.toAlgHom := by + apply AlgHom.ext_of_adjoin_eq_top hgenAlg + intro q hq + simp only [Set.mem_insert_iff, Set.mem_singleton_iff] at hq + rcases hq with rfl | rfl + · exact hx + · exact hy + exact fun z => DFunLike.congr_fun hhom z + calc + Module.finrank B L = Nat.card (L ≃ₐ[B] L) := + (IsGalois.card_aut_eq_finrank B L).symm + _ ≤ Nat.card (planeCurveSupportCharacterStabilizer F f) := + Nat.card_le_card_of_injective e he + _ ≤ 2 * MvPolynomial.degreeOf 0 f * MvPolynomial.degreeOf 1 f := + natCard_planeCurveSupportCharacterStabilizer_le_twice_bidegree hrank + +/-- The same algebraically closed bound in the first-coordinate presentation +used by the Corvaja--Zannier endpoint. -/ +theorem finrank_poweredImageOverFirst_le_twice_bidegree_isAlgClosed + {F : Type*} [Field F] [IsAlgClosed F] + {f : MvPolynomial (Fin 2) F} + (hf : Irreducible f) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (hrank : PlaneCurveSupportHasRankTwo f) + (m n : ℕ) (hm : 0 < m) (hn : 0 < n) + (hmF : (m : F) ≠ 0) (hnF : (n : F) ≠ 0) : + letI := planeCurveCoordinateRing_isDomain hf + Module.finrank (PoweredImageOverFirst f m n) + (PlaneCurveFunctionField f) ≤ + 2 * MvPolynomial.degreeOf 0 f * MvPolynomial.degreeOf 1 f := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + rw [finrank_poweredImageOverFirst_eq_imageField] + exact finrank_poweredCoordinateImageField_le_twice_bidegree_isAlgClosed + hf hpartialFirst hpartialSecond hrank m n hm hn hmF hnF + +end +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/PoweredImageHeightFactor.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/PoweredImageHeightFactor.lean new file mode 100644 index 0000000000..8f8ca72544 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/PoweredImageHeightFactor.lean @@ -0,0 +1,89 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PoweredImageCurve + +/-! +# The source-to-powered-image degree factor + +The bidegrees of `poweredCoordinateImageRelation` are degrees on the powered +image curve, whereas the divisor argument computes coordinate heights on the +source curve. The discrepancy is exactly the degree of the finite map from +the source curve to its powered image. These tower identities expose that +factor explicitly. +-/ + +@[expose] public section + +namespace BGS.CorvajaZannier + +noncomputable section + +/-- The source degree over the powered first coordinate is the powered-image +relation's degree in the second coordinate times the source-to-image degree. -/ +theorem poweredCoordinateImageRelation_natDegree_mul_imageIndex + {K : Type*} [Field K] {f : MvPolynomial (Fin 2) K} + (hf : Irreducible f) (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (m : ℕ) (hm : 0 < m) (n : ℕ) : + letI := planeCurveCoordinateRing_isDomain hf + (poweredCoordinateImageRelation hf hpartialSecond m hm n).natDegree * + Module.finrank (PoweredImageOverFirst f m n) + (PlaneCurveFunctionField f) = + Module.finrank (FirstPoweredCoordinateSubfield f m) + (PlaneCurveFunctionField f) := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let : FiniteDimensional (FirstPoweredCoordinateSubfield f m) + (PlaneCurveFunctionField f) := + finiteDimensional_over_firstPoweredCoordinate hf hpartialSecond m hm + rw [poweredCoordinateImageRelation_natDegree_eq_finrank + hf hpartialSecond m hm n] + have : Module.Free (FirstPoweredCoordinateSubfield f m) (PoweredImageOverFirst f m n) := + Module.Free.of_divisionRing _ _ + have : Module.Free (PoweredImageOverFirst f m n) (PlaneCurveFunctionField f) := + Module.Free.of_divisionRing _ _ + exact Module.finrank_mul_finrank + (FirstPoweredCoordinateSubfield f m) + (PoweredImageOverFirst f m n) + (PlaneCurveFunctionField f) + +/-- The source degree over the powered second coordinate is the powered-image +relation's degree in the first coordinate times the same geometric +source-to-image degree, written in the second-coordinate presentation. -/ +theorem poweredCoordinateImageRelation_transpose_natDegree_mul_imageIndex + {K : Type*} [Field K] {f : MvPolynomial (Fin 2) K} + (hf : Irreducible f) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (m : ℕ) (hm : 0 < m) (n : ℕ) (hn : 0 < n) : + letI := planeCurveCoordinateRing_isDomain hf + (transposeBivariate + (poweredCoordinateImageRelation hf hpartialSecond m hm n)).natDegree * + Module.finrank (PoweredImageOverSecond f m n) + (PlaneCurveFunctionField f) = + Module.finrank (SecondPoweredCoordinateSubfield f n) + (PlaneCurveFunctionField f) := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let : FiniteDimensional (SecondPoweredCoordinateSubfield f n) + (PlaneCurveFunctionField f) := + finiteDimensional_over_secondPoweredCoordinate hf hpartialFirst n hn + rw [poweredCoordinateImageRelation_transpose_natDegree_eq_finrank + hf hpartialFirst hpartialSecond m hm n hn] + have : Module.Free (SecondPoweredCoordinateSubfield f n) (PoweredImageOverSecond f m n) := + Module.Free.of_divisionRing _ _ + have : Module.Free (PoweredImageOverSecond f m n) (PlaneCurveFunctionField f) := + Module.Free.of_divisionRing _ _ + exact Module.finrank_mul_finrank + (SecondPoweredCoordinateSubfield f n) + (PoweredImageOverSecond f m n) + (PlaneCurveFunctionField f) + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/PoweredImageIndex.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/PoweredImageIndex.lean new file mode 100644 index 0000000000..dfa70963b9 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/PoweredImageIndex.lean @@ -0,0 +1,186 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PoweredImageHeightFactor +public import Mathlib.Tactic + +/-! +# The common source-to-powered-image index + +The powered image field is presented twice, once over each powered coordinate. +Although these presentations have different base fields, their underlying +intermediate field in the source function field is the same. This file +transports finrank across `IntermediateField.restrictScalars`, identifies the +two source-to-image indices, and records the elementary projection bounds. + +These statements do not identify image-curve degrees with source heights. +The missing exponent-independent bound on the common index is a genuinely +additional logarithmic-geometric input. +-/ + +@[expose] public section + +namespace BGS.CorvajaZannier + +noncomputable section + +private theorem finrank_restrictScalars_intermediateField + {K E L : Type*} [Field K] [Field E] [Field L] + [Algebra K E] [Algebra K L] [Algebra E L] [IsScalarTower K E L] + (A : IntermediateField E L) : + Module.finrank (A.restrictScalars K) L = Module.finrank A L := by + let e : (A.restrictScalars K) ≃+* A := + { toFun := fun z => ⟨z.1, z.2⟩ + invFun := fun z => ⟨z.1, z.2⟩ + left_inv := fun _ => rfl + right_inv := fun _ => rfl + map_add' := fun _ _ => rfl + map_mul' := fun _ _ => rfl } + exact Algebra.finrank_eq_of_equiv_equiv e (RingEquiv.refl L) + (by ext z; rfl) + +/-- The first-coordinate presentation has the same source degree as the +common powered image field `K(x^m,y^n)`. -/ +theorem finrank_poweredImageOverFirst_eq_imageField + {K : Type*} [Field K] {f : MvPolynomial (Fin 2) K} + [IsDomain (PlaneCurveCoordinateRing f)] (m n : ℕ) : + Module.finrank (PoweredImageOverFirst f m n) + (PlaneCurveFunctionField f) = + Module.finrank (PoweredCoordinateImageField f m n) + (PlaneCurveFunctionField f) := by + let A := PoweredImageOverFirst f m n + have htransport : Module.finrank (A.restrictScalars K) + (PlaneCurveFunctionField f) = + Module.finrank A (PlaneCurveFunctionField f) := + finrank_restrictScalars_intermediateField A + have hfield := restrictScalars_poweredImageOverFirst_eq f m n + have hrank := congrArg + (fun E : IntermediateField K (PlaneCurveFunctionField f) => + Module.finrank E (PlaneCurveFunctionField f)) hfield + exact htransport.symm.trans hrank + +/-- The second-coordinate presentation has the same source degree as the +common powered image field `K(x^m,y^n)`. -/ +theorem finrank_poweredImageOverSecond_eq_imageField + {K : Type*} [Field K] {f : MvPolynomial (Fin 2) K} + [IsDomain (PlaneCurveCoordinateRing f)] (m n : ℕ) : + Module.finrank (PoweredImageOverSecond f m n) + (PlaneCurveFunctionField f) = + Module.finrank (PoweredCoordinateImageField f m n) + (PlaneCurveFunctionField f) := by + let A := PoweredImageOverSecond f m n + have htransport : Module.finrank (A.restrictScalars K) + (PlaneCurveFunctionField f) = + Module.finrank A (PlaneCurveFunctionField f) := + finrank_restrictScalars_intermediateField A + have hfield := restrictScalars_poweredImageOverSecond_eq f m n + have hrank := congrArg + (fun E : IntermediateField K (PlaneCurveFunctionField f) => + Module.finrank E (PlaneCurveFunctionField f)) hfield + exact htransport.symm.trans hrank + +/-- Both relative presentations compute one and the same geometric degree of +the source-to-powered-image map. -/ +theorem finrank_poweredImageOverFirst_eq_poweredImageOverSecond + {K : Type*} [Field K] {f : MvPolynomial (Fin 2) K} + [IsDomain (PlaneCurveCoordinateRing f)] (m n : ℕ) : + Module.finrank (PoweredImageOverFirst f m n) + (PlaneCurveFunctionField f) = + Module.finrank (PoweredImageOverSecond f m n) + (PlaneCurveFunctionField f) := by + rw [finrank_poweredImageOverFirst_eq_imageField, + finrank_poweredImageOverSecond_eq_imageField] + +/-- The common powered-image index is at most the source degree over the +powered first coordinate, hence at most `m * degreeOf 1 f`. -/ +theorem finrank_poweredImageOverFirst_le_firstProjectionPowerDegree + {K : Type*} [Field K] {f : MvPolynomial (Fin 2) K} + (hf : Irreducible f) (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (m : ℕ) (hm : 0 < m) (n : ℕ) : + letI := planeCurveCoordinateRing_isDomain hf + Module.finrank (PoweredImageOverFirst f m n) + (PlaneCurveFunctionField f) ≤ + m * MvPolynomial.degreeOf 1 f := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let : FiniteDimensional (FirstPoweredCoordinateSubfield f m) + (PlaneCurveFunctionField f) := + finiteDimensional_over_firstPoweredCoordinate hf hpartialSecond m hm + have : Module.Free (FirstPoweredCoordinateSubfield f m) + (PoweredImageOverFirst f m n) := Module.Free.of_divisionRing _ _ + have : Module.Free (PoweredImageOverFirst f m n) (PlaneCurveFunctionField f) := + Module.Free.of_divisionRing _ _ + have htower := Module.finrank_mul_finrank + (FirstPoweredCoordinateSubfield f m) + (PoweredImageOverFirst f m n) + (PlaneCurveFunctionField f) + have hfactor : 0 < Module.finrank (FirstPoweredCoordinateSubfield f m) + (PoweredImageOverFirst f m n) := Module.finrank_pos + have hindexSource : Module.finrank (PoweredImageOverFirst f m n) + (PlaneCurveFunctionField f) ≤ + Module.finrank (FirstPoweredCoordinateSubfield f m) + (PlaneCurveFunctionField f) := by + calc + Module.finrank (PoweredImageOverFirst f m n) + (PlaneCurveFunctionField f) ≤ + Module.finrank (FirstPoweredCoordinateSubfield f m) + (PoweredImageOverFirst f m n) * + Module.finrank (PoweredImageOverFirst f m n) + (PlaneCurveFunctionField f) := by + exact Nat.le_mul_of_pos_left _ hfactor + _ = Module.finrank (FirstPoweredCoordinateSubfield f m) + (PlaneCurveFunctionField f) := htower + exact hindexSource.trans + (finrank_over_firstPoweredCoordinate_le hf hpartialSecond m hm) + +/-- The common powered-image index is at most the source degree over the +powered second coordinate, hence at most `n * degreeOf 0 f`. -/ +theorem finrank_poweredImageOverSecond_le_secondProjectionPowerDegree + {K : Type*} [Field K] {f : MvPolynomial (Fin 2) K} + (hf : Irreducible f) (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (m n : ℕ) (hn : 0 < n) : + letI := planeCurveCoordinateRing_isDomain hf + Module.finrank (PoweredImageOverSecond f m n) + (PlaneCurveFunctionField f) ≤ + n * MvPolynomial.degreeOf 0 f := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let : FiniteDimensional (SecondPoweredCoordinateSubfield f n) + (PlaneCurveFunctionField f) := + finiteDimensional_over_secondPoweredCoordinate hf hpartialFirst n hn + have : Module.Free (SecondPoweredCoordinateSubfield f n) + (PoweredImageOverSecond f m n) := Module.Free.of_divisionRing _ _ + have : Module.Free (PoweredImageOverSecond f m n) (PlaneCurveFunctionField f) := + Module.Free.of_divisionRing _ _ + have htower := Module.finrank_mul_finrank + (SecondPoweredCoordinateSubfield f n) + (PoweredImageOverSecond f m n) + (PlaneCurveFunctionField f) + have hfactor : 0 < Module.finrank (SecondPoweredCoordinateSubfield f n) + (PoweredImageOverSecond f m n) := Module.finrank_pos + have hindexSource : Module.finrank (PoweredImageOverSecond f m n) + (PlaneCurveFunctionField f) ≤ + Module.finrank (SecondPoweredCoordinateSubfield f n) + (PlaneCurveFunctionField f) := by + calc + Module.finrank (PoweredImageOverSecond f m n) + (PlaneCurveFunctionField f) ≤ + Module.finrank (SecondPoweredCoordinateSubfield f n) + (PoweredImageOverSecond f m n) * + Module.finrank (PoweredImageOverSecond f m n) + (PlaneCurveFunctionField f) := by + exact Nat.le_mul_of_pos_left _ hfactor + _ = Module.finrank (SecondPoweredCoordinateSubfield f n) + (PlaneCurveFunctionField f) := htower + exact hindexSource.trans + (finrank_over_secondPoweredCoordinate_le hf hpartialFirst n hn) + +end + + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/PoweredImageIndexBound.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/PoweredImageIndexBound.lean new file mode 100644 index 0000000000..72e23049cc --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/PoweredImageIndexBound.lean @@ -0,0 +1,142 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveSupportRank +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveBidegreeBridge +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PoweredImageBaseChange +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PoweredImageGaloisBound +public import Mathlib.Tactic + +/-! +# The Corvaja--Zannier source-to-powered-image index bound + +This module transports the Galois stabilizer count from algebraically closed +constants back to the original constant field. Absolute irreducibility makes +the powered-image degree invariant under this extension of constants, while +the semantic non-subtorus hypothesis supplies the rank-two support determinant. +-/ + +@[expose] public section + +namespace BGS.CorvajaZannier + +noncomputable section + +/-- The exact source-to-powered-image bound, with separability of the two power +maps expressed by nonvanishing of the exponent casts. -/ +theorem finrank_poweredImageOverFirst_le_twice_bidegree_of_nonzero_natCast + {K : Type*} [Field K] {f : MvPolynomial (Fin 2) K} + (habsolute : Irreducible + (MvPolynomial.map (algebraMap K (AlgebraicClosure K)) f)) + (hnot : BGS.External.TorusCurveNotSubtorusTranslate f) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (m n : ℕ) (hm : 0 < m) (hn : 0 < n) + (hmK : (m : K) ≠ 0) (hnK : (n : K) ≠ 0) : + let hf : Irreducible f := + irreducible_of_irreducible_map_algebraicClosure habsolute + letI := planeCurveCoordinateRing_isDomain hf + Module.finrank (PoweredImageOverFirst f m n) + (PlaneCurveFunctionField f) ≤ + 2 * MvPolynomial.degreeOf 0 f * MvPolynomial.degreeOf 1 f := by + let A := AlgebraicClosure K + let fA : MvPolynomial (Fin 2) A := + MvPolynomial.map (algebraMap K A) f + let hf : Irreducible f := + irreducible_of_irreducible_map_algebraicClosure habsolute + have hfA : Irreducible fA := habsolute + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let : IsDomain (PlaneCurveCoordinateRing fA) := + planeCurveCoordinateRing_isDomain hfA + have hpartialFirstA : MvPolynomial.pderiv 0 fA ≠ 0 := by + rw [MvPolynomial.pderiv_map] + intro hzero + apply hpartialFirst + exact MvPolynomial.map_injective (algebraMap K A) + (algebraMap K A).injective (by simpa using hzero) + have hpartialSecondA : MvPolynomial.pderiv 1 fA ≠ 0 := by + rw [MvPolynomial.pderiv_map] + intro hzero + apply hpartialSecond + exact MvPolynomial.map_injective (algebraMap K A) + (algebraMap K A).injective (by simpa using hzero) + have hrank : PlaneCurveSupportHasRankTwo f := + planeCurveSupportHasRankTwo_of_absoluteIrreducible_notSubtorusTranslate + habsolute hnot + have hsupp : fA.support = f.support := + MvPolynomial.support_map_of_injective f (algebraMap K A).injective + have hrankA : PlaneCurveSupportHasRankTwo fA := by + obtain ⟨r, s, t, hr, hs, ht, hdet⟩ := hrank + refine ⟨r, s, t, ?_, ?_, ?_, hdet⟩ + · rwa [hsupp] + · rwa [hsupp] + · rwa [hsupp] + have hmA : (m : A) ≠ 0 := by + rw [← map_natCast (algebraMap K A)] + simpa using (algebraMap K A).injective.ne hmK + have hnA : (n : A) ≠ 0 := by + rw [← map_natCast (algebraMap K A)] + simpa using (algebraMap K A).injective.ne hnK + have hindexBaseChange : + Module.finrank (PoweredCoordinateImageField f m n) + (PlaneCurveFunctionField f) = + Module.finrank (PoweredCoordinateImageField fA m n) + (PlaneCurveFunctionField fA) := + finrank_poweredCoordinateImageField_eq_baseChange + (E := A) habsolute hf hpartialSecond m hm n + have hdegreeFirst : MvPolynomial.degreeOf 0 fA = + MvPolynomial.degreeOf 0 f := + degreeOf_map_eq_of_injective (algebraMap K A) + (algebraMap K A).injective 0 f + have hdegreeSecond : MvPolynomial.degreeOf 1 fA = + MvPolynomial.degreeOf 1 f := + degreeOf_map_eq_of_injective (algebraMap K A) + (algebraMap K A).injective 1 f + change Module.finrank (PoweredImageOverFirst f m n) + (PlaneCurveFunctionField f) ≤ + 2 * MvPolynomial.degreeOf 0 f * MvPolynomial.degreeOf 1 f + rw [finrank_poweredImageOverFirst_eq_imageField] + calc + Module.finrank (PoweredCoordinateImageField f m n) + (PlaneCurveFunctionField f) = + Module.finrank (PoweredCoordinateImageField fA m n) + (PlaneCurveFunctionField fA) := hindexBaseChange + _ ≤ 2 * MvPolynomial.degreeOf 0 fA * MvPolynomial.degreeOf 1 fA := + finrank_poweredCoordinateImageField_le_twice_bidegree_isAlgClosed + hfA hpartialFirstA hpartialSecondA hrankA m n hm hn hmA hnA + _ = 2 * MvPolynomial.degreeOf 0 f * MvPolynomial.degreeOf 1 f := by + rw [hdegreeFirst, hdegreeSecond] + +/-- Prime-to-characteristic powers satisfy the exact Corvaja--Zannier +source-to-powered-image index bound. -/ +theorem finrank_poweredImageOverFirst_le_twice_bidegree + {p : ℕ} [Fact p.Prime] + {K : Type*} [Field K] [CharP K p] + {f : MvPolynomial (Fin 2) K} + (habsolute : Irreducible + (MvPolynomial.map (algebraMap K (AlgebraicClosure K)) f)) + (hnot : BGS.External.TorusCurveNotSubtorusTranslate f) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (m n : ℕ) (hm : 0 < m) (hn : 0 < n) + (hmPrime : ¬ p ∣ m) (hnPrime : ¬ p ∣ n) : + let hf : Irreducible f := + irreducible_of_irreducible_map_algebraicClosure habsolute + letI := planeCurveCoordinateRing_isDomain hf + Module.finrank (PoweredImageOverFirst f m n) + (PlaneCurveFunctionField f) ≤ + 2 * MvPolynomial.degreeOf 0 f * MvPolynomial.degreeOf 1 f := by + apply finrank_poweredImageOverFirst_le_twice_bidegree_of_nonzero_natCast + habsolute hnot hpartialFirst hpartialSecond m n hm hn + · rwa [ne_eq, CharP.cast_eq_zero_iff K p] + · rwa [ne_eq, CharP.cast_eq_zero_iff K p] + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/PropositionTwoDegreeMonotonicity.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/PropositionTwoDegreeMonotonicity.lean new file mode 100644 index 0000000000..90917fcade --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/PropositionTwoDegreeMonotonicity.lean @@ -0,0 +1,245 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.ParameterizedBound +public import Mathlib.Tactic + +/-! +# Enlarging the degree data in Corvaja--Zannier Proposition 2 + +The actual coordinate degrees of a plane curve can be strictly smaller than +the public bidegree bounds used by the final theorem. The degree alternative +in Proposition 2 is not itself monotone in those bounds. Nevertheless, once +the gcd quantity satisfies its trivial bound by the first actual degree, an +actual degree alternative implies the numerical alternative for every larger +pair of degrees: its Euler term already dominates the first degree. + +This is the exact numerical bridge needed between a Proposition 2 proof at +the curve's actual degrees and the public min/max degree convention. +-/ + +@[expose] public section + +namespace BGS.CorvajaZannier + +noncomputable section + +/-- Proposition 2 remains valid after enlarging both degrees and the Euler +budget, provided the gcd quantity has the trivial bound by the first original +degree. + +The old degree alternative cannot in general be transported to the larger +degrees. In that case both parameters are positive, and +`2 * k <= h * k + h + k - 1`; hence the new Euler term (whose Euler budget is +positive) is at least `k`, and therefore at least the gcd quantity. -/ +theorem propositionTwoNumericalAlternatives_mono_degreeBounds + (a b A B p chi Chi : ℕ) (G : ℝ) + (ha : 0 < a) (hb : 0 < b) + (haA : a ≤ A) (hbB : b ≤ B) + (hchi : chi ≤ Chi) (hChi : 0 < Chi) + (hG : G ≤ (a : ℝ)) + (hactual : PropositionTwoNumericalAlternatives a b p chi G) : + PropositionTwoNumericalAlternatives A B p Chi G := by + intro h k hadmissible + have hadmissibleActual : + PropositionTwoParametersAreAdmissible a b p h k := by + refine ⟨hadmissible.1, ?_⟩ + have hweighted : a * h + b * k ≤ A * h + B * k := + Nat.add_le_add (Nat.mul_le_mul_right h haA) + (Nat.mul_le_mul_right k hbB) + exact hweighted.trans_lt hadmissible.2 + rcases hactual h k hadmissibleActual with hdegree | hbound + · right + let n : ℕ := h * k + h + k + have hkPos : 0 < k := lt_of_lt_of_le ha hdegree.1 + have hhPos : 0 < h := lt_of_lt_of_le hb hdegree.2 + have hnSub : 2 * k ≤ n - 1 := by + obtain ⟨h', rfl⟩ := Nat.exists_eq_succ_of_ne_zero hhPos.ne' + simp only [n, Nat.succ_mul, Nat.succ_eq_add_one] + omega + have hnSubReal : (2 * k : ℝ) ≤ (n : ℝ) - 1 := by + have hnOne : 1 ≤ n := by dsimp only [n]; omega + have hnSubCast : ((2 * k : ℕ) : ℝ) ≤ ((n - 1 : ℕ) : ℝ) := by + exact_mod_cast hnSub + rw [Nat.cast_sub hnOne] at hnSubCast + norm_num at hnSubCast ⊢ + exact hnSubCast + have hkEulerHalf : (k : ℝ) ≤ ((n : ℝ) - 1) / 2 := by + linarith + have hEulerHalfNonneg : 0 ≤ ((n : ℝ) - 1) / 2 := + (Nat.cast_nonneg k).trans hkEulerHalf + have hChiReal : (1 : ℝ) ≤ (Chi : ℝ) := by + exact_mod_cast (Nat.one_le_iff_ne_zero.mpr hChi.ne') + have hkEuler : + (k : ℝ) ≤ (((n : ℝ) - 1) / 2) * (Chi : ℝ) := by + calc + (k : ℝ) ≤ ((n : ℝ) - 1) / 2 := hkEulerHalf + _ = (((n : ℝ) - 1) / 2) * 1 := by ring + _ ≤ (((n : ℝ) - 1) / 2) * (Chi : ℝ) := + mul_le_mul_of_nonneg_left hChiReal hEulerHalfNonneg + have hGa : G ≤ (k : ℝ) := + hG.trans (by exact_mod_cast hdegree.1) + have hnPosReal : 0 < (n : ℝ) := by + exact_mod_cast hadmissible.1 + have hfirstNonneg : + 0 ≤ (((h + 2 * k : ℕ) : ℝ) / (n : ℝ)) * (A : ℝ) := + mul_nonneg (div_nonneg (Nat.cast_nonneg _) hnPosReal.le) + (Nat.cast_nonneg _) + have hsecondNonneg : + 0 ≤ ((k : ℝ) / (n : ℝ)) * (B : ℝ) := + mul_nonneg (div_nonneg (Nat.cast_nonneg _) hnPosReal.le) + (Nat.cast_nonneg _) + calc + G ≤ (k : ℝ) := hGa + _ ≤ (((n : ℝ) - 1) / 2) * (Chi : ℝ) := hkEuler + _ ≤ + (((h + 2 * k : ℕ) : ℝ) / (n : ℝ)) * (A : ℝ) + + ((k : ℝ) / (n : ℝ)) * (B : ℝ) + + (((n : ℝ) - 1) / 2) * (Chi : ℝ) := by + linarith + _ = + (((h + 2 * k : ℕ) : ℝ) / + ((h * k + h + k : ℕ) : ℝ)) * (A : ℝ) + + ((k : ℝ) / ((h * k + h + k : ℕ) : ℝ)) * (B : ℝ) + + ((((h * k + h + k : ℕ) : ℝ) - 1) / 2) * + (Chi : ℝ) := by + rfl + · right + let n : ℕ := h * k + h + k + have hnPosReal : 0 < (n : ℝ) := by + exact_mod_cast hadmissible.1 + have hfirstCoefficient : + 0 ≤ ((h + 2 * k : ℕ) : ℝ) / (n : ℝ) := + div_nonneg (Nat.cast_nonneg _) hnPosReal.le + have hsecondCoefficient : 0 ≤ (k : ℝ) / (n : ℝ) := + div_nonneg (Nat.cast_nonneg _) hnPosReal.le + have hnOne : 1 ≤ n := by + exact Nat.one_le_iff_ne_zero.mpr (Nat.ne_of_gt hadmissible.1) + have hthirdCoefficient : 0 ≤ ((n : ℝ) - 1) / 2 := by + have : (1 : ℝ) ≤ (n : ℝ) := by exact_mod_cast hnOne + positivity + have haReal : (a : ℝ) ≤ (A : ℝ) := by exact_mod_cast haA + have hbReal : (b : ℝ) ≤ (B : ℝ) := by exact_mod_cast hbB + have hchiReal : (chi : ℝ) ≤ (Chi : ℝ) := by exact_mod_cast hchi + have hfirst := mul_le_mul_of_nonneg_left haReal hfirstCoefficient + have hsecond := mul_le_mul_of_nonneg_left hbReal hsecondCoefficient + have hthird := mul_le_mul_of_nonneg_left hchiReal hthirdCoefficient + calc + G ≤ + (((h + 2 * k : ℕ) : ℝ) / + ((h * k + h + k : ℕ) : ℝ)) * (a : ℝ) + + ((k : ℝ) / ((h * k + h + k : ℕ) : ℝ)) * (b : ℝ) + + ((((h * k + h + k : ℕ) : ℝ) - 1) / 2) * + (chi : ℝ) := hbound + _ ≤ + (((h + 2 * k : ℕ) : ℝ) / (n : ℝ)) * (A : ℝ) + + ((k : ℝ) / (n : ℝ)) * (B : ℝ) + + (((n : ℝ) - 1) / 2) * (Chi : ℝ) := by + dsimp only [n] at hfirst hsecond hthird ⊢ + linarith + _ = + (((h + 2 * k : ℕ) : ℝ) / + ((h * k + h + k : ℕ) : ℝ)) * (A : ℝ) + + ((k : ℝ) / ((h * k + h + k : ℕ) : ℝ)) * (B : ℝ) + + ((((h * k + h + k : ℕ) : ℝ) - 1) / 2) * + (Chi : ℝ) := by + rfl + +/-- Convert an auxiliary degree alternative on a finite image curve into the +numerical alternative at the source-curve heights. + +Here `a` and `b` are the two image-curve degrees, `A` is the first source +height, and `d` is the source-to-image degree. In the intended application +`A = d * a`. The hypothesis `d ≤ Chi` is the precise extra input needed to +absorb the image degree alternative into the source Euler term. Merely knowing +`a ≤ A` is not enough. + +The hypothesis `hauxiliary` deliberately keeps the numerical branch already +at the source degrees `A`, `B`: this is the shape produced by the canonical +Wronskian sum, whose divisor degrees are computed on the source curve. -/ +theorem propositionTwoNumericalAlternatives_of_scaledAuxiliaryDegreeAlternative + (a b d A B p Chi : ℕ) (G : ℝ) + (ha : 0 < a) (hb : 0 < b) + (hA : A ≤ d * a) (hdChi : d ≤ Chi) + (hG : G ≤ (A : ℝ)) + (hauxiliary : ∀ h k : ℕ, + PropositionTwoParametersAreAdmissible A B p h k → + (a ≤ k ∧ b ≤ h) ∨ + G ≤ + (((h + 2 * k : ℕ) : ℝ) / + ((h * k + h + k : ℕ) : ℝ)) * (A : ℝ) + + ((k : ℝ) / ((h * k + h + k : ℕ) : ℝ)) * (B : ℝ) + + ((((h * k + h + k : ℕ) : ℝ) - 1) / 2) * + (Chi : ℝ)) : + PropositionTwoNumericalAlternatives A B p Chi G := by + intro h k hadmissible + rcases hauxiliary h k hadmissible with hdegree | hbound + · right + let n : ℕ := h * k + h + k + have hkPos : 0 < k := lt_of_lt_of_le ha hdegree.1 + have hhPos : 0 < h := lt_of_lt_of_le hb hdegree.2 + have hnSub : 2 * k ≤ n - 1 := by + obtain ⟨h', rfl⟩ := Nat.exists_eq_succ_of_ne_zero hhPos.ne' + simp only [n, Nat.succ_mul, Nat.succ_eq_add_one] + omega + have hnOne : 1 ≤ n := by dsimp only [n]; omega + have hnSubReal : (2 * k : ℝ) ≤ (n : ℝ) - 1 := by + have hnSubCast : ((2 * k : ℕ) : ℝ) ≤ ((n - 1 : ℕ) : ℝ) := by + exact_mod_cast hnSub + rw [Nat.cast_sub hnOne] at hnSubCast + norm_num at hnSubCast ⊢ + exact hnSubCast + have hkEulerHalf : (k : ℝ) ≤ ((n : ℝ) - 1) / 2 := by + linarith + have hEulerHalfNonneg : 0 ≤ ((n : ℝ) - 1) / 2 := + (Nat.cast_nonneg k).trans hkEulerHalf + have hdChiReal : (d : ℝ) ≤ (Chi : ℝ) := by exact_mod_cast hdChi + have hkEuler : (d : ℝ) * (k : ℝ) ≤ + (((n : ℝ) - 1) / 2) * (Chi : ℝ) := by + calc + (d : ℝ) * (k : ℝ) ≤ (Chi : ℝ) * (k : ℝ) := + mul_le_mul_of_nonneg_right hdChiReal (Nat.cast_nonneg _) + _ = (k : ℝ) * (Chi : ℝ) := by ring + _ ≤ (((n : ℝ) - 1) / 2) * (Chi : ℝ) := + mul_le_mul_of_nonneg_right hkEulerHalf (Nat.cast_nonneg _) + have hAk : A ≤ d * k := + hA.trans (Nat.mul_le_mul_left d hdegree.1) + have hGdk : G ≤ (d : ℝ) * (k : ℝ) := by + calc + G ≤ (A : ℝ) := hG + _ ≤ ((d * k : ℕ) : ℝ) := by exact_mod_cast hAk + _ = (d : ℝ) * (k : ℝ) := by norm_num + have hnPosReal : 0 < (n : ℝ) := by exact_mod_cast hadmissible.1 + have hfirstNonneg : + 0 ≤ (((h + 2 * k : ℕ) : ℝ) / (n : ℝ)) * (A : ℝ) := + mul_nonneg (div_nonneg (Nat.cast_nonneg _) hnPosReal.le) + (Nat.cast_nonneg _) + have hsecondNonneg : + 0 ≤ ((k : ℝ) / (n : ℝ)) * (B : ℝ) := + mul_nonneg (div_nonneg (Nat.cast_nonneg _) hnPosReal.le) + (Nat.cast_nonneg _) + calc + G ≤ (d : ℝ) * (k : ℝ) := hGdk + _ ≤ (((n : ℝ) - 1) / 2) * (Chi : ℝ) := hkEuler + _ ≤ + (((h + 2 * k : ℕ) : ℝ) / (n : ℝ)) * (A : ℝ) + + ((k : ℝ) / (n : ℝ)) * (B : ℝ) + + (((n : ℝ) - 1) / 2) * (Chi : ℝ) := by + linarith + _ = + (((h + 2 * k : ℕ) : ℝ) / + ((h * k + h + k : ℕ) : ℝ)) * (A : ℝ) + + ((k : ℝ) / ((h * k + h + k : ℕ) : ℝ)) * (B : ℝ) + + ((((h * k + h + k : ℕ) : ℝ) - 1) / 2) * + (Chi : ℝ) := by + rfl + · exact Or.inr hbound + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/RatFuncExhaustiveProductFormula.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/RatFuncExhaustiveProductFormula.lean new file mode 100644 index 0000000000..9a86075830 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/RatFuncExhaustiveProductFormula.lean @@ -0,0 +1,267 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FunctionFieldProductFormula +public import Mathlib.RingTheory.UniqueFactorizationDomain.Finsupp + +/-! +# The exhaustive finite-place product formula for the rational function field + +This file packages the principal fractional ideal of a nonzero element of +`K(X)` as a `Finsupp` on the full `HeightOneSpectrum K[X]`. Each height-one +prime is identified with its canonical normalized prime-polynomial generator, +so the degree-weighted sum can be reindexed to normalized polynomial +factorization. The resulting exhaustive finite-place sum is `f.intDegree`; +after adding Mathlib's order at infinity, the total is zero. +-/ + +@[expose] public section + +open scoped nonZeroDivisors +open IsDedekindDomain Polynomial UniqueFactorizationMonoid + +namespace BGS.CorvajaZannier + +noncomputable section + +variable {K : Type*} [Field K] + +/-- Normalized prime polynomials, i.e. the canonical polynomial representatives +of finite places of `K(X)`. -/ +abbrev NormalizedPrimePolynomial (K : Type*) [Field K] [DecidableEq K] := + {r : K[X] // Prime r ∧ normalize r = r} + +/-- The normalized prime polynomial generating a finite place of `K(X)`. -/ +def finitePlaceNormalizedPrime [DecidableEq K] + (v : HeightOneSpectrum K[X]) : NormalizedPrimePolynomial K := by + let g := Submodule.IsPrincipal.generator v.asIdeal + refine ⟨normalize g, ?_, normalize_idem g⟩ + exact (normalize_associated g).symm.prime + (Submodule.IsPrincipal.prime_generator_of_isPrime v.asIdeal v.ne_bot) + +/-- The finite place cut out by a normalized prime polynomial. -/ +def normalizedPrimeFinitePlace [DecidableEq K] (r : NormalizedPrimePolynomial K) : + HeightOneSpectrum K[X] := + polynomialFinitePlace r r.property.1 + +@[simp] +theorem normalizedPrimeFinitePlace_finitePlaceNormalizedPrime + [DecidableEq K] (v : HeightOneSpectrum K[X]) : + normalizedPrimeFinitePlace (K := K) (finitePlaceNormalizedPrime v) = v := by + apply HeightOneSpectrum.ext + change Ideal.span {normalize (Submodule.IsPrincipal.generator v.asIdeal)} = v.asIdeal + calc + Ideal.span {normalize (Submodule.IsPrincipal.generator v.asIdeal)} = + Ideal.span {Submodule.IsPrincipal.generator v.asIdeal} := + Ideal.span_singleton_eq_span_singleton.mpr (normalize_associated _) + _ = v.asIdeal := Ideal.span_singleton_generator v.asIdeal + +@[simp] +theorem finitePlaceNormalizedPrime_normalizedPrimeFinitePlace + [DecidableEq K] (r : NormalizedPrimePolynomial K) : + finitePlaceNormalizedPrime (normalizedPrimeFinitePlace (K := K) r) = r := by + apply Subtype.ext + change normalize (Submodule.IsPrincipal.generator (Ideal.span {(r : K[X])})) = r + calc + normalize (Submodule.IsPrincipal.generator (Ideal.span {(r : K[X])})) = + normalize (r : K[X]) := by + exact normalize_eq_normalize_iff_associated.mpr + (Submodule.IsPrincipal.associated_generator_span_self (r : K[X])) + _ = r := r.property.2 + +/-- Normalized prime polynomials are equivalent to all finite places of `K(X)`. -/ +def normalizedPrimePolynomialEquivFinitePlace [DecidableEq K] : + NormalizedPrimePolynomial K ≃ HeightOneSpectrum K[X] where + toFun := fun r => normalizedPrimeFinitePlace (K := K) r + invFun := fun v => finitePlaceNormalizedPrime (K := K) v + left_inv := finitePlaceNormalizedPrime_normalizedPrimeFinitePlace + right_inv := normalizedPrimeFinitePlace_finitePlaceNormalizedPrime + +/-- The finitely supported principal divisor at all finite places. -/ +def ratFuncFiniteDivisor (f : RatFunc K) : HeightOneSpectrum K[X] →₀ ℤ := + let h := FractionalIdeal.finite_factors + (FractionalIdeal.spanSingleton (K[X])⁰ f) + Finsupp.mk h.toFinset (fun v => ratFuncFiniteOrder v f) + (fun _ => h.mem_toFinset) + +@[simp] +theorem ratFuncFiniteDivisor_apply (f : RatFunc K) (v : HeightOneSpectrum K[X]) : + ratFuncFiniteDivisor f v = ratFuncFiniteOrder v f := rfl + +/-- Degree of a finite place, defined using its canonical normalized prime generator. -/ +def ratFuncFinitePlaceDegree [DecidableEq K] (v : HeightOneSpectrum K[X]) : ℕ := + (finitePlaceNormalizedPrime v : K[X]).natDegree + +@[simp] +theorem ratFuncFinitePlaceDegree_normalizedPrimeFinitePlace [DecidableEq K] + (r : NormalizedPrimePolynomial K) : + ratFuncFinitePlaceDegree (normalizedPrimeFinitePlace (K := K) r) = + (r : K[X]).natDegree := by + simp [ratFuncFinitePlaceDegree] + +/-- Factorization of a polynomial, restricted to normalized prime polynomials. -/ +def normalizedPrimeFactorization [DecidableEq K] (p : K[X]) : + NormalizedPrimePolynomial K →₀ ℕ := + Finsupp.comapDomain Subtype.val (factorization p) Subtype.val_injective.injOn + +@[simp] +theorem normalizedPrimeFactorization_apply [DecidableEq K] + (p : K[X]) (r : NormalizedPrimePolynomial K) : + normalizedPrimeFactorization p r = (normalizedFactors p).count (r : K[X]) := by + simp [normalizedPrimeFactorization, factorization_eq_count] + +/-- The coefficient of the finite principal divisor is the difference of the +normalized-prime multiplicities in numerator and denominator. -/ +theorem ratFuncFiniteOrder_eq_normalizedPrimeFactorization_sub + [DecidableEq K] (f : RatFunc K) (hf : f ≠ 0) + (v : HeightOneSpectrum K[X]) : + ratFuncFiniteOrder v f = + (normalizedPrimeFactorization f.num (finitePlaceNormalizedPrime v) : ℤ) - + normalizedPrimeFactorization f.denom (finitePlaceNormalizedPrime v) := by + let r := finitePlaceNormalizedPrime v + have h := ratFuncFiniteOrder_polynomialFinitePlace (K := K) f hf + (r : K[X]) r.property.1 r.property.2 + have hrplace : polynomialFinitePlace (r : K[X]) r.property.1 = v := by + change normalizedPrimeFinitePlace (K := K) r = v + exact normalizedPrimeFinitePlace_finitePlaceNormalizedPrime v + rw [hrplace] at h + simpa only [normalizedPrimeFactorization_apply] using h + +/-- The numerator-minus-denominator factorization on canonical normalized +prime polynomial representatives. -/ +def ratFuncNormalizedPrimeDivisor [DecidableEq K] (f : RatFunc K) : + NormalizedPrimePolynomial K →₀ ℤ := + Finsupp.mapRange (fun n : ℕ => (n : ℤ)) (Nat.cast_zero) + (normalizedPrimeFactorization f.num) - + Finsupp.mapRange (fun n : ℕ => (n : ℤ)) (Nat.cast_zero) + (normalizedPrimeFactorization f.denom) + +@[simp] +theorem ratFuncNormalizedPrimeDivisor_apply [DecidableEq K] + (f : RatFunc K) (r : NormalizedPrimePolynomial K) : + ratFuncNormalizedPrimeDivisor f r = + (normalizedPrimeFactorization f.num r : ℤ) - + normalizedPrimeFactorization f.denom r := by + simp [ratFuncNormalizedPrimeDivisor] + +/-- The count-defined finite principal divisor agrees with the transported +normalized polynomial factorization. -/ +theorem ratFuncFiniteDivisor_eq_equivMapDomain_normalizedPrimeDivisor + [DecidableEq K] (f : RatFunc K) (hf : f ≠ 0) : + ratFuncFiniteDivisor f = + Finsupp.equivMapDomain normalizedPrimePolynomialEquivFinitePlace + (ratFuncNormalizedPrimeDivisor f) := by + ext v + rw [ratFuncFiniteDivisor_apply, Finsupp.equivMapDomain_apply, + ratFuncNormalizedPrimeDivisor_apply] + exact ratFuncFiniteOrder_eq_normalizedPrimeFactorization_sub f hf v + +private theorem factorization_support_subset_normalizedPrimePolynomial_range + [DecidableEq K] (p : K[X]) : + ((factorization p).support : Set K[X]) ⊆ + Set.range (Subtype.val : NormalizedPrimePolynomial K → K[X]) := by + intro r hr + have hr' : r ∈ normalizedFactors p := by + simpa only [support_factorization, Finset.mem_coe, Multiset.mem_toFinset] using hr + exact ⟨⟨r, prime_of_normalized_factor r hr', normalize_normalized_factor r hr'⟩, rfl⟩ + +private theorem normalizedPrimePolynomial_bijOn_factorizationSupport + [DecidableEq K] (p : K[X]) : + Set.BijOn (Subtype.val : NormalizedPrimePolynomial K → K[X]) + ((Subtype.val : NormalizedPrimePolynomial K → K[X]) ⁻¹' + ((factorization p).support : Set K[X])) + ((factorization p).support : Set K[X]) := by + refine ⟨?_, Subtype.val_injective.injOn, ?_⟩ + · intro r hr + exact hr + · intro r hr + obtain ⟨r', hr'eq⟩ := + factorization_support_subset_normalizedPrimePolynomial_range p hr + refine ⟨r', ?_, hr'eq⟩ + simpa only [Set.mem_preimage, hr'eq] using hr + +/-- The degree-weighted factorization over canonical normalized prime +representatives has total weight equal to polynomial degree. -/ +theorem normalizedPrimeFactorization_degreeSum [DecidableEq K] + (p : K[X]) (hp : p ≠ 0) : + (normalizedPrimeFactorization p).sum + (fun r n => n * (r : K[X]).natDegree) = p.natDegree := by + calc + (normalizedPrimeFactorization p).sum + (fun r n => n * (r : K[X]).natDegree) = + (factorization p).sum (fun r n => n * r.natDegree) := by + change (Finsupp.comapDomain Subtype.val (factorization p) + Subtype.val_injective.injOn).sum + ((fun r : K[X] => fun n => n * r.natDegree) ∘ Subtype.val) = _ + exact Finsupp.sum_comapDomain + (Subtype.val : NormalizedPrimePolynomial K → K[X]) + (factorization p) (fun r n => n * r.natDegree) + (normalizedPrimePolynomial_bijOn_factorizationSupport p) + _ = ∑ r ∈ (normalizedFactors p).toFinset, + (normalizedFactors p).count r * r.natDegree := by + simp only [Finsupp.sum, support_factorization, factorization_eq_count] + _ = p.natDegree := sum_normalizedFactor_natDegree p hp + +private theorem normalizedPrimeFactorization_intDegreeSum [DecidableEq K] + (p : K[X]) (hp : p ≠ 0) : + (normalizedPrimeFactorization p).sum + (fun r n => (n : ℤ) * ((r : K[X]).natDegree : ℤ)) = + (p.natDegree : ℤ) := by + exact_mod_cast normalizedPrimeFactorization_degreeSum p hp + +private theorem castNormalizedPrimeFactorization_intDegreeSum [DecidableEq K] + (p : K[X]) (hp : p ≠ 0) : + (Finsupp.mapRange (fun n : ℕ => (n : ℤ)) Nat.cast_zero + (normalizedPrimeFactorization p)).sum + (fun r n => n * ((r : K[X]).natDegree : ℤ)) = + (p.natDegree : ℤ) := by + rw [Finsupp.sum_mapRange_index (fun _ => zero_mul _)] + exact normalizedPrimeFactorization_intDegreeSum p hp + +/-- The exhaustive degree-weighted sum over all height-one primes of `K[X]`. +Its finite support is the support of the principal fractional ideal of `f`. -/ +def ratFuncExhaustiveFinitePlaceDegreeSum [DecidableEq K] (f : RatFunc K) : ℤ := + (ratFuncFiniteDivisor f).sum + (fun v n => n * (ratFuncFinitePlaceDegree v : ℤ)) + +private theorem ratFuncNormalizedPrimeDivisor_degreeSum_eq_intDegree + [DecidableEq K] (f : RatFunc K) (hf : f ≠ 0) : + (ratFuncNormalizedPrimeDivisor f).sum + (fun r n => n * ((r : K[X]).natDegree : ℤ)) = f.intDegree := by + rw [ratFuncNormalizedPrimeDivisor, Finsupp.sum_sub_index] + · rw [castNormalizedPrimeFactorization_intDegreeSum f.num (RatFunc.num_ne_zero hf), + castNormalizedPrimeFactorization_intDegreeSum f.denom f.denom_ne_zero] + rfl + · intro r a b + ring + +/-- The actual exhaustive finite-place degree formula for `K(X)`: the +degree-weighted sum of the principal-divisor coefficients over every +`HeightOneSpectrum K[X]` equals the rational-function degree. -/ +theorem ratFuncExhaustiveFinitePlaceDegreeSum_eq_intDegree + [DecidableEq K] (f : RatFunc K) (hf : f ≠ 0) : + ratFuncExhaustiveFinitePlaceDegreeSum f = f.intDegree := by + rw [ratFuncExhaustiveFinitePlaceDegreeSum, + ratFuncFiniteDivisor_eq_equivMapDomain_normalizedPrimeDivisor f hf, + Finsupp.sum_equivMapDomain] + change (ratFuncNormalizedPrimeDivisor f).sum + (fun r n => n * (ratFuncFinitePlaceDegree + (normalizedPrimeFinitePlace (K := K) r) : ℤ)) = f.intDegree + simpa only [ratFuncFinitePlaceDegree_normalizedPrimeFinitePlace] using + ratFuncNormalizedPrimeDivisor_degreeSum_eq_intDegree f hf + +/-- The exhaustive finite-place sum plus the order at infinity is zero. -/ +theorem ratFunc_exhaustiveFinitePlace_plus_infinity_productFormula + [DecidableEq K] (f : RatFunc K) (hf : f ≠ 0) : + ratFuncExhaustiveFinitePlaceDegreeSum f + ratFuncInfinityOrder f = 0 := by + rw [ratFuncExhaustiveFinitePlaceDegreeSum_eq_intDegree f hf] + simp only [ratFuncInfinityOrder, add_neg_cancel] + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/SeparatingCoordinateNotFrobenius.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/SeparatingCoordinateNotFrobenius.lean new file mode 100644 index 0000000000..ea52a94966 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/SeparatingCoordinateNotFrobenius.lean @@ -0,0 +1,224 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FrobeniusSubfield +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveSeparability +public import Mathlib.FieldTheory.PurelyInseparable.PerfectClosure + +/-! +# Separating coordinates are not Frobenius powers + +For an irreducible plane curve in characteristic `p`, a nonzero partial +derivative makes the function field separable over the field generated by the +opposite coordinate. This file uses that separability to prove that the +generating coordinate cannot be a `p`-th power in the curve function field. + +The last step is made explicit in the one-variable rational function field: +if `(a / b) ^ p = X`, then `a ^ p = X * b ^ p`, whose degrees would satisfy +`p * degree(a) = 1 + p * degree(b)`. +-/ + +@[expose] public section + +namespace BGS.CorvajaZannier + +noncomputable section + +/-- A polynomial variable is not a nontrivial power in the fraction field of +a multivariate polynomial ring. -/ +theorem mvPolynomial_variable_not_pow_in_fractionRing + {K σ : Type*} [Field K] (i : σ) (p : ℕ) (hp : 1 < p) : + ¬ ∃ z : FractionRing (MvPolynomial σ K), + z ^ p = algebraMap (MvPolynomial σ K) + (FractionRing (MvPolynomial σ K)) (MvPolynomial.X i) := by + rintro ⟨z, hz⟩ + let R := MvPolynomial σ K + let F := FractionRing R + obtain ⟨a, b, hb, hab⟩ := IsFractionRing.div_surjective R z + have hb0 : b ≠ 0 := nonZeroDivisors.ne_zero hb + have hmapb0 : algebraMap R F b ≠ 0 := by + simpa using (IsFractionRing.injective R F).ne hb0 + have hfield : + algebraMap R F (a ^ p) = algebraMap R F (MvPolynomial.X i * b ^ p) := by + rw [map_mul, map_pow, map_pow, ← hz, ← hab, div_pow] + rw [div_mul_cancel₀ _ (pow_ne_zero p hmapb0)] + have hpoly : a ^ p = MvPolynomial.X i * b ^ p := + IsFractionRing.injective R F hfield + have ha0 : a ≠ 0 := by + intro ha + rw [ha, zero_pow (Nat.ne_zero_of_lt hp), zero_eq_mul] at hpoly + exact pow_ne_zero p hb0 (hpoly.resolve_left (MvPolynomial.X_ne_zero i)) + have hdegree := congrArg (MvPolynomial.degreeOf i) hpoly + rw [MvPolynomial.degreeOf_pow_eq i a p ha0, + MvPolynomial.degreeOf_mul_eq (MvPolynomial.X_ne_zero i) (pow_ne_zero p hb0), + MvPolynomial.degreeOf_X_self, + MvPolynomial.degreeOf_pow_eq i b p hb0] at hdegree + have hmod := congrArg (fun n : ℕ => n % p) hdegree + simp [Nat.add_mod, Nat.mod_eq_of_lt hp] at hmod + +/-- The first coordinate has no nontrivial power root in the field it +generates over the constant field. -/ +theorem firstCoordinateInSubfield_not_pow + {K : Type*} [Field K] {f : MvPolynomial (Fin 2) K} + (hf : Irreducible f) (hsecond : 0 < MvPolynomial.degreeOf 1 f) + (p : ℕ) (hp : 1 < p) : + letI := planeCurveCoordinateRing_isDomain hf + ¬ ∃ z : FirstCoordinateSubfield f, + z ^ p = firstCoordinateInSubfield f := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let remaining := {i : Fin 2 // i ≠ 1} + let i0 : remaining := ⟨0, by decide⟩ + have htrans : Transcendental K (planeCurveFunction f 0) := + firstCoordinate_transcendental hf hsecond + let e := firstCoordinateFractionEquiv f htrans + rintro ⟨z, hz⟩ + apply mvPolynomial_variable_not_pow_in_fractionRing + (K := K) (σ := remaining) i0 p hp + refine ⟨e.symm z, ?_⟩ + apply e.injective + rw [map_pow, e.apply_symm_apply, hz, + firstCoordinateFractionEquiv_algebraMap] + apply Subtype.ext + simp [firstCoordinateCoefficientEval, firstCoordinateInSubfield, i0] + +/-- The second coordinate has no nontrivial power root in the field it +generates over the constant field. -/ +theorem secondCoordinateInSubfield_not_pow + {K : Type*} [Field K] {f : MvPolynomial (Fin 2) K} + (hf : Irreducible f) (hfirst : 0 < MvPolynomial.degreeOf 0 f) + (p : ℕ) (hp : 1 < p) : + letI := planeCurveCoordinateRing_isDomain hf + ¬ ∃ z : SecondCoordinateSubfield f, + z ^ p = secondCoordinateInSubfield f := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let remaining := {i : Fin 2 // i ≠ 0} + let i1 : remaining := ⟨1, by decide⟩ + have htrans : Transcendental K (planeCurveFunction f 1) := + secondCoordinate_transcendental hf hfirst + let e := secondCoordinateFractionEquiv f htrans + rintro ⟨z, hz⟩ + apply mvPolynomial_variable_not_pow_in_fractionRing + (K := K) (σ := remaining) i1 p hp + refine ⟨e.symm z, ?_⟩ + apply e.injective + rw [map_pow, e.apply_symm_apply, hz, + secondCoordinateFractionEquiv_algebraMap] + apply Subtype.ext + simp [secondCoordinateCoefficientEval, secondCoordinateInSubfield, i1] + +/-- A first coordinate that is separating (equivalently here, the other +partial derivative is nonzero) is not a `p`-th power in the plane-curve +function field. -/ +theorem firstCoordinate_not_mem_frobeniusSubfield + {K : Type*} [Field K] {p : ℕ} [Fact p.Prime] [CharP K p] + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) : + letI := planeCurveCoordinateRing_isDomain hf + letI : CharP (PlaneCurveFunctionField f) p := + charP_of_injective_algebraMap + (algebraMap K (PlaneCurveFunctionField f)).injective p + planeCurveFunction f 0 ∉ + frobeniusSubfield (PlaneCurveFunctionField f) p := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let L := PlaneCurveFunctionField f + let : CharP L p := charP_of_injective_algebraMap + (algebraMap K L).injective p + let F := FirstCoordinateSubfield f + have hseparable := + (finiteSeparable_over_firstCoordinate_of_irreducible hf hpartialSecond).2 + let : Algebra.IsSeparable F L := hseparable + intro hx + rcases hx with ⟨y, hy⟩ + have hypow : y ^ p = planeCurveFunction f 0 := by + simpa [frobenius_def] using hy + let E : IntermediateField F L := IntermediateField.adjoin F {y} + let : IsPurelyInseparable F E := + (IntermediateField.isPurelyInseparable_adjoin_simple_iff_pow_mem F L p).2 (by + refine ⟨1, ?_⟩ + rw [pow_one] + refine ⟨firstCoordinateInSubfield f, ?_⟩ + change planeCurveFunction f 0 = y ^ p + exact hypow.symm) + let : Algebra.IsSeparable F E := + (IntermediateField.isSeparable_adjoin_simple_iff_isSeparable F L).2 + (Algebra.IsSeparable.isSeparable F y) + have hE : E = ⊥ := + IntermediateField.eq_bot_of_isPurelyInseparable_of_isSeparable E + have hyE : y ∈ E := IntermediateField.mem_adjoin_simple_self F y + rw [hE] at hyE + rw [IntermediateField.mem_bot] at hyE + rcases hyE with ⟨z, hz⟩ + apply firstCoordinateInSubfield_not_pow hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) p + (Fact.out : p.Prime).one_lt + refine ⟨z, ?_⟩ + apply Subtype.ext + change (z : L) ^ p = planeCurveFunction f 0 + have hz' : (z : L) = y := by simpa [L] using hz + rw [hz'] + exact hypow + +/-- A second coordinate that is separating (equivalently here, the other +partial derivative is nonzero) is not a `p`-th power in the plane-curve +function field. -/ +theorem secondCoordinate_not_mem_frobeniusSubfield + {K : Type*} [Field K] {p : ℕ} [Fact p.Prime] [CharP K p] + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) : + letI := planeCurveCoordinateRing_isDomain hf + letI : CharP (PlaneCurveFunctionField f) p := + charP_of_injective_algebraMap + (algebraMap K (PlaneCurveFunctionField f)).injective p + planeCurveFunction f 1 ∉ + frobeniusSubfield (PlaneCurveFunctionField f) p := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let L := PlaneCurveFunctionField f + let : CharP L p := charP_of_injective_algebraMap + (algebraMap K L).injective p + let F := SecondCoordinateSubfield f + have hseparable := + (finiteSeparable_over_secondCoordinate_of_irreducible hf hpartialFirst).2 + let : Algebra.IsSeparable F L := hseparable + intro hx + rcases hx with ⟨y, hy⟩ + have hypow : y ^ p = planeCurveFunction f 1 := by + simpa [frobenius_def] using hy + let E : IntermediateField F L := IntermediateField.adjoin F {y} + let : IsPurelyInseparable F E := + (IntermediateField.isPurelyInseparable_adjoin_simple_iff_pow_mem F L p).2 (by + refine ⟨1, ?_⟩ + rw [pow_one] + refine ⟨secondCoordinateInSubfield f, ?_⟩ + change planeCurveFunction f 1 = y ^ p + exact hypow.symm) + let : Algebra.IsSeparable F E := + (IntermediateField.isSeparable_adjoin_simple_iff_isSeparable F L).2 + (Algebra.IsSeparable.isSeparable F y) + have hE : E = ⊥ := + IntermediateField.eq_bot_of_isPurelyInseparable_of_isSeparable E + have hyE : y ∈ E := IntermediateField.mem_adjoin_simple_self F y + rw [hE] at hyE + rw [IntermediateField.mem_bot] at hyE + rcases hyE with ⟨z, hz⟩ + apply secondCoordinateInSubfield_not_pow hf + (degreeOf_first_pos_of_pderiv_ne_zero hpartialFirst) p + (Fact.out : p.Prime).one_lt + refine ⟨z, ?_⟩ + apply Subtype.ext + change (z : L) ^ p = planeCurveFunction f 1 + have hz' : (z : L) = y := by simpa [L] using hz + rw [hz'] + exact hypow + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/TorsionBidegreeCount.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/TorsionBidegreeCount.lean new file mode 100644 index 0000000000..f85626d643 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/TorsionBidegreeCount.lean @@ -0,0 +1,370 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveDiscriminantBound +public import Mathlib.RingTheory.RootsOfUnity.Basic +public import Mathlib.Tactic + +/-! +# Bidegree bounds for finite torus-curve intersections + +For an irreducible bivariate curve with positive degree in both coordinates, +every coordinate fiber is cut out by a nonzero univariate polynomial. Counting +roots in each fiber gives the sharp elementary estimates +`firstOrder * secondDegree` and `secondOrder * firstDegree`; their minimum is +the elementary divisor bound used at the Corvaja--Zannier endpoint. + +The irreducibility and positive-coordinate-degree hypotheses are essential: +a polynomial with a vertical or horizontal component can contain an entire row +or column of the torsion grid. +-/ + +@[expose] public section + +open Polynomial + +namespace BGS.CorvajaZannier + +noncomputable section + +variable {K : Type*} [Field K] + +/-- Specialize the first coordinate of a bivariate polynomial, leaving a +univariate polynomial in the second coordinate. -/ +def secondCoordinateSpecialization + (f : MvPolynomial (Fin 2) K) (x : K) : Polynomial K := + (planeCurvePolynomialInSecondCoordinate f).map (Polynomial.evalRingHom x) + +@[simp] +theorem secondCoordinateSpecialization_eval + (f : MvPolynomial (Fin 2) K) (x y : K) : + (secondCoordinateSpecialization f x).eval y = + MvPolynomial.eval ![x, y] f := by + let g := MvPolynomial.rename (Equiv.swap (0 : Fin 2) 1) f + let Q := MvPolynomial.finSuccEquiv K 1 g + let e := MvPolynomial.uniqueAlgEquiv K (Fin 1) + have hevalHom : + (Polynomial.evalRingHom x).comp e.toRingEquiv.toRingHom = + MvPolynomial.eval ![x] := by + apply MvPolynomial.ringHom_ext + · intro c + simp [e] + · intro i + fin_cases i + simp [e, MvPolynomial.uniqueAlgEquiv_apply] + have hiterated := MvPolynomial.eval_eq_eval_mv_eval' ![x] y g + change Polynomial.eval y + (Polynomial.map (Polynomial.evalRingHom x) + (Polynomial.map e.toRingEquiv.toRingHom Q)) = _ + rw [Polynomial.map_map, hevalHom] + rw [← hiterated] + simp [g, MvPolynomial.eval_rename] + +/-- An irreducible curve of positive second-coordinate degree has no +identically zero fiber over a fixed first coordinate. -/ +theorem secondCoordinateSpecialization_ne_zero_of_irreducible + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hsecond : 0 < MvPolynomial.degreeOf 1 f) (x : K) : + secondCoordinateSpecialization f x ≠ 0 := by + let F : Polynomial (Polynomial K) := planeCurvePolynomialInSecondCoordinate f + have hF : Irreducible F := + hf.map planeCurvePolynomialInSecondCoordinate + have hFdegree : 0 < F.natDegree := by + simpa [F] using hsecond + intro hspecialization + have hcoeffEval : ∀ i, (F.coeff i).eval x = 0 := by + intro i + have hi := congrArg (fun P : Polynomial K => P.coeff i) hspecialization + simpa [secondCoordinateSpecialization, F] using hi + have hcoeffDvd : ∀ i, Polynomial.X - Polynomial.C x ∣ F.coeff i := by + intro i + exact Polynomial.dvd_iff_isRoot.mpr (hcoeffEval i) + have hdvd : Polynomial.C (Polynomial.X - Polynomial.C x) ∣ F := + Polynomial.C_dvd_iff_dvd_coeff _ _ |>.mpr hcoeffDvd + obtain ⟨q, hfactor⟩ := hdvd + have hfactor' : F = Polynomial.C (Polynomial.X - Polynomial.C x) * q := + hfactor + rcases hF.isUnit_or_isUnit hfactor' with hunit | hqunit + · exact (Polynomial.not_isUnit_X_sub_C x) + (Polynomial.isUnit_C.mp hunit) + · have hdegreeZero : F.natDegree = 0 := by + rw [hfactor'] + apply Nat.eq_zero_of_le_zero + calc + (Polynomial.C (Polynomial.X - Polynomial.C x) * q).natDegree + ≤ (Polynomial.C (Polynomial.X - Polynomial.C x)).natDegree + + q.natDegree := Polynomial.natDegree_mul_le + _ = 0 := by rw [Polynomial.natDegree_C, + Polynomial.natDegree_eq_zero_of_isUnit hqunit] + exact (Nat.ne_of_gt hFdegree) hdegreeZero + +/-- A support-wise bidegree bound controls every specialized fiber degree. -/ +theorem secondCoordinateSpecialization_natDegree_le + {f : MvPolynomial (Fin 2) K} {firstDegree secondDegree : ℕ} + (hdegree : BGS.External.HasBidegreeAtMost f firstDegree secondDegree) + (x : K) : + (secondCoordinateSpecialization f x).natDegree ≤ secondDegree := by + calc + (secondCoordinateSpecialization f x).natDegree ≤ + (planeCurvePolynomialInSecondCoordinate f).natDegree := + Polynomial.natDegree_map_le + _ = MvPolynomial.degreeOf 1 f := + planeCurvePolynomialInSecondCoordinate_natDegree f + _ ≤ secondDegree := + degreeOf_second_le_of_hasBidegreeAtMost hdegree + +/-- Specialization cannot increase the second-coordinate degree. -/ +theorem secondCoordinateSpecialization_natDegree_le_degreeOf_second + (f : MvPolynomial (Fin 2) K) (x : K) : + (secondCoordinateSpecialization f x).natDegree ≤ + MvPolynomial.degreeOf 1 f := by + calc + (secondCoordinateSpecialization f x).natDegree ≤ + (planeCurvePolynomialInSecondCoordinate f).natDegree := + Polynomial.natDegree_map_le + _ = MvPolynomial.degreeOf 1 f := + planeCurvePolynomialInSecondCoordinate_natDegree f + +private theorem evalZeroSubtype_card_le_natDegree + {K : Type*} [Field K] [Fintype K] [DecidableEq K] + (P : Polynomial K) (hP : P ≠ 0) : + Fintype.card {x : K // P.eval x = 0} ≤ P.natDegree := by + classical + let rootEmbedding : {x : K // P.eval x = 0} ↪ P.roots.toFinset := + { toFun := fun x => ⟨x, by + rw [Multiset.mem_toFinset, Polynomial.mem_roots hP] + exact x.2⟩ + inj' := by + intro x y h + apply Subtype.ext + exact congrArg (fun z : P.roots.toFinset => (z : K)) h } + calc + Fintype.card {x : K // P.eval x = 0} ≤ P.roots.toFinset.card := + by + simpa only [Fintype.card_coe] using + Fintype.card_le_of_injective rootEmbedding rootEmbedding.injective + _ ≤ P.roots.card := Multiset.toFinset_card_le _ + _ ≤ P.natDegree := Polynomial.card_roots' P + +/-- Fiber counting over first-coordinate roots of unity, stated using an +explicit second-coordinate degree bound. -/ +theorem torusCurveTorsionIntersection_card_le_firstOrder_mul_of_degreeOf_second_le + {K : Type*} [Field K] [Fintype K] [DecidableEq K] + (f : MvPolynomial (Fin 2) K) + (secondDegree firstOrder secondOrder : ℕ) + (hdegreeSecond : MvPolynomial.degreeOf 1 f ≤ secondDegree) + (hf : Irreducible f) + (hsecond : 0 < MvPolynomial.degreeOf 1 f) + (hfirstOrder : 0 < firstOrder) : + (BGS.External.torusCurveTorsionIntersection + K f firstOrder secondOrder).card ≤ firstOrder * secondDegree := by + classical + let S := BGS.External.torusCurveTorsionIntersection + K f firstOrder secondOrder + let : NeZero firstOrder := ⟨hfirstOrder.ne'⟩ + let : Fintype (rootsOfUnity firstOrder K) := Fintype.ofFinite _ + let T := fun x : rootsOfUnity firstOrder K => + {y : K // (secondCoordinateSpecialization f (x.1 : K)).eval y = 0} + let embedding : {z // z ∈ S} ↪ Sigma T := + { toFun := fun z => + ⟨⟨z.1.1, (mem_rootsOfUnity firstOrder z.1.1).2 + (BGS.External.mem_torusCurveTorsionIntersection_iff.mp z.2).2.1⟩, + ⟨(z.1.2 : K), by + rw [secondCoordinateSpecialization_eval] + exact (BGS.External.mem_torusCurveTorsionIntersection_iff.mp z.2).1⟩⟩ + inj' := by + intro z w hzw + apply Subtype.ext + apply Prod.ext + · exact congrArg (fun q : Sigma T => (q.1 : Kˣ)) hzw + · apply Units.ext + exact congrArg (fun q : Sigma T => (q.2.1 : K)) hzw } + have hFiber (x : rootsOfUnity firstOrder K) : + Fintype.card (T x) ≤ secondDegree := by + exact (evalZeroSubtype_card_le_natDegree + (secondCoordinateSpecialization f (x.1 : K)) + (secondCoordinateSpecialization_ne_zero_of_irreducible + hf hsecond (x.1 : K))).trans + ((secondCoordinateSpecialization_natDegree_le_degreeOf_second + f (x.1 : K)).trans hdegreeSecond) + calc + S.card = Fintype.card {z // z ∈ S} := by simp + _ ≤ Fintype.card (Sigma T) := + Fintype.card_le_of_injective embedding embedding.injective + _ = ∑ x, Fintype.card (T x) := Fintype.card_sigma + _ ≤ ∑ _x : rootsOfUnity firstOrder K, secondDegree := by + exact Finset.sum_le_sum fun x _ => hFiber x + _ = Fintype.card (rootsOfUnity firstOrder K) * secondDegree := by + simp + _ ≤ firstOrder * secondDegree := + Nat.mul_le_mul_right secondDegree (by + simpa only [Nat.card_eq_fintype_card] using + card_rootsOfUnity K firstOrder) + +/-- The torsion intersection has at most `firstOrder * secondDegree` points. -/ +theorem torusCurveTorsionIntersection_card_le_firstOrder_mul_secondDegree + {K : Type*} [Field K] [Fintype K] [DecidableEq K] + (f : MvPolynomial (Fin 2) K) + (firstDegree secondDegree firstOrder secondOrder : ℕ) + (hdegree : BGS.External.HasBidegreeAtMost f firstDegree secondDegree) + (hf : Irreducible f) + (hsecond : 0 < MvPolynomial.degreeOf 1 f) + (hfirstOrder : 0 < firstOrder) : + (BGS.External.torusCurveTorsionIntersection + K f firstOrder secondOrder).card ≤ firstOrder * secondDegree := + torusCurveTorsionIntersection_card_le_firstOrder_mul_of_degreeOf_second_le + f secondDegree firstOrder secondOrder + (degreeOf_second_le_of_hasBidegreeAtMost hdegree) + hf hsecond hfirstOrder + +/-- Swap the two coordinates of a bivariate polynomial. -/ +def swapPlaneCurveCoordinates (f : MvPolynomial (Fin 2) K) : + MvPolynomial (Fin 2) K := + MvPolynomial.rename (Equiv.swap (0 : Fin 2) 1) f + +@[simp] +theorem eval_swapPlaneCurveCoordinates (f : MvPolynomial (Fin 2) K) + (x y : K) : + MvPolynomial.eval ![y, x] (swapPlaneCurveCoordinates f) = + MvPolynomial.eval ![x, y] f := by + simp [swapPlaneCurveCoordinates, MvPolynomial.eval_rename] + +/-- Swapping both curve coordinates and torsion orders preserves the torsion +intersection. -/ +def torusCurveTorsionIntersectionSwapEquiv + {K : Type*} [Field K] [Fintype K] [DecidableEq K] + (f : MvPolynomial (Fin 2) K) (firstOrder secondOrder : ℕ) : + {z // z ∈ BGS.External.torusCurveTorsionIntersection + K f firstOrder secondOrder} ≃ + {z // z ∈ BGS.External.torusCurveTorsionIntersection + K (swapPlaneCurveCoordinates f) secondOrder firstOrder} := by + classical + let swapPoint : Kˣ × Kˣ → Kˣ × Kˣ := fun z => (z.2, z.1) + refine + { toFun := fun z => ⟨swapPoint z.1, ?_⟩ + invFun := fun z => ⟨swapPoint z.1, ?_⟩ + left_inv := ?_ + right_inv := ?_ } + · rw [BGS.External.mem_torusCurveTorsionIntersection_iff] + have hz := BGS.External.mem_torusCurveTorsionIntersection_iff.mp z.2 + exact ⟨by + simpa [swapPoint] using hz.1, + hz.2.2, hz.2.1⟩ + · rw [BGS.External.mem_torusCurveTorsionIntersection_iff] + have hz := BGS.External.mem_torusCurveTorsionIntersection_iff.mp z.2 + exact ⟨by + simpa [swapPoint] using hz.1, + hz.2.2, hz.2.1⟩ + · intro z + apply Subtype.ext + rfl + · intro z + apply Subtype.ext + rfl + +/-- Coordinate swapping preserves the torsion-intersection cardinality. -/ +theorem torusCurveTorsionIntersection_card_swap + {K : Type*} [Field K] [Fintype K] [DecidableEq K] + (f : MvPolynomial (Fin 2) K) (firstOrder secondOrder : ℕ) : + (BGS.External.torusCurveTorsionIntersection + K f firstOrder secondOrder).card = + (BGS.External.torusCurveTorsionIntersection K + (swapPlaneCurveCoordinates f) secondOrder firstOrder).card := by + classical + calc + (BGS.External.torusCurveTorsionIntersection + K f firstOrder secondOrder).card = + Fintype.card {z // z ∈ BGS.External.torusCurveTorsionIntersection + K f firstOrder secondOrder} := + (Fintype.card_coe + (BGS.External.torusCurveTorsionIntersection + K f firstOrder secondOrder)).symm + _ = Fintype.card {z // z ∈ BGS.External.torusCurveTorsionIntersection K + (swapPlaneCurveCoordinates f) secondOrder firstOrder} := + Fintype.card_congr + (torusCurveTorsionIntersectionSwapEquiv f firstOrder secondOrder) + _ = (BGS.External.torusCurveTorsionIntersection K + (swapPlaneCurveCoordinates f) secondOrder firstOrder).card := + Fintype.card_coe + (BGS.External.torusCurveTorsionIntersection K + (swapPlaneCurveCoordinates f) secondOrder firstOrder) + +/-- The torsion intersection has at most `secondOrder * firstDegree` points. -/ +theorem torusCurveTorsionIntersection_card_le_secondOrder_mul_firstDegree + {K : Type*} [Field K] [Fintype K] [DecidableEq K] + (f : MvPolynomial (Fin 2) K) + (firstDegree secondDegree firstOrder secondOrder : ℕ) + (hdegree : BGS.External.HasBidegreeAtMost f firstDegree secondDegree) + (hf : Irreducible f) + (hfirst : 0 < MvPolynomial.degreeOf 0 f) + (hsecondOrder : 0 < secondOrder) : + (BGS.External.torusCurveTorsionIntersection + K f firstOrder secondOrder).card ≤ secondOrder * firstDegree := by + let fSwap := swapPlaneCurveCoordinates f + have hfSwap : Irreducible fSwap := by + exact hf.map (MvPolynomial.renameEquiv K (Equiv.swap (0 : Fin 2) 1)) + have hdegreeSwap : MvPolynomial.degreeOf 1 fSwap ≤ firstDegree := by + have hdegreeEq := MvPolynomial.degreeOf_rename_of_injective + (Equiv.swap (0 : Fin 2) 1).injective (0 : Fin 2) (p := f) + rw [show (Equiv.swap (0 : Fin 2) 1) 0 = 1 by decide] at hdegreeEq + exact hdegreeEq.le.trans + (degreeOf_first_le_of_hasBidegreeAtMost hdegree) + have hpositiveSwap : 0 < MvPolynomial.degreeOf 1 fSwap := by + have hdegreeEq := MvPolynomial.degreeOf_rename_of_injective + (Equiv.swap (0 : Fin 2) 1).injective (0 : Fin 2) (p := f) + rw [show (Equiv.swap (0 : Fin 2) 1) 0 = 1 by decide] at hdegreeEq + exact hdegreeEq.symm ▸ hfirst + rw [torusCurveTorsionIntersection_card_swap] + exact torusCurveTorsionIntersection_card_le_firstOrder_mul_of_degreeOf_second_le + fSwap firstDegree secondOrder firstOrder hdegreeSwap hfSwap + hpositiveSwap hsecondOrder + +/-- The sharp elementary bidegree/order bound under the precise algebraic +hypotheses needed for fiber counting. -/ +theorem torusCurveTorsionIntersection_card_le_min_bidegree_order_of_irreducible + {K : Type*} [Field K] [Fintype K] [DecidableEq K] + (f : MvPolynomial (Fin 2) K) + (firstDegree secondDegree firstOrder secondOrder : ℕ) + (hdegree : BGS.External.HasBidegreeAtMost f firstDegree secondDegree) + (hf : Irreducible f) + (hfirst : 0 < MvPolynomial.degreeOf 0 f) + (hsecond : 0 < MvPolynomial.degreeOf 1 f) + (hfirstOrder : 0 < firstOrder) (hsecondOrder : 0 < secondOrder) : + (BGS.External.torusCurveTorsionIntersection + K f firstOrder secondOrder).card ≤ + min (firstOrder * secondDegree) (secondOrder * firstDegree) := by + apply le_min + · exact torusCurveTorsionIntersection_card_le_firstOrder_mul_secondDegree + f firstDegree secondDegree firstOrder secondOrder hdegree hf + hsecond hfirstOrder + · exact torusCurveTorsionIntersection_card_le_secondOrder_mul_firstDegree + f firstDegree secondDegree firstOrder secondOrder hdegree hf + hfirst hsecondOrder + +/-- The sharp elementary bidegree/order bound for an admissible torus curve. -/ +theorem torusCurveTorsionIntersection_card_le_min_bidegree_order + {K : Type*} [Field K] [Fintype K] [DecidableEq K] + (f : MvPolynomial (Fin 2) K) + (firstDegree secondDegree firstOrder secondOrder : ℕ) + (hdegree : BGS.External.HasBidegreeAtMost f firstDegree secondDegree) + (hcurve : BGS.External.IsCorvajaZannierPlaneCurve f) + (hfirstOrder : 0 < firstOrder) (hsecondOrder : 0 < secondOrder) : + (BGS.External.torusCurveTorsionIntersection + K f firstOrder secondOrder).card ≤ + min (firstOrder * secondDegree) (secondOrder * firstDegree) := by + have hf : Irreducible f := + irreducible_of_irreducible_map_algebraicClosure hcurve.1 + exact torusCurveTorsionIntersection_card_le_min_bidegree_order_of_irreducible + f firstDegree secondDegree firstOrder secondOrder hdegree hf + (degreeOf_first_pos_of_pderiv_ne_zero hcurve.2.2.1) + (degreeOf_second_pos_of_pderiv_ne_zero hcurve.2.2.2) + hfirstOrder hsecondOrder + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/TorsionExhaustiveGcdDivisorBound.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/TorsionExhaustiveGcdDivisorBound.lean new file mode 100644 index 0000000000..943e5df653 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/TorsionExhaustiveGcdDivisorBound.lean @@ -0,0 +1,862 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.TorsionGcdDivisorBound +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionPrincipalDivisor +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveRatFuncModel +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.DedekindLocalizationOrder +public import Mathlib.RingTheory.Valuation.LocalSubring + +/-! +# Torsion points and the exhaustive gcd divisor + +The affine normalization used in `TorsionGcdDivisorBound` need not be finite +over the polynomial ring defining the selected `K(X)`-model. This file +bridges that mismatch without assuming an algebra map between the two +normalizations. A valuation subring dominating the affine local ring of a +torsion point determines a height-one prime in the finite integral closure of +`K[X]`. Distinct affine points determine distinct valuation subrings, hence +distinct finite places. Both powered coordinate functions have positive +order there. + +Consequently rational torsion points inject into the finite part of the +exhaustive place type. Each selected place contributes at least one to the +degree-weighted positive gcd divisor used by the global Wronskian argument. +-/ + +@[expose] public section + +open IsDedekindDomain +open Multiplicative WithZero + +namespace BGS.CorvajaZannier + +noncomputable section + +section DominatingValuationSubring + +variable {A L : Type*} [CommRing A] [IsDomain A] [Field L] + [Algebra A L] [IsFractionRing A L] + +/-- The fraction-field embedding, with codomain restricted to its range. -/ +noncomputable def fractionEmbeddingRangeEquiv : + A ≃+* (algebraMap A L).range := + RingEquiv.ofBijective (algebraMap A L).rangeRestrict + ⟨fun x y hxy => IsFractionRing.injective A L (congrArg Subtype.val hxy), + fun y => by + obtain ⟨x, hx⟩ := y.2 + exact ⟨x, Subtype.ext hx⟩⟩ + +/-- The image of a maximal ideal inside the embedded copy of `A` in `L`. -/ +noncomputable def maximalIdealInFractionEmbeddingRange + (m : MaximalSpectrum A) : Ideal (algebraMap A L).range := + m.asIdeal.map (fractionEmbeddingRangeEquiv (A := A) (L := L)).toRingHom + +omit [IsDomain A] in +private theorem maximalIdealInFractionEmbeddingRange_ne_top + (m : MaximalSpectrum A) : + maximalIdealInFractionEmbeddingRange (A := A) (L := L) m ≠ ⊤ := by + rw [maximalIdealInFractionEmbeddingRange] + intro htop + apply m.isMaximal.ne_top + let e := fractionEmbeddingRangeEquiv (A := A) (L := L) + calc + m.asIdeal = Ideal.comap e.toRingHom + (Ideal.map e.toRingHom m.asIdeal) := by + symm + calc + Ideal.comap e.toRingHom (Ideal.map e.toRingHom m.asIdeal) = + m.asIdeal ⊔ Ideal.comap e.toRingHom ⊥ := + Ideal.comap_map_of_surjective e.toRingHom e.surjective m.asIdeal + _ = m.asIdeal := by + have hker : Ideal.comap e.toRingHom ⊥ = ⊥ := + (RingHom.injective_iff_ker_eq_bot e.toRingHom).mp e.injective + rw [hker, sup_eq_left] + exact bot_le + _ = Ideal.comap e.toRingHom ⊤ := by rw [htop] + _ = ⊤ := Ideal.comap_top + +/-- A valuation subring of the fraction field dominating the affine local +ring at `m`. -/ +noncomputable def dominatingValuationSubring (m : MaximalSpectrum A) : + ValuationSubring L := + Classical.choose (Ideal.image_subset_nonunits_valuationSubring + (maximalIdealInFractionEmbeddingRange (A := A) (L := L) m) + (by exact maximalIdealInFractionEmbeddingRange_ne_top m)) + +omit [IsDomain A] in +theorem range_le_dominatingValuationSubring (m : MaximalSpectrum A) : + (algebraMap A L).range ≤ + (dominatingValuationSubring (A := A) (L := L) m).toSubring := + (Classical.choose_spec (Ideal.image_subset_nonunits_valuationSubring + (maximalIdealInFractionEmbeddingRange (A := A) (L := L) m) + (by exact maximalIdealInFractionEmbeddingRange_ne_top m))).1 + +omit [IsDomain A] in +theorem algebraMap_mem_dominatingValuationSubring_nonunits_of_mem + (m : MaximalSpectrum A) (r : A) (hr : r ∈ m.asIdeal) : + algebraMap A L r ∈ + (dominatingValuationSubring (A := A) (L := L) m).nonunits := by + let e := fractionEmbeddingRangeEquiv (A := A) (L := L) + have himage : e r ∈ + maximalIdealInFractionEmbeddingRange (A := A) (L := L) m := by + exact Ideal.mem_map_of_mem e.toRingHom hr + have hnonunits := + (Classical.choose_spec (Ideal.image_subset_nonunits_valuationSubring + (maximalIdealInFractionEmbeddingRange (A := A) (L := L) m) + (by exact maximalIdealInFractionEmbeddingRange_ne_top m))).2 + apply hnonunits + refine ⟨e r, himage, ?_⟩ + rfl + +/-- The affine ring map into its dominating valuation subring. -/ +noncomputable def coordinateRingToDominatingValuationSubring + (m : MaximalSpectrum A) : + A →+* dominatingValuationSubring (A := A) (L := L) m := + (Subring.inclusion (range_le_dominatingValuationSubring m)).comp + (algebraMap A L).rangeRestrict + +omit [IsDomain A] in +theorem pointIdeal_eq_comap_dominatingValuationSubring_maximalIdeal + (m : MaximalSpectrum A) : + m.asIdeal = Ideal.comap (coordinateRingToDominatingValuationSubring m) + (IsLocalRing.maximalIdeal + (dominatingValuationSubring (A := A) (L := L) m)) := by + apply m.isMaximal.eq_of_le + · intro htop + have hmaxTop : IsLocalRing.maximalIdeal + (dominatingValuationSubring (A := A) (L := L) m) = ⊤ := + Ideal.comap_eq_top_iff.mp htop + exact (IsLocalRing.maximalIdeal.isMaximal + (dominatingValuationSubring (A := A) (L := L) m)).ne_top hmaxTop + · intro r hr + have hnonunits := + algebraMap_mem_dominatingValuationSubring_nonunits_of_mem + (A := A) (L := L) m r hr + exact ValuationSubring.coe_mem_nonunits_iff.mp hnonunits + +/-- Equality of the chosen dominating valuation subrings forces equality of +the affine centers. -/ +theorem pointIdeal_eq_of_dominatingValuationSubring_eq + {m n : MaximalSpectrum A} + (h : dominatingValuationSubring (A := A) (L := L) m = + dominatingValuationSubring (A := A) (L := L) n) : + m.asIdeal = n.asIdeal := by + apply le_antisymm + · intro r hr + rw [pointIdeal_eq_comap_dominatingValuationSubring_maximalIdeal + (A := A) (L := L) n] + have hnonunits := + algebraMap_mem_dominatingValuationSubring_nonunits_of_mem + (A := A) (L := L) m r hr + rw [h] at hnonunits + exact ValuationSubring.coe_mem_nonunits_iff.mp hnonunits + · intro r hr + rw [pointIdeal_eq_comap_dominatingValuationSubring_maximalIdeal + (A := A) (L := L) m] + have hnonunits := + algebraMap_mem_dominatingValuationSubring_nonunits_of_mem + (A := A) (L := L) n r hr + rw [← h] at hnonunits + exact ValuationSubring.coe_mem_nonunits_iff.mp hnonunits + +section IntegralClosure + +variable {P : Type*} [CommRing P] [Algebra P L] + +omit [IsDomain A] in +theorem integralClosure_le_dominatingValuationSubring + (m : MaximalSpectrum A) + (hbase : ∀ p : P, algebraMap P L p ∈ (algebraMap A L).range) : + (integralClosure P L).toSubring ≤ + (dominatingValuationSubring (A := A) (L := L) m).toSubring := by + let V := dominatingValuationSubring (A := A) (L := L) m + let : IsIntegrallyClosedIn V.toSubring L := + inferInstanceAs (IsIntegrallyClosedIn V L) + rw [Subring.integralClosure_le_iff] + intro p + exact range_le_dominatingValuationSubring m (hbase p) + +/-- The finite integral closure maps into the valuation subring because the +selected polynomial base is already contained in the affine ring. -/ +noncomputable def integralClosureToDominatingValuationSubring + (m : MaximalSpectrum A) + (hbase : ∀ p : P, algebraMap P L p ∈ (algebraMap A L).range) : + integralClosure P L →+* + dominatingValuationSubring (A := A) (L := L) m := + Subring.inclusion (integralClosure_le_dominatingValuationSubring m hbase) + +/-- The center of the dominating valuation on the finite integral closure. -/ +noncomputable def dominatingIntegralClosurePrime + (m : MaximalSpectrum A) + (hbase : ∀ p : P, algebraMap P L p ∈ (algebraMap A L).range) : + Ideal (integralClosure P L) := + Ideal.comap (integralClosureToDominatingValuationSubring m hbase) + (IsLocalRing.maximalIdeal + (dominatingValuationSubring (A := A) (L := L) m)) + +theorem dominatingIntegralClosurePrime_isPrime + (m : MaximalSpectrum A) + (hbase : ∀ p : P, algebraMap P L p ∈ (algebraMap A L).range) : + (dominatingIntegralClosurePrime m hbase).IsPrime := by + exact Ideal.comap_isPrime _ _ + +variable [IsDedekindDomain (integralClosure P L)] + [IsFractionRing (integralClosure P L) L] + +/-- A nonzero center in the finite integral closure, regarded as a finite +place. -/ +noncomputable def dominatingIntegralClosurePlace + (m : MaximalSpectrum A) + (hbase : ∀ p : P, algebraMap P L p ∈ (algebraMap A L).range) + (hne : dominatingIntegralClosurePrime m hbase ≠ ⊥) : + HeightOneSpectrum (integralClosure P L) := + ⟨dominatingIntegralClosurePrime m hbase, + dominatingIntegralClosurePrime_isPrime m hbase, hne⟩ + +theorem valuationSubringAt_dominatingIntegralClosurePlace_le + (m : MaximalSpectrum A) + (hbase : ∀ p : P, algebraMap P L p ∈ (algebraMap A L).range) + (hne : dominatingIntegralClosurePrime m hbase ≠ ⊥) : + IsDedekindDomain.HeightOneSpectrum.valuationSubringAtPrime L + (dominatingIntegralClosurePlace m hbase hne) ≤ + dominatingValuationSubring (A := A) (L := L) m := by + let V := dominatingValuationSubring (A := A) (L := L) m + let q := dominatingIntegralClosurePlace m hbase hne + let φ : integralClosure P L →+* V := + integralClosureToDominatingValuationSubring m hbase + rintro x ⟨a, s, hs, rfl⟩ + have hsNotMem : s ∉ q.asIdeal := hs + have hsUnit : IsUnit (φ s) := by + rw [← IsLocalRing.notMem_maximalIdeal] + exact hsNotMem + obtain ⟨u, hu⟩ := hsUnit + let t : V := φ a * ↑(u⁻¹) + have ht : algebraMap (integralClosure P L) L a * + (algebraMap (integralClosure P L) L s)⁻¹ = (t : L) := by + dsimp only [t] + have hφa : ((φ a : V) : L) = + algebraMap (integralClosure P L) L a := rfl + have hφs : ((φ s : V) : L) = + algebraMap (integralClosure P L) L s := rfl + rw [← hφa, ← hφs, ← hu] + change ((φ a : V) : L) * ((((u : V) : L))⁻¹) = + ((φ a : V) : L) * (((↑(u⁻¹) : V) : L)) + congr 1 + exact (map_units_inv V.toSubring.subtype u).symm + rw [ht] + exact t.property + +theorem valuationSubringAt_dominatingIntegralClosurePlace_eq + (m : MaximalSpectrum A) + (hbase : ∀ p : P, algebraMap P L p ∈ (algebraMap A L).range) + (hne : dominatingIntegralClosurePrime m hbase ≠ ⊥) + (hV : dominatingValuationSubring (A := A) (L := L) m ≠ ⊤) : + IsDedekindDomain.HeightOneSpectrum.valuationSubringAtPrime L + (dominatingIntegralClosurePlace m hbase hne) = + dominatingValuationSubring (A := A) (L := L) m := by + exact ValuationSubring.eq_of_le_of_ne_top _ + (valuationSubringAt_dominatingIntegralClosurePlace_le m hbase hne) hV + +theorem dominatingIntegralClosurePlace_valuation_isEquiv + (m : MaximalSpectrum A) + (hbase : ∀ p : P, algebraMap P L p ∈ (algebraMap A L).range) + (hne : dominatingIntegralClosurePrime m hbase ≠ ⊥) + (hV : dominatingValuationSubring (A := A) (L := L) m ≠ ⊤) : + ((dominatingIntegralClosurePlace m hbase hne).valuation L).IsEquiv + (dominatingValuationSubring (A := A) (L := L) m).valuation := by + rw [Valuation.isEquiv_iff_valuationSubring, + ← IsDedekindDomain.HeightOneSpectrum.valuationSubringAtPrime_eq_valuationSubring, + ValuationSubring.valuationSubring_valuation] + exact valuationSubringAt_dominatingIntegralClosurePlace_eq m hbase hne hV + +theorem finitePlaceOrder_dominatingIntegralClosurePlace_pos_of_mem + (m : MaximalSpectrum A) + (hbase : ∀ p : P, algebraMap P L p ∈ (algebraMap A L).range) + (hne : dominatingIntegralClosurePrime m hbase ≠ ⊥) + (hV : dominatingValuationSubring (A := A) (L := L) m ≠ ⊤) + (r : A) (hr : r ∈ m.asIdeal) (hr0 : algebraMap A L r ≠ 0) : + 0 < finitePlaceOrder (dominatingIntegralClosurePlace m hbase hne) + (algebraMap A L r) := by + have hnonunits := + algebraMap_mem_dominatingValuationSubring_nonunits_of_mem + (A := A) (L := L) m r hr + have hVlt : + (dominatingValuationSubring (A := A) (L := L) m).valuation + (algebraMap A L r) < 1 := hnonunits + have hequiv := dominatingIntegralClosurePlace_valuation_isEquiv + m hbase hne hV + have hqlt : + (dominatingIntegralClosurePlace m hbase hne).valuation L + (algebraMap A L r) < 1 := hequiv.lt_one_iff_lt_one.mpr hVlt + have horder := valuation_eq_exp_neg_finitePlaceOrder + (dominatingIntegralClosurePlace m hbase hne) (algebraMap A L r) hr0 + rw [horder, ← exp_zero, exp_lt_exp] at hqlt + omega + +/-- A nonzero integral element at a maximal ideal gives a centered finite place +where both prescribed elements have positive order. -/ +theorem exists_integralClosurePlace_orders_positive + (m : MaximalSpectrum A) + (hbase : ∀ p : P, algebraMap P L p ∈ (algebraMap A L).range) + (r s : A) (hr : r ∈ m.asIdeal) (hs : s ∈ m.asIdeal) + (hr0 : algebraMap A L r ≠ 0) (hs0 : algebraMap A L s ≠ 0) + (b : integralClosure P L) (hb : algebraMap (integralClosure P L) L b = + algebraMap A L r) : + ∃ q : HeightOneSpectrum (integralClosure P L), + HeightOneSpectrum.valuationSubringAtPrime L q = + dominatingValuationSubring (A := A) (L := L) m ∧ + 0 < finitePlaceOrder q (algebraMap A L r) ∧ + 0 < finitePlaceOrder q (algebraMap A L s) := by + let V := dominatingValuationSubring (A := A) (L := L) m + have hnonunits : algebraMap A L r ∈ V.nonunits := + algebraMap_mem_dominatingValuationSubring_nonunits_of_mem m r hr + have hV : V ≠ ⊤ := by + intro htop + exact ((ValuationSubring.eq_top_iff V).mp htop) + ((Valuation.isNontrivial_iff_exists_lt_one V.valuation).2 ⟨_, hr0, hnonunits⟩) + have hb0 : b ≠ 0 := by + intro hzero + apply hr0 + rw [← hb, hzero, map_zero] + have hbMem : b ∈ dominatingIntegralClosurePrime m hbase := by + change integralClosureToDominatingValuationSubring m hbase b ∈ IsLocalRing.maximalIdeal V + apply ValuationSubring.coe_mem_nonunits_iff.mp + change algebraMap (integralClosure P L) L b ∈ V.nonunits + rwa [hb] + have hqne : dominatingIntegralClosurePrime m hbase ≠ ⊥ := by + intro hbot + apply hb0 + simpa only [hbot, Ideal.mem_bot] using hbMem + exact ⟨dominatingIntegralClosurePlace m hbase hqne, + valuationSubringAt_dominatingIntegralClosurePlace_eq m hbase hqne hV, + finitePlaceOrder_dominatingIntegralClosurePlace_pos_of_mem m hbase hqne hV r hr hr0, + finitePlaceOrder_dominatingIntegralClosurePlace_pos_of_mem m hbase hqne hV s hs hs0⟩ + +end IntegralClosure + +end DominatingValuationSubring + +section FiniteExtensionGcdDivisor + +variable (K : Type*) [Field K] [DecidableEq K] [DecidableEq (RatFunc K)] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +local instance (priority := 10) exhaustiveGcdPolynomialAlgebra : + Algebra (Polynomial K) L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap (Polynomial K) (RatFunc K))) + +local instance exhaustiveGcdPolynomialScalarTower : + IsScalarTower (Polynomial K) (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + +local instance exhaustiveGcdFiniteIntegralClosureIsDedekindDomain : + IsDedekindDomain (RatFuncFiniteIntegralClosure K L) := + integralClosure.isDedekindDomain (Polynomial K) (RatFunc K) L + +local instance exhaustiveGcdFiniteIntegralClosureIsFractionRing : + IsFractionRing (RatFuncFiniteIntegralClosure K L) L := + integralClosure.isFractionRing_of_finite_extension (RatFunc K) L + +local instance exhaustiveGcdFiniteIntegralClosureModuleFinite : + Module.Finite (Polynomial K) (RatFuncFiniteIntegralClosure K L) := + Module.IsNoetherian.finite (Polynomial K) + (RatFuncFiniteIntegralClosure K L) + +/-- Common finite support of the two principal divisors on the exhaustive +place type. -/ +noncomputable def finiteExtensionGcdSupport (x y : L) : + Finset (FiniteExtensionPlace K L) := by + classical + exact (finiteExtensionPrincipalDivisor K L x).support ∪ + (finiteExtensionPrincipalDivisor K L y).support + +/-- Positive local gcd multiplicity of two nonzero rational functions. -/ +def finiteExtensionGcdMultiplicity (x y : L) + (v : FiniteExtensionPlace K L) : ℕ := + Int.toNat (min + (finiteExtensionPrincipalDivisor K L x v) + (finiteExtensionPrincipalDivisor K L y v)) + +/-- Degree of the positive gcd divisor on the exhaustive place type. -/ +def finiteExtensionGcdWeightedDegree (x y : L) : ℕ := + ∑ v ∈ finiteExtensionGcdSupport K L x y, + finiteExtensionGcdMultiplicity K L x y v * + finiteExtensionPlaceDegree K L v + +omit [DecidableEq K] in +/-- On a finite place, the exhaustive principal-divisor coefficient is the +normalized order computed directly in `L`. -/ +theorem finiteExtensionPrincipalDivisor_inl_eq_finitePlaceOrder + (x : L) (q : FiniteExtensionFinitePlace K L) : + finiteExtensionPrincipalDivisor K L x (.inl q) = + finitePlaceOrder q x := by + classical + rw [finiteExtensionPrincipalDivisor_inl] + have h := fractionRingAlgEquiv_finitePlaceOrder_eq + (L := L) q ((ratFuncFiniteIntegralClosureFractionRingEquiv K L).symm x) + simpa [ratFuncFiniteIntegralClosureFractionRingEquiv] using h.symm + +theorem finiteExtensionPlaceDegree_inl_pos + (q : FiniteExtensionFinitePlace K L) : + 0 < finiteExtensionPlaceDegree K L (.inl q) := by + rw [finiteExtensionPlaceDegree] + apply Nat.mul_pos + · exact Ideal.inertiaDeg_pos q.asIdeal (Polynomial K) + · exact (finitePlaceNormalizedPrime + (HeightOneSpectrum.under (Polynomial K) q)).property.1.irreducible.natDegree_pos + +omit [DecidableEq K] in +theorem inl_mem_finiteExtensionGcdSupport_of_orders_positive + (x y : L) (q : FiniteExtensionFinitePlace K L) + (hxpos : 0 < finitePlaceOrder q x) : + (.inl q : FiniteExtensionPlace K L) ∈ + finiteExtensionGcdSupport K L x y := by + classical + rw [finiteExtensionGcdSupport] + apply Finset.mem_union_left + rw [Finsupp.mem_support_iff, + finiteExtensionPrincipalDivisor_inl_eq_finitePlaceOrder K L x q] + omega + +theorem one_le_finiteExtensionGcdMultiplicity_mul_degree_inl_of_orders_positive + (x y : L) (q : FiniteExtensionFinitePlace K L) + (hxpos : 0 < finitePlaceOrder q x) + (hypos : 0 < finitePlaceOrder q y) : + 1 ≤ finiteExtensionGcdMultiplicity K L x y (.inl q) * + finiteExtensionPlaceDegree K L (.inl q) := by + have hxD : 0 < finiteExtensionPrincipalDivisor K L x (.inl q) := by + rw [finiteExtensionPrincipalDivisor_inl_eq_finitePlaceOrder K L x q] + exact hxpos + have hyD : 0 < finiteExtensionPrincipalDivisor K L y (.inl q) := by + rw [finiteExtensionPrincipalDivisor_inl_eq_finitePlaceOrder K L y q] + exact hypos + have hmult : 0 < finiteExtensionGcdMultiplicity K L x y (.inl q) := by + unfold finiteExtensionGcdMultiplicity + omega + exact Nat.mul_pos hmult (finiteExtensionPlaceDegree_inl_pos K L q) + +end FiniteExtensionGcdDivisor + +section PlaneCurveExhaustiveFinitePlaces + +variable {K : Type*} [Field K] +variable {f : MvPolynomial (Fin 2) K} + +/-- The selected polynomial parameter belongs to the affine coordinate ring +inside the curve's function field. -/ +theorem polynomial_algebraMap_mem_planeCurveCoordinateRing_range + (hf : Irreducible f) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (P : Polynomial K) : + letI := planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + letI := planeCurveFirstCoordinateRatFuncAlgebra f hx + letI : Algebra (Polynomial K) (PlaneCurveFunctionField f) := + RingHom.toAlgebra + ((algebraMap (RatFunc K) (PlaneCurveFunctionField f)).comp + (algebraMap (Polynomial K) (RatFunc K))) + algebraMap (Polynomial K) (PlaneCurveFunctionField f) P ∈ + (algebraMap (PlaneCurveCoordinateRing f) + (PlaneCurveFunctionField f)).range := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let : Algebra (RatFunc K) (PlaneCurveFunctionField f) := + planeCurveFirstCoordinateRatFuncAlgebra f hx + let : Algebra (Polynomial K) (PlaneCurveFunctionField f) := + RingHom.toAlgebra + ((algebraMap (RatFunc K) (PlaneCurveFunctionField f)).comp + (algebraMap (Polynomial K) (RatFunc K))) + refine ⟨planeCurveQuotientMap f (polynomialInFirstCoordinate P), ?_⟩ + change algebraMap (PlaneCurveCoordinateRing f) (PlaneCurveFunctionField f) + (planeCurveQuotientMap f (polynomialInFirstCoordinate P)) = + algebraMap (Polynomial K) (PlaneCurveFunctionField f) P + rw [show algebraMap (Polynomial K) (PlaneCurveFunctionField f) P = + algebraMap (RatFunc K) (PlaneCurveFunctionField f) + (algebraMap (Polynomial K) (RatFunc K) P) by rfl] + change ((algebraMap (PlaneCurveCoordinateRing f) + (PlaneCurveFunctionField f)).comp (planeCurveQuotientMap f)) + (polynomialInFirstCoordinate P) = _ + rw [← eval₂_planeCurveFunction f] + have hcoordinates : planeCurveFunction f = + ![planeCurveFunction f 0, planeCurveFunction f 1] := by + funext i + fin_cases i <;> rfl + rw [hcoordinates] + change MvPolynomial.eval₂ (algebraMap K (PlaneCurveFunctionField f)) + ![planeCurveFunction f 0, planeCurveFunction f 1] + (polynomialInFirstCoordinate P) = _ + rw [eval₂_polynomialInFirstCoordinate] + have hcomp := congrArg + (fun h : Polynomial K →+* PlaneCurveFunctionField f => h P) + (ratFuncSpecialization_comp_polynomial_algebraMap + (planeCurveFunction f 0) hx) + exact hcomp.symm + +private theorem map_power_sub_one {R S : Type*} [Ring R] [Ring S] + (φ : R →+* S) (x : R) (y : S) (h : φ x = y) (n : ℕ) : + φ (x ^ n - 1) = y ^ n - 1 := by + rw [map_sub, map_pow, map_one, h] + +variable [Fintype K] [DecidableEq K] + +/-- Every rational torsion point produces an actual finite place of the +`K[X]` integral-closure model at which both powered coordinate functions have +positive order. The valuation-subring equality records its affine center and +will make the choice injective. -/ +theorem exists_torsionPoint_exhaustiveFinitePlace_orders_positive + (hf : Irreducible f) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (firstOrder secondOrder : ℕ) + (hfirstNonzero : planeCurveFunction f 0 ^ firstOrder - 1 ≠ 0) + (hsecondNonzero : planeCurveFunction f 1 ^ secondOrder - 1 ≠ 0) + (z : TorusCurveTorsionPoint f firstOrder secondOrder) : + let := planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let := planeCurveFirstCoordinateRatFuncAlgebra f hx + let : Algebra (Polynomial K) (PlaneCurveFunctionField f) := + RingHom.toAlgebra + ((algebraMap (RatFunc K) (PlaneCurveFunctionField f)).comp + (algebraMap (Polynomial K) (RatFunc K))) + let : IsScalarTower (Polynomial K) (RatFunc K) + (PlaneCurveFunctionField f) := + IsScalarTower.of_algebraMap_eq' rfl + let : FiniteDimensional (RatFunc K) (PlaneCurveFunctionField f) := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : Algebra.IsSeparable (RatFunc K) (PlaneCurveFunctionField f) := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : IsDedekindDomain + (integralClosure (Polynomial K) (PlaneCurveFunctionField f)) := + integralClosure.isDedekindDomain (Polynomial K) (RatFunc K) + (PlaneCurveFunctionField f) + let : IsFractionRing + (integralClosure (Polynomial K) (PlaneCurveFunctionField f)) + (PlaneCurveFunctionField f) := + integralClosure.isFractionRing_of_finite_extension (RatFunc K) + (PlaneCurveFunctionField f) + ∃ q : HeightOneSpectrum + (integralClosure (Polynomial K) (PlaneCurveFunctionField f)), + IsDedekindDomain.HeightOneSpectrum.valuationSubringAtPrime + (PlaneCurveFunctionField f) q = + dominatingValuationSubring + (torsionPointMaximalIdeal f firstOrder secondOrder z) ∧ + 0 < finitePlaceOrder q + (planeCurveFunction f 0 ^ firstOrder - 1) ∧ + 0 < finitePlaceOrder q + (planeCurveFunction f 1 ^ secondOrder - 1) := by + intro domain hx ratFuncAlgebra polynomialAlgebra scalarTower finiteDimension separable + dedekind fraction + let A := PlaneCurveCoordinateRing f + let E := PlaneCurveFunctionField f + let B := integralClosure (Polynomial K) E + let m := torsionPointMaximalIdeal f firstOrder secondOrder z + have hbase : ∀ P : Polynomial K, + algebraMap (Polynomial K) E P ∈ (algebraMap A E).range := + polynomial_algebraMap_mem_planeCurveCoordinateRing_range hf hpartialSecond + let rfirst : A := planeCurveCoordinate f 0 ^ firstOrder - 1 + let rsecond : A := planeCurveCoordinate f 1 ^ secondOrder - 1 + let Pfirst : Polynomial K := Polynomial.X ^ firstOrder - 1 + let bfirst : B := algebraMap (Polynomial K) B Pfirst + have hrfirst : rfirst ∈ m.asIdeal := + first_torsionFunction_mem_torsionPointMaximalIdeal + f firstOrder secondOrder z + have hrsecond : rsecond ∈ m.asIdeal := + second_torsionFunction_mem_torsionPointMaximalIdeal + f firstOrder secondOrder z + have hrfirstMap : algebraMap A E rfirst = + planeCurveFunction f 0 ^ firstOrder - 1 := by + simp only [rfirst, map_sub, map_pow, map_one] + rfl + have hrsecondMap : algebraMap A E rsecond = + planeCurveFunction f 1 ^ secondOrder - 1 := by + simp only [rsecond, map_sub, map_pow, map_one] + rfl + have hPfirstMap : algebraMap (Polynomial K) E Pfirst = + planeCurveFunction f 0 ^ firstOrder - 1 := by + exact map_power_sub_one (algebraMap (Polynomial K) E) Polynomial.X + (planeCurveFunction f 0) (planeCurveFirstCoordinateRatFuncAlgebra_X f hx) firstOrder + have hbfirstMap : algebraMap B E bfirst = + planeCurveFunction f 0 ^ firstOrder - 1 := by + rw [show algebraMap B E bfirst = + algebraMap (Polynomial K) E Pfirst by + exact IsScalarTower.algebraMap_apply (Polynomial K) B E Pfirst] + exact hPfirstMap + have hrfirstMap0 : algebraMap A E rfirst ≠ 0 := by + rw [hrfirstMap] + exact hfirstNonzero + have hrsecondMap0 : algebraMap A E rsecond ≠ 0 := by + rw [hrsecondMap] + exact hsecondNonzero + obtain ⟨q, hq, hfirst, hsecond⟩ := exists_integralClosurePlace_orders_positive + m hbase rfirst rsecond hrfirst hrsecond hrfirstMap0 hrsecondMap0 bfirst + (hbfirstMap.trans hrfirstMap.symm) + exact ⟨q, hq, hrfirstMap ▸ hfirst, hrsecondMap ▸ hsecond⟩ + +/-- The finite place in the exhaustive `K[X]`-integral-closure model selected +above a rational torsion point. -/ +def torsionPointExhaustiveFinitePlace + (hf : Irreducible f) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (firstOrder secondOrder : ℕ) + (hfirstNonzero : planeCurveFunction f 0 ^ firstOrder - 1 ≠ 0) + (hsecondNonzero : planeCurveFunction f 1 ^ secondOrder - 1 ≠ 0) + (z : TorusCurveTorsionPoint f firstOrder secondOrder) : + letI := planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + letI := planeCurveFirstCoordinateRatFuncAlgebra f hx + letI : Algebra (Polynomial K) (PlaneCurveFunctionField f) := + RingHom.toAlgebra + ((algebraMap (RatFunc K) (PlaneCurveFunctionField f)).comp + (algebraMap (Polynomial K) (RatFunc K))) + letI : IsScalarTower (Polynomial K) (RatFunc K) + (PlaneCurveFunctionField f) := + IsScalarTower.of_algebraMap_eq' rfl + letI : FiniteDimensional (RatFunc K) (PlaneCurveFunctionField f) := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + letI : Algebra.IsSeparable (RatFunc K) (PlaneCurveFunctionField f) := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + FiniteExtensionFinitePlace K (PlaneCurveFunctionField f) := by + exact Classical.choose + (exists_torsionPoint_exhaustiveFinitePlace_orders_positive + hf hpartialSecond firstOrder secondOrder + hfirstNonzero hsecondNonzero z) + +/-- The selected exhaustive finite place is centered at the given affine +torsion point, and both powered coordinate functions have positive order +there. -/ +theorem torsionPointExhaustiveFinitePlace_spec + (hf : Irreducible f) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (firstOrder secondOrder : ℕ) + (hfirstNonzero : planeCurveFunction f 0 ^ firstOrder - 1 ≠ 0) + (hsecondNonzero : planeCurveFunction f 1 ^ secondOrder - 1 ≠ 0) + (z : TorusCurveTorsionPoint f firstOrder secondOrder) : + letI := planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + letI := planeCurveFirstCoordinateRatFuncAlgebra f hx + letI : Algebra (Polynomial K) (PlaneCurveFunctionField f) := + RingHom.toAlgebra + ((algebraMap (RatFunc K) (PlaneCurveFunctionField f)).comp + (algebraMap (Polynomial K) (RatFunc K))) + letI : IsScalarTower (Polynomial K) (RatFunc K) + (PlaneCurveFunctionField f) := + IsScalarTower.of_algebraMap_eq' rfl + letI : FiniteDimensional (RatFunc K) (PlaneCurveFunctionField f) := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + letI : Algebra.IsSeparable (RatFunc K) (PlaneCurveFunctionField f) := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + IsDedekindDomain.HeightOneSpectrum.valuationSubringAtPrime + (PlaneCurveFunctionField f) + (torsionPointExhaustiveFinitePlace hf hpartialSecond + firstOrder secondOrder hfirstNonzero hsecondNonzero z) = + dominatingValuationSubring + (torsionPointMaximalIdeal f firstOrder secondOrder z) ∧ + 0 < finitePlaceOrder + (torsionPointExhaustiveFinitePlace hf hpartialSecond + firstOrder secondOrder hfirstNonzero hsecondNonzero z) + (planeCurveFunction f 0 ^ firstOrder - 1) ∧ + 0 < finitePlaceOrder + (torsionPointExhaustiveFinitePlace hf hpartialSecond + firstOrder secondOrder hfirstNonzero hsecondNonzero z) + (planeCurveFunction f 1 ^ secondOrder - 1) := by + exact Classical.choose_spec + (exists_torsionPoint_exhaustiveFinitePlace_orders_positive + hf hpartialSecond firstOrder secondOrder + hfirstNonzero hsecondNonzero z) + +/-- Distinct rational torsion points have distinct selected finite places in +the exhaustive `K[X]`-model. -/ +theorem torsionPointExhaustiveFinitePlace_injective + (hf : Irreducible f) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (firstOrder secondOrder : ℕ) + (hfirstNonzero : planeCurveFunction f 0 ^ firstOrder - 1 ≠ 0) + (hsecondNonzero : planeCurveFunction f 1 ^ secondOrder - 1 ≠ 0) : + letI := planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + letI := planeCurveFirstCoordinateRatFuncAlgebra f hx + letI : Algebra (Polynomial K) (PlaneCurveFunctionField f) := + RingHom.toAlgebra + ((algebraMap (RatFunc K) (PlaneCurveFunctionField f)).comp + (algebraMap (Polynomial K) (RatFunc K))) + letI : IsScalarTower (Polynomial K) (RatFunc K) + (PlaneCurveFunctionField f) := + IsScalarTower.of_algebraMap_eq' rfl + letI : FiniteDimensional (RatFunc K) (PlaneCurveFunctionField f) := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + letI : Algebra.IsSeparable (RatFunc K) (PlaneCurveFunctionField f) := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + Function.Injective + (torsionPointExhaustiveFinitePlace hf hpartialSecond + firstOrder secondOrder hfirstNonzero hsecondNonzero) := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let : Algebra (RatFunc K) (PlaneCurveFunctionField f) := + planeCurveFirstCoordinateRatFuncAlgebra f hx + let : Algebra (Polynomial K) (PlaneCurveFunctionField f) := + RingHom.toAlgebra + ((algebraMap (RatFunc K) (PlaneCurveFunctionField f)).comp + (algebraMap (Polynomial K) (RatFunc K))) + let : IsScalarTower (Polynomial K) (RatFunc K) + (PlaneCurveFunctionField f) := + IsScalarTower.of_algebraMap_eq' rfl + let : FiniteDimensional (RatFunc K) (PlaneCurveFunctionField f) := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : Algebra.IsSeparable (RatFunc K) (PlaneCurveFunctionField f) := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + change Function.Injective + (torsionPointExhaustiveFinitePlace hf hpartialSecond + firstOrder secondOrder hfirstNonzero hsecondNonzero) + intro z w hzw + apply torsionPointMaximalIdeal_injective f firstOrder secondOrder + apply MaximalSpectrum.ext + apply pointIdeal_eq_of_dominatingValuationSubring_eq + (A := PlaneCurveCoordinateRing f) + (L := PlaneCurveFunctionField f) + calc + dominatingValuationSubring + (torsionPointMaximalIdeal f firstOrder secondOrder z) = + IsDedekindDomain.HeightOneSpectrum.valuationSubringAtPrime + (PlaneCurveFunctionField f) + (torsionPointExhaustiveFinitePlace hf hpartialSecond + firstOrder secondOrder hfirstNonzero hsecondNonzero z) := + (torsionPointExhaustiveFinitePlace_spec hf hpartialSecond + firstOrder secondOrder hfirstNonzero hsecondNonzero z).1.symm + _ = IsDedekindDomain.HeightOneSpectrum.valuationSubringAtPrime + (PlaneCurveFunctionField f) + (torsionPointExhaustiveFinitePlace hf hpartialSecond + firstOrder secondOrder hfirstNonzero hsecondNonzero w) := by + rw [hzw] + _ = dominatingValuationSubring + (torsionPointMaximalIdeal f firstOrder secondOrder w) := + (torsionPointExhaustiveFinitePlace_spec hf hpartialSecond + firstOrder secondOrder hfirstNonzero hsecondNonzero w).1 + +/-- Degree of the positive gcd divisor of the two powered coordinate +functions, taken on the exhaustive finite-and-infinite place model attached to +the first coordinate. -/ +noncomputable def planeCurveExhaustiveTorsionGcdWeightedDegree + (hf : Irreducible f) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (firstOrder secondOrder : ℕ) : ℕ := by + letI : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + letI : DecidableEq (RatFunc K) := Classical.decEq (RatFunc K) + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + letI : Algebra (RatFunc K) (PlaneCurveFunctionField f) := + planeCurveFirstCoordinateRatFuncAlgebra f hx + letI : FiniteDimensional (RatFunc K) (PlaneCurveFunctionField f) := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + letI : Algebra.IsSeparable (RatFunc K) (PlaneCurveFunctionField f) := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + exact finiteExtensionGcdWeightedDegree K (PlaneCurveFunctionField f) + (planeCurveFunction f 0 ^ firstOrder - 1) + (planeCurveFunction f 1 ^ secondOrder - 1) + +/-- Rational torsion points inject into the positive gcd divisor on the +exhaustive place model. The residue-degree weight of every selected place is +positive, so each point contributes at least one to its weighted degree. -/ +theorem torsionPoint_card_le_planeCurveExhaustiveTorsionGcdWeightedDegree + (hf : Irreducible f) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (firstOrder secondOrder : ℕ) + (hfirstNonzero : planeCurveFunction f 0 ^ firstOrder - 1 ≠ 0) + (hsecondNonzero : planeCurveFunction f 1 ^ secondOrder - 1 ≠ 0) : + Fintype.card (TorusCurveTorsionPoint f firstOrder secondOrder) ≤ + planeCurveExhaustiveTorsionGcdWeightedDegree + hf hpartialSecond firstOrder secondOrder := by + classical + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let : DecidableEq (RatFunc K) := Classical.decEq (RatFunc K) + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let : Algebra (RatFunc K) (PlaneCurveFunctionField f) := + planeCurveFirstCoordinateRatFuncAlgebra f hx + let : Algebra (Polynomial K) (PlaneCurveFunctionField f) := + RingHom.toAlgebra + ((algebraMap (RatFunc K) (PlaneCurveFunctionField f)).comp + (algebraMap (Polynomial K) (RatFunc K))) + let : IsScalarTower (Polynomial K) (RatFunc K) + (PlaneCurveFunctionField f) := + IsScalarTower.of_algebraMap_eq' rfl + let : FiniteDimensional (RatFunc K) (PlaneCurveFunctionField f) := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : Algebra.IsSeparable (RatFunc K) (PlaneCurveFunctionField f) := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : DecidableEq (FiniteExtensionPlace K (PlaneCurveFunctionField f)) := + Classical.decEq _ + let x : PlaneCurveFunctionField f := + planeCurveFunction f 0 ^ firstOrder - 1 + let y : PlaneCurveFunctionField f := + planeCurveFunction f 1 ^ secondOrder - 1 + let finitePlace : TorusCurveTorsionPoint f firstOrder secondOrder → + FiniteExtensionFinitePlace K (PlaneCurveFunctionField f) := + torsionPointExhaustiveFinitePlace hf hpartialSecond + firstOrder secondOrder hfirstNonzero hsecondNonzero + let place : TorusCurveTorsionPoint f firstOrder secondOrder → + FiniteExtensionPlace K (PlaneCurveFunctionField f) := + fun z => .inl (finitePlace z) + have hFinitePlaceInjective : Function.Injective finitePlace := + torsionPointExhaustiveFinitePlace_injective hf hpartialSecond + firstOrder secondOrder hfirstNonzero hsecondNonzero + have hPlaceInjective : Function.Injective place := by + intro z w hzw + apply hFinitePlaceInjective + exact Sum.inl_injective hzw + have hImageSubset : Finset.univ.image place ⊆ + finiteExtensionGcdSupport K (PlaneCurveFunctionField f) x y := by + intro v hv + obtain ⟨z, -, rfl⟩ := Finset.mem_image.mp hv + have hz := torsionPointExhaustiveFinitePlace_spec hf hpartialSecond + firstOrder secondOrder hfirstNonzero hsecondNonzero z + exact inl_mem_finiteExtensionGcdSupport_of_orders_positive + K (PlaneCurveFunctionField f) x y (finitePlace z) hz.2.1 + calc + Fintype.card (TorusCurveTorsionPoint f firstOrder secondOrder) = + (Finset.univ.image place).card := by + rw [Finset.card_image_of_injective _ hPlaceInjective, + Finset.card_univ] + _ = ∑ v ∈ Finset.univ.image place, 1 := by simp + _ ≤ ∑ v ∈ Finset.univ.image place, + finiteExtensionGcdMultiplicity K (PlaneCurveFunctionField f) x y v * + finiteExtensionPlaceDegree K (PlaneCurveFunctionField f) v := by + apply Finset.sum_le_sum + intro v hv + obtain ⟨z, -, rfl⟩ := Finset.mem_image.mp hv + have hz := torsionPointExhaustiveFinitePlace_spec hf hpartialSecond + firstOrder secondOrder hfirstNonzero hsecondNonzero z + exact + one_le_finiteExtensionGcdMultiplicity_mul_degree_inl_of_orders_positive + K (PlaneCurveFunctionField f) x y (finitePlace z) hz.2.1 hz.2.2 + _ ≤ ∑ v ∈ finiteExtensionGcdSupport K (PlaneCurveFunctionField f) x y, + finiteExtensionGcdMultiplicity K (PlaneCurveFunctionField f) x y v * + finiteExtensionPlaceDegree K (PlaneCurveFunctionField f) v := by + exact Finset.sum_le_sum_of_subset_of_nonneg hImageSubset (by omega) + _ = planeCurveExhaustiveTorsionGcdWeightedDegree + hf hpartialSecond firstOrder secondOrder := by + rfl + +end PlaneCurveExhaustiveFinitePlaces + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/TorsionGcdDivisorBound.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/TorsionGcdDivisorBound.lean new file mode 100644 index 0000000000..ba00281ead --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/TorsionGcdDivisorBound.lean @@ -0,0 +1,315 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.TorsionPointNormalization + +/-! +# Torsion points contribute to the normalization gcd divisor + +This file upgrades the pointwise normalization result to a finite divisor +inequality. For any Dedekind normalization model of the plane-curve function +field, one branch is chosen over each rational torsion point. Distinct points +give distinct branches, both torsion functions have positive order there, and +therefore the number of torsion points is bounded by the sum of the local gcd +multiplicities. +-/ + +@[expose] public section + +namespace BGS.CorvajaZannier + +noncomputable section + +open IsDedekindDomain + +variable {K : Type*} [Field K] [Fintype K] [DecidableEq K] +variable {f : MvPolynomial (Fin 2) K} +variable [IsDomain (PlaneCurveCoordinateRing f)] + +/-- Choose a branch in an arbitrary Dedekind integral-closure model above the +maximal ideal defined by a torsion point. -/ +def liftedTorsionPointNormalizationBranch + {B : Type*} [CommRing B] [IsDedekindDomain B] + [Algebra (PlaneCurveCoordinateRing f) B] + [Algebra B (PlaneCurveFunctionField f)] + [IsScalarTower (PlaneCurveCoordinateRing f) B (PlaneCurveFunctionField f)] + [Algebra.IsIntegral (PlaneCurveCoordinateRing f) B] + [FaithfulSMul (PlaneCurveCoordinateRing f) B] + [IsIntegralClosure B (PlaneCurveCoordinateRing f) (PlaneCurveFunctionField f)] + (firstOrder secondOrder : ℕ) + (z : TorusCurveTorsionPoint f firstOrder secondOrder) : + MaximalSpectrum B := by + let hex := Ideal.exists_maximal_ideal_liesOver_of_isIntegral + (S := B) (torsionPointMaximalIdeal f firstOrder secondOrder z).asIdeal + exact ⟨Classical.choose hex, (Classical.choose_spec hex).1⟩ + +omit [IsDomain (PlaneCurveCoordinateRing f)] in +theorem liftedTorsionPointNormalizationBranch_liesOver + {B : Type*} [CommRing B] [IsDedekindDomain B] + [Algebra (PlaneCurveCoordinateRing f) B] + [Algebra B (PlaneCurveFunctionField f)] + [IsScalarTower (PlaneCurveCoordinateRing f) B (PlaneCurveFunctionField f)] + [Algebra.IsIntegral (PlaneCurveCoordinateRing f) B] + [FaithfulSMul (PlaneCurveCoordinateRing f) B] + [IsIntegralClosure B (PlaneCurveCoordinateRing f) (PlaneCurveFunctionField f)] + (firstOrder secondOrder : ℕ) + (z : TorusCurveTorsionPoint f firstOrder secondOrder) : + (liftedTorsionPointNormalizationBranch (f := f) (B := B) + firstOrder secondOrder z).asIdeal.LiesOver + (torsionPointMaximalIdeal f firstOrder secondOrder z).asIdeal := by + let hex := Ideal.exists_maximal_ideal_liesOver_of_isIntegral + (S := B) (torsionPointMaximalIdeal f firstOrder secondOrder z).asIdeal + exact (Classical.choose_spec hex).2 + +omit [IsDomain (PlaneCurveCoordinateRing f)] in +/-- Chosen branches above distinct torsion points are distinct because their +contractions to the affine coordinate ring are distinct. -/ +theorem liftedTorsionPointNormalizationBranch_injective + {B : Type*} [CommRing B] [IsDedekindDomain B] + [Algebra (PlaneCurveCoordinateRing f) B] + [Algebra B (PlaneCurveFunctionField f)] + [IsScalarTower (PlaneCurveCoordinateRing f) B (PlaneCurveFunctionField f)] + [Algebra.IsIntegral (PlaneCurveCoordinateRing f) B] + [FaithfulSMul (PlaneCurveCoordinateRing f) B] + [IsIntegralClosure B (PlaneCurveCoordinateRing f) (PlaneCurveFunctionField f)] + (firstOrder secondOrder : ℕ) : + Function.Injective + (liftedTorsionPointNormalizationBranch (f := f) (B := B) + firstOrder secondOrder) := by + intro z w hzw + apply torsionPointMaximalIdeal_injective f firstOrder secondOrder + apply MaximalSpectrum.ext + let hz : + (liftedTorsionPointNormalizationBranch (f := f) (B := B) + firstOrder secondOrder z).asIdeal.LiesOver + (torsionPointMaximalIdeal f firstOrder secondOrder z).asIdeal := + liftedTorsionPointNormalizationBranch_liesOver (f := f) firstOrder secondOrder z + let hw : + (liftedTorsionPointNormalizationBranch (f := f) (B := B) + firstOrder secondOrder w).asIdeal.LiesOver + (torsionPointMaximalIdeal f firstOrder secondOrder w).asIdeal := + liftedTorsionPointNormalizationBranch_liesOver (f := f) firstOrder secondOrder w + calc + (torsionPointMaximalIdeal f firstOrder secondOrder z).asIdeal = + (liftedTorsionPointNormalizationBranch (f := f) (B := B) + firstOrder secondOrder z).asIdeal.under (PlaneCurveCoordinateRing f) := + Ideal.over_def + (P := (liftedTorsionPointNormalizationBranch (f := f) (B := B) + firstOrder secondOrder z).asIdeal) + (p := (torsionPointMaximalIdeal f firstOrder secondOrder z).asIdeal) + _ = (liftedTorsionPointNormalizationBranch (f := f) (B := B) + firstOrder secondOrder w).asIdeal.under (PlaneCurveCoordinateRing f) := by + rw [hzw] + _ = (torsionPointMaximalIdeal f firstOrder secondOrder w).asIdeal := + (Ideal.over_def + (P := (liftedTorsionPointNormalizationBranch (f := f) (B := B) + firstOrder secondOrder w).asIdeal) + (p := (torsionPointMaximalIdeal f firstOrder secondOrder w).asIdeal)).symm + +/-- The finite place selected above a torsion point. It is obtained from the +positive-order branch theorem, so its defining prime is the chosen branch. -/ +def torsionPointFinitePlace + {B : Type*} [CommRing B] [IsDedekindDomain B] + [Algebra (PlaneCurveCoordinateRing f) B] + [Algebra B (PlaneCurveFunctionField f)] + [IsScalarTower (PlaneCurveCoordinateRing f) B (PlaneCurveFunctionField f)] + [Algebra.IsIntegral (PlaneCurveCoordinateRing f) B] + [FaithfulSMul (PlaneCurveCoordinateRing f) B] + [IsIntegralClosure B (PlaneCurveCoordinateRing f) (PlaneCurveFunctionField f)] + (firstOrder secondOrder : ℕ) + (hfirstNonzero : planeCurveFunction f 0 ^ firstOrder - 1 ≠ 0) + (hsecondNonzero : planeCurveFunction f 1 ^ secondOrder - 1 ≠ 0) + (z : TorusCurveTorsionPoint f firstOrder secondOrder) : + HeightOneSpectrum B := + Classical.choose (liftedNormalizationBranch_torsion_orders_positive + f firstOrder secondOrder hfirstNonzero hsecondNonzero z + (liftedTorsionPointNormalizationBranch (f := f) (B := B) + firstOrder secondOrder z) + (liftedTorsionPointNormalizationBranch_liesOver (f := f) firstOrder secondOrder z)) + +theorem torsionPointFinitePlace_spec + {B : Type*} [CommRing B] [IsDedekindDomain B] + [Algebra (PlaneCurveCoordinateRing f) B] + [Algebra B (PlaneCurveFunctionField f)] + [IsScalarTower (PlaneCurveCoordinateRing f) B (PlaneCurveFunctionField f)] + [Algebra.IsIntegral (PlaneCurveCoordinateRing f) B] + [FaithfulSMul (PlaneCurveCoordinateRing f) B] + [IsIntegralClosure B (PlaneCurveCoordinateRing f) (PlaneCurveFunctionField f)] + (firstOrder secondOrder : ℕ) + (hfirstNonzero : planeCurveFunction f 0 ^ firstOrder - 1 ≠ 0) + (hsecondNonzero : planeCurveFunction f 1 ^ secondOrder - 1 ≠ 0) + (z : TorusCurveTorsionPoint f firstOrder secondOrder) : + (torsionPointFinitePlace (B := B) firstOrder secondOrder + hfirstNonzero hsecondNonzero z).asIdeal = + (liftedTorsionPointNormalizationBranch (f := f) (B := B) + firstOrder secondOrder z).asIdeal ∧ + (1 : ℤ) ≤ finitePlaceOrder + (torsionPointFinitePlace (B := B) firstOrder secondOrder + hfirstNonzero hsecondNonzero z) + (planeCurveFunction f 0 ^ firstOrder - 1) ∧ + (1 : ℤ) ≤ finitePlaceOrder + (torsionPointFinitePlace (B := B) firstOrder secondOrder + hfirstNonzero hsecondNonzero z) + (planeCurveFunction f 1 ^ secondOrder - 1) ∧ + (1 : ℤ) ≤ min + (finitePlaceOrder + (torsionPointFinitePlace (B := B) firstOrder secondOrder + hfirstNonzero hsecondNonzero z) + (planeCurveFunction f 0 ^ firstOrder - 1)) + (finitePlaceOrder + (torsionPointFinitePlace (B := B) firstOrder secondOrder + hfirstNonzero hsecondNonzero z) + (planeCurveFunction f 1 ^ secondOrder - 1)) := + Classical.choose_spec (liftedNormalizationBranch_torsion_orders_positive + f firstOrder secondOrder hfirstNonzero hsecondNonzero z + (liftedTorsionPointNormalizationBranch (f := f) (B := B) + firstOrder secondOrder z) + (liftedTorsionPointNormalizationBranch_liesOver (f := f) firstOrder secondOrder z)) + +theorem torsionPointFinitePlace_injective + {B : Type*} [CommRing B] [IsDedekindDomain B] + [Algebra (PlaneCurveCoordinateRing f) B] + [Algebra B (PlaneCurveFunctionField f)] + [IsScalarTower (PlaneCurveCoordinateRing f) B (PlaneCurveFunctionField f)] + [Algebra.IsIntegral (PlaneCurveCoordinateRing f) B] + [FaithfulSMul (PlaneCurveCoordinateRing f) B] + [IsIntegralClosure B (PlaneCurveCoordinateRing f) (PlaneCurveFunctionField f)] + (firstOrder secondOrder : ℕ) + (hfirstNonzero : planeCurveFunction f 0 ^ firstOrder - 1 ≠ 0) + (hsecondNonzero : planeCurveFunction f 1 ^ secondOrder - 1 ≠ 0) : + Function.Injective (torsionPointFinitePlace (B := B) firstOrder secondOrder + hfirstNonzero hsecondNonzero) := by + intro z w hzw + apply liftedTorsionPointNormalizationBranch_injective + (f := f) (B := B) firstOrder secondOrder + apply MaximalSpectrum.ext + rw [← (torsionPointFinitePlace_spec (f := f) (B := B) firstOrder secondOrder + hfirstNonzero hsecondNonzero z).1, + ← (torsionPointFinitePlace_spec (f := f) (B := B) firstOrder secondOrder + hfirstNonzero hsecondNonzero w).1, + hzw] + +/-- The finite support containing every chosen torsion place. -/ +def torsionGcdPlaceSupport + {B : Type*} [CommRing B] [IsDedekindDomain B] + [Algebra B (PlaneCurveFunctionField f)] + [IsFractionRing B (PlaneCurveFunctionField f)] + (firstOrder secondOrder : ℕ) : Finset (HeightOneSpectrum B) := by + classical + exact (finitePrincipalDivisor (R := B) + (planeCurveFunction f 0 ^ firstOrder - 1)).support ∪ + (finitePrincipalDivisor (R := B) + (planeCurveFunction f 1 ^ secondOrder - 1)).support + +theorem torsionPointFinitePlace_mem_torsionGcdPlaceSupport + {B : Type*} [CommRing B] [IsDedekindDomain B] + [Algebra (PlaneCurveCoordinateRing f) B] + [Algebra B (PlaneCurveFunctionField f)] + [IsScalarTower (PlaneCurveCoordinateRing f) B (PlaneCurveFunctionField f)] + [Algebra.IsIntegral (PlaneCurveCoordinateRing f) B] + [FaithfulSMul (PlaneCurveCoordinateRing f) B] + [IsIntegralClosure B (PlaneCurveCoordinateRing f) (PlaneCurveFunctionField f)] + [IsFractionRing B (PlaneCurveFunctionField f)] + (firstOrder secondOrder : ℕ) + (hfirstNonzero : planeCurveFunction f 0 ^ firstOrder - 1 ≠ 0) + (hsecondNonzero : planeCurveFunction f 1 ^ secondOrder - 1 ≠ 0) + (z : TorusCurveTorsionPoint f firstOrder secondOrder) : + torsionPointFinitePlace (B := B) firstOrder secondOrder + hfirstNonzero hsecondNonzero z ∈ + torsionGcdPlaceSupport (f := f) (B := B) firstOrder secondOrder := by + classical + apply Finset.mem_union_left + rw [Finsupp.mem_support_iff, finitePrincipalDivisor_apply] + have h := (torsionPointFinitePlace_spec (f := f) (B := B) + firstOrder secondOrder hfirstNonzero hsecondNonzero z).2.1 + omega + +/-- The natural-number local gcd multiplicity of the two torsion functions. -/ +def torsionGcdMultiplicity + {B : Type*} [CommRing B] [IsDedekindDomain B] + [Algebra B (PlaneCurveFunctionField f)] + [IsFractionRing B (PlaneCurveFunctionField f)] + (firstOrder secondOrder : ℕ) (v : HeightOneSpectrum B) : ℕ := + Int.toNat (min + (finitePlaceOrder v (planeCurveFunction f 0 ^ firstOrder - 1)) + (finitePlaceOrder v (planeCurveFunction f 1 ^ secondOrder - 1))) + +/-- Every chosen torsion branch contributes at least one to the local gcd +multiplicity. -/ +theorem one_le_torsionGcdMultiplicity_torsionPointFinitePlace + {B : Type*} [CommRing B] [IsDedekindDomain B] + [Algebra (PlaneCurveCoordinateRing f) B] + [Algebra B (PlaneCurveFunctionField f)] + [IsScalarTower (PlaneCurveCoordinateRing f) B (PlaneCurveFunctionField f)] + [Algebra.IsIntegral (PlaneCurveCoordinateRing f) B] + [FaithfulSMul (PlaneCurveCoordinateRing f) B] + [IsIntegralClosure B (PlaneCurveCoordinateRing f) (PlaneCurveFunctionField f)] + [IsFractionRing B (PlaneCurveFunctionField f)] + (firstOrder secondOrder : ℕ) + (hfirstNonzero : planeCurveFunction f 0 ^ firstOrder - 1 ≠ 0) + (hsecondNonzero : planeCurveFunction f 1 ^ secondOrder - 1 ≠ 0) + (z : TorusCurveTorsionPoint f firstOrder secondOrder) : + 1 ≤ torsionGcdMultiplicity (f := f) (B := B) firstOrder secondOrder + (torsionPointFinitePlace (B := B) firstOrder secondOrder + hfirstNonzero hsecondNonzero z) := by + unfold torsionGcdMultiplicity + have h := (torsionPointFinitePlace_spec (f := f) (B := B) firstOrder secondOrder + hfirstNonzero hsecondNonzero z).2.2.2 + omega + +/-- The torsion-point count is bounded by the finite sum of local gcd +multiplicities on any Dedekind normalization model. -/ +theorem torsionPoint_card_le_torsionGcdMultiplicity_sum + {B : Type*} [CommRing B] [IsDedekindDomain B] + [Algebra (PlaneCurveCoordinateRing f) B] + [Algebra B (PlaneCurveFunctionField f)] + [IsScalarTower (PlaneCurveCoordinateRing f) B (PlaneCurveFunctionField f)] + [Algebra.IsIntegral (PlaneCurveCoordinateRing f) B] + [FaithfulSMul (PlaneCurveCoordinateRing f) B] + [IsIntegralClosure B (PlaneCurveCoordinateRing f) (PlaneCurveFunctionField f)] + [IsFractionRing B (PlaneCurveFunctionField f)] + (firstOrder secondOrder : ℕ) + (hfirstNonzero : planeCurveFunction f 0 ^ firstOrder - 1 ≠ 0) + (hsecondNonzero : planeCurveFunction f 1 ^ secondOrder - 1 ≠ 0) : + Fintype.card (TorusCurveTorsionPoint f firstOrder secondOrder) ≤ + ∑ v ∈ torsionGcdPlaceSupport (f := f) (B := B) firstOrder secondOrder, + torsionGcdMultiplicity (f := f) (B := B) firstOrder secondOrder v := by + classical + let place : TorusCurveTorsionPoint f firstOrder secondOrder → HeightOneSpectrum B := + torsionPointFinitePlace (B := B) firstOrder secondOrder + hfirstNonzero hsecondNonzero + have hPlaceInjective : Function.Injective place := + torsionPointFinitePlace_injective (B := B) firstOrder secondOrder + hfirstNonzero hsecondNonzero + have hImageSubset : Finset.univ.image place ⊆ + torsionGcdPlaceSupport (f := f) (B := B) firstOrder secondOrder := by + intro v hv + obtain ⟨z, -, rfl⟩ := Finset.mem_image.mp hv + exact torsionPointFinitePlace_mem_torsionGcdPlaceSupport (f := f) firstOrder secondOrder + hfirstNonzero hsecondNonzero z + calc + Fintype.card (TorusCurveTorsionPoint f firstOrder secondOrder) = + (Finset.univ.image place).card := by + rw [Finset.card_image_of_injective _ hPlaceInjective, + Finset.card_univ] + _ = ∑ v ∈ Finset.univ.image place, 1 := by simp + _ ≤ ∑ v ∈ Finset.univ.image place, + torsionGcdMultiplicity (f := f) (B := B) firstOrder secondOrder v := by + apply Finset.sum_le_sum + intro v hv + obtain ⟨z, -, rfl⟩ := Finset.mem_image.mp hv + exact one_le_torsionGcdMultiplicity_torsionPointFinitePlace + firstOrder secondOrder hfirstNonzero hsecondNonzero z + _ ≤ ∑ v ∈ torsionGcdPlaceSupport (f := f) (B := B) + firstOrder secondOrder, + torsionGcdMultiplicity (f := f) (B := B) firstOrder secondOrder v := by + exact Finset.sum_le_sum_of_subset_of_nonneg hImageSubset (by omega) + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/TorsionPointNormalization.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/TorsionPointNormalization.lean new file mode 100644 index 0000000000..8374a95097 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/TorsionPointNormalization.lean @@ -0,0 +1,429 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FinitePlaceCompletion +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveSeparability +public import LeanPool.MarkoffModP.BGS.External.GeneralCurveTheorems +public import Mathlib.RingTheory.Ideal.GoingUp +public import Mathlib.RingTheory.Localization.Integral + +/-! +# Affine centers and normalization of torsion points + +Construct coordinate-ring evaluations and their maximal ideals, and compare affine torsion +points with normalization places. +-/ + +@[expose] public section + +namespace BGS.CorvajaZannier + +noncomputable section + +open IsDedekindDomain Multiplicative WithZero + +variable {K : Type*} [Field K] + +/-- An affine rational point of the plane curve `f = 0`. -/ +abbrev AffinePlaneCurvePoint (f : MvPolynomial (Fin 2) K) := + {z : K × K // MvPolynomial.eval ![z.1, z.2] f = 0} + +/-- Evaluation at an affine rational point, descended to the coordinate ring. -/ +def planeCurvePointEval (f : MvPolynomial (Fin 2) K) + (z : AffinePlaneCurvePoint f) : PlaneCurveCoordinateRing f →+* K := + Ideal.Quotient.lift (Ideal.span {f}) + (MvPolynomial.eval₂Hom (RingHom.id K) ![z.1.1, z.1.2]) (by + intro g hg + obtain ⟨a, rfl⟩ := Ideal.mem_span_singleton.mp hg + rw [map_mul] + have hfzero : + (MvPolynomial.eval₂Hom (RingHom.id K) ![z.1.1, z.1.2]) f = 0 := by + change (MvPolynomial.eval ![z.1.1, z.1.2]) f = 0 + exact z.2 + rw [hfzero, zero_mul]) + +@[simp] +theorem planeCurvePointEval_coordinate (f : MvPolynomial (Fin 2) K) + (z : AffinePlaneCurvePoint f) (i : Fin 2) : + planeCurvePointEval f z (planeCurveCoordinate f i) = ![z.1.1, z.1.2] i := by + simp [planeCurvePointEval, planeCurveCoordinate, planeCurveQuotientMap] + +@[simp] +theorem planeCurvePointEval_algebraMap (f : MvPolynomial (Fin 2) K) + (z : AffinePlaneCurvePoint f) (c : K) : + planeCurvePointEval f z (algebraMap K (PlaneCurveCoordinateRing f) c) = c := by + change planeCurvePointEval f z + (Ideal.Quotient.mk (Ideal.span {f}) (MvPolynomial.C c)) = c + simp [planeCurvePointEval] + +theorem planeCurvePointEval_surjective (f : MvPolynomial (Fin 2) K) + (z : AffinePlaneCurvePoint f) : Function.Surjective (planeCurvePointEval f z) := by + intro c + exact ⟨algebraMap K (PlaneCurveCoordinateRing f) c, + planeCurvePointEval_algebraMap f z c⟩ + +/-- The maximal ideal of the affine coordinate ring attached to a rational point. -/ +def affinePlaneCurvePointMaximalIdeal (f : MvPolynomial (Fin 2) K) + (z : AffinePlaneCurvePoint f) : MaximalSpectrum (PlaneCurveCoordinateRing f) where + asIdeal := RingHom.ker (planeCurvePointEval f z) + isMaximal := RingHom.ker_isMaximal_of_surjective _ + (planeCurvePointEval_surjective f z) + +/-- Distinct rational affine points define distinct maximal ideals. -/ +theorem affinePlaneCurvePointMaximalIdeal_injective (f : MvPolynomial (Fin 2) K) : + Function.Injective (affinePlaneCurvePointMaximalIdeal f) := by + intro z w hzw + have hker : RingHom.ker (planeCurvePointEval f z) = + RingHom.ker (planeCurvePointEval f w) := + congrArg MaximalSpectrum.asIdeal hzw + apply Subtype.ext + apply Prod.ext + · have hzmem : planeCurveCoordinate f 0 - + algebraMap K (PlaneCurveCoordinateRing f) z.1.1 ∈ + RingHom.ker (planeCurvePointEval f z) := by + change planeCurvePointEval f z + (planeCurveCoordinate f 0 - + algebraMap K (PlaneCurveCoordinateRing f) z.1.1) = 0 + simp + have hwmem : planeCurveCoordinate f 0 - + algebraMap K (PlaneCurveCoordinateRing f) z.1.1 ∈ + RingHom.ker (planeCurvePointEval f w) := by + rw [← hker] + exact hzmem + change planeCurvePointEval f w + (planeCurveCoordinate f 0 - + algebraMap K (PlaneCurveCoordinateRing f) z.1.1) = 0 at hwmem + have heval : w.1.1 - z.1.1 = 0 := by simpa using hwmem + exact (sub_eq_zero.mp heval).symm + · have hzmem : planeCurveCoordinate f 1 - + algebraMap K (PlaneCurveCoordinateRing f) z.1.2 ∈ + RingHom.ker (planeCurvePointEval f z) := by + change planeCurvePointEval f z + (planeCurveCoordinate f 1 - + algebraMap K (PlaneCurveCoordinateRing f) z.1.2) = 0 + simp + have hwmem : planeCurveCoordinate f 1 - + algebraMap K (PlaneCurveCoordinateRing f) z.1.2 ∈ + RingHom.ker (planeCurvePointEval f w) := by + rw [← hker] + exact hzmem + change planeCurvePointEval f w + (planeCurveCoordinate f 1 - + algebraMap K (PlaneCurveCoordinateRing f) z.1.2) = 0 at hwmem + have heval : w.1.2 - z.1.2 = 0 := by simpa using hwmem + exact (sub_eq_zero.mp heval).symm + +variable [Fintype K] [DecidableEq K] + +/-- A torsion point in the finite-field intersection, as a finite subtype. -/ +abbrev TorusCurveTorsionPoint (f : MvPolynomial (Fin 2) K) + (firstOrder secondOrder : ℕ) := + {z : Kˣ × Kˣ // z ∈ BGS.External.torusCurveTorsionIntersection + K f firstOrder secondOrder} + +/-- Forget the unit witnesses and regard a torsion point as an affine point of +the plane curve. -/ +def torsionPointToAffinePlaneCurvePoint + (f : MvPolynomial (Fin 2) K) (firstOrder secondOrder : ℕ) + (z : TorusCurveTorsionPoint f firstOrder secondOrder) : + AffinePlaneCurvePoint f := + ⟨((z.1.1 : K), (z.1.2 : K)), + (BGS.External.mem_torusCurveTorsionIntersection_iff.mp z.2).1⟩ + +theorem torsionPointToAffinePlaneCurvePoint_injective + (f : MvPolynomial (Fin 2) K) (firstOrder secondOrder : ℕ) : + Function.Injective + (torsionPointToAffinePlaneCurvePoint f firstOrder secondOrder) := by + intro z w hzw + apply Subtype.ext + apply Prod.ext <;> apply Units.ext + · exact congrArg Prod.fst (congrArg Subtype.val hzw) + · exact congrArg Prod.snd (congrArg Subtype.val hzw) + +/-- A finite-field torsion point determines a maximal ideal of the affine +coordinate ring. -/ +def torsionPointMaximalIdeal + (f : MvPolynomial (Fin 2) K) (firstOrder secondOrder : ℕ) + (z : TorusCurveTorsionPoint f firstOrder secondOrder) : + MaximalSpectrum (PlaneCurveCoordinateRing f) := + affinePlaneCurvePointMaximalIdeal f + (torsionPointToAffinePlaneCurvePoint f firstOrder secondOrder z) + +theorem torsionPointMaximalIdeal_injective + (f : MvPolynomial (Fin 2) K) (firstOrder secondOrder : ℕ) : + Function.Injective (torsionPointMaximalIdeal f firstOrder secondOrder) := + (affinePlaneCurvePointMaximalIdeal_injective f).comp + (torsionPointToAffinePlaneCurvePoint_injective f firstOrder secondOrder) + +/-- The first torsion function belongs to the maximal ideal of its point. -/ +theorem first_torsionFunction_mem_torsionPointMaximalIdeal + (f : MvPolynomial (Fin 2) K) (firstOrder secondOrder : ℕ) + (z : TorusCurveTorsionPoint f firstOrder secondOrder) : + planeCurveCoordinate f 0 ^ firstOrder - 1 ∈ + (torsionPointMaximalIdeal f firstOrder secondOrder z).asIdeal := by + change planeCurvePointEval f + (torsionPointToAffinePlaneCurvePoint f firstOrder secondOrder z) + (planeCurveCoordinate f 0 ^ firstOrder - 1) = 0 + rw [map_sub, map_pow, map_one, planeCurvePointEval_coordinate] + have hpow := + (BGS.External.mem_torusCurveTorsionIntersection_iff.mp z.2).2.1 + exact sub_eq_zero.mpr (congrArg Units.val hpow) + +/-- The second torsion function belongs to the maximal ideal of its point. -/ +theorem second_torsionFunction_mem_torsionPointMaximalIdeal + (f : MvPolynomial (Fin 2) K) (firstOrder secondOrder : ℕ) + (z : TorusCurveTorsionPoint f firstOrder secondOrder) : + planeCurveCoordinate f 1 ^ secondOrder - 1 ∈ + (torsionPointMaximalIdeal f firstOrder secondOrder z).asIdeal := by + change planeCurvePointEval f + (torsionPointToAffinePlaneCurvePoint f firstOrder secondOrder z) + (planeCurveCoordinate f 1 ^ secondOrder - 1) = 0 + rw [map_sub, map_pow, map_one, planeCurvePointEval_coordinate] + have hpow := + (BGS.External.mem_torusCurveTorsionIntersection_iff.mp z.2).2.2 + exact sub_eq_zero.mpr (congrArg Units.val hpow) + +variable {f : MvPolynomial (Fin 2) K} +variable [IsDomain (PlaneCurveCoordinateRing f)] + +/-- The affine normalization of the plane-curve coordinate ring inside its +fraction field. -/ +abbrev PlaneCurveNormalization (f : MvPolynomial (Fin 2) K) + [IsDomain (PlaneCurveCoordinateRing f)] := + integralClosure (PlaneCurveCoordinateRing f) (PlaneCurveFunctionField f) + +/-- Choose one normalization branch above an affine maximal ideal. Lying over +guarantees that such a branch exists; no smoothness is assumed. -/ +def planeCurveNormalizationBranch + (f : MvPolynomial (Fin 2) K) + [IsDomain (PlaneCurveCoordinateRing f)] + (m : MaximalSpectrum (PlaneCurveCoordinateRing f)) : + MaximalSpectrum (PlaneCurveNormalization f) := by + let hex := Ideal.exists_maximal_ideal_liesOver_of_isIntegral + (S := PlaneCurveNormalization f) m.asIdeal + exact ⟨Classical.choose hex, (Classical.choose_spec hex).1⟩ + +omit [Fintype K] [DecidableEq K] in +theorem planeCurveNormalizationBranch_liesOver + (f : MvPolynomial (Fin 2) K) + [IsDomain (PlaneCurveCoordinateRing f)] + (m : MaximalSpectrum (PlaneCurveCoordinateRing f)) : + (planeCurveNormalizationBranch f m).asIdeal.LiesOver m.asIdeal := by + let hex := Ideal.exists_maximal_ideal_liesOver_of_isIntegral + (S := PlaneCurveNormalization f) m.asIdeal + exact (Classical.choose_spec hex).2 + +omit [Fintype K] [DecidableEq K] in +/-- Chosen normalization branches above distinct affine maximal ideals remain +distinct, because their contractions are distinct. -/ +theorem planeCurveNormalizationBranch_injective + (f : MvPolynomial (Fin 2) K) + [IsDomain (PlaneCurveCoordinateRing f)] : + Function.Injective (planeCurveNormalizationBranch f) := by + intro m n hmn + apply MaximalSpectrum.ext + let hm : (planeCurveNormalizationBranch f m).asIdeal.LiesOver m.asIdeal := + planeCurveNormalizationBranch_liesOver f m + let hn : (planeCurveNormalizationBranch f n).asIdeal.LiesOver n.asIdeal := + planeCurveNormalizationBranch_liesOver f n + calc + m.asIdeal = (planeCurveNormalizationBranch f m).asIdeal.under + (PlaneCurveCoordinateRing f) := + Ideal.over_def + (P := (planeCurveNormalizationBranch f m).asIdeal) (p := m.asIdeal) + _ = (planeCurveNormalizationBranch f n).asIdeal.under + (PlaneCurveCoordinateRing f) := by rw [hmn] + _ = n.asIdeal := + (Ideal.over_def + (P := (planeCurveNormalizationBranch f n).asIdeal) (p := n.asIdeal)).symm + +/-- The chosen branch of the normalization above a torsion point. -/ +def torsionPointNormalizationBranch + (f : MvPolynomial (Fin 2) K) + [IsDomain (PlaneCurveCoordinateRing f)] + (firstOrder secondOrder : ℕ) + (z : TorusCurveTorsionPoint f firstOrder secondOrder) : + MaximalSpectrum (PlaneCurveNormalization f) := + planeCurveNormalizationBranch f + (torsionPointMaximalIdeal f firstOrder secondOrder z) + +theorem torsionPointNormalizationBranch_injective + (f : MvPolynomial (Fin 2) K) + [IsDomain (PlaneCurveCoordinateRing f)] + (firstOrder secondOrder : ℕ) : + Function.Injective + (torsionPointNormalizationBranch f firstOrder secondOrder) := + (planeCurveNormalizationBranch_injective f).comp + (torsionPointMaximalIdeal_injective f firstOrder secondOrder) + +/-- The first torsion function vanishes on the chosen normalization branch. -/ +theorem first_torsionFunction_mem_normalizationBranch + (f : MvPolynomial (Fin 2) K) + [IsDomain (PlaneCurveCoordinateRing f)] + (firstOrder secondOrder : ℕ) + (z : TorusCurveTorsionPoint f firstOrder secondOrder) : + algebraMap (PlaneCurveCoordinateRing f) (PlaneCurveNormalization f) + (planeCurveCoordinate f 0 ^ firstOrder - 1) ∈ + (torsionPointNormalizationBranch f firstOrder secondOrder z).asIdeal := by + let : + (torsionPointNormalizationBranch f firstOrder secondOrder z).asIdeal.LiesOver + (torsionPointMaximalIdeal f firstOrder secondOrder z).asIdeal := + planeCurveNormalizationBranch_liesOver f + (torsionPointMaximalIdeal f firstOrder secondOrder z) + exact (Ideal.mem_of_liesOver + (P := (torsionPointNormalizationBranch f firstOrder secondOrder z).asIdeal) + (p := (torsionPointMaximalIdeal f firstOrder secondOrder z).asIdeal) _).mp + (first_torsionFunction_mem_torsionPointMaximalIdeal + f firstOrder secondOrder z) + +/-- The second torsion function vanishes on the chosen normalization branch. -/ +theorem second_torsionFunction_mem_normalizationBranch + (f : MvPolynomial (Fin 2) K) + [IsDomain (PlaneCurveCoordinateRing f)] + (firstOrder secondOrder : ℕ) + (z : TorusCurveTorsionPoint f firstOrder secondOrder) : + algebraMap (PlaneCurveCoordinateRing f) (PlaneCurveNormalization f) + (planeCurveCoordinate f 1 ^ secondOrder - 1) ∈ + (torsionPointNormalizationBranch f firstOrder secondOrder z).asIdeal := by + let : + (torsionPointNormalizationBranch f firstOrder secondOrder z).asIdeal.LiesOver + (torsionPointMaximalIdeal f firstOrder secondOrder z).asIdeal := + planeCurveNormalizationBranch_liesOver f + (torsionPointMaximalIdeal f firstOrder secondOrder z) + exact (Ideal.mem_of_liesOver + (P := (torsionPointNormalizationBranch f firstOrder secondOrder z).asIdeal) + (p := (torsionPointMaximalIdeal f firstOrder secondOrder z).asIdeal) _).mp + (second_torsionFunction_mem_torsionPointMaximalIdeal + f firstOrder secondOrder z) + +/-- An integral-closure model of the plane-curve function field has that +function field as its fraction field. -/ +noncomputable instance planeCurveIntegralClosureIsFractionRing + {B : Type*} [CommRing B] [IsDomain B] + [Algebra (PlaneCurveCoordinateRing f) B] + [Algebra B (PlaneCurveFunctionField f)] + [IsScalarTower (PlaneCurveCoordinateRing f) B (PlaneCurveFunctionField f)] + [IsIntegralClosure B (PlaneCurveCoordinateRing f) (PlaneCurveFunctionField f)] : + IsFractionRing B (PlaneCurveFunctionField f) := by + let : Algebra.IsAlgebraic (PlaneCurveCoordinateRing f) + (PlaneCurveFunctionField f) := + (IsFractionRing.comap_isAlgebraic_iff + (A := PlaneCurveCoordinateRing f) + (K := PlaneCurveFunctionField f) + (C := PlaneCurveFunctionField f)).mpr inferInstance + exact IsIntegralClosure.isFractionRing_of_algebraic + (PlaneCurveCoordinateRing f) B + (fun x hx => IsFractionRing.injective + (PlaneCurveCoordinateRing f) (PlaneCurveFunctionField f) (by simpa using hx)) + +/-- Membership in a height-one prime gives at least one unit of additive +finite-place order. -/ +theorem one_le_finitePlaceOrder_of_mem + {R L : Type*} [CommRing R] [IsDedekindDomain R] + [Field L] [Algebra R L] [IsFractionRing R L] + (v : HeightOneSpectrum R) (a : R) (ha : a ∈ v.asIdeal) (ha0 : a ≠ 0) : + (1 : ℤ) ≤ finitePlaceOrder v (algebraMap R L a) := by + have hmap : algebraMap R L a ≠ 0 := + fun h ↦ ha0 ((IsFractionRing.injective R L) (by simpa using h)) + have hvaluation := valuation_eq_exp_neg_finitePlaceOrder + v (algebraMap R L a) hmap + rw [IsDedekindDomain.HeightOneSpectrum.valuation_of_algebraMap] at hvaluation + have hlt : exp (-finitePlaceOrder v (algebraMap R L a)) < 1 := by + rw [← hvaluation] + exact (v.intValuation_lt_one_iff_mem a).2 ha + rw [← exp_zero, exp_lt_exp] at hlt + omega + +/-- Generic local bridge for any Dedekind integral-closure model `B` of the +curve's function field. A maximal ideal of `B` lying over the torsion point +is a finite place, and both torsion functions have order at least one there. + +The branch is an explicit parameter, so a later global normalization or +projective model can supply its own chosen lift. -/ +theorem liftedNormalizationBranch_torsion_orders_positive + (f : MvPolynomial (Fin 2) K) + [IsDomain (PlaneCurveCoordinateRing f)] + {B : Type*} [CommRing B] [IsDedekindDomain B] + [Algebra (PlaneCurveCoordinateRing f) B] + [Algebra B (PlaneCurveFunctionField f)] + [IsScalarTower (PlaneCurveCoordinateRing f) B (PlaneCurveFunctionField f)] + [IsIntegralClosure B (PlaneCurveCoordinateRing f) (PlaneCurveFunctionField f)] + (firstOrder secondOrder : ℕ) + (hfirstNonzero : planeCurveFunction f 0 ^ firstOrder - 1 ≠ 0) + (hsecondNonzero : planeCurveFunction f 1 ^ secondOrder - 1 ≠ 0) + (z : TorusCurveTorsionPoint f firstOrder secondOrder) + (branch : MaximalSpectrum B) + (hbranch : branch.asIdeal.LiesOver + (torsionPointMaximalIdeal f firstOrder secondOrder z).asIdeal) : + ∃ v : HeightOneSpectrum B, + v.asIdeal = branch.asIdeal ∧ + (1 : ℤ) ≤ finitePlaceOrder v + (planeCurveFunction f 0 ^ firstOrder - 1) ∧ + (1 : ℤ) ≤ finitePlaceOrder v + (planeCurveFunction f 1 ^ secondOrder - 1) ∧ + (1 : ℤ) ≤ min + (finitePlaceOrder v (planeCurveFunction f 0 ^ firstOrder - 1)) + (finitePlaceOrder v (planeCurveFunction f 1 ^ secondOrder - 1)) := by + let A := PlaneCurveCoordinateRing f + let L := PlaneCurveFunctionField f + let firstRegular : B := + algebraMap A B (planeCurveCoordinate f 0 ^ firstOrder - 1) + let secondRegular : B := + algebraMap A B (planeCurveCoordinate f 1 ^ secondOrder - 1) + have hfirstMap : algebraMap B L firstRegular = + planeCurveFunction f 0 ^ firstOrder - 1 := by + simp only [firstRegular, map_sub, map_pow, map_one] + rw [← IsScalarTower.algebraMap_apply A B L] + rfl + have hsecondMap : algebraMap B L secondRegular = + planeCurveFunction f 1 ^ secondOrder - 1 := by + simp only [secondRegular, map_sub, map_pow, map_one] + rw [← IsScalarTower.algebraMap_apply A B L] + rfl + have hfirstRegular : firstRegular ≠ 0 := by + intro hzero + apply hfirstNonzero + rw [← hfirstMap, hzero, map_zero] + have hsecondRegular : secondRegular ≠ 0 := by + intro hzero + apply hsecondNonzero + rw [← hsecondMap, hzero, map_zero] + let : branch.asIdeal.LiesOver + (torsionPointMaximalIdeal f firstOrder secondOrder z).asIdeal := hbranch + have hfirstMem : firstRegular ∈ branch.asIdeal := by + exact (Ideal.mem_of_liesOver + (P := branch.asIdeal) + (p := (torsionPointMaximalIdeal f firstOrder secondOrder z).asIdeal) _).mp + (first_torsionFunction_mem_torsionPointMaximalIdeal + f firstOrder secondOrder z) + have hsecondMem : secondRegular ∈ branch.asIdeal := by + exact (Ideal.mem_of_liesOver + (P := branch.asIdeal) + (p := (torsionPointMaximalIdeal f firstOrder secondOrder z).asIdeal) _).mp + (second_torsionFunction_mem_torsionPointMaximalIdeal + f firstOrder secondOrder z) + have hbranchNeBot : branch.asIdeal ≠ ⊥ := by + intro hbot + have : firstRegular = 0 := by + simpa [hbot] using hfirstMem + exact hfirstRegular this + let v : HeightOneSpectrum B := + ⟨branch.asIdeal, branch.isMaximal.isPrime, hbranchNeBot⟩ + have hfirstOrder : (1 : ℤ) ≤ + finitePlaceOrder v (planeCurveFunction f 0 ^ firstOrder - 1) := by + rw [← hfirstMap] + exact one_le_finitePlaceOrder_of_mem v firstRegular hfirstMem hfirstRegular + have hsecondOrder : (1 : ℤ) ≤ + finitePlaceOrder v (planeCurveFunction f 1 ^ secondOrder - 1) := by + rw [← hsecondMap] + exact one_le_finitePlaceOrder_of_mem v secondRegular hsecondMem hsecondRegular + exact ⟨v, rfl, hfirstOrder, hsecondOrder, le_min hfirstOrder hsecondOrder⟩ + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/TorusCharacterKernelBound.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/TorusCharacterKernelBound.lean new file mode 100644 index 0000000000..c34802b83e --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/TorusCharacterKernelBound.lean @@ -0,0 +1,329 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveSupportDeterminant +public import Mathlib.Data.Int.GCD +public import Mathlib.RingTheory.RootsOfUnity.Basic +public import Mathlib.SetTheory.Cardinal.Finite +public import Mathlib.Tactic + +/-! +# Rank-two character kernels in a two-dimensional torus + +Two independent integer characters cut out a finite subgroup of a +two-dimensional torus. This file proves the sharp elementary bound: the +number of common kernel points is at most the absolute determinant of the +two character vectors. The proof is valid over an arbitrary field and does +not assume that all roots of unity are present. + +Applied to three monomials in the support of a plane curve, this bounds the +diagonal support stabilizer by the corresponding support determinant and +hence by twice the product of the two coordinate degrees. +-/ + +@[expose] public section + +namespace BGS.CorvajaZannier + +noncomputable section + +/-- The fiber of the `g`-th power map on units. -/ +def unitPowerFiber {F : Type*} [Field F] (g : ℕ) (c : Fˣ) := + {z : Fˣ // z ^ g = c} + +instance unitPowerFiber_finite {F : Type*} [Field F] + (g : ℕ) [NeZero g] (c : Fˣ) : Finite (unitPowerFiber g c) := by + classical + let e : unitPowerFiber g c → + {x : F // x ∈ Polynomial.nthRoots g (c : F)} := fun z => + ⟨z.1.1, (Polynomial.mem_nthRoots (NeZero.pos g)).mpr + (congrArg (fun u : Fˣ => (u : F)) z.2)⟩ + exact Finite.of_injective e (fun z w h => by + apply Subtype.ext + apply Units.ext + exact congrArg Subtype.val h) + +/-- A nonzero power equation in one unit has at most its exponent many +solutions. -/ +theorem natCard_unitPowerFiber_le {F : Type*} [Field F] + (g : ℕ) (hg : 0 < g) (c : Fˣ) : + Nat.card (unitPowerFiber g c) ≤ g := by + classical + by_cases h : Nonempty (unitPowerFiber g c) + · let z₀ : unitPowerFiber g c := Classical.choice h + let e : unitPowerFiber g c → rootsOfUnity g F := fun z => + ⟨z.1 * z₀.1⁻¹, by + rw [mem_rootsOfUnity, mul_pow, inv_pow, z.2, z₀.2] + simp⟩ + have he : Function.Injective e := by + intro z w hzw + apply Subtype.ext + have hval := congrArg (fun u : rootsOfUnity g F => (u.1 : Fˣ)) hzw + dsimp only [e] at hval + exact mul_right_cancel hval + have : NeZero g := ⟨hg.ne'⟩ + exact (Nat.card_le_card_of_injective e he).trans + (card_rootsOfUnity F g) + · let : IsEmpty (unitPowerFiber g c) := ⟨fun z => h ⟨z⟩⟩ + simp + +/-- The common kernel of two integer characters of a two-dimensional +algebraic torus. -/ +def torusCharacterKernel (F : Type*) [Field F] + (a b c d : ℤ) := + {z : Fˣ × Fˣ // + z.1 ^ a * z.2 ^ b = 1 ∧ z.1 ^ c * z.2 ^ d = 1} + +private theorem pow_natAbs_eq_one_of_zpow_eq_one + {F : Type*} [Field F] (z : Fˣ) (k : ℤ) (h : z ^ k = 1) : + z ^ k.natAbs = 1 := by + rcases (Int.natAbs_eq_iff.mp + (rfl : k.natAbs = k.natAbs)) with hk | hk + · rw [← zpow_natCast, ← hk] + exact h + · have hinv := congrArg Inv.inv h + rw [hk] at hinv + simpa [← zpow_neg] using hinv + +/-- A nonzero determinant makes the common character kernel finite. This +coarse finiteness proof embeds it into a product of two root-of-unity groups; +the sharper cardinal estimate below uses Hermite reduction. -/ +theorem finite_torusCharacterKernel_of_det_ne_zero + {F : Type*} [Field F] (a b c d : ℤ) + (hdet : a * d - b * c ≠ 0) : + Finite (torusCharacterKernel F a b c d) := by + classical + let D := a * d - b * c + have hD : D ≠ 0 := hdet + have hDpos : 0 < D.natAbs := Int.natAbs_pos.mpr hD + have hfirst (z : torusCharacterKernel F a b c d) : + z.1.1 ^ D = 1 := by + rcases z.2 with ⟨h₁, h₂⟩ + have hprod : + (z.1.1 ^ a * z.1.2 ^ b) ^ d * + (z.1.1 ^ c * z.1.2 ^ d) ^ (-b) = + z.1.1 ^ (a * d + c * (-b)) * + z.1.2 ^ (b * d + d * (-b)) := by + simp only [mul_zpow, zpow_mul, zpow_add] + ac_rfl + have hx : a * d + c * (-b) = D := by dsimp only [D]; ring + have hy : b * d + d * (-b) = 0 := by ring + calc + z.1.1 ^ D = z.1.1 ^ (a * d + c * (-b)) * + z.1.2 ^ (b * d + d * (-b)) := by rw [hx, hy]; simp + _ = (z.1.1 ^ a * z.1.2 ^ b) ^ d * + (z.1.1 ^ c * z.1.2 ^ d) ^ (-b) := hprod.symm + _ = 1 := by rw [h₁, h₂]; simp + have hsecond (z : torusCharacterKernel F a b c d) : + z.1.2 ^ D = 1 := by + rcases z.2 with ⟨h₁, h₂⟩ + have hprod : + (z.1.1 ^ a * z.1.2 ^ b) ^ (-c) * + (z.1.1 ^ c * z.1.2 ^ d) ^ a = + z.1.1 ^ (a * (-c) + c * a) * + z.1.2 ^ (b * (-c) + d * a) := by + simp only [mul_zpow, zpow_mul, zpow_add] + ac_rfl + have hx : a * (-c) + c * a = 0 := by ring + have hy : b * (-c) + d * a = D := by dsimp only [D]; ring + calc + z.1.2 ^ D = z.1.1 ^ (a * (-c) + c * a) * + z.1.2 ^ (b * (-c) + d * a) := by rw [hx, hy]; simp + _ = (z.1.1 ^ a * z.1.2 ^ b) ^ (-c) * + (z.1.1 ^ c * z.1.2 ^ d) ^ a := hprod.symm + _ = 1 := by rw [h₁, h₂]; simp + have : NeZero D.natAbs := ⟨hDpos.ne'⟩ + let e : torusCharacterKernel F a b c d → + rootsOfUnity D.natAbs F × rootsOfUnity D.natAbs F := fun z => + ⟨⟨z.1.1, by + rw [mem_rootsOfUnity] + exact pow_natAbs_eq_one_of_zpow_eq_one z.1.1 D (hfirst z)⟩, + ⟨z.1.2, by + rw [mem_rootsOfUnity] + exact pow_natAbs_eq_one_of_zpow_eq_one z.1.2 D (hsecond z)⟩⟩ + exact Finite.of_injective e (fun z w hzw => by + apply Subtype.ext + apply Prod.ext + · exact congrArg (fun u => u.1.1) hzw + · exact congrArg (fun u => u.2.1) hzw) + +/-- The sharp determinant bound for the common kernel of two characters. -/ +theorem natCard_torusCharacterKernel_le_det + {F : Type*} [Field F] (a b c d : ℤ) + (hdet : a * d - b * c ≠ 0) : + Nat.card (torusCharacterKernel F a b c d) ≤ + (a * d - b * c).natAbs := by + classical + let g : ℕ := Int.gcd a c + have hg : 0 < g := by + rw [Int.gcd_pos_iff] + by_contra h + push Not at h + rcases h with ⟨rfl, rfl⟩ + simp at hdet + obtain ⟨a', ha'⟩ := Int.gcd_dvd_left a c + obtain ⟨c', hc'⟩ := Int.gcd_dvd_right a c + have ha : a = (g : ℤ) * a' := ha' + have hc : c = (g : ℤ) * c' := hc' + let q : ℤ := b * c' - d * a' + have hdetq : a * d - b * c = -(g : ℤ) * q := by + dsimp only [q] + rw [ha, hc] + ring + have hq : q ≠ 0 := by + intro h + apply hdet + rw [hdetq, h, mul_zero] + have hqpos : 0 < q.natAbs := Int.natAbs_pos.mpr hq + let base := rootsOfUnity q.natAbs F + let fiber (η : base) := unitPowerFiber g + (η.1 ^ (-(b * Int.gcdA a c + d * Int.gcdB a c))) + have hηq (z : torusCharacterKernel F a b c d) : + z.1.2 ^ q = 1 := by + rcases z.2 with ⟨h₁, h₂⟩ + have hx : a * c' + c * (-a') = 0 := by + rw [ha, hc] + ring + have hy : b * c' + d * (-a') = q := by + dsimp only [q] + ring + have hprod : + (z.1.1 ^ a * z.1.2 ^ b) ^ c' * + (z.1.1 ^ c * z.1.2 ^ d) ^ (-a') = + z.1.1 ^ (a * c' + c * (-a')) * + z.1.2 ^ (b * c' + d * (-a')) := by + simp only [mul_zpow, zpow_mul, zpow_add] + ac_rfl + calc + z.1.2 ^ q = z.1.1 ^ (a * c' + c * (-a')) * + z.1.2 ^ (b * c' + d * (-a')) := by rw [hx, hy]; simp + _ = (z.1.1 ^ a * z.1.2 ^ b) ^ c' * + (z.1.1 ^ c * z.1.2 ^ d) ^ (-a') := hprod.symm + _ = 1 := by rw [h₁, h₂]; simp + have hηabs (z : torusCharacterKernel F a b c d) : + z.1.2 ^ q.natAbs = 1 := by + rcases (Int.natAbs_eq_iff.mp + (rfl : q.natAbs = q.natAbs)) with hqcast | hqcast + · rw [← zpow_natCast, ← hqcast] + exact hηq z + · have hinv := congrArg Inv.inv (hηq z) + rw [hqcast] at hinv + simpa [← zpow_neg] using hinv + have hfirst (z : torusCharacterKernel F a b c d) : + z.1.1 ^ g = + z.1.2 ^ (-(b * Int.gcdA a c + d * Int.gcdB a c)) := by + rcases z.2 with ⟨h₁, h₂⟩ + have hbez : (g : ℤ) = a * Int.gcdA a c + c * Int.gcdB a c := + Int.gcd_eq_gcd_ab a c + let A := Int.gcdA a c + let B := Int.gcdB a c + let w := b * A + d * B + have hprod : + (z.1.1 ^ a * z.1.2 ^ b) ^ A * + (z.1.1 ^ c * z.1.2 ^ d) ^ B = + z.1.1 ^ (a * A + c * B) * z.1.2 ^ w := by + dsimp only [w] + simp only [mul_zpow, zpow_mul, zpow_add] + ac_rfl + have hone : z.1.1 ^ (g : ℤ) * z.1.2 ^ w = 1 := by + rw [hbez] + rw [← hprod, h₁, h₂] + simp + have hinv : z.1.1 ^ (g : ℤ) = (z.1.2 ^ w)⁻¹ := + (mul_eq_one_iff_eq_inv).mp hone + rw [← zpow_natCast] + simpa [w, A, B, ← zpow_neg] using hinv + let e : torusCharacterKernel F a b c d → Sigma fiber := fun z => + ⟨⟨z.1.2, by + rw [mem_rootsOfUnity] + exact hηabs z⟩, + ⟨z.1.1, hfirst z⟩⟩ + have he : Function.Injective e := by + intro z w hzw + apply Subtype.ext + apply Prod.ext + · exact congrArg (fun s : Sigma fiber => s.2.1) hzw + · exact congrArg (fun s : Sigma fiber => s.1.1) hzw + have : NeZero q.natAbs := ⟨hqpos.ne'⟩ + have : NeZero g := ⟨hg.ne'⟩ + let : Fintype base := Fintype.ofFinite base + let (η : base) : Finite (fiber η) := unitPowerFiber_finite g _ + have hbase : Nat.card base ≤ q.natAbs := card_rootsOfUnity F q.natAbs + have hfiber : ∀ η : base, Nat.card (fiber η) ≤ g := by + intro η + exact natCard_unitPowerFiber_le g hg _ + calc + Nat.card (torusCharacterKernel F a b c d) ≤ Nat.card (Sigma fiber) := + Nat.card_le_card_of_injective e he + _ = ∑ η : base, Nat.card (fiber η) := Nat.card_sigma + _ ≤ ∑ _η : base, g := Finset.sum_le_sum fun _ _ => hfiber _ + _ = Nat.card base * g := by simp + _ ≤ q.natAbs * g := Nat.mul_le_mul_right g hbase + _ = (a * d - b * c).natAbs := by + rw [hdetq, Int.natAbs_mul] + simp [Nat.mul_comm] + +/-- Diagonal scalings on which every support character of `f` has the same +value. These are precisely the possible diagonal stabilizers detected from +the monomial support. -/ +def planeCurveSupportCharacterStabilizer + (F : Type*) [Field F] {K : Type*} [Field K] + (f : MvPolynomial (Fin 2) K) := + {z : Fˣ × Fˣ // ∀ r ∈ f.support, ∀ s ∈ f.support, + z.1 ^ ((s 0 : ℤ) - (r 0 : ℤ)) * + z.2 ^ ((s 1 : ℤ) - (r 1 : ℤ)) = 1} + +/-- A nonzero support determinant bounds every diagonal support stabilizer. -/ +theorem natCard_planeCurveSupportCharacterStabilizer_le_supportDet + {F K : Type*} [Field F] [Field K] + {f : MvPolynomial (Fin 2) K} + {r s t : Fin 2 →₀ ℕ} + (hr : r ∈ f.support) (hs : s ∈ f.support) (ht : t ∈ f.support) + (hdet : planeCurveSupportDifferenceDet r s t ≠ 0) : + Nat.card (planeCurveSupportCharacterStabilizer F f) ≤ + (planeCurveSupportDifferenceDet r s t).natAbs := by + let a : ℤ := (s 0 : ℤ) - (r 0 : ℤ) + let b : ℤ := (s 1 : ℤ) - (r 1 : ℤ) + let c : ℤ := (t 0 : ℤ) - (r 0 : ℤ) + let d : ℤ := (t 1 : ℤ) - (r 1 : ℤ) + have hdet' : a * d - b * c ≠ 0 := by + simpa [a, b, c, d, planeCurveSupportDifferenceDet] using hdet + let : Finite (torusCharacterKernel F a b c d) := + finite_torusCharacterKernel_of_det_ne_zero a b c d hdet' + let e : planeCurveSupportCharacterStabilizer F f → + torusCharacterKernel F a b c d := fun z => + ⟨z.1, z.2 r hr s hs, z.2 r hr t ht⟩ + have he : Function.Injective e := by + intro z w hzw + apply Subtype.ext + exact congrArg (fun u : torusCharacterKernel F a b c d => u.1) hzw + calc + Nat.card (planeCurveSupportCharacterStabilizer F f) ≤ + Nat.card (torusCharacterKernel F a b c d) := + Nat.card_le_card_of_injective e he + _ ≤ (a * d - b * c).natAbs := + natCard_torusCharacterKernel_le_det a b c d hdet' + _ = (planeCurveSupportDifferenceDet r s t).natAbs := by + simp [a, b, c, d, planeCurveSupportDifferenceDet] + +/-- Rank-two support gives the public bidegree bound for every diagonal +support stabilizer. -/ +theorem natCard_planeCurveSupportCharacterStabilizer_le_twice_bidegree + {F K : Type*} [Field F] [Field K] + {f : MvPolynomial (Fin 2) K} + (hrank : PlaneCurveSupportHasRankTwo f) : + Nat.card (planeCurveSupportCharacterStabilizer F f) ≤ + 2 * MvPolynomial.degreeOf 0 f * MvPolynomial.degreeOf 1 f := by + obtain ⟨r, s, t, hr, hs, ht, hdet⟩ := hrank + exact (natCard_planeCurveSupportCharacterStabilizer_le_supportDet + (F := F) hr hs ht hdet).trans + (natAbs_planeCurveSupportDifferenceDet_le_twice_bidegree hr hs ht) + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/TranscendentalPowerDegree.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/TranscendentalPowerDegree.lean new file mode 100644 index 0000000000..f5508fa8e7 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/TranscendentalPowerDegree.lean @@ -0,0 +1,235 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PoweredImageCurve +public import Mathlib.RingTheory.Polynomial.Eisenstein.Basic +public import Mathlib.Tactic + +/-! +# Exact degree of a transcendental power map + +For a transcendental element `z`, the extension `K(z)/K(z^m)` has exact +degree `m`. The key polynomial is Eisenstein at the rational parameter. +-/ + +@[expose] public section + +namespace BGS.CorvajaZannier + +noncomputable section + +open scoped Polynomial +open Polynomial + +private theorem polynomial_X_pow_sub_C_X_irreducible + {K : Type*} [Field K] (m : ℕ) (hm : 0 < m) : + Irreducible + (Polynomial.X ^ m - Polynomial.C (Polynomial.X : Polynomial K) : + Polynomial (Polynomial K)) := by + let R := Polynomial K + let q : Polynomial R := + Polynomial.X ^ m - Polynomial.C (Polynomial.X : R) + let P : Ideal R := Ideal.span {(Polynomial.X : R)} + have hX : Irreducible (Polynomial.X : R) := Polynomial.irreducible_X + have hP : P.IsPrime := + (Ideal.span_singleton_prime Polynomial.X_ne_zero).mpr hX.prime + have hqMonic : q.Monic := + Polynomial.monic_X_pow_sub_C (Polynomial.X : R) hm.ne' + have hqDegree : q.natDegree = m := by + simpa only [q] using + (Polynomial.natDegree_X_pow_sub_C + (R := R) (n := m) (r := (Polynomial.X : R))) + have hqEisenstein : q.IsEisensteinAt P := by + refine { + leading := ?_ + mem := ?_ + notMem := ?_ } + · rw [hqMonic.leadingCoeff, Ideal.mem_span_singleton] + exact hX.not_dvd_one + · intro i hi + rw [hqDegree] at hi + by_cases hi0 : i = 0 + · subst i + have hq0 : q.coeff 0 = -(Polynomial.X : R) := by + simp [q, Ne.symm hm.ne'] + rw [hq0] + exact P.neg_mem (Ideal.subset_span (Set.mem_singleton _)) + · have him : i ≠ m := ne_of_lt hi + simp only [q, Polynomial.coeff_sub, Polynomial.coeff_X_pow, + Polynomial.coeff_C, ite_eq_right him, ite_eq_right hi0, sub_zero] + exact P.zero_mem + · have hcoeff : q.coeff 0 = -(Polynomial.X : R) := by + simp [q, Ne.symm hm.ne'] + rw [hcoeff, Ideal.span_singleton_pow, + Ideal.mem_span_singleton] + intro hdvd + have hle := Polynomial.natDegree_le_of_dvd hdvd + (neg_ne_zero.mpr Polynomial.X_ne_zero) + rw [Polynomial.natDegree_pow, Polynomial.natDegree_X] at hle + norm_num at hle + exact hqEisenstein.irreducible hP hqMonic.isPrimitive + (by rw [hqDegree]; exact hm) + +/-- A transcendental element has minimal polynomial of degree `m` over the +field generated by its `m`-th power. -/ +theorem minpoly_natDegree_over_adjoin_pow_eq + {K L : Type*} [Field K] [Field L] [Algebra K L] + (z : L) (hz : Transcendental K z) (m : ℕ) (hm : 0 < m) : + (minpoly (IntermediateField.adjoin K {z ^ m}) z).natDegree = m := by + let E0 := IntermediateField.adjoin K {z ^ m} + let c : E0 := + ⟨z ^ m, IntermediateField.subset_adjoin K {z ^ m} + (Set.mem_singleton (z ^ m))⟩ + let q : Polynomial E0 := Polynomial.X ^ m - Polynomial.C c + have hzmTrans : Transcendental K (z ^ m) := hz.pow hm + let e : RatFunc K ≃ₐ[K] E0 := + RatFunc.algEquivOfTranscendental (z ^ m) hzmTrans + have hec : e RatFunc.X = c := by + apply Subtype.ext + simpa only [e, c] using + (RatFunc.algEquivOfTranscendental_X + (f := z ^ m) (h := hzmTrans)) + have hecinv : e.symm c = RatFunc.X := by + rw [← hec, e.symm_apply_apply] + have hqMap : (Polynomial.mapEquiv e.symm.toRingEquiv) q = + (Polynomial.X ^ m - Polynomial.C RatFunc.X : + Polynomial (RatFunc K)) := by + simp [Polynomial.mapEquiv_apply, q, hecinv] + let q0 : Polynomial (Polynomial K) := + Polynomial.X ^ m - Polynomial.C (Polynomial.X : Polynomial K) + have hq0 : Irreducible q0 := by + exact polynomial_X_pow_sub_C_X_irreducible m hm + have hq0Monic : q0.Monic := + Polynomial.monic_X_pow_sub_C (Polynomial.X : Polynomial K) hm.ne' + have hqRat : Irreducible + (q0.map (algebraMap (Polynomial K) (RatFunc K))) := + hq0Monic.isPrimitive.irreducible_iff_irreducible_map_fraction_map.mp hq0 + have hqMapIrred : Irreducible + ((Polynomial.mapEquiv e.symm.toRingEquiv) q) := by + rw [hqMap] + simpa [q0] using hqRat + have hqIrred : Irreducible q := by + apply Irreducible.of_map + (f := Polynomial.mapEquiv e.symm.toRingEquiv) + exact hqMapIrred + have hqMonic : q.Monic := + Polynomial.monic_X_pow_sub_C c hm.ne' + have hqRoot : Polynomial.aeval z q = 0 := by + simp [q, c] + have hminpoly : minpoly E0 z = q := + (minpoly.eq_of_irreducible_of_monic hqIrred hqRoot hqMonic).symm + rw [hminpoly] + simp [q] + +/-- The simple extension generated by a transcendental element over the +field generated by its power has exact degree `m`. -/ +theorem finrank_adjoin_over_adjoin_pow_eq + {K L : Type*} [Field K] [Field L] [Algebra K L] + (z : L) (hz : Transcendental K z) (m : ℕ) (hm : 0 < m) : + Module.finrank (IntermediateField.adjoin K {z ^ m}) + (IntermediateField.adjoin + (IntermediateField.adjoin K {z ^ m}) {z}) = m := by + let E0 := IntermediateField.adjoin K {z ^ m} + let c : E0 := + ⟨z ^ m, IntermediateField.subset_adjoin K {z ^ m} + (Set.mem_singleton (z ^ m))⟩ + let q : Polynomial E0 := Polynomial.X ^ m - Polynomial.C c + have hqMonic : q.Monic := + Polynomial.monic_X_pow_sub_C c hm.ne' + have hqRoot : Polynomial.aeval z q = 0 := by simp [q, c] + have hzIntegral : IsIntegral E0 z := ⟨q, hqMonic, hqRoot⟩ + rw [IntermediateField.adjoin.finrank hzIntegral, + minpoly_natDegree_over_adjoin_pow_eq z hz m hm] + +/-- Passing from `K(z)` to `K(z^m)` multiplies the degree of any finite top +extension by exactly `m`. -/ +theorem finrank_over_adjoin_pow_eq_mul + {K L : Type*} [Field K] [Field L] [Algebra K L] + (z : L) (hz : Transcendental K z) (m : ℕ) (hm : 0 < m) + [FiniteDimensional (IntermediateField.adjoin K {z}) L] : + Module.finrank (IntermediateField.adjoin K {z ^ m}) L = + m * Module.finrank (IntermediateField.adjoin K {z}) L := by + let E0 := IntermediateField.adjoin K {z ^ m} + let A := IntermediateField.adjoin E0 {z} + let AK : IntermediateField K L := A.restrictScalars K + have hAK : AK = IntermediateField.adjoin K {z} := + restrictScalars_adjoin_over_adjoin_pow_eq_adjoin z m + let c : E0 := + ⟨z ^ m, IntermediateField.subset_adjoin K {z ^ m} + (Set.mem_singleton (z ^ m))⟩ + let q : Polynomial E0 := Polynomial.X ^ m - Polynomial.C c + have hqMonic : q.Monic := + Polynomial.monic_X_pow_sub_C c hm.ne' + have hqRoot : Polynomial.aeval z q = 0 := by simp [q, c] + have hzIntegral : IsIntegral E0 z := ⟨q, hqMonic, hqRoot⟩ + let : FiniteDimensional E0 A := + IntermediateField.adjoin.finiteDimensional hzIntegral + let : FiniteDimensional A L := by + change FiniteDimensional AK L + rw [hAK] + infer_instance + have : Module.Free A L := Module.Free.of_divisionRing A L + have : Module.Free E0 A := Module.Free.of_divisionRing E0 A + calc + Module.finrank E0 L = Module.finrank E0 A * Module.finrank A L := by + rw [Module.finrank_mul_finrank] + _ = m * Module.finrank A L := by + rw [finrank_adjoin_over_adjoin_pow_eq z hz m hm] + _ = m * Module.finrank (IntermediateField.adjoin K {z}) L := by + congr 1 + change Module.finrank AK L = _ + rw [hAK] + +/-- Exact source degree over the powered first coordinate. -/ +theorem finrank_over_firstPoweredCoordinate_eq + {K : Type*} [Field K] {f : MvPolynomial (Fin 2) K} + (hf : Irreducible f) (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (m : ℕ) (hm : 0 < m) : + letI := planeCurveCoordinateRing_isDomain hf + Module.finrank (FirstPoweredCoordinateSubfield f m) + (PlaneCurveFunctionField f) = + m * MvPolynomial.degreeOf 1 f := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let x := planeCurveFunction f 0 + have hx : Transcendental K x := + firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let : FiniteDimensional (FirstCoordinateSubfield f) + (PlaneCurveFunctionField f) := + finiteDimensional_over_firstCoordinate_of_irreducible hf hpartialSecond + rw [finrank_over_adjoin_pow_eq_mul x hx m hm, + finrank_over_firstCoordinate_eq_degreeOf_second_of_irreducible + hf hpartialSecond] + +/-- Exact source degree over the powered second coordinate. -/ +theorem finrank_over_secondPoweredCoordinate_eq + {K : Type*} [Field K] {f : MvPolynomial (Fin 2) K} + (hf : Irreducible f) (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (n : ℕ) (hn : 0 < n) : + letI := planeCurveCoordinateRing_isDomain hf + Module.finrank (SecondPoweredCoordinateSubfield f n) + (PlaneCurveFunctionField f) = + n * MvPolynomial.degreeOf 0 f := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let y := planeCurveFunction f 1 + have hy : Transcendental K y := + secondCoordinate_transcendental hf + (degreeOf_first_pos_of_pderiv_ne_zero hpartialFirst) + let : FiniteDimensional (SecondCoordinateSubfield f) + (PlaneCurveFunctionField f) := + (finiteSeparable_over_secondCoordinate_of_irreducible + hf hpartialFirst).1 + rw [finrank_over_adjoin_pow_eq_mul y hy n hn, + finrank_over_secondCoordinate_eq_degreeOf_first_of_irreducible + hf hpartialFirst] + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/CorvajaZannier/WronskianChangeParameter.lean b/LeanPool/MarkoffModP/BGS/CorvajaZannier/WronskianChangeParameter.lean new file mode 100644 index 0000000000..ff7bf63558 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/CorvajaZannier/WronskianChangeParameter.lean @@ -0,0 +1,212 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Algebra.DifferentialWronskian +public import Mathlib.LinearAlgebra.Matrix.Block + +/-! +# Change of parameter for ordinary Wronskians + +If two derivations on a field satisfy `D = a • E`, then the `i`-th iterate of +`D` is `a^i` times the `i`-th iterate of `E`, up to lower-order iterates of +`E`. Thus the corresponding Wronskian matrices differ by a lower-triangular +matrix whose diagonal is `1, a, a^2, ...`. This file records that argument; +in particular it does not make the false simplification `(a • E)^i = a^i • E^i`. +-/ + +@[expose] public section + +namespace BGS.CorvajaZannier + +noncomputable section + +open scoped Matrix +open Finset + +variable {C L : Type*} [Field C] [Field L] [Algebra C L] + +/-- Coefficients expressing the iterates of `a • E` in terms of the iterates +of `E`. The recurrence is the Leibniz rule written coefficientwise. -/ +private def changeParameterCoeff (E : Derivation C L L) (a : L) : ℕ → ℕ → L + | 0, k => if k = 0 then 1 else 0 + | n + 1, k => + a * (E (changeParameterCoeff E a n k) + + if k = 0 then 0 else changeParameterCoeff E a n (k - 1)) + +private lemma changeParameterCoeff_of_lt (E : Derivation C L L) (a : L) + {n k : ℕ} (h : n < k) : changeParameterCoeff E a n k = 0 := by + induction n generalizing k with + | zero => + simp [changeParameterCoeff, Nat.ne_of_gt h] + | succ n ih => + have hk : k ≠ 0 := by omega + have hnk : n < k := by omega + have hnkp : n < k - 1 := by omega + rw [changeParameterCoeff] + simp [hk, ih hnk, ih hnkp] + +private lemma changeParameterCoeff_diag (E : Derivation C L L) (a : L) (n : ℕ) : + changeParameterCoeff E a n n = a ^ n := by + induction n with + | zero => simp [changeParameterCoeff] + | succ n ih => + rw [changeParameterCoeff] + simp [changeParameterCoeff_of_lt E a (Nat.lt_succ_self n), ih, pow_succ, + mul_comm] + +private lemma derivation_iterate_succ (E : Derivation C L L) (n : ℕ) (x : L) : + E ((E.toLinearMap ^ n) x) = (E.toLinearMap ^ (n + 1)) x := by + rw [pow_succ', Module.End.mul_apply] + rfl + +private lemma changeParameterCoeff_sum_succ (E : Derivation C L L) (a x : L) (n : ℕ) : + ∑ k ∈ range (n + 2), + changeParameterCoeff E a (n + 1) k * (E.toLinearMap ^ k) x = + (∑ k ∈ range (n + 1), + (a * E (changeParameterCoeff E a n k)) * (E.toLinearMap ^ k) x) + + ∑ k ∈ range (n + 1), + (a * changeParameterCoeff E a n k) * (E.toLinearMap ^ (k + 1)) x := by + simp_rw [changeParameterCoeff] + have hsplit (k : ℕ) : + (a * + (E (changeParameterCoeff E a n k) + + if k = 0 then 0 else changeParameterCoeff E a n (k - 1))) * + (E.toLinearMap ^ k) x = + (a * E (changeParameterCoeff E a n k)) * (E.toLinearMap ^ k) x + + (a * (if k = 0 then 0 else changeParameterCoeff E a n (k - 1))) * + (E.toLinearMap ^ k) x := by + ring + simp_rw [hsplit, sum_add_distrib] + congr 1 + · rw [sum_range_succ] + simp [changeParameterCoeff_of_lt E a (Nat.lt_succ_self n)] + · rw [sum_range_succ'] + simp + +private lemma derivation_iterate_eq_changeParameterCoeff_sum + (D E : Derivation C L L) (a : L) (hD : D = a • E) (n : ℕ) (x : L) : + (D.toLinearMap ^ n) x = + ∑ k ∈ range (n + 1), + changeParameterCoeff E a n k * (E.toLinearMap ^ k) x := by + induction n with + | zero => simp [changeParameterCoeff] + | succ n ih => + calc + (D.toLinearMap ^ (n + 1)) x = D ((D.toLinearMap ^ n) x) := by + rw [pow_succ', Module.End.mul_apply] + rfl + _ = D (∑ k ∈ range (n + 1), + changeParameterCoeff E a n k * (E.toLinearMap ^ k) x) := by rw [ih] + _ = a * E (∑ k ∈ range (n + 1), + changeParameterCoeff E a n k * (E.toLinearMap ^ k) x) := by + rw [hD] + rfl + _ = ∑ k ∈ range (n + 1), + ((a * E (changeParameterCoeff E a n k)) * + (E.toLinearMap ^ k) x + + (a * changeParameterCoeff E a n k) * + (E.toLinearMap ^ (k + 1)) x) := by + rw [map_sum, mul_sum] + apply sum_congr rfl + intro k hk + rw [E.leibniz, derivation_iterate_succ] + simp only [smul_eq_mul] + ring + _ = (∑ k ∈ range (n + 1), + (a * E (changeParameterCoeff E a n k)) * + (E.toLinearMap ^ k) x) + + ∑ k ∈ range (n + 1), + (a * changeParameterCoeff E a n k) * + (E.toLinearMap ^ (k + 1)) x := by + rw [sum_add_distrib] + _ = ∑ k ∈ range (n + 2), + changeParameterCoeff E a (n + 1) k * + (E.toLinearMap ^ k) x := + (changeParameterCoeff_sum_succ E a x n).symm + +/-- The lower-triangular matrix relating the two lists of iterated +derivations. -/ +private def changeParameterMatrix (E : Derivation C L L) (a : L) (n : ℕ) : + Matrix (Fin n) (Fin n) L := + fun i k => changeParameterCoeff E a i k + +private lemma derivation_iterate_eq_changeParameterMatrix_sum + (D E : Derivation C L L) (a : L) (hD : D = a • E) {n : ℕ} + (i : Fin n) (x : L) : + (D.toLinearMap ^ (i : ℕ)) x = + ∑ k : Fin n, changeParameterMatrix E a n i k * + (E.toLinearMap ^ (k : ℕ)) x := by + let g : ℕ → L := fun k => + changeParameterCoeff E a (i : ℕ) k * (E.toLinearMap ^ k) x + have hsubset : range ((i : ℕ) + 1) ⊆ range n := + range_subset_range.mpr (Nat.succ_le_iff.mpr i.isLt) + have hsum : ∑ k ∈ range ((i : ℕ) + 1), g k = ∑ k ∈ range n, g k := by + apply sum_subset hsubset + intro k hkn hki + have hik : (i : ℕ) < k := by + rw [mem_range] at hkn + rw [mem_range] at hki + omega + simp [g, changeParameterCoeff_of_lt E a hik] + calc + (D.toLinearMap ^ (i : ℕ)) x = ∑ k ∈ range ((i : ℕ) + 1), g k := + derivation_iterate_eq_changeParameterCoeff_sum D E a hD i x + _ = ∑ k ∈ range n, g k := hsum + _ = ∑ k : Fin n, changeParameterMatrix E a n i k * + (E.toLinearMap ^ (k : ℕ)) x := by + simpa [g, changeParameterMatrix] using + (Fin.sum_univ_eq_sum_range g n).symm + +private lemma changeParameterMatrix_lowerTriangular + (E : Derivation C L L) (a : L) (n : ℕ) : + (changeParameterMatrix E a n).BlockTriangular OrderDual.toDual := by + intro i k hik + apply changeParameterCoeff_of_lt E a + exact OrderDual.toDual_lt_toDual.mp hik + +private lemma changeParameterMatrix_det + (E : Derivation C L L) (a : L) (n : ℕ) : + (changeParameterMatrix E a n).det = a ^ n.choose 2 := by + rw [Matrix.det_of_isLowerTriangular _ (changeParameterMatrix_lowerTriangular E a n)] + simp only [changeParameterMatrix, changeParameterCoeff_diag] + calc + ∏ i : Fin n, a ^ (i : ℕ) = a ^ ∑ i : Fin n, (i : ℕ) := by + simpa using (prod_pow_eq_pow_sum univ (fun i : Fin n => (i : ℕ)) a) + _ = a ^ n.choose 2 := by + congr 1 + rw [show (∑ i : Fin n, (i : ℕ)) = ∑ i ∈ range n, i from + Fin.sum_univ_eq_sum_range (fun i => i) n] + rw [sum_range_id, Nat.choose_two_right] + +private lemma derivationWronskian_eq_changeParameterMatrix_mul + (D E : Derivation C L L) (a : L) (hD : D = a • E) + {n : ℕ} (f : Fin n → L) : + BGS.Algebra.derivationWronskian D f = + changeParameterMatrix E a n * BGS.Algebra.derivationWronskian E f := by + ext i j + rw [Matrix.mul_apply] + simpa [BGS.Algebra.derivationWronskian] using + derivation_iterate_eq_changeParameterMatrix_sum D E a hD i (f j) + +/-- Change-of-parameter formula for an ordinary Wronskian. + +The triangular exponent is `n.choose 2 = 0 + 1 + ... + (n - 1)`. The proof +keeps all lower-order terms arising from differentiating `a`; they form the +strictly lower-triangular part of `changeParameterMatrix` and hence do not +affect its determinant. -/ +theorem derivationWronskian_det_changeParameter + (D E : Derivation C L L) (a : L) (hD : D = a • E) + {n : ℕ} (f : Fin n → L) : + (BGS.Algebra.derivationWronskian D f).det = + a ^ n.choose 2 * (BGS.Algebra.derivationWronskian E f).det := by + rw [derivationWronskian_eq_changeParameterMatrix_mul D E a hD f, + Matrix.det_mul, changeParameterMatrix_det] + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/Dynamics/FiniteForwardOrbit.lean b/LeanPool/MarkoffModP/BGS/Dynamics/FiniteForwardOrbit.lean new file mode 100644 index 0000000000..295e748289 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Dynamics/FiniteForwardOrbit.lean @@ -0,0 +1,53 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import Mathlib.Data.Set.Finite.Basic +public import Mathlib.Logic.Function.Iterate + +/-! +# Finite forward orbits of injective maps + +An injective self-map cannot have a finite forward orbit with a nonperiodic initial point. The +injectivity hypothesis is what lets us cancel the transient part of a repeated pair of iterates. +-/ + +@[expose] public section + +namespace BGS + +universe u + +variable {X : Type u} {f : X → X} {x : X} + +/-- If the forward orbit of `x` under an injective self-map is finite, then a positive iterate +returns to `x`. -/ +theorem exists_positive_iterate_eq_self_of_finite_forwardOrbit + (hf : Function.Injective f) + (horbit : (Set.range fun n : ℕ ↦ (f^[n]) x).Finite) : + ∃ n : ℕ, 0 < n ∧ (f^[n]) x = x := by + let orbitMap : ℕ → X := fun n ↦ (f^[n]) x + obtain ⟨m, -, n, -, hmn, hcollision⟩ := + Set.infinite_univ.exists_ne_map_eq_of_mapsTo + (f := orbitMap) (t := Set.range orbitMap) + (fun k _ ↦ ⟨k, rfl⟩) horbit + rcases lt_or_gt_of_ne hmn with hmn | hnm + · refine ⟨n - m, Nat.sub_pos_of_lt hmn, ?_⟩ + exact Function.iterate_cancel hf hcollision.symm + · refine ⟨m - n, Nat.sub_pos_of_lt hnm, ?_⟩ + exact Function.iterate_cancel hf hcollision + +/-- A finite set containing every forward iterate forces a positive return for an injective +self-map. This form is convenient when an orbit has already been bounded by a concrete finite +set. -/ +theorem exists_positive_iterate_eq_self_of_forwardOrbit_subset + (hf : Function.Injective f) {s : Set X} (hs : s.Finite) + (horbit : Set.range (fun n : ℕ ↦ (f^[n]) x) ⊆ s) : + ∃ n : ℕ, 0 < n ∧ (f^[n]) x = x := + exists_positive_iterate_eq_self_of_finite_forwardOrbit hf (hs.subset horbit) + +end BGS diff --git a/LeanPool/MarkoffModP/BGS/Dynamics/StrictMeasureEscape.lean b/LeanPool/MarkoffModP/BGS/Dynamics/StrictMeasureEscape.lean new file mode 100644 index 0000000000..3208012910 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Dynamics/StrictMeasureEscape.lean @@ -0,0 +1,44 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import Mathlib.Logic.Relation +public import Mathlib.Data.Nat.Order.Lemmas +public import Mathlib.Tactic + +/-! +# Escape by a strictly increasing measure + +Iterate admissible transitions to reach a prescribed lower bound for a strictly increasing +measure. +-/ + +@[expose] public section + +namespace BGS + +universe u + + +/-- If every state below a target measure admits a relation step that strictly raises the +measure, then finitely many such steps reach the target. -/ +theorem exists_reflTransGen_measure_ge + {X : Type u} (r : X → X → Prop) (measure : X → ℕ) (target : ℕ) + (step : ∀ x, measure x < target → ∃ y, r x y ∧ measure x < measure y) + (x : X) : + ∃ y, Relation.ReflTransGen r x y ∧ target ≤ measure y := by + by_cases hx : target ≤ measure x + · exact ⟨x, Relation.ReflTransGen.refl, hx⟩ + · have hxlt : measure x < target := Nat.lt_of_not_ge hx + obtain ⟨y, hxy, hmeasure⟩ := step x hxlt + obtain ⟨z, hyz, hz⟩ := + exists_reflTransGen_measure_ge r measure target step y + exact ⟨z, Relation.ReflTransGen.head hxy hyz, hz⟩ +termination_by target - measure x +decreasing_by omega + +end BGS diff --git a/LeanPool/MarkoffModP/BGS/External/GeneralCurveTheorems.lean b/LeanPool/MarkoffModP/BGS/External/GeneralCurveTheorems.lean new file mode 100644 index 0000000000..f5a58a3a6d --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/External/GeneralCurveTheorems.lean @@ -0,0 +1,157 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import Mathlib.Algebra.MvPolynomial.PDeriv +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.CorvajaZannierSourceBound +public import Mathlib.FieldTheory.IsAlgClosed.Basic +public import Mathlib.RingTheory.MvPolynomial.Basic + +/-! +# General curve-theorem interfaces + +These propositions are deliberately independent of the Markoff surface and +of every split, nonsplit, or cage family. Downstream code must construct the +relevant plane curve, prove its geometric hypotheses and bidegree bounds, and +then apply one of these two general statements. Both interfaces now have +in-repository inhabitants; keeping the propositions separate makes their +Markoff-specific applications explicit. +-/ + +@[expose] public section + +namespace BGS.External + +noncomputable section + +/-- A bivariate polynomial has coordinate degrees bounded by `firstDegree` +and `secondDegree`. -/ +def HasBidegreeAtMost {K : Type*} [CommSemiring K] + (f : MvPolynomial (Fin 2) K) (firstDegree secondDegree : ℕ) : Prop := + ∀ monomial : Fin 2 →₀ ℕ, monomial ∈ f.support → + monomial 0 ≤ firstDegree ∧ monomial 1 ≤ secondDegree + +/-- Affine rational zeros of a bivariate polynomial. -/ +noncomputable def affinePlaneCurveZeros + (K : Type*) [Field K] [Fintype K] [DecidableEq K] + (f : MvPolynomial (Fin 2) K) : Finset (K × K) := by + classical + exact Finset.univ.filter fun z => + MvPolynomial.eval ![z.1, z.2] f = 0 + +@[simp] +theorem mem_affinePlaneCurveZeros_iff + {K : Type*} [Field K] [Fintype K] [DecidableEq K] + {f : MvPolynomial (Fin 2) K} {z : K × K} : + z ∈ affinePlaneCurveZeros K f ↔ + MvPolynomial.eval ![z.1, z.2] f = 0 := by + classical + simp [affinePlaneCurveZeros] + +/-- A general affine plane-curve Hasse--Weil estimate with its coefficient +fixed in the type. Keeping this layer separate from the existential wrapper +makes numerical specializations auditable. -/ +def BivariateAffineHasseWeilBound (coefficient : ℕ) : Prop := + ∀ (K : Type) [Field K] [Fintype K] [DecidableEq K] + (f : MvPolynomial (Fin 2) K) (firstDegree secondDegree : ℕ), + 0 < firstDegree → + 0 < secondDegree → + HasBidegreeAtMost (K := K) f firstDegree secondDegree → + Irreducible + (MvPolynomial.map (algebraMap K (AlgebraicClosure K)) f) → + |((affinePlaneCurveZeros K f).card : ℝ) - + (Fintype.card K : ℝ)| ≤ + (coefficient : ℝ) * Real.sqrt (Fintype.card K : ℝ) * + (firstDegree : ℝ) * (secondDegree : ℝ) + +/-- The general affine plane-curve Hasse--Weil interface used by the Markoff +applications. + +This is the standard bidegree corollary of Hasse--Weil: normalization and the +boundary of a geometrically irreducible curve of positive bidegree contribute +only a universal multiple of `firstDegree * secondDegree`. -/ +def GeneralBivariateAffineHasseWeilTheorem : Prop := + ∃ coefficient : ℕ, 0 < coefficient ∧ + BivariateAffineHasseWeilBound coefficient + +/-- Torsion points of a general bivariate torus curve. -/ +noncomputable def torusCurveTorsionIntersection + (K : Type*) [Field K] [Fintype K] [DecidableEq K] + (f : MvPolynomial (Fin 2) K) (firstOrder secondOrder : ℕ) : + Finset (Kˣ × Kˣ) := by + classical + exact Finset.univ.filter fun z => + MvPolynomial.eval ![(z.1 : K), (z.2 : K)] f = 0 ∧ + z.1 ^ firstOrder = 1 ∧ z.2 ^ secondOrder = 1 + +@[simp] +theorem mem_torusCurveTorsionIntersection_iff + {K : Type*} [Field K] [Fintype K] [DecidableEq K] + {f : MvPolynomial (Fin 2) K} {firstOrder secondOrder : ℕ} + {z : Kˣ × Kˣ} : + z ∈ torusCurveTorsionIntersection K f firstOrder secondOrder ↔ + MvPolynomial.eval ![(z.1 : K), (z.2 : K)] f = 0 ∧ + z.1 ^ firstOrder = 1 ∧ z.2 ^ secondOrder = 1 := by + classical + simp [torusCurveTorsionIntersection] + +/-- No nontrivial character is constant on the geometric torus curve. -/ +def TorusCurveNotSubtorusTranslate + {K : Type*} [Field K] (f : MvPolynomial (Fin 2) K) : Prop := + ∀ (a b : ℤ), (a ≠ 0 ∨ b ≠ 0) → + ∀ c : (AlgebraicClosure K)ˣ, + ∃ x y : (AlgebraicClosure K)ˣ, + MvPolynomial.eval ![(x : AlgebraicClosure K), + (y : AlgebraicClosure K)] + (MvPolynomial.map (algebraMap K (AlgebraicClosure K)) f) = 0 ∧ + x ^ a * y ^ b ≠ c + +/-- A general plane torus curve satisfies the geometric hypotheses of the +Corvaja--Zannier theorem. Nonzero partial derivatives express that both +coordinate functions are separating; prime-to-characteristic torsion orders +then retain nonzero differentials. -/ +def IsCorvajaZannierPlaneCurve + {K : Type*} [Field K] (f : MvPolynomial (Fin 2) K) : Prop := + Irreducible + (MvPolynomial.map (algebraMap K (AlgebraicClosure K)) f) ∧ + TorusCurveNotSubtorusTranslate f ∧ + MvPolynomial.pderiv 0 f ≠ 0 ∧ MvPolynomial.pderiv 1 f ≠ 0 + +/-- A general bidegree-only upper bound for the Euler characteristic of the +normalization of a torus plane curve. For bidegree `(d₁,d₂)`, genus is at +most `(d₁-1)(d₂-1)` and the toric boundary has at most `2d₁+2d₂` points. -/ +def planeTorusEulerCharacteristicBound + (firstDegree secondDegree : ℕ) : ℝ := + 2 * firstDegree * secondDegree + +/-- The Corvaja--Zannier plane-curve interface, stated for every admissible +bivariate torus curve rather than for the weighted Markoff trace family. The +in-repository proof is `BGS.CorvajaZannier.generalCorvajaZannierPlaneCurveTheorem`; +the source proof and its formal dependency path are tracked in the dedicated +Blueprint chapter. -/ +def GeneralCorvajaZannierPlaneCurveTheorem : Prop := + ∀ (p : ℕ) [Fact p.Prime] + (K : Type) [Field K] [Fintype K] [DecidableEq K] [CharP K p] + (f : MvPolynomial (Fin 2) K) + (firstDegree secondDegree firstOrder secondOrder : ℕ), + 0 < firstDegree → + 0 < secondDegree → + HasBidegreeAtMost (K := K) f firstDegree secondDegree → + IsCorvajaZannierPlaneCurve f → + 0 < firstOrder → + 0 < secondOrder → + ¬ p ∣ firstOrder → + ¬ p ∣ secondOrder → + ((torusCurveTorsionIntersection + K f firstOrder secondOrder).card : ℝ) ≤ + BGS.Markoff.corvajaZannierCorollaryTwoNumericalBound + p firstOrder secondOrder firstDegree secondDegree + (planeTorusEulerCharacteristicBound firstDegree secondDegree) + +end + +end BGS.External diff --git a/LeanPool/MarkoffModP/BGS/FiniteField/EllipticCharacterSum.lean b/LeanPool/MarkoffModP/BGS/FiniteField/EllipticCharacterSum.lean new file mode 100644 index 0000000000..2377f9fb0b --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/FiniteField/EllipticCharacterSum.lean @@ -0,0 +1,198 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import Mathlib.NumberTheory.LegendreSymbol.QuadraticChar.Basic +public import Mathlib.AlgebraicGeometry.EllipticCurve.Affine.Point +public import Mathlib.SetTheory.Cardinal.NatCard + +/-! +# The explicit elliptic character sum needed by the incidence argument + +This file reduces the needed Legendre character-sum estimate to a narrow +point-cardinality target. The target is an explicit proposition parameter, +not a `sorry` or axiom; the selected Theorem 1 route does not use it. +-/ + +@[expose] public section + +namespace BGS.FiniteField + +open Finset + +variable {F : Type*} [Field F] [Fintype F] [DecidableEq F] + +/-- The quadratic-character trace sum of `Y² = X (X - u) (X - v)`. -/ +def ellipticCubicCharacterSum (u v : F) : ℤ := + ∑ x : F, quadraticChar F (x * (x - u) * (x - v)) + +/-- The Weierstrass model `Y² = X (X - u) (X - v)`. -/ +def legendreWeierstrassCurve (u v : F) : WeierstrassCurve F := + ⟨0, -(u + v), 0, u * v, 0⟩ + +omit [Fintype F] [DecidableEq F] in +lemma legendreWeierstrassCurve_equation_iff (u v x y : F) : + (legendreWeierstrassCurve u v).toAffine.Equation x y ↔ + y ^ 2 = x * (x - u) * (x - v) := by + rw [WeierstrassCurve.Affine.equation_iff] + simp only [legendreWeierstrassCurve, zero_mul, neg_mul, add_mul] + constructor <;> intro h + · linear_combination h + · linear_combination h + +omit [Fintype F] [DecidableEq F] in +lemma legendreWeierstrassCurve_discriminant (u v : F) : + (legendreWeierstrassCurve u v).Δ = 16 * u ^ 2 * v ^ 2 * (u - v) ^ 2 := by + simp only [legendreWeierstrassCurve, WeierstrassCurve.Δ, WeierstrassCurve.b₂, + WeierstrassCurve.b₄, WeierstrassCurve.b₆, WeierstrassCurve.b₈] + ring + +omit [Fintype F] [DecidableEq F] in +lemma legendreWeierstrassCurve_discriminant_ne_zero {u v : F} + (hu : u ≠ 0) (hv : v ≠ 0) (huv : u ≠ v) (hF : ringChar F ≠ 2) : + (legendreWeierstrassCurve u v).Δ ≠ 0 := by + rw [legendreWeierstrassCurve_discriminant] + have htwo : (2 : F) ≠ 0 := Ring.two_ne_zero hF + have hsixteen : (16 : F) ≠ 0 := by + rw [show (16 : F) = 2 ^ 4 by norm_num] + exact pow_ne_zero 4 htwo + exact mul_ne_zero (mul_ne_zero (mul_ne_zero hsixteen (pow_ne_zero 2 hu)) + (pow_ne_zero 2 hv)) (pow_ne_zero 2 (sub_ne_zero.mpr huv)) + +/-- Affine solutions, rearranged into fibers of the `X`-coordinate. -/ +def affineCubicSolutionEquivSigma (u v : F) : + {xy : F × F // xy.2 ^ 2 = xy.1 * (xy.1 - u) * (xy.1 - v)} ≃ + Σ x : F, {y : F // y ^ 2 = x * (x - u) * (x - v)} where + toFun xy := ⟨xy.1.1, xy.1.2, xy.2⟩ + invFun xy := ⟨(xy.1, xy.2.1), xy.2.2⟩ + left_inv _ := rfl + right_inv _ := rfl + +/-- The affine Weierstrass equation is exactly the displayed cubic equation. -/ +def legendreAffineEquationEquiv (u v : F) : + {xy : F × F // (legendreWeierstrassCurve u v).toAffine.Equation xy.1 xy.2} ≃ + {xy : F × F // xy.2 ^ 2 = xy.1 * (xy.1 - u) * (xy.1 - v)} where + toFun xy := ⟨xy.1, (legendreWeierstrassCurve_equation_iff u v xy.1.1 xy.1.2).mp xy.2⟩ + invFun xy := ⟨xy.1, (legendreWeierstrassCurve_equation_iff u v xy.1.1 xy.1.2).mpr xy.2⟩ + left_inv _ := rfl + right_inv _ := rfl + +lemma affineCubicSolution_card_eq_card_add_characterSum + (hF : ringChar F ≠ 2) (u v : F) : + (Fintype.card {xy : F × F // xy.2 ^ 2 = xy.1 * (xy.1 - u) * (xy.1 - v)} : ℤ) = + Fintype.card F + ellipticCubicCharacterSum u v := by + rw [Fintype.card_congr (affineCubicSolutionEquivSigma u v), Fintype.card_sigma] + push_cast + calc + ∑ x : F, (Fintype.card {y : F // y ^ 2 = x * (x - u) * (x - v)} : ℤ) = + ∑ x : F, (quadraticChar F (x * (x - u) * (x - v)) + 1) := by + apply sum_congr rfl + intro x _ + calc + (Fintype.card {y : F // y ^ 2 = x * (x - u) * (x - v)} : ℤ) = + ((({y : F | y ^ 2 = x * (x - u) * (x - v)} : Set F).toFinset.card : ℕ) : ℤ) := by + rw [Set.toFinset_card] + exact_mod_cast Fintype.card_congr + (Equiv.refl {y : F // y ^ 2 = x * (x - u) * (x - v)}) + _ = quadraticChar F (x * (x - u) * (x - v)) + 1 := + quadraticChar_card_sqrts hF (x * (x - u) * (x - v)) + _ = Fintype.card F + ellipticCubicCharacterSum u v := by + simp [ellipticCubicCharacterSum, sum_add_distrib, add_comm] + +omit [Fintype F] [DecidableEq F] in +/-- The nonsingularity hypotheses give an honest elliptic-curve instance for the Legendre model. -/ +theorem legendreWeierstrassCurveIsElliptic {u v : F} + (hF : ringChar F ≠ 2) (hu : u ≠ 0) (hv : v ≠ 0) (huv : u ≠ v) : + (legendreWeierstrassCurve u v).IsElliptic := + ⟨isUnit_iff_ne_zero.mpr (legendreWeierstrassCurve_discriminant_ne_zero hu hv huv hF)⟩ + +/-- The exact rational-point identity behind the cubic character sum. -/ +theorem legendreWeierstrassCurve_point_card_eq_card_add_one_add_characterSum + (hF : ringChar F ≠ 2) {u v : F} (hu : u ≠ 0) (hv : v ≠ 0) (huv : u ≠ v) : + (Nat.card (legendreWeierstrassCurve u v).toAffine.Point : ℤ) = + Fintype.card F + 1 + ellipticCubicCharacterSum u v := by + let W := legendreWeierstrassCurve u v + let : W.IsElliptic := legendreWeierstrassCurveIsElliptic hF hu hv huv + calc + (Nat.card W.toAffine.Point : ℤ) = + Nat.card (WithZero {xy : F × F // W.toAffine.Equation xy.1 xy.2}) := by + exact_mod_cast Nat.card_congr W.toAffine.pointEquiv + _ = Nat.card {xy : F × F // W.toAffine.Equation xy.1 xy.2} + 1 := by + change (Nat.card (Option {xy : F × F // W.toAffine.Equation xy.1 xy.2}) : ℤ) = _ + rw [Finite.card_option] + norm_num + _ = Nat.card {xy : F × F // xy.2 ^ 2 = xy.1 * (xy.1 - u) * (xy.1 - v)} + 1 := by + exact_mod_cast congrArg (fun n : ℕ => n + 1) + (Nat.card_congr (legendreAffineEquationEquiv u v)) + _ = Fintype.card {xy : F × F // xy.2 ^ 2 = xy.1 * (xy.1 - u) * (xy.1 - v)} + 1 := by + rw [Nat.card_eq_fintype_card] + _ = Fintype.card F + ellipticCubicCharacterSum u v + 1 := by + rw [affineCubicSolution_card_eq_card_add_characterSum hF u v] + _ = Fintype.card F + 1 + ellipticCubicCharacterSum u v := by ring + +/-- The cubic sum is the negative of the usual Frobenius trace `q + 1 - #E(F)`. -/ +theorem ellipticCubicCharacterSum_eq_point_card_sub_card_sub_one + (hF : ringChar F ≠ 2) {u v : F} (hu : u ≠ 0) (hv : v ≠ 0) (huv : u ≠ v) : + ellipticCubicCharacterSum u v = + (Nat.card (legendreWeierstrassCurve u v).toAffine.Point : ℤ) - Fintype.card F - 1 := by + have hcount := legendreWeierstrassCurve_point_card_eq_card_add_one_add_characterSum + hF hu hv huv + linarith + +/-- The desired character-sum estimate is exactly the Hasse rational-point bound for this model. -/ +theorem ellipticCubicCharacterSum_sq_le_four_mul_card_iff_point_card_hasse + (hF : ringChar F ≠ 2) {u v : F} (hu : u ≠ 0) (hv : v ≠ 0) (huv : u ≠ v) : + ellipticCubicCharacterSum u v ^ 2 ≤ 4 * (Fintype.card F : ℤ) ↔ + ((Nat.card (legendreWeierstrassCurve u v).toAffine.Point : ℤ) - + Fintype.card F - 1) ^ 2 ≤ 4 * (Fintype.card F : ℤ) := by + rw [ellipticCubicCharacterSum_eq_point_card_sub_card_sub_one hF hu hv huv] + +/-- The exact Legendre-family Hasse target. It is retained only as an +explicit premise for the optional incidence-diameter route. -/ +def LegendrePointCardHasseBound (F : Type*) + [Field F] [Fintype F] [DecidableEq F] : Prop := + ∀ {u v : F}, u ≠ 0 → v ≠ 0 → u ≠ v → + ((Nat.card (legendreWeierstrassCurve u v).toAffine.Point : ℤ) - + Fintype.card F - 1) ^ 2 ≤ 4 * (Fintype.card F : ℤ) + +/-- +The exact Hasse character-sum input needed in Proposition 6. Unlike the point-cardinality bound +above, this is now a proved reduction rather than a second gap. +-/ +theorem ellipticCubicCharacterSum_sq_le_four_mul_card + (hHasse : LegendrePointCardHasseBound F) + (hF : ringChar F ≠ 2) {u v : F} (hu : u ≠ 0) (hv : v ≠ 0) (huv : u ≠ v) : + ellipticCubicCharacterSum u v ^ 2 ≤ 4 * (Fintype.card F : ℤ) := by + exact (ellipticCubicCharacterSum_sq_le_four_mul_card_iff_point_card_hasse + hF hu hv huv).2 (hHasse hu hv huv) + +/-- For fields of cardinality at least `26`, Hasse's square bound is strong enough to leave more +than twelve points after the three forbidden fibers are removed. -/ +theorem fifteen_sub_card_lt_ellipticCubicCharacterSum + (hHasse : LegendrePointCardHasseBound F) + (hF : ringChar F ≠ 2) (hcard : 26 ≤ Fintype.card F) + {u v : F} (hu : u ≠ 0) (hv : v ≠ 0) (huv : u ≠ v) : + (15 : ℤ) - Fintype.card F < ellipticCubicCharacterSum u v := by + let q : ℤ := Fintype.card F + let trace : ℤ := ellipticCubicCharacterSum u v + have hq : (26 : ℤ) ≤ q := by + dsimp [q] + exact_mod_cast hcard + have hHasse : trace ^ 2 ≤ 4 * q := by + simpa [q, trace] using + ellipticCubicCharacterSum_sq_le_four_mul_card hHasse hF hu hv huv + by_contra hbound + have htrace : trace ≤ 15 - q := by omega + have hleftNonnegative : 0 ≤ -trace - (q - 15) := by omega + have hrightNonnegative : 0 ≤ -trace + (q - 15) := by omega + have hsquareLower : (q - 15) ^ 2 ≤ trace ^ 2 := by + nlinarith [mul_nonneg hleftNonnegative hrightNonnegative] + have hfactorPositive : 0 < (q - 9) * (q - 25) := + mul_pos (by omega) (by omega) + nlinarith + +end BGS.FiniteField diff --git a/LeanPool/MarkoffModP/BGS/FiniteField/HasseFrobenius.lean b/LeanPool/MarkoffModP/BGS/FiniteField/HasseFrobenius.lean new file mode 100644 index 0000000000..78ca220970 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/FiniteField/HasseFrobenius.lean @@ -0,0 +1,344 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.FiniteField.EllipticCharacterSum +public import Mathlib.FieldTheory.IsAlgClosed.AlgebraicClosure +public import Mathlib.FieldTheory.Finite.Basic + +/-! +# Frobenius setup for the explicit Hasse bound + +This work file develops the Frobenius--norm route to Hasse's bound for the explicit curve +`Y² = X (X - u) (X - v)`. It contains no replacement assumption for Hasse's theorem: the aim is +to isolate, in Mathlib's actual elliptic-point API, the first geometric degree calculation that is +still missing. +-/ + +@[expose] public section + +noncomputable section + +namespace BGS.FiniteField + +open Polynomial + +variable {F : Type*} [Field F] + +local instance algebraicClosureDecidableEq : + DecidableEq (AlgebraicClosure F) := Classical.decEq _ + +/-- The Legendre affine model after base change to an extension field. -/ +abbrev legendreAffineOver (u v : F) (K : Type*) [Field K] [Algebra F K] : + WeierstrassCurve.Affine K := + WeierstrassCurve.Affine.baseChange (legendreWeierstrassCurve u v).toAffine + K + +/-- Coordinatewise transport of a Legendre point along a field-extension homomorphism. + +Mathlib's bundled point map requires elliptic-curve group instances. This underlying map does not: +nonsingular points transport along every injective field homomorphism, including before we have +installed the nonsingularity hypotheses on the Legendre model. -/ +def mapLegendrePointCoordinates {K L : Type*} [Field K] [Field L] + [Algebra F K] [Algebra F L] (u v : F) (f : K →ₐ[F] L) : + (legendreAffineOver u v K).Point → (legendreAffineOver u v L).Point + | .zero => .zero + | .some x y h => .some (f x) (f y) + (((legendreWeierstrassCurve u v).toAffine.baseChange_nonsingular f.injective x y).mpr h) + +/-- The Legendre affine model over a fixed algebraic closure. -/ +abbrev legendreAffineOverClosure (u v : F) : WeierstrassCurve.Affine (AlgebraicClosure F) := + legendreAffineOver u v (AlgebraicClosure F) + +/-- Base change of an `F`-rational Legendre point to the algebraic closure. -/ +def legendrePointBaseChange (u v : F) : + (legendreWeierstrassCurve u v).toAffine.Point → + (legendreAffineOverClosure u v).Point + | .zero => .zero + | .some x y h => .some (algebraMap F (AlgebraicClosure F) x) + (algebraMap F (AlgebraicClosure F) y) + (((legendreWeierstrassCurve u v).toAffine.baseChange_nonsingular + (Algebra.ofId F (AlgebraicClosure F)).injective x y).mpr h) + +/-- Base change into the algebraic closure is injective on Legendre points. -/ +theorem legendrePointBaseChange_injective (u v : F) : + Function.Injective (legendrePointBaseChange u v) := by + rintro (_ | _) (_ | _) h + any_goals contradiction + · rfl + · simpa only [WeierstrassCurve.Affine.Point.some.injEq] using + And.intro + ((algebraMap F (AlgebraicClosure F)).injective + (WeierstrassCurve.Affine.Point.some.inj h).1) + ((algebraMap F (AlgebraicClosure F)).injective + (WeierstrassCurve.Affine.Point.some.inj h).2) + +section FiniteBaseField + +variable [Fintype F] + +/-- The `#F`-power Frobenius acting on points of the Legendre curve over an algebraic closure. -/ +def legendrePointFrobenius (u v : F) : + (legendreAffineOverClosure u v).Point → + (legendreAffineOverClosure u v).Point := + mapLegendrePointCoordinates u v (FiniteField.frobeniusAlgHom F (AlgebraicClosure F)) + +/-- The endomorphism `Frob - 1`; its kernel is the group of `F`-rational points. -/ +def legendreFrobeniusMinusIdentity (u v : F) : + (legendreAffineOverClosure u v).Point → + (legendreAffineOverClosure u v).Point := by + classical + exact fun P ↦ (legendrePointFrobenius u v P).add (-P) + +@[simp] +theorem legendrePointFrobenius_zero (u v : F) : + legendrePointFrobenius u v 0 = 0 := rfl + +/-- An algebraic-closure element fixed by the `#F`-power Frobenius comes from `F`. + +This is the coordinate descent input for identifying the kernel of `Frob - 1`: it is proved from +the complete root multiset of `X ^ #F - X`, rather than assumed as a fixed-field theorem. -/ +theorem exists_eq_algebraMap_of_frobenius_eq (z : AlgebraicClosure F) + (hz : FiniteField.frobeniusAlgHom F (AlgebraicClosure F) z = z) : + ∃ x : F, algebraMap F (AlgebraicClosure F) x = z := by + let P : F[X] := X ^ Fintype.card F - X + have hP0 : P ≠ 0 := by + exact FiniteField.X_pow_card_sub_X_ne_zero F Fintype.one_lt_card + have hsplit : P.Splits := by + rw [Polynomial.splits_iff_card_roots] + dsimp [P] + rw [FiniteField.roots_X_pow_card_sub_X, ← Finset.card_def, Finset.card_univ, + FiniteField.X_pow_card_sub_X_natDegree_eq F Fintype.one_lt_card] + have hzroot : (P.map (algebraMap F (AlgebraicClosure F))).IsRoot z := by + rw [Polynomial.IsRoot.def] + rw [Polynomial.eval_map] + dsimp [P] + simp only [Polynomial.eval₂_sub, Polynomial.eval₂_pow, Polynomial.eval₂_X] + exact sub_eq_zero.mpr hz + exact hsplit.mem_range_of_isRoot hP0 hzroot + +@[simp] +theorem legendrePointFrobenius_baseChange (u v : F) + (P : (legendreWeierstrassCurve u v).toAffine.Point) : + legendrePointFrobenius u v (legendrePointBaseChange u v P) = + legendrePointBaseChange u v P := by + cases P with + | zero => rfl + | some x y h => + simp only [legendrePointFrobenius, legendrePointBaseChange, + mapLegendrePointCoordinates, AlgHom.commutes] + +/-- Every Frobenius-fixed algebraic-closure point descends to an `F`-rational point. -/ +theorem exists_baseChange_eq_of_legendrePointFrobenius_eq (u v : F) + (P : (legendreAffineOverClosure u v).Point) + (hP : legendrePointFrobenius u v P = P) : + ∃ P₀ : (legendreWeierstrassCurve u v).toAffine.Point, + legendrePointBaseChange u v P₀ = P := by + cases P with + | zero => exact ⟨.zero, rfl⟩ + | some x y h => + have hxy : + FiniteField.frobeniusAlgHom F (AlgebraicClosure F) x = x ∧ + FiniteField.frobeniusAlgHom F (AlgebraicClosure F) y = y := by + simpa only [legendrePointFrobenius, mapLegendrePointCoordinates, + WeierstrassCurve.Affine.Point.some.injEq] using hP + obtain ⟨x₀, hx₀⟩ := exists_eq_algebraMap_of_frobenius_eq x hxy.1 + obtain ⟨y₀, hy₀⟩ := exists_eq_algebraMap_of_frobenius_eq y hxy.2 + have hmapped : + (legendreAffineOverClosure u v).Nonsingular + (algebraMap F (AlgebraicClosure F) x₀) + (algebraMap F (AlgebraicClosure F) y₀) := by + simpa only [hx₀, hy₀] using h + have hbase : (legendreWeierstrassCurve u v).toAffine.Nonsingular x₀ y₀ := + ((legendreWeierstrassCurve u v).toAffine.baseChange_nonsingular + (Algebra.ofId F (AlgebraicClosure F)).injective x₀ y₀).mp hmapped + refine ⟨.some x₀ y₀ hbase, ?_⟩ + simp only [legendrePointBaseChange, hx₀, hy₀] + +/-- `F`-rational Legendre points are exactly the Frobenius-fixed algebraic-closure points. -/ +def legendreRationalPointEquivFrobeniusFixed (u v : F) : + (legendreWeierstrassCurve u v).toAffine.Point ≃ + {P : (legendreAffineOverClosure u v).Point // legendrePointFrobenius u v P = P} := + Equiv.ofBijective + (fun P ↦ ⟨legendrePointBaseChange u v P, legendrePointFrobenius_baseChange u v P⟩) + ⟨fun P Q h ↦ legendrePointBaseChange_injective u v (congrArg Subtype.val h), + fun P ↦ by + obtain ⟨P₀, hP₀⟩ := + exists_baseChange_eq_of_legendrePointFrobenius_eq u v P.1 P.2 + exact ⟨P₀, Subtype.ext hP₀⟩⟩ + +/-- Point cardinality is the cardinality of the Frobenius fixed-point subtype. -/ +theorem legendre_point_card_eq_frobeniusFixed_card (u v : F) : + Nat.card (legendreWeierstrassCurve u v).toAffine.Point = + Nat.card {P : (legendreAffineOverClosure u v).Point // + legendrePointFrobenius u v P = P} := + Nat.card_congr (legendreRationalPointEquivFrobeniusFixed u v) + +section FrobeniusEndomorphism + +variable {u v : F} [(legendreWeierstrassCurve u v).IsElliptic] + +/-- The coordinate Frobenius as an endomorphism of the algebraic-closure point group. -/ +def legendrePointFrobeniusHom (u v : F) + [(legendreWeierstrassCurve u v).IsElliptic] : + (legendreAffineOverClosure u v).Point →+ + (legendreAffineOverClosure u v).Point := + WeierstrassCurve.Affine.Point.map + (W' := (legendreWeierstrassCurve u v).toAffine) + (FiniteField.frobeniusAlgHom F (AlgebraicClosure F)) + +@[simp] +theorem legendrePointFrobeniusHom_apply (u v : F) + [(legendreWeierstrassCurve u v).IsElliptic] + (P : (legendreAffineOverClosure u v).Point) : + legendrePointFrobeniusHom u v P = legendrePointFrobenius u v P := by + cases P <;> rfl + +/-- The group endomorphism `Frob - 1`. -/ +def legendreFrobeniusMinusIdentityHom (u v : F) + [(legendreWeierstrassCurve u v).IsElliptic] : + (legendreAffineOverClosure u v).Point →+ + (legendreAffineOverClosure u v).Point := + legendrePointFrobeniusHom u v - AddMonoidHom.id _ + +/-- The usual Frobenius trace `q + 1 - #E(F)`. This is the negative of the cubic character sum +used elsewhere in the incidence count. -/ +def legendreFrobeniusTrace (u v : F) : ℤ := + (Fintype.card F : ℤ) + 1 - Nat.card (legendreWeierstrassCurve u v).toAffine.Point + +/-- The single endomorphism used by the integral discriminant proof of Hasse's inequality: +`[t] - [2]Frob`, where `t = q + 1 - #E(F)` is the usual Frobenius trace. + +The remaining geometric wall is to construct an isogeny-degree theory strong enough to compute +the degree of this endomorphism as `frobeniusNormForm q t t 2 = 4q - t²`. -/ +def legendreHasseWitnessEndomorphism (u v : F) + [(legendreWeierstrassCurve u v).IsElliptic] : + (legendreAffineOverClosure u v).Point →+ + (legendreAffineOverClosure u v).Point := + legendreFrobeniusTrace u v • AddMonoidHom.id _ - + (2 : ℤ) • legendrePointFrobeniusHom u v + +/-- The rational-point fixed subtype is literally the kernel of `Frob - 1`. -/ +def legendreFrobeniusFixedEquivKernel (u v : F) + [(legendreWeierstrassCurve u v).IsElliptic] : + {P : (legendreAffineOverClosure u v).Point // legendrePointFrobenius u v P = P} ≃ + (legendreFrobeniusMinusIdentityHom u v).ker where + toFun P := ⟨P.1, by + change legendrePointFrobeniusHom u v P.1 - P.1 = 0 + rw [legendrePointFrobeniusHom_apply, P.2, sub_self]⟩ + invFun P := ⟨P.1, by + have hP := P.2 + change legendrePointFrobeniusHom u v P.1 - P.1 = 0 at hP + exact legendrePointFrobeniusHom_apply u v P.1 ▸ sub_eq_zero.mp hP⟩ + left_inv P := Subtype.ext rfl + right_inv P := Subtype.ext rfl + +/-- Rational points are equivalent to the kernel of `Frob - 1`. -/ +def legendreRationalPointEquivFrobeniusKernel (u v : F) + [(legendreWeierstrassCurve u v).IsElliptic] : + (legendreWeierstrassCurve u v).toAffine.Point ≃ + (legendreFrobeniusMinusIdentityHom u v).ker := + (legendreRationalPointEquivFrobeniusFixed u v).trans + (legendreFrobeniusFixedEquivKernel u v) + +/-- The point cardinality is the kernel cardinality of `Frob - 1`. -/ +theorem legendre_point_card_eq_frobeniusMinusIdentity_ker_card (u v : F) + [(legendreWeierstrassCurve u v).IsElliptic] : + Nat.card (legendreWeierstrassCurve u v).toAffine.Point = + Nat.card (legendreFrobeniusMinusIdentityHom u v).ker := + Nat.card_congr (legendreRationalPointEquivFrobeniusKernel u v) + +end FrobeniusEndomorphism + +@[simp] +theorem legendreFrobeniusMinusIdentity_baseChange (u v : F) + (P : (legendreWeierstrassCurve u v).toAffine.Point) : + legendreFrobeniusMinusIdentity u v + (legendrePointBaseChange u v P) = 0 := by + classical + change (legendrePointFrobenius u v (legendrePointBaseChange u v P)).add + (-(legendrePointBaseChange u v P)) = 0 + rw [legendrePointFrobenius_baseChange] + cases P with + | zero => rfl + | some x y h => + simp only [legendrePointBaseChange] + exact WeierstrassCurve.Affine.Point.add_of_Y_eq rfl + (WeierstrassCurve.Affine.negY_negY _ _).symm + +/-- The integer quadratic form which Hasse identifies with the degree of `m - n·Frob`. -/ +def frobeniusNormForm (q t m n : ℤ) : ℤ := + m ^ 2 - t * m * n + q * n ^ 2 + +/-- The norm-form value of Hasse's witness endomorphism is exactly the discriminant gap. -/ +theorem frobeniusNormForm_hasseWitness (q t : ℤ) : + frobeniusNormForm q t t 2 = 4 * q - t ^ 2 := by + simp only [frobeniusNormForm] + ring + +/-- A single nonnegative value of Hasse's norm form, at `(m,n) = (t,2)`, forces the +discriminant inequality. -/ +theorem sq_le_four_mul_of_frobeniusNormForm_nonnegative {q t : ℤ} + (hnorm : 0 ≤ frobeniusNormForm q t t 2) : t ^ 2 ≤ 4 * q := by + rw [frobeniusNormForm_hasseWitness] at hnorm + omega + +/-- The norm-form value which must be identified with the degree of +`legendreHasseWitnessEndomorphism`. This definition does not assume that identification. -/ +def legendreHasseNormWitness (u v : F) : ℤ := + let q : ℤ := Fintype.card F + let t : ℤ := legendreFrobeniusTrace u v + frobeniusNormForm q t t 2 + +/-! +### Exact remaining geometric statement + +The next theorem must construct a natural-valued algebraic degree for +`legendreHasseWitnessEndomorphism u v` and prove that its integer cast is +`legendreHasseNormWitness u v`. Nonnegativity would then be automatic and the theorem below would +close Hasse's bound. + +This cannot honestly be replaced by the cardinality of the kernel of the underlying abstract group +homomorphism: identifying kernel cardinality with algebraic degree already requires separability, +and the quadratic degree law is geometry, not abstract group theory. In the current Mathlib API, +the division polynomials are not connected to scalar multiplication on `Affine.Point`, the +`ωₙ` polynomial needed for the `Y`-coordinate is still absent, and no rational-map/isogeny degree or +parallelogram law is available. Thus even the minimal witness degree requires constructing those +interfaces in-repository. +-/ + +/-- Once the missing geometric degree calculation proves the norm witness nonnegative, the +arithmetic reduction gives exactly the desired point-cardinality bound. -/ +theorem legendreWeierstrassCurve_point_card_hasse_of_normWitness_nonnegative + {u v : F} (hnorm : 0 ≤ legendreHasseNormWitness u v) : + ((Nat.card (legendreWeierstrassCurve u v).toAffine.Point : ℤ) - + Fintype.card F - 1) ^ 2 ≤ 4 * (Fintype.card F : ℤ) := by + have htrace : legendreFrobeniusTrace u v ^ 2 ≤ 4 * (Fintype.card F : ℤ) := + sq_le_four_mul_of_frobeniusNormForm_nonnegative hnorm + convert htrace using 1 + simp only [legendreFrobeniusTrace] + ring + +/-- Nonnegativity of the explicit Frobenius norm witness is exactly the Hasse point-cardinality +inequality. Thus the missing algebraic-degree calculation is not merely sufficient: it is the +whole remaining Hasse wall. -/ +theorem legendreHasseNormWitness_nonnegative_iff_point_card_hasse (u v : F) : + 0 ≤ legendreHasseNormWitness u v ↔ + ((Nat.card (legendreWeierstrassCurve u v).toAffine.Point : ℤ) - + Fintype.card F - 1) ^ 2 ≤ 4 * (Fintype.card F : ℤ) := by + constructor + · exact legendreWeierstrassCurve_point_card_hasse_of_normWitness_nonnegative + · intro hhasse + simp only [legendreHasseNormWitness, frobeniusNormForm_hasseWitness, + legendreFrobeniusTrace] + nlinarith [sq_nonneg + ((Nat.card (legendreWeierstrassCurve u v).toAffine.Point : ℤ) - + Fintype.card F - 1)] + +end FiniteBaseField + +end BGS.FiniteField diff --git a/LeanPool/MarkoffModP/BGS/FiniteField/QuadraticCharacter.lean b/LeanPool/MarkoffModP/BGS/FiniteField/QuadraticCharacter.lean new file mode 100644 index 0000000000..6140ed02bd --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/FiniteField/QuadraticCharacter.lean @@ -0,0 +1,196 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import Mathlib.NumberTheory.JacobiSum.Basic +public import Mathlib.NumberTheory.LegendreSymbol.QuadraticChar.Basic + +/-! +# Quadratic character sums and conic points + +Evaluate quadratic character sums and use them to find conic points avoiding a prescribed small +exceptional set. +-/ + +@[expose] public section + +namespace BGS.FiniteField + +open Finset + +variable {F : Type*} [Field F] [Fintype F] [DecidableEq F] + +/-- Sum a function over the square map, with fiber sizes expressed by the quadratic character. -/ +theorem sum_comp_sq_eq_sum_quadraticChar_add_one + (hF : ringChar F ≠ 2) (f : F → ℤ) : + ∑ y : F, f (y ^ 2) = ∑ x : F, (quadraticChar F x + 1) * f x := by + classical + rw [← sum_fiberwise (s := univ) (g := fun y : F => y ^ 2) (f := fun y => f (y ^ 2))] + apply sum_congr rfl + intro x _ + have hcard : + ((#{y ∈ (univ : Finset F) | y ^ 2 = x} : ℕ) : ℤ) = quadraticChar F x + 1 := by + simpa [Set.toFinset_ofPred] using quadraticChar_card_sqrts hF x + calc + ∑ y ∈ (univ : Finset F) with y ^ 2 = x, f (y ^ 2) = + ∑ _y ∈ (univ : Finset F) with _y ^ 2 = x, f x := by + apply sum_congr rfl + intro y hy + rw [(mem_filter.mp hy).2] + _ = ((#{y ∈ (univ : Finset F) | y ^ 2 = x} : ℕ) : ℤ) * f x := by + simp + _ = (quadraticChar F x + 1) * f x := by rw [hcard] + +/-- The quadratic-character sum of `1 - d * y²` is a Jacobi sum. -/ +theorem sum_quadraticChar_one_sub_mul_sq + (hF : ringChar F ≠ 2) {d : F} (hd : d ≠ 0) : + ∑ y : F, quadraticChar F (1 - d * y ^ 2) = + -quadraticChar F d * quadraticChar F (-1) := by + let chi := quadraticChar F + have hzero : ∑ x : F, chi (1 - d * x) = 0 := by + let e : F ≃ F := (Equiv.mulLeft₀ d hd).trans (Equiv.subLeft 1) + calc + ∑ x : F, chi (1 - d * x) = ∑ x : F, chi (e x) := by + apply sum_congr rfl + intro x _ + simp [e] + _ = ∑ x : F, chi x := e.sum_comp chi + _ = 0 := quadraticChar_sum_zero hF + have hJacobi : jacobiSum chi chi = -chi (-1) := by + have hinv : chi⁻¹ = chi := by + dsimp [chi] + exact (quadraticChar_isQuadratic F).inv + calc + jacobiSum chi chi = jacobiSum chi chi⁻¹ := by rw [hinv] + _ = -chi (-1) := by + dsimp [chi] + exact jacobiSum_nontrivial_inv (quadraticChar_ne_one hF) + have hscaled : + chi d * (∑ x : F, chi x * chi (1 - d * x)) = jacobiSum chi chi := by + rw [mul_sum] + let e : F ≃ F := Equiv.mulLeft₀ d hd + calc + ∑ x : F, chi d * (chi x * chi (1 - d * x)) = + ∑ x : F, chi (e x) * chi (1 - e x) := by + apply sum_congr rfl + intro x _ + simp [e, mul_assoc] + _ = ∑ x : F, chi x * chi (1 - x) := + e.sum_comp (fun x => chi x * chi (1 - x)) + _ = jacobiSum chi chi := rfl + have hchi_sq : chi d ^ 2 = 1 := quadraticChar_sq_one hd + calc + ∑ y : F, chi (1 - d * y ^ 2) = + ∑ x : F, (chi x + 1) * chi (1 - d * x) := by + simpa [chi] using + sum_comp_sq_eq_sum_quadraticChar_add_one hF (fun x => chi (1 - d * x)) + _ = (∑ x : F, chi x * chi (1 - d * x)) + ∑ x : F, chi (1 - d * x) := by + simp_rw [add_mul, one_mul, sum_add_distrib] + _ = ∑ x : F, chi x * chi (1 - d * x) := by rw [hzero, add_zero] + _ = + chi d ^ 2 * ∑ x : F, chi x * chi (1 - d * x) := by rw [hchi_sq, one_mul] + _ = chi d * (chi d * ∑ x : F, chi x * chi (1 - d * x)) := by ring + _ = chi d * jacobiSum chi chi := by rw [hscaled] + _ = -chi d * chi (-1) := by rw [hJacobi]; ring + +/-- A nondegenerate quadratic polynomial has quadratic-character sum `-chi(A)`. -/ +theorem sum_quadraticChar_mul_sq_sub + (hF : ringChar F ≠ 2) {A C : F} (hA : A ≠ 0) (hC : C ≠ 0) : + ∑ y : F, quadraticChar F (A * y ^ 2 - C) = -quadraticChar F A := by + let chi := quadraticChar F + have hd : A / C ≠ 0 := div_ne_zero hA hC + have hinv : chi⁻¹ = chi := by + dsimp [chi] + exact (quadraticChar_isQuadratic F).inv + have hchiCinv : chi C⁻¹ = chi C := by + rw [← MulChar.inv_apply' chi C, hinv] + have hchiC_sq : chi C ^ 2 = 1 := quadraticChar_sq_one hC + have hchiNegOne_sq : chi (-1) ^ 2 = 1 := quadraticChar_sq_one (neg_ne_zero.mpr one_ne_zero) + calc + ∑ y : F, chi (A * y ^ 2 - C) = + ∑ y : F, chi ((-C) * (1 - (A / C) * y ^ 2)) := by + apply sum_congr rfl + intro y _ + congr 1 + field_simp [hC] + ring + _ = ∑ y : F, chi (-C) * chi (1 - (A / C) * y ^ 2) := by + simp only [map_mul] + _ = chi (-C) * ∑ y : F, chi (1 - (A / C) * y ^ 2) := by rw [mul_sum] + _ = chi (-C) * (-chi (A / C) * chi (-1)) := by + rw [sum_quadraticChar_one_sub_mul_sq hF hd] + _ = -chi A := by + rw [show -C = (-1) * C by ring, map_mul, div_eq_mul_inv, map_mul, hchiCinv] + calc + chi (-1) * chi C * (-(chi A * chi C) * chi (-1)) = + -(chi A) * (chi C ^ 2) * (chi (-1) ^ 2) := by ring + _ = -chi A := by rw [hchiC_sq, hchiNegOne_sq, mul_one, mul_one] + +/-- A nondegenerate affine conic has a point outside any set of at most three forbidden first +coordinates once the field has at least eight elements. -/ +theorem exists_quadratic_conic_point_away_from_three + (hF : ringChar F ≠ 2) (hcard : 8 ≤ Fintype.card F) + {A C : F} (hA : A ≠ 0) (hC : C ≠ 0) (bad : Finset F) (hbad : #bad ≤ 3) : + ∃ y, y ∉ bad ∧ ∃ lambda, lambda ^ 2 = A * y ^ 2 - C := by + classical + let roots (y : F) : Finset F := univ.filter fun lambda => lambda ^ 2 = A * y ^ 2 - C + let rootCount (y : F) : ℤ := #(roots y) + have hrootCount (y : F) : + rootCount y = quadraticChar F (A * y ^ 2 - C) + 1 := by + dsimp [rootCount, roots] + simpa [Set.toFinset_ofPred] using + quadraticChar_card_sqrts hF (A * y ^ 2 - C) + have hsum : + ∑ y : F, rootCount y = (Fintype.card F : ℤ) - quadraticChar F A := by + calc + ∑ y : F, rootCount y = + ∑ y : F, (quadraticChar F (A * y ^ 2 - C) + 1) := by + apply sum_congr rfl + intro y _ + exact hrootCount y + _ = (∑ y : F, quadraticChar F (A * y ^ 2 - C)) + ∑ _y : F, 1 := by + simp_rw [sum_add_distrib] + _ = -quadraticChar F A + (Fintype.card F : ℤ) := by + rw [sum_quadraticChar_mul_sq_sub hF hA hC] + simp + _ = (Fintype.card F : ℤ) - quadraticChar F A := by ring + have hrootCount_le (y : F) : rootCount y ≤ 2 := by + rw [hrootCount] + by_cases hzero : A * y ^ 2 - C = 0 + · rw [hzero, quadraticChar_zero] + norm_num + · rcases quadraticChar_dichotomy hzero with h | h <;> rw [h] <;> norm_num + by_contra hExists + have hzeroOutside (y : F) (hy : y ∉ bad) : rootCount y = 0 := by + have hnone : ∀ lambda : F, lambda ^ 2 ≠ A * y ^ 2 - C := by + intro lambda hlambda + exact hExists ⟨y, hy, lambda, hlambda⟩ + have hempty : roots y = ∅ := by + ext lambda + simp [roots, hnone lambda] + simp [rootCount, hempty] + have hrestrict : ∑ y ∈ bad, rootCount y = ∑ y : F, rootCount y := by + apply sum_subset (subset_univ bad) + intro y _ hy + exact hzeroOutside y hy + have hupper : ∑ y : F, rootCount y ≤ 6 := by + rw [← hrestrict] + calc + ∑ y ∈ bad, rootCount y ≤ ∑ _y ∈ bad, (2 : ℤ) := by + exact sum_le_sum fun y _ => hrootCount_le y + _ = (#bad : ℤ) * 2 := by simp + _ ≤ 6 := by exact_mod_cast Nat.mul_le_mul_right 2 hbad + have hchi_le : quadraticChar F A ≤ 1 := by + rcases quadraticChar_dichotomy hA with h | h + · omega + · omega + have hlower : 7 ≤ ∑ y : F, rootCount y := by + rw [hsum] + omega + omega + +end BGS.FiniteField diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/AffinePointPlace.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/AffinePointPlace.lean new file mode 100644 index 0000000000..d57e137d06 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/AffinePointPlace.lean @@ -0,0 +1,528 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.TorsionExhaustiveGcdDivisorBound + +/-! +# Finite places centered at affine rational points + +For an irreducible plane curve with both coordinates separating, this file +chooses an exhaustive finite place centered at each affine rational point. +Both coordinate differences have positive order at the selected place, and +distinct affine points give distinct places. + +The construction records the affine center through equality of valuation +subrings. It deliberately makes no residue-degree-one claim: above a +singular rational point, a chosen normalization branch need not be rational. +-/ + +@[expose] public section + +open IsDedekindDomain +open Multiplicative WithZero + +namespace BGS.HasseWeil + +open BGS.CorvajaZannier + +noncomputable section + +variable {K : Type*} [Field K] +variable {f : MvPolynomial (Fin 2) K} + +/-- The first coordinate minus its value at an affine point belongs to the +point's maximal ideal. -/ +theorem firstCoordinate_sub_mem_affinePlaneCurvePointMaximalIdeal + (z : AffinePlaneCurvePoint f) : + planeCurveCoordinate f 0 - + algebraMap K (PlaneCurveCoordinateRing f) z.1.1 ∈ + (affinePlaneCurvePointMaximalIdeal f z).asIdeal := by + change planeCurvePointEval f z + (planeCurveCoordinate f 0 - + algebraMap K (PlaneCurveCoordinateRing f) z.1.1) = 0 + simp + +/-- The second coordinate minus its value at an affine point belongs to the +point's maximal ideal. -/ +theorem secondCoordinate_sub_mem_affinePlaneCurvePointMaximalIdeal + (z : AffinePlaneCurvePoint f) : + planeCurveCoordinate f 1 - + algebraMap K (PlaneCurveCoordinateRing f) z.1.2 ∈ + (affinePlaneCurvePointMaximalIdeal f z).asIdeal := by + change planeCurvePointEval f z + (planeCurveCoordinate f 1 - + algebraMap K (PlaneCurveCoordinateRing f) z.1.2) = 0 + simp + +/-- A separating first coordinate cannot equal the constant first coordinate +of an affine point in the function field. -/ +theorem firstCoordinate_sub_affinePoint_ne_zero + (hf : Irreducible f) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (z : AffinePlaneCurvePoint f) : + letI := planeCurveCoordinateRing_isDomain hf + planeCurveFunction f 0 - + algebraMap K (PlaneCurveFunctionField f) z.1.1 ≠ 0 := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + have htrans : Transcendental K (planeCurveFunction f 0) := + firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + intro hzero + apply htrans + rw [sub_eq_zero.mp hzero] + exact isAlgebraic_algebraMap z.1.1 + +/-- A separating second coordinate cannot equal the constant second +coordinate of an affine point in the function field. -/ +theorem secondCoordinate_sub_affinePoint_ne_zero + (hf : Irreducible f) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (z : AffinePlaneCurvePoint f) : + letI := planeCurveCoordinateRing_isDomain hf + planeCurveFunction f 1 - + algebraMap K (PlaneCurveFunctionField f) z.1.2 ≠ 0 := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + have htrans : Transcendental K (planeCurveFunction f 1) := + secondCoordinate_transcendental hf + (degreeOf_first_pos_of_pderiv_ne_zero hpartialFirst) + intro hzero + apply htrans + rw [sub_eq_zero.mp hzero] + exact isAlgebraic_algebraMap z.1.2 + +private theorem ratFuncSpecialization_X_sub_C + {K E : Type*} [Field K] [Field E] [Algebra K E] + (x : E) (hx : Transcendental K x) (c : K) : + ratFuncSpecialization x hx + (algebraMap (Polynomial K) (RatFunc K) (Polynomial.X - Polynomial.C c)) = + x - algebraMap K E c := by + have hcomp := congrArg + (fun h : Polynomial K →+* E => h (Polynomial.X - Polynomial.C c)) + (ratFuncSpecialization_comp_polynomial_algebraMap x hx) + simpa using hcomp + +/-- Every affine rational point has an exhaustive finite place centered at +that point where both coordinate differences have positive order. -/ +theorem exists_affinePoint_exhaustiveFinitePlace_orders_positive + (hf : Irreducible f) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (z : AffinePlaneCurvePoint f) : + let := planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let := planeCurveFirstCoordinateRatFuncAlgebra f hx + let : Algebra (Polynomial K) (PlaneCurveFunctionField f) := + RingHom.toAlgebra + ((algebraMap (RatFunc K) (PlaneCurveFunctionField f)).comp + (algebraMap (Polynomial K) (RatFunc K))) + let : IsScalarTower (Polynomial K) (RatFunc K) + (PlaneCurveFunctionField f) := + IsScalarTower.of_algebraMap_eq' rfl + let : FiniteDimensional (RatFunc K) (PlaneCurveFunctionField f) := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : Algebra.IsSeparable (RatFunc K) (PlaneCurveFunctionField f) := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : IsDedekindDomain + (integralClosure (Polynomial K) (PlaneCurveFunctionField f)) := + integralClosure.isDedekindDomain (Polynomial K) (RatFunc K) + (PlaneCurveFunctionField f) + let : IsFractionRing + (integralClosure (Polynomial K) (PlaneCurveFunctionField f)) + (PlaneCurveFunctionField f) := + integralClosure.isFractionRing_of_finite_extension (RatFunc K) + (PlaneCurveFunctionField f) + ∃ q : HeightOneSpectrum + (integralClosure (Polynomial K) (PlaneCurveFunctionField f)), + IsDedekindDomain.HeightOneSpectrum.valuationSubringAtPrime + (PlaneCurveFunctionField f) q = + dominatingValuationSubring + (affinePlaneCurvePointMaximalIdeal f z) ∧ + 0 < finitePlaceOrder q + (planeCurveFunction f 0 - + algebraMap K (PlaneCurveFunctionField f) z.1.1) ∧ + 0 < finitePlaceOrder q + (planeCurveFunction f 1 - + algebraMap K (PlaneCurveFunctionField f) z.1.2) := by + intro domain hx ratFuncAlgebra polynomialAlgebra scalarTower finiteDimension separable + dedekind fraction + let A := PlaneCurveCoordinateRing f + let E := PlaneCurveFunctionField f + let B := integralClosure (Polynomial K) E + let m := affinePlaneCurvePointMaximalIdeal f z + let hbase : ∀ P : Polynomial K, + algebraMap (Polynomial K) E P ∈ (algebraMap A E).range := + polynomial_algebraMap_mem_planeCurveCoordinateRing_range hf hpartialSecond + let rfirst : A := planeCurveCoordinate f 0 - algebraMap K A z.1.1 + let rsecond : A := planeCurveCoordinate f 1 - algebraMap K A z.1.2 + let Pfirst : Polynomial K := Polynomial.X - Polynomial.C z.1.1 + let bfirst : B := algebraMap (Polynomial K) B Pfirst + have hfirstNonzero : + planeCurveFunction f 0 - algebraMap K E z.1.1 ≠ 0 := + firstCoordinate_sub_affinePoint_ne_zero hf hpartialSecond z + have hsecondNonzero : + planeCurveFunction f 1 - algebraMap K E z.1.2 ≠ 0 := + secondCoordinate_sub_affinePoint_ne_zero hf hpartialFirst z + have hrfirst : rfirst ∈ m.asIdeal := + firstCoordinate_sub_mem_affinePlaneCurvePointMaximalIdeal z + have hrsecond : rsecond ∈ m.asIdeal := + secondCoordinate_sub_mem_affinePlaneCurvePointMaximalIdeal z + have hrfirstMap : algebraMap A E rfirst = + planeCurveFunction f 0 - algebraMap K E z.1.1 := by + simp only [rfirst, map_sub] + rfl + have hrsecondMap : algebraMap A E rsecond = + planeCurveFunction f 1 - algebraMap K E z.1.2 := by + simp only [rsecond, map_sub] + rfl + have hPfirstMap : algebraMap (Polynomial K) E Pfirst = + planeCurveFunction f 0 - algebraMap K E z.1.1 := by + change ratFuncSpecialization (planeCurveFunction f 0) hx + (algebraMap (Polynomial K) (RatFunc K) Pfirst) = _ + exact ratFuncSpecialization_X_sub_C (planeCurveFunction f 0) hx z.1.1 + have hbfirstMap : algebraMap B E bfirst = + planeCurveFunction f 0 - algebraMap K E z.1.1 := by + rw [show algebraMap B E bfirst = + algebraMap (Polynomial K) E Pfirst by + exact IsScalarTower.algebraMap_apply (Polynomial K) B E Pfirst] + exact hPfirstMap + have hrfirstMap0 : algebraMap A E rfirst ≠ 0 := by + rwa [hrfirstMap] + have hrsecondMap0 : algebraMap A E rsecond ≠ 0 := by + rwa [hrsecondMap] + have hb : algebraMap B E bfirst = algebraMap A E rfirst := + hbfirstMap.trans hrfirstMap.symm + obtain ⟨q, hq, hfirst, hsecond⟩ := exists_integralClosurePlace_orders_positive + m hbase rfirst rsecond hrfirst hrsecond hrfirstMap0 hrsecondMap0 bfirst hb + exact ⟨q, hq, hrfirstMap ▸ hfirst, hrsecondMap ▸ hsecond⟩ + +variable [DecidableEq K] + +/-- The exhaustive finite place selected above an affine rational point. -/ +def affinePointExhaustiveFinitePlace + (hf : Irreducible f) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (z : AffinePlaneCurvePoint f) : + letI := planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + letI := planeCurveFirstCoordinateRatFuncAlgebra f hx + letI : Algebra (Polynomial K) (PlaneCurveFunctionField f) := + RingHom.toAlgebra + ((algebraMap (RatFunc K) (PlaneCurveFunctionField f)).comp + (algebraMap (Polynomial K) (RatFunc K))) + letI : IsScalarTower (Polynomial K) (RatFunc K) + (PlaneCurveFunctionField f) := + IsScalarTower.of_algebraMap_eq' rfl + letI : FiniteDimensional (RatFunc K) (PlaneCurveFunctionField f) := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + letI : Algebra.IsSeparable (RatFunc K) (PlaneCurveFunctionField f) := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + FiniteExtensionFinitePlace K (PlaneCurveFunctionField f) := by + exact Classical.choose + (exists_affinePoint_exhaustiveFinitePlace_orders_positive + hf hpartialFirst hpartialSecond z) + +omit [DecidableEq K] in +/-- The selected finite place has the prescribed affine center, and both +coordinate differences have positive order there. -/ +theorem affinePointExhaustiveFinitePlace_spec + (hf : Irreducible f) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (z : AffinePlaneCurvePoint f) : + letI := planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + letI := planeCurveFirstCoordinateRatFuncAlgebra f hx + letI : Algebra (Polynomial K) (PlaneCurveFunctionField f) := + RingHom.toAlgebra + ((algebraMap (RatFunc K) (PlaneCurveFunctionField f)).comp + (algebraMap (Polynomial K) (RatFunc K))) + letI : IsScalarTower (Polynomial K) (RatFunc K) + (PlaneCurveFunctionField f) := + IsScalarTower.of_algebraMap_eq' rfl + letI : FiniteDimensional (RatFunc K) (PlaneCurveFunctionField f) := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + letI : Algebra.IsSeparable (RatFunc K) (PlaneCurveFunctionField f) := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + IsDedekindDomain.HeightOneSpectrum.valuationSubringAtPrime + (PlaneCurveFunctionField f) + (affinePointExhaustiveFinitePlace + hf hpartialFirst hpartialSecond z) = + dominatingValuationSubring (affinePlaneCurvePointMaximalIdeal f z) ∧ + 0 < finitePlaceOrder + (affinePointExhaustiveFinitePlace + hf hpartialFirst hpartialSecond z) + (planeCurveFunction f 0 - + algebraMap K (PlaneCurveFunctionField f) z.1.1) ∧ + 0 < finitePlaceOrder + (affinePointExhaustiveFinitePlace + hf hpartialFirst hpartialSecond z) + (planeCurveFunction f 1 - + algebraMap K (PlaneCurveFunctionField f) z.1.2) := by + exact Classical.choose_spec + (exists_affinePoint_exhaustiveFinitePlace_orders_positive + hf hpartialFirst hpartialSecond z) + +omit [DecidableEq K] in +/-- Distinct affine rational points have distinct selected exhaustive finite +places. The proof uses equality of affine centers, not residue degrees. -/ +theorem affinePointExhaustiveFinitePlace_injective + (hf : Irreducible f) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) : + letI := planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + letI := planeCurveFirstCoordinateRatFuncAlgebra f hx + letI : Algebra (Polynomial K) (PlaneCurveFunctionField f) := + RingHom.toAlgebra + ((algebraMap (RatFunc K) (PlaneCurveFunctionField f)).comp + (algebraMap (Polynomial K) (RatFunc K))) + letI : IsScalarTower (Polynomial K) (RatFunc K) + (PlaneCurveFunctionField f) := + IsScalarTower.of_algebraMap_eq' rfl + letI : FiniteDimensional (RatFunc K) (PlaneCurveFunctionField f) := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + letI : Algebra.IsSeparable (RatFunc K) (PlaneCurveFunctionField f) := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + Function.Injective + (affinePointExhaustiveFinitePlace + hf hpartialFirst hpartialSecond) := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let : Algebra (RatFunc K) (PlaneCurveFunctionField f) := + planeCurveFirstCoordinateRatFuncAlgebra f hx + let : Algebra (Polynomial K) (PlaneCurveFunctionField f) := + RingHom.toAlgebra + ((algebraMap (RatFunc K) (PlaneCurveFunctionField f)).comp + (algebraMap (Polynomial K) (RatFunc K))) + let : IsScalarTower (Polynomial K) (RatFunc K) + (PlaneCurveFunctionField f) := + IsScalarTower.of_algebraMap_eq' rfl + let : FiniteDimensional (RatFunc K) (PlaneCurveFunctionField f) := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : Algebra.IsSeparable (RatFunc K) (PlaneCurveFunctionField f) := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + change Function.Injective + (affinePointExhaustiveFinitePlace hf hpartialFirst hpartialSecond) + intro z w hzw + apply affinePlaneCurvePointMaximalIdeal_injective f + apply MaximalSpectrum.ext + apply pointIdeal_eq_of_dominatingValuationSubring_eq + (A := PlaneCurveCoordinateRing f) + (L := PlaneCurveFunctionField f) + calc + dominatingValuationSubring (affinePlaneCurvePointMaximalIdeal f z) = + IsDedekindDomain.HeightOneSpectrum.valuationSubringAtPrime + (PlaneCurveFunctionField f) + (affinePointExhaustiveFinitePlace + hf hpartialFirst hpartialSecond z) := + (affinePointExhaustiveFinitePlace_spec + hf hpartialFirst hpartialSecond z).1.symm + _ = IsDedekindDomain.HeightOneSpectrum.valuationSubringAtPrime + (PlaneCurveFunctionField f) + (affinePointExhaustiveFinitePlace + hf hpartialFirst hpartialSecond w) := by + rw [hzw] + _ = dominatingValuationSubring + (affinePlaneCurvePointMaximalIdeal f w) := + (affinePointExhaustiveFinitePlace_spec + hf hpartialFirst hpartialSecond w).1 + +omit [DecidableEq K] in +/-- Any nonzero regular function vanishing at an affine point has positive +order at that point's selected finite place. -/ +theorem finitePlaceOrder_affinePointExhaustiveFinitePlace_pos_of_mem + (hf : Irreducible f) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (z : AffinePlaneCurvePoint f) + (r : PlaneCurveCoordinateRing f) + (hr : r ∈ (affinePlaneCurvePointMaximalIdeal f z).asIdeal) + (hr0 : algebraMap (PlaneCurveCoordinateRing f) + (PlaneCurveFunctionField f) r ≠ 0) : + letI := planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + letI := planeCurveFirstCoordinateRatFuncAlgebra f hx + letI : Algebra (Polynomial K) (PlaneCurveFunctionField f) := + RingHom.toAlgebra + ((algebraMap (RatFunc K) (PlaneCurveFunctionField f)).comp + (algebraMap (Polynomial K) (RatFunc K))) + letI : IsScalarTower (Polynomial K) (RatFunc K) + (PlaneCurveFunctionField f) := + IsScalarTower.of_algebraMap_eq' rfl + letI : FiniteDimensional (RatFunc K) (PlaneCurveFunctionField f) := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + letI : Algebra.IsSeparable (RatFunc K) (PlaneCurveFunctionField f) := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + 0 < finitePlaceOrder + (affinePointExhaustiveFinitePlace + hf hpartialFirst hpartialSecond z) + (algebraMap (PlaneCurveCoordinateRing f) + (PlaneCurveFunctionField f) r) := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let : Algebra (RatFunc K) (PlaneCurveFunctionField f) := + planeCurveFirstCoordinateRatFuncAlgebra f hx + let : Algebra (Polynomial K) (PlaneCurveFunctionField f) := + RingHom.toAlgebra + ((algebraMap (RatFunc K) (PlaneCurveFunctionField f)).comp + (algebraMap (Polynomial K) (RatFunc K))) + let : IsScalarTower (Polynomial K) (RatFunc K) + (PlaneCurveFunctionField f) := + IsScalarTower.of_algebraMap_eq' rfl + let : FiniteDimensional (RatFunc K) (PlaneCurveFunctionField f) := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : Algebra.IsSeparable (RatFunc K) (PlaneCurveFunctionField f) := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let E := PlaneCurveFunctionField f + let q := affinePointExhaustiveFinitePlace + hf hpartialFirst hpartialSecond z + let V := dominatingValuationSubring + (A := PlaneCurveCoordinateRing f) (L := E) + (affinePlaneCurvePointMaximalIdeal f z) + have hnonunits : + algebraMap (PlaneCurveCoordinateRing f) E r ∈ V.nonunits := + algebraMap_mem_dominatingValuationSubring_nonunits_of_mem + (A := PlaneCurveCoordinateRing f) + (L := E) (affinePlaneCurvePointMaximalIdeal f z) r hr + have hVlt : V.valuation + (algebraMap (PlaneCurveCoordinateRing f) E r) < 1 := + hnonunits + have hequiv : (q.valuation E).IsEquiv V.valuation := by + rw [Valuation.isEquiv_iff_valuationSubring, + ← IsDedekindDomain.HeightOneSpectrum.valuationSubringAtPrime_eq_valuationSubring, + ValuationSubring.valuationSubring_valuation] + exact (affinePointExhaustiveFinitePlace_spec + hf hpartialFirst hpartialSecond z).1 + have hqlt : q.valuation E + (algebraMap (PlaneCurveCoordinateRing f) E r) < 1 := + hequiv.lt_one_iff_lt_one.mpr hVlt + have horder := valuation_eq_exp_neg_finitePlaceOrder q + (algebraMap (PlaneCurveCoordinateRing f) E r) hr0 + rw [horder, ← exp_zero, exp_lt_exp] at hqlt + have hpos : 0 < finitePlaceOrder q + (algebraMap (PlaneCurveCoordinateRing f) E r) := by + omega + simpa [q, E] using hpos + +/-- A finite family of distinct affine rational points at which two fixed +nonzero regular functions vanish is bounded by their degree-weighted positive +gcd divisor. Positive place degree suffices; no selected place is asserted +to have degree one. -/ +theorem affinePointFamily_card_le_finiteExtensionGcdWeightedDegree + {ι : Type*} [Fintype ι] + (hf : Irreducible f) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (point : ι → AffinePlaneCurvePoint f) + (hpoint : Function.Injective point) + (r s : PlaneCurveCoordinateRing f) + (hr : ∀ i, r ∈ (affinePlaneCurvePointMaximalIdeal f (point i)).asIdeal) + (hs : ∀ i, s ∈ (affinePlaneCurvePointMaximalIdeal f (point i)).asIdeal) + (hr0 : algebraMap (PlaneCurveCoordinateRing f) + (PlaneCurveFunctionField f) r ≠ 0) + (hs0 : algebraMap (PlaneCurveCoordinateRing f) + (PlaneCurveFunctionField f) s ≠ 0) : + letI := planeCurveCoordinateRing_isDomain hf + letI : DecidableEq (RatFunc K) := Classical.decEq (RatFunc K) + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + letI := planeCurveFirstCoordinateRatFuncAlgebra f hx + letI : FiniteDimensional (RatFunc K) (PlaneCurveFunctionField f) := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + letI : Algebra.IsSeparable (RatFunc K) (PlaneCurveFunctionField f) := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + Fintype.card ι ≤ finiteExtensionGcdWeightedDegree K + (PlaneCurveFunctionField f) + (algebraMap (PlaneCurveCoordinateRing f) + (PlaneCurveFunctionField f) r) + (algebraMap (PlaneCurveCoordinateRing f) + (PlaneCurveFunctionField f) s) := by + classical + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let : DecidableEq (RatFunc K) := Classical.decEq (RatFunc K) + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let : Algebra (RatFunc K) (PlaneCurveFunctionField f) := + planeCurveFirstCoordinateRatFuncAlgebra f hx + let : Algebra (Polynomial K) (PlaneCurveFunctionField f) := + RingHom.toAlgebra + ((algebraMap (RatFunc K) (PlaneCurveFunctionField f)).comp + (algebraMap (Polynomial K) (RatFunc K))) + let : IsScalarTower (Polynomial K) (RatFunc K) + (PlaneCurveFunctionField f) := + IsScalarTower.of_algebraMap_eq' rfl + let : FiniteDimensional (RatFunc K) (PlaneCurveFunctionField f) := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : Algebra.IsSeparable (RatFunc K) (PlaneCurveFunctionField f) := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let E := PlaneCurveFunctionField f + let x : E := algebraMap (PlaneCurveCoordinateRing f) E r + let y : E := algebraMap (PlaneCurveCoordinateRing f) E s + let finitePlace : ι → FiniteExtensionFinitePlace K E := fun i => + affinePointExhaustiveFinitePlace + hf hpartialFirst hpartialSecond (point i) + let _ : DecidableEq (FiniteExtensionPlace K E) := Classical.decEq _ + let place : ι → FiniteExtensionPlace K E := fun i => .inl (finitePlace i) + have hFinitePlaceInjective : Function.Injective finitePlace := + (affinePointExhaustiveFinitePlace_injective + hf hpartialFirst hpartialSecond).comp hpoint + have hPlaceInjective : Function.Injective place := by + intro i j hij + apply hFinitePlaceInjective + exact Sum.inl_injective hij + have hImageSubset : Finset.univ.image place ⊆ + finiteExtensionGcdSupport K E x y := by + intro v hv + obtain ⟨i, -, rfl⟩ := Finset.mem_image.mp hv + have hri : 0 < finitePlaceOrder (finitePlace i) x := + finitePlaceOrder_affinePointExhaustiveFinitePlace_pos_of_mem + hf hpartialFirst hpartialSecond (point i) r (hr i) hr0 + exact inl_mem_finiteExtensionGcdSupport_of_orders_positive + K E x y (finitePlace i) hri + calc + Fintype.card ι = (Finset.univ.image place).card := by + rw [Finset.card_image_of_injective _ hPlaceInjective, + Finset.card_univ] + _ = ∑ v ∈ Finset.univ.image place, 1 := by simp + _ ≤ ∑ v ∈ Finset.univ.image place, + finiteExtensionGcdMultiplicity K E x y v * + finiteExtensionPlaceDegree K E v := by + apply Finset.sum_le_sum + intro v hv + obtain ⟨i, -, rfl⟩ := Finset.mem_image.mp hv + have hri : 0 < finitePlaceOrder (finitePlace i) x := + finitePlaceOrder_affinePointExhaustiveFinitePlace_pos_of_mem + hf hpartialFirst hpartialSecond (point i) r (hr i) hr0 + have hsi : 0 < finitePlaceOrder (finitePlace i) y := + finitePlaceOrder_affinePointExhaustiveFinitePlace_pos_of_mem + hf hpartialFirst hpartialSecond (point i) s (hs i) hs0 + exact one_le_finiteExtensionGcdMultiplicity_mul_degree_inl_of_orders_positive + K E x y (finitePlace i) hri hsi + _ ≤ ∑ v ∈ finiteExtensionGcdSupport K E x y, + finiteExtensionGcdMultiplicity K E x y v * + finiteExtensionPlaceDegree K E v := by + exact Finset.sum_le_sum_of_subset_of_nonneg hImageSubset (by omega) + _ = finiteExtensionGcdWeightedDegree K E x y := by + rfl + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/CechRiemannLinearAlgebra.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/CechRiemannLinearAlgebra.lean new file mode 100644 index 0000000000..ddf6cd6158 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/CechRiemannLinearAlgebra.lean @@ -0,0 +1,165 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import Mathlib.LinearAlgebra.FiniteDimensional.Lemmas +public import Mathlib.LinearAlgebra.Isomorphisms + +/-! +# The linear-algebra inequality in the Cech proof of Riemann's inequality + +Let `A ≤ A'` and `B` be subspaces of a vector space `V`. The canonical map + +`A' / A → V / (A ⊔ B)` + +has kernel canonically represented by + +`(A' ⊓ B) / (A ⊓ B)`. + +Rank--nullity therefore gives + +`finrank (A' / A) ≤ finrank ((A' ⊓ B) / (A ⊓ B)) + finrank (V / (A ⊔ B))`. + +Only the three quotient spaces occurring in this argument need to be +finite-dimensional; the ambient space `V` and the subspaces themselves may +be infinite-dimensional. This is the abstract finite-dimensional step used +by the Cech proof of Riemann's inequality. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +open Submodule + +noncomputable section + +variable {K V : Type*} [Field K] [AddCommGroup V] [Module K V] + +/-- The copy of `A` inside `A'`. When `A ≤ A'`, this is the denominator in +the relative quotient `A' / A`. -/ +abbrev relativeSubmodule (A A' : Submodule K V) : Submodule K A' := + A.comap A'.subtype + +/-- The canonical map `A' / A → V / (A ⊔ B)` used in the Cech argument. -/ +def cechRelativeQuotientMap (A A' B : Submodule K V) : + (A' ⧸ relativeSubmodule A A') →ₗ[K] V ⧸ (A ⊔ B) := + (relativeSubmodule A A').mapQ (A ⊔ B) A'.subtype + (comap_mono le_sup_left) + +/-- The quotient `(A' ⊓ B) / (A ⊓ B)` maps naturally into `A' / A`. -/ +def cechIntersectionQuotientMap (A A' B : Submodule K V) : + (↥(A' ⊓ B) ⧸ (A ⊓ B).comap (A' ⊓ B).subtype) →ₗ[K] + A' ⧸ relativeSubmodule A A' := + let sourceDenominator := (A ⊓ B).comap (A' ⊓ B).subtype + let targetDenominator := relativeSubmodule A A' + let inclusion : ↥(A' ⊓ B) →ₗ[K] A' := Submodule.inclusion inf_le_left + sourceDenominator.liftQ (targetDenominator.mkQ.comp inclusion) <| by + intro x hx + rw [LinearMap.mem_ker, LinearMap.comp_apply, Submodule.mkQ_apply, + Submodule.Quotient.mk_eq_zero] + change (x : V) ∈ A + exact hx.1 + +theorem cechIntersectionQuotientMap_injective (A A' B : Submodule K V) : + Function.Injective (cechIntersectionQuotientMap A A' B) := by + rw [← LinearMap.ker_eq_bot] + apply Submodule.ker_liftQ_eq_bot + intro x hx + change (x : V) ∈ A ⊓ B + have hxA : (x : V) ∈ A := by + simpa [cechIntersectionQuotientMap, relativeSubmodule] using hx + exact ⟨hxA, x.property.2⟩ + +private theorem comap_sup_eq_sup_comap_of_le + (A A' B : Submodule K V) (hAA' : A ≤ A') : + (A ⊔ B).comap A'.subtype = + relativeSubmodule A A' ⊔ B.comap A'.subtype := by + apply le_antisymm + · intro x hx + have hx' : (x : V) ∈ A' ⊓ (A ⊔ B) := ⟨x.property, hx⟩ + have hmodular : A' ⊓ (A ⊔ B) = A ⊔ (A' ⊓ B) := by + calc + A' ⊓ (A ⊔ B) = A' ⊓ (B ⊔ A) := by rw [sup_comm A B] + _ = (A' ⊓ B) ⊔ A := (inf_sup_assoc_of_le B hAA').symm + _ = A ⊔ (A' ⊓ B) := sup_comm _ _ + rw [hmodular] at hx' + obtain ⟨a, ha, b, hb, hab⟩ := Submodule.mem_sup.mp hx' + refine Submodule.mem_sup.mpr + ⟨⟨a, hAA' ha⟩, ha, ⟨b, hb.1⟩, hb.2, ?_⟩ + exact Subtype.ext hab + · exact sup_le (comap_mono le_sup_left) (comap_mono le_sup_right) + +/-- The intersection quotient identifies exactly with the kernel of the Cech +relative quotient map. -/ +theorem range_cechIntersectionQuotientMap_eq_ker + (A A' B : Submodule K V) (hAA' : A ≤ A') : + LinearMap.range (cechIntersectionQuotientMap A A' B) = + LinearMap.ker (cechRelativeQuotientMap A A' B) := by + rw [cechIntersectionQuotientMap, Submodule.range_liftQ, + LinearMap.range_comp, Submodule.range_inclusion] + simp only [comap_inf, comap_subtype_self, top_inf_eq] + rw [cechRelativeQuotientMap, Submodule.ker_mapQ, + comap_sup_eq_sup_comap_of_le A A' B hAA', Submodule.map_sup, + Submodule.mkQ_map_self, bot_sup_eq] + +/-- Rank--nullity with the Cech kernel written as the intersection quotient. +This equality is the strongest finite-dimensional form of the abstract +linear-algebra argument. -/ +theorem finrank_relativeQuotient_eq_infQuotient_add_range + (A A' B : Submodule K V) (hAA' : A ≤ A') + [Module.Finite K (A' ⧸ relativeSubmodule A A')] : + Module.finrank K (A' ⧸ relativeSubmodule A A') = + Module.finrank K (↥(A' ⊓ B) ⧸ (A ⊓ B).comap (A' ⊓ B).subtype) + + Module.finrank K (LinearMap.range (cechRelativeQuotientMap A A' B)) := by + have hker := range_cechIntersectionQuotientMap_eq_ker A A' B hAA' + have hinj := cechIntersectionQuotientMap_injective A A' B + calc + Module.finrank K (A' ⧸ relativeSubmodule A A') = + Module.finrank K (LinearMap.range (cechRelativeQuotientMap A A' B)) + + Module.finrank K (LinearMap.ker (cechRelativeQuotientMap A A' B)) := + (LinearMap.finrank_range_add_finrank_ker _).symm + _ = Module.finrank K (LinearMap.range (cechRelativeQuotientMap A A' B)) + + Module.finrank K + (↥(A' ⊓ B) ⧸ (A ⊓ B).comap (A' ⊓ B).subtype) := by + rw [← hker, LinearMap.finrank_range_of_inj hinj] + _ = Module.finrank K + (↥(A' ⊓ B) ⧸ (A ⊓ B).comap (A' ⊓ B).subtype) + + Module.finrank K (LinearMap.range (cechRelativeQuotientMap A A' B)) := + Nat.add_comm _ _ + +/-- The abstract finite-dimensional inequality behind the Cech proof of +Riemann's inequality. No finite-dimensionality hypothesis is imposed on +the ambient vector space. -/ +theorem finrank_relativeQuotient_le_infQuotient_add_supQuotient + (A A' B : Submodule K V) (hAA' : A ≤ A') + [Module.Finite K (A' ⧸ relativeSubmodule A A')] + [Module.Finite K (V ⧸ (A ⊔ B))] : + Module.finrank K (A' ⧸ relativeSubmodule A A') ≤ + Module.finrank K (↥(A' ⊓ B) ⧸ (A ⊓ B).comap (A' ⊓ B).subtype) + + Module.finrank K (V ⧸ (A ⊔ B)) := by + rw [finrank_relativeQuotient_eq_infQuotient_add_range A A' B hAA'] + exact Nat.add_le_add_left + (LinearMap.range (cechRelativeQuotientMap A A' B)).finrank_le _ + +/-- Subtractive form of +`finrank_relativeQuotient_le_infQuotient_add_supQuotient`, convenient when +the intersection quotient is the desired lower bound. -/ +theorem finrank_relativeQuotient_sub_supQuotient_le_infQuotient + (A A' B : Submodule K V) (hAA' : A ≤ A') + [Module.Finite K (A' ⧸ relativeSubmodule A A')] + [Module.Finite K (V ⧸ (A ⊔ B))] : + Module.finrank K (A' ⧸ relativeSubmodule A A') - + Module.finrank K (V ⧸ (A ⊔ B)) ≤ + Module.finrank K (↥(A' ⊓ B) ⧸ (A ⊓ B).comap (A' ⊓ B).subtype) := by + apply Nat.sub_le_iff_le_add.mpr + simpa [Nat.add_comm] using + finrank_relativeQuotient_le_infQuotient_add_supQuotient A A' B hAA' + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/ClosedPlaceEulerRecurrence.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/ClosedPlaceEulerRecurrence.lean new file mode 100644 index 0000000000..14f1d4fff9 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/ClosedPlaceEulerRecurrence.lean @@ -0,0 +1,616 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionEffectiveDivisorSplit +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionPlaceDegreeFiniteness +public import LeanPool.MarkoffModP.BGS.HasseWeil.FormalZetaEuler +public import Mathlib.Data.Finsupp.Weight + +/-! +# The closed-place Euler recurrence + +For a finite family of positive integral weights, an effective divisor is a +finitely supported family of multiplicities. Marking one occurrence of one +place, together with one of as many labels as the place's weight, gives the +coefficient recurrence obtained by logarithmically differentiating the Euler +product. + +This file proves that recurrence by an explicit bijection. It then uses the +local finiteness of bounded-degree places to apply the finite combinatorial +result to all exhaustive places of a finite extension of `K(X)`. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +open scoped BigOperators + +noncomputable section + +section FiniteWeightedFamily + +variable {I : Type*} [Fintype I] [DecidableEq I] + +/-- Natural-valued divisors of a prescribed weighted degree. -/ +abbrev WeightedEffectiveDivisor (w : I → ℕ) (n : ℕ) := + {D : I →₀ ℕ // Finsupp.weight w D = n} + +/-- A finite enumeration of weighted effective divisors when every weight is nonzero. -/ +@[reducible] noncomputable def weightedEffectiveDivisorFintype + (w : I → ℕ) (hw : ∀ i, w i ≠ 0) (n : ℕ) : + Fintype (WeightedEffectiveDivisor w n) := + Set.Finite.fintype (Finsupp.finite_of_nat_weight_eq w hw n) + +@[ext] +private structure WeightedMarkedEffectiveDivisor (w : I → ℕ) (n : ℕ) where + divisor : I →₀ ℕ + place : I + occurrence : ℕ + label : ℕ + weight_eq : Finsupp.weight w divisor = n + occurrence_lt : occurrence < divisor place + label_lt : label < w place + +@[ext] +private structure WeightedEulerDecomposition (w : I → ℕ) (n : ℕ) where + leftDegree : ℕ + rightDegree : ℕ + split_eq : leftDegree + rightDegree = n + divisor : I →₀ ℕ + divisor_weight : Finsupp.weight w divisor = leftDegree + place : I + divides : w place ∣ rightDegree + 1 + label : ℕ + label_lt : label < w place + +private def weightedMarkedToEulerDecomposition + (w : I → ℕ) (hw : ∀ i, 0 < w i) (n : ℕ) : + WeightedMarkedEffectiveDivisor w (n + 1) → + WeightedEulerDecomposition w n := by + intro x + let t := x.occurrence + 1 + let r := t * w x.place + have htpos : 0 < t := by simp [t] + have hrpos : 0 < r := Nat.mul_pos htpos (hw x.place) + have htcoeff : t ≤ x.divisor x.place := by + dsimp [t] + exact x.occurrence_lt + have hsingle : Finsupp.single x.place t ≤ x.divisor := + Finsupp.single_le_iff.mpr htcoeff + let E := x.divisor - Finsupp.single x.place t + have hrestore : E + Finsupp.single x.place t = x.divisor := + tsub_add_cancel_of_le hsingle + have hweight : Finsupp.weight w E + r = n + 1 := by + have h := congrArg (Finsupp.weight w) hrestore + simpa [E, r, Finsupp.weight_single, add_comm] using + h.trans x.weight_eq + have hrle : r ≤ n + 1 := by omega + have hEweight : Finsupp.weight w E = n + 1 - r := by omega + refine { + leftDegree := n + 1 - r + rightDegree := r - 1 + split_eq := ?_ + divisor := E + divisor_weight := hEweight + place := x.place + divides := ⟨t, ?_⟩ + label := x.label + label_lt := x.label_lt } + · omega + · rw [Nat.sub_add_cancel hrpos] + simp [r, Nat.mul_comm] + +private def weightedEulerDecompositionToMarked + (w : I → ℕ) (_hw : ∀ i, 0 < w i) (n : ℕ) : + WeightedEulerDecomposition w n → + WeightedMarkedEffectiveDivisor w (n + 1) := by + intro x + let r := x.rightDegree + 1 + let t := r / w x.place + have htprod : t * w x.place = r := Nat.div_mul_cancel x.divides + have htpos : 0 < t := by + by_contra ht + have htzero : t = 0 := Nat.eq_zero_of_not_pos ht + rw [htzero, zero_mul] at htprod + simp [r] at htprod + let D := x.divisor + Finsupp.single x.place t + have hweight : Finsupp.weight w D = n + 1 := by + rw [show Finsupp.weight w D = + Finsupp.weight w x.divisor + t * w x.place by + simp [D, Finsupp.weight_single]] + rw [x.divisor_weight, htprod] + dsimp [r] + have hsplit := x.split_eq + omega + have htD : t - 1 < D x.place := by + simp only [D, Finsupp.add_apply, Finsupp.single_eq_same] + omega + exact { + divisor := D + place := x.place + occurrence := t - 1 + label := x.label + weight_eq := hweight + occurrence_lt := htD + label_lt := x.label_lt } + +private def weightedMarkedEffectiveDivisorEquivEulerDecomposition + (w : I → ℕ) (hw : ∀ i, 0 < w i) (n : ℕ) : + WeightedMarkedEffectiveDivisor w (n + 1) ≃ + WeightedEulerDecomposition w n where + toFun := weightedMarkedToEulerDecomposition w hw n + invFun := weightedEulerDecompositionToMarked w hw n + left_inv := by + intro x + apply WeightedMarkedEffectiveDivisor.ext + · dsimp [weightedEulerDecompositionToMarked, + weightedMarkedToEulerDecomposition] + rw [Nat.sub_add_cancel (Nat.mul_pos (by omega) (hw x.place))] + rw [Nat.mul_div_cancel (x.occurrence + 1) (hw x.place)] + exact tsub_add_cancel_of_le + (Finsupp.single_le_iff.mpr x.occurrence_lt) + · rfl + · dsimp [weightedEulerDecompositionToMarked, + weightedMarkedToEulerDecomposition] + rw [Nat.sub_add_cancel (Nat.mul_pos (by omega) (hw x.place))] + rw [Nat.mul_div_cancel (x.occurrence + 1) (hw x.place)] + omega + · rfl + right_inv := by + intro x + have htpos : 0 < (x.rightDegree + 1) / w x.place := by + have hprod := Nat.div_mul_cancel x.divides + by_contra ht + have hzero : (x.rightDegree + 1) / w x.place = 0 := + Nat.eq_zero_of_not_pos ht + rw [hzero, zero_mul] at hprod + omega + apply WeightedEulerDecomposition.ext + · dsimp [weightedMarkedToEulerDecomposition, + weightedEulerDecompositionToMarked] + rw [Nat.sub_add_cancel htpos] + rw [Nat.div_mul_cancel x.divides] + have hsplit := x.split_eq + omega + · dsimp [weightedMarkedToEulerDecomposition, + weightedEulerDecompositionToMarked] + rw [Nat.sub_add_cancel htpos] + rw [Nat.div_mul_cancel x.divides] + exact Nat.add_sub_cancel x.rightDegree 1 + · dsimp [weightedMarkedToEulerDecomposition, + weightedEulerDecompositionToMarked] + rw [Nat.sub_add_cancel htpos] + exact add_tsub_cancel_right _ _ + · rfl + · rfl + +private def weightedMarkedEffectiveDivisorEquivSigma + (w : I → ℕ) (n : ℕ) : + WeightedMarkedEffectiveDivisor w n ≃ + Σ D : WeightedEffectiveDivisor w n, + Σ P : I, Fin (D.1 P) × Fin (w P) where + toFun x := + ⟨⟨x.divisor, x.weight_eq⟩, x.place, + ⟨x.occurrence, x.occurrence_lt⟩, + ⟨x.label, x.label_lt⟩⟩ + invFun x := { + divisor := x.1.1 + place := x.2.1 + occurrence := x.2.2.1.1 + label := x.2.2.2.1 + weight_eq := x.1.2 + occurrence_lt := x.2.2.1.2 + label_lt := x.2.2.2.2 } + left_inv := by intro x; ext <;> rfl + right_inv := by intro x; rcases x with ⟨D, P, k, l⟩; rfl + +@[reducible] private noncomputable def weightedMarkedEffectiveDivisorFintype + (w : I → ℕ) (hw : ∀ i, w i ≠ 0) (n : ℕ) : + Fintype (WeightedMarkedEffectiveDivisor w n) := by + letI := weightedEffectiveDivisorFintype w hw n + exact Fintype.ofEquiv _ (weightedMarkedEffectiveDivisorEquivSigma w n).symm + +/-- The number of natural-valued divisors having weighted degree `n` in a +finite family of nonzero weights. -/ +noncomputable def weightedEffectiveDivisorCount + (w : I → ℕ) (hw : ∀ i, w i ≠ 0) (n : ℕ) : ℕ := + @Fintype.card _ (weightedEffectiveDivisorFintype w hw n) + +omit [DecidableEq I] in +private theorem weightedMarkedEffectiveDivisor_card + (w : I → ℕ) (hw : ∀ i, w i ≠ 0) (n : ℕ) : + @Fintype.card (WeightedMarkedEffectiveDivisor w n) + (weightedMarkedEffectiveDivisorFintype w hw n) = + weightedEffectiveDivisorCount w hw n * n := by + let := weightedEffectiveDivisorFintype w hw n + let := weightedMarkedEffectiveDivisorFintype w hw n + rw [Fintype.card_congr (weightedMarkedEffectiveDivisorEquivSigma w n)] + rw [Fintype.card_sigma] + simp only [Fintype.card_sigma, Fintype.card_prod, Fintype.card_fin] + simp_rw [show ∀ D : WeightedEffectiveDivisor w n, + ∑ P : I, D.1 P * w P = n by + intro D + calc + ∑ P : I, D.1 P * w P = Finsupp.weight w D.1 := by + rw [Finsupp.weight_apply] + simpa using + (Finsupp.sum_fintype D.1 (fun i c => c • w i) (by simp)).symm + _ = n := D.2] + simp [weightedEffectiveDivisorCount] + +private def weightedEulerDecompositionEquivSigma + (w : I → ℕ) (n : ℕ) : + WeightedEulerDecomposition w n ≃ + Σ ij : {ij : ℕ × ℕ // + ij ∈ Finset.HasAntidiagonal.antidiagonal n}, + WeightedEffectiveDivisor w ij.1.1 × + Σ P : {P : I // w P ∣ ij.1.2 + 1}, Fin (w P.1) where + toFun x := + ⟨⟨(x.leftDegree, x.rightDegree), by + simpa only [Finset.HasAntidiagonal.mem_antidiagonal] using x.split_eq⟩, + ⟨⟨x.divisor, x.divisor_weight⟩, + ⟨⟨x.place, x.divides⟩, ⟨x.label, x.label_lt⟩⟩⟩⟩ + invFun x := { + leftDegree := x.1.1.1 + rightDegree := x.1.1.2 + split_eq := by + simpa only [Finset.HasAntidiagonal.mem_antidiagonal] using x.1.2 + divisor := x.2.1.1 + divisor_weight := x.2.1.2 + place := x.2.2.1.1 + divides := x.2.2.1.2 + label := x.2.2.2.1 + label_lt := x.2.2.2.2 } + left_inv := by intro x; ext <;> rfl + right_inv := by intro x; rcases x with ⟨ij, D, P, l⟩; rfl + +@[reducible] private noncomputable def weightedEulerDecompositionFintype + (w : I → ℕ) (hw : ∀ i, w i ≠ 0) (n : ℕ) : + Fintype (WeightedEulerDecomposition w n) := by + letI (m : ℕ) := weightedEffectiveDivisorFintype w hw m + exact Fintype.ofEquiv _ (weightedEulerDecompositionEquivSigma w n).symm + +/-- The degree-weighted sum of the places whose weights divide `r`. -/ +def weightedClosedPlaceExtensionCount (w : I → ℕ) (r : ℕ) : ℕ := + ∑ P : I, if w P ∣ r then w P else 0 + +omit [DecidableEq I] in +private theorem weightedEulerDecomposition_card + (w : I → ℕ) (hw : ∀ i, w i ≠ 0) (n : ℕ) : + @Fintype.card (WeightedEulerDecomposition w n) + (weightedEulerDecompositionFintype w hw n) = + ∑ ij ∈ Finset.HasAntidiagonal.antidiagonal n, + weightedEffectiveDivisorCount w hw ij.1 * + weightedClosedPlaceExtensionCount w (ij.2 + 1) := by + let (m : ℕ) := weightedEffectiveDivisorFintype w hw m + let := weightedEulerDecompositionFintype w hw n + rw [Fintype.card_congr (weightedEulerDecompositionEquivSigma w n)] + rw [Fintype.card_sigma] + simp only [Fintype.card_prod, Fintype.card_sigma, Fintype.card_fin] + simp only [weightedEffectiveDivisorCount] + have hplace (r : ℕ) : + (∑ P : {P : I // w P ∣ r}, w P.1) = + ∑ P : I, if w P ∣ r then w P else 0 := by + calc + (∑ P : {P : I // w P ∣ r}, w P.1) = + ∑ P ∈ Finset.univ.filter (fun P : I => w P ∣ r), w P := by + symm + exact Finset.sum_subtype _ (by simp) _ + _ = ∑ P ∈ Finset.univ, if w P ∣ r then w P else 0 := + Finset.sum_filter _ _ + _ = ∑ P : I, if w P ∣ r then w P else 0 := by rfl + simp_rw [hplace] + rw [Finset.univ_eq_attach] + simpa only [weightedClosedPlaceExtensionCount] using + (Finset.sum_attach (Finset.HasAntidiagonal.antidiagonal n) + (fun ij : ℕ × ℕ => + @Fintype.card (WeightedEffectiveDivisor w ij.1) + (weightedEffectiveDivisorFintype w hw ij.1) * + ∑ P : I, if w P ∣ ij.2 + 1 then w P else 0)) + +omit [DecidableEq I] in +/-- The logarithmic-derivative Euler recurrence for any finite family of +positive integral place weights. -/ +theorem weightedEffectiveDivisorPointCountRecurrence + (w : I → ℕ) (hw : ∀ i, 0 < w i) : + HasEffectiveDivisorPointCountRecurrence + (weightedEffectiveDivisorCount w (fun i => (hw i).ne')) + (weightedClosedPlaceExtensionCount w) := by + intro n + let := weightedMarkedEffectiveDivisorFintype w + (fun i => (hw i).ne') (n + 1) + let := weightedEulerDecompositionFintype w + (fun i => (hw i).ne') n + calc + weightedEffectiveDivisorCount w (fun i => (hw i).ne') (n + 1) * + (n + 1) = + Fintype.card (WeightedMarkedEffectiveDivisor w (n + 1)) := + (weightedMarkedEffectiveDivisor_card w (fun i => (hw i).ne') + (n + 1)).symm + _ = Fintype.card (WeightedEulerDecomposition w n) := + Fintype.card_congr + (weightedMarkedEffectiveDivisorEquivEulerDecomposition w hw n) + _ = ∑ ij ∈ Finset.HasAntidiagonal.antidiagonal n, + weightedEffectiveDivisorCount w (fun i => (hw i).ne') ij.1 * + weightedClosedPlaceExtensionCount w (ij.2 + 1) := + weightedEulerDecomposition_card w (fun i => (hw i).ne') n + +end FiniteWeightedFamily + +section LocalRestriction + +variable {J : Type*} [DecidableEq J] + +omit [DecidableEq J] in +private theorem weightedEffectiveDivisor_support_subset_degreeLE + (w : J → ℕ) (n bound : ℕ) (hn : n ≤ bound) + (D : WeightedEffectiveDivisor w n) : + (D.1.support : Set J) ⊆ + Set.range (Function.Embedding.subtype fun P : J => w P ≤ bound) := by + intro P hP + have hne : D.1 P ≠ 0 := Finsupp.mem_support_iff.mp hP + have hle : w P ≤ bound := by + calc + w P ≤ Finsupp.weight w D.1 := + Finsupp.le_weight_of_ne_zero' w hne + _ = n := D.2 + _ ≤ bound := hn + exact ⟨⟨P, hle⟩, rfl⟩ + +omit [DecidableEq J] in +private theorem weightedEffectiveDivisor_embDomain_weight + (w : J → ℕ) (bound : ℕ) + (E : {P : J // w P ≤ bound} →₀ ℕ) : + Finsupp.weight w + (Finsupp.embDomain + (Function.Embedding.subtype fun P : J => w P ≤ bound) E) = + Finsupp.weight (fun P : {P : J // w P ≤ bound} => w P.1) E := by + rw [Finsupp.weight_apply, Finsupp.sum_embDomain, + Finsupp.weight_apply] + apply Finsupp.sum_congr + intro P _ + rfl + +private def weightedEffectiveDivisorRestrictEquiv + (w : J → ℕ) (n bound : ℕ) (hn : n ≤ bound) : + WeightedEffectiveDivisor w n ≃ + WeightedEffectiveDivisor + (fun P : {P : J // w P ≤ bound} => w P.1) n where + toFun D := by + let e := Function.Embedding.subtype fun P : J => w P ≤ bound + let E := Finsupp.comapDomain e D.1 e.injective.injOn + have hrecover : Finsupp.embDomain e E = D.1 := + Finsupp.embDomain_comapDomain + (weightedEffectiveDivisor_support_subset_degreeLE w n bound hn D) + exact ⟨E, by + rw [← weightedEffectiveDivisor_embDomain_weight w bound E, + hrecover] + exact D.2⟩ + invFun E := by + let e := Function.Embedding.subtype fun P : J => w P ≤ bound + exact ⟨Finsupp.embDomain e E.1, + (weightedEffectiveDivisor_embDomain_weight w bound E.1).trans E.2⟩ + left_inv D := by + apply Subtype.ext + dsimp + exact Finsupp.embDomain_comapDomain + (weightedEffectiveDivisor_support_subset_degreeLE w n bound hn D) + right_inv E := by + apply Subtype.ext + exact Finsupp.comapDomain_embDomain + (Function.Embedding.subtype fun P : J => w P ≤ bound) E.1 + +end LocalRestriction + +section FiniteExtension + +open BGS.CorvajaZannier + +variable (K : Type*) [Field K] [Fintype K] [DecidableEq K] + [DecidableEq (RatFunc K)] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +omit [Fintype K] [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] in +/-- The repository's effective-divisor degree is `Finsupp.weight` for the +closed-place degree function. -/ +theorem finiteExtensionEffectiveDivisorDegree_eq_weight + (D : FiniteExtensionEffectiveDivisor K L) : + finiteExtensionEffectiveDivisorDegree K L D = + Finsupp.weight (finiteExtensionPlaceDegree K L) D := by + rw [finiteExtensionEffectiveDivisorDegree, Finsupp.weight_apply] + apply Finsupp.sum_congr + intro P _ + simp + +private def finiteExtensionEffectiveDivisorWeightEquiv (n : ℕ) : + {D : FiniteExtensionEffectiveDivisor K L // + finiteExtensionEffectiveDivisorDegree K L D = n} ≃ + WeightedEffectiveDivisor (finiteExtensionPlaceDegree K L) n where + toFun D := ⟨D.1, + (finiteExtensionEffectiveDivisorDegree_eq_weight K L D.1).symm.trans D.2⟩ + invFun D := ⟨D.1, + (finiteExtensionEffectiveDivisorDegree_eq_weight K L D.1).trans D.2⟩ + left_inv D := by apply Subtype.ext; rfl + right_inv D := by apply Subtype.ext; rfl + +private def finiteExtensionEffectiveDivisorRestrictEquiv + (n bound : ℕ) (hn : n ≤ bound) : + {D : FiniteExtensionEffectiveDivisor K L // + finiteExtensionEffectiveDivisorDegree K L D = n} ≃ + WeightedEffectiveDivisor + (fun P : {P : FiniteExtensionPlace K L // + finiteExtensionPlaceDegree K L P ≤ bound} => + finiteExtensionPlaceDegree K L P.1) n := by + classical + exact (finiteExtensionEffectiveDivisorWeightEquiv K L n).trans + (weightedEffectiveDivisorRestrictEquiv + (finiteExtensionPlaceDegree K L) n bound hn) + +private theorem weightedEffectiveDivisorCount_degreeLE_eq_finiteExtensionCount + (n bound : ℕ) (hn : n ≤ bound) : + letI := finiteExtensionPlaceDegreeLEFintype K L bound + weightedEffectiveDivisorCount + (fun P : {P : FiniteExtensionPlace K L // + finiteExtensionPlaceDegree K L P ≤ bound} => + finiteExtensionPlaceDegree K L P.1) + (fun P => (finiteExtensionPlaceDegree_pos K L P.1).ne') n = + finiteExtensionEffectiveDivisorCount K L n := by + let := finiteExtensionPlaceDegreeLEFintype K L bound + let := weightedEffectiveDivisorFintype + (fun P : {P : FiniteExtensionPlace K L // + finiteExtensionPlaceDegree K L P ≤ bound} => + finiteExtensionPlaceDegree K L P.1) + (fun P => (finiteExtensionPlaceDegree_pos K L P.1).ne') n + exact Fintype.card_congr + (finiteExtensionEffectiveDivisorRestrictEquiv K L n bound hn).symm + +/-- The extension point count encoded by closed places: a closed place of +degree `d` contributes `d` exactly when `d ∣ r`. -/ +noncomputable def finiteExtensionClosedPlaceExtensionCount (r : ℕ) : ℕ := by + letI := finiteExtensionPlaceDegreeLEFintype K L r + exact ∑ P : {P : FiniteExtensionPlace K L // + finiteExtensionPlaceDegree K L P ≤ r}, + if finiteExtensionPlaceDegree K L P.1 ∣ r then + finiteExtensionPlaceDegree K L P.1 else 0 + +/-- The closed-place extension count is equivalently the sum of the degrees +over the bounded subtype of places whose degrees divide the level. -/ +theorem finiteExtensionClosedPlaceExtensionCount_eq_sum_degree_dvd + (r : ℕ) : + finiteExtensionClosedPlaceExtensionCount K L r = + letI := finiteExtensionPlaceDegreeLEFintype K L r + ∑ P : {P : {P : FiniteExtensionPlace K L // + finiteExtensionPlaceDegree K L P ≤ r} // + finiteExtensionPlaceDegree K L P.1 ∣ r}, + finiteExtensionPlaceDegree K L P.1.1 := by + let := finiteExtensionPlaceDegreeLEFintype K L r + let PlaceLE := {P : FiniteExtensionPlace K L // + finiteExtensionPlaceDegree K L P ≤ r} + let PlaceDvd := {P : PlaceLE // + finiteExtensionPlaceDegree K L P.1 ∣ r} + let degree : PlaceLE → ℕ := fun P => + finiteExtensionPlaceDegree K L P.1 + change (∑ P : PlaceLE, if degree P ∣ r then degree P else 0) = + ∑ P : PlaceDvd, degree P.1 + calc + (∑ P : PlaceLE, if degree P ∣ r then degree P else 0) = + ∑ P ∈ Finset.univ.filter (fun P : PlaceLE => degree P ∣ r), + degree P := by + symm + exact Finset.sum_filter _ _ + _ = ∑ P : PlaceDvd, degree P.1 := by + exact Finset.sum_subtype _ (by intro P; simp [degree]) degree + +@[simp] +theorem finiteExtensionClosedPlaceExtensionCount_zero : + finiteExtensionClosedPlaceExtensionCount K L 0 = 0 := by + rw [finiteExtensionClosedPlaceExtensionCount_eq_sum_degree_dvd] + apply Finset.sum_eq_zero + intro P _ + have hpos := finiteExtensionPlaceDegree_pos K L P.1.1 + have hle := P.1.2 + omega + +private theorem weightedClosedPlaceExtensionCount_degreeLE_eq_finiteExtensionCount + (bound r : ℕ) (hr : 0 < r) (hrb : r ≤ bound) : + letI := finiteExtensionPlaceDegreeLEFintype K L bound + weightedClosedPlaceExtensionCount + (fun P : {P : FiniteExtensionPlace K L // + finiteExtensionPlaceDegree K L P ≤ bound} => + finiteExtensionPlaceDegree K L P.1) r = + finiteExtensionClosedPlaceExtensionCount K L r := by + let := finiteExtensionPlaceDegreeLEFintype K L bound + let := finiteExtensionPlaceDegreeLEFintype K L r + let Big := {P : FiniteExtensionPlace K L // + finiteExtensionPlaceDegree K L P ≤ bound} + let Small := {P : FiniteExtensionPlace K L // + finiteExtensionPlaceDegree K L P ≤ r} + let SmallInBig := {P : Big // + finiteExtensionPlaceDegree K L P.1 ≤ r} + let e : SmallInBig ≃ Small := { + toFun := fun P => ⟨P.1.1, P.2⟩ + invFun := fun P => ⟨⟨P.1, P.2.trans hrb⟩, P.2⟩ + left_inv := by intro P; rcases P with ⟨⟨P, hPb⟩, hPr⟩; rfl + right_inv := by intro P; rcases P with ⟨P, hPr⟩; rfl } + let f : Big → ℕ := fun P => + if finiteExtensionPlaceDegree K L P.1 ∣ r then + finiteExtensionPlaceDegree K L P.1 else 0 + let g : Small → ℕ := fun P => + if finiteExtensionPlaceDegree K L P.1 ∣ r then + finiteExtensionPlaceDegree K L P.1 else 0 + change (∑ P : Big, f P) = ∑ P : Small, g P + calc + (∑ P : Big, f P) = + ∑ P : Big, + if finiteExtensionPlaceDegree K L P.1 ≤ r then f P else 0 := by + apply Finset.sum_congr rfl + intro P _ + by_cases hle : finiteExtensionPlaceDegree K L P.1 ≤ r + · simp [hle] + · have hndiv : ¬ finiteExtensionPlaceDegree K L P.1 ∣ r := by + intro hdiv + exact hle (Nat.le_of_dvd hr hdiv) + simp [f, hle, hndiv] + _ = ∑ P ∈ Finset.univ.filter + (fun P : Big => finiteExtensionPlaceDegree K L P.1 ≤ r), f P := by + symm + exact Finset.sum_filter _ _ + _ = ∑ P : SmallInBig, f P.1 := by + exact Finset.sum_subtype _ (by simp) f + _ = ∑ P : Small, g P := by + exact Fintype.sum_equiv e (fun P : SmallInBig => f P.1) g (by + intro P + rfl) + +/-- The effective-divisor coefficients for the exhaustive closed places of a +finite extension satisfy the exact closed-place Euler recurrence. -/ +theorem finiteExtensionEffectiveDivisorPointCountRecurrence : + HasEffectiveDivisorPointCountRecurrence + (finiteExtensionEffectiveDivisorCount K L) + (finiteExtensionClosedPlaceExtensionCount K L) := by + classical + intro n + let PlaceLE := {P : FiniteExtensionPlace K L // + finiteExtensionPlaceDegree K L P ≤ n + 1} + let w : PlaceLE → ℕ := fun P => finiteExtensionPlaceDegree K L P.1 + let := finiteExtensionPlaceDegreeLEFintype K L (n + 1) + have hw : ∀ P : PlaceLE, 0 < w P := fun P => + finiteExtensionPlaceDegree_pos K L P.1 + have hlocal := weightedEffectiveDivisorPointCountRecurrence w hw n + calc + finiteExtensionEffectiveDivisorCount K L (n + 1) * (n + 1) = + weightedEffectiveDivisorCount w (fun P => (hw P).ne') (n + 1) * + (n + 1) := by + rw [weightedEffectiveDivisorCount_degreeLE_eq_finiteExtensionCount + K L (n + 1) (n + 1) le_rfl] + _ = ∑ ij ∈ Finset.HasAntidiagonal.antidiagonal n, + weightedEffectiveDivisorCount w (fun P => (hw P).ne') ij.1 * + weightedClosedPlaceExtensionCount w (ij.2 + 1) := hlocal + _ = ∑ ij ∈ Finset.HasAntidiagonal.antidiagonal n, + finiteExtensionEffectiveDivisorCount K L ij.1 * + finiteExtensionClosedPlaceExtensionCount K L (ij.2 + 1) := by + apply Finset.sum_congr rfl + intro ij hij + have hsplit : ij.1 + ij.2 = n := by + simpa only [Finset.HasAntidiagonal.mem_antidiagonal] using hij + have hleft : ij.1 ≤ n + 1 := by omega + have hright : ij.2 + 1 ≤ n + 1 := by omega + rw [weightedEffectiveDivisorCount_degreeLE_eq_finiteExtensionCount + K L ij.1 (n + 1) hleft] + rw [weightedClosedPlaceExtensionCount_degreeLE_eq_finiteExtensionCount + K L (n + 1) (ij.2 + 1) (by omega) hright] + +end FiniteExtension + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/ConstantExtensionClosedPlaceCount.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/ConstantExtensionClosedPlaceCount.lean new file mode 100644 index 0000000000..a6268bf079 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/ConstantExtensionClosedPlaceCount.lean @@ -0,0 +1,424 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.ClosedPlaceEulerRecurrence +public import LeanPool.MarkoffModP.BGS.HasseWeil.ConstantExtensionFinitePlaceBridge +public import LeanPool.MarkoffModP.BGS.HasseWeil.ConstantExtensionInfinityPlaceBridge + +/-! +# Closed places and rational places after extension of constants + +For an exact extension of constants `S / C`, the existing finite and +infinity normalization bridges both prove the residue-degree formula + +`deg_S(Q) = deg_C(P) / gcd([S : C], deg_C(P))`. + +This file combines the two branches into one presented-place type and proves +that an upstairs presented place is rational exactly when its downstairs +degree divides `[S : C]`. Thus it identifies, place by place, the support of +the closed-place extension coefficient with rationality after constant +extension. + +The global cardinality identity needs one further splitting theorem: the +fiber over a downstairs place of degree `d` must have cardinality +`gcd([S : C], d)`. That multiplicity is not supplied by the current +finite/infinity bridge APIs, so no global count equality is asserted here. +-/ + +@[expose] public section + +open scoped Polynomial TensorProduct + +namespace BGS.HasseWeil + +noncomputable section + +open BGS.CorvajaZannier + +/-- Elementary arithmetic behind rationality after extension of constants. -/ +theorem div_gcd_eq_one_iff_dvd (r d : ℕ) (hd : 0 < d) : + d / Nat.gcd r d = 1 ↔ d ∣ r := by + constructor + · intro h + have heq : d = Nat.gcd r d * 1 := + Nat.eq_mul_of_div_eq_right (Nat.gcd_dvd_right r d) h + have hgcd : Nat.gcd r d = d := by simpa using heq.symm + exact Nat.gcd_eq_right_iff_dvd.mp hgcd + · intro h + rw [Nat.gcd_eq_right_iff_dvd.mpr h] + exact Nat.div_self hd + +/-- The degree after extending constants divides an extension level exactly +when the original closed-place degree divides the multiplied level. -/ +theorem div_gcd_dvd_iff_dvd_mul + (extensionDegree placeDegree level : ℕ) + (hextension : 0 < extensionDegree) : + placeDegree / Nat.gcd extensionDegree placeDegree ∣ level ↔ + placeDegree ∣ extensionDegree * level := by + let g := Nat.gcd extensionDegree placeDegree + have hgpos : 0 < g := Nat.gcd_pos_of_pos_left placeDegree hextension + have hgPlace : g ∣ placeDegree := Nat.gcd_dvd_right _ _ + have hgExtension : g ∣ extensionDegree := Nat.gcd_dvd_left _ _ + have hplace : g * (placeDegree / g) = placeDegree := + Nat.mul_div_cancel' hgPlace + have hext : g * (extensionDegree / g) = extensionDegree := + Nat.mul_div_cancel' hgExtension + have hcoprime : + (placeDegree / g).Coprime (extensionDegree / g) := + (Nat.coprime_div_gcd_div_gcd hgpos).symm + constructor + · intro h + have hdiv : placeDegree / g ∣ (extensionDegree / g) * level := + hcoprime.dvd_mul_left.mpr h + have hmul : g * (placeDegree / g) ∣ + g * ((extensionDegree / g) * level) := + (Nat.mul_dvd_mul_iff_left hgpos).mpr hdiv + simpa only [hplace, ← Nat.mul_assoc, hext] using hmul + · intro h + have hmul : g * (placeDegree / g) ∣ + g * ((extensionDegree / g) * level) := by + simpa only [hplace, ← Nat.mul_assoc, hext] using h + have hdiv : placeDegree / g ∣ (extensionDegree / g) * level := + (Nat.mul_dvd_mul_iff_left hgpos).mp hmul + exact hcoprime.dvd_mul_left.mp hdiv + +/-- Abstract finite-fiber form of the constant-extension contribution +identity. If every object above `P` has degree `deg(P) / gcd(r, deg(P))` +and there are exactly `gcd(r, deg(P))` such objects, then the total degrees +in the two finite families agree. -/ +theorem sum_degree_eq_sum_degree_of_div_gcd_and_fiber_card + {Base Up : Type*} [Fintype Base] [Fintype Up] + (down : Up → Base) (baseDegree : Base → ℕ) (upDegree : Up → ℕ) + (extensionDegree : ℕ) + (hdegree : ∀ Q, upDegree Q = + baseDegree (down Q) / + Nat.gcd extensionDegree (baseDegree (down Q))) + (hfiber : ∀ P, Nat.card {Q : Up // down Q = P} = + Nat.gcd extensionDegree (baseDegree P)) : + (∑ Q, upDegree Q) = ∑ P, baseDegree P := by + classical + let : DecidableEq Base := Classical.decEq Base + calc + (∑ Q, upDegree Q) = + ∑ z : Σ P, {Q : Up // down Q = P}, upDegree z.2.1 := by + apply Fintype.sum_equiv (Equiv.sigmaFiberEquiv down).symm + intro Q + rfl + _ = ∑ P, ∑ Q : {Q : Up // down Q = P}, upDegree Q.1 := + Fintype.sum_sigma _ + _ = ∑ P, Fintype.card {Q : Up // down Q = P} * + (baseDegree P / + Nat.gcd extensionDegree (baseDegree P)) := by + apply Finset.sum_congr rfl + intro P _ + apply Finset.sum_const_nat + intro Q _ + rw [hdegree, Q.2] + _ = ∑ P, Nat.gcd extensionDegree (baseDegree P) * + (baseDegree P / + Nat.gcd extensionDegree (baseDegree P)) := by + simp_rw [← Nat.card_eq_fintype_card, hfiber] + _ = ∑ P, baseDegree P := by + apply Finset.sum_congr rfl + intro P _ + exact Nat.mul_div_cancel' (Nat.gcd_dvd_right _ _) + +/-- Bounded divisor-support form of the preceding fiber identity. It is the +exact combinatorial interface used by closed-place extension counts: the map +between all places need not have finite domain, because the two degree-bounded +families are supplied as finite types. -/ +theorem sum_degree_dvd_eq_sum_degree_dvd_of_div_gcd_fibers + {Base Up : Type*} + (down : Up → Base) (baseDegree : Base → ℕ) (upDegree : Up → ℕ) + (extensionDegree level : ℕ) + (hextension : 0 < extensionDegree) (hlevel : 0 < level) + [Fintype {P : Base // baseDegree P ≤ extensionDegree * level}] + [Fintype {Q : Up // upDegree Q ≤ level}] + (hdegree : ∀ Q, upDegree Q = + baseDegree (down Q) / + Nat.gcd extensionDegree (baseDegree (down Q))) + (hfiber : ∀ P, Nat.card {Q : Up // down Q = P} = + Nat.gcd extensionDegree (baseDegree P)) : + (∑ Q : {Q : {Q : Up // upDegree Q ≤ level} // + upDegree Q.1 ∣ level}, upDegree Q.1.1) = + ∑ P : {P : {P : Base // + baseDegree P ≤ extensionDegree * level} // + baseDegree P.1 ∣ extensionDegree * level}, + baseDegree P.1.1 := by + classical + let BaseLE := {P : Base // baseDegree P ≤ extensionDegree * level} + let UpLE := {Q : Up // upDegree Q ≤ level} + let BaseDvd := {P : BaseLE // + baseDegree P.1 ∣ extensionDegree * level} + let UpDvd := {Q : UpLE // upDegree Q.1 ∣ level} + let downDvd : UpDvd → BaseDvd := fun Q => by + have hdiv : baseDegree (down Q.1.1) ∣ extensionDegree * level := + (div_gcd_dvd_iff_dvd_mul extensionDegree + (baseDegree (down Q.1.1)) level hextension).mp (by + rw [← hdegree Q.1.1] + exact Q.2) + exact ⟨⟨down Q.1.1, + Nat.le_of_dvd (Nat.mul_pos hextension hlevel) hdiv⟩, hdiv⟩ + have hdownDvd (Q : UpDvd) : (downDvd Q).1.1 = down Q.1.1 := rfl + have hfiberDvd (P : BaseDvd) : + Nat.card {Q : UpDvd // downDvd Q = P} = + Nat.gcd extensionDegree (baseDegree P.1.1) := by + let e : {Q : UpDvd // downDvd Q = P} ≃ + {Q : Up // down Q = P.1.1} := + { toFun := fun Q => ⟨Q.1.1.1, by + have h := congrArg (fun R : BaseDvd => R.1.1) Q.2 + exact h⟩ + invFun := fun Q => by + have hbaseDiv : baseDegree (down Q.1) ∣ + extensionDegree * level := by + simpa only [Q.2] using P.2 + have hupDiv : upDegree Q.1 ∣ level := by + rw [hdegree] + exact (div_gcd_dvd_iff_dvd_mul extensionDegree + (baseDegree (down Q.1)) level hextension).mpr hbaseDiv + let qDvd : UpDvd := ⟨⟨Q.1, + Nat.le_of_dvd hlevel hupDiv⟩, hupDiv⟩ + refine ⟨qDvd, ?_⟩ + apply Subtype.ext + apply Subtype.ext + exact Q.2 + left_inv := fun Q => by + apply Subtype.ext + apply Subtype.ext + apply Subtype.ext + rfl + right_inv := fun Q => by + apply Subtype.ext + rfl } + calc + Nat.card {Q : UpDvd // downDvd Q = P} = + Nat.card {Q : Up // down Q = P.1.1} := Nat.card_congr e + _ = Nat.gcd extensionDegree (baseDegree P.1.1) := hfiber P.1.1 + apply sum_degree_eq_sum_degree_of_div_gcd_and_fiber_card + downDvd (fun P : BaseDvd => baseDegree P.1.1) + (fun Q : UpDvd => upDegree Q.1.1) extensionDegree + · intro Q + simpa only [hdownDvd] using hdegree Q.1.1 + · exact hfiberDvd + +variable (C S N : Type*) [Field C] [Field S] [Field N] + [Fintype C] [Finite S] + [DecidableEq C] [DecidableEq S] + [Algebra (RatFunc C) N] [FiniteDimensional (RatFunc C) N] + [Algebra.IsSeparable (RatFunc C) N] + [Algebra C S] [FiniteDimensional C S] [IsGalois C S] + +-- The infinity bridge fixes classical decidable equality locally. Reusing +-- the same definitions keeps its dependent place types definitionally equal +-- to the exhaustive place types in this file. +local instance (priority := 10000) closedPlaceRatFuncBaseDecidableEq : + DecidableEq (RatFunc C) := + infinityBridgeDecidableEqRatFuncConstants C + +local instance (priority := 10000) closedPlaceRatFuncConstantsDecidableEq : + DecidableEq (RatFunc S) := + infinityBridgeDecidableEqRatFuncConstants S + +local instance closedPlaceBaseConstantAlgebra : Algebra C N := + bridgeBaseConstantAlgebra C N + +local instance closedPlaceTargetPolynomialAlgebra : + Algebra S[X] (ExactConstantExtension C N S) := + bridgeTargetPolynomialAlgebra C S N + +/-- Reciprocal-affine primes used to present places above infinity. The +local algebra structure sends the polynomial variable to `X⁻¹`, exactly as +in `ConstantExtensionInfinityPlaceBridge`. -/ +abbrev ExactConstantExtensionPresentedInfinityPlace := + letI : Algebra C[X] N := + infinityBridgeBaseReciprocalPolynomialAlgebra C N + letI : IsScalarTower C C[X] N := + infinityBridgeBaseConstantPolynomialTower C N + letI : Algebra C (integralClosure C[X] N) := + infinityBridgeOldNormalizationConstantAlgebra C N + letI : IsScalarTower C C[X] (integralClosure C[X] N) := + infinityBridgeOldNormalizationConstantPolynomialTower C N + letI : Algebra S[X] (S ⊗[C] integralClosure C[X] N) := + infinityBridgeTensorPolynomialAlgebra C S N + {q : IsDedekindDomain.HeightOneSpectrum + (S ⊗[C] integralClosure C[X] N) // + q.asIdeal.under S[X] = + Ideal.span ({Polynomial.X} : Set S[X])} + +/-- A common presentation of finite and infinity places in the explicit +normalizations used by the two constant-extension bridge files. -/ +abbrev ExactConstantExtensionPresentedPlace := + Sum + (IsDedekindDomain.HeightOneSpectrum + (integralClosure S[X] (ExactConstantExtension C N S))) + (ExactConstantExtensionPresentedInfinityPlace C S N) + +variable (hExact : algebraicClosure C N = + (⊥ : IntermediateField C N)) + +/-- The actual upstairs exhaustive place represented by a finite or +reciprocal-infinity normalization prime. -/ +noncomputable def exactConstantExtensionPresentedUpstairsPlace + (q : ExactConstantExtensionPresentedPlace C S N) : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc S) (ExactConstantExtension C N S) := + ratFuncExactConstantExtensionAlgebra C S N hExact + FiniteExtensionPlace S (ExactConstantExtension C N S) := by + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc S) (ExactConstantExtension C N S) := + ratFuncExactConstantExtensionAlgebra C S N hExact + cases q with + | inl q => + exact .inl (exactConstantExtensionUpstairsFinitePlace + C S N hExact q) + | inr q => + exact .inr (exactConstantExtensionUpstairsInfinityPlace + C S N hExact q.1 q.2) + +/-- The actual downstairs exhaustive place obtained by contraction. -/ +noncomputable def exactConstantExtensionPresentedDownstairsPlace + (q : ExactConstantExtensionPresentedPlace C S N) : + FiniteExtensionPlace C N := by + cases q with + | inl q => + exact .inl (exactConstantExtensionDownstairsFinitePlace + C S N hExact q) + | inr q => + exact .inr (exactConstantExtensionDownstairsInfinityPlace + C S N q.1 q.2) + +/-- The finite and infinity residue-degree formulas combine into one formula +on presented exhaustive places. -/ +theorem exactConstantExtensionPresentedPlace_degree_eq_div_gcd + (q : ExactConstantExtensionPresentedPlace C S N) : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc S) (ExactConstantExtension C N S) := + ratFuncExactConstantExtensionAlgebra C S N hExact + finiteExtensionPlaceDegree S (ExactConstantExtension C N S) + (exactConstantExtensionPresentedUpstairsPlace C S N hExact q) = + finiteExtensionPlaceDegree C N + (exactConstantExtensionPresentedDownstairsPlace C S N hExact q) / + Nat.gcd (Module.finrank C S) + (finiteExtensionPlaceDegree C N + (exactConstantExtensionPresentedDownstairsPlace + C S N hExact q)) := by + let : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + let : Algebra (RatFunc S) (ExactConstantExtension C N S) := + ratFuncExactConstantExtensionAlgebra C S N hExact + cases q with + | inl q => + exact exactConstantExtensionFinitePlace_degree_eq_div_gcd + C S N hExact q + | inr q => + exact exactConstantExtensionInfinityPlace_degree_eq_div_gcd + C S N hExact q.1 q.2 + +/-- A presented upstairs place is rational over `S` exactly when its +downstairs degree divides the constant-extension degree. -/ +theorem exactConstantExtensionPresentedPlace_degree_eq_one_iff_dvd + (q : ExactConstantExtensionPresentedPlace C S N) : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc S) (ExactConstantExtension C N S) := + ratFuncExactConstantExtensionAlgebra C S N hExact + finiteExtensionPlaceDegree S (ExactConstantExtension C N S) + (exactConstantExtensionPresentedUpstairsPlace C S N hExact q) = 1 ↔ + finiteExtensionPlaceDegree C N + (exactConstantExtensionPresentedDownstairsPlace C S N hExact q) ∣ + Module.finrank C S := by + let : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + let : Algebra (RatFunc S) (ExactConstantExtension C N S) := + ratFuncExactConstantExtensionAlgebra C S N hExact + rw [exactConstantExtensionPresentedPlace_degree_eq_div_gcd] + exact div_gcd_eq_one_iff_dvd + (Module.finrank C S) + (finiteExtensionPlaceDegree C N + (exactConstantExtensionPresentedDownstairsPlace C S N hExact q)) + (finiteExtensionPlaceDegree_pos C N + (exactConstantExtensionPresentedDownstairsPlace C S N hExact q)) + +/-- Presented rational places are the same subtype as presented places whose +downstairs degree contributes to the closed-place extension coefficient. -/ +def exactConstantExtensionPresentedRationalPlaceEquivDegreeDvd : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc S) (ExactConstantExtension C N S) := + ratFuncExactConstantExtensionAlgebra C S N hExact + {q : ExactConstantExtensionPresentedPlace C S N // + finiteExtensionPlaceDegree S (ExactConstantExtension C N S) + (exactConstantExtensionPresentedUpstairsPlace C S N hExact q) = 1} ≃ + {q : ExactConstantExtensionPresentedPlace C S N // + finiteExtensionPlaceDegree C N + (exactConstantExtensionPresentedDownstairsPlace C S N hExact q) ∣ + Module.finrank C S} := by + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc S) (ExactConstantExtension C N S) := + ratFuncExactConstantExtensionAlgebra C S N hExact + exact Equiv.subtypeEquivRight fun q => + exactConstantExtensionPresentedPlace_degree_eq_one_iff_dvd + C S N hExact q + +/-- Pointwise equality between the closed-place contribution and the +rational-presented-place indicator. -/ +theorem exactConstantExtensionPresentedPlace_closedContribution_eq + (q : ExactConstantExtensionPresentedPlace C S N) : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc S) (ExactConstantExtension C N S) := + ratFuncExactConstantExtensionAlgebra C S N hExact + (if finiteExtensionPlaceDegree S (ExactConstantExtension C N S) + (exactConstantExtensionPresentedUpstairsPlace C S N hExact q) = 1 + then finiteExtensionPlaceDegree C N + (exactConstantExtensionPresentedDownstairsPlace C S N hExact q) + else 0) = + (if finiteExtensionPlaceDegree C N + (exactConstantExtensionPresentedDownstairsPlace C S N hExact q) ∣ + Module.finrank C S + then finiteExtensionPlaceDegree C N + (exactConstantExtensionPresentedDownstairsPlace C S N hExact q) + else 0) := by + let : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + let : Algebra (RatFunc S) (ExactConstantExtension C N S) := + ratFuncExactConstantExtensionAlgebra C S N hExact + by_cases hrat : finiteExtensionPlaceDegree S + (ExactConstantExtension C N S) + (exactConstantExtensionPresentedUpstairsPlace C S N hExact q) = 1 + · have hdiv := + (exactConstantExtensionPresentedPlace_degree_eq_one_iff_dvd + C S N hExact q).mp hrat + simp [hrat, hdiv] + · have hndiv : ¬ finiteExtensionPlaceDegree C N + (exactConstantExtensionPresentedDownstairsPlace C S N hExact q) ∣ + Module.finrank C S := by + intro hdiv + exact hrat + ((exactConstantExtensionPresentedPlace_degree_eq_one_iff_dvd + C S N hExact q).mpr hdiv) + simp [hrat, hndiv] + +/-- Public unfolding of the closed-place extension coefficient. -/ +theorem finiteExtensionClosedPlaceExtensionCount_eq_degreeDvdSum + (r : ℕ) : + finiteExtensionClosedPlaceExtensionCount C N r = + letI := finiteExtensionPlaceDegreeLEFintype C N r + ∑ P : {P : FiniteExtensionPlace C N // + finiteExtensionPlaceDegree C N P ≤ r}, + if finiteExtensionPlaceDegree C N P.1 ∣ r then + finiteExtensionPlaceDegree C N P.1 else 0 := by + rfl + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/ConstantExtensionClosedPlaceSplittingFormula.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/ConstantExtensionClosedPlaceSplittingFormula.lean new file mode 100644 index 0000000000..786d1b5eaf --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/ConstantExtensionClosedPlaceSplittingFormula.lean @@ -0,0 +1,761 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.ConstantExtensionInfinityPlaceDegreeTower + +/-! +# Closed-place splitting formula for an exact extension of constants + +This file supplies the exhaustive presentation equivalences needed to sum +the local constant-extension splitting laws over all closed places. + +The finite branch is recorded first, then the reciprocal-infinity branch is +transported to actual places. Their exact sum-branch fiber equivalence gives +the global gcd splitting law and the closed-place degree-extension identity. +-/ + +@[expose] public section + +open scoped Polynomial TensorProduct + +namespace BGS.HasseWeil + +noncomputable section + +open BGS.CorvajaZannier + +section FinitePresentation + +variable (C S N : Type*) [Field C] [Field S] [Field N] + [Fintype C] [Finite S] + [DecidableEq C] [DecidableEq S] + [DecidableEq (RatFunc C)] [DecidableEq (RatFunc S)] + [Algebra (RatFunc C) N] [FiniteDimensional (RatFunc C) N] + [Algebra.IsSeparable (RatFunc C) N] + [Algebra C S] [FiniteDimensional C S] [IsGalois C S] + +local instance splittingFormulaBaseConstantAlgebra : Algebra C N := + bridgeBaseConstantAlgebra C N + +local instance splittingFormulaBaseConstantTower : + IsScalarTower C (RatFunc C) N := + IsScalarTower.of_algebraMap_eq' rfl + +local instance splittingFormulaTargetPolynomialAlgebra : + Algebra S[X] (ExactConstantExtension C N S) := + bridgeTargetPolynomialAlgebra C S N + +variable (hExact : algebraicClosure C N = + (⊥ : IntermediateField C N)) + +/-- The explicit `S[X]`-normalization presentation exhausts the actual +finite places over the enlarged rational function field `S(X)`. + +The first equivalence presents the same primes as places over `C(X)`; the +second is the finite-normalization base-change equivalence from `C` to `S`. +-/ +noncomputable def exactConstantExtensionPresentedUpstairsFinitePlaceEquiv : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + letI : Algebra (RatFunc S) (ExactConstantExtension C N S) := + ratFuncExactConstantExtensionAlgebra C S N hExact + IsDedekindDomain.HeightOneSpectrum + (integralClosure S[X] (ExactConstantExtension C N S)) ≃ + FiniteExtensionFinitePlace S (ExactConstantExtension C N S) := by + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + letI : Algebra (RatFunc S) (ExactConstantExtension C N S) := + ratFuncExactConstantExtensionAlgebra C S N hExact + let first := exactConstantExtensionPresentedFinitePlaceEquiv + C S N hExact + let second := IsDedekindDomain.HeightOneSpectrum.equivOfRingEquiv + (ratFuncFiniteIntegralClosureRingEquiv C S + (ExactConstantExtension C N S) + (exactConstantExtension_ratFunc_polynomialCompatibility + C S N hExact)) + exact first.trans second + +omit [DecidableEq C] [DecidableEq S] [DecidableEq (RatFunc C)] [DecidableEq (RatFunc S)] + [FiniteDimensional (RatFunc C) N] [Algebra.IsSeparable (RatFunc C) N] in +/-- The exhaustive finite-place equivalence is definitionally the existing +upstairs finite-place construction on presented primes. -/ +@[simp] +theorem exactConstantExtensionPresentedUpstairsFinitePlaceEquiv_apply + (q : IsDedekindDomain.HeightOneSpectrum + (integralClosure S[X] (ExactConstantExtension C N S))) : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + letI : Algebra (RatFunc S) (ExactConstantExtension C N S) := + ratFuncExactConstantExtensionAlgebra C S N hExact + exactConstantExtensionPresentedUpstairsFinitePlaceEquiv + C S N hExact q = + exactConstantExtensionUpstairsFinitePlace C S N hExact q := by + let : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : Algebra (RatFunc S) (ExactConstantExtension C N S) := + ratFuncExactConstantExtensionAlgebra C S N hExact + change IsDedekindDomain.HeightOneSpectrum.equivOfRingEquiv + (ratFuncFiniteIntegralClosureRingEquiv C S + (ExactConstantExtension C N S) + (exactConstantExtension_ratFunc_polynomialCompatibility + C S N hExact)) + (exactConstantExtensionPresentedFinitePlaceEquiv C S N hExact q) = _ + rw [exactConstantExtensionPresentedFinitePlaceEquiv_apply] + exact exactConstantExtensionCompatibleBaseFinitePlace_baseChange + C S N hExact q + +/-- Every downstairs finite place has the standard gcd number of presented +finite places above it. Unlike the selected-prime form of the splitting +theorem, this statement is indexed by an arbitrary downstairs place and is +therefore ready for fiberwise summation. -/ +theorem exactConstantExtensionPresentedFinitePlaceFiber_natCard_eq_gcd_of_downstairs + (P : FiniteExtensionFinitePlace C N) : + Nat.card {q : IsDedekindDomain.HeightOneSpectrum + (integralClosure S[X] (ExactConstantExtension C N S)) // + exactConstantExtensionDownstairsFinitePlace C S N hExact q = P} = + Nat.gcd (Module.finrank C S) + (finiteExtensionPlaceDegree C N (.inl P)) := by + let E := ExactConstantExtension C N S + let : Field E := exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) E := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : SMul (RatFunc C) E := Algebra.toSMul + let : Module (RatFunc C) E := Algebra.toModule + let : FiniteDimensional (RatFunc C) E := + finiteDimensional_exactConstantExtension_over_baseRatFunc + C S N hExact + let : Algebra.IsSeparable (RatFunc C) E := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + let : Algebra (RatFunc S) E := + ratFuncExactConstantExtensionAlgebra C S N hExact + let : Algebra N E := exactConstantExtensionAlgebra C N S + let : SMul N E := Algebra.toSMul + let : Module N E := Algebra.toModule + let : IsScalarTower (RatFunc C) N E := + exactConstantExtensionBaseTower C (RatFunc C) N S + obtain ⟨Q, hQ⟩ := finitePlaceUnder_surjective C N E P + let Q₀ : FinitePlaceUnderFiber C N E P := ⟨Q, hQ⟩ + let e := exactConstantExtensionPresentedFinitePlaceFiberEquiv + C S N hExact P + let q₀ := e.symm Q₀ + have hselected := + exactConstantExtensionPresentedFinitePlaceFiber_natCard_eq_gcd + C S N hExact q₀.1 + simpa only [q₀.2] using hselected + +end FinitePresentation + +section InfinityPresentation + + +private theorem splittingFormulaReciprocalPolynomialAlgebra_map + (K L : Type*) [Field K] [Field L] + [DecidableEq K] [DecidableEq (RatFunc K)] + [Algebra (RatFunc K) L] (p : K[X]) : + letI : Algebra K[X] L := + ratFuncExtensionReciprocalPolynomialAlgebra K L + algebraMap K[X] L p = algebraMap (RatFunc K) L + (((reciprocalPolynomialRingHom K p : + RatFuncInfinityIntegers K) : RatFunc K)) := by + let : Algebra K[X] L := + ratFuncExtensionReciprocalPolynomialAlgebra K L + change algebraMap (RatFuncInfinityIntegers K) L + (reciprocalPolynomialRingHom K p) = _ + exact IsScalarTower.algebraMap_apply + (RatFuncInfinityIntegers K) (RatFunc K) L _ + +variable (C S N : Type*) [Field C] [Field S] [Field N] + [Fintype C] [Finite S] + [DecidableEq C] [DecidableEq S] + [Algebra (RatFunc C) N] [FiniteDimensional (RatFunc C) N] + [Algebra.IsSeparable (RatFunc C) N] + [Algebra C S] [FiniteDimensional C S] [IsGalois C S] + +local instance (priority := 10000) splittingFormulaBaseRatFuncDecidableEq : + DecidableEq (RatFunc C) := + closedPlaceRatFuncBaseDecidableEq C + +local instance (priority := 10000) splittingFormulaTargetRatFuncDecidableEq : + DecidableEq (RatFunc S) := + closedPlaceRatFuncConstantsDecidableEq S + +local instance splittingFormulaInfinityBaseConstantAlgebra : Algebra C N := + bridgeBaseConstantAlgebra C N + +local instance splittingFormulaInfinityBaseConstantTower : + IsScalarTower C (RatFunc C) N := + IsScalarTower.of_algebraMap_eq' rfl + +local instance splittingFormulaBaseReciprocalPolynomialAlgebra : + Algebra C[X] N := + infinityBridgeBaseReciprocalPolynomialAlgebra C N + +local instance splittingFormulaBaseReciprocalConstantTower : + IsScalarTower C C[X] N := + infinityBridgeBaseConstantPolynomialTower C N + +local instance splittingFormulaOldNormalizationConstantAlgebra : + Algebra C (integralClosure C[X] N) := + infinityBridgeOldNormalizationConstantAlgebra C N + +local instance splittingFormulaOldNormalizationConstantTower : + IsScalarTower C C[X] (integralClosure C[X] N) := + infinityBridgeOldNormalizationConstantPolynomialTower C N + +local instance splittingFormulaTensorReciprocalPolynomialAlgebra : + Algebra S[X] (S ⊗[C] integralClosure C[X] N) := + infinityBridgeTensorPolynomialAlgebra C S N + +variable (hExact : algebraicClosure C N = + (⊥ : IntermediateField C N)) + +/-- The reciprocal-normalization presentation exhausts the actual infinity +places of the exact constant extension over the enlarged constant field +`S`. The equivalence first transports the reciprocal affine prime to the +`S[X]`-normalization, then localizes at the reciprocal origin. -/ +noncomputable def exactConstantExtensionPresentedUpstairsInfinityPlaceEquiv : + ExactConstantExtensionPresentedInfinityPlace C S N ≃ + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc S) (ExactConstantExtension C N S) := + ratFuncExactConstantExtensionAlgebra C S N hExact + FiniteExtensionInfinityPlace S (ExactConstantExtension C N S) := by + let E := ExactConstantExtension C N S + letI : Field E := exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc S) E := + ratFuncExactConstantExtensionAlgebra C S N hExact + letI : SMul (RatFunc S) E := Algebra.toSMul + letI : Module (RatFunc S) E := Algebra.toModule + letI : FiniteDimensional (RatFunc S) E := + finiteDimensional_over_extendedRatFunc C S N hExact + letI : Algebra.IsSeparable (RatFunc S) E := + isSeparable_over_extendedRatFunc C S N hExact + letI : Algebra S[X] E := + ratFuncExtensionReciprocalPolynomialAlgebra S E + letI : SMul S[X] E := Algebra.toSMul + letI : Module S[X] E := Algebra.toModule + let R := S ⊗[C] integralClosure C[X] N + let A := integralClosure S[X] E + let V := RatFuncInfinityIntegers S + let B := RatFuncInfinityIntegralClosure S E + let o := Ideal.span ({Polynomial.X} : Set S[X]) + let e := exactConstantExtensionInfinityAffineNormalizationAlgEquiv + C S N hExact + let eH := heightOneSpectrumEquivOfAlgEquiv e + let first : ExactConstantExtensionPresentedInfinityPlace C S N ≃ + {q : IsDedekindDomain.HeightOneSpectrum A // + q.asIdeal.under S[X] = o} := by + apply eH.subtypeEquiv + intro q + change q.asIdeal.under S[X] = o ↔ + (eH q).asIdeal.under S[X] = o + have hUnder : (eH q).asIdeal.under S[X] = + q.asIdeal.under S[X] := by + ext p + change e.symm _ ∈ q.asIdeal ↔ _ ∈ q.asIdeal + rw [e.symm.commutes] + rw [hUnder] + have ho : o ≠ ⊥ := by + exact fun h => Polynomial.X_ne_zero + (Ideal.span_singleton_eq_bot.mp h) + letI : o.IsPrime := + (Ideal.span_singleton_prime Polynomial.X_ne_zero).mpr + Polynomial.prime_X + letI : Algebra S[X] (RatFunc S) := + ratFuncExtensionReciprocalPolynomialAlgebra S (RatFunc S) + letI : SMul S[X] (RatFunc S) := Algebra.toSMul + letI : IsScalarTower S[X] (RatFunc S) E := + IsScalarTower.of_algebraMap_eq fun p => by + calc + algebraMap S[X] E p = + algebraMap (RatFunc S) E + (((reciprocalPolynomialRingHom S p : + RatFuncInfinityIntegers S) : RatFunc S)) := + splittingFormulaReciprocalPolynomialAlgebra_map S E p + _ = algebraMap (RatFunc S) E + (algebraMap S[X] (RatFunc S) p) := by + rw [splittingFormulaReciprocalPolynomialAlgebra_map + S (RatFunc S) p] + exact congrArg (algebraMap (RatFunc S) E) + (Algebra.algebraMap_self_apply _).symm + letI : IsFractionRing S[X] (RatFunc S) := + ratFunc_isFractionRing_reciprocalPolynomial S + letI : IsDedekindDomain A := + IsIntegralClosure.isDedekindDomain S[X] (RatFunc S) E A + letI : Module S[X] A := Algebra.toModule + letI : Module.IsTorsionFree S[X] E := by + rw [Module.isTorsionFree_iff_algebraMap_injective] + intro x y hxy + apply IsFractionRing.injective S[X] (RatFunc S) + apply (algebraMap (RatFunc S) E).injective + simpa only [IsScalarTower.algebraMap_apply S[X] (RatFunc S) E] + using hxy + letI : IsScalarTower S[X] A E := by infer_instance + letI : Module.IsTorsionFree S[X] A := + IsIntegralClosure.isTorsionFree S[X] E + let origin : IsDedekindDomain.HeightOneSpectrum S[X] := + ⟨o, inferInstance, ho⟩ + let second : {q : IsDedekindDomain.HeightOneSpectrum A // + q.asIdeal.under S[X] = o} ≃ o.primesOver A := + { toFun := fun q => ⟨q.1.asIdeal, q.1.isPrime, ⟨q.2.symm⟩⟩ + invFun := fun P => ⟨primeOverHeightOne origin P, by + exact (Ideal.over_def P.1 o).symm⟩ + left_inv := by + intro q + apply Subtype.ext + apply IsDedekindDomain.HeightOneSpectrum.ext + rfl + right_inv := by + intro P + apply Subtype.ext + rfl } + letI : Algebra S[X] V := + ratFuncInfinityReciprocalPolynomialAlgebra S + letI : IsLocalization o.primeCompl V := + ratFuncInfinityIntegers_isLocalization_reciprocal S + letI : Algebra A B := + ratFuncInfinityReciprocalIntegralClosureAlgebra S E + letI : SMul A B := Algebra.toSMul + letI : IsLocalization + (Algebra.algebraMapSubmonoid A o.primeCompl) B := + ratFuncInfinityIntegralClosure_isLocalization_reciprocal S E + letI : Algebra S[X] B := + RingHom.toAlgebra + ((algebraMap V B).comp (algebraMap S[X] V)) + letI : IsScalarTower S[X] V B := + IsScalarTower.of_algebraMap_eq' rfl + letI : IsScalarTower S[X] A B := + IsScalarTower.of_algebraMap_eq fun p => by + apply Subtype.ext + rfl + let third : o.primesOver A ≃ FiniteExtensionInfinityPlace S E := by + change o.primesOver A ≃ + (IsLocalRing.maximalIdeal V).primesOver B + exact (IsDedekindDomain.primesOverEquivPrimesOver + o V B ho).toEquiv + exact first.trans (second.trans third) + +omit [DecidableEq C] in +/-- On a reciprocal affine prime, the exhaustive equivalence is exactly the +existing upstairs infinity-place construction. -/ +@[simp] +theorem exactConstantExtensionPresentedUpstairsInfinityPlaceEquiv_apply + (q : ExactConstantExtensionPresentedInfinityPlace C S N) : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc S) (ExactConstantExtension C N S) := + ratFuncExactConstantExtensionAlgebra C S N hExact + exactConstantExtensionPresentedUpstairsInfinityPlaceEquiv + C S N hExact q = + exactConstantExtensionUpstairsInfinityPlace + C S N hExact q.1 q.2 := by + let E := ExactConstantExtension C N S + let : Field E := exactConstantExtensionField C N S hExact + let : Algebra (RatFunc S) E := + ratFuncExactConstantExtensionAlgebra C S N hExact + apply Subtype.ext + rfl + +include hExact + +omit [DecidableEq C] [DecidableEq S] in +/-- Every downstairs infinity place has the standard gcd number of presented +reciprocal-normalization places above it. This removes the selected-prime +index from the infinity splitting theorem and makes it ready for global +fiberwise summation. -/ +theorem exactConstantExtensionPresentedInfinityPlaceFiber_natCard_eq_gcd_of_downstairs : + letI : DecidableEq C := infinityBridgeDecidableEqConstants C + letI : DecidableEq (RatFunc C) := + infinityBridgeDecidableEqRatFuncConstants C + letI : DecidableEq S := infinityBridgeDecidableEqConstants S + letI : DecidableEq (RatFunc S) := + infinityBridgeDecidableEqRatFuncConstants S + (P : FiniteExtensionInfinityPlace C N) → + Nat.card {q : ExactConstantExtensionPresentedInfinityPlace C S N // + exactConstantExtensionDownstairsInfinityPlace + C S N q.1 q.2 = P} = + Nat.gcd (Module.finrank C S) + (finiteExtensionPlaceDegree C N (.inr P)) := by + let : DecidableEq C := infinityBridgeDecidableEqConstants C + let : DecidableEq (RatFunc C) := + infinityBridgeDecidableEqRatFuncConstants C + let : DecidableEq S := infinityBridgeDecidableEqConstants S + let : DecidableEq (RatFunc S) := + infinityBridgeDecidableEqRatFuncConstants S + intro P + let E := ExactConstantExtension C N S + let : Field E := exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) E := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : SMul (RatFunc C) E := Algebra.toSMul + let : Module (RatFunc C) E := Algebra.toModule + let : FiniteDimensional (RatFunc C) E := + finiteDimensional_exactConstantExtension_over_baseRatFunc + C S N hExact + let : Algebra.IsSeparable (RatFunc C) E := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + let : Algebra (RatFunc S) E := + ratFuncExactConstantExtensionAlgebra C S N hExact + let : Algebra N E := exactConstantExtensionAlgebra C N S + let : SMul N E := Algebra.toSMul + let : Module N E := Algebra.toModule + let : IsScalarTower (RatFunc C) N E := + exactConstantExtensionBaseTower C (RatFunc C) N S + obtain ⟨Q, hQ⟩ := infinityPlaceUnder_surjective C N E P + let Q₀ : InfinityPlaceUnderFiber C N E P := ⟨Q, hQ⟩ + let e := exactConstantExtensionPresentedInfinityPlaceFiberEquiv + C S N hExact P + let q₀ := e.symm Q₀ + have hselected := + exactConstantExtensionPresentedInfinityPlaceFiber_natCard_eq_gcd + C S N hExact q₀.1 + simpa only [q₀.2] using hselected + +end InfinityPresentation + +section GlobalPresentation + +variable (C S N : Type*) [Field C] [Field S] [Field N] + [Fintype C] [Finite S] + [DecidableEq C] [DecidableEq S] + [Algebra (RatFunc C) N] [FiniteDimensional (RatFunc C) N] + [Algebra.IsSeparable (RatFunc C) N] + [Algebra C S] [FiniteDimensional C S] [IsGalois C S] + +local instance (priority := 10000) globalPresentationBaseRatFuncDecidableEq : + DecidableEq (RatFunc C) := + closedPlaceRatFuncBaseDecidableEq C + +local instance (priority := 10000) globalPresentationTargetRatFuncDecidableEq : + DecidableEq (RatFunc S) := + closedPlaceRatFuncConstantsDecidableEq S + +local instance globalPresentationBaseConstantAlgebra : Algebra C N := + bridgeBaseConstantAlgebra C N + +local instance globalPresentationBaseConstantTower : + IsScalarTower C (RatFunc C) N := + IsScalarTower.of_algebraMap_eq' rfl + +local instance globalPresentationTargetPolynomialAlgebra : + Algebra S[X] (ExactConstantExtension C N S) := + bridgeTargetPolynomialAlgebra C S N + +variable (hExact : algebraicClosure C N = + (⊥ : IntermediateField C N)) + +/-- The finite-normalization and reciprocal-normalization presentations +together exhaust all actual closed places of the exact constant extension +over `S`. -/ +noncomputable def exactConstantExtensionPresentedUpstairsPlaceEquiv : + ExactConstantExtensionPresentedPlace C S N ≃ + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc S) (ExactConstantExtension C N S) := + ratFuncExactConstantExtensionAlgebra C S N hExact + FiniteExtensionPlace S (ExactConstantExtension C N S) := by + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + letI : Algebra (RatFunc S) (ExactConstantExtension C N S) := + ratFuncExactConstantExtensionAlgebra C S N hExact + exact Equiv.sumCongr + (exactConstantExtensionPresentedUpstairsFinitePlaceEquiv + C S N hExact) + (exactConstantExtensionPresentedUpstairsInfinityPlaceEquiv + C S N hExact) + +/-- The global exhaustive equivalence agrees branchwise with the existing +presented-upstairs-place construction. -/ +@[simp] +theorem exactConstantExtensionPresentedUpstairsPlaceEquiv_apply + (q : ExactConstantExtensionPresentedPlace C S N) : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc S) (ExactConstantExtension C N S) := + ratFuncExactConstantExtensionAlgebra C S N hExact + exactConstantExtensionPresentedUpstairsPlaceEquiv C S N hExact q = + exactConstantExtensionPresentedUpstairsPlace C S N hExact q := by + let : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : Algebra (RatFunc S) (ExactConstantExtension C N S) := + ratFuncExactConstantExtensionAlgebra C S N hExact + cases q with + | inl q => + change Sum.inl + (exactConstantExtensionPresentedUpstairsFinitePlaceEquiv + C S N hExact q) = + Sum.inl + (exactConstantExtensionUpstairsFinitePlace C S N hExact q) + exact congrArg Sum.inl + (exactConstantExtensionPresentedUpstairsFinitePlaceEquiv_apply + C S N hExact q) + | inr q => + change Sum.inr + (exactConstantExtensionPresentedUpstairsInfinityPlaceEquiv + C S N hExact q) = + Sum.inr + (exactConstantExtensionUpstairsInfinityPlace + C S N hExact q.1 q.2) + exact congrArg Sum.inr + (exactConstantExtensionPresentedUpstairsInfinityPlaceEquiv_apply + C S N hExact q) + +include hExact + +omit [DecidableEq C] [DecidableEq S] in +/-- The contraction fiber of the combined finite-plus-infinity presentation +over an arbitrary downstairs closed place has the standard gcd cardinality. +The proof is an exact branchwise fiber equivalence, so finite and infinity +places cannot be mixed by the presentation map. -/ +theorem exactConstantExtensionPresentedPlaceFiber_natCard_eq_gcd_of_downstairs : + letI : DecidableEq C := infinityBridgeDecidableEqConstants C + letI : DecidableEq (RatFunc C) := + infinityBridgeDecidableEqRatFuncConstants C + letI : DecidableEq S := infinityBridgeDecidableEqConstants S + letI : DecidableEq (RatFunc S) := + infinityBridgeDecidableEqRatFuncConstants S + (P : FiniteExtensionPlace C N) → + Nat.card {q : ExactConstantExtensionPresentedPlace C S N // + exactConstantExtensionPresentedDownstairsPlace + C S N hExact q = P} = + Nat.gcd (Module.finrank C S) + (finiteExtensionPlaceDegree C N P) := by + let : DecidableEq C := infinityBridgeDecidableEqConstants C + let : DecidableEq (RatFunc C) := + infinityBridgeDecidableEqRatFuncConstants C + let : DecidableEq S := infinityBridgeDecidableEqConstants S + let : DecidableEq (RatFunc S) := + infinityBridgeDecidableEqRatFuncConstants S + intro P + cases P with + | inl P => + let e : {q : ExactConstantExtensionPresentedPlace C S N // + exactConstantExtensionPresentedDownstairsPlace + C S N hExact q = .inl P} ≃ + {q : IsDedekindDomain.HeightOneSpectrum + (integralClosure S[X] (ExactConstantExtension C N S)) // + exactConstantExtensionDownstairsFinitePlace + C S N hExact q = P} := + { toFun := fun q => by + rcases q with ⟨q, hq⟩ + cases q with + | inl q => + refine ⟨q, ?_⟩ + exact Sum.inl.inj hq + | inr q => + change Sum.inr _ = Sum.inl P at hq + exact (Sum.inr_ne_inl hq).elim + invFun := fun q => + ⟨.inl q.1, congrArg Sum.inl q.2⟩ + left_inv := by + intro q + apply Subtype.ext + rcases q with ⟨q, hq⟩ + cases q with + | inl q => rfl + | inr q => + change Sum.inr _ = Sum.inl P at hq + exact (Sum.inr_ne_inl hq).elim + right_inv := by + intro q + apply Subtype.ext + rfl } + calc + Nat.card {q : ExactConstantExtensionPresentedPlace C S N // + exactConstantExtensionPresentedDownstairsPlace + C S N hExact q = .inl P} = + Nat.card {q : IsDedekindDomain.HeightOneSpectrum + (integralClosure S[X] (ExactConstantExtension C N S)) // + exactConstantExtensionDownstairsFinitePlace + C S N hExact q = P} := Nat.card_congr e + _ = Nat.gcd (Module.finrank C S) + (finiteExtensionPlaceDegree C N (.inl P)) := + exactConstantExtensionPresentedFinitePlaceFiber_natCard_eq_gcd_of_downstairs + C S N hExact P + | inr P => + let e : {q : ExactConstantExtensionPresentedPlace C S N // + exactConstantExtensionPresentedDownstairsPlace + C S N hExact q = .inr P} ≃ + {q : ExactConstantExtensionPresentedInfinityPlace C S N // + exactConstantExtensionDownstairsInfinityPlace + C S N q.1 q.2 = P} := + { toFun := fun q => by + rcases q with ⟨q, hq⟩ + cases q with + | inl q => + change Sum.inl _ = Sum.inr P at hq + exact (Sum.inl_ne_inr hq).elim + | inr q => + refine ⟨q, ?_⟩ + exact Sum.inr.inj hq + invFun := fun q => + ⟨.inr q.1, congrArg Sum.inr q.2⟩ + left_inv := by + intro q + apply Subtype.ext + rcases q with ⟨q, hq⟩ + cases q with + | inl q => + change Sum.inl _ = Sum.inr P at hq + exact (Sum.inl_ne_inr hq).elim + | inr q => rfl + right_inv := by + intro q + apply Subtype.ext + rfl } + calc + Nat.card {q : ExactConstantExtensionPresentedPlace C S N // + exactConstantExtensionPresentedDownstairsPlace + C S N hExact q = .inr P} = + Nat.card {q : ExactConstantExtensionPresentedInfinityPlace C S N // + exactConstantExtensionDownstairsInfinityPlace + C S N q.1 q.2 = P} := Nat.card_congr e + _ = Nat.gcd (Module.finrank C S) + (finiteExtensionPlaceDegree C N (.inr P)) := + exactConstantExtensionPresentedInfinityPlaceFiber_natCard_eq_gcd_of_downstairs + C S N hExact P + +omit [DecidableEq C] [DecidableEq S] in +/-- Exact closed-place count identity for an extension of constants. At +level `n`, the exhaustive closed-place count over `S` is the original count +at level `[S : C] * n`. The proof transfers the bounded upstairs family +through the exhaustive presentation equivalence and sums the degree and gcd +fiber formulas. -/ +theorem exactConstantExtensionClosedPlaceExtensionCount_eq + (level : ℕ) : + letI : DecidableEq C := infinityBridgeDecidableEqConstants C + letI : DecidableEq (RatFunc C) := + infinityBridgeDecidableEqRatFuncConstants C + letI : DecidableEq S := infinityBridgeDecidableEqConstants S + letI : DecidableEq (RatFunc S) := + infinityBridgeDecidableEqRatFuncConstants S + letI : Fintype S := Fintype.ofFinite S + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc S) (ExactConstantExtension C N S) := + ratFuncExactConstantExtensionAlgebra C S N hExact + letI : SMul (RatFunc S) (ExactConstantExtension C N S) := + Algebra.toSMul + letI : Module (RatFunc S) (ExactConstantExtension C N S) := + Algebra.toModule + letI : FiniteDimensional (RatFunc S) + (ExactConstantExtension C N S) := + finiteDimensional_over_extendedRatFunc C S N hExact + letI : Algebra.IsSeparable (RatFunc S) + (ExactConstantExtension C N S) := + isSeparable_over_extendedRatFunc C S N hExact + finiteExtensionClosedPlaceExtensionCount S + (ExactConstantExtension C N S) level = + finiteExtensionClosedPlaceExtensionCount C N + (Module.finrank C S * level) := by + let : DecidableEq C := infinityBridgeDecidableEqConstants C + let : DecidableEq (RatFunc C) := + infinityBridgeDecidableEqRatFuncConstants C + let : DecidableEq S := infinityBridgeDecidableEqConstants S + let : DecidableEq (RatFunc S) := + infinityBridgeDecidableEqRatFuncConstants S + let : Fintype S := Fintype.ofFinite S + let E := ExactConstantExtension C N S + let : Field E := exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) E := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : SMul (RatFunc C) E := Algebra.toSMul + let : Module (RatFunc C) E := Algebra.toModule + let : FiniteDimensional (RatFunc C) E := + finiteDimensional_exactConstantExtension_over_baseRatFunc + C S N hExact + let : Algebra.IsSeparable (RatFunc C) E := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + let : Algebra (RatFunc S) E := + ratFuncExactConstantExtensionAlgebra C S N hExact + let : SMul (RatFunc S) E := Algebra.toSMul + let : Module (RatFunc S) E := Algebra.toModule + let : FiniteDimensional (RatFunc S) E := + finiteDimensional_over_extendedRatFunc C S N hExact + let : Algebra.IsSeparable (RatFunc S) E := + isSeparable_over_extendedRatFunc C S N hExact + by_cases hlevel : level = 0 + · subst level + simp + have hlevelPos : 0 < level := Nat.pos_of_ne_zero hlevel + let Base := FiniteExtensionPlace C N + let Up := ExactConstantExtensionPresentedPlace C S N + let Actual := FiniteExtensionPlace S E + let down : Up → Base := + exactConstantExtensionPresentedDownstairsPlace C S N hExact + let baseDegree : Base → ℕ := finiteExtensionPlaceDegree C N + let e : Up ≃ Actual := + exactConstantExtensionPresentedUpstairsPlaceEquiv C S N hExact + let upDegree : Up → ℕ := fun q => + finiteExtensionPlaceDegree S E (e q) + let BaseLE := {P : Base // + baseDegree P ≤ Module.finrank C S * level} + let UpLE := {q : Up // upDegree q ≤ level} + let ActualLE := {Q : Actual // + finiteExtensionPlaceDegree S E Q ≤ level} + let : Fintype BaseLE := + finiteExtensionPlaceDegreeLEFintype C N + (Module.finrank C S * level) + let : Fintype ActualLE := + finiteExtensionPlaceDegreeLEFintype S E level + let eLE : UpLE ≃ ActualLE := + Equiv.subtypeEquiv e (fun _ => Iff.rfl) + let : Fintype UpLE := Fintype.ofEquiv ActualLE eLE.symm + let UpDvd := {q : UpLE // upDegree q.1 ∣ level} + let ActualDvd := {Q : ActualLE // + finiteExtensionPlaceDegree S E Q.1 ∣ level} + let eDvd : UpDvd ≃ ActualDvd := + Equiv.subtypeEquiv eLE (fun _ => Iff.rfl) + have hsumPresented : + (∑ q : UpDvd, upDegree q.1.1) = + ∑ P : {P : BaseLE // + baseDegree P.1 ∣ Module.finrank C S * level}, + baseDegree P.1.1 := by + apply sum_degree_dvd_eq_sum_degree_dvd_of_div_gcd_fibers + down baseDegree upDegree (Module.finrank C S) level + Module.finrank_pos hlevelPos + · intro q + change finiteExtensionPlaceDegree S E (e q) = + finiteExtensionPlaceDegree C N (down q) / + Nat.gcd (Module.finrank C S) + (finiteExtensionPlaceDegree C N (down q)) + dsimp [e, down] + rw [exactConstantExtensionPresentedUpstairsPlaceEquiv_apply] + exact exactConstantExtensionPresentedPlace_degree_eq_div_gcd + C S N hExact q + · intro P + exact exactConstantExtensionPresentedPlaceFiber_natCard_eq_gcd_of_downstairs + C S N hExact P + have hsumEquiv : + (∑ q : UpDvd, upDegree q.1.1) = + ∑ Q : ActualDvd, + finiteExtensionPlaceDegree S E Q.1.1 := by + apply Fintype.sum_equiv eDvd + intro q + rfl + rw [finiteExtensionClosedPlaceExtensionCount_eq_sum_degree_dvd, + finiteExtensionClosedPlaceExtensionCount_eq_sum_degree_dvd] + exact hsumEquiv.symm.trans hsumPresented + +end GlobalPresentation + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/ConstantExtensionFinitePlaceBridge.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/ConstantExtensionFinitePlaceBridge.lean new file mode 100644 index 0000000000..1cc7955ea4 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/ConstantExtensionFinitePlaceBridge.lean @@ -0,0 +1,327 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteFieldConstantExtensionResidue +public import LeanPool.MarkoffModP.BGS.HasseWeil.FinitePlaceNormalizationTransport +public import LeanPool.MarkoffModP.BGS.HasseWeil.FunctionFieldConstantField +public import LeanPool.MarkoffModP.BGS.HasseWeil.RatFuncExactConstantExtension + +/-! +# Finite places in an exact constant extension + +Let `N / C(X)` be finite separable with exact constant field `C`, and let `S / C` +be finite Galois. This file connects maximal ideals in the explicit +normalization of `S ⊗[C] N` to the project's finite-place types over `S` and +`C`. It proves that the upstairs residue field is finite, packages the +downstairs contraction as an actual finite place of `N`, and expresses the +constant-extension residue formula as + +`deg_S(Q) = deg_C(P) / gcd([S : C], deg_C(P))`. + +No maximality or residue-finiteness hypothesis is left to downstream users. +-/ + +@[expose] public section + +open scoped Polynomial TensorProduct + +namespace BGS.HasseWeil + +noncomputable section + +open BGS.CorvajaZannier + + +variable (C S N : Type*) [Field C] [Field S] [Field N] + [Fintype C] [Finite S] + [DecidableEq C] [DecidableEq S] + [DecidableEq (RatFunc C)] [DecidableEq (RatFunc S)] + [Algebra (RatFunc C) N] [FiniteDimensional (RatFunc C) N] + [Algebra.IsSeparable (RatFunc C) N] + [Algebra C S] [FiniteDimensional C S] [IsGalois C S] + +local instance bridgeBaseConstantAlgebra : Algebra C N := + RingHom.toAlgebra ((algebraMap (RatFunc C) N).comp + (algebraMap C (RatFunc C))) + +local instance (priority := 10000) bridgeBasePolynomialAlgebra : Algebra C[X] N := + ratFuncInducedPolynomialAlgebra C N + +local instance bridgeBaseConstantPolynomialTower : + IsScalarTower C C[X] N := + IsScalarTower.of_algebraMap_eq' (by + ext c + rfl) + +local instance (priority := 10000) bridgeTargetPolynomialAlgebra : + Algebra S[X] (ExactConstantExtension C N S) := + constantExtensionTensorPolynomialAlgebra C S N + +local instance (priority := 10000) bridgeTensorNormalizationPolynomialAlgebra : + Algebra S[X] (S ⊗[C] integralClosure C[X] N) := + constantExtensionNormalizationTensorPolynomialAlgebra C S N + +local instance bridgeUpstairsConstantAlgebra : + Algebra S + (integralClosure S[X] (ExactConstantExtension C N S)) := + RingHom.toAlgebra + ((algebraMap S[X] + (integralClosure S[X] (ExactConstantExtension C N S))).comp + (algebraMap S S[X])) + +variable (hExact : algebraicClosure C N = + (⊥ : IntermediateField C N)) + +/-- A ring equivalence transports the residue field of a height-one ideal. -/ +private noncomputable def heightOneResidueFieldRingEquiv + {A B : Type*} [CommRing A] [CommRing B] + (e : A ≃+* B) (q : IsDedekindDomain.HeightOneSpectrum A) : + q.asIdeal.ResidueField ≃+* + (IsDedekindDomain.HeightOneSpectrum.equivOfRingEquiv e q).asIdeal.ResidueField := + Ideal.residueFieldRingEquiv q.asIdeal + (IsDedekindDomain.HeightOneSpectrum.equivOfRingEquiv e q).asIdeal e + (by + change q.asIdeal = (q.asIdeal.comap e.symm).comap e + exact (Ideal.comap_of_equiv e).symm) + +/-- Pull an ideal in the explicit base-changed normalization back to the +constant tensor of the original normalization. -/ +noncomputable def exactConstantExtensionTensorNormalizationHeightOne + (q : IsDedekindDomain.HeightOneSpectrum + (integralClosure S[X] (ExactConstantExtension C N S))) : + IsDedekindDomain.HeightOneSpectrum + (S ⊗[C] integralClosure C[X] N) := + heightOneSpectrumEquivOfAlgEquiv + (finiteFieldConstantExtensionIntegralClosureAlgEquiv C S N).symm q + +/-- Package a height-one ideal of the explicit normalization as an actual +finite place over `S`. -/ +noncomputable def exactConstantExtensionUpstairsFinitePlace + (q : IsDedekindDomain.HeightOneSpectrum + (integralClosure S[X] (ExactConstantExtension C N S))) : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc S) (ExactConstantExtension C N S) := + ratFuncExactConstantExtensionAlgebra C S N hExact + FiniteExtensionFinitePlace S (ExactConstantExtension C N S) := by + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc S) (ExactConstantExtension C N S) := + ratFuncExactConstantExtensionAlgebra C S N hExact + exact finiteExtensionFinitePlaceEquivOfNormalizationAlgEquiv + S (ExactConstantExtension C N S) + (S ⊗[C] integralClosure C[X] N) + (exactConstantExtensionNormalizationAlgEquiv C S N hExact) + (exactConstantExtensionTensorNormalizationHeightOne C S N q) + +include hExact + +omit [Fintype C] [DecidableEq C] [DecidableEq S] + [DecidableEq (RatFunc C)] [DecidableEq (RatFunc S)] in +/-- The residue field of an upstairs height-one ideal is finite. -/ +theorem exactConstantExtensionUpstairsResidueField_finite [Finite C] + (q : IsDedekindDomain.HeightOneSpectrum + (integralClosure S[X] (ExactConstantExtension C N S))) : + Finite q.asIdeal.ResidueField := by + let : Fintype C := Fintype.ofFinite C + let : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + let : Algebra (RatFunc S) (ExactConstantExtension C N S) := + ratFuncExactConstantExtensionAlgebra C S N hExact + let : SMul (RatFunc S) (ExactConstantExtension C N S) := + Algebra.toSMul + let : Module (RatFunc S) (ExactConstantExtension C N S) := + Algebra.toModule + let : FiniteDimensional (RatFunc S) + (ExactConstantExtension C N S) := + finiteDimensional_over_extendedRatFunc C S N hExact + let : Algebra.IsSeparable (RatFunc S) + (ExactConstantExtension C N S) := + isSeparable_over_extendedRatFunc C S N hExact + let : Fintype S := Fintype.ofFinite S + let qTensor := exactConstantExtensionTensorNormalizationHeightOne C S N q + let e₂ := exactConstantExtensionNormalizationAlgEquiv C S N hExact + let Q : FiniteExtensionFinitePlace S (ExactConstantExtension C N S) := + IsDedekindDomain.HeightOneSpectrum.equivOfRingEquiv + e₂.toRingEquiv qTensor + let : Finite Q.asIdeal.ResidueField := + finiteExtensionFinitePlaceResidueField_finite S + (ExactConstantExtension C N S) Q + let e₁ := finiteFieldConstantExtensionIntegralClosureAlgEquiv C S N + let r₁ := heightOneResidueFieldRingEquiv e₁.symm.toRingEquiv q + let r₂ := heightOneResidueFieldRingEquiv e₂.toRingEquiv qTensor + exact Finite.of_injective (r₂ ∘ r₁) (r₂.injective.comp r₁.injective) + +omit [Fintype C] [DecidableEq C] [DecidableEq S] + [DecidableEq (RatFunc C)] [DecidableEq (RatFunc S)] in +/-- Every upstairs height-one ideal is maximal. -/ +theorem exactConstantExtensionUpstairsIdeal_isMaximal [Finite C] + (q : IsDedekindDomain.HeightOneSpectrum + (integralClosure S[X] (ExactConstantExtension C N S))) : + q.asIdeal.IsMaximal := by + let : Finite q.asIdeal.ResidueField := + exactConstantExtensionUpstairsResidueField_finite C S N hExact q + let : Finite + (integralClosure S[X] (ExactConstantExtension C N S) ⧸ q.asIdeal) := + Finite.of_injective + (algebraMap + (integralClosure S[X] (ExactConstantExtension C N S) ⧸ q.asIdeal) + q.asIdeal.ResidueField) + q.asIdeal.injective_algebraMap_quotient_residueField + exact (Ideal.Quotient.maximal_ideal_iff_isField_quotient q.asIdeal).mpr + (Finite.isField_of_domain + (integralClosure S[X] (ExactConstantExtension C N S) ⧸ q.asIdeal)) + +/-- Package the downstairs contraction as an actual finite place of `N/C(X)`. -/ +noncomputable def exactConstantExtensionDownstairsFinitePlace + (q : IsDedekindDomain.HeightOneSpectrum + (integralClosure S[X] (ExactConstantExtension C N S))) : + FiniteExtensionFinitePlace C N := by + letI : Finite q.asIdeal.ResidueField := + exactConstantExtensionUpstairsResidueField_finite C S N hExact q + letI : q.asIdeal.IsMaximal := + exactConstantExtensionUpstairsIdeal_isMaximal C S N hExact q + let p := finiteFieldConstantExtensionDownstairsIdeal C S N q.asIdeal + letI : p.IsMaximal := + finiteFieldConstantExtensionDownstairsIdeal_isMaximal C S N q.asIdeal + change IsDedekindDomain.HeightOneSpectrum (integralClosure C[X] N) + exact + { asIdeal := p + isPrime := Ideal.IsMaximal.isPrime + (show p.IsMaximal from inferInstance) + ne_bot := Ring.ne_bot_of_isMaximal_of_not_isField + (show p.IsMaximal from inferInstance) + (by + intro hfield + have hinj : Function.Injective + (algebraMap C[X] (integralClosure C[X] N)) := by + intro x y hxy + apply RatFunc.algebraMap_injective C + apply (algebraMap (RatFunc C) N).injective + exact congrArg Subtype.val hxy + exact Polynomial.not_isField C + (isField_of_isIntegral_of_isField hinj hfield)) } + +omit [DecidableEq C] [DecidableEq (RatFunc C)] + [DecidableEq (RatFunc S)] in +omit [DecidableEq S] in +@[simp] +theorem exactConstantExtensionDownstairsFinitePlace_asIdeal + (q : IsDedekindDomain.HeightOneSpectrum + (integralClosure S[X] (ExactConstantExtension C N S))) : + (exactConstantExtensionDownstairsFinitePlace C S N hExact q).asIdeal = + finiteFieldConstantExtensionDownstairsIdeal C S N q.asIdeal := + rfl + +/-- Constant extension changes the degree of an actual finite place by the +standard division-by-gcd formula. -/ +theorem exactConstantExtensionFinitePlace_degree_eq_div_gcd + (q : IsDedekindDomain.HeightOneSpectrum + (integralClosure S[X] (ExactConstantExtension C N S))) : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc S) (ExactConstantExtension C N S) := + ratFuncExactConstantExtensionAlgebra C S N hExact + finiteExtensionPlaceDegree S (ExactConstantExtension C N S) + (.inl (exactConstantExtensionUpstairsFinitePlace C S N hExact q)) = + finiteExtensionPlaceDegree C N + (.inl (exactConstantExtensionDownstairsFinitePlace C S N hExact q)) / + Nat.gcd (Module.finrank C S) + (finiteExtensionPlaceDegree C N + (.inl (exactConstantExtensionDownstairsFinitePlace C S N hExact q))) := by + let : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + let : Algebra (RatFunc S) (ExactConstantExtension C N S) := + ratFuncExactConstantExtensionAlgebra C S N hExact + let : SMul (RatFunc S) (ExactConstantExtension C N S) := + Algebra.toSMul + let : Module (RatFunc S) (ExactConstantExtension C N S) := + Algebra.toModule + let : FiniteDimensional (RatFunc S) + (ExactConstantExtension C N S) := + finiteDimensional_over_extendedRatFunc C S N hExact + let : Algebra.IsSeparable (RatFunc S) + (ExactConstantExtension C N S) := + isSeparable_over_extendedRatFunc C S N hExact + let : Finite q.asIdeal.ResidueField := + exactConstantExtensionUpstairsResidueField_finite C S N hExact q + let : q.asIdeal.IsMaximal := + exactConstantExtensionUpstairsIdeal_isMaximal C S N hExact q + let A := S ⊗[C] integralClosure C[X] N + let T := ExactConstantExtension C N S + let : Algebra S[X] A := + bridgeTensorNormalizationPolynomialAlgebra C S N + let : Algebra S A := Algebra.TensorProduct.leftAlgebra + let : Algebra S (RatFuncFiniteIntegralClosure S T) := + RingHom.toAlgebra + ((algebraMap S[X] (RatFuncFiniteIntegralClosure S T)).comp + (algebraMap S S[X])) + let : SMul S A := Algebra.toSMul + let : SMul S (RatFuncFiniteIntegralClosure S T) := Algebra.toSMul + let : SMul S[X] (RatFuncFiniteIntegralClosure S T) := Algebra.toSMul + let : IsScalarTower S S[X] (RatFuncFiniteIntegralClosure S T) := + IsScalarTower.of_algebraMap_eq' rfl + let qTensor := exactConstantExtensionTensorNormalizationHeightOne C S N q + let Q := exactConstantExtensionUpstairsFinitePlace C S N hExact q + let P := exactConstantExtensionDownstairsFinitePlace C S N hExact q + let : (finiteFieldConstantExtensionTensorIdeal + C S N q.asIdeal).IsPrime := by + change qTensor.asIdeal.IsPrime + exact qTensor.isPrime + let p := finiteFieldConstantExtensionDownstairsIdeal C S N q.asIdeal + let : p.IsMaximal := + finiteFieldConstantExtensionDownstairsIdeal_isMaximal C S N q.asIdeal + let : p.IsPrime := Ideal.IsMaximal.isPrime + (show p.IsMaximal from inferInstance) + let e₂ := exactConstantExtensionNormalizationAlgEquiv C S N hExact + let e₂S : A ≃ₐ[S] RatFuncFiniteIntegralClosure S T := + { e₂.toRingEquiv with + commutes' := fun s => by + change e₂ (s ⊗ₜ[C] (1 : integralClosure C[X] N)) = + algebraMap S[X] (RatFuncFiniteIntegralClosure S T) (Polynomial.C s) + rw [← e₂.commutes (Polynomial.C s)] + congr 1 + change s ⊗ₜ[C] (1 : integralClosure C[X] N) = + Polynomial.aeval + (polynomialTensorCancelEvaluationPoint C S + (integralClosure C[X] N)) (Polynomial.C s) + simp } + have hTensorToUpstairs : + Module.finrank S qTensor.asIdeal.ResidueField = + Module.finrank S q.asIdeal.ResidueField := by + change Module.finrank S + (finiteFieldConstantExtensionTensorIdeal C S N q.asIdeal).ResidueField = + Module.finrank S q.asIdeal.ResidueField + exact (finiteFieldConstantExtensionResidueFieldAlgEquiv + C S N q.asIdeal).toLinearEquiv.finrank_eq + have hTensorToPlace : + Module.finrank S qTensor.asIdeal.ResidueField = + Module.finrank S Q.asIdeal.ResidueField := by + exact heightOneSpectrum_residueField_finrank_eq e₂S qTensor + rw [finiteExtensionFinitePlace_degree_eq_finrank_residueField S T Q, + finiteExtensionFinitePlace_degree_eq_finrank_residueField C N P] + calc + Module.finrank S Q.asIdeal.ResidueField = + Module.finrank S qTensor.asIdeal.ResidueField := hTensorToPlace.symm + _ = Module.finrank S q.asIdeal.ResidueField := hTensorToUpstairs + _ = Module.finrank C + (finiteFieldConstantExtensionDownstairsIdeal C S N q.asIdeal).ResidueField / + Nat.gcd (Module.finrank C S) + (Module.finrank C + (finiteFieldConstantExtensionDownstairsIdeal + C S N q.asIdeal).ResidueField) := + finiteFieldConstantExtensionResidue_finrank_over_constants_eq_div_gcd + C S N q.asIdeal + _ = Module.finrank C P.asIdeal.ResidueField / + Nat.gcd (Module.finrank C S) + (Module.finrank C P.asIdeal.ResidueField) := by + rfl + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/ConstantExtensionInfinityPlaceBridge.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/ConstantExtensionInfinityPlaceBridge.lean new file mode 100644 index 0000000000..f09304e176 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/ConstantExtensionInfinityPlaceBridge.lean @@ -0,0 +1,1001 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.ConstantTensorResidue +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionInfinityNormalization +public import LeanPool.MarkoffModP.BGS.HasseWeil.OnePointLeadingCoefficient + +/-! +# Infinity places in an exact constant extension + +This file localizes the reciprocal affine normalizations used by the exact +constant-extension model. A height-one prime of + +`S ⊗[C] integralClosure C[X] N` + +above the reciprocal origin gives actual places above infinity in both the +extended function field and the original function field. Their residue +degrees satisfy the usual division-by-gcd formula. +-/ + +@[expose] public section + +open scoped Polynomial TensorProduct nonZeroDivisors + +namespace BGS.HasseWeil + +noncomputable section + +open BGS.CorvajaZannier IsDedekindDomain + + +section ReciprocalFractionField + +variable (K : Type*) [Field K] [DecidableEq K] [DecidableEq (RatFunc K)] + +@[reducible] private noncomputable def canonicalRatFuncPolynomialAlgebra : + Algebra K[X] (RatFunc K) := inferInstance + +omit [DecidableEq K] [DecidableEq (RatFunc K)] in +private theorem canonicalRatFuncPolynomialFractionRing : + letI := canonicalRatFuncPolynomialAlgebra K + IsFractionRing K[X] (RatFunc K) := by + let := canonicalRatFuncPolynomialAlgebra K + infer_instance + +omit [DecidableEq K] [DecidableEq (RatFunc K)] in +private theorem canonicalRatFuncPolynomialAlgebraMap_injective : + Function.Injective + (@algebraMap K[X] (RatFunc K) _ _ + (canonicalRatFuncPolynomialAlgebra K)) := by + let := canonicalRatFuncPolynomialAlgebra K + exact RatFunc.algebraMap_injective K + +omit [DecidableEq K] [DecidableEq (RatFunc K)] in +private theorem canonicalRatFunc_div_surjective (z : RatFunc K) : + ∃ p q : K[X], q ≠ 0 ∧ z = + @algebraMap K[X] (RatFunc K) _ _ + (canonicalRatFuncPolynomialAlgebra K) p / + @algebraMap K[X] (RatFunc K) _ _ + (canonicalRatFuncPolynomialAlgebra K) q := by + let := canonicalRatFuncPolynomialAlgebra K + let : IsFractionRing K[X] (RatFunc K) := + canonicalRatFuncPolynomialFractionRing K + obtain ⟨p, q, hq, h⟩ := IsFractionRing.div_surjective K[X] z + exact ⟨p, q, nonZeroDivisors.ne_zero hq, h.symm⟩ + +local instance reciprocalRatFuncPolynomialAlgebra : + Algebra K[X] (RatFunc K) := + ratFuncExtensionReciprocalPolynomialAlgebra K (RatFunc K) + +local instance reciprocalRatFuncPolynomialSMul : SMul K[X] (RatFunc K) := + Algebra.toSMul + +local instance reciprocalRatFuncPolynomialModule : Module K[X] (RatFunc K) := + Algebra.toModule + +local instance reciprocalRatFuncPolynomialFaithful : + FaithfulSMul K[X] (RatFunc K) := by + rw [faithfulSMul_iff_algebraMap_injective] + intro p q hpq + apply reciprocalPolynomialRingHom_injective K + apply Subtype.ext + exact hpq + +private theorem reciprocalRatFunc_algebraMap_eq_eval (p : K[X]) : + algebraMap K[X] (RatFunc K) p = + Polynomial.eval₂ RatFunc.C (1 / RatFunc.X) p := by + change algebraMap (RatFuncInfinityIntegers K) (RatFunc K) + (reciprocalPolynomialRingHom K p) = _ + change (((reciprocalPolynomialRingHom K p : + RatFuncInfinityIntegers K) : RatFunc K)) = _ + rw [reciprocalPolynomialRingHom_coe] + +/-- The reciprocal polynomial embedding `K[X] → K(X)`, sending the +polynomial variable to `X⁻¹`, still has `K(X)` as its fraction field. -/ +theorem ratFunc_isFractionRing_reciprocalPolynomial : + IsFractionRing K[X] (RatFunc K) := by + apply IsFractionRing.of_field K[X] (RatFunc K) + intro z + obtain ⟨p, q, hq0, hz⟩ := canonicalRatFunc_div_surjective K z + let x := p.reverse * Polynomial.X ^ q.natDegree + let y := q.reverse * Polynomial.X ^ p.natDegree + refine ⟨x, y, ?_⟩ + rw [reciprocalRatFunc_algebraMap_eq_eval K x, + reciprocalRatFunc_algebraMap_eq_eval K y] + dsimp only [x, y] + simp only [Polynomial.eval₂_mul, Polynomial.eval₂_pow, + Polynomial.eval₂_X] + have hp := eval_reciprocal_reverse_mul_X_pow K p + have hq := eval_reciprocal_reverse_mul_X_pow K q + let can : K[X] →+* RatFunc K := + @algebraMap K[X] (RatFunc K) _ _ + (canonicalRatFuncPolynomialAlgebra K) + have hcanq : can q ≠ 0 := by + simpa [can] using + (canonicalRatFuncPolynomialAlgebraMap_injective K).ne hq0 + have hevalq : + Polynomial.eval₂ RatFunc.C (1 / RatFunc.X) q.reverse ≠ 0 := by + intro hzero + apply hcanq + rw [← hq, hzero, zero_mul] + calc + z = can p / can q := hz + _ = (Polynomial.eval₂ RatFunc.C (1 / RatFunc.X) p.reverse * + (1 / RatFunc.X) ^ q.natDegree) / + (Polynomial.eval₂ RatFunc.C (1 / RatFunc.X) q.reverse * + (1 / RatFunc.X) ^ p.natDegree) := by + rw [← hp, ← hq] + field_simp [RatFunc.X_ne_zero, hevalq] + simp [RatFunc.X_ne_zero] + +end ReciprocalFractionField + +section LocalizationHelpers + +/-- A ring equivalence transports the residue field of a height-one prime. -/ +noncomputable def heightOneResidueFieldRingEquiv + {A B : Type*} [CommRing A] [CommRing B] + (e : A ≃+* B) (q : HeightOneSpectrum A) : + q.asIdeal.ResidueField ≃+* + (HeightOneSpectrum.equivOfRingEquiv e q).asIdeal.ResidueField := + Ideal.residueFieldRingEquiv q.asIdeal + (HeightOneSpectrum.equivOfRingEquiv e q).asIdeal e + (by + change q.asIdeal = (q.asIdeal.comap e.symm).comap e + exact (Ideal.comap_of_equiv e).symm) + +/-- A prime is disjoint from the image of the complement of its contracted prime. -/ +theorem mappedPrimeCompl_disjoint_of_under_eq + (R A : Type*) [CommRing R] [CommRing A] [Algebra R A] + (p : Ideal R) [p.IsPrime] (q : Ideal A) + (hq : q.under R = p) : + Disjoint + ((Algebra.algebraMapSubmonoid A p.primeCompl : Submonoid A) : Set A) + (q : Set A) := by + rw [Set.disjoint_left] + intro x hxM hxq + obtain ⟨r, hr, rfl⟩ := hxM + exact hr (hq ▸ hxq) + +/-- Localizing a prime over the base prime gives a prime over the local maximal ideal. -/ +theorem localizationMap_liesOver_maximalIdeal + (R V A B : Type*) + [CommRing R] [CommRing V] [CommRing A] [CommRing B] + [Algebra R V] [Algebra R A] [Algebra R B] + [Algebra V B] [Algebra A B] + [IsScalarTower R V B] [IsScalarTower R A B] + (p : Ideal R) [p.IsPrime] + [IsLocalization p.primeCompl V] [IsLocalRing V] + (q : Ideal A) (hqPrime : q.IsPrime) (hqUnder : q.under R = p) + [IsLocalization (Algebra.algebraMapSubmonoid A p.primeCompl) B] : + (Ideal.map (algebraMap A B) q).LiesOver + (IsLocalRing.maximalIdeal V) := by + let M := Algebra.algebraMapSubmonoid A p.primeCompl + have hdisj : Disjoint (M : Set A) (q : Set A) := + mappedPrimeCompl_disjoint_of_under_eq R A p q hqUnder + let Q := Ideal.map (algebraMap A B) q + have hQA : Q.under A = q := + IsLocalization.under_map_of_isPrime_disjoint M B hqPrime hdisj + rw [Ideal.liesOver_iff] + apply (IsLocalization.orderEmbedding p.primeCompl V).injective + calc + (IsLocalRing.maximalIdeal V).under R = p := + IsLocalization.AtPrime.under_maximalIdeal V p + _ = q.under R := hqUnder.symm + _ = Q.under R := + (congrArg (Ideal.under R) hQA).symm.trans (Ideal.under_under Q) + _ = (Q.under V).under R := Ideal.under_under Q |>.symm + +/-- Localizing away from a prime preserves its residue field as an algebra over the base field. -/ +noncomputable def localizationResidueFieldAlgEquiv + (K A B : Type*) + [Field K] [CommRing A] [CommRing B] + [Algebra K A] [Algebra K B] [Algebra A B] + [IsScalarTower K A B] + (M : Submonoid A) [IsLocalization M B] + (q : Ideal A) [q.IsPrime] + (hdisj : Disjoint (M : Set A) (q : Set A)) : + let Q := Ideal.map (algebraMap A B) q + letI : Q.IsPrime := + IsLocalization.isPrime_of_isPrime_disjoint M B q inferInstance hdisj + q.ResidueField ≃ₐ[K] Q.ResidueField := by + let Q := Ideal.map (algebraMap A B) q + letI hQPrime : Q.IsPrime := + IsLocalization.isPrime_of_isPrime_disjoint M B q inferInstance hdisj + have hcomap : q = Q.under A := + (IsLocalization.under_map_of_isPrime_disjoint M B inferInstance hdisj).symm + let f : A →ₐ[K] B := IsScalarTower.toAlgHom K A B + let rf : q.ResidueField →ₐ[K] Q.ResidueField := + Ideal.ResidueField.mapₐ q Q f hcomap + apply AlgEquiv.ofBijective rf + exact (RingHom.surjectiveOnStalks_of_isLocalization M B) + |>.residueFieldMap_bijective q Q hcomap + +/-- Localizing away from a prime preserves its residue field as a ring. -/ +noncomputable def localizationResidueFieldRingEquiv + (A B : Type*) [CommRing A] [CommRing B] [Algebra A B] + (M : Submonoid A) [IsLocalization M B] + (q : Ideal A) [q.IsPrime] + (hdisj : Disjoint (M : Set A) (q : Set A)) : + let Q := Ideal.map (algebraMap A B) q + letI : Q.IsPrime := + IsLocalization.isPrime_of_isPrime_disjoint M B q inferInstance hdisj + q.ResidueField ≃+* Q.ResidueField := by + let Q := Ideal.map (algebraMap A B) q + letI hQPrime : Q.IsPrime := + IsLocalization.isPrime_of_isPrime_disjoint M B q inferInstance hdisj + have hcomap : q = Q.under A := + (IsLocalization.under_map_of_isPrime_disjoint M B inferInstance hdisj).symm + let f : q.ResidueField →+* Q.ResidueField := + Ideal.ResidueField.map q Q (algebraMap A B) hcomap + apply RingEquiv.ofBijective f + exact (RingHom.surjectiveOnStalks_of_isLocalization M B) + |>.residueFieldMap_bijective q Q hcomap + +private theorem finrank_eq_of_finite_ringEquiv + (K E F : Type*) [Field K] [Finite K] + [Field E] [Field F] [Algebra K E] [Algebra K F] + [Finite E] [Finite F] (e : E ≃+* F) : + Module.finrank K E = Module.finrank K F := by + let : Fintype K := Fintype.ofFinite K + let : Fintype E := Fintype.ofFinite E + let : Fintype F := Fintype.ofFinite F + have hcard : Fintype.card E = Fintype.card F := + Fintype.card_congr e.toEquiv + rw [Module.card_eq_pow_finrank (K := K) (V := E), + Module.card_eq_pow_finrank (K := K) (V := F)] at hcard + exact Nat.pow_right_injective + (show 2 ≤ Fintype.card K from Fintype.one_lt_card) hcard + +private theorem actualInfinityPlaceResidueField_finite + (K L : Type*) [Field K] [Field L] + [DecidableEq K] [DecidableEq (RatFunc K)] + [Finite K] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + (P : FiniteExtensionInfinityPlace K L) : + Finite P.1.ResidueField := by + let : Algebra K (RatFuncInfinityIntegers K) := + (ratFuncInfinityConstantRingHom K).toAlgebra + let : IsScalarTower K (RatFuncInfinityIntegers K) (RatFunc K) := + IsScalarTower.of_algebraMap_eq' rfl + let : Module.Finite (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.finite (RatFuncInfinityIntegers K) (RatFunc K) L + (RatFuncInfinityIntegralClosure K L) + let p := (ratFuncInfinityPlace K).asIdeal + let : Finite p.ResidueField := + Finite.of_injective (ratFuncInfinityPlaceResidueEquiv K) + (ratFuncInfinityPlaceResidueEquiv K).injective + let : P.1.LiesOver p := by + simpa [p] using Ideal.primesOver.liesOver + (ratFuncInfinityPlace K).asIdeal P + let := Localization.AtPrime.algebraOfLiesOver p P.1 + let _ : IsScalarTower (RatFuncInfinityIntegers K) (Localization.AtPrime p) + (Localization.AtPrime P.1) := inferInstance + let : Algebra.QuasiFiniteAt (RatFuncInfinityIntegers K) P.1 := + inferInstance + let : Module.Finite p.ResidueField P.1.ResidueField := inferInstance + exact Module.finite_of_finite p.ResidueField + +end LocalizationHelpers + +section TensorReciprocalNormalization + +/-- Extending polynomial coefficients carries the reciprocal origin back to +the reciprocal origin. -/ +theorem coefficientPolynomial_under_span_X + (C S : Type*) [Field C] [Field S] [Algebra C S] : + letI : Algebra C[X] S[X] := Polynomial.algebra C S + (Ideal.span ({Polynomial.X} : Set S[X])).under C[X] = + Ideal.span ({Polynomial.X} : Set C[X]) := by + let : Algebra C[X] S[X] := Polynomial.algebra C S + ext p + change algebraMap C[X] S[X] p ∈ + Ideal.span ({Polynomial.X} : Set S[X]) ↔ + p ∈ Ideal.span ({Polynomial.X} : Set C[X]) + rw [Ideal.mem_span_singleton, Ideal.mem_span_singleton] + rw [Polynomial.X_dvd_iff, Polynomial.X_dvd_iff] + simp + +/-- In the polynomial-cancellation model, coefficient extension of a +polynomial acts as the right pure tensor of its old action. -/ +theorem polynomialTensorCancel_algebraMap_coefficient + (C S A : Type*) [Field C] [Field S] [CommRing A] + [Algebra C S] [Algebra C[X] A] + [Algebra C A] [IsScalarTower C C[X] A] + (p : C[X]) : + letI : Algebra C[X] S[X] := Polynomial.algebra C S + letI : Algebra S[X] (S ⊗[C] A) := + polynomialTensorCancelTargetPolynomialExtensionAlgebra C S A + algebraMap S[X] (S ⊗[C] A) (algebraMap C[X] S[X] p) = + (1 : S) ⊗ₜ[C] algebraMap C[X] A p := by + let : Algebra C[X] S[X] := Polynomial.algebra C S + let : Algebra S[X] (S ⊗[C] A) := + polynomialTensorCancelTargetPolynomialExtensionAlgebra C S A + let e := polynomialTensorCancelOverCoefficientPolynomial C S A + have hsource : + (algebraMap C[X] S[X] p) ⊗ₜ[C[X]] (1 : A) = + (1 : S[X]) ⊗ₜ[C[X]] (algebraMap C[X] A p) := + Algebra.TensorProduct.tmul_one_eq_one_tmul p + calc + algebraMap S[X] (S ⊗[C] A) (algebraMap C[X] S[X] p) = + e ((algebraMap C[X] S[X] p) ⊗ₜ[C[X]] (1 : A)) := + (e.commutes (algebraMap C[X] S[X] p)).symm + _ = e ((1 : S[X]) ⊗ₜ[C[X]] (algebraMap C[X] A p)) := + congrArg e hsource + _ = (1 : S) ⊗ₜ[C] algebraMap C[X] A p := by + rw [polynomialTensorCancelOverCoefficientPolynomial_apply, + polynomialTensorCancel_tmul] + simp + +variable (C S N : Type*) [Field C] [Field S] [Field N] + [Fintype C] [Finite S] + [Algebra (RatFunc C) N] [FiniteDimensional (RatFunc C) N] + [Algebra.IsSeparable (RatFunc C) N] + [Algebra C S] [FiniteDimensional C S] [IsGalois C S] + +local instance infinityBridgeDecidableEqBase : DecidableEq C := Classical.decEq C +local instance infinityBridgeDecidableEqConstants : DecidableEq S := Classical.decEq S +local instance infinityBridgeDecidableEqRatFuncBase : DecidableEq (RatFunc C) := + Classical.decEq (RatFunc C) +local instance infinityBridgeDecidableEqRatFuncConstants : DecidableEq (RatFunc S) := + Classical.decEq (RatFunc S) + +local instance infinityBridgeBaseConstantAlgebra : Algebra C N := + RingHom.toAlgebra ((algebraMap (RatFunc C) N).comp + (algebraMap C (RatFunc C))) + +local instance infinityBridgeBaseReciprocalPolynomialAlgebra : Algebra C[X] N := + ratFuncExtensionReciprocalPolynomialAlgebra C N + +local instance infinityBridgeBaseConstantPolynomialTower : + IsScalarTower C C[X] N := by + exact IsScalarTower.of_algebraMap_eq' (by + ext c + change algebraMap (RatFunc C) N (algebraMap C (RatFunc C) c) = + algebraMap (RatFunc C) N + (((reciprocalPolynomialRingHom C (Polynomial.C c) : + RatFuncInfinityIntegers C) : RatFunc C)) + rw [reciprocalPolynomialRingHom_coe] + simp) + +local instance infinityBridgeOldNormalizationConstantAlgebra : + Algebra C (integralClosure C[X] N) := + RingHom.toAlgebra + ((algebraMap C[X] (integralClosure C[X] N)).comp + (algebraMap C C[X])) + +local instance infinityBridgeOldNormalizationConstantPolynomialTower : + IsScalarTower C C[X] (integralClosure C[X] N) := + IsScalarTower.of_algebraMap_eq' rfl + +local instance infinityBridgeTensorPolynomialAlgebra : + Algebra S[X] (S ⊗[C] integralClosure C[X] N) := + polynomialTensorCancelTargetPolynomialExtensionAlgebra C S + (integralClosure C[X] N) + +local instance infinityBridgeTensorConstantAlgebra : + Algebra S (S ⊗[C] integralClosure C[X] N) := + Algebra.TensorProduct.leftAlgebra + +local instance infinityBridgeTensorOldNormalizationAlgebra : + Algebra (integralClosure C[X] N) + (S ⊗[C] integralClosure C[X] N) := + Algebra.TensorProduct.rightAlgebra + +/-- Contract a reciprocal tensor-normalization prime to the old reciprocal +normalization. -/ +def exactConstantExtensionInfinityDownstairsIdeal + (q : HeightOneSpectrum (S ⊗[C] integralClosure C[X] N)) : + Ideal (integralClosure C[X] N) := + q.asIdeal.comap + (Algebra.TensorProduct.includeRight + (R := C) (A := S) (B := integralClosure C[X] N)).toRingHom + +omit [Fintype C] [Finite S] + [FiniteDimensional (RatFunc C) N] [Algebra.IsSeparable (RatFunc C) N] + [FiniteDimensional C S] [IsGalois C S] in +@[simp] +theorem exactConstantExtensionInfinityDownstairsIdeal_eq + (q : HeightOneSpectrum (S ⊗[C] integralClosure C[X] N)) : + exactConstantExtensionInfinityDownstairsIdeal C S N q = + q.asIdeal.comap + (Algebra.TensorProduct.includeRight + (R := C) (A := S) (B := integralClosure C[X] N)).toRingHom := + rfl + +omit [Fintype C] [Finite S] + [FiniteDimensional (RatFunc C) N] [Algebra.IsSeparable (RatFunc C) N] + [FiniteDimensional C S] [IsGalois C S] in +/-- A tensor-normalization prime above the reciprocal origin contracts to a +prime above the reciprocal origin in the old normalization. -/ +theorem exactConstantExtensionInfinityDownstairsIdeal_under + (q : HeightOneSpectrum (S ⊗[C] integralClosure C[X] N)) + (hqOrigin : q.asIdeal.under S[X] = + Ideal.span ({Polynomial.X} : Set S[X])) : + (exactConstantExtensionInfinityDownstairsIdeal C S N q).under C[X] = + Ideal.span ({Polynomial.X} : Set C[X]) := by + let p := exactConstantExtensionInfinityDownstairsIdeal C S N q + let oS := Ideal.span ({Polynomial.X} : Set S[X]) + let oC := Ideal.span ({Polynomial.X} : Set C[X]) + let : Algebra C[X] S[X] := Polynomial.algebra C S + ext r + change + (1 : S) ⊗ₜ[C] + algebraMap C[X] (integralClosure C[X] N) r ∈ q.asIdeal ↔ + r ∈ oC + rw [← polynomialTensorCancel_algebraMap_coefficient C S + (integralClosure C[X] N) r] + change algebraMap C[X] S[X] r ∈ q.asIdeal.under S[X] ↔ r ∈ oC + rw [hqOrigin] + exact SetLike.ext_iff.mp (coefficientPolynomial_under_span_X C S) r + +local instance infinityBridgeBaseInfinityPolynomialAlgebra : + Algebra C[X] (RatFuncInfinityIntegers C) := + ratFuncInfinityReciprocalPolynomialAlgebra C + +local instance infinityBridgeBaseInfinityConstantAlgebra : + Algebra C (RatFuncInfinityIntegers C) := + (ratFuncInfinityConstantRingHom C).toAlgebra + +local instance infinityBridgeBaseOriginPrime : + (Ideal.span ({Polynomial.X} : Set C[X])).IsPrime := + (Ideal.span_singleton_prime Polynomial.X_ne_zero).mpr Polynomial.prime_X + +local instance infinityBridgeBaseInfinityLocalization : + IsLocalization + (Ideal.span ({Polynomial.X} : Set C[X])).primeCompl + (RatFuncInfinityIntegers C) := + ratFuncInfinityIntegers_isLocalization_reciprocal C + +local instance infinityBridgeOldNormalizationInfinityAlgebra : + Algebra (integralClosure C[X] N) (RatFuncInfinityIntegralClosure C N) := + ratFuncInfinityReciprocalIntegralClosureAlgebra C N + +local instance infinityBridgeOldNormalizationInfinitySMul : + SMul (integralClosure C[X] N) (RatFuncInfinityIntegralClosure C N) := + Algebra.toSMul + +local instance infinityBridgeOldNormalizationInfinityLocalization : + IsLocalization + (Algebra.algebraMapSubmonoid (integralClosure C[X] N) + (Ideal.span ({Polynomial.X} : Set C[X])).primeCompl) + (RatFuncInfinityIntegralClosure C N) := + ratFuncInfinityIntegralClosure_isLocalization_reciprocal C N + +local instance infinityBridgeBasePolynomialInfinityAlgebra : + Algebra C[X] (RatFuncInfinityIntegralClosure C N) := + RingHom.toAlgebra + ((algebraMap (RatFuncInfinityIntegers C) + (RatFuncInfinityIntegralClosure C N)).comp + (algebraMap C[X] (RatFuncInfinityIntegers C))) + +local instance infinityBridgeInfinityConstantAlgebra : + Algebra C (RatFuncInfinityIntegralClosure C N) := + RingHom.toAlgebra + ((algebraMap (RatFuncInfinityIntegers C) + (RatFuncInfinityIntegralClosure C N)).comp + (algebraMap C (RatFuncInfinityIntegers C))) + +local instance infinityBridgeOldNormalizationInfinityConstantTower : + IsScalarTower C (integralClosure C[X] N) + (RatFuncInfinityIntegralClosure C N) := + IsScalarTower.of_algebraMap_eq fun c => by + apply Subtype.ext + change algebraMap (RatFunc C) N (algebraMap C (RatFunc C) c) = + algebraMap (RatFunc C) N + (((reciprocalPolynomialRingHom C (Polynomial.C c) : + RatFuncInfinityIntegers C) : RatFunc C)) + rw [reciprocalPolynomialRingHom_coe] + simp + +local instance infinityBridgeBasePolynomialInfinityTower : + IsScalarTower C[X] (RatFuncInfinityIntegers C) + (RatFuncInfinityIntegralClosure C N) := + IsScalarTower.of_algebraMap_eq' rfl + +local instance infinityBridgeOldNormalizationInfinityTower : + IsScalarTower C[X] (integralClosure C[X] N) + (RatFuncInfinityIntegralClosure C N) := + IsScalarTower.of_algebraMap_eq fun p => by + apply Subtype.ext + rfl + +/-- The contraction of a reciprocal tensor prime, localized at the old +reciprocal origin, is an actual place of `N` above infinity. -/ +noncomputable def exactConstantExtensionDownstairsInfinityPlace + (q : HeightOneSpectrum (S ⊗[C] integralClosure C[X] N)) + (hqOrigin : q.asIdeal.under S[X] = + Ideal.span ({Polynomial.X} : Set S[X])) : + FiniteExtensionInfinityPlace C N := by + let A := integralClosure C[X] N + let B := RatFuncInfinityIntegralClosure C N + let o := Ideal.span ({Polynomial.X} : Set C[X]) + let p := exactConstantExtensionInfinityDownstairsIdeal C S N q + let M := Algebra.algebraMapSubmonoid A o.primeCompl + have hpPrime : p.IsPrime := by + exact Ideal.comap_isPrime + (f := (Algebra.TensorProduct.includeRight + (R := C) (A := S) (B := integralClosure C[X] N)).toRingHom) + (K := q.asIdeal) + have hpUnder : p.under C[X] = o := + exactConstantExtensionInfinityDownstairsIdeal_under C S N q hqOrigin + have hdisj : Disjoint (M : Set A) (p : Set A) := by + let : o.IsPrime := infinityBridgeBaseOriginPrime C + exact mappedPrimeCompl_disjoint_of_under_eq C[X] A o p hpUnder + let P := Ideal.map (algebraMap A B) p + letI : p.IsPrime := hpPrime + letI : P.IsPrime := + IsLocalization.isPrime_of_isPrime_disjoint M B p hpPrime hdisj + have hOver : P.LiesOver (ratFuncInfinityPlace C).asIdeal := by + exact localizationMap_liesOver_maximalIdeal C[X] + (RatFuncInfinityIntegers C) A B o p hpPrime hpUnder + exact ⟨P, inferInstance, hOver⟩ + +omit [Fintype C] [Finite S] + [FiniteDimensional (RatFunc C) N] [Algebra.IsSeparable (RatFunc C) N] + [FiniteDimensional C S] [IsGalois C S] in +@[simp] +theorem exactConstantExtensionDownstairsInfinityPlace_asIdeal + (q : HeightOneSpectrum (S ⊗[C] integralClosure C[X] N)) + (hqOrigin : q.asIdeal.under S[X] = + Ideal.span ({Polynomial.X} : Set S[X])) : + (exactConstantExtensionDownstairsInfinityPlace + C S N q hqOrigin).1 = + Ideal.map + (algebraMap (integralClosure C[X] N) + (RatFuncInfinityIntegralClosure C N)) + (exactConstantExtensionInfinityDownstairsIdeal C S N q) := + rfl + +/-- Localization at the reciprocal origin does not change the residue field +of the contracted downstairs prime. -/ +noncomputable def exactConstantExtensionDownstairsResidueFieldAlgEquiv + (q : HeightOneSpectrum (S ⊗[C] integralClosure C[X] N)) + (hqOrigin : q.asIdeal.under S[X] = + Ideal.span ({Polynomial.X} : Set S[X])) : + let i := (Algebra.TensorProduct.includeRight + (R := C) (A := S) (B := integralClosure C[X] N)).toRingHom + let p := exactConstantExtensionInfinityDownstairsIdeal C S N q + letI : p.IsPrime := Ideal.comap_isPrime (f := i) (K := q.asIdeal) + p.ResidueField ≃ₐ[C] + (exactConstantExtensionDownstairsInfinityPlace + C S N q hqOrigin).1.ResidueField := by + let A := integralClosure C[X] N + let B := RatFuncInfinityIntegralClosure C N + let o := Ideal.span ({Polynomial.X} : Set C[X]) + let p := exactConstantExtensionInfinityDownstairsIdeal C S N q + let M := Algebra.algebraMapSubmonoid A o.primeCompl + have hpPrime : p.IsPrime := by + exact Ideal.comap_isPrime + (f := (Algebra.TensorProduct.includeRight + (R := C) (A := S) (B := integralClosure C[X] N)).toRingHom) + (K := q.asIdeal) + letI : p.IsPrime := hpPrime + have hpUnder : p.under C[X] = o := + exactConstantExtensionInfinityDownstairsIdeal_under C S N q hqOrigin + have hdisj : Disjoint (M : Set A) (p : Set A) := + mappedPrimeCompl_disjoint_of_under_eq C[X] A o p hpUnder + let P := Ideal.map (algebraMap A B) p + letI : P.IsPrime := + IsLocalization.isPrime_of_isPrime_disjoint M B p hpPrime hdisj + change p.ResidueField ≃ₐ[C] + P.ResidueField + exact localizationResidueFieldAlgEquiv C A B M p hdisj + +variable (hExact : algebraicClosure C N = + (⊥ : IntermediateField C N)) + +/-- Localizing the corresponding prime in the reciprocal affine +normalization of the exact constant extension produces an actual upstairs +place above infinity. -/ +noncomputable def exactConstantExtensionUpstairsInfinityPlace + (q : HeightOneSpectrum (S ⊗[C] integralClosure C[X] N)) + (hqOrigin : q.asIdeal.under S[X] = + Ideal.span ({Polynomial.X} : Set S[X])) : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc S) (ExactConstantExtension C N S) := + ratFuncExactConstantExtensionAlgebra C S N hExact + FiniteExtensionInfinityPlace S (ExactConstantExtension C N S) := by + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc S) (ExactConstantExtension C N S) := + ratFuncExactConstantExtensionAlgebra C S N hExact + letI : Algebra S[X] (ExactConstantExtension C N S) := + ratFuncExtensionReciprocalPolynomialAlgebra S + (ExactConstantExtension C N S) + let R := S ⊗[C] integralClosure C[X] N + let A := integralClosure S[X] (ExactConstantExtension C N S) + let V := RatFuncInfinityIntegers S + let B := RatFuncInfinityIntegralClosure S (ExactConstantExtension C N S) + let o := Ideal.span ({Polynomial.X} : Set S[X]) + let e := exactConstantExtensionInfinityAffineNormalizationAlgEquiv + C S N hExact + let qA : HeightOneSpectrum A := heightOneSpectrumEquivOfAlgEquiv e q + have hqAOrigin : qA.asIdeal.under S[X] = o := by + calc + qA.asIdeal.under S[X] = q.asIdeal.under S[X] := by + ext p + change e.symm (algebraMap S[X] A p) ∈ q.asIdeal ↔ + algebraMap S[X] R p ∈ q.asIdeal + rw [e.symm.commutes] + _ = o := hqOrigin + letI : Algebra S[X] V := ratFuncInfinityReciprocalPolynomialAlgebra S + letI : o.IsPrime := + (Ideal.span_singleton_prime Polynomial.X_ne_zero).mpr Polynomial.prime_X + letI : IsLocalization o.primeCompl V := + ratFuncInfinityIntegers_isLocalization_reciprocal S + letI : Algebra A B := + ratFuncInfinityReciprocalIntegralClosureAlgebra S + (ExactConstantExtension C N S) + letI : SMul A B := Algebra.toSMul + letI : IsLocalization (Algebra.algebraMapSubmonoid A o.primeCompl) B := + ratFuncInfinityIntegralClosure_isLocalization_reciprocal S + (ExactConstantExtension C N S) + letI : Algebra S[X] B := + RingHom.toAlgebra + ((algebraMap V B).comp (algebraMap S[X] V)) + letI : IsScalarTower S[X] V B := + IsScalarTower.of_algebraMap_eq' rfl + letI : IsScalarTower S[X] A B := + IsScalarTower.of_algebraMap_eq fun p => by + apply Subtype.ext + rfl + let M := Algebra.algebraMapSubmonoid A o.primeCompl + have hdisj : Disjoint (M : Set A) (qA.asIdeal : Set A) := + mappedPrimeCompl_disjoint_of_under_eq S[X] A o qA.asIdeal hqAOrigin + let Q := Ideal.map (algebraMap A B) qA.asIdeal + letI : Q.IsPrime := + IsLocalization.isPrime_of_isPrime_disjoint M B qA.asIdeal qA.isPrime hdisj + have hOver : Q.LiesOver (ratFuncInfinityPlace S).asIdeal := by + exact localizationMap_liesOver_maximalIdeal S[X] V A B o + qA.asIdeal qA.isPrime hqAOrigin + exact ⟨Q, inferInstance, hOver⟩ + +/-- The reciprocal affine prime and the corresponding actual upstairs +infinity place have canonically ring-equivalent residue fields. -/ +noncomputable def exactConstantExtensionUpstairsResidueFieldRingEquiv + (q : HeightOneSpectrum (S ⊗[C] integralClosure C[X] N)) + (hqOrigin : q.asIdeal.under S[X] = + Ideal.span ({Polynomial.X} : Set S[X])) : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc S) (ExactConstantExtension C N S) := + ratFuncExactConstantExtensionAlgebra C S N hExact + q.asIdeal.ResidueField ≃+* + (exactConstantExtensionUpstairsInfinityPlace + C S N hExact q hqOrigin).1.ResidueField := by + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc S) (ExactConstantExtension C N S) := + ratFuncExactConstantExtensionAlgebra C S N hExact + letI : Algebra S[X] (ExactConstantExtension C N S) := + ratFuncExtensionReciprocalPolynomialAlgebra S + (ExactConstantExtension C N S) + let R := S ⊗[C] integralClosure C[X] N + let A := integralClosure S[X] (ExactConstantExtension C N S) + let V := RatFuncInfinityIntegers S + let B := RatFuncInfinityIntegralClosure S (ExactConstantExtension C N S) + let o := Ideal.span ({Polynomial.X} : Set S[X]) + let e := exactConstantExtensionInfinityAffineNormalizationAlgEquiv + C S N hExact + let qA : HeightOneSpectrum A := heightOneSpectrumEquivOfAlgEquiv e q + have hqAOrigin : qA.asIdeal.under S[X] = o := by + calc + qA.asIdeal.under S[X] = q.asIdeal.under S[X] := by + ext p + change e.symm (algebraMap S[X] A p) ∈ q.asIdeal ↔ + algebraMap S[X] R p ∈ q.asIdeal + rw [e.symm.commutes] + _ = o := hqOrigin + let affineResidue : q.asIdeal.ResidueField ≃+* + qA.asIdeal.ResidueField := + heightOneResidueFieldRingEquiv e.toRingEquiv q + letI : Algebra S[X] V := ratFuncInfinityReciprocalPolynomialAlgebra S + letI : o.IsPrime := + (Ideal.span_singleton_prime Polynomial.X_ne_zero).mpr Polynomial.prime_X + letI : IsLocalization o.primeCompl V := + ratFuncInfinityIntegers_isLocalization_reciprocal S + letI : Algebra A B := + ratFuncInfinityReciprocalIntegralClosureAlgebra S + (ExactConstantExtension C N S) + letI : SMul A B := Algebra.toSMul + letI : IsLocalization (Algebra.algebraMapSubmonoid A o.primeCompl) B := + ratFuncInfinityIntegralClosure_isLocalization_reciprocal S + (ExactConstantExtension C N S) + letI : Algebra S[X] B := + RingHom.toAlgebra ((algebraMap V B).comp (algebraMap S[X] V)) + letI : IsScalarTower S[X] V B := + IsScalarTower.of_algebraMap_eq' rfl + letI : IsScalarTower S[X] A B := + IsScalarTower.of_algebraMap_eq fun p => by + apply Subtype.ext + rfl + let M := Algebra.algebraMapSubmonoid A o.primeCompl + have hdisj : Disjoint (M : Set A) (qA.asIdeal : Set A) := + mappedPrimeCompl_disjoint_of_under_eq S[X] A o qA.asIdeal hqAOrigin + let Q := Ideal.map (algebraMap A B) qA.asIdeal + letI : Q.IsPrime := + IsLocalization.isPrime_of_isPrime_disjoint M B qA.asIdeal qA.isPrime hdisj + let localResidue : qA.asIdeal.ResidueField ≃+* Q.ResidueField := + localizationResidueFieldRingEquiv A B M qA.asIdeal hdisj + change q.asIdeal.ResidueField ≃+* Q.ResidueField + exact affineResidue.trans localResidue + +/-- The residue field of the actual upstairs infinity place is finite. -/ +theorem exactConstantExtensionUpstairsInfinityResidueField_finite + (q : HeightOneSpectrum (S ⊗[C] integralClosure C[X] N)) + (hqOrigin : q.asIdeal.under S[X] = + Ideal.span ({Polynomial.X} : Set S[X])) : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc S) (ExactConstantExtension C N S) := + ratFuncExactConstantExtensionAlgebra C S N hExact + Finite (exactConstantExtensionUpstairsInfinityPlace + C S N hExact q hqOrigin).1.ResidueField := by + let : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + let : Algebra (RatFunc S) (ExactConstantExtension C N S) := + ratFuncExactConstantExtensionAlgebra C S N hExact + let : SMul (RatFunc S) (ExactConstantExtension C N S) := + Algebra.toSMul + let : Module (RatFunc S) (ExactConstantExtension C N S) := + Algebra.toModule + let : FiniteDimensional (RatFunc S) (ExactConstantExtension C N S) := + finiteDimensional_over_extendedRatFunc C S N hExact + let : Algebra.IsSeparable (RatFunc S) (ExactConstantExtension C N S) := + isSeparable_over_extendedRatFunc C S N hExact + let : Fintype S := Fintype.ofFinite S + exact actualInfinityPlaceResidueField_finite S + (ExactConstantExtension C N S) + (exactConstantExtensionUpstairsInfinityPlace + C S N hExact q hqOrigin) + +include hExact + +omit [Fintype C] in +/-- The residue field of the reciprocal tensor-normalization prime is finite. -/ +theorem exactConstantExtensionInfinityTensorResidueField_finite [Finite C] + (q : HeightOneSpectrum (S ⊗[C] integralClosure C[X] N)) + (hqOrigin : q.asIdeal.under S[X] = + Ideal.span ({Polynomial.X} : Set S[X])) : + Finite q.asIdeal.ResidueField := by + let : Fintype C := Fintype.ofFinite C + let : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + let : Algebra (RatFunc S) (ExactConstantExtension C N S) := + ratFuncExactConstantExtensionAlgebra C S N hExact + let : Finite + (exactConstantExtensionUpstairsInfinityPlace + C S N hExact q hqOrigin).1.ResidueField := + exactConstantExtensionUpstairsInfinityResidueField_finite + C S N hExact q hqOrigin + let e := exactConstantExtensionUpstairsResidueFieldRingEquiv + C S N hExact q hqOrigin + exact Finite.of_injective e e.injective + +omit [Fintype C] in +/-- A reciprocal tensor-normalization height-one prime above the origin is +maximal; no maximality hypothesis is left to the residue calculation. -/ +theorem exactConstantExtensionInfinityTensorIdeal_isMaximal [Finite C] + (q : HeightOneSpectrum (S ⊗[C] integralClosure C[X] N)) + (hqOrigin : q.asIdeal.under S[X] = + Ideal.span ({Polynomial.X} : Set S[X])) : + q.asIdeal.IsMaximal := by + let : Fintype C := Fintype.ofFinite C + let : Finite q.asIdeal.ResidueField := + exactConstantExtensionInfinityTensorResidueField_finite + C S N hExact q hqOrigin + let : Finite + (HasQuotient.Quotient + (S ⊗[C] integralClosure C[X] N) q.asIdeal) := + Finite.of_injective + (algebraMap + (HasQuotient.Quotient + (S ⊗[C] integralClosure C[X] N) q.asIdeal) + q.asIdeal.ResidueField) + q.asIdeal.injective_algebraMap_quotient_residueField + exact (Ideal.Quotient.maximal_ideal_iff_isField_quotient q.asIdeal).mpr + (Finite.isField_of_domain + (HasQuotient.Quotient + (S ⊗[C] integralClosure C[X] N) q.asIdeal)) + +omit [Finite S] [FiniteDimensional C S] [IsGalois C S] hExact in +/-- The residue field of the contracted downstairs reciprocal prime is finite. -/ +theorem exactConstantExtensionInfinityDownstairsResidueField_finite + (q : HeightOneSpectrum (S ⊗[C] integralClosure C[X] N)) + (hqOrigin : q.asIdeal.under S[X] = + Ideal.span ({Polynomial.X} : Set S[X])) : + let p := exactConstantExtensionInfinityDownstairsIdeal C S N q + let i := (Algebra.TensorProduct.includeRight + (R := C) (A := S) (B := integralClosure C[X] N)).toRingHom + letI : p.IsPrime := Ideal.comap_isPrime (f := i) (K := q.asIdeal) + Finite p.ResidueField := by + let p := exactConstantExtensionInfinityDownstairsIdeal C S N q + let i := (Algebra.TensorProduct.includeRight + (R := C) (A := S) (B := integralClosure C[X] N)).toRingHom + let : p.IsPrime := Ideal.comap_isPrime (f := i) (K := q.asIdeal) + let P := exactConstantExtensionDownstairsInfinityPlace C S N q hqOrigin + let : Finite P.1.ResidueField := + actualInfinityPlaceResidueField_finite C N P + let e := exactConstantExtensionDownstairsResidueFieldAlgEquiv + C S N q hqOrigin + exact Finite.of_injective e e.injective + +omit [Field C] [Field N] [Fintype C] + [Algebra (RatFunc C) N] [FiniteDimensional (RatFunc C) N] + [Algebra.IsSeparable (RatFunc C) N] hExact in +private theorem constantTensorResidue_finrank_over_constants_eq_div_gcd + (C R S : Type*) + [Field C] [CommRing R] [Field S] + [Algebra C R] [Algebra C S] + [Finite C] [Finite S] + (q : Ideal (S ⊗[C] R)) [q.IsMaximal] + [Finite ((q.comap (Algebra.TensorProduct.includeRight + (R := C) (A := S) (B := R)).toRingHom).ResidueField)] + [Finite q.ResidueField] : + let p := q.comap (Algebra.TensorProduct.includeRight + (R := C) (A := S) (B := R)).toRingHom + Module.finrank S q.ResidueField = + Module.finrank C p.ResidueField / + Nat.gcd (Module.finrank C S) + (Module.finrank C p.ResidueField) := by + let p := q.comap (Algebra.TensorProduct.includeRight + (R := C) (A := S) (B := R)).toRingHom + let m := Module.finrank C S + let n := Module.finrank C p.ResidueField + let d := Nat.gcd m n + let l := Nat.lcm m n + let r := Module.finrank S q.ResidueField + have htotal : Module.finrank C q.ResidueField = l := + constantTensorResidue_finrank_eq_lcm C R S q + have hmr : m * r = l := by + exact (Module.finrank_mul_finrank C S q.ResidueField).trans htotal + have hdr : d * r = n := by + apply Nat.mul_left_cancel + (Module.finrank_pos (R := C) (M := S)) + calc + m * (d * r) = d * (m * r) := by ac_rfl + _ = d * l := by rw [hmr] + _ = m * n := Nat.gcd_mul_lcm m n + have hdpos : 0 < d := Nat.gcd_pos_of_pos_left n + (Module.finrank_pos (R := C) (M := S)) + change r = n / d + symm + apply Nat.div_eq_of_eq_mul_left hdpos + simpa [mul_comm] using hdr.symm + +/-- Exact extension of constants changes the degree of an actual infinity +place by the standard division-by-gcd formula. -/ +theorem exactConstantExtensionInfinityPlace_degree_eq_div_gcd + (q : HeightOneSpectrum (S ⊗[C] integralClosure C[X] N)) + (hqOrigin : q.asIdeal.under S[X] = + Ideal.span ({Polynomial.X} : Set S[X])) : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc S) (ExactConstantExtension C N S) := + ratFuncExactConstantExtensionAlgebra C S N hExact + finiteExtensionPlaceDegree S (ExactConstantExtension C N S) + (.inr (exactConstantExtensionUpstairsInfinityPlace + C S N hExact q hqOrigin)) = + finiteExtensionPlaceDegree C N + (.inr (exactConstantExtensionDownstairsInfinityPlace + C S N q hqOrigin)) / + Nat.gcd (Module.finrank C S) + (finiteExtensionPlaceDegree C N + (.inr (exactConstantExtensionDownstairsInfinityPlace + C S N q hqOrigin))) := by + let : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + let : Algebra (RatFunc S) (ExactConstantExtension C N S) := + ratFuncExactConstantExtensionAlgebra C S N hExact + let : SMul (RatFunc S) (ExactConstantExtension C N S) := + Algebra.toSMul + let : Module (RatFunc S) (ExactConstantExtension C N S) := + Algebra.toModule + let : FiniteDimensional (RatFunc S) (ExactConstantExtension C N S) := + finiteDimensional_over_extendedRatFunc C S N hExact + let : Algebra.IsSeparable (RatFunc S) (ExactConstantExtension C N S) := + isSeparable_over_extendedRatFunc C S N hExact + let : Fintype S := Fintype.ofFinite S + let p := exactConstantExtensionInfinityDownstairsIdeal C S N q + let i := (Algebra.TensorProduct.includeRight + (R := C) (A := S) (B := integralClosure C[X] N)).toRingHom + let : p.IsPrime := Ideal.comap_isPrime (f := i) (K := q.asIdeal) + let : Finite p.ResidueField := + exactConstantExtensionInfinityDownstairsResidueField_finite + C S N q hqOrigin + let : Finite + (q.asIdeal.comap (Algebra.TensorProduct.includeRight + (R := C) (A := S) (B := integralClosure C[X] N)).toRingHom).ResidueField := by + change Finite p.ResidueField + infer_instance + let : Finite q.asIdeal.ResidueField := + exactConstantExtensionInfinityTensorResidueField_finite + C S N hExact q hqOrigin + let : q.asIdeal.IsMaximal := + exactConstantExtensionInfinityTensorIdeal_isMaximal + C S N hExact q hqOrigin + let Q := exactConstantExtensionUpstairsInfinityPlace + C S N hExact q hqOrigin + let P := exactConstantExtensionDownstairsInfinityPlace + C S N q hqOrigin + let : Finite Q.1.ResidueField := + exactConstantExtensionUpstairsInfinityResidueField_finite + C S N hExact q hqOrigin + let : Finite P.1.ResidueField := + actualInfinityPlaceResidueField_finite C N P + have hUp : Module.finrank S q.asIdeal.ResidueField = + Module.finrank S Q.1.ResidueField := + finrank_eq_of_finite_ringEquiv S q.asIdeal.ResidueField + Q.1.ResidueField + (exactConstantExtensionUpstairsResidueFieldRingEquiv + C S N hExact q hqOrigin) + have hDown : Module.finrank C p.ResidueField = + Module.finrank C P.1.ResidueField := + (exactConstantExtensionDownstairsResidueFieldAlgEquiv + C S N q hqOrigin).toLinearEquiv.finrank_eq + rw [finiteExtensionInfinityPlace_degree_eq_finrank_residueField S + (ExactConstantExtension C N S) Q, + finiteExtensionInfinityPlace_degree_eq_finrank_residueField C N P] + calc + Module.finrank S Q.1.ResidueField = + Module.finrank S q.asIdeal.ResidueField := hUp.symm + _ = Module.finrank C p.ResidueField / + Nat.gcd (Module.finrank C S) + (Module.finrank C p.ResidueField) := + constantTensorResidue_finrank_over_constants_eq_div_gcd + C (integralClosure C[X] N) S q.asIdeal + _ = Module.finrank C P.1.ResidueField / + Nat.gcd (Module.finrank C S) + (Module.finrank C P.1.ResidueField) := by rw [hDown] + +/-- If the downstairs infinity-place degree divides the extension degree of +the constants, the corresponding upstairs infinity place has degree one. -/ +theorem exactConstantExtensionInfinityPlace_degree_eq_one_of_dvd + (q : HeightOneSpectrum (S ⊗[C] integralClosure C[X] N)) + (hqOrigin : q.asIdeal.under S[X] = + Ideal.span ({Polynomial.X} : Set S[X])) + (hdiv : finiteExtensionPlaceDegree C N + (.inr (exactConstantExtensionDownstairsInfinityPlace + C S N q hqOrigin)) ∣ Module.finrank C S) : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc S) (ExactConstantExtension C N S) := + ratFuncExactConstantExtensionAlgebra C S N hExact + finiteExtensionPlaceDegree S (ExactConstantExtension C N S) + (.inr (exactConstantExtensionUpstairsInfinityPlace + C S N hExact q hqOrigin)) = 1 := by + let : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + let : Algebra (RatFunc S) (ExactConstantExtension C N S) := + ratFuncExactConstantExtensionAlgebra C S N hExact + rw [exactConstantExtensionInfinityPlace_degree_eq_div_gcd + C S N hExact q hqOrigin] + rw [Nat.gcd_eq_right_iff_dvd.mpr hdiv] + let P := exactConstantExtensionDownstairsInfinityPlace + C S N q hqOrigin + let : Finite P.1.ResidueField := + actualInfinityPlaceResidueField_finite C N P + let _ : DistribMulAction (RatFuncInfinityIntegralClosure C N) + (RatFuncInfinityIntegralClosure C N) := + (Algebra.toModule : Module (RatFuncInfinityIntegralClosure C N) + (RatFuncInfinityIntegralClosure C N)).toDistribMulAction + apply Nat.div_self + rw [finiteExtensionInfinityPlace_degree_eq_finrank_residueField C N P] + exact Module.finrank_pos + +end TensorReciprocalNormalization + +end + + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/ConstantExtensionInfinityPlaceDegreeTower.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/ConstantExtensionInfinityPlaceDegreeTower.lean new file mode 100644 index 0000000000..dce1182ec6 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/ConstantExtensionInfinityPlaceDegreeTower.lean @@ -0,0 +1,592 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.ConstantExtensionInfinityPlaceSplittingMultiplicity + +/-! +# Absolute degrees of constant-extension places at infinity + +This file compares the degree of an infinity place in the original constant +field presentation with its degree after extending the constants. Both +degrees are computed from the same reciprocal-normalization residue field, so +the comparison is just the residue-field dimension tower. +-/ + +@[expose] public section + +open scoped Polynomial TensorProduct nonZeroDivisors + +namespace BGS.HasseWeil + +noncomputable section + +open BGS.CorvajaZannier IsDedekindDomain + + +/-- A ring equivalence between finite field extensions of a finite field +preserves their dimensions, even when it is not presented as an algebra +equivalence. -/ +private theorem finrank_eq_of_finite_ringEquiv + (K E F : Type*) [Field K] [Finite K] + [Field E] [Field F] [Algebra K E] [Algebra K F] + [Finite E] [Finite F] (e : E ≃+* F) : + Module.finrank K E = Module.finrank K F := by + let : Fintype K := Fintype.ofFinite K + let : Fintype E := Fintype.ofFinite E + let : Fintype F := Fintype.ofFinite F + have hcard : Fintype.card E = Fintype.card F := + Fintype.card_congr e.toEquiv + rw [Module.card_eq_pow_finrank (K := K) (V := E), + Module.card_eq_pow_finrank (K := K) (V := F)] at hcard + exact Nat.pow_right_injective + (show 2 ≤ Fintype.card K from Fintype.one_lt_card) hcard + +/-- Arithmetic cancellation recovering a relative residue degree from the +two absolute degree formulas. -/ +private theorem eq_div_gcd_of_mul_eq_mul_div_gcd + (r d f : ℕ) (hd : 0 < d) + (h : d * f = r * (d / Nat.gcd r d)) : + f = r / Nat.gcd r d := by + apply Nat.eq_of_mul_eq_mul_left hd + calc + d * f = r * (d / Nat.gcd r d) := h + _ = (Nat.gcd r d * (r / Nat.gcd r d)) * + (d / Nat.gcd r d) := by + rw [Nat.mul_div_cancel' (Nat.gcd_dvd_left r d)] + _ = (Nat.gcd r d * (d / Nat.gcd r d)) * + (r / Nat.gcd r d) := by ac_rfl + _ = d * (r / Nat.gcd r d) := by + rw [Nat.mul_div_cancel' (Nat.gcd_dvd_right r d)] + +/-- Arithmetic cancellation recovering the number of split places after the +relative residue degree is known. -/ +private theorem eq_gcd_of_mul_div_gcd_eq + (r d a : ℕ) (hr : 0 < r) + (h : a * (r / Nat.gcd r d) = r) : + a = Nat.gcd r d := by + have hquot : 0 < r / Nat.gcd r d := + Nat.div_pos + (Nat.le_of_dvd hr (Nat.gcd_dvd_left r d)) + (Nat.gcd_pos_of_pos_left d hr) + apply Nat.eq_of_mul_eq_mul_right hquot + calc + a * (r / Nat.gcd r d) = r := h + _ = Nat.gcd r d * (r / Nat.gcd r d) := + (Nat.mul_div_cancel' (Nat.gcd_dvd_left r d)).symm + +variable (C S N : Type*) [Field C] [Field S] [Field N] + [Fintype C] [Finite S] + [DecidableEq C] [DecidableEq S] + [DecidableEq (RatFunc C)] [DecidableEq (RatFunc S)] + [Algebra (RatFunc C) N] [FiniteDimensional (RatFunc C) N] + [Algebra.IsSeparable (RatFunc C) N] + [Algebra C S] [FiniteDimensional C S] [IsGalois C S] + +local instance (priority := 10000) infinityDegreeTowerDecidableEqBase : + DecidableEq C := + infinityBridgeDecidableEqConstants C + +local instance (priority := 10000) infinityDegreeTowerDecidableEqRatFuncBase : + DecidableEq (RatFunc C) := + infinityBridgeDecidableEqRatFuncConstants C + +local instance (priority := 10000) infinityDegreeTowerDecidableEqConstants : + DecidableEq S := + infinityBridgeDecidableEqConstants S + +local instance (priority := 10000) + infinityDegreeTowerDecidableEqRatFuncConstants : + DecidableEq (RatFunc S) := + infinityBridgeDecidableEqRatFuncConstants S + +@[reducible] local instance infinityDegreeTowerBaseConstantAlgebra : + Algebra C N := + infinityConstantAlgebra C N + +local instance infinityDegreeTowerBaseRatFuncTower : + IsScalarTower C (RatFunc C) N := + IsScalarTower.of_algebraMap_eq' rfl + +variable (hExact : algebraicClosure C N = + (⊥ : IntermediateField C N)) + +omit [DecidableEq C] [DecidableEq S] [DecidableEq (RatFunc C)] [DecidableEq (RatFunc S)] in +/-- The degree over the original constants of a presented infinity place is +the constant-field degree times the degree of its upstairs `S`-place. -/ +theorem exactConstantExtensionPresentedInfinityPlace_degree_baseChange + (q : ExactConstantExtensionPresentedInfinityPlace C S N) : + letI : DecidableEq C := infinityBridgeDecidableEqConstants C + letI : DecidableEq (RatFunc C) := + infinityBridgeDecidableEqRatFuncConstants C + letI : DecidableEq S := infinityBridgeDecidableEqConstants S + letI : DecidableEq (RatFunc S) := + infinityBridgeDecidableEqRatFuncConstants S + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + letI : Algebra (RatFunc S) (ExactConstantExtension C N S) := + ratFuncExactConstantExtensionAlgebra C S N hExact + finiteExtensionPlaceDegree C (ExactConstantExtension C N S) + (.inr (exactConstantExtensionPresentedInfinityPlaceEquiv + C S N hExact q)) = + Module.finrank C S * + finiteExtensionPlaceDegree S (ExactConstantExtension C N S) + (.inr (exactConstantExtensionUpstairsInfinityPlace + C S N hExact q.1 q.2)) := by + let : DecidableEq C := infinityBridgeDecidableEqConstants C + let : DecidableEq (RatFunc C) := + infinityBridgeDecidableEqRatFuncConstants C + let : DecidableEq S := infinityBridgeDecidableEqConstants S + let : DecidableEq (RatFunc S) := + infinityBridgeDecidableEqRatFuncConstants S + let : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : SMul (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toSMul + let : Module (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toModule + let : FiniteDimensional (RatFunc C) + (ExactConstantExtension C N S) := + finiteDimensional_exactConstantExtension_over_baseRatFunc + C S N hExact + let : Algebra.IsSeparable (RatFunc C) + (ExactConstantExtension C N S) := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + let : Algebra (RatFunc S) (ExactConstantExtension C N S) := + ratFuncExactConstantExtensionAlgebra C S N hExact + let : SMul (RatFunc S) (ExactConstantExtension C N S) := + Algebra.toSMul + let : Module (RatFunc S) (ExactConstantExtension C N S) := + Algebra.toModule + let : FiniteDimensional (RatFunc S) + (ExactConstantExtension C N S) := + finiteDimensional_over_extendedRatFunc C S N hExact + let : Algebra.IsSeparable (RatFunc S) + (ExactConstantExtension C N S) := + isSeparable_over_extendedRatFunc C S N hExact + let : Fintype S := Fintype.ofFinite S + let : Finite q.1.asIdeal.ResidueField := + exactConstantExtensionInfinityTensorResidueField_finite + C S N hExact q.1 q.2 + let : q.1.asIdeal.IsMaximal := + exactConstantExtensionInfinityTensorIdeal_isMaximal + C S N hExact q.1 q.2 + let QC := exactConstantExtensionPresentedInfinityPlaceEquiv + C S N hExact q + let QS := exactConstantExtensionUpstairsInfinityPlace + C S N hExact q.1 q.2 + let BC := RatFuncInfinityIntegralClosure C + (ExactConstantExtension C N S) + let BS := RatFuncInfinityIntegralClosure S + (ExactConstantExtension C N S) + let : Algebra C BC := + onePointInfinityClosureConstantAlgebra C + (ExactConstantExtension C N S) + let : Algebra S BS := + onePointInfinityClosureConstantAlgebra S + (ExactConstantExtension C N S) + let : Algebra C QC.1.ResidueField := by infer_instance + let : Algebra S QS.1.ResidueField := by infer_instance + let eC := exactConstantExtensionPresentedInfinityResidueFieldRingEquiv + C S N hExact q + let : Finite QC.1.ResidueField := + Finite.of_injective eC.symm eC.symm.injective + let : Finite QS.1.ResidueField := + exactConstantExtensionUpstairsInfinityResidueField_finite + C S N hExact q.1 q.2 + have hC : Module.finrank C q.1.asIdeal.ResidueField = + Module.finrank C QC.1.ResidueField := + finrank_eq_of_finite_ringEquiv C q.1.asIdeal.ResidueField + QC.1.ResidueField eC + have hS : Module.finrank S q.1.asIdeal.ResidueField = + Module.finrank S QS.1.ResidueField := + finrank_eq_of_finite_ringEquiv S q.1.asIdeal.ResidueField + QS.1.ResidueField + (exactConstantExtensionUpstairsResidueFieldRingEquiv + C S N hExact q.1 q.2) + rw [finiteExtensionInfinityPlace_degree_eq_finrank_residueField C + (ExactConstantExtension C N S) QC, + finiteExtensionInfinityPlace_degree_eq_finrank_residueField S + (ExactConstantExtension C N S) QS] + calc + Module.finrank C QC.1.ResidueField = + Module.finrank C q.1.asIdeal.ResidueField := hC.symm + _ = Module.finrank C S * + Module.finrank S q.1.asIdeal.ResidueField := + (Module.finrank_mul_finrank C S q.1.asIdeal.ResidueField).symm + _ = Module.finrank C S * Module.finrank S QS.1.ResidueField := by + rw [hS] + +omit [DecidableEq C] [DecidableEq S] [DecidableEq (RatFunc C)] [DecidableEq (RatFunc S)] in +/-- The relative residue degree over the original function field is the +constant extension degree divided by the same gcd that controls splitting. -/ +theorem exactConstantExtensionPresentedInfinityPlace_relativeInertiaDeg_eq_div_gcd + (q : ExactConstantExtensionPresentedInfinityPlace C S N) : + letI : DecidableEq C := infinityBridgeDecidableEqConstants C + letI : DecidableEq (RatFunc C) := + infinityBridgeDecidableEqRatFuncConstants C + letI : DecidableEq S := infinityBridgeDecidableEqConstants S + letI : DecidableEq (RatFunc S) := + infinityBridgeDecidableEqRatFuncConstants S + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + letI : SMul (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toSMul + letI : Module (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toModule + letI : Algebra N (ExactConstantExtension C N S) := + exactConstantExtensionAlgebra C N S + letI : SMul N (ExactConstantExtension C N S) := Algebra.toSMul + letI : Module N (ExactConstantExtension C N S) := Algebra.toModule + letI : IsScalarTower (RatFunc C) N + (ExactConstantExtension C N S) := + exactConstantExtensionBaseTower C (RatFunc C) N S + infinityPlaceRelativeInertiaDeg C N (ExactConstantExtension C N S) + (exactConstantExtensionPresentedInfinityPlaceEquiv + C S N hExact q) = + Module.finrank C S / + Nat.gcd (Module.finrank C S) + (finiteExtensionPlaceDegree C N + (.inr (exactConstantExtensionDownstairsInfinityPlace + C S N q.1 q.2))) := by + let : DecidableEq C := infinityBridgeDecidableEqConstants C + let : DecidableEq (RatFunc C) := + infinityBridgeDecidableEqRatFuncConstants C + let : DecidableEq S := infinityBridgeDecidableEqConstants S + let : DecidableEq (RatFunc S) := + infinityBridgeDecidableEqRatFuncConstants S + let : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : SMul (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toSMul + let : Module (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toModule + let : FiniteDimensional (RatFunc C) + (ExactConstantExtension C N S) := + finiteDimensional_exactConstantExtension_over_baseRatFunc + C S N hExact + let : Algebra.IsSeparable (RatFunc C) + (ExactConstantExtension C N S) := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + let : Algebra (RatFunc S) (ExactConstantExtension C N S) := + ratFuncExactConstantExtensionAlgebra C S N hExact + let : SMul (RatFunc S) (ExactConstantExtension C N S) := + Algebra.toSMul + let : Module (RatFunc S) (ExactConstantExtension C N S) := + Algebra.toModule + let : FiniteDimensional (RatFunc S) + (ExactConstantExtension C N S) := + finiteDimensional_over_extendedRatFunc C S N hExact + let : Algebra.IsSeparable (RatFunc S) + (ExactConstantExtension C N S) := + isSeparable_over_extendedRatFunc C S N hExact + let : Algebra N (ExactConstantExtension C N S) := + exactConstantExtensionAlgebra C N S + let : SMul N (ExactConstantExtension C N S) := Algebra.toSMul + let : Module N (ExactConstantExtension C N S) := Algebra.toModule + let : IsScalarTower (RatFunc C) N + (ExactConstantExtension C N S) := + exactConstantExtensionBaseTower C (RatFunc C) N S + let P := exactConstantExtensionDownstairsInfinityPlace + C S N q.1 q.2 + let Q := exactConstantExtensionPresentedInfinityPlaceEquiv + C S N hExact q + let QS := exactConstantExtensionUpstairsInfinityPlace + C S N hExact q.1 q.2 + let r := Module.finrank C S + let d := finiteExtensionPlaceDegree C N (.inr P) + have hUnder : infinityPlaceUnder C N (ExactConstantExtension C N S) Q = P := + exactConstantExtensionPresentedInfinityPlaceEquiv_under + C S N hExact q + have hUpstairs : finiteExtensionPlaceDegree S + (ExactConstantExtension C N S) (.inr QS) = + d / Nat.gcd r d := by + exact exactConstantExtensionInfinityPlace_degree_eq_div_gcd + C S N hExact q.1 q.2 + have hTop : finiteExtensionPlaceDegree C + (ExactConstantExtension C N S) (.inr Q) = + r * (d / Nat.gcd r d) := by + exact (exactConstantExtensionPresentedInfinityPlace_degree_baseChange + C S N hExact q).trans (congrArg (fun n => r * n) hUpstairs) + have hTower := finiteExtensionPlaceDegree_inr_eq_mul_relativeInertiaDeg + C N (ExactConstantExtension C N S) Q + rw [hUnder] at hTower + have hd : 0 < d := finiteExtensionPlaceDegree_pos C N (.inr P) + exact eq_div_gcd_of_mul_eq_mul_div_gcd r d _ hd + (hTower.symm.trans hTop) + +omit [DecidableEq C] [DecidableEq S] [DecidableEq (RatFunc C)] [DecidableEq (RatFunc S)] in +/-- A downstairs infinity place of degree `d` has exactly +`gcd([S : C], d)` places above it in an exact extension of constants. -/ +theorem exactConstantExtensionInfinityPlace_fiber_card_eq_gcd + (q : ExactConstantExtensionPresentedInfinityPlace C S N) : + letI : DecidableEq C := infinityBridgeDecidableEqConstants C + letI : DecidableEq (RatFunc C) := + infinityBridgeDecidableEqRatFuncConstants C + letI : DecidableEq S := infinityBridgeDecidableEqConstants S + letI : DecidableEq (RatFunc S) := + infinityBridgeDecidableEqRatFuncConstants S + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + letI : SMul (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toSMul + letI : Module (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toModule + letI : FiniteDimensional (RatFunc C) + (ExactConstantExtension C N S) := + finiteDimensional_exactConstantExtension_over_baseRatFunc + C S N hExact + letI : Algebra.IsSeparable (RatFunc C) + (ExactConstantExtension C N S) := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + letI : Algebra N (ExactConstantExtension C N S) := + exactConstantExtensionAlgebra C N S + letI : SMul N (ExactConstantExtension C N S) := Algebra.toSMul + letI : Module N (ExactConstantExtension C N S) := Algebra.toModule + letI : IsScalarTower (RatFunc C) N + (ExactConstantExtension C N S) := + exactConstantExtensionBaseTower C (RatFunc C) N S + letI : IsGalois N (ExactConstantExtension C N S) := + exactConstantExtension_isGalois C N N S hExact + Fintype.card (InfinityPlaceUnderFiber C N + (ExactConstantExtension C N S) + (exactConstantExtensionDownstairsInfinityPlace + C S N q.1 q.2)) = + Nat.gcd (Module.finrank C S) + (finiteExtensionPlaceDegree C N + (.inr (exactConstantExtensionDownstairsInfinityPlace + C S N q.1 q.2))) := by + let : DecidableEq C := infinityBridgeDecidableEqConstants C + let : DecidableEq (RatFunc C) := + infinityBridgeDecidableEqRatFuncConstants C + let : DecidableEq S := infinityBridgeDecidableEqConstants S + let : DecidableEq (RatFunc S) := + infinityBridgeDecidableEqRatFuncConstants S + let : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : SMul (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toSMul + let : Module (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toModule + let : FiniteDimensional (RatFunc C) + (ExactConstantExtension C N S) := + finiteDimensional_exactConstantExtension_over_baseRatFunc + C S N hExact + let : Algebra.IsSeparable (RatFunc C) + (ExactConstantExtension C N S) := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + let : Algebra N (ExactConstantExtension C N S) := + exactConstantExtensionAlgebra C N S + let : SMul N (ExactConstantExtension C N S) := Algebra.toSMul + let : Module N (ExactConstantExtension C N S) := Algebra.toModule + let : IsScalarTower (RatFunc C) N + (ExactConstantExtension C N S) := + exactConstantExtensionBaseTower C (RatFunc C) N S + let : IsGalois N (ExactConstantExtension C N S) := + exactConstantExtension_isGalois C N N S hExact + let P := exactConstantExtensionDownstairsInfinityPlace + C S N q.1 q.2 + let Q := exactConstantExtensionPresentedInfinityPlaceEquiv + C S N hExact q + let r := Module.finrank C S + let d := finiteExtensionPlaceDegree C N (.inr P) + have hUnder : infinityPlaceUnder C N (ExactConstantExtension C N S) Q = P := + exactConstantExtensionPresentedInfinityPlaceEquiv_under + C S N hExact q + let Q0 : InfinityPlaceUnderFiber C N + (ExactConstantExtension C N S) P := ⟨Q, hUnder⟩ + have hFund := + infinityPlaceUnderFiber_card_mul_ramificationIdx_mul_inertiaDeg_eq_field_finrank + C N (ExactConstantExtension C N S) P Q0 + have hRam : infinityPlaceRelativeRamificationIdx C N + (ExactConstantExtension C N S) Q = 1 := + exactConstantExtensionInfinityPlace_ramificationIdx_eq_one + C S N hExact Q + have hInertia : infinityPlaceRelativeInertiaDeg C N + (ExactConstantExtension C N S) Q = r / Nat.gcd r d := + exactConstantExtensionPresentedInfinityPlace_relativeInertiaDeg_eq_div_gcd + C S N hExact q + rw [exactConstantExtension_finrank C N S] at hFund + have hCount : Fintype.card (InfinityPlaceUnderFiber C N + (ExactConstantExtension C N S) P) * (r / Nat.gcd r d) = r := by + simpa [Q0, hRam, hInertia, r] using hFund + exact eq_gcd_of_mul_div_gcd_eq r d _ Module.finrank_pos hCount + +/-- Restricting the global reciprocal presentation equivalence to a fixed +downstairs infinity place identifies the presented contraction fiber with the +entire actual place-restriction fiber. -/ +noncomputable def exactConstantExtensionPresentedInfinityPlaceFiberEquiv : + letI : DecidableEq C := infinityBridgeDecidableEqConstants C + letI : DecidableEq (RatFunc C) := + infinityBridgeDecidableEqRatFuncConstants C + letI : DecidableEq S := infinityBridgeDecidableEqConstants S + letI : DecidableEq (RatFunc S) := + infinityBridgeDecidableEqRatFuncConstants S + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + letI : SMul (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toSMul + letI : Module (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toModule + letI : FiniteDimensional (RatFunc C) + (ExactConstantExtension C N S) := + finiteDimensional_exactConstantExtension_over_baseRatFunc + C S N hExact + letI : Algebra.IsSeparable (RatFunc C) + (ExactConstantExtension C N S) := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + letI : Algebra N (ExactConstantExtension C N S) := + exactConstantExtensionAlgebra C N S + letI : SMul N (ExactConstantExtension C N S) := Algebra.toSMul + letI : Module N (ExactConstantExtension C N S) := Algebra.toModule + letI : IsScalarTower (RatFunc C) N + (ExactConstantExtension C N S) := + exactConstantExtensionBaseTower C (RatFunc C) N S + (P : FiniteExtensionInfinityPlace C N) → + {q : ExactConstantExtensionPresentedInfinityPlace C S N // + exactConstantExtensionDownstairsInfinityPlace + C S N q.1 q.2 = P} ≃ + InfinityPlaceUnderFiber C N (ExactConstantExtension C N S) P := by + letI : DecidableEq C := infinityBridgeDecidableEqConstants C + letI : DecidableEq (RatFunc C) := + infinityBridgeDecidableEqRatFuncConstants C + letI : DecidableEq S := infinityBridgeDecidableEqConstants S + letI : DecidableEq (RatFunc S) := + infinityBridgeDecidableEqRatFuncConstants S + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + letI : SMul (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toSMul + letI : Module (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toModule + letI : FiniteDimensional (RatFunc C) + (ExactConstantExtension C N S) := + finiteDimensional_exactConstantExtension_over_baseRatFunc + C S N hExact + letI : Algebra.IsSeparable (RatFunc C) + (ExactConstantExtension C N S) := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + letI : Algebra N (ExactConstantExtension C N S) := + exactConstantExtensionAlgebra C N S + letI : SMul N (ExactConstantExtension C N S) := Algebra.toSMul + letI : Module N (ExactConstantExtension C N S) := Algebra.toModule + letI : IsScalarTower (RatFunc C) N + (ExactConstantExtension C N S) := + exactConstantExtensionBaseTower C (RatFunc C) N S + intro P + let e := exactConstantExtensionPresentedInfinityPlaceEquiv + C S N hExact + exact + { toFun := fun q => + ⟨e q.1, by + rw [exactConstantExtensionPresentedInfinityPlaceEquiv_under] + exact q.2⟩ + invFun := fun Q => + ⟨e.symm Q.1, by + have hUnder := + exactConstantExtensionPresentedInfinityPlaceEquiv_under + C S N hExact (e.symm Q.1) + have he : e (e.symm Q.1) = Q.1 := e.apply_symm_apply Q.1 + rw [he] at hUnder + exact hUnder.symm.trans Q.2⟩ + left_inv := fun q => by + apply Subtype.ext + exact e.symm_apply_apply q.1 + right_inv := fun Q => by + apply Subtype.ext + exact e.apply_symm_apply Q.1 } + +include hExact + +omit [DecidableEq C] [DecidableEq S] [DecidableEq (RatFunc C)] [DecidableEq (RatFunc S)] in +/-- The presented reciprocal infinity fiber itself has the standard gcd +cardinality. This is the presentation-level exhaustiveness form of the +constant-extension splitting law at infinity. -/ +theorem exactConstantExtensionPresentedInfinityPlaceFiber_natCard_eq_gcd + (q : ExactConstantExtensionPresentedInfinityPlace C S N) : + letI : DecidableEq C := infinityBridgeDecidableEqConstants C + letI : DecidableEq (RatFunc C) := + infinityBridgeDecidableEqRatFuncConstants C + letI : DecidableEq S := infinityBridgeDecidableEqConstants S + letI : DecidableEq (RatFunc S) := + infinityBridgeDecidableEqRatFuncConstants S + Nat.card {q' : ExactConstantExtensionPresentedInfinityPlace C S N // + exactConstantExtensionDownstairsInfinityPlace + C S N q'.1 q'.2 = + exactConstantExtensionDownstairsInfinityPlace + C S N q.1 q.2} = + Nat.gcd (Module.finrank C S) + (finiteExtensionPlaceDegree C N + (.inr (exactConstantExtensionDownstairsInfinityPlace + C S N q.1 q.2))) := by + let : DecidableEq C := infinityBridgeDecidableEqConstants C + let : DecidableEq (RatFunc C) := + infinityBridgeDecidableEqRatFuncConstants C + let : DecidableEq S := infinityBridgeDecidableEqConstants S + let : DecidableEq (RatFunc S) := + infinityBridgeDecidableEqRatFuncConstants S + let : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : SMul (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toSMul + let : Module (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toModule + let : FiniteDimensional (RatFunc C) + (ExactConstantExtension C N S) := + finiteDimensional_exactConstantExtension_over_baseRatFunc + C S N hExact + let : Algebra.IsSeparable (RatFunc C) + (ExactConstantExtension C N S) := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + let : Algebra N (ExactConstantExtension C N S) := + exactConstantExtensionAlgebra C N S + let : SMul N (ExactConstantExtension C N S) := Algebra.toSMul + let : Module N (ExactConstantExtension C N S) := Algebra.toModule + let : IsScalarTower (RatFunc C) N + (ExactConstantExtension C N S) := + exactConstantExtensionBaseTower C (RatFunc C) N S + let : IsGalois N (ExactConstantExtension C N S) := + exactConstantExtension_isGalois C N N S hExact + let P := exactConstantExtensionDownstairsInfinityPlace + C S N q.1 q.2 + calc + Nat.card {q' : ExactConstantExtensionPresentedInfinityPlace C S N // + exactConstantExtensionDownstairsInfinityPlace C S N q'.1 q'.2 = P} = + Nat.card (InfinityPlaceUnderFiber C N + (ExactConstantExtension C N S) P) := + Nat.card_congr + (exactConstantExtensionPresentedInfinityPlaceFiberEquiv + C S N hExact P) + _ = Fintype.card (InfinityPlaceUnderFiber C N + (ExactConstantExtension C N S) P) := + Nat.card_eq_fintype_card + _ = Nat.gcd (Module.finrank C S) + (finiteExtensionPlaceDegree C N (.inr P)) := + exactConstantExtensionInfinityPlace_fiber_card_eq_gcd + C S N hExact q + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/ConstantExtensionInfinityPlaceSplittingMultiplicity.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/ConstantExtensionInfinityPlaceSplittingMultiplicity.lean new file mode 100644 index 0000000000..8b6eb455c9 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/ConstantExtensionInfinityPlaceSplittingMultiplicity.lean @@ -0,0 +1,1376 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import Mathlib.RingTheory.Localization.AtPrime.Extension +public import LeanPool.MarkoffModP.BGS.HasseWeil.ConstantExtensionInfinityPlaceBridge +public import LeanPool.MarkoffModP.BGS.HasseWeil.ConstantExtensionPlaceSplittingMultiplicity + +/-! +# Splitting multiplicity at infinity in an exact extension of constants + +This file identifies the reciprocal-normalization presentation of the places +at infinity with the actual places over the original constant field. It then +proves that an exact extension of constants is unramified at those places. + +The comparison is noncircular: reciprocal affine normalizations are first +compared over `C[X]`, and only then localized to the valuation ring at +infinity. +-/ + +@[expose] public section + +open scoped Polynomial TensorProduct nonZeroDivisors + +namespace BGS.HasseWeil + +noncomputable section + +open BGS.CorvajaZannier IsDedekindDomain + + +variable (C S N : Type*) [Field C] [Field S] [Field N] + [Fintype C] [Finite S] + [DecidableEq C] [DecidableEq S] + [DecidableEq (RatFunc C)] [DecidableEq (RatFunc S)] + [Algebra (RatFunc C) N] [FiniteDimensional (RatFunc C) N] + [Algebra.IsSeparable (RatFunc C) N] + [Algebra C S] [FiniteDimensional C S] [IsGalois C S] + +local instance (priority := 10000) infinitySplittingDecidableEqBase : + DecidableEq C := infinityBridgeDecidableEqConstants C + +local instance (priority := 10000) infinitySplittingDecidableEqRatFuncBase : + DecidableEq (RatFunc C) := infinityBridgeDecidableEqRatFuncConstants C + +local instance (priority := 10000) infinitySplittingDecidableEqConstants : + DecidableEq S := infinityBridgeDecidableEqConstants S + +local instance (priority := 10000) infinitySplittingDecidableEqRatFuncConstants : + DecidableEq (RatFunc S) := infinityBridgeDecidableEqRatFuncConstants S + +@[reducible] local instance infinitySplittingBaseConstantAlgebra : Algebra C N := + infinityConstantAlgebra C N + +@[reducible] local instance infinitySplittingBaseReciprocalPolynomialAlgebra : + Algebra C[X] N := + infinityReciprocalPolynomialAlgebra C N + +local instance infinitySplittingBaseConstantReciprocalPolynomialTower : + IsScalarTower C C[X] N := + infinityReciprocalPolynomialTower C N + +local instance infinitySplittingBaseRatFuncTower : + IsScalarTower C (RatFunc C) N := + IsScalarTower.of_algebraMap_eq' rfl + +local instance infinitySplittingOldNormalizationConstantAlgebra : + Algebra C (integralClosure C[X] N) := + RingHom.toAlgebra + ((algebraMap C[X] (integralClosure C[X] N)).comp + (algebraMap C C[X])) + +local instance infinitySplittingOldNormalizationConstantPolynomialTower : + IsScalarTower C C[X] (integralClosure C[X] N) := + IsScalarTower.of_algebraMap_eq' rfl + +local instance infinitySplittingCoefficientPolynomialAlgebra : + Algebra C[X] S[X] := + Polynomial.algebra C S + +local instance infinitySplittingCoefficientPolynomialSMul : + SMul C[X] S[X] := Algebra.toSMul + +local instance infinitySplittingCoefficientPolynomialModule : + Module C[X] S[X] := Algebra.toModule + +local instance infinitySplittingCOriginPrime : + (Ideal.span ({Polynomial.X} : Set C[X])).IsPrime := + (Ideal.span_singleton_prime Polynomial.X_ne_zero).mpr Polynomial.prime_X + +local instance infinitySplittingSOriginPrime : + (Ideal.span ({Polynomial.X} : Set S[X])).IsPrime := + (Ideal.span_singleton_prime Polynomial.X_ne_zero).mpr Polynomial.prime_X + +variable (hExact : algebraicClosure C N = + (⊥ : IntermediateField C N)) + +/-- The reciprocal `C[X]`-action on the exact constant extension. -/ +@[reducible] noncomputable def exactConstantExtensionCReciprocalPolynomialAlgebra : + Algebra C[X] (ExactConstantExtension C N S) := + RingHom.toAlgebra + ((Algebra.TensorProduct.includeRight + (R := C) (A := S) (B := N)).toRingHom.comp + (algebraMap C[X] N)) + +@[reducible] local instance infinitySplittingExactCPolynomialAlgebra : + Algebra C[X] (ExactConstantExtension C N S) := + exactConstantExtensionCReciprocalPolynomialAlgebra C S N + +@[reducible] local instance infinitySplittingExactSPolynomialAlgebra : + Algebra S[X] (ExactConstantExtension C N S) := + polynomialTensorCancelTargetPolynomialExtensionAlgebra C S N + +local instance infinitySplittingExactCPolynomialSMul : + SMul C[X] (ExactConstantExtension C N S) := Algebra.toSMul + +local instance infinitySplittingExactCPolynomialModule : + Module C[X] (ExactConstantExtension C N S) := Algebra.toModule + +local instance infinitySplittingExactSPolynomialSMul : + SMul S[X] (ExactConstantExtension C N S) := Algebra.toSMul + +@[reducible] local instance infinitySplittingPresentedSPolynomialAlgebra : + Algebra S[X] (TensorProduct C S (integralClosure C[X] N)) := + polynomialTensorCancelTargetPolynomialExtensionAlgebra C S + (integralClosure C[X] N) + +@[reducible] local instance infinitySplittingPresentedCPolynomialAlgebra : + Algebra C[X] (TensorProduct C S (integralClosure C[X] N)) := + RingHom.toAlgebra + ((Algebra.TensorProduct.includeRight + (R := C) (A := S) (B := integralClosure C[X] N)).toRingHom.comp + (algebraMap C[X] (integralClosure C[X] N))) + +local instance infinitySplittingPresentedSPolynomialSMul : + SMul S[X] (TensorProduct C S (integralClosure C[X] N)) := Algebra.toSMul + +local instance infinitySplittingPresentedCPolynomialSMul : + SMul C[X] (TensorProduct C S (integralClosure C[X] N)) := Algebra.toSMul + +omit [Fintype C] [Finite S] [DecidableEq C] [DecidableEq S] [DecidableEq (RatFunc C)] + [DecidableEq (RatFunc S)] [FiniteDimensional (RatFunc C) N] + [Algebra.IsSeparable (RatFunc C) N] [FiniteDimensional C S] [IsGalois C S] in +/-- The reciprocal polynomial actions on the exact constant extension form +the expected scalar tower. -/ +theorem exactConstantExtensionReciprocalPolynomialTower : + IsScalarTower C[X] S[X] (ExactConstantExtension C N S) := by + apply IsScalarTower.of_algebraMap_eq + intro p + rw [polynomialTensorCancel_algebraMap_coefficient C S N p] + rfl + +/-- Integral closure is unchanged when the integral coefficient extension +`C[X] -> S[X]` is inserted into the reciprocal normalization. -/ +noncomputable def exactConstantExtensionReciprocalIntegralClosureTowerEquiv : + integralClosure C[X] (ExactConstantExtension C N S) ≃+* + @integralClosure S[X] (ExactConstantExtension C N S) _ _ + (polynomialTensorCancelTargetPolynomialExtensionAlgebra C S N) := by + letI : IsScalarTower C[X] S[X] (ExactConstantExtension C N S) := + exactConstantExtensionReciprocalPolynomialTower C S N + exact integralClosureRingEquivOfIntegralTower C[X] S[X] + (ExactConstantExtension C N S) + +/-- The presented reciprocal normalization is the normalization of the exact +constant extension over the original reciprocal polynomial ring `C[X]`. -/ +noncomputable def exactConstantExtensionPresentedToCReciprocalNormalizationRingEquiv : + TensorProduct C S (integralClosure C[X] N) ≃+* + integralClosure C[X] (ExactConstantExtension C N S) := by + letI : IsScalarTower C[X] S[X] (ExactConstantExtension C N S) := + exactConstantExtensionReciprocalPolynomialTower C S N + let eS := finiteFieldReciprocalNormalizationAlgEquiv C S N + let eC := exactConstantExtensionReciprocalIntegralClosureTowerEquiv C S N + exact eS.toRingEquiv.trans eC.symm + +omit [Fintype C] [Finite S] [FiniteDimensional C S] [IsGalois C S] in +/-- Coefficient extension commutes with evaluation in the reciprocal +coordinate. -/ +private theorem ratFuncCoefficientAlgHom_reciprocalPolynomialRingHom + (p : C[X]) : + ratFuncCoefficientAlgHom C S + (((reciprocalPolynomialRingHom C p : + RatFuncInfinityIntegers C) : RatFunc C)) = + ((reciprocalPolynomialRingHom S (algebraMap C[X] S[X] p) : + RatFuncInfinityIntegers S) : RatFunc S) := by + rw [reciprocalPolynomialRingHom_coe, + reciprocalPolynomialRingHom_coe] + change (ratFuncCoefficientAlgHom C S).toRingHom + (Polynomial.eval₂ RatFunc.C (1 / RatFunc.X) p) = _ + rw [Polynomial.hom_eval₂] + have hX : ratFuncCoefficientAlgHom C S RatFunc.X = RatFunc.X := by + have h := ratFuncCoefficientAlgHom_algebraMap C S Polynomial.X + simpa using h + have hcoeff : + (ratFuncCoefficientAlgHom C S).toRingHom.comp RatFunc.C = + RatFunc.C.comp (algebraMap C S) := by + ext c + change ratFuncCoefficientAlgHom C S + (algebraMap C (RatFunc C) c) = + algebraMap S (RatFunc S) (algebraMap C S c) + rw [(ratFuncCoefficientAlgHom C S).commutes] + exact IsScalarTower.algebraMap_apply C S (RatFunc S) c + have hrecip : (ratFuncCoefficientAlgHom C S).toRingHom + (1 / RatFunc.X) = 1 / RatFunc.X := by + rw [one_div, map_inv₀] + have hX' : (ratFuncCoefficientAlgHom C S).toRingHom RatFunc.X = + RatFunc.X := hX + simpa [hX'] + rw [hcoeff, hrecip] + change Polynomial.eval₂ (RatFunc.C.comp (algebraMap C S)) + (1 / RatFunc.X) p = + Polynomial.eval₂ RatFunc.C (1 / RatFunc.X) + (Polynomial.map (algebraMap C S) p) + rw [Polynomial.eval₂_map] + +/-- The reciprocal polynomial algebra map is the composite through the +rational-function field. -/ +theorem ratFuncExtensionReciprocalPolynomialAlgebra_map + (K L : Type*) [Field K] [Field L] + [DecidableEq K] [DecidableEq (RatFunc K)] + [Algebra (RatFunc K) L] (p : K[X]) : + letI : Algebra K[X] L := + ratFuncExtensionReciprocalPolynomialAlgebra K L + algebraMap K[X] L p = algebraMap (RatFunc K) L + (((reciprocalPolynomialRingHom K p : + RatFuncInfinityIntegers K) : RatFunc K)) := by + let : Algebra K[X] L := + ratFuncExtensionReciprocalPolynomialAlgebra K L + change algebraMap (RatFuncInfinityIntegers K) L + (reciprocalPolynomialRingHom K p) = _ + exact IsScalarTower.algebraMap_apply + (RatFuncInfinityIntegers K) (RatFunc K) L _ + +omit [Fintype C] [Finite S] [DecidableEq C] [DecidableEq (RatFunc C)] + [FiniteDimensional (RatFunc C) N] [Algebra.IsSeparable (RatFunc C) N] in +/-- Version of reciprocal polynomial compatibility elaborated with the +instances used in this file. -/ +private theorem exactConstantExtensionSReciprocalPolynomialAlgebra_eq : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc S) (ExactConstantExtension C N S) := + ratFuncExactConstantExtensionAlgebra C S N hExact + polynomialTensorCancelTargetPolynomialExtensionAlgebra C S N = + ratFuncExtensionReciprocalPolynomialAlgebra S + (ExactConstantExtension C N S) := by + let : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + let : Algebra (RatFunc S) (ExactConstantExtension C N S) := + ratFuncExactConstantExtensionAlgebra C S N hExact + apply Algebra.algebra_ext + intro p + change Polynomial.aeval + (polynomialTensorCancelEvaluationPoint C S N) p = + algebraMap (RatFunc S) (ExactConstantExtension C N S) + (((reciprocalPolynomialRingHom S p : + RatFuncInfinityIntegers S) : RatFunc S)) + rw [reciprocalPolynomialRingHom_coe, Polynomial.hom_eval₂] + have hcoeff : + (algebraMap (RatFunc S) + (ExactConstantExtension C N S)).comp RatFunc.C = + algebraMap S (ExactConstantExtension C N S) := by + ext s + exact (ratFuncToExactConstantExtension C S N hExact).commutes s + rw [hcoeff] + change Polynomial.eval₂ + (algebraMap S (ExactConstantExtension C N S)) + (polynomialTensorCancelEvaluationPoint C S N) p = + Polynomial.eval₂ + (algebraMap S (ExactConstantExtension C N S)) + (ratFuncToExactConstantExtension C S N hExact + (1 / RatFunc.X)) p + rw [ratFuncToExactConstantExtension_reciprocal_X C S N hExact] + +omit [Fintype C] [Finite S] [FiniteDimensional (RatFunc C) N] + [Algebra.IsSeparable (RatFunc C) N] in +/-- The transported reciprocal `C[X]`-action is the actual action induced by +the canonical embedding of `C(X)` into the exact constant extension. -/ +theorem exactConstantExtensionCReciprocalPolynomialAlgebra_eq : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + exactConstantExtensionCReciprocalPolynomialAlgebra C S N = + ratFuncExtensionReciprocalPolynomialAlgebra C + (ExactConstantExtension C N S) := by + let : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : SMul (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toSMul + let : Module (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toModule + let : Algebra (RatFunc C) (RatFunc S) := + ratFuncCoefficientAlgebra C S + let : Algebra (RatFunc S) (ExactConstantExtension C N S) := + ratFuncExactConstantExtensionAlgebra C S N hExact + let : Algebra C[X] (ExactConstantExtension C N S) := + exactConstantExtensionCReciprocalPolynomialAlgebra C S N + let : Algebra S[X] (ExactConstantExtension C N S) := + infinitySplittingExactSPolynomialAlgebra C S N + let : SMul C[X] (ExactConstantExtension C N S) := + infinitySplittingExactCPolynomialSMul C S N + let : SMul S[X] (ExactConstantExtension C N S) := + infinitySplittingExactSPolynomialSMul C S N + let : IsScalarTower C[X] S[X] (ExactConstantExtension C N S) := + exactConstantExtensionReciprocalPolynomialTower C S N + apply Algebra.algebra_ext + intro p + let pS := algebraMap C[X] S[X] p + let yC := ((reciprocalPolynomialRingHom C p : + RatFuncInfinityIntegers C) : RatFunc C) + let yS := ((reciprocalPolynomialRingHom S pS : + RatFuncInfinityIntegers S) : RatFunc S) + have hSAlg := exactConstantExtensionSReciprocalPolynomialAlgebra_eq + C S N hExact + have hRat := rationalBase_algebraMap_eq C S N hExact + calc + algebraMap C[X] (ExactConstantExtension C N S) p = + algebraMap S[X] (ExactConstantExtension C N S) pS := + IsScalarTower.algebraMap_apply C[X] S[X] + (ExactConstantExtension C N S) p + _ = @algebraMap S[X] (ExactConstantExtension C N S) _ _ + (ratFuncExtensionReciprocalPolynomialAlgebra S + (ExactConstantExtension C N S)) pS := by + change @algebraMap S[X] (ExactConstantExtension C N S) _ _ + (polynomialTensorCancelTargetPolynomialExtensionAlgebra C S N) pS = _ + exact DFunLike.congr_fun + (congrArg (fun a : Algebra S[X] (ExactConstantExtension C N S) => + @algebraMap S[X] (ExactConstantExtension C N S) _ _ a) hSAlg) pS + _ = algebraMap (RatFunc S) (ExactConstantExtension C N S) yS := + ratFuncExtensionReciprocalPolynomialAlgebra_map S + (ExactConstantExtension C N S) pS + _ = algebraMap (RatFunc S) (ExactConstantExtension C N S) + (algebraMap (RatFunc C) (RatFunc S) yC) := by + congr 1 + exact (ratFuncCoefficientAlgHom_reciprocalPolynomialRingHom C S p).symm + _ = algebraMap (RatFunc C) (ExactConstantExtension C N S) yC := by + exact (DFunLike.congr_fun hRat yC).symm + _ = @algebraMap C[X] (ExactConstantExtension C N S) _ _ + (ratFuncExtensionReciprocalPolynomialAlgebra C + (ExactConstantExtension C N S)) p := + (ratFuncExtensionReciprocalPolynomialAlgebra_map C + (ExactConstantExtension C N S) p).symm + +/-- Replace the transported reciprocal polynomial action by the definitionally +actual action induced from `C(X)`. -/ +noncomputable def exactConstantExtensionCReciprocalNormalizationRingEquiv : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + @integralClosure C[X] (ExactConstantExtension C N S) _ _ + (exactConstantExtensionCReciprocalPolynomialAlgebra C S N) ≃+* + @integralClosure C[X] (ExactConstantExtension C N S) _ _ + (ratFuncExtensionReciprocalPolynomialAlgebra C + (ExactConstantExtension C N S)) := by + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + rw [exactConstantExtensionCReciprocalPolynomialAlgebra_eq C S N hExact] + +/-- Localization at the reciprocal origin identifies affine primes with the +actual places of the exact constant extension above `C`-infinity. -/ +noncomputable def exactConstantExtensionCReciprocalPrimesEquivInfinityPlace : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + letI : Algebra C[X] (ExactConstantExtension C N S) := + ratFuncExtensionReciprocalPolynomialAlgebra C + (ExactConstantExtension C N S) + (Ideal.span ({Polynomial.X} : Set C[X])).primesOver + (integralClosure C[X] (ExactConstantExtension C N S)) ≃ + FiniteExtensionInfinityPlace C (ExactConstantExtension C N S) := by + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + letI : SMul (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toSMul + letI : Module (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toModule + letI : FiniteDimensional (RatFunc C) + (ExactConstantExtension C N S) := + finiteDimensional_exactConstantExtension_over_baseRatFunc + C S N hExact + letI : Algebra.IsSeparable (RatFunc C) + (ExactConstantExtension C N S) := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + letI : Algebra C[X] (ExactConstantExtension C N S) := + ratFuncExtensionReciprocalPolynomialAlgebra C + (ExactConstantExtension C N S) + letI : SMul C[X] (ExactConstantExtension C N S) := + Algebra.toSMul + letI : Module C[X] (ExactConstantExtension C N S) := + Algebra.toModule + letI : Algebra C[X] (RatFunc C) := + ratFuncExtensionReciprocalPolynomialAlgebra C (RatFunc C) + letI : SMul C[X] (RatFunc C) := Algebra.toSMul + letI : IsScalarTower C[X] (RatFunc C) + (ExactConstantExtension C N S) := + IsScalarTower.of_algebraMap_eq fun p => by + calc + algebraMap C[X] (ExactConstantExtension C N S) p = + algebraMap (RatFunc C) (ExactConstantExtension C N S) + (((reciprocalPolynomialRingHom C p : + RatFuncInfinityIntegers C) : RatFunc C)) := + ratFuncExtensionReciprocalPolynomialAlgebra_map C + (ExactConstantExtension C N S) p + _ = algebraMap (RatFunc C) (ExactConstantExtension C N S) + (algebraMap C[X] (RatFunc C) p) := by + rw [ratFuncExtensionReciprocalPolynomialAlgebra_map C (RatFunc C) p] + exact congrArg (algebraMap (RatFunc C) + (ExactConstantExtension C N S)) + (Algebra.algebraMap_self_apply _).symm + letI : IsFractionRing C[X] (RatFunc C) := + ratFunc_isFractionRing_reciprocalPolynomial C + let A := integralClosure C[X] (ExactConstantExtension C N S) + let V := RatFuncInfinityIntegers C + let B := RatFuncInfinityIntegralClosure C + (ExactConstantExtension C N S) + let o := Ideal.span ({Polynomial.X} : Set C[X]) + letI : Algebra C[X] V := ratFuncInfinityReciprocalPolynomialAlgebra C + letI : o.IsPrime := + (Ideal.span_singleton_prime Polynomial.X_ne_zero).mpr Polynomial.prime_X + letI : IsLocalization o.primeCompl V := + ratFuncInfinityIntegers_isLocalization_reciprocal C + letI : Algebra A B := + ratFuncInfinityReciprocalIntegralClosureAlgebra C + (ExactConstantExtension C N S) + letI : SMul A B := Algebra.toSMul + letI : IsLocalization (Algebra.algebraMapSubmonoid A o.primeCompl) B := + ratFuncInfinityIntegralClosure_isLocalization_reciprocal C + (ExactConstantExtension C N S) + letI : Algebra C[X] B := + RingHom.toAlgebra ((algebraMap V B).comp (algebraMap C[X] V)) + letI : IsScalarTower C[X] V B := + IsScalarTower.of_algebraMap_eq' rfl + letI : IsScalarTower C[X] A B := + IsScalarTower.of_algebraMap_eq fun p => by + apply Subtype.ext + rfl + letI : IsDedekindDomain A := + IsIntegralClosure.isDedekindDomain C[X] (RatFunc C) + (ExactConstantExtension C N S) A + letI : Module C[X] A := Algebra.toModule + letI : Module.IsTorsionFree C[X] + (ExactConstantExtension C N S) := by + rw [Module.isTorsionFree_iff_algebraMap_injective] + intro x y hxy + apply IsFractionRing.injective C[X] (RatFunc C) + apply (algebraMap (RatFunc C) + (ExactConstantExtension C N S)).injective + simpa only [IsScalarTower.algebraMap_apply C[X] (RatFunc C) + (ExactConstantExtension C N S)] using hxy + letI : IsScalarTower C[X] A (ExactConstantExtension C N S) := by + infer_instance + letI : Module.IsTorsionFree C[X] A := + IsIntegralClosure.isTorsionFree C[X] + (ExactConstantExtension C N S) + have ho : o ≠ ⊥ := by + exact fun h => Polynomial.X_ne_zero (Ideal.span_singleton_eq_bot.mp h) + change o.primesOver A ≃ + (IsLocalRing.maximalIdeal V).primesOver B + exact (IsDedekindDomain.primesOverEquivPrimesOver o V B ho).toEquiv + +omit [Fintype C] [Finite S] [DecidableEq C] [DecidableEq S] [DecidableEq (RatFunc C)] + [DecidableEq (RatFunc S)] [FiniteDimensional (RatFunc C) N] + [Algebra.IsSeparable (RatFunc C) N] [FiniteDimensional C S] [IsGalois C S] in +private theorem exactConstantExtensionPresentedReciprocalPolynomialTower : + IsScalarTower C[X] S[X] + (S ⊗[C] integralClosure C[X] N) := by + apply IsScalarTower.of_algebraMap_eq + intro p + rw [polynomialTensorCancel_algebraMap_coefficient C S + (integralClosure C[X] N) p] + rfl + +/-- The old reciprocal normalization maps into the reciprocal normalization +of the exact constant extension through the right tensor factor. -/ +private noncomputable def exactConstantExtensionOldToCReciprocalNormalizationMap : + integralClosure C[X] N →ₐ[C[X]] + integralClosure C[X] (ExactConstantExtension C N S) := by + letI : Algebra N (ExactConstantExtension C N S) := + exactConstantExtensionAlgebra C N S + letI : SMul N (ExactConstantExtension C N S) := Algebra.toSMul + letI : IsScalarTower C[X] N (ExactConstantExtension C N S) := + IsScalarTower.of_algebraMap_eq' rfl + exact (IsScalarTower.toAlgHom C[X] N + (ExactConstantExtension C N S)).mapIntegralClosure + +omit [DecidableEq C] [DecidableEq S] [DecidableEq (RatFunc C)] [DecidableEq (RatFunc S)] + [FiniteDimensional (RatFunc C) N] [Algebra.IsSeparable (RatFunc C) N] + [FiniteDimensional C S] in +/-- The normalization equivalence carries the old normalization embedded in +the right tensor factor to its canonical map into the exact extension. -/ +private theorem + exactConstantExtensionPresentedToCReciprocalNormalizationRingEquiv_includeRight + (x : integralClosure C[X] N) : + exactConstantExtensionPresentedToCReciprocalNormalizationRingEquiv + C S N + (Algebra.TensorProduct.includeRight + (R := C) (A := S) (B := integralClosure C[X] N) x) = + exactConstantExtensionOldToCReciprocalNormalizationMap C S N x := by + apply Subtype.ext + change ((finiteFieldReciprocalNormalizationAlgEquiv C S N + (Algebra.TensorProduct.includeRight + (R := C) (A := S) (B := integralClosure C[X] N) x) : + integralClosure S[X] (ExactConstantExtension C N S)) : + ExactConstantExtension C N S) = + (1 : S) ⊗ₜ[C] (x : N) + simp only [finiteFieldReciprocalNormalizationAlgEquiv, + AlgEquiv.trans_apply, + Algebra.TensorProduct.includeRight_apply, + polynomialTensorCancelOverCoefficientPolynomial_symm_apply, + polynomialTensorCancel_symm_tmul, + finiteFieldPolynomialIntegralClosureBaseChangeAlgEquiv, + polynomialIntegralClosureBaseChangeAlgEquiv, + AlgEquiv.ofBijective_apply, + AlgEquiv.coe_mapIntegralClosure] + rw [polynomialTensorCancelOverCoefficientPolynomial_apply] + change polynomialTensorCancel C S N + (Polynomial.C 1 ⊗ₜ[C[X]] (x : N)) = + (1 : S) ⊗ₜ[C] (x : N) + rw [polynomialTensorCancel_tmul] + simp + +omit [Fintype C] [Finite S] [DecidableEq C] [DecidableEq S] [DecidableEq (RatFunc C)] + [DecidableEq (RatFunc S)] [FiniteDimensional C S] [IsGalois C S] in +/-- The reciprocal origin is the unique prime of `S[X]` above the reciprocal +origin of `C[X]`. -/ +theorem primeUnderReciprocalOrigin_eq_origin + (p : Ideal S[X]) [p.IsPrime] + (hunder : p.under C[X] = + Ideal.span ({Polynomial.X} : Set C[X])) : + p = Ideal.span ({Polynomial.X} : Set S[X]) := by + let oS := Ideal.span ({Polynomial.X} : Set S[X]) + have hXC : (Polynomial.X : C[X]) ∈ p.under C[X] := by + rw [hunder] + exact Ideal.subset_span (Set.mem_singleton Polynomial.X) + have hXS : (Polynomial.X : S[X]) ∈ p := by + change algebraMap C[X] S[X] (Polynomial.X : C[X]) ∈ p at hXC + simpa using hXC + have hle : oS ≤ p := by + rw [Ideal.span_le] + exact Set.singleton_subset_iff.mpr hXS + have hoPrime : oS.IsPrime := by + exact (Ideal.span_singleton_prime Polynomial.X_ne_zero).mpr + Polynomial.prime_X + have hoNeBot : oS ≠ ⊥ := by + rw [ne_eq, Ideal.span_singleton_eq_bot] + exact Polynomial.X_ne_zero + exact ((hoPrime.isMaximal hoNeBot).eq_of_le + (inferInstance : p.IsPrime).ne_top hle).symm + +omit [DecidableEq C] [DecidableEq S] [DecidableEq (RatFunc C)] [DecidableEq (RatFunc S)] + [FiniteDimensional (RatFunc C) N] [Algebra.IsSeparable (RatFunc C) N] + [FiniteDimensional C S] in +private theorem + exactConstantExtensionPresentedToCReciprocalNormalizationRingEquiv_commutes + (p : C[X]) : + exactConstantExtensionPresentedToCReciprocalNormalizationRingEquiv C S N + (algebraMap C[X] (S ⊗[C] integralClosure C[X] N) p) = + algebraMap C[X] + (integralClosure C[X] (ExactConstantExtension C N S)) p := by + let : IsScalarTower C[X] S[X] (ExactConstantExtension C N S) := + exactConstantExtensionReciprocalPolynomialTower C S N + let eS := finiteFieldReciprocalNormalizationAlgEquiv C S N + let eC := exactConstantExtensionReciprocalIntegralClosureTowerEquiv C S N + change eC.symm (eS + (algebraMap C[X] (S ⊗[C] integralClosure C[X] N) p)) = _ + rw [show algebraMap C[X] (S ⊗[C] integralClosure C[X] N) p = + algebraMap S[X] (S ⊗[C] integralClosure C[X] N) + (algebraMap C[X] S[X] p) by + rw [polynomialTensorCancel_algebraMap_coefficient C S + (integralClosure C[X] N) p] + rfl] + rw [eS.commutes] + apply Subtype.ext + change algebraMap S[X] (ExactConstantExtension C N S) + (algebraMap C[X] S[X] p) = + algebraMap C[X] (ExactConstantExtension C N S) p + rw [polynomialTensorCancel_algebraMap_coefficient C S N p] + rfl + +/-- The reciprocal normalization equivalence transports height-one primes. -/ +noncomputable def + exactConstantExtensionPresentedToCReciprocalNormalizationHeightOneEquiv : + HeightOneSpectrum (S ⊗[C] integralClosure C[X] N) ≃ + HeightOneSpectrum + (integralClosure C[X] (ExactConstantExtension C N S)) := + HeightOneSpectrum.equivOfRingEquiv + (exactConstantExtensionPresentedToCReciprocalNormalizationRingEquiv C S N) + +omit [DecidableEq C] [DecidableEq S] [DecidableEq (RatFunc C)] [DecidableEq (RatFunc S)] + [FiniteDimensional (RatFunc C) N] [Algebra.IsSeparable (RatFunc C) N] + [FiniteDimensional C S] in +/-- The reciprocal normalization equivalence preserves contraction to `C[X]`. -/ +theorem + exactConstantExtensionPresentedToCReciprocalNormalizationHeightOneEquiv_under + (q : HeightOneSpectrum (S ⊗[C] integralClosure C[X] N)) : + ((exactConstantExtensionPresentedToCReciprocalNormalizationHeightOneEquiv + C S N) q).asIdeal.under C[X] = + q.asIdeal.under C[X] := by + let e := exactConstantExtensionPresentedToCReciprocalNormalizationRingEquiv + C S N + ext p + change e.symm + (algebraMap C[X] + (integralClosure C[X] (ExactConstantExtension C N S)) p) ∈ + q.asIdeal ↔ + algebraMap C[X] (S ⊗[C] integralClosure C[X] N) p ∈ q.asIdeal + rw [← + exactConstantExtensionPresentedToCReciprocalNormalizationRingEquiv_commutes + C S N p] + simp only [e, RingEquiv.symm_apply_apply] + +/-- Presented infinity places correspond to height-one primes above the reciprocal origin. -/ +noncomputable def + exactConstantExtensionPresentedInfinityHeightOneEquiv : + ExactConstantExtensionPresentedInfinityPlace C S N ≃ + {q : HeightOneSpectrum + (integralClosure C[X] (ExactConstantExtension C N S)) // + q.asIdeal.under C[X] = + Ideal.span ({Polynomial.X} : Set C[X])} := by + letI : IsScalarTower C[X] S[X] + (S ⊗[C] integralClosure C[X] N) := + by exact exactConstantExtensionPresentedReciprocalPolynomialTower C S N + let e := + exactConstantExtensionPresentedToCReciprocalNormalizationHeightOneEquiv + C S N + apply e.subtypeEquiv + intro q + constructor + · intro hq + rw [ + exactConstantExtensionPresentedToCReciprocalNormalizationHeightOneEquiv_under + C S N q] + calc + q.asIdeal.under C[X] = + (q.asIdeal.under S[X]).under C[X] := + (Ideal.under_under q.asIdeal).symm + _ = (Ideal.span ({Polynomial.X} : Set S[X])).under C[X] := by + rw [hq] + _ = Ideal.span ({Polynomial.X} : Set C[X]) := + coefficientPolynomial_under_span_X C S + · intro hq + have hqC : q.asIdeal.under C[X] = + Ideal.span ({Polynomial.X} : Set C[X]) := by + rw [← + exactConstantExtensionPresentedToCReciprocalNormalizationHeightOneEquiv_under + C S N q] + exact hq + let p := q.asIdeal.under S[X] + let : q.asIdeal.IsPrime := q.isPrime + let : p.IsPrime := inferInstance + apply primeUnderReciprocalOrigin_eq_origin C S p + calc + p.under C[X] = q.asIdeal.under C[X] := Ideal.under_under q.asIdeal + _ = Ideal.span ({Polynomial.X} : Set C[X]) := hqC + +/-- Height-one primes above the reciprocal origin identify with its prime fiber. -/ +noncomputable def + exactConstantExtensionCReciprocalHeightOneEquivPrimesOver : + {q : HeightOneSpectrum + (integralClosure C[X] (ExactConstantExtension C N S)) // + q.asIdeal.under C[X] = + Ideal.span ({Polynomial.X} : Set C[X])} ≃ + (Ideal.span ({Polynomial.X} : Set C[X])).primesOver + (integralClosure C[X] (ExactConstantExtension C N S)) := by + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + exact + { toFun := fun q => ⟨q.1.asIdeal, q.1.isPrime, ⟨q.2.symm⟩⟩ + invFun := fun P => by + let oC := Ideal.span ({Polynomial.X} : Set C[X]) + have hNX : algebraMap C[X] N (Polynomial.X : C[X]) ≠ 0 := by + let : DecidableEq C := infinityBridgeDecidableEqConstants C + let : DecidableEq (RatFunc C) := + infinityBridgeDecidableEqRatFuncConstants C + have hNX' : @algebraMap C[X] N _ _ + (ratFuncExtensionReciprocalPolynomialAlgebra C N) + (Polynomial.X : C[X]) ≠ 0 := by + rw [ratFuncExtensionReciprocalPolynomialAlgebra_map C N] + rw [reciprocalPolynomialRingHom_X] + change algebraMap (RatFunc C) N (1 / RatFunc.X) ≠ 0 + intro hzero + have hzero' : (1 / RatFunc.X : RatFunc C) = 0 := by + apply (algebraMap (RatFunc C) N).injective + simpa only [map_zero] using hzero + exact (one_div_ne_zero RatFunc.X_ne_zero) hzero' + change @algebraMap C[X] N _ _ + (infinitySplittingBaseReciprocalPolynomialAlgebra C N) + (Polynomial.X : C[X]) ≠ 0 + unfold infinitySplittingBaseReciprocalPolynomialAlgebra + unfold infinityReciprocalPolynomialAlgebra + exact hNX' + have hEX : algebraMap C[X] (ExactConstantExtension C N S) + (Polynomial.X : C[X]) ≠ 0 := by + change Algebra.TensorProduct.includeRight + (R := C) (A := S) (B := N) + (algebraMap C[X] N (Polynomial.X : C[X])) ≠ 0 + let f := Algebra.TensorProduct.includeRight + (R := C) (A := S) (B := N) + intro hx + apply hNX + apply f.injective + exact hx.trans (map_zero f).symm + have hAX : algebraMap C[X] + (integralClosure C[X] (ExactConstantExtension C N S)) + (Polynomial.X : C[X]) ≠ 0 := by + intro hzero + apply hEX + exact congrArg Subtype.val hzero + letI : P.1.LiesOver oC := P.2.2 + have hXmem : algebraMap C[X] + (integralClosure C[X] (ExactConstantExtension C N S)) + (Polynomial.X : C[X]) ∈ P.1 := + (Ideal.mem_of_liesOver P.1 oC Polynomial.X).mp + (Ideal.mem_span_singleton_self Polynomial.X) + have hPNeBot : P.1 ≠ ⊥ := by + intro hbot + apply hAX + rw [hbot] at hXmem + change algebraMap C[X] + (integralClosure C[X] (ExactConstantExtension C N S)) + (Polynomial.X : C[X]) = 0 at hXmem + exact hXmem + let q : HeightOneSpectrum + (integralClosure C[X] (ExactConstantExtension C N S)) := + ⟨P.1, P.2.1, hPNeBot⟩ + refine ⟨q, ?_⟩ + exact (Ideal.over_def P.1 oC).symm + left_inv := by + intro q + apply Subtype.ext + apply HeightOneSpectrum.ext + rfl + right_inv := by + intro P + apply Subtype.ext + rfl } + +/-- Presented infinity places, before changing the transported reciprocal +action to the actual one, are precisely the affine primes above `(X)`. -/ +noncomputable def + exactConstantExtensionPresentedInfinityPlaceEquivCReciprocalPrimes : + ExactConstantExtensionPresentedInfinityPlace C S N ≃ + (Ideal.span ({Polynomial.X} : Set C[X])).primesOver + (integralClosure C[X] (ExactConstantExtension C N S)) := + (exactConstantExtensionPresentedInfinityHeightOneEquiv C S N).trans + (exactConstantExtensionCReciprocalHeightOneEquivPrimesOver + C S N) + +/-- Contracting the transported reciprocal affine prime to the old +normalization recovers the contraction used in the presented downstairs +place. -/ +private theorem + exactConstantExtensionPresentedInfinityPlaceEquivCReciprocalPrimes_under_old + (q : ExactConstantExtensionPresentedInfinityPlace C S N) : + letI : Algebra (integralClosure C[X] N) + (integralClosure C[X] (ExactConstantExtension C N S)) := + (exactConstantExtensionOldToCReciprocalNormalizationMap C S N).toAlgebra + ((exactConstantExtensionPresentedInfinityPlaceEquivCReciprocalPrimes + C S N q).1).under (integralClosure C[X] N) = + exactConstantExtensionInfinityDownstairsIdeal C S N q.1 := by + let e := exactConstantExtensionPresentedToCReciprocalNormalizationRingEquiv + C S N + let f := exactConstantExtensionOldToCReciprocalNormalizationMap C S N + let : Algebra (integralClosure C[X] N) + (integralClosure C[X] (ExactConstantExtension C N S)) := + f.toAlgebra + ext x + change e.symm (f x) ∈ q.1.asIdeal ↔ + Algebra.TensorProduct.includeRight + (R := C) (A := S) (B := integralClosure C[X] N) x ∈ + q.1.asIdeal + have hx : e.symm (f x) = + Algebra.TensorProduct.includeRight + (R := C) (A := S) (B := integralClosure C[X] N) x := by + apply e.injective + rw [e.apply_symm_apply, + exactConstantExtensionPresentedToCReciprocalNormalizationRingEquiv_includeRight] + rw [hx] + +/-- Changing from the transported reciprocal action to the actual action does +not change the affine prime fiber. -/ +private noncomputable def integralClosureAlgHomOfAlgebraEq + (R L A : Type*) [CommRing R] [Field L] [CommRing A] [Algebra R A] + (a b : Algebra R L) (h : a = b) + (f : A →ₐ[R] @integralClosure R L _ _ a) : + A →ₐ[R] @integralClosure R L _ _ b := by + rw [← h] + exact f + +private noncomputable def primesOverEquivOfAlgebraEq + (R L : Type*) [CommRing R] [Field L] + (a b : Algebra R L) (h : a = b) (p : Ideal R) : + @Ideal.primesOver R _ p (@integralClosure R L _ _ a) _ _ ≃ + @Ideal.primesOver R _ p (@integralClosure R L _ _ b) _ _ := by + rw [h] + +private theorem primesOverEquivOfAlgebraEq_under + (R L A : Type*) [CommRing R] [Field L] [CommRing A] [Algebra R A] + (a b : Algebra R L) (h : a = b) (p : Ideal R) + (f : A →ₐ[R] @integralClosure R L _ _ a) + (P : @Ideal.primesOver R _ p (@integralClosure R L _ _ a) _ _) : + let g := integralClosureAlgHomOfAlgebraEq R L A a b h f + letI : Algebra A (@integralClosure R L _ _ a) := f.toAlgebra + letI : Algebra A (@integralClosure R L _ _ b) := g.toAlgebra + ((primesOverEquivOfAlgebraEq R L a b h p P).1).under A = + P.1.under A := by + subst b + rfl + +/-- The prime fiber over the reciprocal origin is preserved by identifying the two polynomial +actions. -/ +noncomputable def + exactConstantExtensionCReciprocalPrimesEquivActual : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + @Ideal.primesOver C[X] _ + (Ideal.span ({Polynomial.X} : Set C[X])) + (@integralClosure C[X] (ExactConstantExtension C N S) _ _ + (exactConstantExtensionCReciprocalPolynomialAlgebra C S N)) _ _ ≃ + @Ideal.primesOver C[X] _ + (Ideal.span ({Polynomial.X} : Set C[X])) + (@integralClosure C[X] (ExactConstantExtension C N S) _ _ + (ratFuncExtensionReciprocalPolynomialAlgebra C + (ExactConstantExtension C N S))) _ _ := by + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + rw [exactConstantExtensionCReciprocalPolynomialAlgebra_eq C S N hExact] + +/-- The reciprocal-normalization presentation of infinity places is exactly +the actual infinity-place type of the exact constant extension over `C`. -/ +noncomputable def exactConstantExtensionPresentedInfinityPlaceEquiv : + ExactConstantExtensionPresentedInfinityPlace C S N ≃ + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + FiniteExtensionInfinityPlace C (ExactConstantExtension C N S) := + (exactConstantExtensionPresentedInfinityPlaceEquivCReciprocalPrimes + C S N).trans + ((exactConstantExtensionCReciprocalPrimesEquivActual + C S N hExact).trans + (exactConstantExtensionCReciprocalPrimesEquivInfinityPlace + C S N hExact)) + +omit [DecidableEq C] [DecidableEq (RatFunc C)] in +/-- The reciprocal presentation equivalence respects restriction to the +original function field. -/ +@[simp] +theorem exactConstantExtensionPresentedInfinityPlaceEquiv_under + (q : ExactConstantExtensionPresentedInfinityPlace C S N) : + letI : DecidableEq C := infinityBridgeDecidableEqConstants C + letI : DecidableEq (RatFunc C) := + infinityBridgeDecidableEqRatFuncConstants C + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + letI : SMul (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toSMul + letI : Module (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toModule + letI : FiniteDimensional (RatFunc C) + (ExactConstantExtension C N S) := + finiteDimensional_exactConstantExtension_over_baseRatFunc + C S N hExact + letI : Algebra.IsSeparable (RatFunc C) + (ExactConstantExtension C N S) := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + letI : Algebra N (ExactConstantExtension C N S) := + exactConstantExtensionAlgebra C N S + letI : SMul N (ExactConstantExtension C N S) := Algebra.toSMul + letI : Module N (ExactConstantExtension C N S) := Algebra.toModule + letI : IsScalarTower (RatFunc C) N + (ExactConstantExtension C N S) := + exactConstantExtensionBaseTower C (RatFunc C) N S + infinityPlaceUnder C N (ExactConstantExtension C N S) + (exactConstantExtensionPresentedInfinityPlaceEquiv + C S N hExact q) = + exactConstantExtensionDownstairsInfinityPlace C S N q.1 q.2 := by + let : DecidableEq C := infinityBridgeDecidableEqConstants C + let : DecidableEq (RatFunc C) := + infinityBridgeDecidableEqRatFuncConstants C + let : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : SMul (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toSMul + let : Module (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toModule + let : FiniteDimensional (RatFunc C) + (ExactConstantExtension C N S) := + finiteDimensional_exactConstantExtension_over_baseRatFunc + C S N hExact + let : Algebra.IsSeparable (RatFunc C) + (ExactConstantExtension C N S) := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + let : Algebra N (ExactConstantExtension C N S) := + exactConstantExtensionAlgebra C N S + let : SMul N (ExactConstantExtension C N S) := Algebra.toSMul + let : Module N (ExactConstantExtension C N S) := Algebra.toModule + let : IsScalarTower (RatFunc C) N + (ExactConstantExtension C N S) := + exactConstantExtensionBaseTower C (RatFunc C) N S + apply Subtype.ext + rw [infinityPlaceUnder_asIdeal, + exactConstantExtensionDownstairsInfinityPlace_asIdeal] + let E := ExactConstantExtension C N S + let : Algebra C[X] E := + ratFuncExtensionReciprocalPolynomialAlgebra C E + let A₀ := integralClosure C[X] N + let B₀ := RatFuncInfinityIntegralClosure C N + let A := integralClosure C[X] E + let B := RatFuncInfinityIntegralClosure C E + let P := (exactConstantExtensionCReciprocalPrimesEquivActual + C S N hExact) + (exactConstantExtensionPresentedInfinityPlaceEquivCReciprocalPrimes + C S N q) + let a := exactConstantExtensionCReciprocalPolynomialAlgebra C S N + let b := ratFuncExtensionReciprocalPolynomialAlgebra C E + let h : a = b := + exactConstantExtensionCReciprocalPolynomialAlgebra_eq C S N hExact + let f₀ := exactConstantExtensionOldToCReciprocalNormalizationMap C S N + let g := integralClosureAlgHomOfAlgebraEq C[X] E A₀ a b h f₀ + let : Algebra A B := + ratFuncInfinityReciprocalIntegralClosureAlgebra C E + let : SMul A B := Algebra.toSMul + let : Algebra A₀ B₀ := + ratFuncInfinityReciprocalIntegralClosureAlgebra C N + let : SMul A₀ B₀ := Algebra.toSMul + let : Algebra A₀ A := + g.toAlgebra + let : SMul A₀ A := Algebra.toSMul + let : Algebra B₀ B := + (infinityIntegralClosureMap C N E).toAlgebra + let : SMul B₀ B := Algebra.toSMul + change (Ideal.map (algebraMap A B) P.1).under + B₀ = + Ideal.map + (algebraMap A₀ B₀) + (exactConstantExtensionInfinityDownstairsIdeal C S N q.1) + have hAffine : P.1.under A₀ = + exactConstantExtensionInfinityDownstairsIdeal C S N q.1 := by + let P₀ := + exactConstantExtensionPresentedInfinityPlaceEquivCReciprocalPrimes + C S N q + have hTransport : P.1.under A₀ = P₀.1.under A₀ := by + exact primesOverEquivOfAlgebraEq_under + C[X] E A₀ a b h + (Ideal.span ({Polynomial.X} : Set C[X])) f₀ P₀ + have hOld := + exactConstantExtensionPresentedInfinityPlaceEquivCReciprocalPrimes_under_old + C S N q + exact hTransport.trans hOld + let : Algebra A₀ B := + RingHom.toAlgebra + ((algebraMap B₀ B).comp (algebraMap A₀ B₀)) + let : SMul A₀ B := Algebra.toSMul + let : IsScalarTower A₀ B₀ B := + IsScalarTower.of_algebraMap_eq' rfl + let : IsScalarTower A₀ A B := + IsScalarTower.of_algebraMap_eq fun x => by + apply Subtype.ext + rfl + have hMax : + (Ideal.map (algebraMap A₀ B₀) (P.1.under A₀)).IsMaximal := by + rw [hAffine] + change (exactConstantExtensionDownstairsInfinityPlace + C S N q.1 q.2).1.IsMaximal + infer_instance + have hNe : Ideal.map (algebraMap A B) P.1 ≠ ⊤ := by + change (exactConstantExtensionPresentedInfinityPlaceEquiv + C S N hExact q).1 ≠ ⊤ + exact (exactConstantExtensionPresentedInfinityPlaceEquiv + C S N hExact q).2.1.ne_top + rw [Ideal.under_map_eq_map_under P.1 hMax hNe, hAffine] + +/-- The residue field of a presented reciprocal prime is the residue field of +the corresponding actual `C`-infinity place. -/ +noncomputable def exactConstantExtensionPresentedInfinityResidueFieldRingEquiv + (q : ExactConstantExtensionPresentedInfinityPlace C S N) : + letI : DecidableEq C := infinityBridgeDecidableEqConstants C + letI : DecidableEq (RatFunc C) := + infinityBridgeDecidableEqRatFuncConstants C + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + q.1.asIdeal.ResidueField ≃+* + (exactConstantExtensionPresentedInfinityPlaceEquiv + C S N hExact q).1.ResidueField := by + letI : DecidableEq C := infinityBridgeDecidableEqConstants C + letI : DecidableEq (RatFunc C) := + infinityBridgeDecidableEqRatFuncConstants C + let E := ExactConstantExtension C N S + letI : Field E := exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) E := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let e₀ := + exactConstantExtensionPresentedToCReciprocalNormalizationRingEquiv + C S N + let e₁ := exactConstantExtensionCReciprocalNormalizationRingEquiv + C S N hExact + let e := e₀.trans e₁ + let qA : IsDedekindDomain.HeightOneSpectrum + (@integralClosure C[X] E _ _ + (ratFuncExtensionReciprocalPolynomialAlgebra C E)) := + IsDedekindDomain.HeightOneSpectrum.equivOfRingEquiv e q.1 + let P := (exactConstantExtensionCReciprocalPrimesEquivActual + C S N hExact) + (exactConstantExtensionPresentedInfinityPlaceEquivCReciprocalPrimes + C S N q) + have hqA : qA.asIdeal = P.1 := by + rfl + let affineResidue : q.1.asIdeal.ResidueField ≃+* + qA.asIdeal.ResidueField := + heightOneResidueFieldRingEquiv e q.1 + letI : Algebra C[X] E := + ratFuncExtensionReciprocalPolynomialAlgebra C E + let A := integralClosure C[X] E + let idealResidue : qA.asIdeal.ResidueField ≃+* P.1.ResidueField := + Ideal.residueFieldRingEquiv qA.asIdeal P.1 (RingEquiv.refl A) + (by + change qA.asIdeal = P.1.comap (RingHom.id A) + rw [Ideal.comap_id, hqA]) + let affineResidue' : q.1.asIdeal.ResidueField ≃+* P.1.ResidueField := + affineResidue.trans idealResidue + let B := RatFuncInfinityIntegralClosure C E + let o := Ideal.span ({Polynomial.X} : Set C[X]) + letI : Algebra A B := + ratFuncInfinityReciprocalIntegralClosureAlgebra C E + letI : SMul A B := Algebra.toSMul + letI : IsLocalization + (Algebra.algebraMapSubmonoid A o.primeCompl) B := + ratFuncInfinityIntegralClosure_isLocalization_reciprocal C E + let M := Algebra.algebraMapSubmonoid A o.primeCompl + have hPUnder : P.1.under C[X] = o := P.2.2.over.symm + have hdisj : Disjoint (M : Set A) (P.1 : Set A) := + mappedPrimeCompl_disjoint_of_under_eq + C[X] A o P.1 hPUnder + let Q := Ideal.map (algebraMap A B) P.1 + letI : Q.IsPrime := + IsLocalization.isPrime_of_isPrime_disjoint M B P.1 P.2.1 hdisj + let localResidue : P.1.ResidueField ≃+* Q.ResidueField := + localizationResidueFieldRingEquiv A B M P.1 hdisj + change q.1.asIdeal.ResidueField ≃+* Q.ResidueField + exact affineResidue'.trans localResidue + +section InfinityRamification + + +private theorem infinitySplitting_eq_of_algebraMap_sub_mem_prime + (K R : Type*) [Field K] [CommRing R] [Algebra K R] + (P : Ideal R) [P.IsPrime] (a b : K) + (h : algebraMap K R a - algebraMap K R b ∈ P) : + a = b := by + by_contra hab + have hne : a - b ≠ 0 := sub_ne_zero.mpr hab + have hunit : IsUnit (algebraMap K R (a - b)) := + (isUnit_iff_ne_zero.mpr hne).map (algebraMap K R) + have hmem : algebraMap K R (a - b) ∈ P := by simpa using h + exact (inferInstance : P.IsPrime).ne_top + (P.eq_top_of_isUnit_mem hmem hunit) + +private theorem + infinitySplitting_constantQuotient_eq_one_imp_eq_one + (C N S : Type*) [Field C] [Field N] [Field S] + [Algebra C N] [Algebra C S] + [FiniteDimensional C S] [IsGalois C S] + (hExact : algebraicClosure C N = + (⊥ : IntermediateField C N)) + (g : letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra N (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C N N S + ExactConstantExtension C N S ≃ₐ[N] + ExactConstantExtension C N S) + (hg : letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra N (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C N N S + exactConstantExtensionConstantQuotient C N N S hExact g = 1) : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra N (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C N N S + g = 1 := by + let : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + let : Algebra N (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C N N S + have hker : g ∈ + (exactConstantExtensionConstantQuotient C N N S hExact).ker := + MonoidHom.mem_ker.mpr hg + rw [exactConstantExtensionConstantQuotient_ker C N N S hExact] at hker + obtain ⟨u, hu⟩ := hker + have huOne : u = 1 := Subsingleton.elim _ _ + calc + g = exactConstantExtensionFunctionAutHom C N N S u := hu.symm + _ = exactConstantExtensionFunctionAutHom C N N S 1 := + congrArg (exactConstantExtensionFunctionAutHom C N N S) huOne + _ = 1 := map_one (exactConstantExtensionFunctionAutHom C N N S) + +@[reducible] local instance infinitySplittingInfinityBaseRatFuncAlgebra : + Algebra (RatFuncInfinityIntegers C) (RatFunc C) := + RingHom.toAlgebra + (SubringClass.subtype ((RatFunc.inftyValuation C).integer)) + +local instance infinitySplittingInfinityBaseRatFuncSMul : + SMul (RatFuncInfinityIntegers C) (RatFunc C) := Algebra.toSMul + +local instance infinitySplittingInfinityBaseRatFuncModule : + Module (RatFuncInfinityIntegers C) (RatFunc C) := Algebra.toModule + +@[reducible] local instance infinitySplittingInfinityBaseNAlgebra : + Algebra (RatFuncInfinityIntegers C) N := + RingHom.toAlgebra + ((algebraMap (RatFunc C) N).comp + (algebraMap (RatFuncInfinityIntegers C) (RatFunc C))) + +local instance infinitySplittingInfinityBaseNSMul : + SMul (RatFuncInfinityIntegers C) N := Algebra.toSMul + +local instance infinitySplittingInfinityBaseNModule : + Module (RatFuncInfinityIntegers C) N := Algebra.toModule + +local instance infinitySplittingInfinityBaseNTower : + IsScalarTower (RatFuncInfinityIntegers C) (RatFunc C) N := + IsScalarTower.of_algebraMap_eq' rfl + +omit [Fintype C] [DecidableEq C] [DecidableEq S] [DecidableEq (RatFunc S)] + [Algebra.IsSeparable (RatFunc C) N] in +/-- Galois action on the infinity normalization restricts to the expected +constant-field quotient action. -/ +theorem exactConstantExtensionConstantQuotient_action_on_infinityNormalization : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + letI : SMul (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toSMul + letI : Module (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toModule + letI : Algebra N (ExactConstantExtension C N S) := + exactConstantExtensionAlgebra C N S + letI : SMul N (ExactConstantExtension C N S) := Algebra.toSMul + letI : Module N (ExactConstantExtension C N S) := Algebra.toModule + letI : IsScalarTower (RatFunc C) N + (ExactConstantExtension C N S) := + exactConstantExtensionBaseTower C (RatFunc C) N S + letI : IsGalois N (ExactConstantExtension C N S) := + exactConstantExtension_isGalois C N N S hExact + letI : Algebra (RatFuncInfinityIntegers C) + (ExactConstantExtension C N S) := + RingHom.toAlgebra + ((algebraMap (RatFunc C) (ExactConstantExtension C N S)).comp + (algebraMap (RatFuncInfinityIntegers C) (RatFunc C))) + letI : SMul (RatFuncInfinityIntegers C) + (ExactConstantExtension C N S) := Algebra.toSMul + letI : Module (RatFuncInfinityIntegers C) + (ExactConstantExtension C N S) := Algebra.toModule + letI : IsScalarTower (RatFuncInfinityIntegers C) (RatFunc C) + (ExactConstantExtension C N S) := + IsScalarTower.of_algebraMap_eq' rfl + letI : Algebra S (RatFuncInfinityIntegralClosure C + (ExactConstantExtension C N S)) := + exactConstantExtensionInfinityIntegralClosureConstantAlgebra + C S N hExact + letI : MulSemiringAction + (ExactConstantExtension C N S ≃ₐ[N] + ExactConstantExtension C N S) + (RatFuncInfinityIntegralClosure C + (ExactConstantExtension C N S)) := + infinityIntegralClosureGalAction C N (ExactConstantExtension C N S) + ∀ (g : ExactConstantExtension C N S ≃ₐ[N] + ExactConstantExtension C N S) (s : S), + g • algebraMap S (RatFuncInfinityIntegralClosure C + (ExactConstantExtension C N S)) s = + algebraMap S (RatFuncInfinityIntegralClosure C + (ExactConstantExtension C N S)) + (exactConstantExtensionConstantQuotient C N N S hExact g s) := by + let : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : SMul (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toSMul + let : Module (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toModule + let : Algebra N (ExactConstantExtension C N S) := + exactConstantExtensionAlgebra C N S + let : SMul N (ExactConstantExtension C N S) := Algebra.toSMul + let : Module N (ExactConstantExtension C N S) := Algebra.toModule + let : IsScalarTower (RatFunc C) N + (ExactConstantExtension C N S) := + exactConstantExtensionBaseTower C (RatFunc C) N S + let : IsGalois N (ExactConstantExtension C N S) := + exactConstantExtension_isGalois C N N S hExact + let : Algebra (RatFuncInfinityIntegers C) + (ExactConstantExtension C N S) := + RingHom.toAlgebra + ((algebraMap (RatFunc C) (ExactConstantExtension C N S)).comp + (algebraMap (RatFuncInfinityIntegers C) (RatFunc C))) + let : SMul (RatFuncInfinityIntegers C) + (ExactConstantExtension C N S) := Algebra.toSMul + let : Module (RatFuncInfinityIntegers C) + (ExactConstantExtension C N S) := Algebra.toModule + let : IsScalarTower (RatFuncInfinityIntegers C) (RatFunc C) + (ExactConstantExtension C N S) := + IsScalarTower.of_algebraMap_eq' rfl + let : Algebra S (RatFuncInfinityIntegralClosure C + (ExactConstantExtension C N S)) := + exactConstantExtensionInfinityIntegralClosureConstantAlgebra + C S N hExact + let : MulSemiringAction + (ExactConstantExtension C N S ≃ₐ[N] + ExactConstantExtension C N S) + (RatFuncInfinityIntegralClosure C + (ExactConstantExtension C N S)) := + infinityIntegralClosureGalAction C N (ExactConstantExtension C N S) + intro g s + apply Subtype.ext + calc + ((g • algebraMap S (RatFuncInfinityIntegralClosure C + (ExactConstantExtension C N S)) s : + RatFuncInfinityIntegralClosure C + (ExactConstantExtension C N S)) : + ExactConstantExtension C N S) = + g ((algebraMap S (RatFuncInfinityIntegralClosure C + (ExactConstantExtension C N S)) s : + RatFuncInfinityIntegralClosure C + (ExactConstantExtension C N S)) : + ExactConstantExtension C N S) := by + exact algebraMap.smul' + (B := RatFuncInfinityIntegralClosure C + (ExactConstantExtension C N S)) + g + (algebraMap S (RatFuncInfinityIntegralClosure C + (ExactConstantExtension C N S)) s) + (ExactConstantExtension C N S) + _ = (Algebra.TensorProduct.includeLeft + (R := C) (S := C) (A := S) (B := N)) + (exactConstantExtensionConstantQuotient C N N S hExact g s) := by + change g ((Algebra.TensorProduct.includeLeft + (R := C) (S := C) (A := S) (B := N)) s) = _ + exact exactConstantExtensionConstantQuotient_action_on_constants + C N N S hExact g s + _ = ((algebraMap S (RatFuncInfinityIntegralClosure C + (ExactConstantExtension C N S)) + (exactConstantExtensionConstantQuotient C N N S hExact g s) : + RatFuncInfinityIntegralClosure C + (ExactConstantExtension C N S)) : + ExactConstantExtension C N S) := rfl + +omit [DecidableEq C] [DecidableEq S] [DecidableEq (RatFunc S)] in +/-- Every infinity place is unramified in an exact extension of constants. -/ +theorem exactConstantExtensionInfinityPlace_ramificationIdx_eq_one + (Q : letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + FiniteExtensionInfinityPlace C (ExactConstantExtension C N S)) : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + letI : SMul (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toSMul + letI : Module (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toModule + letI : Algebra N (ExactConstantExtension C N S) := + exactConstantExtensionAlgebra C N S + letI : SMul N (ExactConstantExtension C N S) := Algebra.toSMul + letI : Module N (ExactConstantExtension C N S) := Algebra.toModule + letI : IsScalarTower (RatFunc C) N + (ExactConstantExtension C N S) := + exactConstantExtensionBaseTower C (RatFunc C) N S + infinityPlaceRelativeRamificationIdx C N + (ExactConstantExtension C N S) Q = 1 := by + let : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : SMul (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toSMul + let : Module (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toModule + let : FiniteDimensional (RatFunc C) + (ExactConstantExtension C N S) := + finiteDimensional_exactConstantExtension_over_baseRatFunc C S N hExact + let : Algebra.IsSeparable (RatFunc C) + (ExactConstantExtension C N S) := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + let : Algebra N (ExactConstantExtension C N S) := + exactConstantExtensionAlgebra C N S + let : SMul N (ExactConstantExtension C N S) := Algebra.toSMul + let : Module N (ExactConstantExtension C N S) := Algebra.toModule + let : IsScalarTower (RatFunc C) N + (ExactConstantExtension C N S) := + exactConstantExtensionBaseTower C (RatFunc C) N S + let : IsGalois N (ExactConstantExtension C N S) := + exactConstantExtension_isGalois C N N S hExact + let : Algebra (RatFuncInfinityIntegers C) + (ExactConstantExtension C N S) := + RingHom.toAlgebra + ((algebraMap (RatFunc C) (ExactConstantExtension C N S)).comp + (algebraMap (RatFuncInfinityIntegers C) (RatFunc C))) + let : SMul (RatFuncInfinityIntegers C) + (ExactConstantExtension C N S) := Algebra.toSMul + let : Module (RatFuncInfinityIntegers C) + (ExactConstantExtension C N S) := Algebra.toModule + let : IsScalarTower (RatFuncInfinityIntegers C) (RatFunc C) + (ExactConstantExtension C N S) := + IsScalarTower.of_algebraMap_eq' rfl + let : Algebra S (RatFuncInfinityIntegralClosure C + (ExactConstantExtension C N S)) := + exactConstantExtensionInfinityIntegralClosureConstantAlgebra + C S N hExact + let : MulSemiringAction + (ExactConstantExtension C N S ≃ₐ[N] + ExactConstantExtension C N S) + (RatFuncInfinityIntegralClosure C + (ExactConstantExtension C N S)) := + infinityIntegralClosureGalAction C N (ExactConstantExtension C N S) + rw [← infinityPlaceInertiaGroup_card_eq_ramificationIdx C N + (ExactConstantExtension C N S) Q] + have hsubsingleton : + Subsingleton (infinityPlaceInertiaGroup C N + (ExactConstantExtension C N S) Q) := by + constructor + intro g h + apply Subtype.ext + have inertiaElement_eq_one + (u : infinityPlaceInertiaGroup C N + (ExactConstantExtension C N S) Q) : u.1 = 1 := by + have hquot : exactConstantExtensionConstantQuotient + C N N S hExact u.1 = 1 := by + apply AlgEquiv.ext + intro s + have hinertia := AddSubgroup.mem_inertia.mp u.2 + (algebraMap S (RatFuncInfinityIntegralClosure C + (ExactConstantExtension C N S)) s) + rw [exactConstantExtensionConstantQuotient_action_on_infinityNormalization + C S N hExact] at hinertia + let : Q.1.IsPrime := Q.2.1 + exact infinitySplitting_eq_of_algebraMap_sub_mem_prime S + (RatFuncInfinityIntegralClosure C + (ExactConstantExtension C N S)) Q.1 _ _ hinertia + exact infinitySplitting_constantQuotient_eq_one_imp_eq_one + C N S hExact u.1 hquot + have hgOne := inertiaElement_eq_one g + have hhOne := inertiaElement_eq_one h + exact hgOne.trans hhOne.symm + let := hsubsingleton + exact Nat.card_unique + +end InfinityRamification + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/ConstantExtensionPlaceSplittingMultiplicity.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/ConstantExtensionPlaceSplittingMultiplicity.lean new file mode 100644 index 0000000000..4aaf6064b7 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/ConstantExtensionPlaceSplittingMultiplicity.lean @@ -0,0 +1,674 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.ConstantExtensionClosedPlaceCount +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionFinitePlaceCompatibility + +/-! +# Splitting multiplicity in an exact extension of constants + +This file proves the finite-place multiplicity in the standard splitting law +for an exact extension of constants. The proof does not assume the splitting +law: it proves that inertia is trivial by restricting an inertia element to +the embedded enlarged constant field, computes the relative residue degree +from the already established absolute degree formula, and applies the Galois +fiber identity. +-/ + +@[expose] public section + +open scoped Polynomial TensorProduct + +namespace BGS.HasseWeil + +noncomputable section + +open BGS.CorvajaZannier + + +/-- A prime ideal in an algebra over a field cannot identify two distinct +elements of that field. -/ +private theorem eq_of_algebraMap_sub_mem_prime + (K R : Type*) [Field K] [CommRing R] [Algebra K R] + (P : Ideal R) [P.IsPrime] (a b : K) + (h : algebraMap K R a - algebraMap K R b ∈ P) : + a = b := by + by_contra hab + have hne : a - b ≠ 0 := sub_ne_zero.mpr hab + have hunit : IsUnit (algebraMap K R (a - b)) := + (isUnit_iff_ne_zero.mpr hne).map (algebraMap K R) + have hmem : algebraMap K R (a - b) ∈ P := by + simpa using h + exact (inferInstance : P.IsPrime).ne_top + (P.eq_top_of_isUnit_mem hmem hunit) + +/-- If the intermediate field is the original function field itself, the +constant quotient is faithful. This is the exactness input used to kill +inertia. -/ +private theorem exactConstantExtensionConstantQuotient_eq_one_imp_eq_one + (C N S : Type*) [Field C] [Field N] [Field S] + [Algebra C N] [Algebra C S] + [FiniteDimensional C S] [IsGalois C S] + (hExact : algebraicClosure C N = + (⊥ : IntermediateField C N)) + (g : letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra N (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C N N S + ExactConstantExtension C N S ≃ₐ[N] + ExactConstantExtension C N S) + (hg : letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra N (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C N N S + exactConstantExtensionConstantQuotient C N N S hExact g = 1) : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra N (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C N N S + g = 1 := by + let : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + let : Algebra N (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C N N S + have hker : g ∈ + (exactConstantExtensionConstantQuotient C N N S hExact).ker := + MonoidHom.mem_ker.mpr hg + rw [exactConstantExtensionConstantQuotient_ker C N N S hExact] at hker + obtain ⟨u, hu⟩ := hker + have huOne : u = 1 := Subsingleton.elim _ _ + calc + g = exactConstantExtensionFunctionAutHom C N N S u := hu.symm + _ = exactConstantExtensionFunctionAutHom C N N S 1 := + congrArg (exactConstantExtensionFunctionAutHom C N N S) huOne + _ = 1 := map_one (exactConstantExtensionFunctionAutHom C N N S) + +/-- Arithmetic cancellation used to recover the relative residue degree from +the two absolute degree formulas. -/ +private theorem eq_div_gcd_of_mul_eq_mul_div_gcd + (r d f : ℕ) (hd : 0 < d) + (h : d * f = r * (d / Nat.gcd r d)) : + f = r / Nat.gcd r d := by + apply Nat.eq_of_mul_eq_mul_left hd + calc + d * f = r * (d / Nat.gcd r d) := h + _ = (Nat.gcd r d * (r / Nat.gcd r d)) * + (d / Nat.gcd r d) := by + rw [Nat.mul_div_cancel' (Nat.gcd_dvd_left r d)] + _ = (Nat.gcd r d * (d / Nat.gcd r d)) * + (r / Nat.gcd r d) := by ac_rfl + _ = d * (r / Nat.gcd r d) := by + rw [Nat.mul_div_cancel' (Nat.gcd_dvd_right r d)] + +/-- Cancelling the nonzero complementary factor in the gcd decomposition of +`r`. -/ +private theorem eq_gcd_of_mul_div_gcd_eq + (r d a : ℕ) (hr : 0 < r) + (h : a * (r / Nat.gcd r d) = r) : + a = Nat.gcd r d := by + have hquot : 0 < r / Nat.gcd r d := + Nat.div_pos + (Nat.le_of_dvd hr (Nat.gcd_dvd_left r d)) + (Nat.gcd_pos_of_pos_left d hr) + apply Nat.eq_of_mul_eq_mul_right hquot + calc + a * (r / Nat.gcd r d) = r := h + _ = Nat.gcd r d * (r / Nat.gcd r d) := + (Nat.mul_div_cancel' (Nat.gcd_dvd_left r d)).symm + +variable (C S N : Type*) [Field C] [Field S] [Field N] + [Fintype C] [Finite S] + [DecidableEq C] [DecidableEq S] + [DecidableEq (RatFunc C)] [DecidableEq (RatFunc S)] + [Algebra (RatFunc C) N] [FiniteDimensional (RatFunc C) N] + [Algebra.IsSeparable (RatFunc C) N] + [Algebra C S] [FiniteDimensional C S] [IsGalois C S] + +local instance splittingBaseConstantAlgebra : Algebra C N := + bridgeBaseConstantAlgebra C N + +local instance splittingBaseConstantTower : + IsScalarTower C (RatFunc C) N := + IsScalarTower.of_algebraMap_eq' rfl + +local instance splittingBasePolynomialAlgebra : Algebra C[X] N := + bridgeBasePolynomialAlgebra C N + +local instance splittingTargetPolynomialAlgebra : + Algebra S[X] (ExactConstantExtension C N S) := + bridgeTargetPolynomialAlgebra C S N + +variable (hExact : algebraicClosure C N = + (⊥ : IntermediateField C N)) + +omit [Finite S] [DecidableEq C] [DecidableEq S] [DecidableEq (RatFunc C)] + [DecidableEq (RatFunc S)] in +/-- Every finite place is unramified in an exact extension of constants. -/ +theorem exactConstantExtensionFinitePlace_ramificationIdx_eq_one + (Q : letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + FiniteExtensionFinitePlace C (ExactConstantExtension C N S)) : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + letI : SMul (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toSMul + letI : Module (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toModule + letI : Algebra N (ExactConstantExtension C N S) := + exactConstantExtensionAlgebra C N S + letI : SMul N (ExactConstantExtension C N S) := + Algebra.toSMul + letI : Module N (ExactConstantExtension C N S) := + Algebra.toModule + letI : IsScalarTower (RatFunc C) N + (ExactConstantExtension C N S) := + exactConstantExtensionBaseTower C (RatFunc C) N S + finitePlaceRelativeRamificationIdx C N + (ExactConstantExtension C N S) Q = 1 := by + let : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : SMul (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toSMul + let : Module (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toModule + let : FiniteDimensional (RatFunc C) + (ExactConstantExtension C N S) := + finiteDimensional_exactConstantExtension_over_baseRatFunc + C S N hExact + let : Algebra.IsSeparable (RatFunc C) + (ExactConstantExtension C N S) := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + let : Algebra N (ExactConstantExtension C N S) := + exactConstantExtensionAlgebra C N S + let : SMul N (ExactConstantExtension C N S) := + Algebra.toSMul + let : Module N (ExactConstantExtension C N S) := + Algebra.toModule + let : IsScalarTower (RatFunc C) N + (ExactConstantExtension C N S) := + exactConstantExtensionBaseTower C (RatFunc C) N S + let : IsGalois N (ExactConstantExtension C N S) := + exactConstantExtension_isGalois C N N S hExact + let : Algebra S (RatFuncFiniteIntegralClosure C + (ExactConstantExtension C N S)) := + exactConstantExtensionFiniteIntegralClosureConstantAlgebra + C N S hExact + let : MulSemiringAction + (ExactConstantExtension C N S ≃ₐ[N] + ExactConstantExtension C N S) + (RatFuncFiniteIntegralClosure C + (ExactConstantExtension C N S)) := + finiteIntegralClosureGalAction C N + (ExactConstantExtension C N S) + rw [← finitePlaceInertiaGroup_card_eq_ramificationIdx C N + (ExactConstantExtension C N S) Q] + have hsubsingleton : + Subsingleton (finitePlaceInertiaGroup C N + (ExactConstantExtension C N S) Q) := by + constructor + intro g h + apply Subtype.ext + have inertiaElement_eq_one + (u : finitePlaceInertiaGroup C N + (ExactConstantExtension C N S) Q) : u.1 = 1 := by + have hquot : exactConstantExtensionConstantQuotient + C N N S hExact u.1 = 1 := by + apply AlgEquiv.ext + intro s + have hinertia := + AddSubgroup.mem_inertia.mp u.2 + (algebraMap S (RatFuncFiniteIntegralClosure C + (ExactConstantExtension C N S)) s) + rw [exactConstantExtensionConstantQuotient_action_on_finiteNormalization + C N S hExact N] at hinertia + exact eq_of_algebraMap_sub_mem_prime S + (RatFuncFiniteIntegralClosure C + (ExactConstantExtension C N S)) Q.asIdeal _ _ hinertia + exact exactConstantExtensionConstantQuotient_eq_one_imp_eq_one + C N S hExact u.1 hquot + have hgOne := inertiaElement_eq_one g + have hhOne := inertiaElement_eq_one h + exact hgOne.trans hhOne.symm + let := hsubsingleton + exact Nat.card_unique + +/-- A downstairs finite place of degree `d` has exactly +`gcd([S : C], d)` finite places above it in the exact extension of constants. + +The chosen explicit normalization prime supplies one point of the fiber; the +cardinality is that of the entire actual restriction fiber, not merely a +cardinality of a selected presentation. -/ +theorem exactConstantExtensionFinitePlace_fiber_card_eq_gcd + (q : IsDedekindDomain.HeightOneSpectrum + (integralClosure S[X] (ExactConstantExtension C N S))) : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + letI : SMul (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toSMul + letI : Module (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toModule + letI : FiniteDimensional (RatFunc C) + (ExactConstantExtension C N S) := + finiteDimensional_exactConstantExtension_over_baseRatFunc + C S N hExact + letI : Algebra.IsSeparable (RatFunc C) + (ExactConstantExtension C N S) := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + letI : Algebra (RatFunc S) (ExactConstantExtension C N S) := + ratFuncExactConstantExtensionAlgebra C S N hExact + letI : SMul (RatFunc S) (ExactConstantExtension C N S) := + Algebra.toSMul + letI : Module (RatFunc S) (ExactConstantExtension C N S) := + Algebra.toModule + letI : FiniteDimensional (RatFunc S) + (ExactConstantExtension C N S) := + finiteDimensional_over_extendedRatFunc C S N hExact + letI : Algebra.IsSeparable (RatFunc S) + (ExactConstantExtension C N S) := + isSeparable_over_extendedRatFunc C S N hExact + letI : Algebra N (ExactConstantExtension C N S) := + exactConstantExtensionAlgebra C N S + letI : SMul N (ExactConstantExtension C N S) := + Algebra.toSMul + letI : Module N (ExactConstantExtension C N S) := + Algebra.toModule + letI : IsScalarTower (RatFunc C) N + (ExactConstantExtension C N S) := + exactConstantExtensionBaseTower C (RatFunc C) N S + letI : IsGalois N (ExactConstantExtension C N S) := + exactConstantExtension_isGalois C N N S hExact + Fintype.card (FinitePlaceUnderFiber C N + (ExactConstantExtension C N S) + (exactConstantExtensionDownstairsFinitePlace + C S N hExact q)) = + Nat.gcd (Module.finrank C S) + (finiteExtensionPlaceDegree C N + (.inl (exactConstantExtensionDownstairsFinitePlace + C S N hExact q))) := by + let : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : SMul (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toSMul + let : Module (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toModule + let : FiniteDimensional (RatFunc C) + (ExactConstantExtension C N S) := + finiteDimensional_exactConstantExtension_over_baseRatFunc + C S N hExact + let : Algebra.IsSeparable (RatFunc C) + (ExactConstantExtension C N S) := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + let : Algebra (RatFunc S) (ExactConstantExtension C N S) := + ratFuncExactConstantExtensionAlgebra C S N hExact + let : SMul (RatFunc S) (ExactConstantExtension C N S) := + Algebra.toSMul + let : Module (RatFunc S) (ExactConstantExtension C N S) := + Algebra.toModule + let : FiniteDimensional (RatFunc S) + (ExactConstantExtension C N S) := + finiteDimensional_over_extendedRatFunc C S N hExact + let : Algebra.IsSeparable (RatFunc S) + (ExactConstantExtension C N S) := + isSeparable_over_extendedRatFunc C S N hExact + let : Algebra N (ExactConstantExtension C N S) := + exactConstantExtensionAlgebra C N S + let : SMul N (ExactConstantExtension C N S) := + Algebra.toSMul + let : Module N (ExactConstantExtension C N S) := + Algebra.toModule + let : IsScalarTower (RatFunc C) N + (ExactConstantExtension C N S) := + exactConstantExtensionBaseTower C (RatFunc C) N S + let : IsGalois N (ExactConstantExtension C N S) := + exactConstantExtension_isGalois C N N S hExact + let P := exactConstantExtensionDownstairsFinitePlace C S N hExact q + let Q := exactConstantExtensionCompatibleBaseFinitePlace C S N hExact q + let Qs := exactConstantExtensionUpstairsFinitePlace C S N hExact q + let r := Module.finrank C S + let d := finiteExtensionPlaceDegree C N (.inl P) + have hUnder : finitePlaceUnder C N + (ExactConstantExtension C N S) Q = P := + exactConstantExtensionCompatibleBaseFinitePlace_under_original + C S N hExact q + have hBase := finiteExtensionFinitePlace_degree_baseChange + C S (ExactConstantExtension C N S) + (exactConstantExtension_ratFunc_polynomialCompatibility + C S N hExact) Q + rw [exactConstantExtensionCompatibleBaseFinitePlace_baseChange] + at hBase + have hUpstairs : finiteExtensionPlaceDegree S + (ExactConstantExtension C N S) (.inl Qs) = + d / Nat.gcd r d := by + exact exactConstantExtensionFinitePlace_degree_eq_div_gcd + C S N hExact q + have hTop : finiteExtensionPlaceDegree C + (ExactConstantExtension C N S) (.inl Q) = + r * (d / Nat.gcd r d) := by + exact hBase.trans (congrArg (fun n => r * n) hUpstairs) + have hTower := finiteExtensionPlaceDegree_inl_eq_mul_relativeInertiaDeg + C N (ExactConstantExtension C N S) Q + rw [hUnder] at hTower + have hd : 0 < d := finiteExtensionPlaceDegree_pos C N (.inl P) + have hInertia : finitePlaceRelativeInertiaDeg C N + (ExactConstantExtension C N S) Q = r / Nat.gcd r d := + eq_div_gcd_of_mul_eq_mul_div_gcd r d _ hd + (hTower.symm.trans hTop) + let Q0 : FinitePlaceUnderFiber C N + (ExactConstantExtension C N S) P := ⟨Q, hUnder⟩ + have hFund := + finitePlaceUnderFiber_card_mul_ramificationIdx_mul_inertiaDeg_eq_field_finrank + C N (ExactConstantExtension C N S) P Q0 + have hRam : finitePlaceRelativeRamificationIdx C N + (ExactConstantExtension C N S) Q = 1 := + exactConstantExtensionFinitePlace_ramificationIdx_eq_one + C S N hExact Q + rw [exactConstantExtension_finrank C N S] at hFund + have hCount : Fintype.card (FinitePlaceUnderFiber C N + (ExactConstantExtension C N S) P) * (r / Nat.gcd r d) = r := by + simpa [Q0, hRam, hInertia, r] using hFund + exact eq_gcd_of_mul_div_gcd_eq r d _ Module.finrank_pos hCount + +/-- The explicit `S[X]`-normalization presentation exhausts the actual finite +places of the constant extension, viewed over the original constant field +`C`. -/ +noncomputable def exactConstantExtensionPresentedFinitePlaceEquiv : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + letI : Algebra (RatFunc S) (ExactConstantExtension C N S) := + ratFuncExactConstantExtensionAlgebra C S N hExact + IsDedekindDomain.HeightOneSpectrum + (integralClosure S[X] (ExactConstantExtension C N S)) ≃ + FiniteExtensionFinitePlace C (ExactConstantExtension C N S) := by + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + letI : Algebra (RatFunc S) (ExactConstantExtension C N S) := + ratFuncExactConstantExtensionAlgebra C S N hExact + letI : Algebra C (integralClosure C[X] N) := + RingHom.toAlgebra + ((algebraMap C[X] (integralClosure C[X] N)).comp + (algebraMap C C[X])) + letI : IsScalarTower C C[X] (integralClosure C[X] N) := + IsScalarTower.of_algebraMap_eq' rfl + letI : Algebra S[X] (S ⊗[C] integralClosure C[X] N) := + bridgeTensorNormalizationPolynomialAlgebra C S N + letI : Algebra S (integralClosure S[X] + (ExactConstantExtension C N S)) := + RingHom.toAlgebra + ((algebraMap S[X] (integralClosure S[X] + (ExactConstantExtension C N S))).comp (algebraMap S S[X])) + let first := heightOneSpectrumEquivOfAlgEquiv + (finiteFieldConstantExtensionIntegralClosureAlgEquiv C S N).symm + let second := finiteExtensionFinitePlaceEquivOfNormalizationAlgEquiv + S (ExactConstantExtension C N S) + (S ⊗[C] integralClosure C[X] N) + (exactConstantExtensionNormalizationAlgEquiv C S N hExact) + let third := (IsDedekindDomain.HeightOneSpectrum.equivOfRingEquiv + (ratFuncFiniteIntegralClosureRingEquiv C S + (ExactConstantExtension C N S) + (exactConstantExtension_ratFunc_polynomialCompatibility + C S N hExact))).symm + exact first.trans (second.trans third) + +omit [DecidableEq C] [DecidableEq S] [DecidableEq (RatFunc C)] [DecidableEq (RatFunc S)] + [FiniteDimensional (RatFunc C) N] [Algebra.IsSeparable (RatFunc C) N] in +@[simp] +theorem exactConstantExtensionPresentedFinitePlaceEquiv_apply + (q : IsDedekindDomain.HeightOneSpectrum + (integralClosure S[X] (ExactConstantExtension C N S))) : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + letI : Algebra (RatFunc S) (ExactConstantExtension C N S) := + ratFuncExactConstantExtensionAlgebra C S N hExact + exactConstantExtensionPresentedFinitePlaceEquiv C S N hExact q = + exactConstantExtensionCompatibleBaseFinitePlace C S N hExact q := by + rfl + +/-- Restricting the global presentation equivalence to a fixed downstairs +place identifies the presented contraction fiber with the entire actual +place-restriction fiber. -/ +noncomputable def exactConstantExtensionPresentedFinitePlaceFiberEquiv + (P : FiniteExtensionFinitePlace C N) : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + letI : SMul (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toSMul + letI : Module (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toModule + letI : FiniteDimensional (RatFunc C) + (ExactConstantExtension C N S) := + finiteDimensional_exactConstantExtension_over_baseRatFunc + C S N hExact + letI : Algebra.IsSeparable (RatFunc C) + (ExactConstantExtension C N S) := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + letI : Algebra (RatFunc S) (ExactConstantExtension C N S) := + ratFuncExactConstantExtensionAlgebra C S N hExact + letI : Algebra N (ExactConstantExtension C N S) := + exactConstantExtensionAlgebra C N S + letI : SMul N (ExactConstantExtension C N S) := + Algebra.toSMul + letI : Module N (ExactConstantExtension C N S) := + Algebra.toModule + letI : IsScalarTower (RatFunc C) N + (ExactConstantExtension C N S) := + exactConstantExtensionBaseTower C (RatFunc C) N S + {q : IsDedekindDomain.HeightOneSpectrum + (integralClosure S[X] (ExactConstantExtension C N S)) // + exactConstantExtensionDownstairsFinitePlace + C S N hExact q = P} ≃ + FinitePlaceUnderFiber C N (ExactConstantExtension C N S) P := by + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + letI : SMul (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toSMul + letI : Module (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toModule + letI : FiniteDimensional (RatFunc C) + (ExactConstantExtension C N S) := + finiteDimensional_exactConstantExtension_over_baseRatFunc + C S N hExact + letI : Algebra.IsSeparable (RatFunc C) + (ExactConstantExtension C N S) := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + letI : Algebra (RatFunc S) (ExactConstantExtension C N S) := + ratFuncExactConstantExtensionAlgebra C S N hExact + letI : Algebra N (ExactConstantExtension C N S) := + exactConstantExtensionAlgebra C N S + letI : SMul N (ExactConstantExtension C N S) := + Algebra.toSMul + letI : Module N (ExactConstantExtension C N S) := + Algebra.toModule + letI : IsScalarTower (RatFunc C) N + (ExactConstantExtension C N S) := + exactConstantExtensionBaseTower C (RatFunc C) N S + let e := exactConstantExtensionPresentedFinitePlaceEquiv + C S N hExact + exact + { toFun := fun q => + ⟨e q.1, by + rw [exactConstantExtensionPresentedFinitePlaceEquiv_apply] + exact (exactConstantExtensionCompatibleBaseFinitePlace_under_original + C S N hExact q.1).trans q.2⟩ + invFun := fun Q => + ⟨e.symm Q.1, by + have hUnder := + exactConstantExtensionCompatibleBaseFinitePlace_under_original + C S N hExact (e.symm Q.1) + have he : exactConstantExtensionCompatibleBaseFinitePlace + C S N hExact (e.symm Q.1) = Q.1 := by + calc + _ = e (e.symm Q.1) := + (exactConstantExtensionPresentedFinitePlaceEquiv_apply + C S N hExact (e.symm Q.1)).symm + _ = Q.1 := e.apply_symm_apply Q.1 + rw [he] at hUnder + exact hUnder.symm.trans Q.2⟩ + left_inv := fun q => by + apply Subtype.ext + exact e.symm_apply_apply q.1 + right_inv := fun Q => by + apply Subtype.ext + exact e.apply_symm_apply Q.1 } + +/-- The presented finite contraction fiber itself has the standard gcd +cardinality. This is the presentation-level exhaustiveness form of the +constant-extension splitting law. -/ +theorem exactConstantExtensionPresentedFinitePlaceFiber_natCard_eq_gcd + (q : IsDedekindDomain.HeightOneSpectrum + (integralClosure S[X] (ExactConstantExtension C N S))) : + Nat.card {q' : IsDedekindDomain.HeightOneSpectrum + (integralClosure S[X] (ExactConstantExtension C N S)) // + exactConstantExtensionDownstairsFinitePlace C S N hExact q' = + exactConstantExtensionDownstairsFinitePlace C S N hExact q} = + Nat.gcd (Module.finrank C S) + (finiteExtensionPlaceDegree C N + (.inl (exactConstantExtensionDownstairsFinitePlace + C S N hExact q))) := by + let : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : SMul (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toSMul + let : Module (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toModule + let : FiniteDimensional (RatFunc C) + (ExactConstantExtension C N S) := + finiteDimensional_exactConstantExtension_over_baseRatFunc + C S N hExact + let : Algebra.IsSeparable (RatFunc C) + (ExactConstantExtension C N S) := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + let : Algebra (RatFunc S) (ExactConstantExtension C N S) := + ratFuncExactConstantExtensionAlgebra C S N hExact + let : Algebra N (ExactConstantExtension C N S) := + exactConstantExtensionAlgebra C N S + let : SMul N (ExactConstantExtension C N S) := + Algebra.toSMul + let : Module N (ExactConstantExtension C N S) := + Algebra.toModule + let : IsScalarTower (RatFunc C) N + (ExactConstantExtension C N S) := + exactConstantExtensionBaseTower C (RatFunc C) N S + let P := exactConstantExtensionDownstairsFinitePlace C S N hExact q + calc + Nat.card {q' : IsDedekindDomain.HeightOneSpectrum + (integralClosure S[X] (ExactConstantExtension C N S)) // + exactConstantExtensionDownstairsFinitePlace C S N hExact q' = P} = + Nat.card (FinitePlaceUnderFiber C N + (ExactConstantExtension C N S) P) := + Nat.card_congr + (exactConstantExtensionPresentedFinitePlaceFiberEquiv + C S N hExact P) + _ = Fintype.card (FinitePlaceUnderFiber C N + (ExactConstantExtension C N S) P) := + Nat.card_eq_fintype_card + _ = Nat.gcd (Module.finrank C S) + (finiteExtensionPlaceDegree C N (.inl P)) := + exactConstantExtensionFinitePlace_fiber_card_eq_gcd + C S N hExact q + +section InfinityConstantEmbedding + +local instance splittingInfinityBaseConstantAlgebra : + Algebra C (RatFuncInfinityIntegers C) := + (ratFuncInfinityConstantRingHom C).toAlgebra + +local instance splittingInfinityBaseRatFuncAlgebra : + Algebra (RatFuncInfinityIntegers C) (RatFunc C) := + RingHom.toAlgebra + (SubringClass.subtype ((RatFunc.inftyValuation C).integer)) + +local instance splittingInfinityExactBaseAlgebra : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + Algebra (RatFuncInfinityIntegers C) + (ExactConstantExtension C N S) := by + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + exact RingHom.toAlgebra + ((algebraMap (RatFunc C) (ExactConstantExtension C N S)).comp + (algebraMap (RatFuncInfinityIntegers C) (RatFunc C))) + +/-- The enlarged constants map into the infinity normalization over the +original constant field. -/ +noncomputable def exactConstantExtensionConstantToInfinityIntegralClosureRingHom : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + S →+* RatFuncInfinityIntegralClosure C + (ExactConstantExtension C N S) := by + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + letI : Fintype S := Fintype.ofFinite S + let f : S →ₐ[C] ExactConstantExtension C N S := + Algebra.TensorProduct.includeLeft + exact + { toFun := fun s => + ⟨f s, by + refine ⟨Polynomial.X ^ Nat.card S - Polynomial.X, ?_, ?_⟩ + · apply Polynomial.monic_X_pow_sub + rw [Polynomial.degree_X] + exact_mod_cast + (lt_of_lt_of_le Nat.one_lt_two + (Finite.one_lt_card : 2 ≤ Nat.card S)) + · simp only [Polynomial.eval₂_sub, Polynomial.eval₂_pow, + Polynomial.eval₂_X] + change (f s) ^ Nat.card S - f s = 0 + rw [← map_pow, Nat.card_eq_fintype_card, + FiniteField.pow_card s, sub_self]⟩ + map_one' := by ext; exact map_one f + map_mul' := fun x y => by ext; exact map_mul f x y + map_zero' := by ext; exact map_zero f + map_add' := fun x y => by ext; exact map_add f x y } + +/-- The enlarged-constant algebra structure on the infinity normalization. -/ +@[reducible] noncomputable def + exactConstantExtensionInfinityIntegralClosureConstantAlgebra : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + Algebra S (RatFuncInfinityIntegralClosure C + (ExactConstantExtension C N S)) := + RingHom.toAlgebra + (exactConstantExtensionConstantToInfinityIntegralClosureRingHom + C S N hExact) + +end InfinityConstantEmbedding + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/ConstantExtensionRationalPlace.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/ConstantExtensionRationalPlace.lean new file mode 100644 index 0000000000..843df5443d --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/ConstantExtensionRationalPlace.lean @@ -0,0 +1,129 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.ConstantExtensionFinitePlaceBridge + +/-! +# Rational finite places after exact constant extension + +For a finite Galois function-field extension, the degree of a place above a +rational base place divides the relative field degree. Combining this fact +with the constant-extension degree formula shows that an extension of +constants whose degree is divisible by the Galois degree makes every such +lifted place rational. + +This is the numerical-to-geometric bridge used when Stichtenoth chooses the +constant-extension degree to be divisible by the Galois-group order. +-/ + +@[expose] public section + +open scoped Polynomial + +namespace BGS.HasseWeil + +noncomputable section + +open BGS.CorvajaZannier + +variable (K : Type*) [Field K] [DecidableEq K] [DecidableEq (RatFunc K)] +variable (M : Type*) [Field M] [Algebra (RatFunc K) M] + [FiniteDimensional (RatFunc K) M] + [Algebra.IsSeparable (RatFunc K) M] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + [Algebra M L] [IsScalarTower (RatFunc K) M L] [IsGalois M L] + +/-- In a finite Galois tower, a finite place over a degree-one intermediate +place has degree dividing the relative field degree. -/ +theorem finiteExtensionFinitePlace_degree_dvd_relative_finrank_of_under_degree_one + (Q : FiniteExtensionFinitePlace K L) + (hUnder : finiteExtensionPlaceDegree K M + (.inl (finitePlaceUnder K M L Q)) = 1) : + finiteExtensionPlaceDegree K L (.inl Q) ∣ Module.finrank M L := by + let P := finitePlaceUnder K M L Q + let Q₀ : FinitePlaceUnderFiber K M L P := ⟨Q, rfl⟩ + have hfiber := + finitePlaceUnderFiber_card_mul_ramificationIdx_mul_inertiaDeg_eq_field_finrank + K M L P Q₀ + have hdegree := + finiteExtensionPlaceDegree_inl_eq_mul_relativeInertiaDeg K M L Q + rw [hUnder, one_mul] at hdegree + rw [hdegree, ← hfiber] + exact dvd_mul_left _ _ + +section ExactConstantExtension + +variable (C S N : Type*) [Field C] [Field S] [Field N] + [Fintype C] [Finite S] + [DecidableEq C] [DecidableEq S] + [DecidableEq (RatFunc C)] [DecidableEq (RatFunc S)] + [Algebra (RatFunc C) N] [FiniteDimensional (RatFunc C) N] + [IsGalois (RatFunc C) N] + [Algebra C S] [FiniteDimensional C S] [IsGalois C S] + +local instance exactRationalBaseConstantAlgebra : Algebra C N := + bridgeBaseConstantAlgebra C N + +local instance (priority := 10000) exactRationalBasePolynomialAlgebra : + Algebra C[X] N := + bridgeBasePolynomialAlgebra C N + +local instance (priority := 10000) exactRationalTargetPolynomialAlgebra : + Algebra S[X] (ExactConstantExtension C N S) := + bridgeTargetPolynomialAlgebra C S N + +variable (hExact : algebraicClosure C N = + (⊥ : IntermediateField C N)) + +/-- If the constant-extension degree is divisible by the Galois degree, then +an upstairs finite place whose contraction lies over a rational base place +has degree one over the enlarged constants. -/ +theorem exactConstantExtensionUpstairsFinitePlace_degree_eq_one_of_under_degree_one + (q : IsDedekindDomain.HeightOneSpectrum + (integralClosure S[X] (ExactConstantExtension C N S))) + (hUnder : finiteExtensionPlaceDegree C (RatFunc C) + (.inl (finitePlaceUnder C (RatFunc C) N + (exactConstantExtensionDownstairsFinitePlace C S N hExact q))) = 1) + (hDegree : Module.finrank (RatFunc C) N ∣ Module.finrank C S) : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc S) (ExactConstantExtension C N S) := + ratFuncExactConstantExtensionAlgebra C S N hExact + finiteExtensionPlaceDegree S (ExactConstantExtension C N S) + (.inl (exactConstantExtensionUpstairsFinitePlace C S N hExact q)) = 1 := by + let : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + let : Algebra (RatFunc S) (ExactConstantExtension C N S) := + ratFuncExactConstantExtensionAlgebra C S N hExact + let P := exactConstantExtensionDownstairsFinitePlace C S N hExact q + have hPdiv : finiteExtensionPlaceDegree C N (.inl P) ∣ + Module.finrank (RatFunc C) N := + finiteExtensionFinitePlace_degree_dvd_relative_finrank_of_under_degree_one + C (RatFunc C) N P hUnder + have hPdivS : finiteExtensionPlaceDegree C N (.inl P) ∣ + Module.finrank C S := hPdiv.trans hDegree + rw [exactConstantExtensionFinitePlace_degree_eq_div_gcd C S N hExact q, + Nat.gcd_eq_right_iff_dvd.mpr hPdivS] + apply Nat.div_self + apply Nat.pos_of_ne_zero + intro hzero + have hzeroP : finiteExtensionPlaceDegree C N (.inl P) = 0 := by + simpa [P] using hzero + obtain ⟨c, hc⟩ := hPdiv + have hfinrankZero : Module.finrank (RatFunc C) N = 0 := by + simpa [hzeroP] using hc + exact (Module.finrank_pos.ne' hfinrankZero) + +end ExactConstantExtension + +end + + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/ConstantFieldAutomorphism.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/ConstantFieldAutomorphism.lean new file mode 100644 index 0000000000..a7fa93353a --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/ConstantFieldAutomorphism.lean @@ -0,0 +1,436 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.FunctionFieldConstantExtension +public import Mathlib.FieldTheory.Finite.Extension +public import Mathlib.FieldTheory.Galois.Basic + +/-! +# Automorphisms of plane-curve constant extensions + +For an algebraic extension `E / K`, this file transports every element of +`Gal(E/K)` to the scalar extension of a plane-curve function field. The +transported automorphisms act on `E` in the prescribed way and fix the +original function field pointwise. + +When `K` and `E` are finite, the scalar-extended function field has degree +`[E : K]`, is Galois over the original function field, and its full Galois +group is identified with `Gal(E/K)`. The finite-field Frobenius therefore +acts with exact order `[E : K]` on the base-changed function field. + +This file does not identify fixed points or rational places; those are the +next local-geometric layer. +-/ + +@[expose] public section + +open scoped TensorProduct + +namespace BGS.HasseWeil + +noncomputable section + +section Tensor + +variable (K E L : Type*) [Field K] [Field E] [CommRing L] + [Algebra K E] [Algebra K L] + +noncomputable def tensorConstantAlgEquiv (σ : E ≃ₐ[K] E) : + E ⊗[K] L ≃ₐ[K] E ⊗[K] L := + Algebra.TensorProduct.congr σ (AlgEquiv.refl : L ≃ₐ[K] L) + +@[simp] +theorem tensorConstantAlgEquiv_tmul (σ : E ≃ₐ[K] E) (e : E) (x : L) : + tensorConstantAlgEquiv K E L σ (e ⊗ₜ[K] x) = σ e ⊗ₜ[K] x := by + rfl + +@[simp] +theorem tensorConstantAlgEquiv_includeRight (σ : E ≃ₐ[K] E) (x : L) : + tensorConstantAlgEquiv K E L σ + (Algebra.TensorProduct.includeRight (R := K) (A := E) (B := L) x) = + Algebra.TensorProduct.includeRight (R := K) (A := E) (B := L) x := by + simp [Algebra.TensorProduct.includeRight_apply] + +noncomputable def tensorConstantAutHom : + (E ≃ₐ[K] E) →* (E ⊗[K] L ≃ₐ[K] E ⊗[K] L) where + toFun := tensorConstantAlgEquiv K E L + map_one' := by + apply AlgEquiv.ext + intro z + induction z using TensorProduct.inductionOn with + | tmul e x => simp + | add x y hx hy => simp [hx, hy] + map_mul' σ τ := by + apply AlgEquiv.ext + intro z + induction z using TensorProduct.inductionOn with + | tmul e x => simp + | add x y hx hy => simp [hx, hy] + +theorem tensorConstantAutHom_injective [Nontrivial L] : + Function.Injective (tensorConstantAutHom K E L) := by + intro σ τ h + ext e + have h' := DFunLike.congr_fun h (e ⊗ₜ[K] (1 : L)) + change tensorConstantAlgEquiv K E L σ (e ⊗ₜ[K] (1 : L)) = + tensorConstantAlgEquiv K E L τ (e ⊗ₜ[K] (1 : L)) at h' + have hinc : + Algebra.TensorProduct.includeLeft (R := K) (S := K) (A := E) (B := L) (σ e) = + Algebra.TensorProduct.includeLeft (R := K) (S := K) (A := E) (B := L) (τ e) := by + simpa [Algebra.TensorProduct.includeLeft_apply] using h' + exact (Algebra.TensorProduct.includeLeft_injective + (R := K) (S := K) (A := E) (B := L) (algebraMap K L).injective) hinc + +end Tensor + +section Plane + +open BGS.CorvajaZannier + +variable (K E : Type*) [Field K] [Field E] [Algebra K E] + (f : MvPolynomial (Fin 2) K) + (hf : Irreducible f) + (hfE : Irreducible (MvPolynomial.map (algebraMap K E) f)) + [Algebra.IsAlgebraic K E] + +noncomputable def planeCurveConstantAlgEquiv (σ : E ≃ₐ[K] E) : + PlaneCurveFunctionField (MvPolynomial.map (algebraMap K E) f) ≃ₐ[K] + PlaneCurveFunctionField (MvPolynomial.map (algebraMap K E) f) := by + let φ := (planeCurveFunctionFieldBaseChangeAlgEquiv K E f hf hfE).restrictScalars K + exact φ.symm.trans ((tensorConstantAlgEquiv K E (PlaneCurveFunctionField f) σ).trans φ) + +noncomputable def planeCurveFunctionFieldBaseChangeAlgHom : + PlaneCurveFunctionField f →ₐ[K] + PlaneCurveFunctionField (MvPolynomial.map (algebraMap K E) f) := + ((planeCurveFunctionFieldBaseChangeAlgEquiv K E f hf hfE).restrictScalars K).toAlgHom.comp + (Algebra.TensorProduct.includeRight + (R := K) (A := E) (B := PlaneCurveFunctionField f)) + +@[simp] +theorem planeCurveConstantAlgEquiv_baseChange + (σ : E ≃ₐ[K] E) (x : PlaneCurveFunctionField f) : + planeCurveConstantAlgEquiv K E f hf hfE σ + (planeCurveFunctionFieldBaseChangeAlgHom K E f hf hfE x) = + planeCurveFunctionFieldBaseChangeAlgHom K E f hf hfE x := by + simp [planeCurveConstantAlgEquiv, planeCurveFunctionFieldBaseChangeAlgHom] + +@[simp] +theorem planeCurveConstantAlgEquiv_algebraMap + (σ : E ≃ₐ[K] E) (e : E) : + planeCurveConstantAlgEquiv K E f hf hfE σ + (algebraMap E + (PlaneCurveFunctionField (MvPolynomial.map (algebraMap K E) f)) e) = + algebraMap E + (PlaneCurveFunctionField (MvPolynomial.map (algebraMap K E) f)) (σ e) := by + let φ := planeCurveFunctionFieldBaseChangeAlgEquiv K E f hf hfE + change φ ((tensorConstantAlgEquiv K E (PlaneCurveFunctionField f) σ) + (φ.symm (algebraMap E + (PlaneCurveFunctionField (MvPolynomial.map (algebraMap K E) f)) e))) = _ + have hpre : + φ.symm (algebraMap E + (PlaneCurveFunctionField (MvPolynomial.map (algebraMap K E) f)) e) = + e ⊗ₜ[K] (1 : PlaneCurveFunctionField f) := by + simpa only [φ, AlgEquiv.symm_apply_apply] using congrArg φ.symm + (planeCurveFunctionFieldBaseChangeAlgEquiv_tmul_one + K E f hf hfE e).symm + rw [hpre] + rw [tensorConstantAlgEquiv_tmul] + exact planeCurveFunctionFieldBaseChangeAlgEquiv_tmul_one K E f hf hfE (σ e) + +noncomputable def planeCurveConstantAutHom : + (E ≃ₐ[K] E) →* + (PlaneCurveFunctionField (MvPolynomial.map (algebraMap K E) f) ≃ₐ[K] + PlaneCurveFunctionField (MvPolynomial.map (algebraMap K E) f)) where + toFun := planeCurveConstantAlgEquiv K E f hf hfE + map_one' := by + apply AlgEquiv.ext + intro x + change (planeCurveFunctionFieldBaseChangeAlgEquiv K E f hf hfE) + ((tensorConstantAlgEquiv K E (PlaneCurveFunctionField f) 1) + ((planeCurveFunctionFieldBaseChangeAlgEquiv K E f hf hfE).symm x)) = x + rw [show tensorConstantAlgEquiv K E (PlaneCurveFunctionField f) 1 = 1 from + (tensorConstantAutHom K E (PlaneCurveFunctionField f)).map_one] + simp + map_mul' σ τ := by + apply AlgEquiv.ext + intro x + change (planeCurveFunctionFieldBaseChangeAlgEquiv K E f hf hfE) + ((tensorConstantAlgEquiv K E (PlaneCurveFunctionField f) (σ * τ)) + ((planeCurveFunctionFieldBaseChangeAlgEquiv K E f hf hfE).symm x)) = _ + rw [show tensorConstantAlgEquiv K E (PlaneCurveFunctionField f) (σ * τ) = + tensorConstantAlgEquiv K E (PlaneCurveFunctionField f) σ * + tensorConstantAlgEquiv K E (PlaneCurveFunctionField f) τ from + (tensorConstantAutHom K E (PlaneCurveFunctionField f)).map_mul σ τ] + simp [planeCurveConstantAlgEquiv] + +theorem planeCurveConstantAutHom_injective : + Function.Injective (planeCurveConstantAutHom K E f hf hfE) := by + let : IsDomain (PlaneCurveCoordinateRing + (MvPolynomial.map (algebraMap K E) f)) := + planeCurveCoordinateRing_isDomain hfE + intro σ τ h + ext e + have h' := DFunLike.congr_fun h + (algebraMap E + (PlaneCurveFunctionField (MvPolynomial.map (algebraMap K E) f)) e) + change planeCurveConstantAlgEquiv K E f hf hfE σ _ = + planeCurveConstantAlgEquiv K E f hf hfE τ _ at h' + rw [planeCurveConstantAlgEquiv_algebraMap, + planeCurveConstantAlgEquiv_algebraMap] at h' + exact (algebraMap E + (PlaneCurveFunctionField (MvPolynomial.map (algebraMap K E) f))).injective h' + +/-- The algebra structure on the base-changed function field induced by the +canonical embedding of the original function field. -/ +@[reducible] noncomputable def planeCurveFunctionFieldBaseChangeAlgebra : + Algebra (PlaneCurveFunctionField f) + (PlaneCurveFunctionField (MvPolynomial.map (algebraMap K E) f)) := + (planeCurveFunctionFieldBaseChangeAlgHom K E f hf hfE).toAlgebra + +/-- The base-changed function field has the expected dimension over the +original function field. -/ +noncomputable def planeCurveFunctionFieldBaseChangeLinearEquiv : + letI := planeCurveFunctionFieldBaseChangeAlgebra K E f hf hfE + (PlaneCurveFunctionField f) ⊗[K] E ≃ₗ[PlaneCurveFunctionField f] + PlaneCurveFunctionField (MvPolynomial.map (algebraMap K E) f) := by + letI : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + letI : IsDomain (PlaneCurveCoordinateRing + (MvPolynomial.map (algebraMap K E) f)) := + planeCurveCoordinateRing_isDomain hfE + letI := planeCurveFunctionFieldBaseChangeAlgebra K E f hf hfE + let φ := planeCurveFunctionFieldBaseChangeAlgEquiv K E f hf hfE + let ψ := (Algebra.TensorProduct.comm K (PlaneCurveFunctionField f) E).toRingEquiv.trans + φ.toRingEquiv + exact + { toEquiv := ψ.toEquiv + map_add' := map_add ψ + map_smul' := by + intro x z + induction z using TensorProduct.inductionOn with + | tmul y e => + change φ (e ⊗ₜ[K] (x * y)) = + φ (1 ⊗ₜ[K] x) * φ (e ⊗ₜ[K] y) + rw [← map_mul] + simp + | add z w hz hw => + rw [smul_add] + calc + ψ (x • z + x • w) = ψ (x • z) + ψ (x • w) := map_add ψ _ _ + _ = x • ψ z + x • ψ w := congrArg₂ (· + ·) hz hw + _ = x • ψ (z + w) := by rw [map_add, smul_add] } + +theorem planeCurveFunctionFieldBaseChange_finrank : + letI := planeCurveFunctionFieldBaseChangeAlgebra K E f hf hfE + Module.finrank (PlaneCurveFunctionField f) + (PlaneCurveFunctionField (MvPolynomial.map (algebraMap K E) f)) = + Module.finrank K E := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let : IsDomain (PlaneCurveCoordinateRing + (MvPolynomial.map (algebraMap K E) f)) := + planeCurveCoordinateRing_isDomain hfE + let := planeCurveFunctionFieldBaseChangeAlgebra K E f hf hfE + calc + Module.finrank (PlaneCurveFunctionField f) + (PlaneCurveFunctionField (MvPolynomial.map (algebraMap K E) f)) = + Module.finrank (PlaneCurveFunctionField f) + ((PlaneCurveFunctionField f) ⊗[K] E) := + (planeCurveFunctionFieldBaseChangeLinearEquiv K E f hf hfE).finrank_eq.symm + _ = Module.finrank K E := Module.finrank_baseChange + +/-- A constant-field automorphism, viewed as an automorphism over the +embedded original function field. -/ +noncomputable def planeCurveConstantAlgEquivOverBase (σ : E ≃ₐ[K] E) : + letI := planeCurveFunctionFieldBaseChangeAlgebra K E f hf hfE + PlaneCurveFunctionField (MvPolynomial.map (algebraMap K E) f) ≃ₐ[ + PlaneCurveFunctionField f] + PlaneCurveFunctionField (MvPolynomial.map (algebraMap K E) f) := by + letI := planeCurveFunctionFieldBaseChangeAlgebra K E f hf hfE + exact + { planeCurveConstantAlgEquiv K E f hf hfE σ with + commutes' := fun x => by + change planeCurveConstantAlgEquiv K E f hf hfE σ + (planeCurveFunctionFieldBaseChangeAlgHom K E f hf hfE x) = + planeCurveFunctionFieldBaseChangeAlgHom K E f hf hfE x + exact planeCurveConstantAlgEquiv_baseChange K E f hf hfE σ x } + +noncomputable def planeCurveConstantAutOverBaseHom : + letI := planeCurveFunctionFieldBaseChangeAlgebra K E f hf hfE + (E ≃ₐ[K] E) →* + (PlaneCurveFunctionField (MvPolynomial.map (algebraMap K E) f) ≃ₐ[ + PlaneCurveFunctionField f] + PlaneCurveFunctionField (MvPolynomial.map (algebraMap K E) f)) := by + letI := planeCurveFunctionFieldBaseChangeAlgebra K E f hf hfE + exact + { toFun := planeCurveConstantAlgEquivOverBase K E f hf hfE + map_one' := by + apply AlgEquiv.ext + intro x + exact DFunLike.congr_fun + (planeCurveConstantAutHom K E f hf hfE).map_one x + map_mul' := by + intro σ τ + apply AlgEquiv.ext + intro x + exact DFunLike.congr_fun + ((planeCurveConstantAutHom K E f hf hfE).map_mul σ τ) x } + +theorem planeCurveConstantAutOverBaseHom_injective : + letI := planeCurveFunctionFieldBaseChangeAlgebra K E f hf hfE + Function.Injective (planeCurveConstantAutOverBaseHom K E f hf hfE) := by + let := planeCurveFunctionFieldBaseChangeAlgebra K E f hf hfE + intro σ τ h + apply planeCurveConstantAutHom_injective K E f hf hfE + apply AlgEquiv.ext + intro x + exact DFunLike.congr_fun h x + +theorem planeCurveFunctionFieldBaseChange_isGalois + [Finite K] [Finite E] : + letI : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + letI : IsDomain (PlaneCurveCoordinateRing + (MvPolynomial.map (algebraMap K E) f)) := + planeCurveCoordinateRing_isDomain hfE + letI := planeCurveFunctionFieldBaseChangeAlgebra K E f hf hfE + IsGalois (PlaneCurveFunctionField f) + (PlaneCurveFunctionField (MvPolynomial.map (algebraMap K E) f)) := by + let : Fintype K := Fintype.ofFinite K + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let : IsDomain (PlaneCurveCoordinateRing + (MvPolynomial.map (algebraMap K E) f)) := + planeCurveCoordinateRing_isDomain hfE + let := planeCurveFunctionFieldBaseChangeAlgebra K E f hf hfE + let e := planeCurveFunctionFieldBaseChangeLinearEquiv K E f hf hfE + let : Module.Finite (PlaneCurveFunctionField f) + ((PlaneCurveFunctionField f) ⊗[K] E) := + Module.Finite.base_change K (PlaneCurveFunctionField f) E + let : Module.Finite (PlaneCurveFunctionField f) + (PlaneCurveFunctionField (MvPolynomial.map (algebraMap K E) f)) := + Module.Finite.equiv e + apply IsGalois.of_card_aut_eq_finrank + apply Nat.le_antisymm + · calc + Nat.card (PlaneCurveFunctionField + (MvPolynomial.map (algebraMap K E) f) ≃ₐ[PlaneCurveFunctionField f] + PlaneCurveFunctionField + (MvPolynomial.map (algebraMap K E) f)) = + Nat.card (PlaneCurveFunctionField + (MvPolynomial.map (algebraMap K E) f) →ₐ[PlaneCurveFunctionField f] + PlaneCurveFunctionField + (MvPolynomial.map (algebraMap K E) f)) := + Nat.card_congr (algEquivEquivAlgHom + (PlaneCurveFunctionField f) + (PlaneCurveFunctionField + (MvPolynomial.map (algebraMap K E) f))) + _ ≤ Module.finrank (PlaneCurveFunctionField f) + (PlaneCurveFunctionField + (MvPolynomial.map (algebraMap K E) f)) := + card_algHom_le_finrank _ _ _ + · rw [planeCurveFunctionFieldBaseChange_finrank K E f hf hfE, + ← IsGalois.card_aut_eq_finrank K E] + exact Nat.card_le_card_of_injective + (planeCurveConstantAutOverBaseHom K E f hf hfE) + (planeCurveConstantAutOverBaseHom_injective K E f hf hfE) + +/-- The Galois group of the constant extension is exactly the Galois group of +the enlarged constants. -/ +noncomputable def planeCurveConstantAutOverBaseMulEquiv + [Fintype K] [Finite E] : + letI : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + letI : IsDomain (PlaneCurveCoordinateRing + (MvPolynomial.map (algebraMap K E) f)) := + planeCurveCoordinateRing_isDomain hfE + letI := planeCurveFunctionFieldBaseChangeAlgebra K E f hf hfE + (E ≃ₐ[K] E) ≃* + (PlaneCurveFunctionField (MvPolynomial.map (algebraMap K E) f) ≃ₐ[ + PlaneCurveFunctionField f] + PlaneCurveFunctionField (MvPolynomial.map (algebraMap K E) f)) := by + letI : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + letI : IsDomain (PlaneCurveCoordinateRing + (MvPolynomial.map (algebraMap K E) f)) := + planeCurveCoordinateRing_isDomain hfE + letI := planeCurveFunctionFieldBaseChangeAlgebra K E f hf hfE + let e := planeCurveFunctionFieldBaseChangeLinearEquiv K E f hf hfE + letI : Module.Finite (PlaneCurveFunctionField f) + ((PlaneCurveFunctionField f) ⊗[K] E) := + Module.Finite.base_change K (PlaneCurveFunctionField f) E + letI : Module.Finite (PlaneCurveFunctionField f) + (PlaneCurveFunctionField (MvPolynomial.map (algebraMap K E) f)) := + Module.Finite.equiv e + letI : IsGalois (PlaneCurveFunctionField f) + (PlaneCurveFunctionField (MvPolynomial.map (algebraMap K E) f)) := + planeCurveFunctionFieldBaseChange_isGalois K E f hf hfE + let h := planeCurveConstantAutOverBaseHom K E f hf hfE + let hinj := planeCurveConstantAutOverBaseHom_injective K E f hf hfE + apply MulEquiv.ofBijective h + apply hinj.bijective_of_nat_card_le + rw [IsGalois.card_aut_eq_finrank, + planeCurveFunctionFieldBaseChange_finrank K E f hf hfE, + IsGalois.card_aut_eq_finrank K E] + +section Frobenius + +variable [Fintype K] + +/-- Frobenius on the enlarged constant field, transported to the +base-changed plane-curve function field. -/ +noncomputable def planeCurveConstantFrobeniusAlgEquiv : + PlaneCurveFunctionField (MvPolynomial.map (algebraMap K E) f) ≃ₐ[K] + PlaneCurveFunctionField (MvPolynomial.map (algebraMap K E) f) := + planeCurveConstantAlgEquiv K E f hf hfE + (FiniteField.frobeniusAlgEquivOfAlgebraic K E) + +@[simp] +theorem planeCurveConstantFrobeniusAlgEquiv_algebraMap (e : E) : + planeCurveConstantFrobeniusAlgEquiv K E f hf hfE + (algebraMap E + (PlaneCurveFunctionField (MvPolynomial.map (algebraMap K E) f)) e) = + algebraMap E + (PlaneCurveFunctionField (MvPolynomial.map (algebraMap K E) f)) + (e ^ Fintype.card K) := by + rw [planeCurveConstantFrobeniusAlgEquiv, + planeCurveConstantAlgEquiv_algebraMap] + rfl + +@[simp] +theorem planeCurveConstantFrobeniusAlgEquiv_baseChange + (x : PlaneCurveFunctionField f) : + planeCurveConstantFrobeniusAlgEquiv K E f hf hfE + (planeCurveFunctionFieldBaseChangeAlgHom K E f hf hfE x) = + planeCurveFunctionFieldBaseChangeAlgHom K E f hf hfE x := by + exact planeCurveConstantAlgEquiv_baseChange K E f hf hfE _ x + +variable [Finite E] + +theorem orderOf_planeCurveConstantFrobeniusAlgEquiv : + orderOf (planeCurveConstantFrobeniusAlgEquiv K E f hf hfE) = + Module.finrank K E := by + change orderOf ((planeCurveConstantAutHom K E f hf hfE) + (FiniteField.frobeniusAlgEquivOfAlgebraic K E)) = _ + rw [orderOf_injective (planeCurveConstantAutHom K E f hf hfE) + (planeCurveConstantAutHom_injective K E f hf hfE)] + exact FiniteField.orderOf_frobeniusAlgEquivOfAlgebraic K E + +theorem natCard_zpowers_planeCurveConstantFrobeniusAlgEquiv : + Nat.card (Subgroup.zpowers + (planeCurveConstantFrobeniusAlgEquiv K E f hf hfE)) = + Module.finrank K E := by + rw [Nat.card_zpowers, orderOf_planeCurveConstantFrobeniusAlgEquiv] + +end Frobenius + +end Plane + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/ConstantFieldFinitePlace.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/ConstantFieldFinitePlace.lean new file mode 100644 index 0000000000..e214b77f36 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/ConstantFieldFinitePlace.lean @@ -0,0 +1,195 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.ConstantFieldRatFuncCompatibility +public import LeanPool.MarkoffModP.BGS.HasseWeil.RationalPlaceTower +public import Mathlib.RingTheory.DedekindDomain.Ideal.Lemmas + +/-! +# Finite places under constant-field extension + +If `R → S` is integral and both rings act compatibly on a common overring +`L`, then an element of `L` is integral over `R` exactly when it is integral +over `S`. Thus the two integral closures are canonically ring-equivalent by +the identity on `L`. + +For a plane-curve constant extension this identifies the integral closure of +`K[X]` in the enlarged function field with the integral closure of `E[X]` in +that same field. It therefore gives an equivalence between the finite-place +types based on `K(X)` and `E(X)`. + +This file concerns only finite places. The valuation rings at infinity and +the comparison of place degrees are separate boundaries. +-/ + +@[expose] public section + +open scoped Polynomial + +namespace BGS.HasseWeil + +noncomputable section + +open BGS.CorvajaZannier + +/-- Integral closures in a common overring agree after enlarging the base by +an integral extension. The equivalence is the identity on the overring. -/ +def integralClosureRingEquivOfIntegralTower + (R S L : Type*) [CommRing R] [CommRing S] [CommRing L] + [Algebra R S] [Algebra R L] [Algebra S L] [IsScalarTower R S L] + [Algebra.IsIntegral R S] : + integralClosure R L ≃+* integralClosure S L where + toFun x := ⟨x.1, x.2.tower_top⟩ + invFun x := ⟨x.1, isIntegral_trans (R := R) (x : L) x.2⟩ + left_inv _ := rfl + right_inv _ := rfl + map_mul' _ _ := rfl + map_add' _ _ := rfl + +/-- Algebra-equivalence form of the integral-closure identity. -/ +def integralClosureAlgEquivOfIntegralTower + (R S L : Type*) [CommRing R] [CommRing S] [CommRing L] + [Algebra R S] [Algebra R L] [Algebra S L] [IsScalarTower R S L] + [Algebra.IsIntegral R S] : + integralClosure R L ≃ₐ[R] integralClosure S L := + { integralClosureRingEquivOfIntegralTower R S L with + commutes' := fun _ => rfl } + +@[simp] +theorem integralClosureRingEquivOfIntegralTower_coe + (R S L : Type*) [CommRing R] [CommRing S] [CommRing L] + [Algebra R S] [Algebra R L] [Algebra S L] [IsScalarTower R S L] + [Algebra.IsIntegral R S] (x : integralClosure R L) : + ((integralClosureRingEquivOfIntegralTower R S L x : + integralClosure S L) : L) = x := rfl + +variable (K E L : Type*) [Field K] [Field E] [Field L] + [Algebra K E] [Algebra (RatFunc K) L] [Algebra (RatFunc E) L] + +local instance constantFieldFinitePolynomialCoefficientAlgebra : + Algebra K[X] E[X] := + (Polynomial.mapRingHom (algebraMap K E)).toAlgebra + +local instance finiteBasePolynomialAlgebra : Algebra K[X] L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K[X] (RatFunc K))) + +local instance finiteExtensionPolynomialAlgebra : Algebra E[X] L := + RingHom.toAlgebra ((algebraMap (RatFunc E) L).comp + (algebraMap E[X] (RatFunc E))) + +/-- Compatible coefficient extension identifies the two finite integral +closures inside the common top function field. -/ +def ratFuncFiniteIntegralClosureRingEquiv + [Algebra.IsIntegral K E] + (hcomm : ∀ p : K[X], + algebraMap (RatFunc K) L (algebraMap K[X] (RatFunc K) p) = + algebraMap (RatFunc E) L + (algebraMap E[X] (RatFunc E) + (algebraMap K[X] E[X] p))) : + RatFuncFiniteIntegralClosure K L ≃+* + RatFuncFiniteIntegralClosure E L := by + letI : IsScalarTower K[X] E[X] L := + IsScalarTower.of_algebraMap_eq hcomm + exact integralClosureRingEquivOfIntegralTower K[X] E[X] L + +variable (f : MvPolynomial (Fin 2) K) + +/-- The finite integral closures for a plane curve before and after constant +extension are canonically ring-equivalent inside the enlarged function +field. -/ +def planeCurveFiniteIntegralClosureBaseChangeRingEquiv + (hf : Irreducible f) + (hfE : Irreducible (MvPolynomial.map (algebraMap K E) f)) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + [Algebra.IsAlgebraic K E] : + let fE := MvPolynomial.map (algebraMap K E) f + letI : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + letI : IsDomain (PlaneCurveCoordinateRing fE) := + planeCurveCoordinateRing_isDomain hfE + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let hpartialSecondE : MvPolynomial.pderiv 1 fE ≠ 0 := by + rw [MvPolynomial.pderiv_map] + intro hz + apply hpartialSecond + apply MvPolynomial.map_injective (algebraMap K E) + (algebraMap K E).injective + simpa using hz + let hxE := firstCoordinate_transcendental hfE + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecondE) + letI := planeCurveFirstCoordinateRatFuncAlgebra f hx + letI := planeCurveFirstCoordinateRatFuncAlgebra fE hxE + letI := planeCurveFunctionFieldBaseChangeRatFuncAlgebra K E f hf hfE hx + RatFuncFiniteIntegralClosure K (PlaneCurveFunctionField fE) ≃+* + RatFuncFiniteIntegralClosure E (PlaneCurveFunctionField fE) := by + let fE := MvPolynomial.map (algebraMap K E) f + letI : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + letI : IsDomain (PlaneCurveCoordinateRing fE) := + planeCurveCoordinateRing_isDomain hfE + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let hpartialSecondE : MvPolynomial.pderiv 1 fE ≠ 0 := by + rw [MvPolynomial.pderiv_map] + intro hz + apply hpartialSecond + apply MvPolynomial.map_injective (algebraMap K E) + (algebraMap K E).injective + simpa using hz + let hxE := firstCoordinate_transcendental hfE + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecondE) + letI := planeCurveFirstCoordinateRatFuncAlgebra f hx + letI := planeCurveFirstCoordinateRatFuncAlgebra fE hxE + letI := planeCurveFunctionFieldBaseChangeRatFuncAlgebra K E f hf hfE hx + apply ratFuncFiniteIntegralClosureRingEquiv K E + (PlaneCurveFunctionField fE) + intro p + change planeCurveFunctionFieldBaseChangeAlgHom K E f hf hfE + (algebraMap (RatFunc K) (PlaneCurveFunctionField f) p) = _ + rw [planeCurveFunctionFieldBaseChange_ratFunc_commutes + K E f hf hfE hpartialSecond] + apply congrArg (algebraMap (RatFunc E) (PlaneCurveFunctionField fE)) + exact ratFuncCoefficientAlgHom_algebraMap K E p + +/-- The identity equivalence of finite integral closures transports their +height-one spectra, giving the finite-place base-change equivalence. -/ +def planeCurveFinitePlaceBaseChangeEquiv + (hf : Irreducible f) + (hfE : Irreducible (MvPolynomial.map (algebraMap K E) f)) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + [Algebra.IsAlgebraic K E] : + let fE := MvPolynomial.map (algebraMap K E) f + letI : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + letI : IsDomain (PlaneCurveCoordinateRing fE) := + planeCurveCoordinateRing_isDomain hfE + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let hpartialSecondE : MvPolynomial.pderiv 1 fE ≠ 0 := by + rw [MvPolynomial.pderiv_map] + intro hz + apply hpartialSecond + apply MvPolynomial.map_injective (algebraMap K E) + (algebraMap K E).injective + simpa using hz + let hxE := firstCoordinate_transcendental hfE + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecondE) + letI := planeCurveFirstCoordinateRatFuncAlgebra f hx + letI := planeCurveFirstCoordinateRatFuncAlgebra fE hxE + letI := planeCurveFunctionFieldBaseChangeRatFuncAlgebra K E f hf hfE hx + FiniteExtensionFinitePlace K (PlaneCurveFunctionField fE) ≃ + FiniteExtensionFinitePlace E (PlaneCurveFunctionField fE) := by + exact IsDedekindDomain.HeightOneSpectrum.equivOfRingEquiv + (planeCurveFiniteIntegralClosureBaseChangeRingEquiv + K E f hf hfE hpartialSecond) + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/ConstantFieldFinitePlaceDegree.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/ConstantFieldFinitePlaceDegree.lean new file mode 100644 index 0000000000..41b8a20810 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/ConstantFieldFinitePlaceDegree.lean @@ -0,0 +1,213 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.ConstantFieldFinitePlace +public import LeanPool.MarkoffModP.BGS.HasseWeil.OnePointLeadingCoefficient + +/-! +# Finite-place degrees under constant-field extension + +The finite integral closures before and after constant extension are the same +subring of the enlarged function field. This file upgrades that ring +equivalence to an equivalence over the original constant field and transports +it to residue fields. Consequently, if `Q_E` is the finite place obtained +from `Q` after replacing `K` by `E`, then + +`deg_K(Q) = [E : K] * deg_E(Q_E)`. + +This is the arithmetic content missing from a bare equivalence of finite-place +types: an `E`-rational place is a place of degree `[E : K]` over `K`. +-/ + +@[expose] public section + +open scoped Polynomial + +namespace BGS.HasseWeil + +noncomputable section + +open BGS.CorvajaZannier + +attribute [local instance high] Module.Free.of_divisionRing + +variable (K E L : Type*) [Field K] [Field E] [Field L] + [DecidableEq K] [DecidableEq E] + [DecidableEq (RatFunc K)] [DecidableEq (RatFunc E)] + [Algebra K E] + [Algebra (RatFunc K) L] [Algebra (RatFunc E) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + [FiniteDimensional (RatFunc E) L] + [Algebra.IsSeparable (RatFunc E) L] + +local instance degreePolynomialCoefficientAlgebra : Algebra K[X] E[X] := + (Polynomial.mapRingHom (algebraMap K E)).toAlgebra + +local instance degreeBasePolynomialAlgebra : Algebra K[X] L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K[X] (RatFunc K))) + +local instance degreeExtensionPolynomialAlgebra : Algebra E[X] L := + RingHom.toAlgebra ((algebraMap (RatFunc E) L).comp + (algebraMap E[X] (RatFunc E))) + +local instance degreeBaseFiniteClosureConstantAlgebra : + Algebra K (RatFuncFiniteIntegralClosure K L) := + RingHom.toAlgebra ((algebraMap K[X] + (RatFuncFiniteIntegralClosure K L)).comp (algebraMap K K[X])) + +local instance degreeExtensionFiniteClosureConstantAlgebra : + Algebra E (RatFuncFiniteIntegralClosure E L) := + RingHom.toAlgebra ((algebraMap E[X] + (RatFuncFiniteIntegralClosure E L)).comp (algebraMap E E[X])) + +local instance degreeExtensionFiniteClosureBaseConstantAlgebra : + Algebra K (RatFuncFiniteIntegralClosure E L) := + RingHom.toAlgebra ((algebraMap E + (RatFuncFiniteIntegralClosure E L)).comp (algebraMap K E)) + +local instance degreeExtensionFiniteClosureConstantTower : + IsScalarTower K E (RatFuncFiniteIntegralClosure E L) := + IsScalarTower.of_algebraMap_eq' rfl + +/-- The identity equivalence between the two finite integral closures respects +the original constants. -/ +def ratFuncFiniteIntegralClosureBaseChangeAlgEquiv + [Algebra.IsIntegral K E] + (hcomm : ∀ p : K[X], + algebraMap (RatFunc K) L (algebraMap K[X] (RatFunc K) p) = + algebraMap (RatFunc E) L + (algebraMap E[X] (RatFunc E) + (algebraMap K[X] E[X] p))) : + RatFuncFiniteIntegralClosure K L ≃ₐ[K] + RatFuncFiniteIntegralClosure E L := + { ratFuncFiniteIntegralClosureRingEquiv K E L hcomm with + commutes' := fun k => by + apply Subtype.ext + change algebraMap (RatFunc K) L + (algebraMap K[X] (RatFunc K) (Polynomial.C k)) = + algebraMap (RatFunc E) L + (algebraMap E[X] (RatFunc E) + (Polynomial.C (algebraMap K E k))) + simpa using hcomm (Polynomial.C k) } + +/-- The finite-integral-closure equivalence transports residue fields as +`K`-algebras. -/ +def finitePlaceResidueFieldBaseChangeAlgEquiv + [Algebra.IsIntegral K E] + (hcomm : ∀ p : K[X], + algebraMap (RatFunc K) L (algebraMap K[X] (RatFunc K) p) = + algebraMap (RatFunc E) L + (algebraMap E[X] (RatFunc E) + (algebraMap K[X] E[X] p))) + (Q : FiniteExtensionFinitePlace K L) : + Q.asIdeal.ResidueField ≃ₐ[K] + ((IsDedekindDomain.HeightOneSpectrum.equivOfRingEquiv + (ratFuncFiniteIntegralClosureRingEquiv K E L hcomm) Q).asIdeal).ResidueField := + Ideal.residueFieldAlgEquiv Q.asIdeal + ((IsDedekindDomain.HeightOneSpectrum.equivOfRingEquiv + (ratFuncFiniteIntegralClosureRingEquiv K E L hcomm) Q).asIdeal) + (ratFuncFiniteIntegralClosureBaseChangeAlgEquiv K E L hcomm) + (by + change Q.asIdeal = + (Q.asIdeal.comap + (ratFuncFiniteIntegralClosureRingEquiv K E L hcomm).symm).comap + (ratFuncFiniteIntegralClosureRingEquiv K E L hcomm) + exact (Ideal.comap_of_equiv + (ratFuncFiniteIntegralClosureRingEquiv K E L hcomm)).symm) + +/-- A finite place in the common top function field has base-field degree +equal to the constant-extension degree times its extended-field degree. -/ +theorem finiteExtensionFinitePlace_degree_baseChange + [Algebra.IsIntegral K E] + (hcomm : ∀ p : K[X], + algebraMap (RatFunc K) L (algebraMap K[X] (RatFunc K) p) = + algebraMap (RatFunc E) L + (algebraMap E[X] (RatFunc E) + (algebraMap K[X] E[X] p))) + (Q : FiniteExtensionFinitePlace K L) : + finiteExtensionPlaceDegree K L (.inl Q) = + Module.finrank K E * + finiteExtensionPlaceDegree E L (.inl + (IsDedekindDomain.HeightOneSpectrum.equivOfRingEquiv + (ratFuncFiniteIntegralClosureRingEquiv K E L hcomm) Q)) := by + let QE : FiniteExtensionFinitePlace E L := + IsDedekindDomain.HeightOneSpectrum.equivOfRingEquiv + (ratFuncFiniteIntegralClosureRingEquiv K E L hcomm) Q + let e := finitePlaceResidueFieldBaseChangeAlgEquiv K E L hcomm Q + rw [finiteExtensionFinitePlace_degree_eq_finrank_residueField K L Q] + rw [finiteExtensionFinitePlace_degree_eq_finrank_residueField E L QE] + calc + Module.finrank K Q.asIdeal.ResidueField = + Module.finrank K QE.asIdeal.ResidueField := + e.toLinearEquiv.finrank_eq + _ = Module.finrank K E * Module.finrank E QE.asIdeal.ResidueField := + (Module.finrank_mul_finrank K E QE.asIdeal.ResidueField).symm + +/-- A place is rational over the extended constant field exactly when its +degree over the original constant field is the degree of the constant +extension. -/ +theorem finiteExtensionFinitePlace_baseChange_rational_iff + [Algebra.IsIntegral K E] [FiniteDimensional K E] + (hcomm : ∀ p : K[X], + algebraMap (RatFunc K) L (algebraMap K[X] (RatFunc K) p) = + algebraMap (RatFunc E) L + (algebraMap E[X] (RatFunc E) + (algebraMap K[X] E[X] p))) + (Q : FiniteExtensionFinitePlace K L) : + finiteExtensionPlaceDegree E L (.inl + (IsDedekindDomain.HeightOneSpectrum.equivOfRingEquiv + (ratFuncFiniteIntegralClosureRingEquiv K E L hcomm) Q)) = 1 ↔ + finiteExtensionPlaceDegree K L (.inl Q) = Module.finrank K E := by + rw [finiteExtensionFinitePlace_degree_baseChange K E L hcomm Q] + constructor + · intro h + rw [h, Nat.mul_one] + · intro h + apply Nat.eq_of_mul_eq_mul_left + (Module.finrank_pos : 0 < Module.finrank K E) + simpa using h + +/-- Base change identifies the finite places of degree `[E : K]` with the +rational finite places over `E`. -/ +def finiteExtensionFinitePlaceDegreeEquivRationalBaseChange + [Algebra.IsIntegral K E] [FiniteDimensional K E] + (hcomm : ∀ p : K[X], + algebraMap (RatFunc K) L (algebraMap K[X] (RatFunc K) p) = + algebraMap (RatFunc E) L + (algebraMap E[X] (RatFunc E) + (algebraMap K[X] E[X] p))) : + {Q : FiniteExtensionFinitePlace K L // + finiteExtensionPlaceDegree K L (.inl Q) = Module.finrank K E} ≃ + FiniteExtensionRationalFinitePlace E L := + let e := IsDedekindDomain.HeightOneSpectrum.equivOfRingEquiv + (ratFuncFiniteIntegralClosureRingEquiv K E L hcomm) + e.subtypeEquiv fun Q => + (finiteExtensionFinitePlace_baseChange_rational_iff + K E L hcomm Q).symm + +/-- Cardinal form of the finite rational-place base-change correspondence. -/ +theorem natCard_finiteExtensionRationalFinitePlace_eq_degree_baseChange + [Algebra.IsIntegral K E] [FiniteDimensional K E] : + (hcomm : ∀ p : K[X], + algebraMap (RatFunc K) L (algebraMap K[X] (RatFunc K) p) = + algebraMap (RatFunc E) L + (algebraMap E[X] (RatFunc E) + (algebraMap K[X] E[X] p))) → + Nat.card (FiniteExtensionRationalFinitePlace E L) = + Nat.card {Q : FiniteExtensionFinitePlace K L // + finiteExtensionPlaceDegree K L (.inl Q) = Module.finrank K E} := by + intro hcomm + exact Nat.card_congr + (finiteExtensionFinitePlaceDegreeEquivRationalBaseChange + K E L hcomm).symm + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/ConstantFieldInfinityBase.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/ConstantFieldInfinityBase.lean new file mode 100644 index 0000000000..c9d30f61e6 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/ConstantFieldInfinityBase.lean @@ -0,0 +1,165 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.ConstantFieldFinitePlace + +/-! +# The rational-function place at infinity under coefficient extension + +Coefficient extension `K(X) → E(X)` preserves the integer degree of every +rational function, hence preserves the valuation at infinity exactly. It +therefore restricts to an injective local homomorphism between the two +infinity valuation rings. The maximal ideal of the enlarged valuation ring +contracts to the original maximal ideal. + +This is the base-place comparison. It does not identify the integral +closures of these valuation rings inside a further function field. +-/ + +@[expose] public section + +open scoped Polynomial + +namespace BGS.HasseWeil + +noncomputable section + +open BGS.CorvajaZannier + +variable (K E : Type*) [Field K] [Field E] [Algebra K E] + +/-- Injective coefficient extension preserves rational-function integer +degree. -/ +theorem ratFuncCoefficientAlgHom_intDegree (z : RatFunc K) : + RatFunc.intDegree (ratFuncCoefficientAlgHom K E z) = + RatFunc.intDegree z := by + by_cases hz : z = 0 + · simp [hz] + rw [← z.num_div_denom, map_div₀] + have hnumK : algebraMap K[X] (RatFunc K) z.num ≠ 0 := by + simpa using + (IsFractionRing.injective K[X] (RatFunc K)).ne + (RatFunc.num_ne_zero hz) + have hdenK : algebraMap K[X] (RatFunc K) z.denom ≠ 0 := by + simpa using + (IsFractionRing.injective K[X] (RatFunc K)).ne z.denom_ne_zero + have hnumE : ratFuncCoefficientAlgHom K E + (algebraMap K[X] (RatFunc K) z.num) ≠ 0 := by + simpa using (ratFuncCoefficientAlgHom_injective K E).ne hnumK + have hdenE : ratFuncCoefficientAlgHom K E + (algebraMap K[X] (RatFunc K) z.denom) ≠ 0 := by + simpa using (ratFuncCoefficientAlgHom_injective K E).ne hdenK + rw [RatFunc.intDegree_div hnumE hdenE, + RatFunc.intDegree_div hnumK hdenK] + rw [ratFuncCoefficientAlgHom_algebraMap, + ratFuncCoefficientAlgHom_algebraMap] + simp only [RatFunc.intDegree_polynomial] + change ((Polynomial.map (algebraMap K E) z.num).natDegree : ℤ) - + ((Polynomial.map (algebraMap K E) z.denom).natDegree : ℤ) = _ + rw [Polynomial.natDegree_map_eq_of_injective + (algebraMap K E).injective z.num, + Polynomial.natDegree_map_eq_of_injective + (algebraMap K E).injective z.denom] + +/-- Coefficient extension has the expected value on constants. -/ +theorem ratFuncCoefficientAlgHom_C (c : K) : + ratFuncCoefficientAlgHom K E (RatFunc.C c) = + RatFunc.C (algebraMap K E c) := by + change ratFuncCoefficientAlgHom K E + (algebraMap K[X] (RatFunc K) (Polynomial.C c)) = _ + rw [ratFuncCoefficientAlgHom_algebraMap] + simp + +variable [DecidableEq (RatFunc K)] [DecidableEq (RatFunc E)] + +/-- Coefficient extension preserves the valuation at infinity exactly. -/ +theorem ratFuncCoefficientAlgHom_inftyValuation (z : RatFunc K) : + RatFunc.inftyValuation E (ratFuncCoefficientAlgHom K E z) = + RatFunc.inftyValuation K z := by + by_cases hz : z = 0 + · simp [hz] + have hmap : ratFuncCoefficientAlgHom K E z ≠ 0 := by + simpa using (ratFuncCoefficientAlgHom_injective K E).ne hz + rw [RatFunc.inftyValuation_apply, RatFunc.inftyValuation_apply, + RatFunc.inftyValuation_of_nonzero E hmap, + RatFunc.inftyValuation_of_nonzero K hz, + ratFuncCoefficientAlgHom_intDegree K E z] + +/-- Coefficient extension restricted to the infinity valuation rings. -/ +def ratFuncInfinityIntegersRingHom : + RatFuncInfinityIntegers K →+* RatFuncInfinityIntegers E where + toFun z := ⟨ratFuncCoefficientAlgHom K E z.1, by + change RatFunc.inftyValuation E (ratFuncCoefficientAlgHom K E z.1) ≤ 1 + rw [ratFuncCoefficientAlgHom_inftyValuation K E z.1] + exact z.2⟩ + map_one' := Subtype.ext (map_one (ratFuncCoefficientAlgHom K E)) + map_mul' x y := + Subtype.ext (map_mul (ratFuncCoefficientAlgHom K E) x.1 y.1) + map_zero' := Subtype.ext (map_zero (ratFuncCoefficientAlgHom K E)) + map_add' x y := + Subtype.ext (map_add (ratFuncCoefficientAlgHom K E) x.1 y.1) + +@[simp] +theorem ratFuncInfinityIntegersRingHom_coe + (z : RatFuncInfinityIntegers K) : + ((ratFuncInfinityIntegersRingHom K E z : + RatFuncInfinityIntegers E) : RatFunc E) = + ratFuncCoefficientAlgHom K E z.1 := rfl + +theorem ratFuncInfinityIntegersRingHom_injective : + Function.Injective (ratFuncInfinityIntegersRingHom K E) := by + intro x y hxy + apply Subtype.ext + exact (ratFuncCoefficientAlgHom_injective K E) + (congrArg Subtype.val hxy) + +/-- The map of infinity valuation rings is local because it reflects the +valuation-one unit condition. -/ +noncomputable instance ratFuncInfinityIntegersRingHom_isLocalHom : + IsLocalHom (ratFuncInfinityIntegersRingHom K E) where + map_nonunit x hx := by + apply (Valuation.Integers.isUnit_iff_valuation_eq_one + (Valuation.integer.integers (RatFunc.inftyValuation K))).mpr + have hx' := (Valuation.Integers.isUnit_iff_valuation_eq_one + (Valuation.integer.integers (RatFunc.inftyValuation E))).mp hx + change RatFunc.inftyValuation E + (ratFuncCoefficientAlgHom K E x.1) = 1 at hx' + rw [ratFuncCoefficientAlgHom_inftyValuation K E x.1] at hx' + exact hx' + +/-- The maximal ideal at infinity over `E` contracts to the maximal ideal at +infinity over `K`. -/ +theorem ratFuncInfinityIntegersRingHom_comap_maximalIdeal : + (IsLocalRing.maximalIdeal (RatFuncInfinityIntegers E)).comap + (ratFuncInfinityIntegersRingHom K E) = + IsLocalRing.maximalIdeal (RatFuncInfinityIntegers K) := + IsLocalRing.maximalIdeal_comap (ratFuncInfinityIntegersRingHom K E) + +/-- Height-one-place form of maximal-ideal contraction. -/ +theorem ratFuncInfinityIntegersRingHom_comap_infinityPlace : + (ratFuncInfinityPlace E).asIdeal.comap + (ratFuncInfinityIntegersRingHom K E) = + (ratFuncInfinityPlace K).asIdeal := by + exact ratFuncInfinityIntegersRingHom_comap_maximalIdeal K E + +/-- The induced map between the two infinity residue fields. -/ +def ratFuncInfinityResidueFieldRingHom : + (ratFuncInfinityPlace K).asIdeal.ResidueField →+* + (ratFuncInfinityPlace E).asIdeal.ResidueField := + Ideal.ResidueField.map (ratFuncInfinityPlace K).asIdeal + (ratFuncInfinityPlace E).asIdeal + (ratFuncInfinityIntegersRingHom K E) + (ratFuncInfinityIntegersRingHom_comap_infinityPlace K E).symm + +theorem ratFuncInfinityResidueFieldRingHom_injective : + Function.Injective (ratFuncInfinityResidueFieldRingHom K E) := + RingHom.injective _ + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/ConstantFieldRatFuncCompatibility.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/ConstantFieldRatFuncCompatibility.lean new file mode 100644 index 0000000000..e8c931d603 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/ConstantFieldRatFuncCompatibility.lean @@ -0,0 +1,418 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.ConstantFieldAutomorphism +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PoweredImageBaseChange +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveRatFuncModel +public import LeanPool.MarkoffModP.BGS.HasseWeil.RatFuncConstantExtension + +/-! +# Rational-function models under constant extension + +This file proves that the scalar extension of a plane-curve function field is +compatible with coefficient extension of its rational-function base. With +the first coordinate as separating variable, the square + +`K(X) → K(C)` + +`↓ ↓` + +`E(X) → E(C_E)` + +commutes exactly. The induced `K(X)`-algebra on `E(C_E)` factors both through +`K(C)` and through `E(X)`. For finite constant extensions it is finite and +separable over `K(X)`, so the existing exhaustive place-tower API can be +applied to `K(C) ⊂ E(C_E)`. + +No fixed-point or rational-place correspondence is asserted here. +-/ + +@[expose] public section + +open scoped TensorProduct Polynomial + +namespace BGS.HasseWeil + +noncomputable section + +open BGS.CorvajaZannier + +variable (K E : Type*) [Field K] [Field E] [Algebra K E] + (f : MvPolynomial (Fin 2) K) + +theorem planeCurveCoordinateRingBaseChangeAlgEquiv_includeRight + (a : PlaneCurveCoordinateRing f) : + planeCurveCoordinateRingBaseChangeAlgEquiv K E f + (Algebra.TensorProduct.includeRight + (R := K) (A := E) (B := PlaneCurveCoordinateRing f) a) = + planeCurveCoordinateRingMap (E := E) f a := by + let Φ : PlaneCurveCoordinateRing f →ₐ[K] + PlaneCurveCoordinateRing (MvPolynomial.map (algebraMap K E) f) := + ((planeCurveCoordinateRingBaseChangeAlgEquiv K E f).restrictScalars K).toAlgHom.comp + (Algebra.TensorProduct.includeRight + (R := K) (A := E) (B := PlaneCurveCoordinateRing f)) + change Φ a = planeCurveCoordinateRingMap (E := E) f a + suffices Φ = planeCurveCoordinateRingMap (E := E) f by + exact DFunLike.congr_fun this a + apply Ideal.Quotient.algHom_ext K + apply MvPolynomial.algHom_ext + intro i + simp only [planeCurveCoordinateRingBaseChangeAlgEquiv, AlgEquiv.toAlgHom_restrictScalars, + AlgHom.coe_comp, AlgHom.coe_restrictScalars', AlgEquiv.coe_toAlgHom, AlgEquiv.coe_trans, + Ideal.Quotient.mkₐ_eq_mk, Function.comp_apply, Algebra.TensorProduct.includeRight_apply, + Algebra.TensorProduct.tensorQuotientEquiv_apply_tmul, planeCurveCoordinateRingMap, + Ideal.quotient_map_mkₐ, AlgHom.coe_mk, MvPolynomial.map_X, Φ] + erw [Ideal.quotientEquivAlg_mk] + simp only [MvPolynomial.algebraTensorAlgEquiv_tmul, one_smul, MvPolynomial.map_X] + +theorem planeCurveFunctionFieldBaseChangeAlgHom_function + (hf : Irreducible f) + (hfE : Irreducible (MvPolynomial.map (algebraMap K E) f)) + [Algebra.IsAlgebraic K E] (i : Fin 2) : + planeCurveFunctionFieldBaseChangeAlgHom K E f hf hfE + (planeCurveFunction f i) = + planeCurveFunction (MvPolynomial.map (algebraMap K E) f) i := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let : IsDomain (E ⊗[K] PlaneCurveCoordinateRing f) := + planeCurveCoordinateRingBaseChange_isDomain K E f hfE + let : IsDomain (PlaneCurveCoordinateRing + (MvPolynomial.map (algebraMap K E) f)) := + planeCurveCoordinateRing_isDomain hfE + let : IsFractionRing + (E ⊗[K] PlaneCurveCoordinateRing f) + (E ⊗[K] PlaneCurveFunctionField f) := + tensorFraction_isFractionRing K E (PlaneCurveCoordinateRing f) + change planeCurveFunctionFieldBaseChangeAlgEquiv K E f hf hfE + (1 ⊗ₜ[K] algebraMap (PlaneCurveCoordinateRing f) + (PlaneCurveFunctionField f) (planeCurveCoordinate f i)) = _ + rw [← tensorBaseTensorFraction_algebraMap_tmul] + rw [show planeCurveFunctionFieldBaseChangeAlgEquiv K E f hf hfE = + IsFractionRing.algEquivOfAlgEquiv + (planeCurveCoordinateRingBaseChangeAlgEquiv K E f) by rfl] + rw [IsFractionRing.algEquivOfAlgEquiv_algebraMap] + change algebraMap _ _ + (planeCurveCoordinateRingBaseChangeAlgEquiv K E f + (Algebra.TensorProduct.includeRight + (R := K) (A := E) (B := PlaneCurveCoordinateRing f) + (planeCurveCoordinate f i))) = _ + rw [planeCurveCoordinateRingBaseChangeAlgEquiv_includeRight] + rw [planeCurveCoordinateRingMap_coordinate] + rfl + +theorem planeCurveFunctionFieldBaseChange_ratFunc_commutes + (hf : Irreducible f) + (hfE : Irreducible (MvPolynomial.map (algebraMap K E) f)) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + [Algebra.IsAlgebraic K E] : + let fE := MvPolynomial.map (algebraMap K E) f + let hpartialSecondE : MvPolynomial.pderiv 1 fE ≠ 0 := by + rw [MvPolynomial.pderiv_map] + intro hz + apply hpartialSecond + apply MvPolynomial.map_injective (algebraMap K E) + (algebraMap K E).injective + simpa using hz + letI : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + letI : IsDomain (PlaneCurveCoordinateRing fE) := + planeCurveCoordinateRing_isDomain hfE + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let hxE := firstCoordinate_transcendental hfE + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecondE) + letI := planeCurveFirstCoordinateRatFuncAlgebra f hx + letI := planeCurveFirstCoordinateRatFuncAlgebra fE hxE + ∀ z : RatFunc K, + planeCurveFunctionFieldBaseChangeAlgHom K E f hf hfE + (algebraMap (RatFunc K) (PlaneCurveFunctionField f) z) = + algebraMap (RatFunc E) (PlaneCurveFunctionField fE) + (ratFuncCoefficientAlgHom K E z) := by + let fE := MvPolynomial.map (algebraMap K E) f + let hpartialSecondE : MvPolynomial.pderiv 1 fE ≠ 0 := by + rw [MvPolynomial.pderiv_map] + intro hz + apply hpartialSecond + apply MvPolynomial.map_injective (algebraMap K E) + (algebraMap K E).injective + simpa using hz + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let : IsDomain (PlaneCurveCoordinateRing fE) := + planeCurveCoordinateRing_isDomain hfE + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let hxE := firstCoordinate_transcendental hfE + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecondE) + let := planeCurveFirstCoordinateRatFuncAlgebra f hx + let := planeCurveFirstCoordinateRatFuncAlgebra fE hxE + let : Algebra K[X] E[X] := + (Polynomial.mapRingHom (algebraMap K E)).toAlgebra + change ∀ z : RatFunc K, + planeCurveFunctionFieldBaseChangeAlgHom K E f hf hfE + (algebraMap (RatFunc K) (PlaneCurveFunctionField f) z) = + algebraMap (RatFunc E) (PlaneCurveFunctionField fE) + (ratFuncCoefficientAlgHom K E z) + let left : RatFunc K →+* PlaneCurveFunctionField fE := + (planeCurveFunctionFieldBaseChangeAlgHom K E f hf hfE).toRingHom.comp + (algebraMap (RatFunc K) (PlaneCurveFunctionField f)) + let right : RatFunc K →+* PlaneCurveFunctionField fE := + (algebraMap (RatFunc E) (PlaneCurveFunctionField fE)).comp + (ratFuncCoefficientAlgHom K E).toRingHom + have hhom : left = right := by + apply IsFractionRing.ringHom_ext (A := K[X]) + intro p + suffices + left (algebraMap K[X] (RatFunc K) Polynomial.X) = + right (algebraMap K[X] (RatFunc K) Polynomial.X) by + let lpoly : K[X] →+* PlaneCurveFunctionField fE := + left.comp (algebraMap K[X] (RatFunc K)) + let rpoly : K[X] →+* PlaneCurveFunctionField fE := + right.comp (algebraMap K[X] (RatFunc K)) + have hpoly : lpoly = rpoly := by + apply Polynomial.ringHom_ext + · intro c + have hspecK : + ratFuncSpecialization (planeCurveFunction f 0) hx (RatFunc.C c) = + algebraMap K (PlaneCurveFunctionField f) c := by + have h := DFunLike.congr_fun + (ratFuncSpecialization_comp_polynomial_algebraMap + (planeCurveFunction f 0) hx) (Polynomial.C c) + simpa using h + have hspecE : + ratFuncSpecialization (planeCurveFunction fE 0) hxE + (RatFunc.C (algebraMap K E c)) = + algebraMap E (PlaneCurveFunctionField fE) (algebraMap K E c) := by + have h := DFunLike.congr_fun + (ratFuncSpecialization_comp_polynomial_algebraMap + (planeCurveFunction fE 0) hxE) + (Polynomial.C (algebraMap K E c)) + simpa using h + have hcoeff : + ratFuncCoefficientAlgHom K E (RatFunc.C c) = + RatFunc.C (algebraMap K E c) := by + change ratFuncCoefficientAlgHom K E + (algebraMap K[X] (RatFunc K) (Polynomial.C c)) = _ + rw [ratFuncCoefficientAlgHom_algebraMap] + simp + change planeCurveFunctionFieldBaseChangeAlgHom K E f hf hfE + (ratFuncSpecialization (planeCurveFunction f 0) hx (RatFunc.C c)) = + ratFuncSpecialization (planeCurveFunction fE 0) hxE + (ratFuncCoefficientAlgHom K E (RatFunc.C c)) + rw [hspecK, hcoeff, hspecE] + exact (planeCurveFunctionFieldBaseChangeAlgHom K E f hf hfE).commutes c + · exact this + exact DFunLike.congr_fun hpoly p + change planeCurveFunctionFieldBaseChangeAlgHom K E f hf hfE + (algebraMap (RatFunc K) (PlaneCurveFunctionField f) RatFunc.X) = + algebraMap (RatFunc E) (PlaneCurveFunctionField fE) + (ratFuncCoefficientAlgHom K E RatFunc.X) + rw [planeCurveFirstCoordinateRatFuncAlgebra_X, + planeCurveFunctionFieldBaseChangeAlgHom_function] + rw [show RatFunc.X = algebraMap K[X] (RatFunc K) Polynomial.X by rfl, + ratFuncCoefficientAlgHom_algebraMap] + rw [show algebraMap K[X] E[X] Polynomial.X = Polynomial.X by simp] + change planeCurveFunction fE 0 = + algebraMap (RatFunc E) (PlaneCurveFunctionField fE) RatFunc.X + rw [planeCurveFirstCoordinateRatFuncAlgebra_X] + intro z + exact DFunLike.congr_fun hhom z + +/-- The `K(X)`-algebra structure on the base-changed function field obtained +through the original function field. -/ +@[reducible] noncomputable def planeCurveFunctionFieldBaseChangeRatFuncAlgebra + (hf : Irreducible f) + (hfE : Irreducible (MvPolynomial.map (algebraMap K E) f)) + [Algebra.IsAlgebraic K E] + (hx : Transcendental K (planeCurveFunction f 0)) : + Algebra (RatFunc K) + (PlaneCurveFunctionField (MvPolynomial.map (algebraMap K E) f)) := by + letI : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + letI : IsDomain (PlaneCurveCoordinateRing + (MvPolynomial.map (algebraMap K E) f)) := + planeCurveCoordinateRing_isDomain hfE + exact RingHom.toAlgebra + ((planeCurveFunctionFieldBaseChangeAlgHom K E f hf hfE).toRingHom.comp + (ratFuncSpecialization (planeCurveFunction f 0) hx)) + +theorem planeCurveFunctionFieldBaseChangeRatFunc_isScalarTower + (hf : Irreducible f) + (hfE : Irreducible (MvPolynomial.map (algebraMap K E) f)) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + [Algebra.IsAlgebraic K E] : + letI : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + letI : IsDomain (PlaneCurveCoordinateRing + (MvPolynomial.map (algebraMap K E) f)) := + planeCurveCoordinateRing_isDomain hfE + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + letI := planeCurveFirstCoordinateRatFuncAlgebra f hx + letI := planeCurveFunctionFieldBaseChangeAlgebra K E f hf hfE + letI := planeCurveFunctionFieldBaseChangeRatFuncAlgebra K E f hf hfE hx + IsScalarTower (RatFunc K) (PlaneCurveFunctionField f) + (PlaneCurveFunctionField + (MvPolynomial.map (algebraMap K E) f)) := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let : IsDomain (PlaneCurveCoordinateRing + (MvPolynomial.map (algebraMap K E) f)) := + planeCurveCoordinateRing_isDomain hfE + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let := planeCurveFirstCoordinateRatFuncAlgebra f hx + let := planeCurveFunctionFieldBaseChangeAlgebra K E f hf hfE + let := planeCurveFunctionFieldBaseChangeRatFuncAlgebra K E f hf hfE hx + exact IsScalarTower.of_algebraMap_eq' rfl + +theorem planeCurveFunctionFieldBaseChangeCoefficientRatFunc_isScalarTower + (hf : Irreducible f) + (hfE : Irreducible (MvPolynomial.map (algebraMap K E) f)) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + [Algebra.IsAlgebraic K E] : + let fE := MvPolynomial.map (algebraMap K E) f + let hpartialSecondE : MvPolynomial.pderiv 1 fE ≠ 0 := by + rw [MvPolynomial.pderiv_map] + intro hz + apply hpartialSecond + apply MvPolynomial.map_injective (algebraMap K E) + (algebraMap K E).injective + simpa using hz + letI : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + letI : IsDomain (PlaneCurveCoordinateRing fE) := + planeCurveCoordinateRing_isDomain hfE + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let hxE := firstCoordinate_transcendental hfE + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecondE) + letI := ratFuncCoefficientAlgebra K E + letI := planeCurveFirstCoordinateRatFuncAlgebra fE hxE + letI := planeCurveFunctionFieldBaseChangeRatFuncAlgebra K E f hf hfE hx + IsScalarTower (RatFunc K) (RatFunc E) + (PlaneCurveFunctionField fE) := by + let fE := MvPolynomial.map (algebraMap K E) f + let hpartialSecondE : MvPolynomial.pderiv 1 fE ≠ 0 := by + rw [MvPolynomial.pderiv_map] + intro hz + apply hpartialSecond + apply MvPolynomial.map_injective (algebraMap K E) + (algebraMap K E).injective + simpa using hz + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let : IsDomain (PlaneCurveCoordinateRing fE) := + planeCurveCoordinateRing_isDomain hfE + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let hxE := firstCoordinate_transcendental hfE + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecondE) + let := ratFuncCoefficientAlgebra K E + let := planeCurveFirstCoordinateRatFuncAlgebra f hx + let := planeCurveFirstCoordinateRatFuncAlgebra fE hxE + let := planeCurveFunctionFieldBaseChangeRatFuncAlgebra K E f hf hfE hx + apply IsScalarTower.of_algebraMap_eq' + ext z + exact (planeCurveFunctionFieldBaseChange_ratFunc_commutes + K E f hf hfE hpartialSecond z) + +theorem finiteDimensional_planeCurveFunctionFieldBaseChange_over_ratFunc + (hf : Irreducible f) + (hfE : Irreducible (MvPolynomial.map (algebraMap K E) f)) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + [Algebra.IsAlgebraic K E] [FiniteDimensional K E] : + letI : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + letI : IsDomain (PlaneCurveCoordinateRing + (MvPolynomial.map (algebraMap K E) f)) := + planeCurveCoordinateRing_isDomain hfE + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + letI := planeCurveFunctionFieldBaseChangeRatFuncAlgebra K E f hf hfE hx + FiniteDimensional (RatFunc K) + (PlaneCurveFunctionField + (MvPolynomial.map (algebraMap K E) f)) := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let : IsDomain (PlaneCurveCoordinateRing + (MvPolynomial.map (algebraMap K E) f)) := + planeCurveCoordinateRing_isDomain hfE + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let := planeCurveFirstCoordinateRatFuncAlgebra f hx + let := planeCurveFunctionFieldBaseChangeAlgebra K E f hf hfE + let := planeCurveFunctionFieldBaseChangeRatFuncAlgebra K E f hf hfE hx + let : IsScalarTower (RatFunc K) (PlaneCurveFunctionField f) + (PlaneCurveFunctionField + (MvPolynomial.map (algebraMap K E) f)) := + planeCurveFunctionFieldBaseChangeRatFunc_isScalarTower + K E f hf hfE hpartialSecond + let : FiniteDimensional (RatFunc K) (PlaneCurveFunctionField f) := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let e := planeCurveFunctionFieldBaseChangeLinearEquiv K E f hf hfE + let : Module.Finite (PlaneCurveFunctionField f) + ((PlaneCurveFunctionField f) ⊗[K] E) := + Module.Finite.base_change K (PlaneCurveFunctionField f) E + let : Module.Finite (PlaneCurveFunctionField f) + (PlaneCurveFunctionField (MvPolynomial.map (algebraMap K E) f)) := + Module.Finite.equiv e + exact FiniteDimensional.trans (RatFunc K) (PlaneCurveFunctionField f) + (PlaneCurveFunctionField (MvPolynomial.map (algebraMap K E) f)) + +theorem separable_planeCurveFunctionFieldBaseChange_over_ratFunc + (hf : Irreducible f) + (hfE : Irreducible (MvPolynomial.map (algebraMap K E) f)) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + [Algebra.IsAlgebraic K E] [Fintype K] [Finite E] : + letI : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + letI : IsDomain (PlaneCurveCoordinateRing + (MvPolynomial.map (algebraMap K E) f)) := + planeCurveCoordinateRing_isDomain hfE + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + letI := planeCurveFunctionFieldBaseChangeRatFuncAlgebra K E f hf hfE hx + Algebra.IsSeparable (RatFunc K) + (PlaneCurveFunctionField + (MvPolynomial.map (algebraMap K E) f)) := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let : IsDomain (PlaneCurveCoordinateRing + (MvPolynomial.map (algebraMap K E) f)) := + planeCurveCoordinateRing_isDomain hfE + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let := planeCurveFirstCoordinateRatFuncAlgebra f hx + let := planeCurveFunctionFieldBaseChangeAlgebra K E f hf hfE + let := planeCurveFunctionFieldBaseChangeRatFuncAlgebra K E f hf hfE hx + let : IsScalarTower (RatFunc K) (PlaneCurveFunctionField f) + (PlaneCurveFunctionField + (MvPolynomial.map (algebraMap K E) f)) := + planeCurveFunctionFieldBaseChangeRatFunc_isScalarTower + K E f hf hfE hpartialSecond + let : FiniteDimensional (RatFunc K) (PlaneCurveFunctionField f) := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : Algebra.IsSeparable (RatFunc K) (PlaneCurveFunctionField f) := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let e := planeCurveFunctionFieldBaseChangeLinearEquiv K E f hf hfE + let : Module.Finite (PlaneCurveFunctionField f) + ((PlaneCurveFunctionField f) ⊗[K] E) := + Module.Finite.base_change K (PlaneCurveFunctionField f) E + let : Module.Finite (PlaneCurveFunctionField f) + (PlaneCurveFunctionField (MvPolynomial.map (algebraMap K E) f)) := + Module.Finite.equiv e + let : IsGalois (PlaneCurveFunctionField f) + (PlaneCurveFunctionField (MvPolynomial.map (algebraMap K E) f)) := + planeCurveFunctionFieldBaseChange_isGalois K E f hf hfE + exact Algebra.IsSeparable.trans (RatFunc K) (PlaneCurveFunctionField f) + (PlaneCurveFunctionField (MvPolynomial.map (algebraMap K E) f)) + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/ConstantTensorResidue.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/ConstantTensorResidue.lean new file mode 100644 index 0000000000..0ac722e5d0 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/ConstantTensorResidue.lean @@ -0,0 +1,170 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteFieldCompositum +public import Mathlib.RingTheory.LocalRing.ResidueField.Fiber + +/-! +# Residue fields of constant tensor extensions + +For a maximal ideal `q` of `S ⊗[C] R`, let `p` be its contraction to `R`. +Reduction gives a canonical map + +`S ⊗[C] κ(p) → κ(q)`. + +This file proves that the map is surjective. For finite fields, the residue +degree is therefore the least common multiple of the degrees of `S` and +`κ(p)` over `C`. The result is ring-theoretic; applying it to places in a +constant extension additionally requires identifying the normalization after +base change with the corresponding tensor ring. +-/ + +@[expose] public section + +open scoped TensorProduct + +namespace BGS.HasseWeil + +noncomputable section + +/-- The scalar extension of a commutative `C`-algebra `R` to a commutative +`C`-algebra `S`. -/ +abbrev ConstantTensorRing (C R S : Type*) + [CommRing C] [CommRing R] [CommRing S] + [Algebra C R] [Algebra C S] := + S ⊗[C] R + +section General + +variable (C R S : Type*) + [CommRing C] [CommRing R] [CommRing S] + [Algebra C R] [Algebra C S] + +local instance constantTensorRingAlgebra : + Algebra R (ConstantTensorRing C R S) := + Algebra.TensorProduct.rightAlgebra + +/-- The canonical map from the tensor product of the enlarged constants and +the contracted residue field to the upstairs residue field. -/ +def constantTensorResidueAlgHom + (q : Ideal (ConstantTensorRing C R S)) [q.IsMaximal] : + let p := q.comap + (Algebra.TensorProduct.includeRight + (R := C) (A := S) (B := R)).toRingHom + S ⊗[C] p.ResidueField →ₐ[C] q.ResidueField := by + let p := q.comap + (Algebra.TensorProduct.includeRight + (R := C) (A := S) (B := R)).toRingHom + let iR := Algebra.TensorProduct.includeRight + (R := C) (A := S) (B := R) + let iS := Algebra.TensorProduct.includeLeft + (R := C) (S := C) (A := S) (B := R) + let fS : S →ₐ[C] q.ResidueField := + (IsScalarTower.toAlgHom C (ConstantTensorRing C R S) + q.ResidueField).comp iS + let fp : p.ResidueField →ₐ[C] q.ResidueField := + Ideal.ResidueField.mapₐ p q iR rfl + exact Algebra.TensorProduct.lift fS fp fun _ _ => Commute.all _ _ + +/-- The canonical residue-field map of a constant tensor extension is +surjective. -/ +theorem constantTensorResidueAlgHom_surjective + (q : Ideal (ConstantTensorRing C R S)) [q.IsMaximal] : + Function.Surjective (constantTensorResidueAlgHom C R S q) := by + let p := q.comap + (Algebra.TensorProduct.includeRight + (R := C) (A := S) (B := R)).toRingHom + intro z + obtain ⟨a, rfl⟩ := q.algebraMap_residueField_surjective z + induction a using TensorProduct.inductionOn with + | tmul s r => + refine ⟨s ⊗ₜ[C] algebraMap R p.ResidueField r, ?_⟩ + simp only [constantTensorResidueAlgHom, + Algebra.TensorProduct.lift_tmul, AlgHom.coe_comp, + Function.comp_apply, Ideal.ResidueField.mapₐ_apply, + Algebra.TensorProduct.includeLeft_apply] + have hpmap : + (Ideal.ResidueField.map p q + (Algebra.TensorProduct.includeRight + (R := C) (A := S) (B := R)).toRingHom rfl) + (algebraMap R p.ResidueField r) = + algebraMap (ConstantTensorRing C R S) q.ResidueField + (Algebra.TensorProduct.includeRight + (R := C) (A := S) (B := R) r) := by + exact Ideal.ResidueField.map_algebraMap p q + (Algebra.TensorProduct.includeRight + (R := C) (A := S) (B := R)).toRingHom rfl r + rw [hpmap] + change + algebraMap (ConstantTensorRing C R S) q.ResidueField + (s ⊗ₜ[C] (1 : R)) * + algebraMap (ConstantTensorRing C R S) q.ResidueField + ((1 : S) ⊗ₜ[C] r) = + algebraMap (ConstantTensorRing C R S) q.ResidueField + (s ⊗ₜ[C] r) + rw [← map_mul] + simp + | add x y hx hy => + obtain ⟨x', hx'⟩ := hx + obtain ⟨y', hy'⟩ := hy + refine ⟨x' + y', ?_⟩ + rw [map_add, map_add, hx', hy'] + +end General + +section FiniteFields + +variable (C R S : Type*) + [Field C] [CommRing R] [Field S] + [Algebra C R] [Algebra C S] + +local instance finiteConstantTensorRingAlgebra : + Algebra R (ConstantTensorRing C R S) := + Algebra.TensorProduct.rightAlgebra + +/-- For finite fields, the residue field of a constant tensor extension has +degree equal to the least common multiple of the new-constant degree and the +contracted residue degree. -/ +theorem constantTensorResidue_finrank_eq_lcm + (q : Ideal (ConstantTensorRing C R S)) [q.IsMaximal] + [Finite C] [Finite S] + [Finite ((q.comap (Algebra.TensorProduct.includeRight + (R := C) (A := S) (B := R)).toRingHom).ResidueField)] + [Finite q.ResidueField] : + let p := q.comap + (Algebra.TensorProduct.includeRight + (R := C) (A := S) (B := R)).toRingHom + Module.finrank C q.ResidueField = + Nat.lcm (Module.finrank C S) + (Module.finrank C p.ResidueField) := by + let p := q.comap + (Algebra.TensorProduct.includeRight + (R := C) (A := S) (B := R)).toRingHom + let iS := Algebra.TensorProduct.includeLeft + (R := C) (S := C) (A := S) (B := R) + let iR := Algebra.TensorProduct.includeRight + (R := C) (A := S) (B := R) + let fS : S →ₐ[C] q.ResidueField := + (IsScalarTower.toAlgHom C (ConstantTensorRing C R S) + q.ResidueField).comp iS + let fp : p.ResidueField →ₐ[C] q.ResidueField := + Ideal.ResidueField.mapₐ p q iR rfl + change Module.finrank C q.ResidueField = + Nat.lcm (Module.finrank C S) + (Module.finrank C p.ResidueField) + apply finiteField_finrank_eq_lcm_of_tensorLift_surjective + C S p.ResidueField q.ResidueField fS fp + (fun _ _ => Commute.all _ _) + simpa only [constantTensorResidueAlgHom, p, iS, iR, fS, fp] using + (constantTensorResidueAlgHom_surjective C R S q) + +end FiniteFields + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/DVRLocalPoleOrder.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/DVRLocalPoleOrder.lean new file mode 100644 index 0000000000..b68910b048 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/DVRLocalPoleOrder.lean @@ -0,0 +1,97 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.LocalPoleFiltration +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.DedekindPlaceOrder + +/-! +# Local pole spaces and valuation order + +The denominator presentation of `localPoleSpace` agrees with the usual +valuation-order condition when its denominator is a power of a uniformizer. +This is the bridge from the exact DVR quotient to exhaustive function-field +places. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +open BGS.CorvajaZannier +open IsDedekindDomain +open scoped nonZeroDivisors + +noncomputable section + +variable {K R L : Type*} [Field K] [CommRing R] + [IsDedekindDomain R] [IsDiscreteValuationRing R] + [Field L] [Algebra K R] [Algebra R L] [Algebra K L] + [IsScalarTower K R L] [IsFractionRing R L] + +/-- Membership in the local denominator filtration is exactly the expected +lower bound on the discrete valuation. -/ +theorem mem_localPoleSpace_iff_finitePlaceOrder + (π : R) (hπ : Irreducible π) + (hπIdeal : (IsDiscreteValuationRing.maximalIdeal R).asIdeal = + Ideal.span {π}) (n : ℕ) (x : L) : + x ∈ localPoleSpace (K := K) (L := L) π n ↔ + x = 0 ∨ (x ≠ 0 ∧ + -(n : ℤ) ≤ finitePlaceOrder + (IsDiscreteValuationRing.maximalIdeal R) x) := by + let v := IsDiscreteValuationRing.maximalIdeal R + have hπMap : algebraMap R L π ≠ 0 := by + simpa using (IsFractionRing.injective R L).ne hπ.ne_zero + have hπPowMap : algebraMap R L (π ^ n) ≠ 0 := by + rw [map_pow] + exact pow_ne_zero n hπMap + have hπPowOrder : + finitePlaceOrderTop v (algebraMap R L (π ^ n)) = + ((n : ℤ) : WithTop ℤ) := by + rw [map_pow] + simpa only [zpow_natCast] using + (finitePlaceOrderTop_uniformizer_zpow + (L := L) v π hπ hπIdeal (n : ℤ)) + constructor + · intro hx + rw [mem_localPoleSpace_iff] at hx + by_cases hx0 : x = 0 + · exact Or.inl hx0 + obtain ⟨r, hr⟩ := hx + refine Or.inr ⟨hx0, ?_⟩ + have hregular := + finitePlaceOrderTop_algebraMap_nonnegative (L := L) v r + rw [← hr, finitePlaceOrderTop_mul, hπPowOrder, + finitePlaceOrderTop_eq_coe v x hx0] at hregular + have hregularInt : 0 ≤ (n : ℤ) + finitePlaceOrder v x := by + exact_mod_cast hregular + change -(n : ℤ) ≤ finitePlaceOrder v x + omega + · rintro (rfl | ⟨hx0, hx⟩) + · exact (localPoleSpace (K := K) (L := L) π n).zero_mem + change -(n : ℤ) ≤ finitePlaceOrder v x at hx + rw [mem_localPoleSpace_iff] + let y : L := algebraMap R L (π ^ n) * x + have hy0 : y ≠ 0 := mul_ne_zero hπPowMap hx0 + have hyOrderTop : (0 : WithTop ℤ) ≤ finitePlaceOrderTop v y := by + dsimp only [y] + rw [finitePlaceOrderTop_mul, hπPowOrder, + finitePlaceOrderTop_eq_coe v x hx0] + exact_mod_cast (show 0 ≤ (n : ℤ) + finitePlaceOrder v x by omega) + have hyOrder : 0 ≤ finitePlaceOrder v y := by + rw [finitePlaceOrderTop_eq_coe v y hy0] at hyOrderTop + exact_mod_cast hyOrderTop + have hyValuation : v.valuation L y ≤ 1 := by + rw [valuation_eq_exp_neg_finitePlaceOrder v y hy0] + simpa only [← WithZero.exp_zero] using + (WithZero.exp_le_exp.mpr (by omega : -finitePlaceOrder v y ≤ 0)) + obtain ⟨r, hr⟩ := IsDiscreteValuationRing.exists_lift_of_le_one hyValuation + exact ⟨r, hr.symm⟩ + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/DedekindDifferentLocalTrace.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/DedekindDifferentLocalTrace.lean new file mode 100644 index 0000000000..2622e147b4 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/DedekindDifferentLocalTrace.lean @@ -0,0 +1,388 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import Mathlib.RingTheory.DedekindDomain.Different +public import Mathlib.RingTheory.DedekindDomain.Factorization +public import Mathlib.RingTheory.DedekindDomain.AdicValuation + +/-! +# Local traces and the different + +Relate different multiplicities to the trace-dual lattice and clear the finitely many bad +valuation bounds by a base multiplier. +-/ + +@[expose] public section + +open scoped nonZeroDivisors + +open Set Function UniqueFactorizationMonoid IsDedekindDomain + IsDedekindDomain.HeightOneSpectrum + +noncomputable section + +variable {R : Type*} [CommRing R] [IsDedekindDomain R] +variable {K : Type*} [Field K] [Algebra R K] [IsFractionRing R K] + +namespace FractionalIdeal + +theorem le_iff_count_ge {I J : FractionalIdeal R⁰ K} (hI : I ≠ 0) (hJ : J ≠ 0) : + I ≤ J ↔ ∀ v : HeightOneSpectrum R, count K v J ≤ count K v I := by + constructor + · intro h v + exact count_mono K v hI h + · intro h + rw [← finprod_heightOneSpectrum_factorization' (K := K) hI, + ← finprod_heightOneSpectrum_factorization' (K := K) hJ] + have hfinite (A : FractionalIdeal R⁰ K) : + (fun v : HeightOneSpectrum R ↦ + (v.asIdeal : FractionalIdeal R⁰ K) ^ count K v A).HasFiniteMulSupport := by + have hcount : Set.Finite {v : HeightOneSpectrum R | count K v A ≠ 0} := by + simpa only [Filter.eventually_cofinite] using finite_factors (K := K) A + exact hcount.subset fun v hv hzero ↦ by + apply hv + simp [hzero] + apply finprod_le_finprod + · exact hfinite I + · exact hfinite J + · intro v + exact zpow_le_zpow_right_of_le_one₀ + (show 0 < (v.asIdeal : FractionalIdeal R⁰ K) from bot_lt_iff_ne_bot.mpr + (coeIdeal_ne_zero.mpr v.ne_bot)) + coeIdeal_le_one (h v) + +theorem count_coeIdeal_eq_multiplicity (I : Ideal R) (hI : I ≠ ⊥) + (v : HeightOneSpectrum R) : + count K v (I : FractionalIdeal R⁰ K) = (multiplicity v.asIdeal I : ℤ) := by + rw [count_coe K v hI, + Ideal.count_associates_factors_eq hI v.isPrime v.ne_bot, + HeightOneSpectrum.count_normalizedFactors_eq_multiplicity hI] + +theorem mem_iff_count_ge {I : FractionalIdeal R⁰ K} (hI : I ≠ 0) + {x : K} (hx : x ≠ 0) : + x ∈ I ↔ ∀ v : HeightOneSpectrum R, + count K v I ≤ count K v (spanSingleton R⁰ x) := by + rw [← spanSingleton_le_iff_mem, + le_iff_count_ge (spanSingleton_ne_zero_iff.mpr hx) hI] + +end FractionalIdeal + +universe u + +variable (A K₀ : Type*) {L : Type u} {B : Type*} +variable [CommRing A] [Field K₀] [CommRing B] [Field L] +variable [Algebra A K₀] [Algebra B L] [Algebra A B] [Algebra K₀ L] [Algebra A L] +variable [IsScalarTower A K₀ L] [IsScalarTower A B L] +variable [IsDomain A] [IsFractionRing A K₀] +variable [FiniteDimensional K₀ L] [Algebra.IsSeparable K₀ L] +variable [IsIntegralClosure B A L] [IsFractionRing B L] [IsIntegrallyClosed A] +variable [IsDedekindDomain B] +variable [Module.IsTorsionFree A B] +variable [Algebra.IsIntegral A B] + +namespace HeightOneSpectrum + +omit [IsIntegrallyClosed A] [Module.IsTorsionFree A B] in +theorem algebraMap_mem_pow_of_mem_under_pow + (q : HeightOneSpectrum B) (c : A) (n : ℕ) + (hc : c ∈ (q.under A).asIdeal ^ n) : + algebraMap A B c ∈ q.asIdeal ^ n := by + have hmap : + algebraMap A B c ∈ + Ideal.map (algebraMap A B) ((q.under A).asIdeal ^ n) := + Ideal.mem_map_of_mem (algebraMap A B) hc + rw [Ideal.map_pow] at hmap + exact (pow_le_pow_left' + (Ideal.map_le_iff_le_comap.mpr (show + (q.under A).asIdeal ≤ q.asIdeal.comap (algebraMap A B) from le_rfl)) n) hmap + +omit [IsIntegralClosure B A L] in +omit [IsIntegrallyClosed A] in +theorem natCast_le_count_spanSingleton_algebraMap_of_mem_under_pow + (q : HeightOneSpectrum B) (c : A) (n : ℕ) (hc0 : c ≠ 0) + (hc : c ∈ (q.under A).asIdeal ^ n) : + (n : ℤ) ≤ FractionalIdeal.count L q + (FractionalIdeal.spanSingleton B⁰ (algebraMap A L c)) := by + have hcB : algebraMap A B c ∈ q.asIdeal ^ n := + algebraMap_mem_pow_of_mem_under_pow A q c n hc + have hcL : algebraMap A L c ∈ + ((q.asIdeal ^ n : Ideal B) : FractionalIdeal B⁰ L) := by + rw [FractionalIdeal.mem_coeIdeal] + refine ⟨algebraMap A B c, hcB, ?_⟩ + exact (IsScalarTower.algebraMap_apply A B L c).symm + have hle : + FractionalIdeal.spanSingleton B⁰ (algebraMap A L c) ≤ + ((q.asIdeal ^ n : Ideal B) : FractionalIdeal B⁰ L) := + FractionalIdeal.spanSingleton_le_iff_mem.mpr hcL + have hcount := FractionalIdeal.count_mono L q + (FractionalIdeal.spanSingleton_ne_zero_iff.mpr + (by + rw [IsScalarTower.algebraMap_apply A B L] + simpa using (IsFractionRing.injective B L).ne + ((FaithfulSMul.algebraMap_injective A B).ne hc0))) hle + simpa [FractionalIdeal.coeIdeal_pow, FractionalIdeal.count_pow, + FractionalIdeal.count_self] using hcount + +end HeightOneSpectrum + +namespace BGS.HasseWeil + +omit [Algebra.IsIntegral A B] in +theorem count_dual_one_eq_neg_different_multiplicity + (q : HeightOneSpectrum B) : + FractionalIdeal.count L q + (FractionalIdeal.dual A K₀ (1 : FractionalIdeal B⁰ L)) = + -(multiplicity q.asIdeal (differentIdeal A B) : ℤ) := by + have hdiff : differentIdeal A B ≠ ⊥ := by + apply (FractionalIdeal.coeIdeal_ne_zero (K := L)).mp + rw [coeIdeal_differentIdeal A K₀ L B] + exact inv_ne_zero (FractionalIdeal.dual_ne_zero A K₀ + (by exact one_ne_zero : (1 : FractionalIdeal B⁰ L) ≠ 0)) + have hdual : + FractionalIdeal.dual A K₀ (1 : FractionalIdeal B⁰ L) = + ((differentIdeal A B : Ideal B) : FractionalIdeal B⁰ L)⁻¹ := by + apply inv_injective + rw [inv_inv, ← coeIdeal_differentIdeal A K₀ L B] + rw [hdual, FractionalIdeal.count_inv, + FractionalIdeal.count_coeIdeal_eq_multiplicity (K := L) _ hdiff] + +omit [Algebra.IsIntegral A B] in +theorem mem_dual_one_iff_different_multiplicity_le_count + {x : L} (hx : x ≠ 0) : + x ∈ FractionalIdeal.dual A K₀ (1 : FractionalIdeal B⁰ L) ↔ + ∀ q : HeightOneSpectrum B, + -(multiplicity q.asIdeal (differentIdeal A B) : ℤ) ≤ + FractionalIdeal.count L q (FractionalIdeal.spanSingleton B⁰ x) := by + rw [FractionalIdeal.mem_iff_count_ge + (FractionalIdeal.dual_ne_zero A K₀ + (by exact one_ne_zero : (1 : FractionalIdeal B⁰ L) ≠ 0)) hx] + exact forall_congr' fun q ↦ by + rw [count_dual_one_eq_neg_different_multiplicity A K₀ q] + +omit [Algebra.IsIntegral A B] in +theorem trace_mem_algebraMap_range_of_different_multiplicity_le_count + {z : L} (hz : z ≠ 0) + (hcount : ∀ q : HeightOneSpectrum B, + -(multiplicity q.asIdeal (differentIdeal A B) : ℤ) ≤ + FractionalIdeal.count L q (FractionalIdeal.spanSingleton B⁰ z)) : + Algebra.trace K₀ L z ∈ (algebraMap A K₀).range := by + have hzdual : z ∈ + FractionalIdeal.dual A K₀ (1 : FractionalIdeal B⁰ L) := + (mem_dual_one_iff_different_multiplicity_le_count A K₀ hz).mpr hcount + have htrace := (FractionalIdeal.mem_dual + (A := A) (K := K₀) (I := (1 : FractionalIdeal B⁰ L)) + (by exact one_ne_zero)).mp hzdual (1 : L) (by simp) + simpa [Algebra.traceForm_apply] using htrace + +omit [Algebra A L] [IsScalarTower A B L] [IsIntegralClosure B A L] [IsIntegrallyClosed A] + [Algebra.IsIntegral A B] in +theorem finite_badDifferentCount_set (hdiff : differentIdeal A B ≠ ⊥) (y : L) : + Set.Finite {q : HeightOneSpectrum B | + ¬ (-(multiplicity q.asIdeal (differentIdeal A B) : ℤ) ≤ + FractionalIdeal.count L q (FractionalIdeal.spanSingleton B⁰ y))} := by + have hdiffFinite : Set.Finite {q : HeightOneSpectrum B | + FractionalIdeal.count L q + ((differentIdeal A B : Ideal B) : FractionalIdeal B⁰ L) ≠ 0} := by + simpa only [Filter.eventually_cofinite] using + FractionalIdeal.finite_factors + (K := L) ((differentIdeal A B : Ideal B) : FractionalIdeal B⁰ L) + have hyFinite : Set.Finite {q : HeightOneSpectrum B | + FractionalIdeal.count L q (FractionalIdeal.spanSingleton B⁰ y) ≠ 0} := by + simpa only [Filter.eventually_cofinite] using + FractionalIdeal.finite_factors + (K := L) (FractionalIdeal.spanSingleton B⁰ y) + refine (hdiffFinite.union hyFinite).subset ?_ + intro q hbad + by_contra hq + have hqdiff : FractionalIdeal.count L q + ((differentIdeal A B : Ideal B) : FractionalIdeal B⁰ L) = 0 := by + by_contra hne + exact hq (by + rw [Set.mem_union, Set.mem_ofPred_eq, Set.mem_ofPred_eq] + exact Or.inl hne) + have hqy : FractionalIdeal.count L q + (FractionalIdeal.spanSingleton B⁰ y) = 0 := by + by_contra hne + exact hq (by + rw [Set.mem_union, Set.mem_ofPred_eq, Set.mem_ofPred_eq] + exact Or.inr hne) + apply hbad + rw [← FractionalIdeal.count_coeIdeal_eq_multiplicity + (K := L) (differentIdeal A B) hdiff, hqdiff, hqy] + simp + +omit [IsIntegralClosure B A L] in +omit [IsIntegrallyClosed A] in +theorem exists_base_multiplier_clearing_different_counts + [IsDedekindDomain A] + (hdiff : differentIdeal A B ≠ ⊥) + (p : HeightOneSpectrum A) {y : L} (hy : y ≠ 0) + (hlocal : ∀ q : HeightOneSpectrum B, + q.under A = p → + -(multiplicity q.asIdeal (differentIdeal A B) : ℤ) ≤ + FractionalIdeal.count L q (FractionalIdeal.spanSingleton B⁰ y)) : + ∃ c : A, c ∉ p.asIdeal ∧ + ∀ q : HeightOneSpectrum B, + -(multiplicity q.asIdeal (differentIdeal A B) : ℤ) ≤ + FractionalIdeal.count L q + (FractionalIdeal.spanSingleton B⁰ (algebraMap A L c * y)) := by + classical + let bad : Finset (HeightOneSpectrum B) := + (finite_badDifferentCount_set (A := A) (B := B) (L := L) hdiff y).toFinset + have hbad_iff (q : HeightOneSpectrum B) : q ∈ bad ↔ + ¬ (-(multiplicity q.asIdeal (differentIdeal A B) : ℤ) ≤ + FractionalIdeal.count L q (FractionalIdeal.spanSingleton B⁰ y)) := by + simp [bad] + let need : HeightOneSpectrum B → ℕ := fun q => + Int.toNat (-(multiplicity q.asIdeal (differentIdeal A B) : ℤ) - + FractionalIdeal.count L q (FractionalIdeal.spanSingleton B⁰ y)) + let N : ℕ := ∑ q ∈ bad, need q + have hbelow_ne (q : HeightOneSpectrum B) (hq : q ∈ bad) : + (q.under A).asIdeal ≠ p.asIdeal := by + intro heq + have heq' : q.under A = p := + HeightOneSpectrum.ext heq + exact (hbad_iff q).mp hq (hlocal q heq') + let selected : Finset (Ideal A) := + insert p.asIdeal + (bad.image fun q => (q.under A).asIdeal) + have hselectedPrime : ∀ P ∈ selected, Prime P := by + intro P hP + rw [Finset.mem_insert] at hP + rcases hP with rfl | hP + · exact p.prime + · rcases Finset.mem_image.mp hP with ⟨q, hq, rfl⟩ + exact (q.under A).prime + let exponent : Ideal A → ℕ := fun P => if P = p.asIdeal then 1 else N + let target : selected → A := fun P => if (P : Ideal A) = p.asIdeal then 1 else 0 + obtain ⟨c, hc⟩ := IsDedekindDomain.exists_forall_sub_mem_ideal + (s := selected) (fun P : Ideal A => P) exponent hselectedPrime + (by + intro P hP Q hQ hPQ + simpa using hPQ) + target + have hpSelected : p.asIdeal ∈ selected := Finset.mem_insert_self _ _ + have hcpow := hc p.asIdeal hpSelected + have hcp : c - 1 ∈ p.asIdeal := by + simpa [target, exponent] using hcpow + have hcnot : c ∉ p.asIdeal := by + intro hcP + have hone : (1 : A) ∈ p.asIdeal := by + have hsub := p.asIdeal.sub_mem hcP hcp + convert hsub using 1 + ring + exact p.isPrime.ne_top ((Ideal.eq_top_iff_one p.asIdeal).mpr hone) + have hc0 : c ≠ 0 := fun hcZero => hcnot (hcZero.symm ▸ p.asIdeal.zero_mem) + refine ⟨c, hcnot, ?_⟩ + intro q + have hcL0 : algebraMap A L c ≠ 0 := by + rw [IsScalarTower.algebraMap_apply A B L] + simpa using (IsFractionRing.injective B L).ne + ((FaithfulSMul.algebraMap_injective A B).ne hc0) + have hspanCount : + FractionalIdeal.count L q + (FractionalIdeal.spanSingleton B⁰ (algebraMap A L c * y)) = + FractionalIdeal.count L q + (FractionalIdeal.spanSingleton B⁰ (algebraMap A L c)) + + FractionalIdeal.count L q (FractionalIdeal.spanSingleton B⁰ y) := by + rw [← FractionalIdeal.spanSingleton_mul_spanSingleton, + FractionalIdeal.count_mul] + · exact FractionalIdeal.spanSingleton_ne_zero_iff.mpr hcL0 + · exact FractionalIdeal.spanSingleton_ne_zero_iff.mpr hy + rw [hspanCount] + by_cases hq : q ∈ bad + · have hqSelected : (q.under A).asIdeal ∈ selected := by + change (q.under A).asIdeal ∈ + insert p.asIdeal + (bad.image fun r => (r.under A).asIdeal) + exact Finset.mem_insert.mpr <| Or.inr <| + Finset.mem_image.mpr ⟨q, hq, rfl⟩ + have hcqpow := hc (q.under A).asIdeal hqSelected + have hrne : q.asIdeal.comap (algebraMap A B) ≠ p.asIdeal := by + simpa using hbelow_ne q hq + have hcq : c ∈ (q.under A).asIdeal ^ N := by + simpa [target, exponent, hrne] using hcqpow + have hNcount : (N : ℤ) ≤ + FractionalIdeal.count L q + (FractionalIdeal.spanSingleton B⁰ (algebraMap A L c)) := + HeightOneSpectrum.natCast_le_count_spanSingleton_algebraMap_of_mem_under_pow + (A := A) (B := B) (L := L) q c N hc0 hcq + have hneedNonneg : 0 ≤ + -(multiplicity q.asIdeal (differentIdeal A B) : ℤ) - + FractionalIdeal.count L q (FractionalIdeal.spanSingleton B⁰ y) := by + have := (hbad_iff q).mp hq + omega + have hneedCast : (need q : ℤ) = + -(multiplicity q.asIdeal (differentIdeal A B) : ℤ) - + FractionalIdeal.count L q (FractionalIdeal.spanSingleton B⁰ y) := by + exact Int.toNat_of_nonneg hneedNonneg + have hneedN : need q ≤ N := by + dsimp [N] + exact Finset.single_le_sum (fun i _ => Nat.zero_le (need i)) hq + omega + · have hgood : + -(multiplicity q.asIdeal (differentIdeal A B) : ℤ) ≤ + FractionalIdeal.count L q (FractionalIdeal.spanSingleton B⁰ y) := by + by_contra hnot + exact hq ((hbad_iff q).mpr hnot) + have hzeroCount : (0 : ℤ) ≤ + FractionalIdeal.count L q + (FractionalIdeal.spanSingleton B⁰ (algebraMap A L c)) := + HeightOneSpectrum.natCast_le_count_spanSingleton_algebraMap_of_mem_under_pow + (A := A) (B := B) (L := L) q c 0 hc0 (by simp) + omega + +omit [IsIntegrallyClosed A] in +theorem valuation_trace_le_one_of_different_count_bounds_over + [IsDedekindDomain A] + (p : HeightOneSpectrum A) {y : L} (hy : y ≠ 0) + (hlocal : ∀ q : HeightOneSpectrum B, + q.under A = p → + -(multiplicity q.asIdeal (differentIdeal A B) : ℤ) ≤ + FractionalIdeal.count L q (FractionalIdeal.spanSingleton B⁰ y)) : + p.valuation K₀ (Algebra.trace K₀ L y) ≤ 1 := by + have hdiff : differentIdeal A B ≠ ⊥ := by + apply (FractionalIdeal.coeIdeal_ne_zero (K := L)).mp + rw [coeIdeal_differentIdeal A K₀ L B] + exact inv_ne_zero (FractionalIdeal.dual_ne_zero A K₀ + (by exact one_ne_zero : (1 : FractionalIdeal B⁰ L) ≠ 0)) + obtain ⟨c, hcnot, hcount⟩ := + exists_base_multiplier_clearing_different_counts + (A := A) (B := B) (L := L) hdiff p hy hlocal + have hc0 : c ≠ 0 := fun hcZero => hcnot (hcZero.symm ▸ p.asIdeal.zero_mem) + have hcL0 : algebraMap A L c ≠ 0 := by + rw [IsScalarTower.algebraMap_apply A B L] + simpa using (IsFractionRing.injective B L).ne + ((FaithfulSMul.algebraMap_injective A B).ne hc0) + have hcy0 : algebraMap A L c * y ≠ 0 := mul_ne_zero hcL0 hy + have htraceRange : + Algebra.trace K₀ L (algebraMap A L c * y) ∈ (algebraMap A K₀).range := + trace_mem_algebraMap_range_of_different_multiplicity_le_count + (A := A) (K₀ := K₀) (B := B) (L := L) hcy0 hcount + obtain ⟨a, ha⟩ := htraceRange + have htraceSmul : + Algebra.trace K₀ L (algebraMap A L c * y) = + algebraMap A K₀ c * Algebra.trace K₀ L y := by + rw [IsScalarTower.algebraMap_apply A K₀ L] + simpa [Algebra.smul_def] using + (Algebra.trace K₀ L).map_smul (algebraMap A K₀ c) y + have hcVal : p.valuation K₀ (algebraMap A K₀ c) = 1 := + (HeightOneSpectrum.valuation_eq_one_iff_notMem (K := K₀) p).mpr hcnot + calc + p.valuation K₀ (Algebra.trace K₀ L y) = + p.valuation K₀ (algebraMap A K₀ c) * + p.valuation K₀ (Algebra.trace K₀ L y) := by rw [hcVal, one_mul] + _ = p.valuation K₀ + (algebraMap A K₀ c * Algebra.trace K₀ L y) := by + rw [map_mul] + _ = p.valuation K₀ + (Algebra.trace K₀ L (algebraMap A L c * y)) := by rw [htraceSmul] + _ = p.valuation K₀ (algebraMap A K₀ a) := by rw [← ha] + _ ≤ 1 := p.valuation_le_one a + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtension.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtension.lean new file mode 100644 index 0000000000..7bfc2b07f8 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtension.lean @@ -0,0 +1,234 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import Mathlib.FieldTheory.LinearDisjoint +public import Mathlib.LinearAlgebra.Dimension.OrzechProperty + +/-! +# Exact constants and finite constant extensions + +Let `N / C` be a field extension whose exact constant field is `C`, meaning +that no element of `N \ C` is algebraic over `C`. If `S / C` is finite +Galois, then `S` and `N` are linearly disjoint over `C`. Consequently the +tensor product `S ⊗[C] N` is a field, and its degree over `N` is `[S : C]`. + +Mathlib's finite-Galois intersection criterion assumes both intermediate +fields are finite over the base. The first theorem below proves the variant +needed here: only the Galois field on the left must be finite. This is the +algebraic foundation for the constant-extension twists in Stichtenoth, +Proposition 5.2.8. +-/ + +@[expose] public section + +open scoped TensorProduct + +namespace BGS.HasseWeil + +noncomputable section + +universe u v + +section LinearDisjoint + +variable {F : Type u} {E : Type v} [Field F] [Field E] [Algebra F E] + +private theorem linearDisjoint_of_inf_eq_bot_of_sup_eq_top + (A B : IntermediateField F E) + [IsGalois F A] [FiniteDimensional F A] + (hsup : A ⊔ B = ⊤) (hinf : A ⊓ B = ⊥) : A.LinearDisjoint B := by + let ι := Module.Free.ChooseBasisIndex F A + let a : Module.Basis ι F A := Module.Free.chooseBasis F A + let : Fintype ι := Fintype.ofFinite ι + have hAspan : A.toSubalgebra.toSubmodule = + Submodule.span F (Set.range (A.val ∘ a)) := by + calc + A.toSubalgebra.toSubmodule = + Submodule.map A.val.toLinearMap (⊤ : Submodule F A) := by + ext x + simp + _ = Submodule.map A.val.toLinearMap + (Submodule.span F (Set.range a)) := by rw [Module.Basis.span_eq a] + _ = Submodule.span F (Set.range (A.val ∘ a)) := by + rw [Submodule.map_span] + congr 1 + ext x + simp [Function.comp_apply] + have hAdjoinField : IntermediateField.adjoin B (A : Set E) = ⊤ := by + apply IntermediateField.restrictScalars_injective F + rw [IntermediateField.restrictScalars_adjoin_eq_sup] + simpa [sup_comm] using hsup + have hAdjoin : Algebra.adjoin B (A : Set E) = ⊤ := by + rw [← IntermediateField.adjoin_intermediateField_toSubalgebra_of_isAlgebraic_right B A, + hAdjoinField] + rfl + have hspan : Submodule.span B (Set.range (A.val ∘ a)) = ⊤ := by + have hAdjoin' : Algebra.adjoin B (A.toSubalgebra : Set E) = ⊤ := by + simpa only [IntermediateField.coe_toSubalgebra] using hAdjoin + rw [← A.toSubalgebra.adjoin_eq_span_of_eq_span B hAspan, hAdjoin'] + rfl + let : FiniteDimensional B E := by + have hfinite : Module.Finite B + (Submodule.span B (Set.range (A.val ∘ a))) := + Module.Finite.span_of_finite B (Set.toFinite _) + rw [hspan] at hfinite + exact Module.Finite.equiv (Submodule.topEquiv (R := B) (M := E)) + let : IsGalois B E := IsGalois.sup_right A B hsup + have hfinrank : Module.finrank B E = Module.finrank F A := by + rw [← IsGalois.card_aut_eq_finrank, ← IsGalois.card_aut_eq_finrank] + exact Nat.card_congr <| Equiv.ofBijective + (IntermediateField.restrictRestrictAlgEquivMapHom F A B E) + ⟨IntermediateField.restrictRestrictAlgEquivMapHom_injective A B hsup, + IntermediateField.restrictRestrictAlgEquivMapHom_surjective A B hinf⟩ + apply IntermediateField.LinearDisjoint.of_basis_left a + apply linearIndependent_of_top_le_span_of_card_eq_finrank + · exact hspan.ge + · rw [hfinrank] + exact (Module.finrank_eq_card_basis a).symm + +/-- A finite Galois intermediate field is linearly disjoint from any other +intermediate field having trivial intersection with it. Unlike Mathlib's +finite intersection criterion, the field on the right need not be finite over +the base. -/ +theorem linearDisjoint_of_inf_eq_bot_of_finite_galois_left + (A B : IntermediateField F E) + [IsGalois F A] [FiniteDimensional F A] + (hinf : A ⊓ B = ⊥) : A.LinearDisjoint B := by + let D : IntermediateField F E := A ⊔ B + let A' : IntermediateField F D := A.restrict le_sup_left + let B' : IntermediateField F D := B.restrict le_sup_right + have hA : IntermediateField.map D.val A' = A := + IntermediateField.lift_restrict le_sup_left + have hB : IntermediateField.map D.val B' = B := + IntermediateField.lift_restrict le_sup_right + suffices A'.LinearDisjoint B' from + hA ▸ hB ▸ IntermediateField.LinearDisjoint.map this D.val + have hsup : A' ⊔ B' = ⊤ := by + rw [← IntermediateField.lift_inj, IntermediateField.lift_top, + IntermediateField.lift_sup, IntermediateField.lift_restrict le_sup_left, + IntermediateField.lift_restrict le_sup_right] + have hinf' : A' ⊓ B' = ⊥ := by + rw [← IntermediateField.lift_inj, IntermediateField.lift_bot, + IntermediateField.lift_inf, IntermediateField.lift_restrict le_sup_left, + IntermediateField.lift_restrict le_sup_right, hinf] + let eA : A ≃ₐ[F] A' := IntermediateField.restrictAlgEquiv .. + let : FiniteDimensional F A' := Module.Finite.equiv eA.toLinearEquiv + have : IsGalois F A' := IsGalois.of_algEquiv eA + exact linearDisjoint_of_inf_eq_bot_of_sup_eq_top A' B' hsup hinf' + +end LinearDisjoint + +section Constants + +variable (C N S : Type*) [Field C] [Field N] [Field S] + [Algebra C N] [Algebra C S] + [FiniteDimensional C S] [IsGalois C S] + +/-- Inside a common algebraic closure, a finite Galois constant extension and +a field with exact constant field `C` are linearly disjoint over `C`. -/ +theorem exactConstantExtensionImages_linearDisjoint + (hExact : algebraicClosure C N = + (⊥ : IntermediateField C N)) : + let Ω := AlgebraicClosure N + let fS : S →ₐ[C] Ω := IsAlgClosed.lift + fS.fieldRange.LinearDisjoint + (IsScalarTower.toAlgHom C N Ω).fieldRange := by + let Ω := AlgebraicClosure N + let fS : S →ₐ[C] Ω := IsAlgClosed.lift + let : Algebra S Ω := fS.toAlgebra + let : IsScalarTower C S Ω := IsScalarTower.of_algebraMap_eq' (by + ext c + exact (fS.commutes c).symm) + let A := fS.fieldRange + let B := (IsScalarTower.toAlgHom C N Ω).fieldRange + have hInf : A ⊓ B = (⊥ : IntermediateField C Ω) := by + refine eq_bot_iff.mpr ?_ + intro x hx + obtain ⟨s, hs⟩ := hx.1 + obtain ⟨n, hn⟩ := hx.2 + have hxAlg : IsAlgebraic C x := by + rw [← hs] + exact (Algebra.IsIntegral.isIntegral s).map fS |>.isAlgebraic + have hnAlg : IsAlgebraic C n := by + apply (isAlgebraic_algHom_iff + (IsScalarTower.toAlgHom C N Ω) + (IsScalarTower.toAlgHom C N Ω).injective).mp + have hn' : (IsScalarTower.toAlgHom C N Ω) n = x := hn + rw [hn'] + exact hxAlg + have hnBot : n ∈ (⊥ : IntermediateField C N) := by + rw [← hExact] + exact mem_algebraicClosure_iff.mpr hnAlg + obtain ⟨c, hc⟩ := IntermediateField.mem_bot.mp hnBot + apply IntermediateField.mem_bot.mpr + refine ⟨c, ?_⟩ + rw [← hn, ← hc] + rfl + let eA : S ≃ₐ[C] A := AlgEquiv.ofInjectiveField fS + let : FiniteDimensional C A := Module.Finite.equiv eA.toLinearEquiv + have : IsGalois C A := IsGalois.of_algEquiv eA + exact linearDisjoint_of_inf_eq_bot_of_finite_galois_left A B hInf + +/-- If `C` is the exact constant field of `N`, adjoining any finite Galois +extension `S / C` by tensor product produces a field. -/ +theorem exactConstantExtensionTensor_isField + (hExact : algebraicClosure C N = + (⊥ : IntermediateField C N)) : + IsField (S ⊗[C] N) := by + exact IntermediateField.LinearDisjoint.isField_of_isAlgebraic' + (exactConstantExtensionImages_linearDisjoint C N S hExact) + (Or.inl (Algebra.IsAlgebraic.of_finite C S)) + +/-- The algebra structure on `S ⊗[C] N` induced by the copy of `N` in the +right tensor factor. -/ +@[reducible] noncomputable def exactConstantExtensionAlgebra : + Algebra N (S ⊗[C] N) := + (Algebra.TensorProduct.includeRight (R := C) (A := S) (B := N)).toAlgebra + +/-- Commuting the tensor factors identifies the constant extension with the +usual scalar extension of `S` from `C` to `N`. -/ +noncomputable def exactConstantExtensionLinearEquiv : + letI := exactConstantExtensionAlgebra C N S + N ⊗[C] S ≃ₗ[N] S ⊗[C] N := by + letI := exactConstantExtensionAlgebra C N S + let e := (Algebra.TensorProduct.comm C N S).toRingEquiv + exact + { toEquiv := e.toEquiv + map_add' := map_add e + map_smul' := by + intro x z + refine TensorProduct.inductionOn (motive := fun z ↦ e (x • z) = x • e z) z + (fun y s => ?_) + (fun z w hz hw => ?_) + · change e ((x * y) ⊗ₜ[C] s) = + e (x ⊗ₜ[C] (1 : S)) * e (y ⊗ₜ[C] s) + rw [← map_mul] + simp + · rw [smul_add] + calc + e (x • z + x • w) = e (x • z) + e (x • w) := map_add e _ _ + _ = x • e z + x • e w := congrArg₂ (· + ·) hz hw + _ = x • e (z + w) := by rw [map_add, smul_add] } + +omit [FiniteDimensional C S] [IsGalois C S] in +/-- A finite constant extension has the expected degree over the original +field. -/ +theorem exactConstantExtension_finrank : + letI := exactConstantExtensionAlgebra C N S + Module.finrank N (S ⊗[C] N) = Module.finrank C S := by + let := exactConstantExtensionAlgebra C N S + calc + Module.finrank N (S ⊗[C] N) = Module.finrank N (N ⊗[C] S) := + (exactConstantExtensionLinearEquiv C N S).finrank_eq.symm + _ = Module.finrank C S := Module.finrank_baseChange + +end Constants + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionAutomorphism.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionAutomorphism.lean new file mode 100644 index 0000000000..afad8c363f --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionAutomorphism.lean @@ -0,0 +1,328 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtension +public import LeanPool.MarkoffModP.BGS.HasseWeil.ConstantFieldAutomorphism +public import Mathlib.GroupTheory.NoncommCoprod + +/-! +# Galois groups of exact constant extensions + +For a tower `C ⊆ L ⊆ N` and a finite Galois extension `S / C`, the tensor +compositum `S ⊗[C] N` carries two commuting actions: constants act on the left +factor and `Gal(N/L)` acts on the right factor. The actions are jointly +faithful without any exact-constant hypothesis. + +If `C` is the exact constant field of `N`, the tensor product is a field. A +degree count then proves that the combined action exhausts its full Galois +group over `L`: + +`Gal((S ⊗[C] N) / L) ≃ Gal(S/C) × Gal(N/L)`. + +This is the direct-product statement used in Stichtenoth, Proposition 5.2.8. +-/ + +@[expose] public section + +open scoped TensorProduct + +namespace BGS.HasseWeil + +noncomputable section + +/-- The tensor compositum of a field `N` and a constant extension `S / C`. -/ +abbrev ExactConstantExtension (C N S : Type*) [CommRing C] [CommRing N] + [CommRing S] [Algebra C N] [Algebra C S] := + S ⊗[C] N + +section Algebra + +variable (C L N S : Type*) [Field C] [Field L] [Field N] [Field S] + [Algebra L N] [Algebra C N] [Algebra C S] + +/-- The field structure on the tensor compositum supplied by exact constants +and finite Galois constant extension. -/ +@[reducible] noncomputable def exactConstantExtensionField + [FiniteDimensional C S] [IsGalois C S] + (hExact : algebraicClosure C N = (⊥ : IntermediateField C N)) : + Field (ExactConstantExtension C N S) := + (exactConstantExtensionTensor_isField C N S hExact).toField + +/-- The `L`-algebra structure on the tensor compositum induced by the right +factor `N`. -/ +@[reducible] noncomputable def exactConstantExtensionBaseAlgebra : + Algebra L (ExactConstantExtension C N S) := + RingHom.toAlgebra + ((Algebra.TensorProduct.includeRight + (R := C) (A := S) (B := N)).toRingHom.comp (algebraMap L N)) + +/-- The `L ⊆ N ⊆ S ⊗[C] N` scalar tower. -/ +theorem exactConstantExtensionBaseTower : + letI := exactConstantExtensionBaseAlgebra C L N S + letI := exactConstantExtensionAlgebra C N S + IsScalarTower L N (ExactConstantExtension C N S) := by + let := exactConstantExtensionBaseAlgebra C L N S + let := exactConstantExtensionAlgebra C N S + exact IsScalarTower.of_algebraMap_eq' rfl + +end Algebra + +section Actions + +variable (C L N S : Type*) [Field C] [Field L] [Field N] [Field S] + [Algebra C L] [Algebra L N] [Algebra C N] [IsScalarTower C L N] + [Algebra C S] + +/-- A constant-field automorphism acting on the left tensor factor and fixing +`N`, viewed as an automorphism over `L`. -/ +noncomputable def exactConstantExtensionConstantAlgEquivOverBase + (σ : S ≃ₐ[C] S) : + letI := exactConstantExtensionBaseAlgebra C L N S + ExactConstantExtension C N S ≃ₐ[L] ExactConstantExtension C N S := by + letI := exactConstantExtensionBaseAlgebra C L N S + exact + { tensorConstantAlgEquiv C S N σ with + commutes' := fun l => by + change tensorConstantAlgEquiv C S N σ + (Algebra.TensorProduct.includeRight (algebraMap L N l)) = + Algebra.TensorProduct.includeRight (algebraMap L N l) + simp } + +/-- A function-field automorphism acting on the right tensor factor and +fixing `S`, viewed as an automorphism over `L`. -/ +noncomputable def exactConstantExtensionFunctionAlgEquivOverBase + (g : N ≃ₐ[L] N) : + letI := exactConstantExtensionBaseAlgebra C L N S + ExactConstantExtension C N S ≃ₐ[L] ExactConstantExtension C N S := by + letI := exactConstantExtensionBaseAlgebra C L N S + let gC : N ≃ₐ[C] N := g.restrictScalars C + let eC : ExactConstantExtension C N S ≃ₐ[C] + ExactConstantExtension C N S := + Algebra.TensorProduct.congr (AlgEquiv.refl : S ≃ₐ[C] S) gC + exact + { eC with + commutes' := fun l => by + change eC (Algebra.TensorProduct.includeRight (algebraMap L N l)) = + Algebra.TensorProduct.includeRight (algebraMap L N l) + simp [eC, gC, Algebra.TensorProduct.includeRight_apply] } + +/-- The constant-field action as a homomorphism into automorphisms over +`L`. -/ +noncomputable def exactConstantExtensionConstantAutHom : + letI := exactConstantExtensionBaseAlgebra C L N S + (S ≃ₐ[C] S) →* + (ExactConstantExtension C N S ≃ₐ[L] ExactConstantExtension C N S) := by + letI := exactConstantExtensionBaseAlgebra C L N S + exact + { toFun := exactConstantExtensionConstantAlgEquivOverBase C L N S + map_one' := by + apply AlgEquiv.ext + intro z + induction z using TensorProduct.inductionOn with + | tmul s n => simp [exactConstantExtensionConstantAlgEquivOverBase] + | add x y hx hy => simp [hx, hy] + map_mul' := by + intro σ τ + apply AlgEquiv.ext + intro z + induction z using TensorProduct.inductionOn with + | tmul s n => simp [exactConstantExtensionConstantAlgEquivOverBase] + | add x y hx hy => simp [hx, hy] } + +/-- The function-field action as a homomorphism into automorphisms over +`L`. -/ +noncomputable def exactConstantExtensionFunctionAutHom : + letI := exactConstantExtensionBaseAlgebra C L N S + (N ≃ₐ[L] N) →* + (ExactConstantExtension C N S ≃ₐ[L] ExactConstantExtension C N S) := by + letI := exactConstantExtensionBaseAlgebra C L N S + exact + { toFun := exactConstantExtensionFunctionAlgEquivOverBase C L N S + map_one' := by + apply AlgEquiv.ext + intro z + induction z using TensorProduct.inductionOn with + | tmul s n => simp [exactConstantExtensionFunctionAlgEquivOverBase] + | add x y hx hy => simp [hx, hy] + map_mul' := by + intro g h + apply AlgEquiv.ext + intro z + induction z using TensorProduct.inductionOn with + | tmul s n => simp [exactConstantExtensionFunctionAlgEquivOverBase] + | add x y hx hy => simp [hx, hy] } + +/-- Constant-field and function-field automorphisms commute on the tensor +compositum. -/ +theorem exactConstantExtension_constant_function_commute + (σ : S ≃ₐ[C] S) (g : N ≃ₐ[L] N) : + letI := exactConstantExtensionBaseAlgebra C L N S + Commute + (exactConstantExtensionConstantAutHom C L N S σ) + (exactConstantExtensionFunctionAutHom C L N S g) := by + let := exactConstantExtensionBaseAlgebra C L N S + rw [Commute] + apply AlgEquiv.ext + intro z + induction z using TensorProduct.inductionOn with + | tmul s n => simp [exactConstantExtensionConstantAutHom, + exactConstantExtensionFunctionAutHom, + exactConstantExtensionConstantAlgEquivOverBase, + exactConstantExtensionFunctionAlgEquivOverBase] + | add x y hx hy => + simp only [map_add] + exact congrArg₂ (· + ·) hx hy + +/-- The product of the commuting constant and function-field actions. -/ +noncomputable def exactConstantExtensionCombinedAutHom : + letI := exactConstantExtensionBaseAlgebra C L N S + (S ≃ₐ[C] S) × (N ≃ₐ[L] N) →* + (ExactConstantExtension C N S ≃ₐ[L] + ExactConstantExtension C N S) := by + letI := exactConstantExtensionBaseAlgebra C L N S + exact (exactConstantExtensionConstantAutHom C L N S).noncommCoprod + (exactConstantExtensionFunctionAutHom C L N S) + (exactConstantExtension_constant_function_commute C L N S) + +/-- The two tensor-factor actions are jointly faithful. -/ +theorem exactConstantExtensionCombinedAutHom_injective : + letI := exactConstantExtensionBaseAlgebra C L N S + Function.Injective (exactConstantExtensionCombinedAutHom C L N S) := by + let := exactConstantExtensionBaseAlgebra C L N S + intro p q hpq + apply Prod.ext + · ext s + have h := DFunLike.congr_fun hpq (s ⊗ₜ[C] (1 : N)) + have hinc : + Algebra.TensorProduct.includeLeft + (R := C) (S := C) (A := S) (B := N) (p.1 s) = + Algebra.TensorProduct.includeLeft + (R := C) (S := C) (A := S) (B := N) (q.1 s) := by + simpa [Algebra.TensorProduct.includeLeft_apply, + exactConstantExtensionCombinedAutHom, + exactConstantExtensionConstantAutHom, + exactConstantExtensionFunctionAutHom, + exactConstantExtensionConstantAlgEquivOverBase, + exactConstantExtensionFunctionAlgEquivOverBase] using h + exact Algebra.TensorProduct.includeLeft_injective + (R := C) (S := C) (A := S) (B := N) (algebraMap C N).injective hinc + · ext n + have h := DFunLike.congr_fun hpq ((1 : S) ⊗ₜ[C] n) + have hinc : + Algebra.TensorProduct.includeRight + (R := C) (A := S) (B := N) (p.2 n) = + Algebra.TensorProduct.includeRight + (R := C) (A := S) (B := N) (q.2 n) := by + simpa [Algebra.TensorProduct.includeRight_apply, + exactConstantExtensionCombinedAutHom, + exactConstantExtensionConstantAutHom, + exactConstantExtensionFunctionAutHom, + exactConstantExtensionConstantAlgEquivOverBase, + exactConstantExtensionFunctionAlgEquivOverBase] using h + exact Algebra.TensorProduct.includeRight_injective + (R := C) (A := S) (B := N) (algebraMap C S).injective hinc + +end Actions + +section Galois + +variable (C L N S : Type*) [Field C] [Field L] [Field N] [Field S] + [Algebra C L] [Algebra L N] [Algebra C N] [IsScalarTower C L N] + [Algebra C S] [FiniteDimensional C S] [IsGalois C S] + [FiniteDimensional L N] [IsGalois L N] + +omit [Algebra C L] [IsScalarTower C L N] + [FiniteDimensional C S] [IsGalois C S] + [FiniteDimensional L N] [IsGalois L N] in +/-- The tensor compositum has degree `[N : L] [S : C]` over `L`. -/ +theorem exactConstantExtension_finrank_over_base : + letI := exactConstantExtensionBaseAlgebra C L N S + Module.finrank L (ExactConstantExtension C N S) = + Module.finrank L N * Module.finrank C S := by + let := exactConstantExtensionBaseAlgebra C L N S + let := exactConstantExtensionAlgebra C N S + let := exactConstantExtensionBaseTower C L N S + change Module.finrank L (S ⊗[C] N) = + Module.finrank L N * Module.finrank C S + rw [← Module.finrank_mul_finrank L N (ExactConstantExtension C N S), + exactConstantExtension_finrank C N S] + +/-- With exact constants, the tensor compositum is Galois over `L`. -/ +theorem exactConstantExtension_isGalois + (hExact : algebraicClosure C N = (⊥ : IntermediateField C N)) : + letI := exactConstantExtensionField C N S hExact + letI := exactConstantExtensionBaseAlgebra C L N S + IsGalois L (ExactConstantExtension C N S) := by + let := exactConstantExtensionField C N S hExact + let := exactConstantExtensionBaseAlgebra C L N S + let := exactConstantExtensionAlgebra C N S + let := exactConstantExtensionBaseTower C L N S + let e := exactConstantExtensionLinearEquiv C N S + let : Module.Finite N (N ⊗[C] S) := Module.Finite.base_change C N S + let : Module.Finite N (ExactConstantExtension C N S) := Module.Finite.equiv e + let : Module.Finite L (ExactConstantExtension C N S) := + Module.Finite.trans N (ExactConstantExtension C N S) + apply IsGalois.of_card_aut_eq_finrank + apply Nat.le_antisymm + · calc + Nat.card (ExactConstantExtension C N S ≃ₐ[L] + ExactConstantExtension C N S) = + Nat.card (ExactConstantExtension C N S →ₐ[L] + ExactConstantExtension C N S) := + Nat.card_congr + (algEquivEquivAlgHom L (ExactConstantExtension C N S)) + _ ≤ Module.finrank L (ExactConstantExtension C N S) := + card_algHom_le_finrank L (ExactConstantExtension C N S) + (ExactConstantExtension C N S) + · calc + Module.finrank L (ExactConstantExtension C N S) = + Module.finrank L N * Module.finrank C S := + exactConstantExtension_finrank_over_base C L N S + _ = Nat.card (N ≃ₐ[L] N) * Nat.card (S ≃ₐ[C] S) := by + rw [IsGalois.card_aut_eq_finrank, IsGalois.card_aut_eq_finrank] + _ = Nat.card ((S ≃ₐ[C] S) × (N ≃ₐ[L] N)) := by + rw [Nat.card_prod, mul_comm] + _ ≤ Nat.card (ExactConstantExtension C N S ≃ₐ[L] + ExactConstantExtension C N S) := + Nat.card_le_card_of_injective + (exactConstantExtensionCombinedAutHom C L N S) + (exactConstantExtensionCombinedAutHom_injective C L N S) + +/-- The full Galois group of an exact finite constant extension is the direct +product of the constant and function-field Galois groups. -/ +noncomputable def exactConstantExtensionAutMulEquiv + (hExact : algebraicClosure C N = (⊥ : IntermediateField C N)) : + letI := exactConstantExtensionField C N S hExact + letI := exactConstantExtensionBaseAlgebra C L N S + (S ≃ₐ[C] S) × (N ≃ₐ[L] N) ≃* + (ExactConstantExtension C N S ≃ₐ[L] + ExactConstantExtension C N S) := by + letI := exactConstantExtensionField C N S hExact + letI := exactConstantExtensionBaseAlgebra C L N S + letI := exactConstantExtensionAlgebra C N S + letI := exactConstantExtensionBaseTower C L N S + let e := exactConstantExtensionLinearEquiv C N S + letI : Module.Finite N (N ⊗[C] S) := Module.Finite.base_change C N S + letI : Module.Finite N (ExactConstantExtension C N S) := Module.Finite.equiv e + letI : Module.Finite L (ExactConstantExtension C N S) := + Module.Finite.trans N (ExactConstantExtension C N S) + letI : IsGalois L (ExactConstantExtension C N S) := + exactConstantExtension_isGalois C L N S hExact + let h := exactConstantExtensionCombinedAutHom C L N S + let hinj := exactConstantExtensionCombinedAutHom_injective C L N S + apply MulEquiv.ofBijective h + apply hinj.bijective_of_nat_card_le + rw [Nat.card_prod, IsGalois.card_aut_eq_finrank, + exactConstantExtension_finrank_over_base C L N S, + IsGalois.card_aut_eq_finrank, IsGalois.card_aut_eq_finrank, mul_comm] + +end Galois + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionConstants.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionConstants.lean new file mode 100644 index 0000000000..b5b477a45e --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionConstants.lean @@ -0,0 +1,178 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionAutomorphism +public import Mathlib.FieldTheory.Finite.Extension + +/-! +# Exact constants after a finite constant extension + +Let `N / C` have exact constant field `C`, and let `S / C` be a finite +Galois extension of finite fields. This file proves that the tensor +compositum `S ⊗[C] N` has exact constant field `S`. + +For an element algebraic over `S`, adjoin it to `C` inside the compositum. +This finite field is linearly disjoint from `N`, since its intersection with +`N` is contained in the exact constants `C`. Its degree over `C` therefore +divides `[S : C]`. The finite-field embedding criterion supplies an embedding +into `S`; uniqueness of the roots of `X ^ #K - X` inside the common +compositum then shows that the original element already belongs to `S`. +-/ + +@[expose] public section + +open scoped Polynomial TensorProduct + +namespace BGS.HasseWeil + +noncomputable section + + +universe u v w + +variable (C N S : Type*) [Field C] [Field N] [Field S] + [Algebra C N] [Algebra C S] + [Finite C] [Finite S] + [FiniteDimensional C S] [IsGalois C S] + +/-- A finite Galois extension of the exact finite constant field remains the +exact constant field after tensor base change. -/ +theorem exactConstantExtension_algebraicClosure_eq_bot + (hExact : algebraicClosure C N = + (⊥ : IntermediateField C N)) : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra S (ExactConstantExtension C N S) := + Algebra.TensorProduct.leftAlgebra + algebraicClosure S (ExactConstantExtension C N S) = + (⊥ : IntermediateField S (ExactConstantExtension C N S)) := by + let : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + let : Algebra C (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C C N S + let : SMul C (ExactConstantExtension C N S) := Algebra.toSMul + let : Algebra N (ExactConstantExtension C N S) := + exactConstantExtensionAlgebra C N S + let : SMul N (ExactConstantExtension C N S) := Algebra.toSMul + have : IsScalarTower C N (ExactConstantExtension C N S) := by + exact exactConstantExtensionBaseTower C C N S + let : Algebra S (ExactConstantExtension C N S) := + Algebra.TensorProduct.leftAlgebra + let : SMul S (ExactConstantExtension C N S) := Algebra.toSMul + have hSN : algebraMap C (ExactConstantExtension C N S) = + (algebraMap S (ExactConstantExtension C N S)).comp (algebraMap C S) := by + ext c + change (1 : S) ⊗ₜ algebraMap C N c = + algebraMap C S c ⊗ₜ (1 : N) + exact (Algebra.TensorProduct.tmul_one_eq_one_tmul c).symm + let : IsScalarTower C S (ExactConstantExtension C N S) := + IsScalarTower.of_algebraMap_eq' hSN + let e := exactConstantExtensionLinearEquiv C N S + let : Module.Finite N (N ⊗[C] S) := Module.Finite.base_change C N S + let : Module.Finite N (ExactConstantExtension C N S) := + Module.Finite.equiv e + have : IsGalois N (ExactConstantExtension C N S) := by + exact exactConstantExtension_isGalois C N N S hExact + apply eq_bot_iff.mpr + intro z hz + have hzS : IsAlgebraic S z := mem_algebraicClosure_iff.mp hz + have hzInt : IsIntegral C z := isIntegral_trans z hzS.isIntegral + let K : IntermediateField C (ExactConstantExtension C N S) := + IntermediateField.adjoin C {z} + let : FiniteDimensional C K := by + dsimp [K] + exact IntermediateField.adjoin.finiteDimensional hzInt + let : Finite K := Module.finite_of_finite C + let : Fintype K := Fintype.ofFinite K + let : Algebra.IsAlgebraic C K := Algebra.IsAlgebraic.of_finite C K + have : IsGalois C K := inferInstance + let iN : N →ₐ[C] ExactConstantExtension C N S := + IsScalarTower.toAlgHom C N (ExactConstantExtension C N S) + let N' : IntermediateField C (ExactConstantExtension C N S) := + iN.fieldRange + have hInf : K ⊓ N' = + (⊥ : IntermediateField C (ExactConstantExtension C N S)) := by + apply eq_bot_iff.mpr + intro x hx + obtain ⟨n, hn⟩ := hx.2 + have hxAlg : IsAlgebraic C (x : ExactConstantExtension C N S) := by + have hxK : IsAlgebraic C (⟨x, hx.1⟩ : K) := + Algebra.IsAlgebraic.isAlgebraic (R := C) (A := K) + (⟨x, hx.1⟩ : K) + exact IsAlgebraic.algHom K.val hxK + have hnAlg : IsAlgebraic C n := by + apply (isAlgebraic_algHom_iff iN iN.injective).mp + change IsAlgebraic C (iN.toRingHom n) + rw [hn] + exact hxAlg + have hnBot : n ∈ (⊥ : IntermediateField C N) := by + rw [← hExact] + exact mem_algebraicClosure_iff.mpr hnAlg + obtain ⟨c, hc⟩ := IntermediateField.mem_bot.mp hnBot + apply IntermediateField.mem_bot.mpr + refine ⟨c, ?_⟩ + calc + algebraMap C (ExactConstantExtension C N S) c = + iN (algebraMap C N c) := (iN.commutes c).symm + _ = iN n := congrArg iN hc + _ = x := hn + have hLD' : K.LinearDisjoint N' := + linearDisjoint_of_inf_eq_bot_of_finite_galois_left K N' hInf + have hLD : K.LinearDisjoint N := by + change K.toSubalgebra.LinearDisjoint iN.range + have hLDsub : K.toSubalgebra.LinearDisjoint N'.toSubalgebra := + (IntermediateField.linearDisjoint_iff' (A := K) (B := N')).mp hLD' + simpa only [N', AlgHom.fieldRange_toSubalgebra] using hLDsub + let A : IntermediateField N (ExactConstantExtension C N S) := + IntermediateField.adjoin N (K : Set (ExactConstantExtension C N S)) + have hrank : Module.rank N A = Module.rank C K := by + simpa [A] using + hLD.adjoin_rank_eq_rank_left_of_isAlgebraic_left + have hfinrank : Module.finrank N A = Module.finrank C K := by + simpa only [Module.finrank] using congrArg Cardinal.toNat hrank + have hdvdTop : Module.finrank N A ∣ + Module.finrank N (ExactConstantExtension C N S) := by + simpa using + (IntermediateField.finrank_dvd_of_le_right + (show A ≤ + (⊤ : IntermediateField N (ExactConstantExtension C N S)) from le_top)) + have hdvd : Module.finrank C K ∣ Module.finrank C S := by + rw [← exactConstantExtension_finrank C N S, ← hfinrank] + exact hdvdTop + let φ : K →ₐ[C] S := + Classical.choice (FiniteField.nonempty_algHom_of_finrank_dvd hdvd) + let iKS : K →ₐ[C] ExactConstantExtension C N S := + (IsScalarTower.toAlgHom C S + (ExactConstantExtension C N S)).comp φ + let zk : K := ⟨z, IntermediateField.subset_adjoin C {z} + (Set.mem_singleton z)⟩ + have hzpow : z ^ Fintype.card K = z := by + calc + z ^ Fintype.card K = ((zk ^ Fintype.card K : K) : + ExactConstantExtension C N S) := rfl + _ = (zk : ExactConstantExtension C N S) := + congrArg Subtype.val (FiniteField.pow_card zk) + _ = z := rfl + let p : K[X] := Polynomial.X ^ Fintype.card K - Polynomial.X + have hpSplit : p.Splits := by + dsimp [p] + simpa [Nat.card_eq_fintype_card] using + (Polynomial.splits_X_pow_nat_card_sub_X (K := K)) + have hp0 : p ≠ 0 := by + dsimp [p] + exact FiniteField.X_pow_card_sub_X_ne_zero K Fintype.one_lt_card + have hroot : (p.map iKS).IsRoot z := by + simp [p, hzpow] + obtain ⟨k, hk⟩ := hpSplit.mem_range_of_isRoot hp0 hroot + apply IntermediateField.mem_bot.mpr + refine ⟨φ k, ?_⟩ + simpa [iKS] using hk + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionDifferentCoefficient.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionDifferentCoefficient.lean new file mode 100644 index 0000000000..82a2e61bde --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionDifferentCoefficient.lean @@ -0,0 +1,1121 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionFiniteDifferent +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionInfinityDifferent +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionInfinityPlaceCompatibility +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionGenusInvariance +public import LeanPool.MarkoffModP.BGS.HasseWeil.IdealMultiplicityMap + +/-! +# Local different coefficients under exact constant extension + +The finite and reciprocal-infinity different ideals commute with exact +extension of finite constants. Since every place in a constant extension +has ramification index one, their multiplicities agree place by place. This +discharges the local hypothesis of the global different-degree and genus +transport theorems. +-/ + +@[expose] public section + +open scoped Polynomial TensorProduct + +namespace BGS.HasseWeil + +private theorem normalization_map_injective + {R B N E : Type*} [CommRing R] [CommRing B] [Field N] [Field E] + [Algebra R B] [Algebra N E] + (i : R → N) (j : B → E) (hi : Function.Injective i) + (hcompat : ∀ x, j (algebraMap R B x) = algebraMap N E (i x)) : + Function.Injective (algebraMap R B) := by + intro x y hxy + apply hi + apply (algebraMap N E).injective + exact (hcompat x).symm.trans ((congrArg j hxy).trans (hcompat y)) + + +private theorem comap_liesOver_of_commutes + {A R B C : Type*} [CommRing A] [CommRing R] [CommRing B] [CommRing C] + [Algebra A C] [Algebra R B] + (e : C →+* B) (f : A →+* R) + (hcomp : e.comp (algebraMap A C) = (algebraMap R B).comp f) + (p : Ideal A) (r : Ideal R) (q : Ideal B) [q.LiesOver r] + (hbase : r.comap f = p) : (q.comap e).LiesOver p := by + constructor + change p = Ideal.comap (algebraMap A C) (q.comap e) + rw [Ideal.comap_comap, hcomp, ← Ideal.comap_comap] + change p = Ideal.comap f (q.under R) + rw [← (inferInstance : q.LiesOver r).over, hbase] + + +noncomputable section + +open BGS.CorvajaZannier IsDedekindDomain + + +variable (C S N : Type*) [Field C] [Field S] [Field N] + [Fintype C] [Finite S] + [Algebra (RatFunc C) N] [FiniteDimensional (RatFunc C) N] + [Algebra.IsSeparable (RatFunc C) N] + [Algebra C S] [FiniteDimensional C S] [IsGalois C S] + +local instance (priority := 10000) + exactConstantDifferentCoefficientConstantsDecidableEq + (K : Type*) [Field K] : DecidableEq K := + infinityBridgeDecidableEqConstants K + +local instance (priority := 10001) + exactConstantDifferentCoefficientRatFuncDecidableEq + (K : Type*) [Field K] : DecidableEq (RatFunc K) := + infinityBridgeDecidableEqRatFuncConstants K + +local instance exactConstantDifferentCoefficientBaseConstantAlgebra : + Algebra C N := + bridgeBaseConstantAlgebra C N + +local instance exactConstantDifferentCoefficientBaseConstantTower : + IsScalarTower C (RatFunc C) N := + IsScalarTower.of_algebraMap_eq' rfl + +local instance (priority := 10) + exactConstantDifferentCoefficientBasePolynomialAlgebra : Algebra C[X] N := + RingHom.toAlgebra ((algebraMap (RatFunc C) N).comp + (algebraMap C[X] (RatFunc C))) + +local instance exactConstantDifferentCoefficientBasePolynomialTower : + IsScalarTower C[X] (RatFunc C) N := + IsScalarTower.of_algebraMap_eq' rfl + +local instance exactConstantDifferentCoefficientBaseConstantPolynomialTower : + IsScalarTower C C[X] N := + IsScalarTower.of_algebraMap_eq' rfl + +local instance exactConstantDifferentCoefficientTargetPolynomialAlgebra : + Algebra S[X] (ExactConstantExtension C N S) := + constantExtensionTensorPolynomialAlgebra C S N + +@[reducible] private noncomputable def + exactConstantDifferentCoefficientCanonicalFractionRingAlgebra + (R : Type*) [CommRing R] [IsDomain R] : + Algebra R (FractionRing R) := inferInstance + +private theorem exactConstantDifferentCoefficientCanonicalFractionRing + (R : Type*) [CommRing R] [IsDomain R] : + letI := exactConstantDifferentCoefficientCanonicalFractionRingAlgebra R + IsFractionRing R (FractionRing R) := by + let := exactConstantDifferentCoefficientCanonicalFractionRingAlgebra R + infer_instance + +private theorem integralClosureAlgEquivRatFuncFiniteOfEq_coe + {k T : Type*} [Field k] [Field T] [Algebra (RatFunc k) T] + (a : Algebra k[X] T) + (h : ratFuncInducedPolynomialAlgebra k T = a) + (x : letI := a; integralClosure k[X] T) : + letI := a + (((integralClosureAlgEquivRatFuncFiniteOfEq k T a h) x : + RatFuncFiniteIntegralClosure k T) : T) = x := by + subst a + rfl + +/-- Changing only the presentation of a finite normalization does not change +the multiplicity of its different. The equivalence here is the equality +transport from a chosen compatible polynomial action to the action induced +by the fixed rational-function-field embedding. -/ +private def idealMapMulEquiv {R T : Type*} [CommSemiring R] [CommSemiring T] + (e : R ≃+* T) : Ideal R ≃* Ideal T where + toFun I := I.map e + invFun I := I.map e.symm + left_inv _ := Ideal.map_of_equiv e + right_inv _ := Ideal.map_of_equiv e.symm + map_mul' I J := Ideal.map_mul e I J + +private theorem finiteNormalization_multiplicity_map_eq + {k T : Type*} [Field k] [Field T] [Algebra (RatFunc k) T] + (a : Algebra k[X] T) + (h : ratFuncInducedPolynomialAlgebra k T = a) + (q : letI := a + IsDedekindDomain.HeightOneSpectrum (integralClosure k[X] T)) + (I : letI := a; Ideal (integralClosure k[X] T)) : + letI := a + let e := integralClosureAlgEquivRatFuncFiniteOfEq k T a h + multiplicity (heightOneSpectrumEquivOfAlgEquiv e q).asIdeal + (Ideal.map e I) = + multiplicity q.asIdeal I := by + dsimp only + rw [heightOneSpectrumEquivOfAlgEquiv_asIdeal] + let e := integralClosureAlgEquivRatFuncFiniteOfEq k T a h + rw [show Ideal.comap e.symm q.asIdeal = Ideal.map e q.asIdeal by + exact (Ideal.map_comap_of_equiv e.toRingEquiv).symm] + exact multiplicity_map_eq + (idealMapMulEquiv e.toRingEquiv) + +private theorem finiteNormalization_differentIdeal_eq_map + {k T : Type*} [Field k] [Finite k] [Field T] + [Algebra (RatFunc k) T] [FiniteDimensional (RatFunc k) T] + [Algebra.IsSeparable (RatFunc k) T] + (a : Algebra k[X] T) + (h : ratFuncInducedPolynomialAlgebra k T = a) + (hDedekind : letI := a + IsDedekindDomain (integralClosure k[X] T)) + (hTorsionFree : letI := a + Module.IsTorsionFree k[X] (integralClosure k[X] T)) : + letI := a + letI : IsDedekindDomain (integralClosure k[X] T) := hDedekind + letI : Module.IsTorsionFree k[X] (integralClosure k[X] T) := + hTorsionFree + let e := integralClosureAlgEquivRatFuncFiniteOfEq k T a h + differentIdeal k[X] (RatFuncFiniteIntegralClosure k T) = + Ideal.map e (differentIdeal k[X] (integralClosure k[X] T)) := by + subst a + dsimp only + change differentIdeal k[X] (RatFuncFiniteIntegralClosure k T) = + Ideal.map (AlgEquiv.refl : + RatFuncFiniteIntegralClosure k T ≃ₐ[k[X]] + RatFuncFiniteIntegralClosure k T) + (differentIdeal k[X] (RatFuncFiniteIntegralClosure k T)) + exact (Ideal.map_id _).symm + +/-- Ramification indices are unchanged by an equivalence of the upper +Dedekind domains that is linear over the lower Dedekind domain. -/ +private theorem ramificationIdx_algEquiv + {R A B : Type*} [CommRing R] [CommRing A] [CommRing B] + [IsDomain R] [IsDedekindDomain A] [IsDedekindDomain B] + [Algebra R A] [Algebra R B] + [Module.IsTorsionFree R A] [Module.IsTorsionFree R B] + (e : A ≃ₐ[R] B) (p : HeightOneSpectrum R) + (q : HeightOneSpectrum A) + [q.asIdeal.LiesOver p.asIdeal] + [(heightOneSpectrumEquivOfAlgEquiv e q).asIdeal.LiesOver p.asIdeal] : + (heightOneSpectrumEquivOfAlgEquiv e q).asIdeal.ramificationIdx R = + q.asIdeal.ramificationIdx R := by + let q' := heightOneSpectrumEquivOfAlgEquiv e q + have hIdeal : q'.asIdeal = Ideal.map e.toRingHom q.asIdeal := by + dsimp only [q'] + rw [heightOneSpectrumEquivOfAlgEquiv_asIdeal] + exact (Ideal.map_comap_of_equiv e.toRingEquiv).symm + calc + q'.asIdeal.ramificationIdx R = + p.asIdeal.ramificationIdx' q'.asIdeal := + (Ideal.ramificationIdx'_eq_ramificationIdx + p.asIdeal q'.asIdeal p.ne_bot).symm + _ = p.asIdeal.ramificationIdx' q.asIdeal := by + rw [hIdeal] + exact Ideal.ramificationIdx'_map_eq p.asIdeal q.asIdeal e + _ = q.asIdeal.ramificationIdx R := + Ideal.ramificationIdx'_eq_ramificationIdx + p.asIdeal q.asIdeal p.ne_bot + +/-- A prime in the explicit `S[X]`-normalization is unramified over its +contracted prime in the original `C[X]`-normalization. The proof transports +the prime to the canonical `C[X]`-normalization used by the place tower and +then invokes unramifiedness of exact constant extensions. -/ +theorem exactConstantExtensionPresentedFinitePlace_ramificationIdx_eq_one + (hExact : algebraicClosure C N = + (⊥ : IntermediateField C N)) + (q : HeightOneSpectrum + (integralClosure S[X] (ExactConstantExtension C N S))) : + let E := ExactConstantExtension C N S + letI : Field E := exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) E := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + letI : Algebra (RatFunc S) E := + ratFuncExactConstantExtensionAlgebra C S N hExact + letI : Algebra S[X] E := + constantExtensionTensorPolynomialAlgebra C S N + let R2 := RatFuncFiniteIntegralClosure C N + let B := integralClosure S[X] E + letI : Algebra R2 B := + exactConstantExtensionFiniteNormalizationAlgebra C S N + q.asIdeal.ramificationIdx R2 = 1 := by + dsimp only + let E := ExactConstantExtension C N S + let : Field E := exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) E := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : SMul (RatFunc C) E := Algebra.toSMul + let : Module (RatFunc C) E := Algebra.toModule + let : FiniteDimensional (RatFunc C) E := + finiteDimensional_exactConstantExtension_over_baseRatFunc C S N hExact + let : Algebra.IsSeparable (RatFunc C) E := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + let : Algebra (RatFunc S) E := + ratFuncExactConstantExtensionAlgebra C S N hExact + let : SMul (RatFunc S) E := Algebra.toSMul + let : Module (RatFunc S) E := Algebra.toModule + let : Algebra S[X] E := + constantExtensionTensorPolynomialAlgebra C S N + let : SMul S[X] E := Algebra.toSMul + let : Module S[X] E := Algebra.toModule + let : Algebra S[X] (RatFunc S) := inferInstance + let : IsFractionRing S[X] (RatFunc S) := inferInstance + let : IsScalarTower S[X] (RatFunc S) E := + IsScalarTower.of_algebraMap_eq' (by + apply DFunLike.ext _ _ + intro p + change algebraMap S[X] E p = + ratFuncToExactConstantExtension C S N hExact + (algebraMap S[X] (RatFunc S) p) + exact + (ratFuncToExactConstantExtension_algebraMap C S N hExact p).symm) + let : FiniteDimensional (RatFunc S) E := + finiteDimensional_over_extendedRatFunc C S N hExact + let : Algebra.IsSeparable (RatFunc S) E := + isSeparable_over_extendedRatFunc C S N hExact + let R2 := RatFuncFiniteIntegralClosure C N + let B := integralClosure S[X] E + let CC := RatFuncFiniteIntegralClosure C E + let CS := RatFuncFiniteIntegralClosure S E + let : Algebra C[X] (RatFunc C) := inferInstance + let : IsFractionRing C[X] (RatFunc C) := inferInstance + let : IsScalarTower C[X] (RatFunc C) N := + IsScalarTower.of_algebraMap_eq' rfl + let : IsScalarTower C C[X] N := + IsScalarTower.of_algebraMap_eq' rfl + let : IsDedekindDomain R2 := + IsIntegralClosure.isDedekindDomain C[X] (RatFunc C) N R2 + let : Module.IsTorsionFree C[X] N := by + rw [Module.isTorsionFree_iff_algebraMap_injective] + change Function.Injective + ((algebraMap (RatFunc C) N).comp (algebraMap C[X] (RatFunc C))) + exact (algebraMap (RatFunc C) N).injective.comp + (RatFunc.algebraMap_injective C) + let : Module.IsTorsionFree C[X] R2 := + IsIntegralClosure.isTorsionFree C[X] N + let : Algebra C R2 := + RingHom.toAlgebra + ((algebraMap C[X] R2).comp (algebraMap C C[X])) + let : SMul C R2 := Algebra.toSMul + let : Module C R2 := Algebra.toModule + let : IsDedekindDomain B := + IsIntegralClosure.isDedekindDomain S[X] (RatFunc S) E B + let : Algebra R2 B := + exactConstantExtensionFiniteNormalizationAlgebra C S N + let : SMul R2 B := Algebra.toSMul + let : Module R2 B := Algebra.toModule + let : Algebra N E := exactConstantExtensionAlgebra C N S + let : SMul N E := Algebra.toSMul + let : Module N E := Algebra.toModule + let : IsScalarTower (RatFunc C) N E := + exactConstantExtensionBaseTower C (RatFunc C) N S + let : Algebra C[X] E := + RingHom.toAlgebra + ((algebraMap (RatFunc C) E).comp (algebraMap C[X] (RatFunc C))) + let : SMul C[X] E := Algebra.toSMul + let : Module C[X] E := Algebra.toModule + let : IsScalarTower C[X] (RatFunc C) E := + IsScalarTower.of_algebraMap_eq' rfl + let : Algebra C[X] S[X] := Polynomial.algebra C S + let : IsScalarTower C[X] S[X] E := + IsScalarTower.of_algebraMap_eq' (by + apply DFunLike.ext _ _ + intro p + change algebraMap (RatFunc C) E + (algebraMap C[X] (RatFunc C) p) = + algebraMap S[X] E (algebraMap C[X] S[X] p) + rw [IsScalarTower.algebraMap_apply S[X] (RatFunc S) E] + rw [rationalBase_algebraMap_eq C S N hExact] + apply congrArg (algebraMap (RatFunc S) E) + exact ratFuncCoefficientAlgHom_algebraMap C S p) + let : Algebra R2 CC := (finiteIntegralClosureMap C N E).toAlgebra + let : SMul R2 CC := Algebra.toSMul + let : Module R2 CC := Algebra.toModule + let : IsDedekindDomain CC := + IsIntegralClosure.isDedekindDomain C[X] (RatFunc C) E CC + let : Algebra S CC := + exactConstantExtensionFiniteIntegralClosureConstantAlgebra C N S hExact + let : Algebra S CS := + RingHom.toAlgebra + ((algebraMap S[X] CS).comp (algebraMap S S[X])) + let eS := integralClosureAlgEquivRatFuncFiniteOfAlgebraMap + S E (constantExtensionTensorPolynomialAlgebra C S N) + (ratFuncToExactConstantExtension_algebraMap C S N hExact) + let eBase := exactConstantExtensionFiniteClosureBaseChangeAlgEquiv + C S N hExact + let eRing : B ≃+* CC := eS.toRingEquiv.trans eBase.toRingEquiv.symm + let e : B ≃ₐ[R2] CC := + { eRing with + commutes' := fun x => by + apply Subtype.ext + have heBaseCoe (y : CC) : + ((eBase y : CS) : E) = y := by + exact integralClosureRingEquivOfIntegralTower_coe C[X] S[X] E y + have heBaseSymmCoe (z : CS) : + ((eBase.symm z : CC) : E) = z := by + calc + ((eBase.symm z : CC) : E) = + ((eBase (eBase.symm z) : CS) : E) := + (heBaseCoe (eBase.symm z)).symm + _ = (z : E) := congrArg Subtype.val (eBase.apply_symm_apply z) + calc + ((eRing ((algebraMap R2 B) x) : CC) : E) = + ((eS ((algebraMap R2 B) x) : CS) : E) := + heBaseSymmCoe (eS ((algebraMap R2 B) x)) + _ = (((algebraMap R2 B) x : B) : E) := + integralClosureAlgEquivRatFuncFiniteOfEq_coe + (constantExtensionTensorPolynomialAlgebra C S N) + (ratFuncInducedPolynomialAlgebra_eq S E + (constantExtensionTensorPolynomialAlgebra C S N) + (ratFuncToExactConstantExtension_algebraMap C S N hExact)) + ((algebraMap R2 B) x) + _ = (((algebraMap R2 CC) x : CC) : E) := by + change + (((finiteFieldConstantExtensionIntegralClosureRingEquiv C S N) + (1 ⊗ₜ[C] x) : B) : E) = + algebraMap N E (x : N) + exact finiteFieldConstantExtensionIntegralClosureRingEquiv_tmul + C S N 1 x } + have hTargetInjective : Function.Injective (algebraMap R2 CC) := by + intro x y hxy + apply Subtype.ext + apply (algebraMap N E).injective + exact congrArg Subtype.val hxy + let : Module.IsTorsionFree R2 CC := by + rw [Module.isTorsionFree_iff_algebraMap_injective] + exact hTargetInjective + let : Module.IsTorsionFree R2 B := by + rw [Module.isTorsionFree_iff_algebraMap_injective] + intro x y hxy + apply hTargetInjective + rw [← e.commutes x, ← e.commutes y, hxy] + let P := exactConstantExtensionDownstairsFinitePlace C S N hExact q + let Q := exactConstantExtensionCompatibleBaseFinitePlace C S N hExact q + have hQ : heightOneSpectrumEquivOfAlgEquiv e q = Q := by + apply (HeightOneSpectrum.equivOfRingEquiv eBase.toRingEquiv).injective + calc + HeightOneSpectrum.equivOfRingEquiv eBase.toRingEquiv + (heightOneSpectrumEquivOfAlgEquiv e q) = + heightOneSpectrumEquivOfAlgEquiv eS q := by + rfl + _ = exactConstantExtensionUpstairsFinitePlace C S N hExact q := by + exact + (exactConstantExtensionUpstairsFinitePlace_eq_compatibleNormalizationTransport + C S N hExact q).symm + _ = HeightOneSpectrum.equivOfRingEquiv eBase.toRingEquiv Q := by + exact + (exactConstantExtensionCompatibleBaseFinitePlace_baseChange + C S N hExact q).symm + let q' := heightOneSpectrumEquivOfAlgEquiv e q + let : q.asIdeal.LiesOver P.asIdeal := ⟨by + change P.asIdeal = q.asIdeal.comap (algebraMap R2 B) + rfl⟩ + let : q'.asIdeal.LiesOver P.asIdeal := ⟨by + change P.asIdeal = q'.asIdeal.comap (algebraMap R2 CC) + rw [show q' = Q by exact hQ] + exact congrArg HeightOneSpectrum.asIdeal + (exactConstantExtensionCompatibleBaseFinitePlace_under_original + C S N hExact q).symm⟩ + calc + q.asIdeal.ramificationIdx R2 = + (heightOneSpectrumEquivOfAlgEquiv e q).asIdeal.ramificationIdx R2 := + (ramificationIdx_algEquiv e P q).symm + _ = Q.asIdeal.ramificationIdx R2 := by rw [hQ] + _ = 1 := by + exact exactConstantExtensionFinitePlace_ramificationIdx_eq_one + C S N hExact Q + +/-- Every prime in the explicit extended infinity normalization is unramified +over the original infinity normalization. -/ +theorem exactConstantExtensionPresentedInfinityPlace_ramificationIdx_eq_one + (hExact : algebraicClosure C N = + (⊥ : IntermediateField C N)) + (q : ExactConstantExtensionPresentedInfinityPlace C S N) : + let E := ExactConstantExtension C N S + letI : Field E := exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) E := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + letI : Algebra (RatFunc S) E := + ratFuncExactConstantExtensionAlgebra C S N hExact + let R2 := RatFuncInfinityIntegralClosure C N + let B := RatFuncInfinityIntegralClosure S E + letI : Algebra R2 B := + exactConstantExtensionInfinityNormalizationAlgebra C S N hExact + (exactConstantExtensionUpstairsInfinityPlace + C S N hExact q.1 q.2).1.ramificationIdx R2 = 1 := by + dsimp only + let E := ExactConstantExtension C N S + let A := RatFuncInfinityIntegers C + let R1 := RatFuncInfinityIntegers S + let R2 := RatFuncInfinityIntegralClosure C N + let : Field E := exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) E := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : SMul (RatFunc C) E := Algebra.toSMul + let : Module (RatFunc C) E := Algebra.toModule + let : FiniteDimensional (RatFunc C) E := + finiteDimensional_exactConstantExtension_over_baseRatFunc C S N hExact + let : Algebra.IsSeparable (RatFunc C) E := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + let : Algebra N E := exactConstantExtensionAlgebra C N S + let : SMul N E := Algebra.toSMul + let : Module N E := Algebra.toModule + let : IsScalarTower (RatFunc C) N E := + exactConstantExtensionBaseTower C (RatFunc C) N S + let : Algebra (RatFunc S) E := + ratFuncExactConstantExtensionAlgebra C S N hExact + let : SMul (RatFunc S) E := Algebra.toSMul + let : Module (RatFunc S) E := Algebra.toModule + let : DistribMulAction (RatFunc S) E := Module.toDistribMulAction + let : MulAction (RatFunc S) E := DistribMulAction.toMulAction + let : FiniteDimensional (RatFunc S) E := + finiteDimensional_over_extendedRatFunc C S N hExact + let : Algebra.IsSeparable (RatFunc S) E := + isSeparable_over_extendedRatFunc C S N hExact + let B := RatFuncInfinityIntegralClosure S E + let CC := RatFuncInfinityIntegralClosure C E + let : Algebra A (RatFunc C) := Algebra.ofSubsemiring A + let : SMul A (RatFunc C) := Algebra.toSMul + let : Module A (RatFunc C) := Algebra.toModule + let : Algebra R1 (RatFunc S) := Algebra.ofSubsemiring R1 + let : SMul R1 (RatFunc S) := Algebra.toSMul + let : Module R1 (RatFunc S) := Algebra.toModule + let : IsFractionRing A (RatFunc C) := + IsFractionRing.of_algEquiv (ratFuncInfinityFractionRingEquiv C) + let : IsFractionRing R1 (RatFunc S) := + IsFractionRing.of_algEquiv (ratFuncInfinityFractionRingEquiv S) + let : Algebra A N := Algebra.ofSubsemiring A + let : SMul A N := Algebra.toSMul + let : Module A N := Algebra.toModule + let : IsScalarTower A (RatFunc C) N := + IsScalarTower.of_algebraMap_eq' rfl + let : Algebra A E := Algebra.ofSubsemiring A + let : SMul A E := Algebra.toSMul + let : Module A E := Algebra.toModule + let : Module.IsTorsionFree A E := by + rw [Module.isTorsionFree_iff_algebraMap_injective] + exact (algebraMap (RatFunc C) E).injective.comp + (IsFractionRing.injective A (RatFunc C)) + let : IsScalarTower A (RatFunc C) E := + IsScalarTower.of_algebraMap_eq' rfl + let : Algebra R1 E := Algebra.ofSubsemiring R1 + let : SMul R1 E := Algebra.toSMul + let : Module R1 E := Algebra.toModule + let : Algebra A R1 := + RingHom.toAlgebra (ratFuncInfinityIntegersRingHom C S) + let : SMul A R1 := Algebra.toSMul + let : Module A R1 := Algebra.toModule + let : Module.Finite A R1 := + ratFuncInfinityIntegers_coefficient_moduleFinite C S + let : Algebra.IsIntegral A R1 := by infer_instance + let : IsScalarTower A R1 E := + IsScalarTower.of_algebraMap_eq' (by + ext z + change algebraMap (RatFunc C) E z.1 = + algebraMap (RatFunc S) E (ratFuncCoefficientAlgHom C S z.1) + exact DFunLike.congr_fun + (rationalBase_algebraMap_eq C S N hExact) z.1) + let : IsDedekindDomain R2 := + integralClosure.isDedekindDomain A (RatFunc C) N + let : IsDedekindDomain B := + integralClosure.isDedekindDomain R1 (RatFunc S) E + let : IsDedekindDomain CC := + integralClosure.isDedekindDomain A (RatFunc C) E + let : Algebra A R2 := inferInstance + let : SMul A R2 := Algebra.toSMul + let : Module A R2 := Algebra.toModule + let : Module.IsTorsionFree A R2 := + IsIntegralClosure.isTorsionFree A N + let : Algebra A CC := inferInstance + let : SMul A CC := Algebra.toSMul + let : Module A CC := Algebra.toModule + let : Module.IsTorsionFree A CC := + IsIntegralClosure.isTorsionFree A E + let : Module.IsTorsionFree R1 E := by + rw [Module.isTorsionFree_iff_algebraMap_injective] + exact (algebraMap (RatFunc S) E).injective.comp + (IsFractionRing.injective R1 (RatFunc S)) + let : Module.IsTorsionFree R1 B := + IsIntegralClosure.isTorsionFree R1 E + let : Algebra R2 B := + exactConstantExtensionInfinityNormalizationAlgebra C S N hExact + let : SMul R2 B := Algebra.toSMul + let : Module R2 B := Algebra.toModule + let : Algebra R2 CC := (infinityIntegralClosureMap C N E).toAlgebra + let : SMul R2 CC := Algebra.toSMul + let : Module R2 CC := Algebra.toModule + let : IsScalarTower A R2 CC := + IsScalarTower.of_algebraMap_eq' (by + ext z + rfl) + let eRing : CC ≃+* B := + integralClosureRingEquivOfIntegralTower A R1 E + let e : CC ≃ₐ[R2] B := + { eRing with + commutes' := fun x => by + apply Subtype.ext + calc + ((eRing ((algebraMap R2 CC) x) : B) : E) = + ((algebraMap R2 CC) x : CC) := + integralClosureRingEquivOfIntegralTower_coe A R1 E _ + _ = algebraMap N E (x : N) := rfl + _ = ((algebraMap R2 B) x : B) := + (exactConstantExtensionInfinityNormalizationAlgebra_coe + C S N hExact x).symm } + have hTargetInjective : Function.Injective (algebraMap R2 CC) := + normalization_map_injective Subtype.val Subtype.val Subtype.val_injective (fun _ => rfl) + let : Module.IsTorsionFree R2 CC := + (Module.isTorsionFree_iff_algebraMap_injective).2 hTargetInjective + let : Module.IsTorsionFree R2 B := + Function.Injective.moduleIsTorsionFree e.symm e.symm.injective (map_smul e.symm.toLinearEquiv) + let w := exactConstantExtensionUpstairsInfinityPlace C S N hExact q.1 q.2 + let QI : Ideal CC := Ideal.comap eRing.toRingHom w.1 + have hQIPrime : QI.IsPrime := Ideal.comap_isPrime (f := eRing.toRingHom) (K := w.1) + have heMap : eRing.toRingHom.comp (algebraMap A CC) = + (algebraMap R1 B).comp (ratFuncInfinityIntegersRingHom C S) := by + apply RingHom.ext + intro x + apply Subtype.ext + calc + ((eRing (algebraMap A CC x) : B) : E) = + ((algebraMap A CC x : CC) : E) := + integralClosureRingEquivOfIntegralTower_coe A R1 E _ + _ = algebraMap (RatFunc C) E x.1 := rfl + _ = algebraMap (RatFunc S) E + (ratFuncCoefficientAlgHom C S x.1) := + DFunLike.congr_fun + (rationalBase_algebraMap_eq C S N hExact) x.1 + _ = ((algebraMap R1 B + (ratFuncInfinityIntegersRingHom C S x) : B) : E) := rfl + have hQIOver : QI.LiesOver (ratFuncInfinityPlace C).asIdeal := + comap_liesOver_of_commutes eRing.toRingHom + (ratFuncInfinityIntegersRingHom C S) heMap + (ratFuncInfinityPlace C).asIdeal (ratFuncInfinityPlace S).asIdeal w.1 + (ratFuncInfinityIntegersRingHom_comap_infinityPlace C S) + let Q : FiniteExtensionInfinityPlace C E := + ⟨QI, hQIPrime, hQIOver⟩ + let qH := primeOverHeightOne (ratFuncInfinityPlace C) Q + let wH := primeOverHeightOne (ratFuncInfinityPlace S) w + have hCompat : heightOneSpectrumEquivOfAlgEquiv e qH = wH := by + apply HeightOneSpectrum.ext + rw [heightOneSpectrumEquivOfAlgEquiv_asIdeal] + dsimp only [qH, wH, primeOverHeightOne, Q, QI] + exact Ideal.comap_of_equiv eRing.symm + let P := infinityPlaceUnder C N E Q + let pH := primeOverHeightOne (ratFuncInfinityPlace C) P + let : qH.asIdeal.LiesOver pH.asIdeal := ⟨by + dsimp only [qH, pH, primeOverHeightOne] + change P.1 = Q.1.comap (algebraMap R2 CC) + exact infinityPlaceUnder_asIdeal C N E Q⟩ + let : (heightOneSpectrumEquivOfAlgEquiv e qH).asIdeal.LiesOver + pH.asIdeal := ⟨by + rw [hCompat] + dsimp only [wH, pH, primeOverHeightOne] + change P.1 = w.1.comap (algebraMap R2 B) + rw [show P.1 = Q.1.comap (algebraMap R2 CC) by + exact infinityPlaceUnder_asIdeal C N E Q] + ext x + change eRing (algebraMap R2 CC x) ∈ w.1 ↔ + algebraMap R2 B x ∈ w.1 + have he := e.commutes x + change eRing (algebraMap R2 CC x) = algebraMap R2 B x at he + rw [he]⟩ + change w.1.ramificationIdx R2 = 1 + calc + w.1.ramificationIdx R2 = + (heightOneSpectrumEquivOfAlgEquiv e qH).asIdeal.ramificationIdx R2 := by + rw [hCompat] + rfl + _ = qH.asIdeal.ramificationIdx R2 := + ramificationIdx_algEquiv e pH qH + _ = 1 := by + exact exactConstantExtensionInfinityPlace_ramificationIdx_eq_one + C S N hExact Q + +private theorem different_ne_bot_of_fraction_fields + (A B K L : Type*) [CommRing A] [IsDomain A] [IsIntegrallyClosed A] + [CommRing B] [IsDedekindDomain B] [Field K] [Field L] + [Algebra A K] [IsFractionRing A K] [Algebra B L] [IsFractionRing B L] + [Algebra A L] [Algebra K L] [Algebra.IsSeparable K L] + [IsScalarTower A K L] [Algebra A B] [IsScalarTower A B L] + [Module.Finite A B] [Module.IsTorsionFree A B] : differentIdeal A B ≠ ⊥ := by + let : Algebra A (FractionRing A) := + exactConstantDifferentCoefficientCanonicalFractionRingAlgebra A + let : SMul A (FractionRing A) := Algebra.toSMul + let : IsFractionRing A (FractionRing A) := + exactConstantDifferentCoefficientCanonicalFractionRing A + let : Algebra B (FractionRing B) := + exactConstantDifferentCoefficientCanonicalFractionRingAlgebra B + let : SMul B (FractionRing B) := Algebra.toSMul + let : IsFractionRing B (FractionRing B) := + exactConstantDifferentCoefficientCanonicalFractionRing B + let : Algebra A (FractionRing B) := + RingHom.toAlgebra ((algebraMap B (FractionRing B)).comp (algebraMap A B)) + let : SMul A (FractionRing B) := Algebra.toSMul + let : IsScalarTower A B (FractionRing B) := IsScalarTower.of_algebraMap_eq' rfl + let : FaithfulSMul A (FractionRing B) := by + rw [faithfulSMul_iff_algebraMap_injective] + change Function.Injective + ((algebraMap B (FractionRing B)).comp (algebraMap A B)) + exact (IsFractionRing.injective B (FractionRing B)).comp + (FaithfulSMul.algebraMap_injective A B) + let : Algebra (FractionRing A) (FractionRing B) := FractionRing.liftAlgebra A (FractionRing B) + let : SMul (FractionRing A) (FractionRing B) := Algebra.toSMul + let : IsScalarTower A (FractionRing A) (FractionRing B) := + FractionRing.isScalarTower_liftAlgebra A (FractionRing B) + let : Algebra.IsSeparable (FractionRing A) (FractionRing B) := by + refine Algebra.IsSeparable.of_equiv_equiv + (FractionRing.algEquiv A K).symm.toRingEquiv + (FractionRing.algEquiv B L).symm.toRingEquiv ?_ + ext z + exact IsFractionRing.algEquiv_commutes + (FractionRing.algEquiv A K).symm (FractionRing.algEquiv B L).symm z + exact differentIdeal_ne_bot + + +private theorem exactConstantExtension_presented_totalDifferentMultiplicity_eq_finite + (hExact : algebraicClosure C N = + (⊥ : IntermediateField C N)) + (q : HeightOneSpectrum + (integralClosure S[X] (ExactConstantExtension C N S))) : + let E := ExactConstantExtension C N S + let : Field E := exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) E := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : SMul (RatFunc C) E := Algebra.toSMul + let : Module (RatFunc C) E := Algebra.toModule + let : FiniteDimensional (RatFunc C) E := + finiteDimensional_exactConstantExtension_over_baseRatFunc + C S N hExact + let : Algebra.IsSeparable (RatFunc C) E := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + let : Algebra (RatFunc S) E := + ratFuncExactConstantExtensionAlgebra C S N hExact + let : SMul (RatFunc S) E := Algebra.toSMul + let : Module (RatFunc S) E := Algebra.toModule + let : Algebra S[X] E := + constantExtensionTensorPolynomialAlgebra C S N + let : SMul S[X] E := Algebra.toSMul + let : Module S[X] E := Algebra.toModule + let : IsScalarTower S[X] (RatFunc S) E := + IsScalarTower.of_algebraMap_eq' (by + apply DFunLike.ext _ _ + intro p + change algebraMap S[X] E p = + ratFuncToExactConstantExtension C S N hExact + (algebraMap S[X] (RatFunc S) p) + exact + (ratFuncToExactConstantExtension_algebraMap C S N hExact p).symm) + let : FiniteDimensional (RatFunc S) E := + finiteDimensional_over_extendedRatFunc C S N hExact + let : Algebra.IsSeparable (RatFunc S) E := + isSeparable_over_extendedRatFunc C S N hExact + finiteExtensionTotalDifferentEffectiveDivisor S E + (exactConstantExtensionPresentedUpstairsPlaceEquiv + C S N hExact (.inl q)) = + finiteExtensionTotalDifferentEffectiveDivisor C N + (exactConstantExtensionPresentedDownstairsPlace + C S N hExact (.inl q)) := by + intro E model1 model2 model3 model4 model5 model6 model7 model8 model9 + model10 model11 model12 model13 model14 model15 + let : Algebra S[X] (RatFunc S) := + inferInstance + let : IsFractionRing S[X] (RatFunc S) := + inferInstance + let : Module.IsTorsionFree S[X] E := + Module.IsTorsionFree.trans_faithfulSMul S[X] (RatFunc S) E + let : IsDedekindDomain (integralClosure S[X] E) := + IsIntegralClosure.isDedekindDomain S[X] (RatFunc S) E + (integralClosure S[X] E) + let : Module.IsTorsionFree S[X] (integralClosure S[X] E) := + IsIntegralClosure.isTorsionFree S[X] E + let R2 := RatFuncFiniteIntegralClosure C N + let B := integralClosure S[X] E + let : Algebra C[X] (RatFunc C) := inferInstance + let : IsFractionRing C[X] (RatFunc C) := inferInstance + let : IsScalarTower C[X] (RatFunc C) N := + IsScalarTower.of_algebraMap_eq' rfl + let : IsDedekindDomain R2 := + IsIntegralClosure.isDedekindDomain C[X] (RatFunc C) N R2 + let : Module.IsTorsionFree C[X] N := by + rw [Module.isTorsionFree_iff_algebraMap_injective] + change Function.Injective + ((algebraMap (RatFunc C) N).comp + (algebraMap C[X] (RatFunc C))) + exact (algebraMap (RatFunc C) N).injective.comp + (RatFunc.algebraMap_injective C) + let : Module.IsTorsionFree C[X] R2 := + IsIntegralClosure.isTorsionFree C[X] N + let : Algebra R2 B := + exactConstantExtensionFiniteNormalizationAlgebra C S N + let : SMul R2 B := Algebra.toSMul + let : Module R2 B := Algebra.toModule + let : SMul C R2 := Algebra.toSMul + let : Module C R2 := Algebra.toModule + let : Module.Free C R2 := Module.Free.of_divisionRing C R2 + let : Module.Flat C R2 := Module.Flat.of_free + let eNorm : S ⊗[C] R2 ≃+* B := + finiteFieldConstantExtensionIntegralClosureRingEquiv C S N + let : Module.IsTorsionFree R2 B := by + rw [Module.isTorsionFree_iff_algebraMap_injective] + change Function.Injective + (eNorm.toRingHom.comp + (Algebra.TensorProduct.includeRight + (R := C) (A := S) (B := R2)).toRingHom) + exact eNorm.injective.comp + (Algebra.TensorProduct.includeRight_injective + (R := C) (A := S) (B := R2) (algebraMap C S).injective) + let a : Algebra S[X] E := + constantExtensionTensorPolynomialAlgebra C S N + have hAlgebra : ratFuncInducedPolynomialAlgebra S E = a := + ratFuncInducedPolynomialAlgebra_eq S E a + (ratFuncToExactConstantExtension_algebraMap C S N hExact) + let e := integralClosureAlgEquivRatFuncFiniteOfEq + S E a hAlgebra + have hDifferent : + differentIdeal S[X] (RatFuncFiniteIntegralClosure S E) = + Ideal.map e + (differentIdeal S[X] (integralClosure S[X] E)) := + finiteNormalization_differentIdeal_eq_map + a hAlgebra inferInstance inferInstance + have hUpstairs : + exactConstantExtensionUpstairsFinitePlace C S N hExact q = + heightOneSpectrumEquivOfAlgEquiv e q := by + simpa [e, a, hAlgebra, + integralClosureAlgEquivRatFuncFiniteOfAlgebraMap] using + (exactConstantExtensionUpstairsFinitePlace_eq_compatibleNormalizationTransport + C S N hExact q) + rw [exactConstantExtensionPresentedUpstairsPlaceEquiv_apply] + simp only [exactConstantExtensionPresentedUpstairsPlace, + exactConstantExtensionPresentedDownstairsPlace, + finiteExtensionTotalDifferentEffectiveDivisor_inl] + rw [hUpstairs, hDifferent] + rw [finiteNormalization_multiplicity_map_eq + a hAlgebra q + (differentIdeal S[X] (integralClosure S[X] E))] + rw [exactConstantExtension_finiteDifferent_eq_map C S N hExact] + let P := exactConstantExtensionDownstairsFinitePlace C S N hExact q + let : q.asIdeal.LiesOver P.asIdeal := ⟨by + change P.asIdeal = q.asIdeal.comap (algebraMap R2 B) + rfl⟩ + have hDifferentBase : + differentIdeal C[X] R2 ≠ ⊥ := + finiteExtensionFiniteDifferentIdeal_ne_bot C N + calc + multiplicity q.asIdeal + (Ideal.map (algebraMap R2 B) + (differentIdeal C[X] R2)) = + q.asIdeal.ramificationIdx R2 * + multiplicity P.asIdeal (differentIdeal C[X] R2) := + multiplicity_map_eq_ramificationIdx_mul + (R := R2) (S := B) P q + (differentIdeal C[X] R2) hDifferentBase + _ = multiplicity P.asIdeal (differentIdeal C[X] R2) := by + have hRam : q.asIdeal.ramificationIdx R2 = 1 := by + exact exactConstantExtensionPresentedFinitePlace_ramificationIdx_eq_one + C S N hExact q + rw [hRam] + simp only [one_mul] + + +private theorem exactConstantExtension_presented_totalDifferentMultiplicity_eq_infinity + (hExact : algebraicClosure C N = + (⊥ : IntermediateField C N)) + (q : ExactConstantExtensionPresentedInfinityPlace C S N) : + let E := ExactConstantExtension C N S + let : Field E := exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) E := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : SMul (RatFunc C) E := Algebra.toSMul + let : Module (RatFunc C) E := Algebra.toModule + let : FiniteDimensional (RatFunc C) E := + finiteDimensional_exactConstantExtension_over_baseRatFunc + C S N hExact + let : Algebra.IsSeparable (RatFunc C) E := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + let : Algebra (RatFunc S) E := + ratFuncExactConstantExtensionAlgebra C S N hExact + let : SMul (RatFunc S) E := Algebra.toSMul + let : Module (RatFunc S) E := Algebra.toModule + let : Algebra S[X] E := + constantExtensionTensorPolynomialAlgebra C S N + let : SMul S[X] E := Algebra.toSMul + let : Module S[X] E := Algebra.toModule + let : IsScalarTower S[X] (RatFunc S) E := + IsScalarTower.of_algebraMap_eq' (by + apply DFunLike.ext _ _ + intro p + change algebraMap S[X] E p = + ratFuncToExactConstantExtension C S N hExact + (algebraMap S[X] (RatFunc S) p) + exact + (ratFuncToExactConstantExtension_algebraMap C S N hExact p).symm) + let : FiniteDimensional (RatFunc S) E := + finiteDimensional_over_extendedRatFunc C S N hExact + let : Algebra.IsSeparable (RatFunc S) E := + isSeparable_over_extendedRatFunc C S N hExact + finiteExtensionTotalDifferentEffectiveDivisor S E + (exactConstantExtensionPresentedUpstairsPlaceEquiv + C S N hExact (.inr q)) = + finiteExtensionTotalDifferentEffectiveDivisor C N + (exactConstantExtensionPresentedDownstairsPlace + C S N hExact (.inr q)) := by + intro E model1 model2 model3 model4 model5 model6 model7 model8 model9 + model10 model11 model12 model13 model14 model15 + rw [exactConstantExtensionPresentedUpstairsPlaceEquiv_apply] + simp only [exactConstantExtensionPresentedUpstairsPlace, + exactConstantExtensionPresentedDownstairsPlace, + finiteExtensionTotalDifferentEffectiveDivisor_inr] + let A := RatFuncInfinityIntegers C + let R1 := RatFuncInfinityIntegers S + let R2 := RatFuncInfinityIntegralClosure C N + let B := RatFuncInfinityIntegralClosure S E + let : Algebra N E := exactConstantExtensionAlgebra C N S + let : SMul N E := Algebra.toSMul + let : Module N E := Algebra.toModule + let : IsScalarTower (RatFunc C) N E := + exactConstantExtensionBaseTower C (RatFunc C) N S + let : Algebra A (RatFunc C) := Algebra.ofSubsemiring A + let : SMul A (RatFunc C) := Algebra.toSMul + let : Module A (RatFunc C) := Algebra.toModule + let : IsFractionRing A (RatFunc C) := + IsFractionRing.of_algEquiv (ratFuncInfinityFractionRingEquiv C) + let : Algebra R1 (RatFunc S) := Algebra.ofSubsemiring R1 + let : SMul R1 (RatFunc S) := Algebra.toSMul + let : Module R1 (RatFunc S) := Algebra.toModule + let : IsFractionRing R1 (RatFunc S) := + IsFractionRing.of_algEquiv (ratFuncInfinityFractionRingEquiv S) + let : Algebra A N := Algebra.ofSubsemiring A + let : SMul A N := Algebra.toSMul + let : Module A N := Algebra.toModule + let : IsScalarTower A (RatFunc C) N := + IsScalarTower.of_algebraMap_eq' rfl + let : Algebra R1 E := Algebra.ofSubsemiring R1 + let : SMul R1 E := Algebra.toSMul + let : Module R1 E := Algebra.toModule + let : IsScalarTower R1 (RatFunc S) E := + IsScalarTower.of_algebraMap_eq' rfl + let : Algebra A R1 := + RingHom.toAlgebra (ratFuncInfinityIntegersRingHom C S) + let : SMul A R1 := Algebra.toSMul + let : Module A R1 := Algebra.toModule + let : IsDedekindDomain R2 := + integralClosure.isDedekindDomain A (RatFunc C) N + let : IsDedekindDomain B := + integralClosure.isDedekindDomain R1 (RatFunc S) E + let : Algebra A R2 := inferInstance + let : SMul A R2 := Algebra.toSMul + let : Module A R2 := Algebra.toModule + let : Algebra R2 N := Algebra.ofSubsemiring R2 + let : SMul R2 N := Algebra.toSMul + let : Module R2 N := Algebra.toModule + let : IsScalarTower A R2 N := + IsScalarTower.of_algebraMap_eq' (by ext z; rfl) + let : IsIntegralClosure R2 A N := + integralClosure.isIntegralClosure A N + let : Module.Finite A R2 := + IsIntegralClosure.finite A (RatFunc C) N R2 + let : Module.IsTorsionFree A R2 := + IsIntegralClosure.isTorsionFree A N + let : Module.IsTorsionFree R1 E := by + rw [Module.isTorsionFree_iff_algebraMap_injective] + exact (algebraMap (RatFunc S) E).injective.comp + (IsFractionRing.injective R1 (RatFunc S)) + let : Module.IsTorsionFree R1 B := + IsIntegralClosure.isTorsionFree R1 E + let : Algebra R2 B := + exactConstantExtensionInfinityNormalizationAlgebra C S N hExact + let : SMul R2 B := Algebra.toSMul + let : Module R2 B := Algebra.toModule + let : Module.IsTorsionFree R2 B := by + rw [Module.isTorsionFree_iff_algebraMap_injective] + exact normalization_map_injective Subtype.val Subtype.val + Subtype.val_injective + (exactConstantExtensionInfinityNormalizationAlgebra_coe C S N hExact) + let : IsFractionRing R2 N := + IsIntegralClosure.isFractionRing_of_finite_extension + A (RatFunc C) N R2 + rw [exactConstantExtension_infinityDifferent_eq_map C S N hExact] + let w := exactConstantExtensionUpstairsInfinityPlace + C S N hExact q.1 q.2 + let wH := primeOverHeightOne (ratFuncInfinityPlace S) w + let P := exactConstantExtensionDownstairsInfinityPlace C S N q.1 q.2 + let pH := primeOverHeightOne (ratFuncInfinityPlace C) P + let : wH.asIdeal.LiesOver pH.asIdeal := ⟨by + change P.1 = w.1.comap (algebraMap R2 B) + exact (exactConstantExtensionUpstairsInfinityPlace_under + C S N hExact q).symm⟩ + have hDifferentBase : + differentIdeal (RatFuncInfinityIntegers C) R2 ≠ ⊥ := + different_ne_bot_of_fraction_fields A R2 (RatFunc C) N + calc + multiplicity w.1 + (Ideal.map (algebraMap R2 B) + (differentIdeal (RatFuncInfinityIntegers C) R2)) = + w.1.ramificationIdx R2 * + multiplicity pH.asIdeal + (differentIdeal (RatFuncInfinityIntegers C) R2) := by + exact multiplicity_map_eq_ramificationIdx_mul + (R := R2) (S := B) pH wH + (differentIdeal (RatFuncInfinityIntegers C) R2) hDifferentBase + _ = multiplicity P.1 + (differentIdeal (RatFuncInfinityIntegers C) R2) := by + change w.1.ramificationIdx R2 * + multiplicity P.1 (differentIdeal A R2) = + multiplicity P.1 (differentIdeal A R2) + have hRam : w.1.ramificationIdx R2 = 1 := + exactConstantExtensionPresentedInfinityPlace_ramificationIdx_eq_one + C S N hExact q + rw [hRam] + simp only [one_mul] + + +/-- Exact constant extension preserves the total-different coefficient at +every presented finite or infinity place. -/ +theorem exactConstantExtension_presented_totalDifferentMultiplicity_eq + (hExact : algebraicClosure C N = + (⊥ : IntermediateField C N)) + (q : ExactConstantExtensionPresentedPlace C S N) : + let E := ExactConstantExtension C N S + let : Field E := exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) E := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : SMul (RatFunc C) E := Algebra.toSMul + let : Module (RatFunc C) E := Algebra.toModule + let : FiniteDimensional (RatFunc C) E := + finiteDimensional_exactConstantExtension_over_baseRatFunc + C S N hExact + let : Algebra.IsSeparable (RatFunc C) E := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + let : Algebra (RatFunc S) E := + ratFuncExactConstantExtensionAlgebra C S N hExact + let : SMul (RatFunc S) E := Algebra.toSMul + let : Module (RatFunc S) E := Algebra.toModule + let : Algebra S[X] E := + constantExtensionTensorPolynomialAlgebra C S N + let : SMul S[X] E := Algebra.toSMul + let : Module S[X] E := Algebra.toModule + let : IsScalarTower S[X] (RatFunc S) E := + IsScalarTower.of_algebraMap_eq' (by + apply DFunLike.ext _ _ + intro p + change algebraMap S[X] E p = + ratFuncToExactConstantExtension C S N hExact + (algebraMap S[X] (RatFunc S) p) + exact + (ratFuncToExactConstantExtension_algebraMap C S N hExact p).symm) + let : FiniteDimensional (RatFunc S) E := + finiteDimensional_over_extendedRatFunc C S N hExact + let : Algebra.IsSeparable (RatFunc S) E := + isSeparable_over_extendedRatFunc C S N hExact + finiteExtensionTotalDifferentEffectiveDivisor S E + (exactConstantExtensionPresentedUpstairsPlaceEquiv + C S N hExact q) = + finiteExtensionTotalDifferentEffectiveDivisor C N + (exactConstantExtensionPresentedDownstairsPlace + C S N hExact q) := by + cases q with + | inl q => + exact exactConstantExtension_presented_totalDifferentMultiplicity_eq_finite + C S N hExact q + | inr q => + exact exactConstantExtension_presented_totalDifferentMultiplicity_eq_infinity + C S N hExact q + +/-- Exact finite extension of the full constant field preserves intrinsic +function-field genus. -/ +theorem exactConstantExtension_genus_eq + (hExact : algebraicClosure C N = + (⊥ : IntermediateField C N)) : + let E := ExactConstantExtension C N S + letI : Field E := exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc S) E := + ratFuncExactConstantExtensionAlgebra C S N hExact + FunctionField.genus S E = FunctionField.genus C N := by + dsimp only + let E := ExactConstantExtension C N S + let : Field E := exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) E := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : SMul (RatFunc C) E := Algebra.toSMul + let : Module (RatFunc C) E := Algebra.toModule + let : FiniteDimensional (RatFunc C) E := + finiteDimensional_exactConstantExtension_over_baseRatFunc + C S N hExact + let : Algebra.IsSeparable (RatFunc C) E := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + let : Algebra (RatFunc S) E := + ratFuncExactConstantExtensionAlgebra C S N hExact + let : SMul (RatFunc S) E := Algebra.toSMul + let : Module (RatFunc S) E := Algebra.toModule + let : FiniteDimensional (RatFunc S) E := + finiteDimensional_over_extendedRatFunc C S N hExact + let : Algebra.IsSeparable (RatFunc S) E := + isSeparable_over_extendedRatFunc C S N hExact + let extendedConstantAlgebra : Algebra S E := + RingHom.toAlgebra ((algebraMap (RatFunc S) E).comp + (algebraMap S (RatFunc S))) + let tensorConstantAlgebra : Algebra S E := + Algebra.TensorProduct.leftAlgebra + have hconstantMap (s : S) : + (@algebraMap S E _ _ extendedConstantAlgebra) s = + (@algebraMap S E _ _ tensorConstantAlgebra) s := by + exact (ratFuncToExactConstantExtension C S N hExact).commutes s + have hConstantAlgebra : + tensorConstantAlgebra = extendedConstantAlgebra := by + apply Algebra.algebra_ext + intro s + exact (hconstantMap s).symm + have hIntrinsicGenus : + @FunctionField.genus S E _ _ tensorConstantAlgebra = + @FunctionField.genus S E _ _ extendedConstantAlgebra := by + rw [hConstantAlgebra] + have htensorPolynomialMap (s : S) : + (@algebraMap S E _ _ tensorConstantAlgebra) s = + (@algebraMap S[X] E _ _ + (constantExtensionTensorPolynomialAlgebra C S N)) + (algebraMap S S[X] s) := by + change (s ⊗ₜ[C] (1 : N)) = + Polynomial.aeval + (polynomialTensorCancelEvaluationPoint C S N) + (Polynomial.C s) + simp + let : Algebra S E := extendedConstantAlgebra + let : SMul S E := Algebra.toSMul + let : Algebra S[X] E := + constantExtensionTensorPolynomialAlgebra C S N + let : SMul S[X] E := Algebra.toSMul + let : IsScalarTower S[X] (RatFunc S) E := + IsScalarTower.of_algebraMap_eq' (by + apply DFunLike.ext _ _ + intro p + change algebraMap S[X] E p = + ratFuncToExactConstantExtension C S N hExact + (algebraMap S[X] (RatFunc S) p) + exact + (ratFuncToExactConstantExtension_algebraMap C S N hExact p).symm) + let : IsScalarTower S S[X] E := + IsScalarTower.of_algebraMap_eq' (by + apply DFunLike.ext _ _ + intro s + exact (hconstantMap s).trans (htensorPolynomialMap s)) + let : FunctionField.IsFullConstantField C N := + (FunctionField.isFullConstantField_iff_algebraicClosure_eq_bot C N).2 + hExact + let : FunctionField.IsFullConstantField S E := + (FunctionField.isFullConstantField_iff_algebraicClosure_eq_bot S E).2 + (by + simpa only [E] using + (exactConstantExtension_extended_algebraicClosure_eq_bot + C S N hExact)) + calc + @FunctionField.genus S E _ _ tensorConstantAlgebra = + @FunctionField.genus S E _ _ extendedConstantAlgebra := + hIntrinsicGenus + _ = FunctionField.Chart.genus S E := + FunctionField.genus_eq_genusChart S E + _ = FunctionField.Chart.genus C N := + exactConstantExtension_chart_genus_eq_of_presentedMultiplicity + C S N hExact + (exactConstantExtension_presented_totalDifferentMultiplicity_eq + C S N hExact) + _ = FunctionField.genus C N := + (FunctionField.genus_eq_genusChart C N).symm + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionFiniteDifferent.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionFiniteDifferent.lean new file mode 100644 index 0000000000..e0a2b4dd0f --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionFiniteDifferent.lean @@ -0,0 +1,670 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteFieldPolynomialDifferent +public import LeanPool.MarkoffModP.BGS.HasseWeil.RatFuncExactConstantExtension +public import Mathlib.RingTheory.DedekindDomain.LinearDisjoint + +/-! +# The finite different after exact constant extension + +This file supplies the field-theoretic input for transporting the finite +different through an exact finite constant extension. Inside +`ExactConstantExtension C N S`, the copies of `S(X)` and `N` generate the +whole tensor field and are linearly disjoint over `C(X)`. The proof uses the +explicit tensor generation and the extension-degree formulas already proved +for rational-function and exact constant extensions. +-/ + +@[expose] public section + +open scoped Polynomial TensorProduct + +namespace BGS.HasseWeil + +noncomputable section + + +/-- The canonical polynomial algebra structure on the rational function field. -/ +@[reducible] noncomputable def + finiteDifferentCanonicalRatFuncPolynomialAlgebra + (K : Type*) [Field K] : Algebra K[X] (RatFunc K) := inferInstance + +/-- The rational function field is the fraction field of its canonical polynomial algebra. -/ +theorem finiteDifferentCanonicalRatFuncPolynomialFractionRing + (K : Type*) [Field K] : + letI := finiteDifferentCanonicalRatFuncPolynomialAlgebra K + IsFractionRing K[X] (RatFunc K) := by + let := finiteDifferentCanonicalRatFuncPolynomialAlgebra K + infer_instance + +@[reducible] private noncomputable def + finiteDifferentCanonicalFractionRingAlgebra + (R : Type*) [CommRing R] [IsDomain R] : + Algebra R (FractionRing R) := inferInstance + +private theorem finiteDifferentCanonicalFractionRing + (R : Type*) [CommRing R] [IsDomain R] : + letI := finiteDifferentCanonicalFractionRingAlgebra R + IsFractionRing R (FractionRing R) := by + let := finiteDifferentCanonicalFractionRingAlgebra R + infer_instance + +private theorem different_eq_map_of_disjoint_fields + (A B R₁ R₂ K L : Type*) + [CommRing A] [IsDomain A] [IsIntegrallyClosed A] + [CommRing B] [IsDedekindDomain B] + [CommRing R₁] [IsDedekindDomain R₁] + [CommRing R₂] [IsDedekindDomain R₂] [Field K] [Field L] + [Algebra A K] [IsFractionRing A K] [Algebra B L] [IsFractionRing B L] + [Algebra A L] [Algebra K L] [FiniteDimensional K L] [Algebra.IsSeparable K L] + [IsScalarTower A K L] [Algebra A B] [IsScalarTower A B L] + [FaithfulSMul A B] [Module.Finite A B] [Module.IsTorsionFree A B] + [Algebra A R₁] [Algebra A R₂] [Algebra R₁ B] [Algebra R₂ B] + [Algebra R₁ L] [Algebra R₂ L] + [IsScalarTower A R₁ L] [IsScalarTower R₁ B L] [IsScalarTower R₂ B L] + [Module.Finite A R₁] [Module.Finite A R₂] [Module.Free A R₂] + [Module.Finite R₁ B] [Module.Finite R₂ B] + [IsScalarTower A R₁ B] [IsScalarTower A R₂ B] + [Module.IsTorsionFree A R₁] [Module.IsTorsionFree A R₂] + [Module.IsTorsionFree R₁ B] [Module.IsTorsionFree R₂ B] + [IsIntegralClosure B R₁ L] + (F₁ F₂ : IntermediateField K L) + [Algebra R₁ F₁] [Algebra R₂ F₂] [Module.IsTorsionFree R₁ F₁] + [IsFractionRing R₁ F₁] [IsFractionRing R₂ F₂] + [IsScalarTower A F₂ L] [IsScalarTower A R₂ F₂] + [IsScalarTower R₁ F₁ L] [IsScalarTower R₂ F₂ L] + [Algebra.IsSeparable K F₂] [Algebra.IsSeparable F₁ L] + [IsLocalization (Algebra.algebraMapSubmonoid R₂ (nonZeroDivisors A)) F₂] + (hdisjoint : F₁.LinearDisjoint F₂) (hsup : F₁ ⊔ F₂ = ⊤) + (hcoprime : IsCoprime + ((differentIdeal A R₁).map (algebraMap R₁ B)) + ((differentIdeal A R₂).map (algebraMap R₂ B))) : + differentIdeal R₁ B = Ideal.map (algebraMap R₂ B) (differentIdeal A R₂) := by + let : Algebra A (FractionRing A) := finiteDifferentCanonicalFractionRingAlgebra A + let : SMul A (FractionRing A) := Algebra.toSMul + let : IsFractionRing A (FractionRing A) := finiteDifferentCanonicalFractionRing A + let : Algebra B (FractionRing B) := finiteDifferentCanonicalFractionRingAlgebra B + let : SMul B (FractionRing B) := Algebra.toSMul + let : IsFractionRing B (FractionRing B) := finiteDifferentCanonicalFractionRing B + let : Algebra A (FractionRing B) := + RingHom.toAlgebra ((algebraMap B (FractionRing B)).comp (algebraMap A B)) + let : SMul A (FractionRing B) := Algebra.toSMul + let : IsScalarTower A B (FractionRing B) := IsScalarTower.of_algebraMap_eq' rfl + let : FaithfulSMul A (FractionRing B) := by + rw [faithfulSMul_iff_algebraMap_injective] + change Function.Injective + ((algebraMap B (FractionRing B)).comp (algebraMap A B)) + exact (IsFractionRing.injective B (FractionRing B)).comp + (FaithfulSMul.algebraMap_injective A B) + let : Algebra (FractionRing A) (FractionRing B) := FractionRing.liftAlgebra A (FractionRing B) + let : SMul (FractionRing A) (FractionRing B) := Algebra.toSMul + let : IsScalarTower A (FractionRing A) (FractionRing B) := + FractionRing.isScalarTower_liftAlgebra A (FractionRing B) + let : Algebra.IsSeparable (FractionRing A) (FractionRing B) := by + refine Algebra.IsSeparable.of_equiv_equiv + (FractionRing.algEquiv A K).symm.toRingEquiv + (FractionRing.algEquiv B L).symm.toRingEquiv ?_ + ext z + exact IsFractionRing.algEquiv_commutes + (FractionRing.algEquiv A K).symm (FractionRing.algEquiv B L).symm z + exact IsDedekindDomain.differentIdeal_eq_map_differentIdeal + (K := K) (L := L) (F₁ := F₁) (F₂ := F₂) A B R₁ R₂ hdisjoint hsup hcoprime + +private theorem finite_torsionFree_of_integral_base_change + (A R₁ R₂ B K L : Type*) + [CommRing A] [CommRing R₁] [CommRing R₂] [CommRing B] [Field K] [Field L] + [IsDedekindDomain R₂] + [Algebra A R₁] [Algebra A R₂] [Algebra A L] + [Algebra R₁ L] [Algebra R₂ L] [Algebra B L] [Algebra R₂ B] + [Algebra R₂ K] [IsFractionRing R₂ K] [Algebra K L] + [IsScalarTower R₂ K L] [IsScalarTower R₂ B L] [Module.IsTorsionFree R₂ L] + [IsScalarTower A R₁ L] [IsScalarTower A R₂ L] + [Algebra.IsIntegral A R₁] [Algebra.IsIntegral A R₂] + [FiniteDimensional K L] [Algebra.IsSeparable K L] + [IsIntegralClosure B R₁ L] : + Module.Finite R₂ B ∧ Module.IsTorsionFree R₂ B := by + let : IsIntegralClosure B R₂ L := by + refine ⟨IsIntegralClosure.algebraMap_injective B R₁ L, ?_⟩ + intro x + constructor + · intro hx + have hxA : IsIntegral A x := isIntegral_trans (R := A) x hx + exact (IsIntegralClosure.isIntegral_iff (A := B) (R := R₁)).mp hxA.tower_top + · intro hx + have hxR₁ : IsIntegral R₁ x := + (IsIntegralClosure.isIntegral_iff (A := B) (R := R₁)).mpr hx + exact (isIntegral_trans (R := A) x hxR₁).tower_top + exact ⟨IsIntegralClosure.finite R₂ K L B, IsIntegralClosure.isTorsionFree R₂ L⟩ + +/-- Base change preserves the relative different when the fraction-field images are linearly +disjoint, generate the ambient field, and the original differents are coprime. -/ +theorem different_eq_map_of_linearlyDisjoint_fieldRanges + (A R₁ R₂ B K K₁ K₂ L : Type*) + [CommRing A] [IsDomain A] [IsPrincipalIdealRing A] + [CommRing R₁] [IsDedekindDomain R₁] + [CommRing R₂] [IsDedekindDomain R₂] [CommRing B] [IsDedekindDomain B] + [Field K] [Field K₁] [Field K₂] [Field L] + [Algebra A K] [IsFractionRing A K] + [Algebra K K₁] [Algebra K K₂] [Algebra K L] + [Algebra K₁ L] [Algebra K₂ L] [Algebra A K₂] + [IsScalarTower K K₁ L] [IsScalarTower K K₂ L] [IsScalarTower A K K₂] + [Algebra A R₁] [Algebra A R₂] [Algebra A B] [Algebra A L] + [Algebra R₁ K₁] [IsFractionRing R₁ K₁] + [Algebra R₂ K₂] [IsFractionRing R₂ K₂] + [Algebra R₁ B] [Algebra R₂ B] [Algebra R₁ L] [Algebra R₂ L] [Algebra B L] + [IsScalarTower A K L] [IsScalarTower A K₂ L] + [IsScalarTower R₁ K₁ L] [IsScalarTower R₂ K₂ L] + [IsScalarTower A R₂ K₂] [IsScalarTower A R₁ L] [IsScalarTower A R₂ L] + [IsScalarTower A R₁ B] [IsScalarTower A R₂ B] + [IsScalarTower R₁ B L] [IsScalarTower R₂ B L] [IsScalarTower A B L] + [FiniteDimensional K K₂] [FiniteDimensional K L] [Algebra.IsSeparable K L] + [Module.Finite A R₁] [Module.Finite A R₂] [Module.Free A R₂] + [Module.IsTorsionFree A R₁] [Module.IsTorsionFree A R₂] + [Module.IsTorsionFree R₁ L] [Module.IsTorsionFree R₂ L] + [Module.IsTorsionFree R₁ B] + [IsIntegralClosure R₂ A K₂] [IsIntegralClosure B R₁ L] + (hdisjoint : (IsScalarTower.toAlgHom K K₁ L).fieldRange.LinearDisjoint + (IsScalarTower.toAlgHom K K₂ L).fieldRange) + (hsup : (IsScalarTower.toAlgHom K K₁ L).fieldRange ⊔ + (IsScalarTower.toAlgHom K K₂ L).fieldRange = ⊤) + (hcoprime : IsCoprime ((differentIdeal A R₁).map (algebraMap R₁ B)) + ((differentIdeal A R₂).map (algebraMap R₂ B))) : + differentIdeal R₁ B = Ideal.map (algebraMap R₂ B) (differentIdeal A R₂) := by + let f₁ := IsScalarTower.toAlgHom K K₁ L + let f₂ := IsScalarTower.toAlgHom K K₂ L + let F₁ := f₁.fieldRange + let F₂ := f₂.fieldRange + let e₁ := f₁.equivFieldRange + let e₂ := f₂.equivFieldRange + let : Algebra R₁ F₁ := + RingHom.toAlgebra (e₁.toRingHom.comp (algebraMap R₁ K₁)) + let e₁inf : K₁ ≃ₐ[R₁] F₁ := { e₁.toRingEquiv with commutes' := fun _ => rfl } + let : IsFractionRing R₁ F₁ := IsFractionRing.of_algEquiv e₁inf + let : Module.IsTorsionFree R₁ F₁ := by + rw [Module.isTorsionFree_iff_algebraMap_injective] + exact IsFractionRing.injective R₁ F₁ + let : IsScalarTower R₁ F₁ L := IsScalarTower.of_algebraMap_eq (fun z => by + change algebraMap R₁ L z = algebraMap K₁ L (algebraMap R₁ K₁ z) + exact IsScalarTower.algebraMap_apply R₁ K₁ L z) + let : Algebra R₂ F₂ := + RingHom.toAlgebra (e₂.toRingHom.comp (algebraMap R₂ K₂)) + let e₂norm : K₂ ≃ₐ[R₂] F₂ := { e₂.toRingEquiv with commutes' := fun _ => rfl } + let : IsFractionRing R₂ F₂ := IsFractionRing.of_algEquiv e₂norm + let : IsScalarTower R₂ F₂ L := IsScalarTower.of_algebraMap_eq (fun z => by + change algebraMap R₂ L z = algebraMap K₂ L (algebraMap R₂ K₂ z) + exact IsScalarTower.algebraMap_apply R₂ K₂ L z) + let : Algebra A F₂ := IntermediateField.algebra' F₂ + let : IsScalarTower A R₂ F₂ := IsScalarTower.of_algebraMap_eq (fun z => by + apply Subtype.ext + change algebraMap A L z = algebraMap K₂ L (algebraMap R₂ K₂ (algebraMap A R₂ z)) + rw [← IsScalarTower.algebraMap_apply A R₂ K₂, + ← IsScalarTower.algebraMap_apply A K₂ L]) + let : IsScalarTower A F₂ L := IsScalarTower.of_algebraMap_eq' rfl + let : IsLocalization (Algebra.algebraMapSubmonoid R₂ (nonZeroDivisors A)) K₂ := + IsIntegralClosure.isLocalization A K K₂ R₂ + let : IsLocalization (Algebra.algebraMapSubmonoid R₂ (nonZeroDivisors A)) F₂ := + IsLocalization.isLocalization_of_algEquiv _ e₂norm + have hnormalization := finite_torsionFree_of_integral_base_change A R₁ R₂ B F₂ L + let : Module.Finite R₂ B := hnormalization.1 + let : Module.IsTorsionFree R₂ B := hnormalization.2 + let : Module.Finite R₁ B := IsIntegralClosure.finite R₁ F₁ L B + let : Module.Finite A B := Module.Finite.trans R₂ B + let : Module.IsTorsionFree A B := by + rw [Module.isTorsionFree_iff_algebraMap_injective] + have hR₂B := Module.isTorsionFree_iff_algebraMap_injective.mp + (show Module.IsTorsionFree R₂ B from inferInstance) + have hAR₂ := Module.isTorsionFree_iff_algebraMap_injective.mp + (show Module.IsTorsionFree A R₂ from inferInstance) + intro x y hxy + apply hAR₂ + apply hR₂B + exact (IsScalarTower.algebraMap_apply A R₂ B x).symm.trans + (hxy.trans (IsScalarTower.algebraMap_apply A R₂ B y)) + let : IsFractionRing B L := + IsIntegralClosure.isFractionRing_of_finite_extension R₁ F₁ L B + exact different_eq_map_of_disjoint_fields A B R₁ R₂ K L F₁ F₂ hdisjoint hsup hcoprime + +private theorem scalarTower_of_injective_algebraMap + (A R B L : Type*) [CommRing A] [CommRing R] [CommRing B] [CommRing L] + [Algebra A R] [Algebra A B] [Algebra A L] + [Algebra R B] [Algebra R L] [Algebra B L] + [IsScalarTower A R L] [IsScalarTower A B L] [IsScalarTower R B L] + (hinjective : Function.Injective (algebraMap B L)) : IsScalarTower A R B := by + apply IsScalarTower.of_algebraMap_eq + intro a + apply hinjective + rw [← IsScalarTower.algebraMap_apply A B L, + ← IsScalarTower.algebraMap_apply R B L, + ← IsScalarTower.algebraMap_apply A R L] + +variable (C S N : Type*) [Field C] [Field S] [Field N] + [Algebra (RatFunc C) N] [FiniteDimensional (RatFunc C) N] + [Algebra.IsSeparable (RatFunc C) N] + [Algebra C S] [FiniteDimensional C S] [IsGalois C S] + +local instance finiteDifferentBaseConstantAlgebra : Algebra C N := + RingHom.toAlgebra ((algebraMap (RatFunc C) N).comp + (algebraMap C (RatFunc C))) + +local instance finiteDifferentBasePolynomialAlgebra : Algebra C[X] N := + ratFuncInducedPolynomialAlgebra C N + +local instance finiteDifferentBaseConstantPolynomialTower : + IsScalarTower C C[X] N := + IsScalarTower.of_algebraMap_eq' (by ext c; rfl) + +local instance finiteDifferentCoefficientPolynomialAlgebra : + Algebra C[X] S[X] := Polynomial.algebra C S + +local instance finiteDifferentTargetPolynomialAlgebra : + Algebra S[X] (ExactConstantExtension C N S) := + constantExtensionTensorPolynomialAlgebra C S N + +local instance finiteDifferentTensorNormalizationPolynomialAlgebra : + Algebra S[X] (S ⊗[C] integralClosure C[X] N) := + constantExtensionNormalizationTensorPolynomialAlgebra C S N + +/-- The original finite normalization acts on the finite normalization after +constant extension through the right tensor factor and the canonical +normalization equivalence. -/ +@[reducible] noncomputable def + exactConstantExtensionFiniteNormalizationAlgebra + [Fintype C] [Finite S] : + Algebra (integralClosure C[X] N) + (integralClosure S[X] (ExactConstantExtension C N S)) := + by + let eNorm : + S ⊗[C] integralClosure C[X] N ≃+* + integralClosure S[X] (ExactConstantExtension C N S) := + finiteFieldConstantExtensionIntegralClosureRingEquiv C S N + exact RingHom.toAlgebra + (eNorm.toRingHom.comp + (Algebra.TensorProduct.includeRight + (R := C) (A := S) (B := integralClosure C[X] N)).toRingHom) + +variable (hExact : algebraicClosure C N = + (⊥ : IntermediateField C N)) + +/-- In an exact constant extension, the embedded copies of `S(X)` and `N` +are linearly disjoint over `C(X)` and generate the whole tensor field. -/ +theorem exactConstantExtension_rationalFunctionRanges_linearDisjoint : + let L := ExactConstantExtension C N S + letI : Field L := exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) L := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + letI : SMul (RatFunc C) L := Algebra.toSMul + letI : Module (RatFunc C) L := Algebra.toModule + letI : DistribMulAction (RatFunc C) L := Module.toDistribMulAction + letI : MulAction (RatFunc C) L := DistribMulAction.toMulAction + letI : Algebra N L := exactConstantExtensionAlgebra C N S + letI : SMul N L := Algebra.toSMul + letI : Module N L := Algebra.toModule + letI : IsScalarTower (RatFunc C) N L := + exactConstantExtensionBaseTower C (RatFunc C) N S + letI : Algebra (RatFunc C) (RatFunc S) := + ratFuncCoefficientAlgebra C S + letI : SMul (RatFunc C) (RatFunc S) := Algebra.toSMul + letI : Module (RatFunc C) (RatFunc S) := Algebra.toModule + letI : Algebra (RatFunc S) L := + ratFuncExactConstantExtensionAlgebra C S N hExact + letI : SMul (RatFunc S) L := Algebra.toSMul + letI : Module (RatFunc S) L := Algebra.toModule + letI : IsScalarTower (RatFunc C) (RatFunc S) L := + rationalBase_scalarTower C S N hExact + let f₁ : RatFunc S →ₐ[RatFunc C] L := + IsScalarTower.toAlgHom (RatFunc C) (RatFunc S) L + let f₂ : N →ₐ[RatFunc C] L := + IsScalarTower.toAlgHom (RatFunc C) N L + let F₁ : IntermediateField (RatFunc C) L := f₁.fieldRange + let F₂ : IntermediateField (RatFunc C) L := f₂.fieldRange + F₁.LinearDisjoint F₂ ∧ F₁ ⊔ F₂ = ⊤ := by + let L := ExactConstantExtension C N S + let : Field L := exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) L := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : SMul (RatFunc C) L := Algebra.toSMul + let : Module (RatFunc C) L := Algebra.toModule + let : DistribMulAction (RatFunc C) L := Module.toDistribMulAction + let : MulAction (RatFunc C) L := DistribMulAction.toMulAction + let : Algebra N L := exactConstantExtensionAlgebra C N S + let : SMul N L := Algebra.toSMul + let : Module N L := Algebra.toModule + let : IsScalarTower (RatFunc C) N L := + exactConstantExtensionBaseTower C (RatFunc C) N S + let : Algebra (RatFunc C) (RatFunc S) := + ratFuncCoefficientAlgebra C S + let : SMul (RatFunc C) (RatFunc S) := Algebra.toSMul + let : Module (RatFunc C) (RatFunc S) := Algebra.toModule + let : Algebra (RatFunc S) L := + ratFuncExactConstantExtensionAlgebra C S N hExact + let : SMul (RatFunc S) L := Algebra.toSMul + let : Module (RatFunc S) L := Algebra.toModule + let : IsScalarTower (RatFunc C) (RatFunc S) L := + rationalBase_scalarTower C S N hExact + let e := exactConstantExtensionLinearEquiv C N S + let : Module.Finite N (N ⊗[C] S) := + Module.Finite.base_change C N S + let : Module.Finite N L := Module.Finite.equiv e + let : FiniteDimensional (RatFunc C) L := + Module.Finite.trans N L + let f₁ : RatFunc S →ₐ[RatFunc C] L := + IsScalarTower.toAlgHom (RatFunc C) (RatFunc S) L + let f₂ : N →ₐ[RatFunc C] L := + IsScalarTower.toAlgHom (RatFunc C) N L + let F₁ : IntermediateField (RatFunc C) L := f₁.fieldRange + let F₂ : IntermediateField (RatFunc C) L := f₂.fieldRange + have hsup : F₁ ⊔ F₂ = ⊤ := by + apply top_unique + intro z _ + induction z using TensorProduct.inductionOn with + | tmul s n => + rw [show s ⊗ₜ[C] n = (s ⊗ₜ[C] 1) * (1 ⊗ₜ[C] n) by simp] + apply (F₁ ⊔ F₂).mul_mem + · apply (show F₁ ≤ F₁ ⊔ F₂ from le_sup_left) + exact ⟨algebraMap S (RatFunc S) s, by + change f₁ (algebraMap S (RatFunc S) s) = s ⊗ₜ[C] 1 + exact (ratFuncToExactConstantExtension C S N hExact).commutes s⟩ + · apply (show F₂ ≤ F₁ ⊔ F₂ from le_sup_right) + exact ⟨n, rfl⟩ + | add x y hx hy => + exact (F₁ ⊔ F₂).add_mem (hx (by simp)) (hy (by simp)) + let e₁ : RatFunc S ≃ₐ[RatFunc C] F₁ := f₁.equivFieldRange + let e₂ : N ≃ₐ[RatFunc C] F₂ := f₂.equivFieldRange + let : FiniteDimensional (RatFunc C) F₁ := by + let : Module.Finite (RatFunc C) (RatFunc S) := + ratFuncCoefficient_moduleFinite C S + exact Module.Finite.equiv e₁.toLinearEquiv + let : FiniteDimensional (RatFunc C) F₂ := + Module.Finite.equiv e₂.toLinearEquiv + have hfinL : + Module.finrank (RatFunc C) L = + Module.finrank (RatFunc C) F₁ * + Module.finrank (RatFunc C) F₂ := by + calc + Module.finrank (RatFunc C) L = + Module.finrank (RatFunc C) N * Module.finrank N L := by + rw [Module.finrank_mul_finrank] + _ = Module.finrank (RatFunc C) N * Module.finrank C S := by + rw [exactConstantExtension_finrank C N S] + _ = Module.finrank C S * Module.finrank (RatFunc C) N := by + rw [mul_comm] + _ = Module.finrank (RatFunc C) (RatFunc S) * + Module.finrank (RatFunc C) N := by + rw [ratFuncCoefficient_finrank C S] + _ = Module.finrank (RatFunc C) F₁ * + Module.finrank (RatFunc C) F₂ := by + rw [e₁.toLinearEquiv.finrank_eq, e₂.toLinearEquiv.finrank_eq] + have hdisjoint : F₁.LinearDisjoint F₂ := by + apply IntermediateField.LinearDisjoint.of_finrank_sup + rw [hsup, IntermediateField.finrank_top'] + exact hfinL + exact ⟨hdisjoint, hsup⟩ + +omit [FiniteDimensional (RatFunc C) N] [Algebra.IsSeparable (RatFunc C) N] in +private theorem normalization_finite_and_torsionFree + [Fintype C] [Finite S] : + let L := ExactConstantExtension C N S + let R₂ := integralClosure C[X] N + let B := integralClosure S[X] L + let : Field L := exactConstantExtensionField C N S hExact + let : Algebra S[X] L := constantExtensionTensorPolynomialAlgebra C S N + let : Algebra R₂ B := exactConstantExtensionFiniteNormalizationAlgebra C S N + let : SMul R₂ B := Algebra.toSMul + let : Module R₂ B := Algebra.toModule + Module.Finite R₂ B ∧ Module.IsTorsionFree R₂ B := by + intro L R₂ B field polynomial normalization scalar module + let : IsDomain R₂ := inferInstance + let : IsDomain B := inferInstance + let : Algebra R₂ (S ⊗[C] R₂) := + Algebra.TensorProduct.rightAlgebra + let : SMul R₂ (S ⊗[C] R₂) := Algebra.toSMul + let : Module R₂ (S ⊗[C] R₂) := Algebra.toModule + let : Algebra R₂ (R₂ ⊗[C] S) := + Algebra.TensorProduct.leftAlgebra + let : SMul R₂ (R₂ ⊗[C] S) := Algebra.toSMul + let : Module R₂ (R₂ ⊗[C] S) := Algebra.toModule + let eSwap : R₂ ⊗[C] S ≃ₐ[R₂] S ⊗[C] R₂ := + { (Algebra.TensorProduct.comm C R₂ S).toRingEquiv with + commutes' := fun r => by + change (Algebra.TensorProduct.comm C R₂ S) + (r ⊗ₜ[C] (1 : S)) = (1 : S) ⊗ₜ[C] r + rfl } + let : Module.Finite R₂ (R₂ ⊗[C] S) := + Module.Finite.base_change C R₂ S + let : Module.Finite R₂ (S ⊗[C] R₂) := + Module.Finite.equiv eSwap.toLinearEquiv + let eNorm : S ⊗[C] R₂ ≃+* B := + finiteFieldConstantExtensionIntegralClosureRingEquiv C S N + let : Algebra R₂ B := + exactConstantExtensionFiniteNormalizationAlgebra C S N + let : SMul R₂ B := Algebra.toSMul + let : Module R₂ B := Algebra.toModule + let eNormR₂ : S ⊗[C] R₂ ≃ₐ[R₂] B := + { eNorm with + commutes' := fun r => by + change eNorm (1 ⊗ₜ[C] r) = + finiteFieldConstantExtensionIntegralClosureRingEquiv C S N + (1 ⊗ₜ[C] r) + rfl } + let : Module.Finite R₂ B := + Module.Finite.equiv eNormR₂.toLinearEquiv + let : Module.IsTorsionFree R₂ B := by + rw [Module.isTorsionFree_iff_algebraMap_injective] + change Function.Injective + (eNorm.toRingHom.comp + (Algebra.TensorProduct.includeRight + (R := C) (A := S) (B := R₂)).toRingHom) + exact eNorm.injective.comp + (Algebra.TensorProduct.includeRight_injective + (R := C) (A := S) (B := R₂) (algebraMap C S).injective) + exact ⟨inferInstance, inferInstance⟩ + +/-- In an exact finite constant extension, the different of the extended +finite normalization is the extension of the original finite different. +The map on ideals is the right-factor map supplied by +`exactConstantExtensionFiniteNormalizationAlgebra`. -/ +theorem exactConstantExtension_finiteDifferent_eq_map + [Fintype C] [Finite S] : + let L := ExactConstantExtension C N S + let R₂ := integralClosure C[X] N + let B := integralClosure S[X] L + let : Field L := exactConstantExtensionField C N S hExact + let : Algebra S[X] L := + constantExtensionTensorPolynomialAlgebra C S N + let : SMul S[X] L := Algebra.toSMul + let : Module S[X] L := Algebra.toModule + let : Algebra (RatFunc S) L := + ratFuncExactConstantExtensionAlgebra C S N hExact + let : SMul (RatFunc S) L := Algebra.toSMul + let : Module (RatFunc S) L := Algebra.toModule + let : Algebra S[X] (RatFunc S) := + finiteDifferentCanonicalRatFuncPolynomialAlgebra S + let : IsFractionRing S[X] (RatFunc S) := + finiteDifferentCanonicalRatFuncPolynomialFractionRing S + let : IsScalarTower S[X] (RatFunc S) L := + IsScalarTower.of_algebraMap_eq' (by + apply DFunLike.ext _ _ + intro p + change algebraMap S[X] L p = + ratFuncToExactConstantExtension C S N hExact + (algebraMap S[X] (RatFunc S) p) + exact + (ratFuncToExactConstantExtension_algebraMap C S N hExact p).symm) + let : Module.IsTorsionFree S[X] L := by + rw [Module.isTorsionFree_iff_algebraMap_injective] + intro p q hpq + apply RatFunc.algebraMap_injective S + apply (algebraMap (RatFunc S) L).injective + simpa only [IsScalarTower.algebraMap_apply S[X] (RatFunc S) L] + using hpq + let : FiniteDimensional (RatFunc S) L := + finiteDimensional_over_extendedRatFunc C S N hExact + let : Algebra.IsSeparable (RatFunc S) L := + isSeparable_over_extendedRatFunc C S N hExact + let : IsDedekindDomain B := + IsIntegralClosure.isDedekindDomain S[X] (RatFunc S) L B + let : Module.IsTorsionFree S[X] B := + IsIntegralClosure.isTorsionFree S[X] L + let : Algebra C[X] (RatFunc C) := + finiteDifferentCanonicalRatFuncPolynomialAlgebra C + let : IsFractionRing C[X] (RatFunc C) := + finiteDifferentCanonicalRatFuncPolynomialFractionRing C + let : IsScalarTower C[X] (RatFunc C) N := + IsScalarTower.of_algebraMap_eq' rfl + let : IsDedekindDomain R₂ := + IsIntegralClosure.isDedekindDomain C[X] (RatFunc C) N R₂ + let : Module.IsTorsionFree C[X] N := by + rw [Module.isTorsionFree_iff_algebraMap_injective] + change Function.Injective + ((algebraMap (RatFunc C) N).comp + (algebraMap C[X] (RatFunc C))) + exact (algebraMap (RatFunc C) N).injective.comp + (RatFunc.algebraMap_injective C) + let : Module.IsTorsionFree C[X] R₂ := + IsIntegralClosure.isTorsionFree C[X] N + let : Algebra R₂ B := + exactConstantExtensionFiniteNormalizationAlgebra C S N + differentIdeal S[X] B = + Ideal.map (algebraMap R₂ B) (differentIdeal C[X] R₂) := by + intro L R₂ B model0 model1 model2 model3 model4 model5 model6 model7 model8 model9 + model10 model11 model12 model13 model14 model15 model16 model17 model18 model19 model20 model21 + let : IsDomain R₂ := inferInstance + let : IsDomain B := inferInstance + let : Algebra (RatFunc C) L := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : SMul (RatFunc C) L := Algebra.toSMul + let : Module (RatFunc C) L := Algebra.toModule + let : DistribMulAction (RatFunc C) L := Module.toDistribMulAction + let : MulAction (RatFunc C) L := DistribMulAction.toMulAction + let : Algebra N L := exactConstantExtensionAlgebra C N S + let : SMul N L := Algebra.toSMul + let : Module N L := Algebra.toModule + let : IsScalarTower (RatFunc C) N L := + exactConstantExtensionBaseTower C (RatFunc C) N S + let : Algebra (RatFunc C) (RatFunc S) := + ratFuncCoefficientAlgebra C S + let : SMul (RatFunc C) (RatFunc S) := Algebra.toSMul + let : Module (RatFunc C) (RatFunc S) := Algebra.toModule + let : IsScalarTower (RatFunc C) (RatFunc S) L := + rationalBase_scalarTower C S N hExact + let : Algebra C[X] L := + RingHom.toAlgebra + ((algebraMap (RatFunc C) L).comp + (algebraMap C[X] (RatFunc C))) + let : SMul C[X] L := Algebra.toSMul + let : Module C[X] L := Algebra.toModule + let : IsScalarTower C[X] (RatFunc C) L := + IsScalarTower.of_algebraMap_eq' rfl + let : Algebra C[X] B := + RingHom.toAlgebra + ((algebraMap S[X] B).comp (algebraMap C[X] S[X])) + let : SMul C[X] B := Algebra.toSMul + let : Module C[X] B := Algebra.toModule + let : IsScalarTower C[X] S[X] B := + IsScalarTower.of_algebraMap_eq' rfl + let : IsScalarTower S[X] B L := + IsScalarTower.of_algebraMap_eq' rfl + let : IsScalarTower C[X] S[X] L := + IsScalarTower.of_algebraMap_eq' (by + apply DFunLike.ext _ _ + intro p + change algebraMap (RatFunc C) L + (algebraMap C[X] (RatFunc C) p) = + algebraMap S[X] L (algebraMap C[X] S[X] p) + rw [IsScalarTower.algebraMap_apply S[X] (RatFunc S) L] + rw [rationalBase_algebraMap_eq C S N hExact] + apply congrArg (algebraMap (RatFunc S) L) + exact ratFuncCoefficientAlgHom_algebraMap C S p) + let : IsScalarTower C[X] B L := + IsScalarTower.of_algebraMap_eq' (by + apply DFunLike.ext _ _ + intro p + change algebraMap C[X] L p = + algebraMap S[X] L (algebraMap C[X] S[X] p) + exact IsScalarTower.algebraMap_apply C[X] S[X] L p) + let : SMul C[X] S[X] := Algebra.toSMul + let : Module C[X] S[X] := Algebra.toModule + let : Module.Finite C[X] (C[X] ⊗[C] S) := + Module.Finite.base_change C C[X] S + let : Module.Finite C[X] S[X] := + Module.Finite.equiv + (Algebra.IsPushout.equiv C C[X] S S[X]).toLinearEquiv + let : Module.IsTorsionFree C[X] S[X] := by + rw [Module.isTorsionFree_iff_algebraMap_injective] + change Function.Injective (Polynomial.map (algebraMap C S)) + exact Polynomial.map_injective (algebraMap C S) (algebraMap C S).injective + let : Module.Free C[X] S[X] := + Module.free_of_finite_type_torsion_free' + let eNL := exactConstantExtensionLinearEquiv C N S + let : Module.Finite N (N ⊗[C] S) := + Module.Finite.base_change C N S + let : Module.Finite N L := Module.Finite.equiv eNL + let : FiniteDimensional (RatFunc C) L := + Module.Finite.trans N L + let : Algebra.IsSeparable (RatFunc C) L := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + let : Algebra R₂ L := + RingHom.toAlgebra ((algebraMap N L).comp (algebraMap R₂ N)) + let : SMul R₂ L := Algebra.toSMul + let : Module R₂ L := Algebra.toModule + let : IsScalarTower R₂ N L := IsScalarTower.of_algebraMap_eq' rfl + let : IsFractionRing R₂ N := + IsIntegralClosure.isFractionRing_of_finite_extension C[X] (RatFunc C) N R₂ + let : IsScalarTower C[X] R₂ N := IsScalarTower.of_algebraMap_eq' rfl + let : IsScalarTower C[X] N L := IsScalarTower.of_algebraMap_eq (fun p => by + change algebraMap (RatFunc C) L (algebraMap C[X] (RatFunc C) p) = + algebraMap N L (algebraMap C[X] N p) + rw [IsScalarTower.algebraMap_apply C[X] (RatFunc C) N] + exact IsScalarTower.algebraMap_apply (RatFunc C) N L _) + let : IsScalarTower C[X] R₂ L := IsScalarTower.of_algebraMap_eq (fun p => by + change algebraMap C[X] L p = + algebraMap N L (algebraMap R₂ N (algebraMap C[X] R₂ p)) + rw [← IsScalarTower.algebraMap_apply C[X] R₂ N, + ← IsScalarTower.algebraMap_apply C[X] N L]) + let : Module.IsTorsionFree R₂ L := by + rw [Module.isTorsionFree_iff_algebraMap_injective] + exact (algebraMap N L).injective.comp (IsFractionRing.injective R₂ N) + let : SMul R₂ B := Algebra.toSMul + let : Module R₂ B := Algebra.toModule + have hR₂BL : + (algebraMap R₂ L) = + (algebraMap B L).comp (algebraMap R₂ B) := by + ext r + change (1 : S) ⊗ₜ[C] (r : N) = + (((finiteFieldConstantExtensionIntegralClosureRingEquiv + C S N) (1 ⊗ₜ[C] r) : B) : L) + exact + (finiteFieldConstantExtensionIntegralClosureRingEquiv_tmul + C S N 1 r).symm + let : IsScalarTower R₂ B L := + IsScalarTower.of_algebraMap_eq' hR₂BL + let : IsScalarTower C[X] R₂ B := + scalarTower_of_injective_algebraMap C[X] R₂ B L + (fun _ _ h => Subtype.ext h) + let : Module.Finite C[X] R₂ := + IsIntegralClosure.finite C[X] (RatFunc C) N R₂ + let : Module.Free C[X] R₂ := + Module.free_of_finite_type_torsion_free' + have hranges := + exactConstantExtension_rationalFunctionRanges_linearDisjoint C S N hExact + have hcoprime : + IsCoprime + ((differentIdeal C[X] S[X]).map (algebraMap S[X] B)) + ((differentIdeal C[X] R₂).map (algebraMap R₂ B)) := by + rw [finiteFieldPolynomial_differentIdeal_eq_top C S] + rw [Ideal.map_top] + apply Ideal.isCoprime_iff_sup_eq.mpr + exact top_sup_eq + (Ideal.map (algebraMap R₂ B) (differentIdeal C[X] R₂)) + exact different_eq_map_of_linearlyDisjoint_fieldRanges C[X] S[X] R₂ B + (RatFunc C) (RatFunc S) N L hranges.1 hranges.2 hcoprime + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionFinitePlace.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionFinitePlace.lean new file mode 100644 index 0000000000..b9d9d574a5 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionFinitePlace.lean @@ -0,0 +1,457 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionQuotient +public import LeanPool.MarkoffModP.BGS.HasseWeil.FrobeniusPlaceCardinality + +/-! +# Finite places of an exact constant extension + +This file embeds the enlarged constant field into the finite normalization +over the original polynomial ring. The canonical constant quotient is +compatible with the resulting Galois action. Consequently, at every finite +place whose residue field has degree one over the enlarged constants, the +kernel of constant restriction on the decomposition group is exactly inertia. +-/ + +@[expose] public section + +open scoped Pointwise Polynomial TensorProduct + +namespace BGS.HasseWeil + +open BGS.CorvajaZannier + +noncomputable section + + +variable (C N S : Type*) [Field C] [Field N] [Field S] + [Algebra C N] [Algebra (RatFunc C) N] + [IsScalarTower C (RatFunc C) N] + [Algebra C S] [FiniteDimensional C S] [IsGalois C S] + +section Exact + +variable (hExact : algebraicClosure C N = + (⊥ : IntermediateField C N)) + +omit [FiniteDimensional C S] [IsGalois C S] in +private theorem exactConstantExtension_polynomialTower : + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + letI : Algebra C[X] (ExactConstantExtension C N S) := + RingHom.toAlgebra + ((algebraMap (RatFunc C) (ExactConstantExtension C N S)).comp + (algebraMap C[X] (RatFunc C))) + IsScalarTower C C[X] (ExactConstantExtension C N S) := by + let : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : Algebra C[X] (ExactConstantExtension C N S) := + RingHom.toAlgebra + ((algebraMap (RatFunc C) (ExactConstantExtension C N S)).comp + (algebraMap C[X] (RatFunc C))) + apply IsScalarTower.of_algebraMap_eq' + ext c + change algebraMap C (S ⊗[C] N) c = (1 : S) ⊗ₜ[C] + algebraMap (RatFunc C) N + (algebraMap C[X] (RatFunc C) (Polynomial.C c)) + rw [RatFunc.algebraMap_C] + change algebraMap C S c ⊗ₜ[C] (1 : N) = + (1 : S) ⊗ₜ[C] + algebraMap (RatFunc C) N (algebraMap C (RatFunc C) c) + rw [← IsScalarTower.algebraMap_apply C (RatFunc C) N] + exact Algebra.TensorProduct.tmul_one_eq_one_tmul c + +/-- The enlarged constants map into the finite normalization. -/ +noncomputable def exactConstantExtensionConstantToFiniteIntegralClosureRingHom : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + S →+* RatFuncFiniteIntegralClosure C + (ExactConstantExtension C N S) := by + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + letI : Algebra C[X] (ExactConstantExtension C N S) := + RingHom.toAlgebra + ((algebraMap (RatFunc C) (ExactConstantExtension C N S)).comp + (algebraMap C[X] (RatFunc C))) + letI : IsScalarTower C C[X] (ExactConstantExtension C N S) := by + exact exactConstantExtension_polynomialTower C N S + let f : S →ₐ[C] ExactConstantExtension C N S := + Algebra.TensorProduct.includeLeft + exact + { toFun := fun s => + ⟨f s, by + have hs : IsIntegral C s := Algebra.IsIntegral.isIntegral s + exact (hs.map f).tower_top⟩ + map_one' := by ext; exact map_one f + map_mul' := fun x y => by ext; exact map_mul f x y + map_zero' := by ext; exact map_zero f + map_add' := fun x y => by ext; exact map_add f x y + } + +/-- The `S`-algebra structure on the finite normalization induced by the +embedded enlarged constants. -/ +@[reducible] noncomputable def exactConstantExtensionFiniteIntegralClosureConstantAlgebra : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + Algebra S (RatFuncFiniteIntegralClosure C + (ExactConstantExtension C N S)) := + RingHom.toAlgebra + (exactConstantExtensionConstantToFiniteIntegralClosureRingHom C N S hExact) + +theorem exactConstantExtensionFiniteIntegralClosure_algebraMap_val (s : S) : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + letI : Algebra S (RatFuncFiniteIntegralClosure C + (ExactConstantExtension C N S)) := + exactConstantExtensionFiniteIntegralClosureConstantAlgebra C N S hExact + ((algebraMap S (RatFuncFiniteIntegralClosure C + (ExactConstantExtension C N S)) s) : ExactConstantExtension C N S) = + (Algebra.TensorProduct.includeLeft + (R := C) (S := C) (A := S) (B := N)) s := by + rfl + +section FullGroup + +variable (L : Type*) [Field L] + [Algebra C L] [Algebra L N] [IsScalarTower C L N] + [Algebra (RatFunc C) L] [FiniteDimensional (RatFunc C) L] + [Algebra.IsSeparable (RatFunc C) L] + [IsScalarTower (RatFunc C) L N] + [FiniteDimensional L N] [IsGalois L N] + +omit [IsScalarTower C (RatFunc C) N] + [FiniteDimensional C S] [IsGalois C S] + [Algebra C L] [IsScalarTower C L N] + [FiniteDimensional (RatFunc C) L] + [Algebra.IsSeparable (RatFunc C) L] + [FiniteDimensional L N] [IsGalois L N] in +private theorem exactConstantExtension_ratFuncBaseTower : + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + letI : Algebra L (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C L N S + IsScalarTower (RatFunc C) L (ExactConstantExtension C N S) := by + let : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : Algebra L (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C L N S + apply IsScalarTower.of_algebraMap_eq' + ext x + change (1 : S) ⊗ₜ[C] algebraMap (RatFunc C) N x = + (1 : S) ⊗ₜ[C] algebraMap L N (algebraMap (RatFunc C) L x) + congr 1 + exact IsScalarTower.algebraMap_apply (RatFunc C) L N x + +omit [Algebra.IsSeparable (RatFunc C) L] in +theorem exactConstantExtensionConstantQuotient_action_on_finiteNormalization + : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + letI : Algebra L (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C L N S + letI : IsScalarTower (RatFunc C) L + (ExactConstantExtension C N S) := by + exact exactConstantExtension_ratFuncBaseTower C N S L + letI : IsGalois L (ExactConstantExtension C N S) := + exactConstantExtension_isGalois C L N S hExact + letI : Algebra S (RatFuncFiniteIntegralClosure C + (ExactConstantExtension C N S)) := + exactConstantExtensionFiniteIntegralClosureConstantAlgebra C N S hExact + letI : MulSemiringAction + (ExactConstantExtension C N S ≃ₐ[L] ExactConstantExtension C N S) + (RatFuncFiniteIntegralClosure C (ExactConstantExtension C N S)) := + finiteIntegralClosureGalAction C L (ExactConstantExtension C N S) + ∀ (g : ExactConstantExtension C N S ≃ₐ[L] + ExactConstantExtension C N S) (s : S), + g • algebraMap S (RatFuncFiniteIntegralClosure C + (ExactConstantExtension C N S)) s = + algebraMap S (RatFuncFiniteIntegralClosure C + (ExactConstantExtension C N S)) + (exactConstantExtensionConstantQuotient C L N S hExact g s) := by + let : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : Algebra L (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C L N S + let : IsScalarTower (RatFunc C) L (ExactConstantExtension C N S) := by + exact exactConstantExtension_ratFuncBaseTower C N S L + let : Algebra C[X] L := + RingHom.toAlgebra + ((algebraMap (RatFunc C) L).comp (algebraMap C[X] (RatFunc C))) + let : IsScalarTower C[X] (RatFunc C) L := + IsScalarTower.of_algebraMap_eq' rfl + let : Algebra C[X] (ExactConstantExtension C N S) := + RingHom.toAlgebra + ((algebraMap (RatFunc C) (ExactConstantExtension C N S)).comp + (algebraMap C[X] (RatFunc C))) + let : IsScalarTower C[X] (RatFunc C) + (ExactConstantExtension C N S) := + IsScalarTower.of_algebraMap_eq' rfl + let : IsGalois L (ExactConstantExtension C N S) := + exactConstantExtension_isGalois C L N S hExact + let : Algebra S (RatFuncFiniteIntegralClosure C + (ExactConstantExtension C N S)) := + exactConstantExtensionFiniteIntegralClosureConstantAlgebra C N S hExact + let : MulSemiringAction + (ExactConstantExtension C N S ≃ₐ[L] ExactConstantExtension C N S) + (RatFuncFiniteIntegralClosure C (ExactConstantExtension C N S)) := + finiteIntegralClosureGalAction C L (ExactConstantExtension C N S) + let : Algebra (RatFuncFiniteIntegralClosure C L) + (RatFuncFiniteIntegralClosure C (ExactConstantExtension C N S)) := + (finiteIntegralClosureMap C L (ExactConstantExtension C N S)).toAlgebra + let : IsScalarTower (RatFuncFiniteIntegralClosure C L) L + (ExactConstantExtension C N S) := inferInstance + let : Algebra.IsIntegral C[X] (RatFuncFiniteIntegralClosure C L) := + IsIntegralClosure.isIntegral_algebra C[X] L + let : IsScalarTower C[X] (RatFuncFiniteIntegralClosure C L) + (ExactConstantExtension C N S) := by + apply IsScalarTower.of_algebraMap_eq + intro x + change algebraMap (RatFunc C) (ExactConstantExtension C N S) + (algebraMap C[X] (RatFunc C) x) = + algebraMap L (ExactConstantExtension C N S) + (algebraMap (RatFunc C) L (algebraMap C[X] (RatFunc C) x)) + exact IsScalarTower.algebraMap_apply (RatFunc C) L + (ExactConstantExtension C N S) _ + let : IsScalarTower (RatFuncFiniteIntegralClosure C L) + (RatFuncFiniteIntegralClosure C (ExactConstantExtension C N S)) + (ExactConstantExtension C N S) := + ⟨fun r t x => by + simp only [Algebra.smul_def, map_mul] + rw [show algebraMap + (RatFuncFiniteIntegralClosure C (ExactConstantExtension C N S)) + (ExactConstantExtension C N S) + (algebraMap (RatFuncFiniteIntegralClosure C L) + (RatFuncFiniteIntegralClosure C + (ExactConstantExtension C N S)) r) = + algebraMap (RatFuncFiniteIntegralClosure C L) + (ExactConstantExtension C N S) r by rfl] + ring⟩ + let : IsIntegralClosure + (RatFuncFiniteIntegralClosure C (ExactConstantExtension C N S)) + (RatFuncFiniteIntegralClosure C L) + (ExactConstantExtension C N S) := + IsIntegralClosure.tower_top (R := C[X]) + intro g s + apply Subtype.ext + calc + ((g • algebraMap S (RatFuncFiniteIntegralClosure C + (ExactConstantExtension C N S)) s : + RatFuncFiniteIntegralClosure C (ExactConstantExtension C N S)) : + ExactConstantExtension C N S) = + g ((algebraMap S (RatFuncFiniteIntegralClosure C + (ExactConstantExtension C N S)) s : + RatFuncFiniteIntegralClosure C (ExactConstantExtension C N S)) : + ExactConstantExtension C N S) := by + exact algebraMap_galRestrict'_apply + (RatFuncFiniteIntegralClosure C L) + (RatFuncFiniteIntegralClosure C (ExactConstantExtension C N S)) + (RatFuncFiniteIntegralClosure C (ExactConstantExtension C N S)) + g.toAlgHom _ + _ = (Algebra.TensorProduct.includeLeft + (R := C) (S := C) (A := S) (B := N)) + (exactConstantExtensionConstantQuotient C L N S hExact g s) := by + rw [exactConstantExtensionFiniteIntegralClosure_algebraMap_val] + exact exactConstantExtensionConstantQuotient_action_on_constants + C L N S hExact g s + _ = ((algebraMap S (RatFuncFiniteIntegralClosure C + (ExactConstantExtension C N S)) + (exactConstantExtensionConstantQuotient C L N S hExact g s) : + RatFuncFiniteIntegralClosure C (ExactConstantExtension C N S)) : + ExactConstantExtension C N S) := by + rw [exactConstantExtensionFiniteIntegralClosure_algebraMap_val] + +/-- On a residue-degree-one finite place, the kernel of constant restriction +on the decomposition group is inertia. -/ +theorem exactConstantExtensionFinitePlace_stabilizerRestriction_ker_eq_inertia + : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + letI : Algebra L (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C L N S + letI : IsScalarTower (RatFunc C) L + (ExactConstantExtension C N S) := by + exact exactConstantExtension_ratFuncBaseTower C N S L + letI : IsGalois L (ExactConstantExtension C N S) := + exactConstantExtension_isGalois C L N S hExact + letI : Algebra S (RatFuncFiniteIntegralClosure C + (ExactConstantExtension C N S)) := + exactConstantExtensionFiniteIntegralClosureConstantAlgebra C N S hExact + letI : MulSemiringAction + (ExactConstantExtension C N S ≃ₐ[L] ExactConstantExtension C N S) + (RatFuncFiniteIntegralClosure C (ExactConstantExtension C N S)) := + finiteIntegralClosureGalAction C L (ExactConstantExtension C N S) + ∀ (Q : FiniteExtensionFinitePlace C (ExactConstantExtension C N S)), + Module.finrank S Q.asIdeal.ResidueField = 1 → + ((exactConstantExtensionConstantQuotient C L N S hExact).comp + (MulAction.stabilizer + (ExactConstantExtension C N S ≃ₐ[L] + ExactConstantExtension C N S) Q.asIdeal).subtype).ker = + Q.asIdeal.inertia + (MulAction.stabilizer + (ExactConstantExtension C N S ≃ₐ[L] + ExactConstantExtension C N S) Q.asIdeal) := by + let : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : Algebra L (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C L N S + let : IsScalarTower (RatFunc C) L (ExactConstantExtension C N S) := by + exact exactConstantExtension_ratFuncBaseTower C N S L + let : IsGalois L (ExactConstantExtension C N S) := + exactConstantExtension_isGalois C L N S hExact + let : Algebra S (RatFuncFiniteIntegralClosure C + (ExactConstantExtension C N S)) := + exactConstantExtensionFiniteIntegralClosureConstantAlgebra C N S hExact + let : MulSemiringAction + (ExactConstantExtension C N S ≃ₐ[L] ExactConstantExtension C N S) + (RatFuncFiniteIntegralClosure C (ExactConstantExtension C N S)) := + finiteIntegralClosureGalAction C L (ExactConstantExtension C N S) + let : Algebra N (ExactConstantExtension C N S) := + exactConstantExtensionAlgebra C N S + let : IsScalarTower (RatFunc C) N (ExactConstantExtension C N S) := + exactConstantExtensionBaseTower C (RatFunc C) N S + let : Module.Finite (RatFunc C) N := Module.Finite.trans L N + let e := exactConstantExtensionLinearEquiv C N S + let : Module.Finite N (N ⊗[C] S) := + Module.Finite.base_change C N S + let : Module.Finite N (ExactConstantExtension C N S) := + Module.Finite.equiv e + let : Module.Finite (RatFunc C) (ExactConstantExtension C N S) := + Module.Finite.trans N (ExactConstantExtension C N S) + let : Algebra C[X] (ExactConstantExtension C N S) := + RingHom.toAlgebra + ((algebraMap (RatFunc C) (ExactConstantExtension C N S)).comp + (algebraMap C[X] (RatFunc C))) + let : IsScalarTower C[X] (RatFunc C) + (ExactConstantExtension C N S) := + IsScalarTower.of_algebraMap_eq' rfl + intro Q hdegree + let : Algebra.IsSeparable L (ExactConstantExtension C N S) := + IsGalois.to_isSeparable + let : Algebra.IsSeparable (RatFunc C) + (ExactConstantExtension C N S) := + Algebra.IsSeparable.trans (RatFunc C) L + (ExactConstantExtension C N S) + let : IsDedekindDomain (RatFuncFiniteIntegralClosure C + (ExactConstantExtension C N S)) := inferInstance + let : Q.asIdeal.IsMaximal := Q.isMaximal + exact stabilizerRestriction_ker_eq_inertia_of_residue_finrank_one + Q.asIdeal (exactConstantExtensionConstantQuotient C L N S hExact) + (exactConstantExtensionConstantQuotient_action_on_finiteNormalization + C N S hExact L) hdegree + +section FiniteConstants + +variable [Fintype C] [DecidableEq C] [DecidableEq (RatFunc C)] + +/-- The decomposition-group cardinality required by Frobenius-coset +averaging, specialized to the exact constant extension. -/ +theorem exactConstantExtensionFinitePlace_decompositionGroup_card + : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + letI : Algebra L (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C L N S + letI : IsScalarTower (RatFunc C) L + (ExactConstantExtension C N S) := by + exact exactConstantExtension_ratFuncBaseTower C N S L + letI : IsGalois L (ExactConstantExtension C N S) := + exactConstantExtension_isGalois C L N S hExact + letI : Algebra S (RatFuncFiniteIntegralClosure C + (ExactConstantExtension C N S)) := + exactConstantExtensionFiniteIntegralClosureConstantAlgebra C N S hExact + letI : MulSemiringAction + (ExactConstantExtension C N S ≃ₐ[L] ExactConstantExtension C N S) + (RatFuncFiniteIntegralClosure C (ExactConstantExtension C N S)) := + finiteIntegralClosureGalAction C L (ExactConstantExtension C N S) + ∀ (Q : FiniteExtensionFinitePlace C (ExactConstantExtension C N S)), + Module.finrank S Q.asIdeal.ResidueField = 1 → + finiteExtensionPlaceDegree C (ExactConstantExtension C N S) (.inl Q) = + Module.finrank C S → + finiteExtensionPlaceDegree C L + (.inl (finitePlaceUnder C L (ExactConstantExtension C N S) Q)) = 1 → + Nat.card (finitePlaceDecompositionGroup C L + (ExactConstantExtension C N S) Q) = + Nat.card + ((exactConstantExtensionConstantQuotient C L N S hExact).comp + (finitePlaceDecompositionGroup C L + (ExactConstantExtension C N S) Q).subtype).ker * + Nat.card (S ≃ₐ[C] S) := by + let : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : Algebra L (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C L N S + let : IsScalarTower (RatFunc C) L (ExactConstantExtension C N S) := by + exact exactConstantExtension_ratFuncBaseTower C N S L + let : IsGalois L (ExactConstantExtension C N S) := + exactConstantExtension_isGalois C L N S hExact + let : Algebra S (RatFuncFiniteIntegralClosure C + (ExactConstantExtension C N S)) := + exactConstantExtensionFiniteIntegralClosureConstantAlgebra C N S hExact + let : MulSemiringAction + (ExactConstantExtension C N S ≃ₐ[L] ExactConstantExtension C N S) + (RatFuncFiniteIntegralClosure C (ExactConstantExtension C N S)) := + finiteIntegralClosureGalAction C L (ExactConstantExtension C N S) + let : Algebra N (ExactConstantExtension C N S) := + exactConstantExtensionAlgebra C N S + let : IsScalarTower (RatFunc C) N (ExactConstantExtension C N S) := + exactConstantExtensionBaseTower C (RatFunc C) N S + let : Module.Finite (RatFunc C) N := Module.Finite.trans L N + let e := exactConstantExtensionLinearEquiv C N S + let : Module.Finite N (N ⊗[C] S) := + Module.Finite.base_change C N S + let : Module.Finite N (ExactConstantExtension C N S) := + Module.Finite.equiv e + let : Module.Finite (RatFunc C) (ExactConstantExtension C N S) := + Module.Finite.trans N (ExactConstantExtension C N S) + let : Algebra.IsSeparable L (ExactConstantExtension C N S) := + IsGalois.to_isSeparable + let : Algebra.IsSeparable (RatFunc C) + (ExactConstantExtension C N S) := + Algebra.IsSeparable.trans (RatFunc C) L + (ExactConstantExtension C N S) + intro Q hResidue hTop hBase + have hker := + exactConstantExtensionFinitePlace_stabilizerRestriction_ker_eq_inertia + C N S hExact L Q hResidue + exact + finitePlaceDecompositionGroup_card_eq_restrictedKernel_mul_card_constantAut + C L (ExactConstantExtension C N S) S + (exactConstantExtensionConstantQuotient C L N S hExact) + Q hTop hBase hker + +end FiniteConstants + +end FullGroup + +end Exact + +end + + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionFinitePlaceCompatibility.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionFinitePlaceCompatibility.lean new file mode 100644 index 0000000000..c7666217e0 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionFinitePlaceCompatibility.lean @@ -0,0 +1,973 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.ConstantExtensionFinitePlaceBridge +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionFinitePlace +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionZeroCounting + +/-! +# Compatibility of the two finite-place models in a constant extension + +The explicit constant-extension normalization is naturally a normalization +over `S[X]`, whereas the relative Galois action is implemented on the +normalization over `C[X]`. This file identifies the corresponding finite +places and their residue fields. In particular, an `S`-rational place has +absolute `C`-degree `[S : C]`, in precisely the model used by the +decomposition-group theorem. +-/ + +@[expose] public section + +open scoped Polynomial TensorProduct + +namespace BGS.HasseWeil + +noncomputable section + +open BGS.CorvajaZannier + + +/-- The equality-transport normalization equivalence does not change the +underlying element of the ambient function field. -/ +private theorem integralClosureAlgEquivRatFuncFiniteOfEq_coe + {k T : Type*} [Field k] [Field T] [Algebra (RatFunc k) T] + (a : Algebra k[X] T) + (h : ratFuncInducedPolynomialAlgebra k T = a) + (x : letI := a; integralClosure k[X] T) : + letI := a + (((integralClosureAlgEquivRatFuncFiniteOfEq k T a h) x : + RatFuncFiniteIntegralClosure k T) : T) = x := by + subst a + rfl + +variable (C S N : Type*) [Field C] [Field S] [Field N] + [Fintype C] [Finite S] + [DecidableEq C] [DecidableEq S] + [DecidableEq (RatFunc C)] [DecidableEq (RatFunc S)] + [Algebra (RatFunc C) N] [FiniteDimensional (RatFunc C) N] + [Algebra.IsSeparable (RatFunc C) N] + [Algebra C S] [FiniteDimensional C S] [IsGalois C S] + +local instance compatibilityBaseConstantAlgebra : Algebra C N := + bridgeBaseConstantAlgebra C N + +local instance compatibilityBasePolynomialAlgebra : Algebra C[X] N := + bridgeBasePolynomialAlgebra C N + +local instance compatibilityBaseConstantTower : + IsScalarTower C (RatFunc C) N := + IsScalarTower.of_algebraMap_eq' rfl + +local instance compatibilityBaseConstantPolynomialTower : + IsScalarTower C C[X] N := + bridgeBaseConstantPolynomialTower C N + +local instance compatibilityPolynomialCoefficientAlgebra : + Algebra C[X] S[X] := + (Polynomial.mapRingHom (algebraMap C S)).toAlgebra + +local instance compatibilityRatFuncCoefficientAlgebra : + Algebra (RatFunc C) (RatFunc S) := + ratFuncCoefficientAlgebra C S + +local instance compatibilityTargetPolynomialAlgebra : + Algebra S[X] (ExactConstantExtension C N S) := + bridgeTargetPolynomialAlgebra C S N + +local instance compatibilityTensorNormalizationPolynomialAlgebra : + Algebra S[X] (S ⊗[C] integralClosure C[X] N) := + bridgeTensorNormalizationPolynomialAlgebra C S N + +local instance compatibilityOldNormalizationConstantAlgebra : + Algebra C (integralClosure C[X] N) := + RingHom.toAlgebra + ((algebraMap C[X] (integralClosure C[X] N)).comp + (algebraMap C C[X])) + +omit [DecidableEq C] [DecidableEq S] [DecidableEq (RatFunc C)] [DecidableEq (RatFunc S)] + [FiniteDimensional (RatFunc C) N] [Algebra.IsSeparable (RatFunc C) N] + [FiniteDimensional C S] [IsGalois C S] in +/-- The two normalization equivalences used by the residue and polynomial +models have the same underlying map. -/ +private theorem finiteFieldConstantExtensionIntegralClosureAlgEquiv_apply_eq_polynomial + (z : S ⊗[C] integralClosure C[X] N) : + finiteFieldConstantExtensionIntegralClosureAlgEquiv C S N z = + finiteFieldConstantExtensionIntegralClosurePolynomialAlgEquiv C S N z := by + induction z using TensorProduct.inductionOn with + | tmul s a => + apply Subtype.ext + rw [finiteFieldConstantExtensionIntegralClosureAlgEquiv_tmul, + finiteFieldConstantExtensionIntegralClosurePolynomialAlgEquiv_tmul] + | add x y hx hy => + calc + finiteFieldConstantExtensionIntegralClosureAlgEquiv C S N (x + y) = + finiteFieldConstantExtensionIntegralClosureAlgEquiv C S N x + + finiteFieldConstantExtensionIntegralClosureAlgEquiv C S N y := + (finiteFieldConstantExtensionIntegralClosureAlgEquiv C S N).map_add x y + _ = finiteFieldConstantExtensionIntegralClosurePolynomialAlgEquiv C S N x + + finiteFieldConstantExtensionIntegralClosurePolynomialAlgEquiv C S N y := by + rw [hx, hy] + _ = finiteFieldConstantExtensionIntegralClosurePolynomialAlgEquiv C S N (x + y) := + ((finiteFieldConstantExtensionIntegralClosurePolynomialAlgEquiv C S N).map_add x y).symm + +variable (hExact : algebraicClosure C N = + (⊥ : IntermediateField C N)) + +include hExact + +omit [Fintype C] [Finite S] [DecidableEq C] [DecidableEq S] [DecidableEq (RatFunc C)] + [DecidableEq (RatFunc S)] [Algebra.IsSeparable (RatFunc C) N] in +/-- The exact constant extension is finite over the original rational +function field. This is the finite-dimensional input needed to compare its +`C[X]`- and `S[X]`-normalizations. -/ +theorem finiteDimensional_exactConstantExtension_over_baseRatFunc : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + letI : SMul (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toSMul + letI : Module (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toModule + FiniteDimensional (RatFunc C) (ExactConstantExtension C N S) := by + let : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : SMul (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toSMul + let : Module (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toModule + let : Algebra N (ExactConstantExtension C N S) := + exactConstantExtensionAlgebra C N S + let : SMul N (ExactConstantExtension C N S) := + Algebra.toSMul + let : Module N (ExactConstantExtension C N S) := + Algebra.toModule + let : IsScalarTower (RatFunc C) N + (ExactConstantExtension C N S) := + exactConstantExtensionBaseTower C (RatFunc C) N S + let e := exactConstantExtensionLinearEquiv C N S + let : Module.Finite N (N ⊗[C] S) := Module.Finite.base_change C N S + let : Module.Finite N (ExactConstantExtension C N S) := + Module.Finite.equiv e + exact Module.Finite.trans N (ExactConstantExtension C N S) + +omit [Fintype C] [Finite S] [DecidableEq C] [DecidableEq S] [DecidableEq (RatFunc C)] + [DecidableEq (RatFunc S)] [FiniteDimensional (RatFunc C) N] + [Algebra.IsSeparable (RatFunc C) N] in +/-- Polynomial coefficient extension is compatible with the two canonical +rational-function embeddings into the exact constant extension. -/ +theorem exactConstantExtension_ratFunc_polynomialCompatibility + (p : C[X]) : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + letI : Algebra (RatFunc S) (ExactConstantExtension C N S) := + ratFuncExactConstantExtensionAlgebra C S N hExact + algebraMap (RatFunc C) (ExactConstantExtension C N S) + (algebraMap C[X] (RatFunc C) p) = + algebraMap (RatFunc S) (ExactConstantExtension C N S) + (algebraMap S[X] (RatFunc S) (algebraMap C[X] S[X] p)) := by + let : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : Algebra (RatFunc S) (ExactConstantExtension C N S) := + ratFuncExactConstantExtensionAlgebra C S N hExact + rw [rationalBase_algebraMap_eq C S N hExact] + apply congrArg (algebraMap (RatFunc S) (ExactConstantExtension C N S)) + exact ratFuncCoefficientAlgHom_algebraMap C S p + +/-- The finite place over `C` corresponding to a place in the explicit +`S[X]`-normalization. Extending its constants back to `S` recovers the +finite place constructed in `ConstantExtensionFinitePlaceBridge`. -/ +noncomputable def exactConstantExtensionCompatibleBaseFinitePlace + (q : IsDedekindDomain.HeightOneSpectrum + (integralClosure S[X] (ExactConstantExtension C N S))) : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + letI : Algebra (RatFunc S) (ExactConstantExtension C N S) := + ratFuncExactConstantExtensionAlgebra C S N hExact + FiniteExtensionFinitePlace C (ExactConstantExtension C N S) := by + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + letI : Algebra (RatFunc S) (ExactConstantExtension C N S) := + ratFuncExactConstantExtensionAlgebra C S N hExact + exact (IsDedekindDomain.HeightOneSpectrum.equivOfRingEquiv + (ratFuncFiniteIntegralClosureRingEquiv C S + (ExactConstantExtension C N S) + (exactConstantExtension_ratFunc_polynomialCompatibility + C S N hExact))).symm + (exactConstantExtensionUpstairsFinitePlace C S N hExact q) + +omit [DecidableEq C] [DecidableEq S] [DecidableEq (RatFunc C)] [DecidableEq (RatFunc S)] + [FiniteDimensional (RatFunc C) N] [Algebra.IsSeparable (RatFunc C) N] in +@[simp] +theorem exactConstantExtensionCompatibleBaseFinitePlace_baseChange + (q : IsDedekindDomain.HeightOneSpectrum + (integralClosure S[X] (ExactConstantExtension C N S))) : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + letI : Algebra (RatFunc S) (ExactConstantExtension C N S) := + ratFuncExactConstantExtensionAlgebra C S N hExact + IsDedekindDomain.HeightOneSpectrum.equivOfRingEquiv + (ratFuncFiniteIntegralClosureRingEquiv C S + (ExactConstantExtension C N S) + (exactConstantExtension_ratFunc_polynomialCompatibility + C S N hExact)) + (exactConstantExtensionCompatibleBaseFinitePlace C S N hExact q) = + exactConstantExtensionUpstairsFinitePlace C S N hExact q := by + let : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : Algebra (RatFunc S) (ExactConstantExtension C N S) := + ratFuncExactConstantExtensionAlgebra C S N hExact + exact Equiv.apply_symm_apply _ _ + +/-- The identity equivalence between the `C[X]`- and `S[X]`-normalizations +is linear over the enlarged constant field. -/ +noncomputable def exactConstantExtensionFiniteClosureBaseChangeAlgEquiv : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + letI : Algebra (RatFunc S) (ExactConstantExtension C N S) := + ratFuncExactConstantExtensionAlgebra C S N hExact + letI : Algebra S (RatFuncFiniteIntegralClosure C + (ExactConstantExtension C N S)) := + exactConstantExtensionFiniteIntegralClosureConstantAlgebra + C N S hExact + letI : Algebra S (RatFuncFiniteIntegralClosure S + (ExactConstantExtension C N S)) := + RingHom.toAlgebra + ((algebraMap S[X] (RatFuncFiniteIntegralClosure S + (ExactConstantExtension C N S))).comp (algebraMap S S[X])) + RatFuncFiniteIntegralClosure C (ExactConstantExtension C N S) ≃ₐ[S] + RatFuncFiniteIntegralClosure S (ExactConstantExtension C N S) := by + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + letI : Algebra (RatFunc S) (ExactConstantExtension C N S) := + ratFuncExactConstantExtensionAlgebra C S N hExact + letI : Algebra S (RatFuncFiniteIntegralClosure C + (ExactConstantExtension C N S)) := + exactConstantExtensionFiniteIntegralClosureConstantAlgebra C N S hExact + letI : Algebra S (RatFuncFiniteIntegralClosure S + (ExactConstantExtension C N S)) := + RingHom.toAlgebra + ((algebraMap S[X] (RatFuncFiniteIntegralClosure S + (ExactConstantExtension C N S))).comp (algebraMap S S[X])) + exact { ratFuncFiniteIntegralClosureRingEquiv C S + (ExactConstantExtension C N S) + (exactConstantExtension_ratFunc_polynomialCompatibility + C S N hExact) with + commutes' := fun s => by + apply Subtype.ext + change + ((algebraMap S (RatFuncFiniteIntegralClosure C + (ExactConstantExtension C N S)) s : + RatFuncFiniteIntegralClosure C + (ExactConstantExtension C N S)) : + ExactConstantExtension C N S) = + ((algebraMap S (RatFuncFiniteIntegralClosure S + (ExactConstantExtension C N S)) s : + RatFuncFiniteIntegralClosure S + (ExactConstantExtension C N S)) : + ExactConstantExtension C N S) + rw [exactConstantExtensionFiniteIntegralClosure_algebraMap_val] + change (Algebra.TensorProduct.includeLeft + (R := C) (S := C) (A := S) (B := N)) s = + algebraMap (RatFunc S) (ExactConstantExtension C N S) + (algebraMap S[X] (RatFunc S) (Polynomial.C s)) + change (Algebra.TensorProduct.includeLeft + (R := C) (S := C) (A := S) (B := N)) s = + (ratFuncToExactConstantExtension C S N hExact) + (algebraMap S (RatFunc S) s) + exact (ratFuncToExactConstantExtension C S N hExact).commutes s |>.symm } + +omit [DecidableEq C] [DecidableEq S] [DecidableEq (RatFunc C)] [DecidableEq (RatFunc S)] + [FiniteDimensional (RatFunc C) N] [Algebra.IsSeparable (RatFunc C) N] in +/-- The actual upstairs finite place is exactly the transport of the +presented prime along the equality bridge from the compatible polynomial +normalization to the canonical rational-function normalization. -/ +theorem exactConstantExtensionUpstairsFinitePlace_eq_compatibleNormalizationTransport + (q : IsDedekindDomain.HeightOneSpectrum + (integralClosure S[X] (ExactConstantExtension C N S))) : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + letI : Algebra (RatFunc S) (ExactConstantExtension C N S) := + ratFuncExactConstantExtensionAlgebra C S N hExact + let e := integralClosureAlgEquivRatFuncFiniteOfAlgebraMap + S (ExactConstantExtension C N S) + (constantExtensionTensorPolynomialAlgebra C S N) + (ratFuncToExactConstantExtension_algebraMap C S N hExact) + exactConstantExtensionUpstairsFinitePlace C S N hExact q = + heightOneSpectrumEquivOfAlgEquiv e q := by + let E := ExactConstantExtension C N S + let : Field E := exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) E := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : Algebra (RatFunc S) E := + ratFuncExactConstantExtensionAlgebra C S N hExact + let e := integralClosureAlgEquivRatFuncFiniteOfAlgebraMap + S E (constantExtensionTensorPolynomialAlgebra C S N) + (ratFuncToExactConstantExtension_algebraMap C S N hExact) + let eNorm := exactConstantExtensionNormalizationAlgEquiv C S N hExact + let qTensor := exactConstantExtensionTensorNormalizationHeightOne C S N q + have hNormalizationToPolynomial + (z : S ⊗[C] integralClosure C[X] N) : + ((eNorm z : RatFuncFiniteIntegralClosure S E) : E) = + ((finiteFieldConstantExtensionIntegralClosurePolynomialAlgEquiv + C S N z : integralClosure S[X] E) : E) := by + simp only [exactConstantExtensionNormalizationAlgEquiv, + normalizationAlgEquivRatFuncFiniteOfAlgebraMap, + integralClosureAlgEquivRatFuncFiniteOfAlgebraMap, AlgEquiv.trans_apply, eNorm] + rw [integralClosureAlgEquivRatFuncFiniteOfEq_coe] + apply IsDedekindDomain.HeightOneSpectrum.ext + have hActualIdeal : + (exactConstantExtensionUpstairsFinitePlace + C S N hExact q).asIdeal = + qTensor.asIdeal.comap eNorm.symm := rfl + have hDirectIdeal : + (heightOneSpectrumEquivOfAlgEquiv e q).asIdeal = + q.asIdeal.comap e.symm := rfl + rw [hActualIdeal, hDirectIdeal] + rw [show qTensor.asIdeal = q.asIdeal.comap + (finiteFieldConstantExtensionIntegralClosureAlgEquiv C S N) by rfl] + ext x + change finiteFieldConstantExtensionIntegralClosureAlgEquiv C S N + (eNorm.symm x) ∈ q.asIdeal ↔ e.symm x ∈ q.asIdeal + rw [show finiteFieldConstantExtensionIntegralClosureAlgEquiv C S N + (eNorm.symm x) = e.symm x by + apply Subtype.ext + calc + ((finiteFieldConstantExtensionIntegralClosureAlgEquiv C S N + (eNorm.symm x) : integralClosure S[X] E) : E) = + ((finiteFieldConstantExtensionIntegralClosurePolynomialAlgEquiv + C S N (eNorm.symm x) : integralClosure S[X] E) : E) := + congrArg Subtype.val + (finiteFieldConstantExtensionIntegralClosureAlgEquiv_apply_eq_polynomial + C S N (eNorm.symm x)) + _ = ((eNorm (eNorm.symm x) : RatFuncFiniteIntegralClosure S E) : E) := + (hNormalizationToPolynomial (eNorm.symm x)).symm + _ = (x : E) := congrArg Subtype.val (eNorm.apply_symm_apply x) + _ = ((e.symm x : integralClosure S[X] E) : E) := by + calc + (x : E) = ((e (e.symm x) : RatFuncFiniteIntegralClosure S E) : E) := + congrArg Subtype.val (e.apply_symm_apply x).symm + _ = ((e.symm x : integralClosure S[X] E) : E) := + integralClosureAlgEquivRatFuncFiniteOfEq_coe + (constantExtensionTensorPolynomialAlgebra C S N) + (ratFuncInducedPolynomialAlgebra_eq S E + (constantExtensionTensorPolynomialAlgebra C S N) + (ratFuncToExactConstantExtension_algebraMap C S N hExact)) + (e.symm x)] + +/-- Corresponding finite places have equivalent residue fields as +`S`-algebras, even though the source place is represented in the +`C[X]`-normalization. -/ +noncomputable def exactConstantExtensionCompatibleResidueFieldAlgEquiv + (q : IsDedekindDomain.HeightOneSpectrum + (integralClosure S[X] (ExactConstantExtension C N S))) : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + letI : Algebra (RatFunc S) (ExactConstantExtension C N S) := + ratFuncExactConstantExtensionAlgebra C S N hExact + letI : Algebra S (RatFuncFiniteIntegralClosure C + (ExactConstantExtension C N S)) := + exactConstantExtensionFiniteIntegralClosureConstantAlgebra + C N S hExact + letI : Algebra S (RatFuncFiniteIntegralClosure S + (ExactConstantExtension C N S)) := + RingHom.toAlgebra + ((algebraMap S[X] (RatFuncFiniteIntegralClosure S + (ExactConstantExtension C N S))).comp (algebraMap S S[X])) + (exactConstantExtensionCompatibleBaseFinitePlace C S N hExact q).asIdeal.ResidueField + ≃ₐ[S] + (exactConstantExtensionUpstairsFinitePlace C S N hExact q).asIdeal.ResidueField := by + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + letI : Algebra (RatFunc S) (ExactConstantExtension C N S) := + ratFuncExactConstantExtensionAlgebra C S N hExact + letI : Algebra S (RatFuncFiniteIntegralClosure C + (ExactConstantExtension C N S)) := + exactConstantExtensionFiniteIntegralClosureConstantAlgebra C N S hExact + letI : Algebra S (RatFuncFiniteIntegralClosure S + (ExactConstantExtension C N S)) := + RingHom.toAlgebra + ((algebraMap S[X] (RatFuncFiniteIntegralClosure S + (ExactConstantExtension C N S))).comp (algebraMap S S[X])) + let e := exactConstantExtensionFiniteClosureBaseChangeAlgEquiv + C S N hExact + let Q := exactConstantExtensionCompatibleBaseFinitePlace C S N hExact q + apply Ideal.residueFieldAlgEquiv Q.asIdeal + (exactConstantExtensionUpstairsFinitePlace C S N hExact q).asIdeal e + change Q.asIdeal = + (exactConstantExtensionUpstairsFinitePlace C S N hExact q).asIdeal.comap e + rfl + +omit [DecidableEq C] [DecidableEq S] [DecidableEq (RatFunc C)] [DecidableEq (RatFunc S)] + [FiniteDimensional (RatFunc C) N] [Algebra.IsSeparable (RatFunc C) N] in +/-- The two representations of the upstairs place have the same residue +degree over the enlarged constants. -/ +theorem exactConstantExtensionCompatibleResidueField_finrank_eq + (q : IsDedekindDomain.HeightOneSpectrum + (integralClosure S[X] (ExactConstantExtension C N S))) : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + letI : Algebra (RatFunc S) (ExactConstantExtension C N S) := + ratFuncExactConstantExtensionAlgebra C S N hExact + letI : Algebra S (RatFuncFiniteIntegralClosure C + (ExactConstantExtension C N S)) := + exactConstantExtensionFiniteIntegralClosureConstantAlgebra + C N S hExact + letI : Algebra S (RatFuncFiniteIntegralClosure S + (ExactConstantExtension C N S)) := + RingHom.toAlgebra + ((algebraMap S[X] (RatFuncFiniteIntegralClosure S + (ExactConstantExtension C N S))).comp (algebraMap S S[X])) + Module.finrank S + (exactConstantExtensionCompatibleBaseFinitePlace + C S N hExact q).asIdeal.ResidueField = + Module.finrank S + (exactConstantExtensionUpstairsFinitePlace + C S N hExact q).asIdeal.ResidueField := + by + let : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : Algebra (RatFunc S) (ExactConstantExtension C N S) := + ratFuncExactConstantExtensionAlgebra C S N hExact + let : Algebra S (RatFuncFiniteIntegralClosure C + (ExactConstantExtension C N S)) := + exactConstantExtensionFiniteIntegralClosureConstantAlgebra C N S hExact + let : Algebra S (RatFuncFiniteIntegralClosure S + (ExactConstantExtension C N S)) := + RingHom.toAlgebra + ((algebraMap S[X] (RatFuncFiniteIntegralClosure S + (ExactConstantExtension C N S))).comp (algebraMap S S[X])) + exact (exactConstantExtensionCompatibleResidueFieldAlgEquiv + C S N hExact q).toLinearEquiv.finrank_eq + +/-- An `S`-rational place in the explicit normalization has absolute +`C`-degree `[S : C]` in the finite-place model used by the Galois action. -/ +theorem exactConstantExtensionCompatibleBaseFinitePlace_degree_eq + (q : IsDedekindDomain.HeightOneSpectrum + (integralClosure S[X] (ExactConstantExtension C N S))) + : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + letI : Algebra (RatFunc S) (ExactConstantExtension C N S) := + ratFuncExactConstantExtensionAlgebra C S N hExact + letI : SMul (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toSMul + letI : Module (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toModule + letI : FiniteDimensional (RatFunc C) + (ExactConstantExtension C N S) := + finiteDimensional_exactConstantExtension_over_baseRatFunc + C S N hExact + letI : Algebra.IsSeparable (RatFunc C) + (ExactConstantExtension C N S) := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + letI : SMul (RatFunc S) (ExactConstantExtension C N S) := + Algebra.toSMul + letI : Module (RatFunc S) (ExactConstantExtension C N S) := + Algebra.toModule + letI : FiniteDimensional (RatFunc S) + (ExactConstantExtension C N S) := + finiteDimensional_over_extendedRatFunc C S N hExact + letI : Algebra.IsSeparable (RatFunc S) + (ExactConstantExtension C N S) := + isSeparable_over_extendedRatFunc C S N hExact + finiteExtensionPlaceDegree S + (ExactConstantExtension C N S) + (.inl (exactConstantExtensionUpstairsFinitePlace + C S N hExact q)) = 1 → + finiteExtensionPlaceDegree C (ExactConstantExtension C N S) + (.inl (exactConstantExtensionCompatibleBaseFinitePlace + C S N hExact q)) = Module.finrank C S := by + let : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : Algebra (RatFunc S) (ExactConstantExtension C N S) := + ratFuncExactConstantExtensionAlgebra C S N hExact + let : SMul (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toSMul + let : Module (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toModule + let : FiniteDimensional (RatFunc C) + (ExactConstantExtension C N S) := + finiteDimensional_exactConstantExtension_over_baseRatFunc C S N hExact + let : Algebra.IsSeparable (RatFunc C) + (ExactConstantExtension C N S) := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + let : SMul (RatFunc S) (ExactConstantExtension C N S) := + Algebra.toSMul + let : Module (RatFunc S) (ExactConstantExtension C N S) := + Algebra.toModule + let : FiniteDimensional (RatFunc S) + (ExactConstantExtension C N S) := + finiteDimensional_over_extendedRatFunc C S N hExact + let : Algebra.IsSeparable (RatFunc S) + (ExactConstantExtension C N S) := + isSeparable_over_extendedRatFunc C S N hExact + intro hRational + rw [finiteExtensionFinitePlace_degree_baseChange C S + (ExactConstantExtension C N S) + (exactConstantExtension_ratFunc_polynomialCompatibility + C S N hExact)] + rw [exactConstantExtensionCompatibleBaseFinitePlace_baseChange, + hRational, Nat.mul_one] + +omit [DecidableEq C] [DecidableEq (RatFunc C)] [DecidableEq (RatFunc S)] in +/-- Restricting the compatible `C[X]`-place to the original function field +recovers the downstairs place obtained by contracting the explicit constant +extension ideal. -/ +theorem exactConstantExtensionCompatibleBaseFinitePlace_under_original + (q : IsDedekindDomain.HeightOneSpectrum + (integralClosure S[X] (ExactConstantExtension C N S))) : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + letI : Algebra (RatFunc S) (ExactConstantExtension C N S) := + ratFuncExactConstantExtensionAlgebra C S N hExact + letI : SMul (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toSMul + letI : Module (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toModule + letI : FiniteDimensional (RatFunc C) + (ExactConstantExtension C N S) := + finiteDimensional_exactConstantExtension_over_baseRatFunc + C S N hExact + letI : Algebra.IsSeparable (RatFunc C) + (ExactConstantExtension C N S) := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + letI : Algebra N (ExactConstantExtension C N S) := + exactConstantExtensionAlgebra C N S + letI : SMul N (ExactConstantExtension C N S) := + Algebra.toSMul + letI : Module N (ExactConstantExtension C N S) := + Algebra.toModule + letI : IsScalarTower (RatFunc C) N + (ExactConstantExtension C N S) := + exactConstantExtensionBaseTower C (RatFunc C) N S + finitePlaceUnder C N (ExactConstantExtension C N S) + (exactConstantExtensionCompatibleBaseFinitePlace + C S N hExact q) = + exactConstantExtensionDownstairsFinitePlace C S N hExact q := by + let : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : Algebra (RatFunc S) (ExactConstantExtension C N S) := + ratFuncExactConstantExtensionAlgebra C S N hExact + let : SMul (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toSMul + let : Module (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toModule + let : FiniteDimensional (RatFunc C) + (ExactConstantExtension C N S) := + finiteDimensional_exactConstantExtension_over_baseRatFunc C S N hExact + let : Algebra.IsSeparable (RatFunc C) + (ExactConstantExtension C N S) := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + let : Algebra N (ExactConstantExtension C N S) := + exactConstantExtensionAlgebra C N S + let : SMul N (ExactConstantExtension C N S) := + Algebra.toSMul + let : Module N (ExactConstantExtension C N S) := + Algebra.toModule + let : IsScalarTower (RatFunc C) N + (ExactConstantExtension C N S) := + exactConstantExtensionBaseTower C (RatFunc C) N S + apply IsDedekindDomain.HeightOneSpectrum.ext + ext x + rw [finitePlaceUnder_asIdeal, + exactConstantExtensionDownstairsFinitePlace_asIdeal] + change finiteIntegralClosureMap C N (ExactConstantExtension C N S) x ∈ + (exactConstantExtensionCompatibleBaseFinitePlace + C S N hExact q).asIdeal ↔ + finiteFieldConstantExtensionIntegralClosureRingHom C S N x ∈ q.asIdeal + let eBase := ratFuncFiniteIntegralClosureRingEquiv C S + (ExactConstantExtension C N S) + (exactConstantExtension_ratFunc_polynomialCompatibility C S N hExact) + let Qs := exactConstantExtensionUpstairsFinitePlace C S N hExact q + have hBaseIdeal : + (exactConstantExtensionCompatibleBaseFinitePlace + C S N hExact q).asIdeal = Qs.asIdeal.comap eBase := rfl + rw [hBaseIdeal] + change eBase (finiteIntegralClosureMap C N + (ExactConstantExtension C N S) x) ∈ Qs.asIdeal ↔ + finiteFieldConstantExtensionIntegralClosureRingHom C S N x ∈ q.asIdeal + let qTensor := exactConstantExtensionTensorNormalizationHeightOne C S N q + let eNorm := exactConstantExtensionNormalizationAlgEquiv C S N hExact + have hTargetIdeal : Qs.asIdeal = qTensor.asIdeal.comap eNorm.symm := rfl + rw [hTargetIdeal] + change eNorm.symm (eBase (finiteIntegralClosureMap C N + (ExactConstantExtension C N S) x)) ∈ qTensor.asIdeal ↔ + finiteFieldConstantExtensionIntegralClosureRingHom C S N x ∈ q.asIdeal + let eTensor := finiteFieldConstantExtensionIntegralClosureAlgEquiv C S N + have hTensorIdeal : qTensor.asIdeal = q.asIdeal.comap eTensor := rfl + rw [hTensorIdeal] + change eTensor (eNorm.symm (eBase (finiteIntegralClosureMap C N + (ExactConstantExtension C N S) x))) ∈ q.asIdeal ↔ + finiteFieldConstantExtensionIntegralClosureRingHom C S N x ∈ q.asIdeal + have hNormalizationToPolynomial + (z : S ⊗[C] integralClosure C[X] N) : + ((eNorm z : RatFuncFiniteIntegralClosure S + (ExactConstantExtension C N S)) : + ExactConstantExtension C N S) = + ((finiteFieldConstantExtensionIntegralClosurePolynomialAlgEquiv + C S N z : integralClosure S[X] + (ExactConstantExtension C N S)) : + ExactConstantExtension C N S) := by + simp only [exactConstantExtensionNormalizationAlgEquiv, + normalizationAlgEquivRatFuncFiniteOfAlgebraMap, + integralClosureAlgEquivRatFuncFiniteOfAlgebraMap, AlgEquiv.trans_apply, eNorm] + rw [integralClosureAlgEquivRatFuncFiniteOfEq_coe] + have hNormalizationMapsAgree + (z : S ⊗[C] integralClosure C[X] N) : + ((eTensor z : integralClosure S[X] (ExactConstantExtension C N S)) : + ExactConstantExtension C N S) = + ((eNorm z : RatFuncFiniteIntegralClosure S + (ExactConstantExtension C N S)) : + ExactConstantExtension C N S) := by + calc + ((eTensor z : integralClosure S[X] + (ExactConstantExtension C N S)) : + ExactConstantExtension C N S) = + ((finiteFieldConstantExtensionIntegralClosurePolynomialAlgEquiv + C S N z : integralClosure S[X] + (ExactConstantExtension C N S)) : + ExactConstantExtension C N S) := + congrArg Subtype.val + (finiteFieldConstantExtensionIntegralClosureAlgEquiv_apply_eq_polynomial + C S N z) + _ = ((eNorm z : RatFuncFiniteIntegralClosure S + (ExactConstantExtension C N S)) : + ExactConstantExtension C N S) := (hNormalizationToPolynomial z).symm + rw [show eTensor (eNorm.symm (eBase (finiteIntegralClosureMap C N + (ExactConstantExtension C N S) x))) = + finiteFieldConstantExtensionIntegralClosureRingHom C S N x by + apply Subtype.ext + calc + ((eTensor (eNorm.symm (eBase (finiteIntegralClosureMap C N + (ExactConstantExtension C N S) x))) : + integralClosure S[X] (ExactConstantExtension C N S)) : + ExactConstantExtension C N S) = + ((eNorm (eNorm.symm (eBase (finiteIntegralClosureMap C N + (ExactConstantExtension C N S) x))) : + RatFuncFiniteIntegralClosure S + (ExactConstantExtension C N S)) : + ExactConstantExtension C N S) := + hNormalizationMapsAgree _ + _ = ((eBase (finiteIntegralClosureMap C N + (ExactConstantExtension C N S) x) : + RatFuncFiniteIntegralClosure S + (ExactConstantExtension C N S)) : + ExactConstantExtension C N S) := by + rw [eNorm.apply_symm_apply] + _ = ((finiteFieldConstantExtensionIntegralClosureRingHom C S N x : + integralClosure S[X] (ExactConstantExtension C N S)) : + ExactConstantExtension C N S) := by + calc + ((eBase (finiteIntegralClosureMap C N + (ExactConstantExtension C N S) x) : + RatFuncFiniteIntegralClosure S + (ExactConstantExtension C N S)) : + ExactConstantExtension C N S) = + ((finiteIntegralClosureMap C N + (ExactConstantExtension C N S) x : + RatFuncFiniteIntegralClosure C + (ExactConstantExtension C N S)) : + ExactConstantExtension C N S) := by + rfl + _ = (1 : S) ⊗ₜ[C] (x : N) := by rfl + _ = ((finiteFieldConstantExtensionIntegralClosureRingHom C S N x : + integralClosure S[X] (ExactConstantExtension C N S)) : + ExactConstantExtension C N S) := + (finiteFieldConstantExtensionIntegralClosureRingHom_coe + C S N x).symm] + +section IntermediateField + +variable (L : Type*) [Field L] + [Algebra (RatFunc C) L] [FiniteDimensional (RatFunc C) L] + [Algebra.IsSeparable (RatFunc C) L] + [Algebra L N] [IsScalarTower (RatFunc C) L N] + [FiniteDimensional L N] [IsGalois L N] + +local instance compatibilityIntermediateConstantAlgebra : Algebra C L := + RingHom.toAlgebra ((algebraMap (RatFunc C) L).comp + (algebraMap C (RatFunc C))) + +local instance compatibilityConstantIntermediateTopTower : + IsScalarTower C L N := by + apply IsScalarTower.of_algebraMap_eq' + ext c + change algebraMap (RatFunc C) N (algebraMap C (RatFunc C) c) = + algebraMap L N + (algebraMap (RatFunc C) L (algebraMap C (RatFunc C) c)) + exact IsScalarTower.algebraMap_apply (RatFunc C) L N _ + +omit [Fintype C] [Finite S] [DecidableEq C] [DecidableEq S] [DecidableEq (RatFunc C)] + [DecidableEq (RatFunc S)] [FiniteDimensional (RatFunc C) N] + [Algebra.IsSeparable (RatFunc C) N] [FiniteDimensional C S] [IsGalois C S] + [FiniteDimensional (RatFunc C) L] [Algebra.IsSeparable (RatFunc C) L] + [FiniteDimensional L N] [IsGalois L N] in +/-- The rational-function base, an intermediate field, and the exact +constant extension form the tower used by the relative Galois action. -/ +private theorem exactConstantExtensionCompatibility_ratFuncBaseTower : + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + letI : Algebra L (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C L N S + letI : SMul (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toSMul + letI : Module (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toModule + letI : SMul L (ExactConstantExtension C N S) := Algebra.toSMul + letI : Module L (ExactConstantExtension C N S) := Algebra.toModule + IsScalarTower (RatFunc C) L (ExactConstantExtension C N S) := by + let : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : Algebra L (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C L N S + let : Algebra N (ExactConstantExtension C N S) := + exactConstantExtensionAlgebra C N S + let : SMul (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toSMul + let : Module (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toModule + let : SMul L (ExactConstantExtension C N S) := Algebra.toSMul + let : Module L (ExactConstantExtension C N S) := Algebra.toModule + apply IsScalarTower.of_algebraMap_eq' + ext x + change (1 : S) ⊗ₜ[C] algebraMap (RatFunc C) N x = + (1 : S) ⊗ₜ[C] algebraMap L N (algebraMap (RatFunc C) L x) + congr 1 + exact IsScalarTower.algebraMap_apply (RatFunc C) L N x + +/-- For an actual finite place in the constant-extended normalization, a +rational restriction to `L` and divisibility `[N : L] ∣ [S : C]` imply the +decomposition-group cardinality identity. The residue-degree-one, absolute +top-degree, and rational-base hypotheses of the generic theorem are all +derived internally. -/ +theorem exactConstantExtensionFinitePlace_decompositionGroup_card_of_rational_base + (q : IsDedekindDomain.HeightOneSpectrum + (integralClosure S[X] (ExactConstantExtension C N S))) + (hBase : finiteExtensionPlaceDegree C L + (.inl (finitePlaceUnder C L N + (exactConstantExtensionDownstairsFinitePlace C S N hExact q))) = 1) + (hDegreeDiv : Module.finrank L N ∣ Module.finrank C S) : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + letI : Algebra L (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C L N S + letI : SMul (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toSMul + letI : Module (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toModule + letI : SMul L (ExactConstantExtension C N S) := Algebra.toSMul + letI : Module L (ExactConstantExtension C N S) := Algebra.toModule + letI : IsScalarTower (RatFunc C) L + (ExactConstantExtension C N S) := + by exact exactConstantExtensionCompatibility_ratFuncBaseTower C S N hExact L + letI : IsGalois L (ExactConstantExtension C N S) := + exactConstantExtension_isGalois C L N S hExact + let Q := exactConstantExtensionCompatibleBaseFinitePlace + C S N hExact q + Nat.card (finitePlaceDecompositionGroup C L + (ExactConstantExtension C N S) Q) = + Nat.card + ((exactConstantExtensionConstantQuotient C L N S hExact).comp + (finitePlaceDecompositionGroup C L + (ExactConstantExtension C N S) Q).subtype).ker * + Nat.card (S ≃ₐ[C] S) := by + let : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : Algebra (RatFunc S) (ExactConstantExtension C N S) := + ratFuncExactConstantExtensionAlgebra C S N hExact + let : Algebra L (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C L N S + let : Algebra N (ExactConstantExtension C N S) := + exactConstantExtensionAlgebra C N S + let : SMul (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toSMul + let : Module (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toModule + let : SMul L (ExactConstantExtension C N S) := Algebra.toSMul + let : Module L (ExactConstantExtension C N S) := Algebra.toModule + let : SMul N (ExactConstantExtension C N S) := Algebra.toSMul + let : Module N (ExactConstantExtension C N S) := Algebra.toModule + let : IsScalarTower (RatFunc C) L + (ExactConstantExtension C N S) := + exactConstantExtensionCompatibility_ratFuncBaseTower C S N hExact L + let : IsScalarTower (RatFunc C) N + (ExactConstantExtension C N S) := + exactConstantExtensionBaseTower C (RatFunc C) N S + let : IsScalarTower L N (ExactConstantExtension C N S) := + exactConstantExtensionBaseTower C L N S + let : IsGalois L (ExactConstantExtension C N S) := + exactConstantExtension_isGalois C L N S hExact + let : FiniteDimensional (RatFunc C) + (ExactConstantExtension C N S) := + finiteDimensional_exactConstantExtension_over_baseRatFunc C S N hExact + let : Algebra.IsSeparable (RatFunc C) + (ExactConstantExtension C N S) := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + let : SMul (RatFunc S) (ExactConstantExtension C N S) := + Algebra.toSMul + let : Module (RatFunc S) (ExactConstantExtension C N S) := + Algebra.toModule + let : FiniteDimensional (RatFunc S) + (ExactConstantExtension C N S) := + finiteDimensional_over_extendedRatFunc C S N hExact + let : Algebra.IsSeparable (RatFunc S) + (ExactConstantExtension C N S) := + isSeparable_over_extendedRatFunc C S N hExact + let : Algebra S (RatFuncFiniteIntegralClosure C + (ExactConstantExtension C N S)) := + exactConstantExtensionFiniteIntegralClosureConstantAlgebra C N S hExact + let : Algebra S (RatFuncFiniteIntegralClosure S + (ExactConstantExtension C N S)) := + RingHom.toAlgebra + ((algebraMap S[X] (RatFuncFiniteIntegralClosure S + (ExactConstantExtension C N S))).comp (algebraMap S S[X])) + let : MulSemiringAction + (ExactConstantExtension C N S ≃ₐ[L] ExactConstantExtension C N S) + (RatFuncFiniteIntegralClosure C (ExactConstantExtension C N S)) := + finiteIntegralClosureGalAction C L (ExactConstantExtension C N S) + let P := exactConstantExtensionDownstairsFinitePlace C S N hExact q + let P₀ := finitePlaceUnder C L N P + let Q := exactConstantExtensionCompatibleBaseFinitePlace C S N hExact q + let Qs := exactConstantExtensionUpstairsFinitePlace C S N hExact q + have hInertiaDiv : finitePlaceRelativeInertiaDeg C L N P ∣ + Module.finrank L N := by + let PInFiber : FinitePlaceUnderFiber C L N P₀ := ⟨P, rfl⟩ + have hFiber := + finitePlaceUnderFiber_card_mul_ramificationIdx_mul_inertiaDeg_eq_field_finrank + C L N P₀ PInFiber + refine ⟨Fintype.card (FinitePlaceUnderFiber C L N P₀) * + finitePlaceRelativeRamificationIdx C L N P, ?_⟩ + simpa [PInFiber, Nat.mul_comm, Nat.mul_left_comm, Nat.mul_assoc] + using hFiber.symm + have hDownDegreeEq : finiteExtensionPlaceDegree C N (.inl P) = + finitePlaceRelativeInertiaDeg C L N P := by + have hDegree := finiteExtensionPlaceDegree_inl_eq_mul_relativeInertiaDeg + C L N P + simpa [P₀, P, hBase] using hDegree + have hDownDegreeDiv : finiteExtensionPlaceDegree C N (.inl P) ∣ + Module.finrank C S := by + rw [hDownDegreeEq] + exact hInertiaDiv.trans hDegreeDiv + have hUpstairsRational : + finiteExtensionPlaceDegree S (ExactConstantExtension C N S) + (.inl Qs) = 1 := by + rw [show finiteExtensionPlaceDegree S (ExactConstantExtension C N S) + (.inl Qs) = + finiteExtensionPlaceDegree C N (.inl P) / + Nat.gcd (Module.finrank C S) + (finiteExtensionPlaceDegree C N (.inl P)) by + exact exactConstantExtensionFinitePlace_degree_eq_div_gcd + C S N hExact q] + rw [(Nat.gcd_eq_right_iff_dvd).2 hDownDegreeDiv] + exact Nat.div_self + (finiteExtensionPlaceDegree_pos C N (.inl P)) + have hResidue : Module.finrank S Q.asIdeal.ResidueField = 1 := by + calc + Module.finrank S Q.asIdeal.ResidueField = + Module.finrank S Qs.asIdeal.ResidueField := + exactConstantExtensionCompatibleResidueField_finrank_eq + C S N hExact q + _ = finiteExtensionPlaceDegree S (ExactConstantExtension C N S) + (.inl Qs) := + (finiteExtensionFinitePlace_degree_eq_finrank_residueField + S (ExactConstantExtension C N S) Qs).symm + _ = 1 := hUpstairsRational + have hTop : finiteExtensionPlaceDegree C + (ExactConstantExtension C N S) (.inl Q) = Module.finrank C S := + exactConstantExtensionCompatibleBaseFinitePlace_degree_eq + C S N hExact q hUpstairsRational + let R₀ := RatFuncFiniteIntegralClosure C L + let R₁ := RatFuncFiniteIntegralClosure C N + let R₂ := RatFuncFiniteIntegralClosure C (ExactConstantExtension C N S) + let : Algebra R₀ R₁ := (finiteIntegralClosureMap C L N).toAlgebra + let : Algebra R₁ R₂ := + (finiteIntegralClosureMap C N (ExactConstantExtension C N S)).toAlgebra + let : Algebra R₀ R₂ := + (finiteIntegralClosureMap C L (ExactConstantExtension C N S)).toAlgebra + let : SMul R₀ R₁ := Algebra.toSMul + let : Module R₀ R₁ := Algebra.toModule + let : SMul R₁ R₂ := Algebra.toSMul + let : Module R₁ R₂ := Algebra.toModule + let : SMul R₀ R₂ := Algebra.toSMul + let : Module R₀ R₂ := Algebra.toModule + let : IsScalarTower R₀ R₁ R₂ := by + apply IsScalarTower.of_algebraMap_eq' + ext x + change algebraMap L (ExactConstantExtension C N S) (x : L) = + algebraMap N (ExactConstantExtension C N S) + (algebraMap L N (x : L)) + exact IsScalarTower.algebraMap_apply L N + (ExactConstantExtension C N S) _ + have hUnderOriginal : finitePlaceUnder C N + (ExactConstantExtension C N S) Q = P := + exactConstantExtensionCompatibleBaseFinitePlace_under_original + C S N hExact q + have hUnder : finitePlaceUnder C L + (ExactConstantExtension C N S) Q = finitePlaceUnder C L N P := by + apply IsDedekindDomain.HeightOneSpectrum.ext + change Q.asIdeal.under R₀ = P.asIdeal.under R₀ + calc + Q.asIdeal.under R₀ = (Q.asIdeal.under R₁).under R₀ := + (Ideal.under_under Q.asIdeal).symm + _ = P.asIdeal.under R₀ := by + rw [show Q.asIdeal.under R₁ = P.asIdeal by + exact congrArg IsDedekindDomain.HeightOneSpectrum.asIdeal + hUnderOriginal] + have hBaseTop : finiteExtensionPlaceDegree C L + (.inl (finitePlaceUnder C L (ExactConstantExtension C N S) Q)) = 1 := by + rw [hUnder] + exact hBase + exact exactConstantExtensionFinitePlace_decompositionGroup_card + C N S hExact L Q hResidue hTop hBaseTop + +end IntermediateField + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionFinitePlaceFrobeniusAverage.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionFinitePlaceFrobeniusAverage.lean new file mode 100644 index 0000000000..525251a3bf --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionFinitePlaceFrobeniusAverage.lean @@ -0,0 +1,351 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionFinitePlaceCompatibility + +/-! +# Frobenius-coset averaging at finite places of an exact constant extension + +This file composes the actual constant-extension finite-place construction +with the Frobenius-coset form of Burnside's lemma. A rational place below +one explicit constant-extended finite place supplies the decomposition-group +cardinality at that place. Transitivity of the relative Galois action and +cyclicity of the finite-field Galois group propagate surjectivity of the +constant quotient to every stabilizer in the same restriction fiber. +-/ + +@[expose] public section + +open scoped Polynomial TensorProduct + +namespace BGS.HasseWeil + +noncomputable section + +open BGS.CorvajaZannier + + +/-- In a transitive action, surjectivity of a homomorphism on one stabilizer +propagates to every stabilizer when the target is cyclic. Stabilizers in the +same orbit are conjugate, and conjugation disappears in a cyclic target. -/ +theorem MonoidHom.stabilizer_surjective_of_isPretransitive_of_isCyclic + {G A X : Type*} [Group G] [Group A] [IsCyclic A] + [MulAction G X] [MulAction.IsPretransitive G X] + (pi : G →* A) (x₀ : X) + (h₀ : Function.Surjective + (pi.comp (MulAction.stabilizer G x₀).subtype)) : + ∀ x : X, Function.Surjective + (pi.comp (MulAction.stabilizer G x).subtype) := by + let : CommGroup A := IsCyclic.commGroup + intro x c + obtain ⟨g, hg⟩ := MulAction.exists_smul_eq G x₀ x + obtain ⟨h, hh⟩ := h₀ c + change pi (h : G) = c at hh + let h' : MulAction.stabilizer G x := + MulAction.stabilizerEquivStabilizer hg.symm h + refine ⟨h', ?_⟩ + change pi (h' : G) = c + rw [show (h' : G) = MulAut.conj g (h : G) by + exact MulAction.stabilizerEquivStabilizer_apply hg.symm h] + simpa [MulAut.conj_apply, map_mul] using hh + +variable (C S N : Type*) [Field C] [Field S] [Field N] + [Fintype C] [Finite S] + [DecidableEq C] [DecidableEq S] + [DecidableEq (RatFunc C)] [DecidableEq (RatFunc S)] + [Algebra (RatFunc C) N] [FiniteDimensional (RatFunc C) N] + [Algebra.IsSeparable (RatFunc C) N] + [Algebra C S] [FiniteDimensional C S] [IsGalois C S] + +local instance averageBaseConstantAlgebra : Algebra C N := + bridgeBaseConstantAlgebra C N + +local instance averageBaseConstantTower : + IsScalarTower C (RatFunc C) N := + IsScalarTower.of_algebraMap_eq' rfl + +local instance averageTargetPolynomialAlgebra : + Algebra S[X] (ExactConstantExtension C N S) := + bridgeTargetPolynomialAlgebra C S N + +variable (hExact : algebraicClosure C N = + (⊥ : IntermediateField C N)) + +section IntermediateField + +variable (L : Type*) [Field L] + [Algebra (RatFunc C) L] [FiniteDimensional (RatFunc C) L] + [Algebra.IsSeparable (RatFunc C) L] + [Algebra L N] [IsScalarTower (RatFunc C) L N] + [FiniteDimensional L N] [IsGalois L N] + +local instance averageIntermediateConstantAlgebra : Algebra C L := + RingHom.toAlgebra ((algebraMap (RatFunc C) L).comp + (algebraMap C (RatFunc C))) + +local instance averageConstantIntermediateTopTower : + IsScalarTower C L N := by + apply IsScalarTower.of_algebraMap_eq' + ext c + change algebraMap (RatFunc C) N (algebraMap C (RatFunc C) c) = + algebraMap L N + (algebraMap (RatFunc C) L (algebraMap C (RatFunc C) c)) + exact IsScalarTower.algebraMap_apply (RatFunc C) L N _ + +omit [Fintype C] [Finite S] [DecidableEq C] [DecidableEq S] [DecidableEq (RatFunc C)] + [DecidableEq (RatFunc S)] [FiniteDimensional (RatFunc C) N] + [Algebra.IsSeparable (RatFunc C) N] [FiniteDimensional C S] [IsGalois C S] + [FiniteDimensional (RatFunc C) L] [Algebra.IsSeparable (RatFunc C) L] + [FiniteDimensional L N] [IsGalois L N] in +/-- The rational-function base, the intermediate field, and the exact +constant extension form the tower used by the finite-place action. -/ +private theorem exactConstantExtensionFrobeniusAverage_ratFuncBaseTower : + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + letI : Algebra L (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C L N S + letI : SMul (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toSMul + letI : Module (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toModule + letI : SMul L (ExactConstantExtension C N S) := Algebra.toSMul + letI : Module L (ExactConstantExtension C N S) := Algebra.toModule + IsScalarTower (RatFunc C) L (ExactConstantExtension C N S) := by + let : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : Algebra L (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C L N S + let : Algebra N (ExactConstantExtension C N S) := + exactConstantExtensionAlgebra C N S + let : SMul (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toSMul + let : Module (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toModule + let : SMul L (ExactConstantExtension C N S) := Algebra.toSMul + let : Module L (ExactConstantExtension C N S) := Algebra.toModule + apply IsScalarTower.of_algebraMap_eq' + ext x + change (1 : S) ⊗ₜ[C] algebraMap (RatFunc C) N x = + (1 : S) ⊗ₜ[C] algebraMap L N (algebraMap (RatFunc C) L x) + congr 1 + exact IsScalarTower.algebraMap_apply (RatFunc C) L N x + +omit [Fintype C] [Finite S] [DecidableEq C] [DecidableEq S] [DecidableEq (RatFunc C)] + [DecidableEq (RatFunc S)] [FiniteDimensional (RatFunc C) N] + [Algebra.IsSeparable (RatFunc C) N] [Algebra (RatFunc C) L] + [FiniteDimensional (RatFunc C) L] [Algebra.IsSeparable (RatFunc C) L] + [IsScalarTower (RatFunc C) L N] [IsGalois L N] in +/-- The exact constant extension is finite-dimensional over the chosen +intermediate field. -/ +private theorem finiteDimensional_exactConstantExtension_over_intermediate + (hExact : algebraicClosure C N = (⊥ : IntermediateField C N)) : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra L (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C L N S + letI : SMul L (ExactConstantExtension C N S) := Algebra.toSMul + letI : Module L (ExactConstantExtension C N S) := Algebra.toModule + FiniteDimensional L (ExactConstantExtension C N S) := by + let : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + let : Algebra L (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C L N S + let : SMul L (ExactConstantExtension C N S) := Algebra.toSMul + let : Module L (ExactConstantExtension C N S) := Algebra.toModule + let : Algebra N (ExactConstantExtension C N S) := + exactConstantExtensionAlgebra C N S + let : SMul N (ExactConstantExtension C N S) := Algebra.toSMul + let : Module N (ExactConstantExtension C N S) := Algebra.toModule + let : IsScalarTower L N (ExactConstantExtension C N S) := + exactConstantExtensionBaseTower C L N S + let e := exactConstantExtensionLinearEquiv C N S + let : Module.Finite N (N ⊗[C] S) := Module.Finite.base_change C N S + let : Module.Finite N (ExactConstantExtension C N S) := + Module.Finite.equiv e + let : Module.Finite L (ExactConstantExtension C N S) := + Module.Finite.trans N (ExactConstantExtension C N S) + infer_instance + +/-- Local Frobenius-coset Burnside identity for an actual finite place of an +exact constant extension. The assumptions say only that its restriction to +`L` is rational and that `[N : L]` divides the constant-extension degree. +The exact decomposition-group cardinality, stabilizer surjectivity, and the +fixed-point total are all derived internally. -/ +theorem exactConstantExtensionFinitePlace_frobeniusFiber_fixedPoint_sum + (q : IsDedekindDomain.HeightOneSpectrum + (integralClosure S[X] (ExactConstantExtension C N S))) + (hBase : finiteExtensionPlaceDegree C L + (.inl (finitePlaceUnder C L N + (exactConstantExtensionDownstairsFinitePlace C S N hExact q))) = 1) + (hDegreeDiv : Module.finrank L N ∣ Module.finrank C S) : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + letI : Algebra L (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C L N S + letI : SMul (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toSMul + letI : Module (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toModule + letI : SMul L (ExactConstantExtension C N S) := Algebra.toSMul + letI : Module L (ExactConstantExtension C N S) := Algebra.toModule + letI : IsScalarTower (RatFunc C) L + (ExactConstantExtension C N S) := + by exact exactConstantExtensionFrobeniusAverage_ratFuncBaseTower C S N L + letI : IsGalois L (ExactConstantExtension C N S) := + exactConstantExtension_isGalois C L N S hExact + letI : FiniteDimensional L (ExactConstantExtension C N S) := + by + exact finiteDimensional_exactConstantExtension_over_intermediate + (C := C) (S := S) (N := N) (L := L) hExact + letI : FiniteDimensional (RatFunc C) + (ExactConstantExtension C N S) := + finiteDimensional_exactConstantExtension_over_baseRatFunc + C S N hExact + letI : Algebra.IsSeparable (RatFunc C) + (ExactConstantExtension C N S) := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + let Q := exactConstantExtensionCompatibleBaseFinitePlace + C S N hExact q + let P := finitePlaceUnder C L (ExactConstantExtension C N S) Q + let pi := exactConstantExtensionConstantQuotient C L N S hExact + letI : DecidableEq (S ≃ₐ[C] S) := Classical.decEq _ + letI : Fintype + (ExactConstantExtension C N S ≃ₐ[L] + ExactConstantExtension C N S) := Fintype.ofFinite _ + letI : Fintype (S ≃ₐ[C] S) := Fintype.ofFinite _ + letI : Fintype + (pi ⁻¹' ({FiniteField.frobeniusAlgEquivOfAlgebraic C S} : + Set (S ≃ₐ[C] S))) := Fintype.ofFinite _ + letI := finiteIntegralClosureGalAction C L + (ExactConstantExtension C N S) + letI := finitePlaceUnderFiberGalAction C L + (ExactConstantExtension C N S) P + (∑ g : pi ⁻¹' ({FiniteField.frobeniusAlgEquivOfAlgebraic C S} : + Set (S ≃ₐ[C] S)), + Nat.card (MulAction.fixedBy + (FinitePlaceUnderFiber C L (ExactConstantExtension C N S) P) g.1)) = + Nat.card (N ≃ₐ[L] N) := by + let : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : Algebra L (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C L N S + let : Algebra N (ExactConstantExtension C N S) := + exactConstantExtensionAlgebra C N S + let : SMul (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toSMul + let : Module (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toModule + let : SMul L (ExactConstantExtension C N S) := Algebra.toSMul + let : Module L (ExactConstantExtension C N S) := Algebra.toModule + let : SMul N (ExactConstantExtension C N S) := Algebra.toSMul + let : Module N (ExactConstantExtension C N S) := Algebra.toModule + let : IsScalarTower (RatFunc C) L + (ExactConstantExtension C N S) := + exactConstantExtensionFrobeniusAverage_ratFuncBaseTower C S N L + let : IsScalarTower (RatFunc C) N + (ExactConstantExtension C N S) := + exactConstantExtensionBaseTower C (RatFunc C) N S + let : IsScalarTower L N (ExactConstantExtension C N S) := + exactConstantExtensionBaseTower C L N S + let : IsGalois L (ExactConstantExtension C N S) := + exactConstantExtension_isGalois C L N S hExact + let : FiniteDimensional L (ExactConstantExtension C N S) := + finiteDimensional_exactConstantExtension_over_intermediate + (C := C) (S := S) (N := N) (L := L) hExact + let : FiniteDimensional (RatFunc C) + (ExactConstantExtension C N S) := + finiteDimensional_exactConstantExtension_over_baseRatFunc C S N hExact + let : Algebra.IsSeparable (RatFunc C) + (ExactConstantExtension C N S) := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + let Q := exactConstantExtensionCompatibleBaseFinitePlace C S N hExact q + let P := finitePlaceUnder C L (ExactConstantExtension C N S) Q + let pi := exactConstantExtensionConstantQuotient C L N S hExact + let : DecidableEq (S ≃ₐ[C] S) := Classical.decEq _ + let : Fintype + (ExactConstantExtension C N S ≃ₐ[L] + ExactConstantExtension C N S) := Fintype.ofFinite _ + let : Fintype (S ≃ₐ[C] S) := Fintype.ofFinite _ + let : Fintype + (pi ⁻¹' ({FiniteField.frobeniusAlgEquivOfAlgebraic C S} : + Set (S ≃ₐ[C] S))) := Fintype.ofFinite _ + let := finiteIntegralClosureGalAction C L + (ExactConstantExtension C N S) + let := finitePlaceUnderFiberGalAction C L + (ExactConstantExtension C N S) P + let : MulAction.IsPretransitive + (ExactConstantExtension C N S ≃ₐ[L] ExactConstantExtension C N S) + (FinitePlaceUnderFiber C L (ExactConstantExtension C N S) P) := + finitePlaceUnderFiberGalAction_isPretransitive C L + (ExactConstantExtension C N S) P + let Q₀ : FinitePlaceUnderFiber C L + (ExactConstantExtension C N S) P := ⟨Q, rfl⟩ + let : Nonempty (FinitePlaceUnderFiber C L + (ExactConstantExtension C N S) P) := ⟨Q₀⟩ + have hdecomp := + exactConstantExtensionFinitePlace_decompositionGroup_card_of_rational_base + C S N hExact L q hBase hDegreeDiv + have hcard₀ : + Nat.card (MulAction.stabilizer + (ExactConstantExtension C N S ≃ₐ[L] + ExactConstantExtension C N S) Q₀) = + Nat.card + (pi.comp (MulAction.stabilizer + (ExactConstantExtension C N S ≃ₐ[L] + ExactConstantExtension C N S) Q₀).subtype).ker * + Nat.card (S ≃ₐ[C] S) := by + rw [finitePlaceUnderFiber_stabilizer_eq_decompositionGroup + C L (ExactConstantExtension C N S) P Q₀] + exact hdecomp + have hsurj₀ : Function.Surjective + (pi.comp (MulAction.stabilizer + (ExactConstantExtension C N S ≃ₐ[L] + ExactConstantExtension C N S) Q₀).subtype) := + MonoidHom.surjective_of_card_eq_card_ker_mul_card _ hcard₀ + have hsurj : ∀ x : FinitePlaceUnderFiber C L + (ExactConstantExtension C N S) P, + Function.Surjective + (pi.comp (MulAction.stabilizer + (ExactConstantExtension C N S ≃ₐ[L] + ExactConstantExtension C N S) x).subtype) := + MonoidHom.stabilizer_surjective_of_isPretransitive_of_isCyclic + pi Q₀ hsurj₀ + have hburnside := sum_card_fixedBy_quotientFiber_eq_card_ker + pi hsurj (FiniteField.frobeniusAlgEquivOfAlgebraic C S) + calc + (∑ g : pi ⁻¹' ({FiniteField.frobeniusAlgEquivOfAlgebraic C S} : + Set (S ≃ₐ[C] S)), + Nat.card (MulAction.fixedBy + (FinitePlaceUnderFiber C L (ExactConstantExtension C N S) P) + g.1)) = + Nat.card pi.ker := hburnside + _ = Nat.card (N ≃ₐ[L] N) := by + rw [exactConstantExtensionConstantQuotient_ker C L N S hExact] + have hinjective : Function.Injective + (exactConstantExtensionFunctionAutHom C L N S) := by + intro g h hgh + have hp := exactConstantExtensionCombinedAutHom_injective C L N S + (show exactConstantExtensionCombinedAutHom C L N S + (1, g) = + exactConstantExtensionCombinedAutHom C L N S + (1, h) by + simpa [exactConstantExtensionCombinedAutHom] using hgh) + exact congrArg Prod.snd hp + exact Nat.card_congr (Equiv.ofInjective + (exactConstantExtensionFunctionAutHom C L N S) + hinjective).symm + +end IntermediateField + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionFrobeniusTwist.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionFrobeniusTwist.lean new file mode 100644 index 0000000000..98d09f14df --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionFrobeniusTwist.lean @@ -0,0 +1,372 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionQuotient +public import LeanPool.MarkoffModP.BGS.HasseWeil.FrobeniusTwistGroup + +/-! +# Fixed fields of Frobenius twists + +Let `C ⊆ L ⊆ N`, let `C` be algebraically closed in `N`, and let +`S / C` be a finite Galois extension of finite fields. The exact constant +extension `T = S ⊗[C] N` has Galois group + +`Gal(T/L) ≃ Gal(S/C) × Gal(N/L)`. + +For `g ∈ Gal(N/L)`, this file constructs the automorphism of `T` represented +by `(Frob, g)`, its cyclic subgroup, and its fixed field. If +`|Gal(N/L)|` divides `[S : C]`, the cyclic subgroup has order `[S : C]` +and meets the original function-field factor trivially. Consequently `T` +is a finite Galois extension of the twist field of degree `[S : C]`, while +the twist field has degree `[N : L]` over `L`. + +These are the structural assertions in the setup of Stichtenoth, +Proposition 5.2.8. Exactness of the constant field of the twist requires, +in addition, stability of relative algebraic closedness under finite +separable base change; that separate regular-base-change lemma is not +assumed here. +-/ + +@[expose] public section + +open scoped TensorProduct + +namespace BGS.HasseWeil + +noncomputable section + +variable (C L N S : Type*) [Field C] [Field L] [Field N] [Field S] + [Algebra C L] [Algebra L N] [Algebra C N] [IsScalarTower C L N] + [Algebra C S] [FiniteDimensional C S] [IsGalois C S] + [FiniteDimensional L N] [IsGalois L N] + +section FiniteConstants + +variable [Fintype C] [Finite S] + +/-- The automorphism of the exact constant extension represented by +`(Frob, g)` under the direct-product description of its Galois group. -/ +noncomputable def exactConstantExtensionFrobeniusTwist + (hExact : algebraicClosure C N = (⊥ : IntermediateField C N)) + (g : N ≃ₐ[L] N) : + letI := exactConstantExtensionField C N S hExact + letI := exactConstantExtensionBaseAlgebra C L N S + ExactConstantExtension C N S ≃ₐ[L] + ExactConstantExtension C N S := by + letI := exactConstantExtensionField C N S hExact + letI := exactConstantExtensionBaseAlgebra C L N S + exact exactConstantExtensionCombinedAutHom C L N S + (FiniteField.frobeniusAlgEquivOfAlgebraic C S, g) + +/-- The cyclic subgroup generated by a Frobenius twist. -/ +noncomputable def exactConstantExtensionFrobeniusTwistSubgroup + (hExact : algebraicClosure C N = (⊥ : IntermediateField C N)) + (g : N ≃ₐ[L] N) : + letI := exactConstantExtensionField C N S hExact + letI := exactConstantExtensionBaseAlgebra C L N S + Subgroup (ExactConstantExtension C N S ≃ₐ[L] + ExactConstantExtension C N S) := by + letI := exactConstantExtensionField C N S hExact + letI := exactConstantExtensionBaseAlgebra C L N S + exact Subgroup.zpowers + (exactConstantExtensionFrobeniusTwist C L N S hExact g) + +/-- The fixed field of the cyclic subgroup generated by a Frobenius twist. -/ +noncomputable def exactConstantExtensionFrobeniusTwistField + (hExact : algebraicClosure C N = (⊥ : IntermediateField C N)) + (g : N ≃ₐ[L] N) : + letI := exactConstantExtensionField C N S hExact + letI := exactConstantExtensionBaseAlgebra C L N S + IntermediateField L (ExactConstantExtension C N S) := by + letI := exactConstantExtensionField C N S hExact + letI := exactConstantExtensionBaseAlgebra C L N S + exact IntermediateField.fixedField + (exactConstantExtensionFrobeniusTwistSubgroup C L N S hExact g) + +/-- The extended base inside the exact constant extension, characterized as +the fixed field of the original function-field factor. In the rational +function specialization this is the copy of `S(X)`. -/ +noncomputable def exactConstantExtensionExtendedBaseField + (hExact : algebraicClosure C N = (⊥ : IntermediateField C N)) : + letI := exactConstantExtensionField C N S hExact + letI := exactConstantExtensionBaseAlgebra C L N S + IntermediateField L (ExactConstantExtension C N S) := by + letI := exactConstantExtensionField C N S hExact + letI := exactConstantExtensionBaseAlgebra C L N S + exact IntermediateField.fixedField + (exactConstantExtensionConstantQuotient C L N S hExact).ker + +omit [Algebra C L] [IsScalarTower C L N] + [IsGalois L N] [Fintype C] [Finite S] in +/-- The exact constant extension is finite-dimensional over the original +base. This local bridge makes the finite Galois correspondence available +for the twist fields. -/ +private theorem finiteDimensional_exactConstantExtension_over_base + (hExact : algebraicClosure C N = (⊥ : IntermediateField C N)) : + letI := exactConstantExtensionField C N S hExact + letI := exactConstantExtensionBaseAlgebra C L N S + FiniteDimensional L (ExactConstantExtension C N S) := by + let := exactConstantExtensionField C N S hExact + let := exactConstantExtensionBaseAlgebra C L N S + let := exactConstantExtensionAlgebra C N S + let := exactConstantExtensionBaseTower C L N S + let e := exactConstantExtensionLinearEquiv C N S + let : Module.Finite N (N ⊗[C] S) := Module.Finite.base_change C N S + let : Module.Finite N (ExactConstantExtension C N S) := Module.Finite.equiv e + let : Module.Finite L (ExactConstantExtension C N S) := + Module.Finite.trans N (ExactConstantExtension C N S) + infer_instance + +omit [FiniteDimensional C S] [FiniteDimensional L N] [IsGalois L N] in +/-- Every Frobenius twist has order `[S : C]` when the order of the original +function-field Galois group divides `[S : C]`. -/ +theorem orderOf_exactConstantExtensionFrobeniusTwist + (hExact : algebraicClosure C N = (⊥ : IntermediateField C N)) + (g : N ≃ₐ[L] N) + (hdiv : Nat.card (N ≃ₐ[L] N) ∣ Module.finrank C S) : + letI := exactConstantExtensionField C N S hExact + letI := exactConstantExtensionBaseAlgebra C L N S + orderOf (exactConstantExtensionFrobeniusTwist C L N S hExact g) = + Module.finrank C S := by + let := exactConstantExtensionField C N S hExact + let := exactConstantExtensionBaseAlgebra C L N S + change orderOf (exactConstantExtensionCombinedAutHom C L N S + (FiniteField.frobeniusAlgEquivOfAlgebraic C S, g)) = _ + rw [orderOf_injective (exactConstantExtensionCombinedAutHom C L N S) + (exactConstantExtensionCombinedAutHom_injective C L N S)] + rw [orderOf_prod_eq_left_of_natCard_dvd] + · exact FiniteField.orderOf_frobeniusAlgEquivOfAlgebraic C S + · rwa [FiniteField.orderOf_frobeniusAlgEquivOfAlgebraic C S] + +omit [FiniteDimensional C S] [FiniteDimensional L N] [IsGalois L N] in +/-- The cyclic subgroup generated by a Frobenius twist has cardinality +`[S : C]`. -/ +theorem natCard_exactConstantExtensionFrobeniusTwistSubgroup + (hExact : algebraicClosure C N = (⊥ : IntermediateField C N)) + (g : N ≃ₐ[L] N) + (hdiv : Nat.card (N ≃ₐ[L] N) ∣ Module.finrank C S) : + letI := exactConstantExtensionField C N S hExact + letI := exactConstantExtensionBaseAlgebra C L N S + Nat.card + (exactConstantExtensionFrobeniusTwistSubgroup C L N S hExact g) = + Module.finrank C S := by + let := exactConstantExtensionField C N S hExact + let := exactConstantExtensionBaseAlgebra C L N S + rw [show exactConstantExtensionFrobeniusTwistSubgroup C L N S hExact g = + Subgroup.zpowers + (exactConstantExtensionFrobeniusTwist C L N S hExact g) by rfl, + Nat.card_zpowers, + orderOf_exactConstantExtensionFrobeniusTwist C L N S hExact g hdiv] + +/-- The twist subgroup meets the kernel of restriction to the enlarged +constants trivially. -/ +theorem exactConstantExtensionFrobeniusTwistSubgroup_inf_quotientKer + (hExact : algebraicClosure C N = (⊥ : IntermediateField C N)) + (g : N ≃ₐ[L] N) + (hdiv : Nat.card (N ≃ₐ[L] N) ∣ Module.finrank C S) : + letI := exactConstantExtensionField C N S hExact + letI := exactConstantExtensionBaseAlgebra C L N S + exactConstantExtensionFrobeniusTwistSubgroup C L N S hExact g ⊓ + (exactConstantExtensionConstantQuotient C L N S hExact).ker = ⊥ := by + let := exactConstantExtensionField C N S hExact + let := exactConstantExtensionBaseAlgebra C L N S + apply le_antisymm + · intro x hx + rw [Subgroup.mem_bot] + obtain ⟨k, hk⟩ := Subgroup.mem_zpowers_iff.mp hx.1 + rw [show exactConstantExtensionFrobeniusTwistSubgroup C L N S hExact g = + Subgroup.zpowers + (exactConstantExtensionFrobeniusTwist C L N S hExact g) by rfl] at hx + rw [← hk] + have hFrob : + (FiniteField.frobeniusAlgEquivOfAlgebraic C S) ^ k = 1 := by + have hker := MonoidHom.mem_ker.mp hx.2 + rw [← hk, map_zpow] at hker + simpa [exactConstantExtensionFrobeniusTwist, + exactConstantExtensionConstantQuotient_combined] using hker + have hkdiv : (Module.finrank C S : ℤ) ∣ k := by + rw [← FiniteField.orderOf_frobeniusAlgEquivOfAlgebraic C S] + exact orderOf_dvd_iff_zpow_eq_one.mpr hFrob + rw [← orderOf_dvd_iff_zpow_eq_one, + orderOf_exactConstantExtensionFrobeniusTwist C L N S hExact g hdiv] + exact hkdiv + · exact bot_le + +/-- Equivalently, the twist subgroup meets the embedded original +function-field Galois group trivially. -/ +theorem exactConstantExtensionFrobeniusTwistSubgroup_inf_functionRange + (hExact : algebraicClosure C N = (⊥ : IntermediateField C N)) + (g : N ≃ₐ[L] N) + (hdiv : Nat.card (N ≃ₐ[L] N) ∣ Module.finrank C S) : + letI := exactConstantExtensionField C N S hExact + letI := exactConstantExtensionBaseAlgebra C L N S + exactConstantExtensionFrobeniusTwistSubgroup C L N S hExact g ⊓ + (exactConstantExtensionFunctionAutHom C L N S).range = ⊥ := by + let := exactConstantExtensionField C N S hExact + let := exactConstantExtensionBaseAlgebra C L N S + rw [← exactConstantExtensionConstantQuotient_ker C L N S hExact] + exact exactConstantExtensionFrobeniusTwistSubgroup_inf_quotientKer + C L N S hExact g hdiv + +/-- A twist field and the extended base generate the entire exact constant +extension. This is the fixed-field form of `T = T_g S` in Stichtenoth, +Proposition 5.2.8(b). -/ +theorem frobeniusTwistField_sup_extendedBaseField_eq_top + (hExact : algebraicClosure C N = (⊥ : IntermediateField C N)) + (g : N ≃ₐ[L] N) + (hdiv : Nat.card (N ≃ₐ[L] N) ∣ Module.finrank C S) : + letI := exactConstantExtensionField C N S hExact + letI := exactConstantExtensionBaseAlgebra C L N S + exactConstantExtensionFrobeniusTwistField C L N S hExact g ⊔ + exactConstantExtensionExtendedBaseField C L N S hExact = ⊤ := by + let := exactConstantExtensionField C N S hExact + let := exactConstantExtensionBaseAlgebra C L N S + let : FiniteDimensional L (ExactConstantExtension C N S) := + finiteDimensional_exactConstantExtension_over_base C L N S hExact + let : IsGalois L (ExactConstantExtension C N S) := + exactConstantExtension_isGalois C L N S hExact + let F := exactConstantExtensionFrobeniusTwistField C L N S hExact g + let B := exactConstantExtensionExtendedBaseField C L N S hExact + have hfix : (F ⊔ B).fixingSubgroup = ⊥ := by + rw [IntermediateField.fixingSubgroup_sup] + change + (IntermediateField.fixedField + (exactConstantExtensionFrobeniusTwistSubgroup + C L N S hExact g)).fixingSubgroup ⊓ + (IntermediateField.fixedField + (exactConstantExtensionConstantQuotient + C L N S hExact).ker).fixingSubgroup = ⊥ + rw [IntermediateField.fixingSubgroup_fixedField, + IntermediateField.fixingSubgroup_fixedField] + exact exactConstantExtensionFrobeniusTwistSubgroup_inf_quotientKer + C L N S hExact g hdiv + calc + F ⊔ B = IntermediateField.fixedField (F ⊔ B).fixingSubgroup := + (IsGalois.fixedField_fixingSubgroup (F ⊔ B)).symm + _ = IntermediateField.fixedField (⊥ : Subgroup + (ExactConstantExtension C N S ≃ₐ[L] + ExactConstantExtension C N S)) := by rw [hfix] + _ = ⊤ := IntermediateField.fixedField_bot + +omit [IsGalois L N] in +/-- The exact constant extension has degree `[S : C]` over the Frobenius +twist field. -/ +theorem finrank_exactConstantExtension_over_frobeniusTwistField + (hExact : algebraicClosure C N = (⊥ : IntermediateField C N)) + (g : N ≃ₐ[L] N) + (hdiv : Nat.card (N ≃ₐ[L] N) ∣ Module.finrank C S) : + letI := exactConstantExtensionField C N S hExact + letI := exactConstantExtensionBaseAlgebra C L N S + Module.finrank + (exactConstantExtensionFrobeniusTwistField C L N S hExact g) + (ExactConstantExtension C N S) = Module.finrank C S := by + let := exactConstantExtensionField C N S hExact + let := exactConstantExtensionBaseAlgebra C L N S + let : FiniteDimensional L (ExactConstantExtension C N S) := + finiteDimensional_exactConstantExtension_over_base C L N S hExact + rw [show exactConstantExtensionFrobeniusTwistField C L N S hExact g = + IntermediateField.fixedField + (exactConstantExtensionFrobeniusTwistSubgroup C L N S hExact g) by + rfl, + IntermediateField.finrank_fixedField_eq_card, + natCard_exactConstantExtensionFrobeniusTwistSubgroup + C L N S hExact g hdiv] + +omit [IsGalois L N] [Finite S] in +/-- The exact constant extension is finite-dimensional over every Frobenius +twist field. -/ +theorem finiteDimensional_exactConstantExtension_over_frobeniusTwistField + (hExact : algebraicClosure C N = (⊥ : IntermediateField C N)) + (g : N ≃ₐ[L] N) : + letI := exactConstantExtensionField C N S hExact + letI := exactConstantExtensionBaseAlgebra C L N S + FiniteDimensional + (exactConstantExtensionFrobeniusTwistField C L N S hExact g) + (ExactConstantExtension C N S) := by + let := exactConstantExtensionField C N S hExact + let := exactConstantExtensionBaseAlgebra C L N S + let : FiniteDimensional L (ExactConstantExtension C N S) := + finiteDimensional_exactConstantExtension_over_base C L N S hExact + infer_instance + +omit [IsGalois L N] [Finite S] in +/-- The exact constant extension is Galois over every Frobenius twist field. +This only uses the general theorem that a field is Galois over the fixed +field of a finite group action. -/ +theorem isGalois_exactConstantExtension_over_frobeniusTwistField + (hExact : algebraicClosure C N = (⊥ : IntermediateField C N)) + (g : N ≃ₐ[L] N) : + letI := exactConstantExtensionField C N S hExact + letI := exactConstantExtensionBaseAlgebra C L N S + IsGalois + (exactConstantExtensionFrobeniusTwistField C L N S hExact g) + (ExactConstantExtension C N S) := by + let := exactConstantExtensionField C N S hExact + let := exactConstantExtensionBaseAlgebra C L N S + let : FiniteDimensional L (ExactConstantExtension C N S) := + finiteDimensional_exactConstantExtension_over_base C L N S hExact + let H := exactConstantExtensionFrobeniusTwistSubgroup C L N S hExact g + change IsGalois (IntermediateField.fixedField H) + (ExactConstantExtension C N S) + exact IsGalois.of_fixed_field (ExactConstantExtension C N S) H + +omit [IsGalois L N] in +/-- Every Frobenius twist field has the same degree over `L` as the original +function field `N`. -/ +theorem finrank_frobeniusTwistField_over_base + (hExact : algebraicClosure C N = (⊥ : IntermediateField C N)) + (g : N ≃ₐ[L] N) + (hdiv : Nat.card (N ≃ₐ[L] N) ∣ Module.finrank C S) : + letI := exactConstantExtensionField C N S hExact + letI := exactConstantExtensionBaseAlgebra C L N S + Module.finrank L + (exactConstantExtensionFrobeniusTwistField C L N S hExact g) = + Module.finrank L N := by + let := exactConstantExtensionField C N S hExact + let := exactConstantExtensionBaseAlgebra C L N S + let : FiniteDimensional L (ExactConstantExtension C N S) := + finiteDimensional_exactConstantExtension_over_base C L N S hExact + let F := exactConstantExtensionFrobeniusTwistField C L N S hExact g + have hmul := Module.finrank_mul_finrank L F + (ExactConstantExtension C N S) + rw [finrank_exactConstantExtension_over_frobeniusTwistField + C L N S hExact g hdiv, + exactConstantExtension_finrank_over_base C L N S] at hmul + exact Nat.mul_right_cancel (Module.finrank_pos (R := C) (M := S)) hmul + +omit [IsGalois L N] in +/-- The Galois group over a Frobenius twist field has cardinality `[S : C]`. -/ +theorem natCard_aut_exactConstantExtension_over_frobeniusTwistField + (hExact : algebraicClosure C N = (⊥ : IntermediateField C N)) + (g : N ≃ₐ[L] N) + (hdiv : Nat.card (N ≃ₐ[L] N) ∣ Module.finrank C S) : + letI := exactConstantExtensionField C N S hExact + letI := exactConstantExtensionBaseAlgebra C L N S + Nat.card + (ExactConstantExtension C N S ≃ₐ[ + exactConstantExtensionFrobeniusTwistField C L N S hExact g] + ExactConstantExtension C N S) = Module.finrank C S := by + let := exactConstantExtensionField C N S hExact + let := exactConstantExtensionBaseAlgebra C L N S + let : FiniteDimensional L (ExactConstantExtension C N S) := + finiteDimensional_exactConstantExtension_over_base C L N S hExact + let : IsGalois + (exactConstantExtensionFrobeniusTwistField C L N S hExact g) + (ExactConstantExtension C N S) := + isGalois_exactConstantExtension_over_frobeniusTwistField + C L N S hExact g + rw [IsGalois.card_aut_eq_finrank, + finrank_exactConstantExtension_over_frobeniusTwistField + C L N S hExact g hdiv] + +end FiniteConstants + +end + + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionFrobeniusTwistBoundedError.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionFrobeniusTwistBoundedError.lean new file mode 100644 index 0000000000..0486c27356 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionFrobeniusTwistBoundedError.lean @@ -0,0 +1,83 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionFrobeniusTwistRationalPlaceAverage + +/-! +# Two-sided Frobenius-twist errors from the bounded average + +The exact average of the infinity-place contributions is not needed to obtain +a two-sided estimate for an individual Frobenius twist. The already-proved +bounded aggregate error, together with a common one-sided Stepanov bound for +all twists, suffices by finite averaging. + +This is the direct function-field specialization of +`abs_le_of_uniform_upper_and_abs_sum_le`. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +noncomputable section + +open BGS.CorvajaZannier +open scoped BigOperators + +variable (C S N : Type*) [Field C] [Field S] [Field N] + [Fintype C] [Finite S] + [DecidableEq C] [DecidableEq S] + [DecidableEq (RatFunc C)] [DecidableEq (RatFunc S)] + [Algebra (RatFunc C) N] [FiniteDimensional (RatFunc C) N] + [IsGalois (RatFunc C) N] + [Algebra C S] [FiniteDimensional C S] [IsGalois C S] + +local instance boundedErrorBaseConstantAlgebra : Algebra C N := + bridgeBaseConstantAlgebra C N + +local instance boundedErrorBaseConstantTower : + IsScalarTower C (RatFunc C) N := + IsScalarTower.of_algebraMap_eq' rfl + +/-- A common upper bound for all Frobenius-twist point-count errors gives a +two-sided bound for every twist. The additive term is uniform in the +auxiliary constant extension `S`: it depends only on the original Galois +group and the degree of `N / C(X)`. + +Consequently, the exact infinity-place average is not a prerequisite for the +two-sided estimate used in a Hasse--Weil argument. -/ +theorem abs_frobeniusTwistFieldRationalPlaceError_le_of_uniform_upper + (hExact : algebraicClosure C N = + (⊥ : IntermediateField C N)) + (hdiv : Nat.card (N ≃ₐ[RatFunc C] N) ∣ Module.finrank C S) + (g : N ≃ₐ[RatFunc C] N) (B : ℝ) + (hB : 0 ≤ B) + (hupper : ∀ τ : N ≃ₐ[RatFunc C] N, + (frobeniusTwistFieldRationalPlaceCount C S N hExact τ : ℝ) - + (Nat.card C : ℝ) - 1 ≤ B) : + |(frobeniusTwistFieldRationalPlaceCount C S N hExact g : ℝ) - + (Nat.card C : ℝ) - 1| ≤ + (Nat.card (N ≃ₐ[RatFunc C] N) : ℝ) * + Module.finrank (RatFunc C) N + + (Nat.card (N ≃ₐ[RatFunc C] N) - 1 : ℕ) * B := by + classical + have hsum := abs_sum_frobeniusTwistFieldRationalPlaceError_le + C S N hExact hdiv + have hbound := abs_le_of_uniform_upper_and_abs_sum_le + (fun τ : N ≃ₐ[RatFunc C] N ↦ + (frobeniusTwistFieldRationalPlaceCount C S N hExact τ : ℝ) - + (Nat.card C : ℝ) - 1) + g + ((Nat.card (N ≃ₐ[RatFunc C] N) : ℝ) * + Module.finrank (RatFunc C) N) + B hB hupper hsum + simpa only [Nat.card_eq_fintype_card] using hbound + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionFrobeniusTwistConstants.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionFrobeniusTwistConstants.lean new file mode 100644 index 0000000000..eb0a304d66 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionFrobeniusTwistConstants.lean @@ -0,0 +1,137 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionConstants +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionFrobeniusTwist + +/-! +# Exact constants of Frobenius-twist fields + +Let `T = S ⊗[C] N` be an exact finite constant extension and let `F_g` +be the fixed field of the cyclic group generated by `(Frob, g)`. This file +proves that `C` is the exact constant field of every `F_g`. + +Indeed, an element of `F_g` algebraic over `C` is algebraic over `S` in `T`, +so exactness of the constants of `T` puts it in the embedded copy of `S`. +Since the element is fixed by `(Frob, g)`, its representative in `S` is fixed +by Frobenius and hence belongs to `C`. + +The order calculation for `(Frob, g)` is not needed for this descent, so the +result is stronger than the version with the usual divisibility hypothesis. +-/ + +@[expose] public section + +open scoped Polynomial TensorProduct + +namespace BGS.HasseWeil + +noncomputable section + + +variable (C L N S : Type*) [Field C] [Field L] [Field N] [Field S] + [Algebra C L] [Algebra L N] [Algebra C N] [IsScalarTower C L N] + [Algebra C S] [FiniteDimensional C S] [IsGalois C S] + [FiniteDimensional L N] [IsGalois L N] + [Fintype C] [Finite S] + +omit [FiniteDimensional L N] [IsGalois L N] in +/-- Every Frobenius-twist fixed field has exact constant field `C`. + +No divisibility condition on the order of `Gal(N/L)` is required: only the +restriction of the twist generator to `S`, which is the `C`-Frobenius, enters +the proof. -/ +theorem exactConstantExtensionFrobeniusTwistField_algebraicClosure_eq_bot + (hExact : algebraicClosure C N = + (⊥ : IntermediateField C N)) + (g : N ≃ₐ[L] N) : + letI := exactConstantExtensionField C N S hExact + letI := exactConstantExtensionBaseAlgebra C L N S + let F := exactConstantExtensionFrobeniusTwistField C L N S hExact g + letI : Algebra C F := Algebra.restrictScalars C L F + algebraicClosure C F = (⊥ : IntermediateField C F) := by + let T := ExactConstantExtension C N S + let : Field T := exactConstantExtensionField C N S hExact + let : Algebra L T := exactConstantExtensionBaseAlgebra C L N S + let : Algebra C T := Algebra.restrictScalars C L T + let : SMul C T := Algebra.toSMul + let : IsScalarTower C L T := IsScalarTower.of_algebraMap_eq' rfl + let F := exactConstantExtensionFrobeniusTwistField C L N S hExact g + let : Algebra C F := Algebra.restrictScalars C L F + let : IsScalarTower C L F := IsScalarTower.of_algebraMap_eq' rfl + let : Algebra S T := Algebra.TensorProduct.leftAlgebra + let : SMul S T := Algebra.toSMul + have hCS : algebraMap C T = + (algebraMap S T).comp (algebraMap C S) := by + ext c + change (1 : S) ⊗ₜ algebraMap L N (algebraMap C L c) = + algebraMap C S c ⊗ₜ (1 : N) + rw [← IsScalarTower.algebraMap_apply C L N] + exact (Algebra.TensorProduct.tmul_one_eq_one_tmul c).symm + let : IsScalarTower C S T := IsScalarTower.of_algebraMap_eq' hCS + have hTopExact : algebraicClosure S T = + (⊥ : IntermediateField S T) := + exactConstantExtension_algebraicClosure_eq_bot C N S hExact + apply eq_bot_iff.mpr + intro z hz + have hzC : IsAlgebraic C z := mem_algebraicClosure_iff.mp hz + have hzCT : IsAlgebraic C (z : T) := by + exact IsAlgebraic.algHom (F.val.restrictScalars C) hzC + have hzST : IsAlgebraic S (z : T) := + IsAlgebraic.tower_top S hzCT + have hzBotS : (z : T) ∈ (⊥ : IntermediateField S T) := by + rw [← hTopExact] + exact mem_algebraicClosure_iff.mpr hzST + obtain ⟨s, hs⟩ := IntermediateField.mem_bot.mp hzBotS + let τ := exactConstantExtensionFrobeniusTwist C L N S hExact g + have hzFix : τ (z : T) = (z : T) := by + apply (IntermediateField.mem_fixedField_iff + (exactConstantExtensionFrobeniusTwistSubgroup C L N S hExact g) + (z : T)).mp z.property + exact Subgroup.mem_zpowers τ + have hsFix : FiniteField.frobeniusAlgEquivOfAlgebraic C S s = s := by + apply (algebraMap S T).injective + calc + algebraMap S T (FiniteField.frobeniusAlgEquivOfAlgebraic C S s) = + τ (algebraMap S T s) := by + change + (FiniteField.frobeniusAlgEquivOfAlgebraic C S s) ⊗ₜ (1 : N) = + τ (s ⊗ₜ (1 : N)) + simp [τ, exactConstantExtensionFrobeniusTwist, + exactConstantExtensionCombinedAutHom, + exactConstantExtensionConstantAutHom, + exactConstantExtensionFunctionAutHom, + exactConstantExtensionConstantAlgEquivOverBase, + exactConstantExtensionFunctionAlgEquivOverBase] + _ = τ (z : T) := congrArg τ hs + _ = (z : T) := hzFix + _ = algebraMap S T s := hs.symm + have hspow : s ^ Fintype.card C = s := by + simpa [FiniteField.coe_frobeniusAlgEquivOfAlgebraic] using hsFix + let p : C[X] := Polynomial.X ^ Fintype.card C - Polynomial.X + have hpSplit : p.Splits := by + dsimp [p] + simpa [Nat.card_eq_fintype_card] using + (Polynomial.splits_X_pow_nat_card_sub_X (K := C)) + have hp0 : p ≠ 0 := by + dsimp [p] + exact FiniteField.X_pow_card_sub_X_ne_zero C Fintype.one_lt_card + have hroot : (p.map (algebraMap C S)).IsRoot s := by + simp [p, hspow] + obtain ⟨c, hc⟩ := hpSplit.mem_range_of_isRoot hp0 hroot + apply IntermediateField.mem_bot.mpr + refine ⟨c, ?_⟩ + apply Subtype.ext + change algebraMap C T c = (z : T) + rw [hCS] + change algebraMap S T (algebraMap C S c) = (z : T) + rw [hc, hs] + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionFrobeniusTwistDegree.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionFrobeniusTwistDegree.lean new file mode 100644 index 0000000000..61f4914469 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionFrobeniusTwistDegree.lean @@ -0,0 +1,86 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionFrobeniusTwistRiemannLower +public import LeanPool.MarkoffModP.BGS.HasseWeil.GeneralSquareFieldStepanovCount + +/-! +# Degrees of exact-constant Frobenius twists + +For an exact constant extension `S \otimes[C] N`, every Frobenius-twist +fixed field has the same degree over `C(X)` as the original function field +`N`. This file records the rational-function specialization used by the +Hasse--Weil averaging argument and combines it with the general bound on +rational places above infinity. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +noncomputable section + +variable (C N S : Type*) [Field C] [Fintype C] [DecidableEq C] + [DecidableEq (RatFunc C)] + [Field N] [Algebra (RatFunc C) N] [Algebra C N] + [IsScalarTower C (RatFunc C) N] + [FiniteDimensional (RatFunc C) N] + [Algebra.IsSeparable (RatFunc C) N] + [Field S] [Algebra C S] [FiniteDimensional C S] [IsGalois C S] + [Finite S] + +omit [DecidableEq C] [DecidableEq (RatFunc C)] + [Algebra.IsSeparable (RatFunc C) N] in +/-- A Frobenius-twist fixed field has the same `C(X)`-degree as the original +function field. -/ +theorem finrank_frobeniusTwistField_over_ratFunc_eq_original + (hExact : algebraicClosure C N = + (⊥ : IntermediateField C N)) + (g : N ≃ₐ[RatFunc C] N) + (hdiv : Nat.card (N ≃ₐ[RatFunc C] N) ∣ Module.finrank C S) : + letI := exactConstantExtensionField C N S hExact + letI := exactConstantExtensionBaseAlgebra C (RatFunc C) N S + Module.finrank (RatFunc C) + (exactConstantExtensionFrobeniusTwistField + C (RatFunc C) N S hExact g) = + Module.finrank (RatFunc C) N := by + exact finrank_frobeniusTwistField_over_base + C (RatFunc C) N S hExact g hdiv + +/-- The number of rational infinity places on a Frobenius-twist fixed field +is bounded uniformly by the degree of the original function field. -/ +theorem rationalInfinityPlace_card_frobeniusTwistField_le_original_finrank + (hExact : algebraicClosure C N = + (⊥ : IntermediateField C N)) + (g : N ≃ₐ[RatFunc C] N) + (hdiv : Nat.card (N ≃ₐ[RatFunc C] N) ∣ Module.finrank C S) : + letI := exactConstantExtensionField C N S hExact + letI := exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let F := exactConstantExtensionFrobeniusTwistField + C (RatFunc C) N S hExact g + Nat.card (FiniteExtensionRationalInfinityPlace C F) ≤ + Module.finrank (RatFunc C) N := by + let := exactConstantExtensionField C N S hExact + let := exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let F := exactConstantExtensionFrobeniusTwistField + C (RatFunc C) N S hExact g + let : FiniteDimensional (RatFunc C) F := + finiteDimensional_frobeniusTwistField_over_ratFunc C N S hExact g + let : Algebra.IsSeparable (RatFunc C) F := + isSeparable_frobeniusTwistField_over_ratFunc C N S hExact g + calc + Nat.card (FiniteExtensionRationalInfinityPlace C F) ≤ + Module.finrank (RatFunc C) F := + rationalInfinityPlace_card_le_finrank C F + _ = Module.finrank (RatFunc C) N := + finrank_frobeniusTwistField_over_ratFunc_eq_original + C N S hExact g hdiv + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionFrobeniusTwistFinitePlaceAverage.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionFrobeniusTwistFinitePlaceAverage.lean new file mode 100644 index 0000000000..e21511acde --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionFrobeniusTwistFinitePlaceAverage.lean @@ -0,0 +1,839 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.ConstantExtensionPlaceSplittingMultiplicity +public import LeanPool.MarkoffModP.BGS.HasseWeil.ConstantExtensionRationalPlace +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionFinitePlaceFrobeniusAverage +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionFrobeniusTwistFinitePlaceUnramified +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionCanonicalDifferentCotrace +public import LeanPool.MarkoffModP.BGS.HasseWeil.OnePointLeadingCoefficient +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneRationalPlaceAffineComparison +public import LeanPool.MarkoffModP.BGS.HasseWeil.RationalPlaceTower + +/-! +# Global finite-place averaging for Frobenius twists + +This file removes the presentation choice from the local Frobenius-coset +fixed-point identity and assembles the rational finite places of all +Frobenius-twist fields without duplication. +-/ + +@[expose] public section + +open scoped Polynomial TensorProduct BigOperators + +namespace BGS.HasseWeil + +noncomputable section + +open BGS.CorvajaZannier + + +/-- Restricting a finite place first to an intermediate function field and +then to `K(X)` agrees with direct restriction to `K(X)`. This is the +finite-extension-place version of `Ideal.under_under`; unlike the raw chart +statement `finitePlaceUnder_under`, both sides live in the normalized +finite-place model of `K(X)`. -/ +theorem finitePlaceUnder_ratFunc_under + (K M L : Type*) [Field K] [Field M] [Field L] + [DecidableEq K] [DecidableEq (RatFunc K)] + [Algebra (RatFunc K) M] [FiniteDimensional (RatFunc K) M] + [Algebra.IsSeparable (RatFunc K) M] + [Algebra (RatFunc K) L] [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + [Algebra M L] [IsScalarTower (RatFunc K) M L] + (Q : FiniteExtensionFinitePlace K L) : + finitePlaceUnder K (RatFunc K) M (finitePlaceUnder K M L Q) = + finitePlaceUnder K (RatFunc K) L Q := by + let : Algebra (RatFuncFiniteIntegralClosure K (RatFunc K)) + (RatFuncFiniteIntegralClosure K M) := + (finiteIntegralClosureMap K (RatFunc K) M).toAlgebra + let : Algebra (RatFuncFiniteIntegralClosure K M) + (RatFuncFiniteIntegralClosure K L) := + (finiteIntegralClosureMap K M L).toAlgebra + let : Algebra (RatFuncFiniteIntegralClosure K (RatFunc K)) + (RatFuncFiniteIntegralClosure K L) := + (finiteIntegralClosureMap K (RatFunc K) L).toAlgebra + let : SMul (RatFuncFiniteIntegralClosure K (RatFunc K)) + (RatFuncFiniteIntegralClosure K M) := Algebra.toSMul + let : SMul (RatFuncFiniteIntegralClosure K M) + (RatFuncFiniteIntegralClosure K L) := Algebra.toSMul + let : SMul (RatFuncFiniteIntegralClosure K (RatFunc K)) + (RatFuncFiniteIntegralClosure K L) := Algebra.toSMul + let : IsScalarTower (RatFuncFiniteIntegralClosure K (RatFunc K)) + (RatFuncFiniteIntegralClosure K M) + (RatFuncFiniteIntegralClosure K L) := + IsScalarTower.of_algebraMap_eq fun x => by + apply Subtype.ext + change algebraMap (RatFunc K) L x.1 = + algebraMap M L (algebraMap (RatFunc K) M x.1) + exact IsScalarTower.algebraMap_apply (RatFunc K) M L x.1 + apply IsDedekindDomain.HeightOneSpectrum.ext + exact Ideal.under_under Q.asIdeal + +variable (C S N : Type*) [Field C] [Field S] [Field N] + [Fintype C] [Finite S] + [DecidableEq C] [DecidableEq S] + [DecidableEq (RatFunc C)] [DecidableEq (RatFunc S)] + [Algebra (RatFunc C) N] [FiniteDimensional (RatFunc C) N] + [IsGalois (RatFunc C) N] + [Algebra C S] [FiniteDimensional C S] [IsGalois C S] + +local instance finiteAverageRatFuncRationalFinitePlaceFintype : + Fintype (RatFuncRationalFinitePlace C) := Fintype.ofFinite _ + +local instance finiteAverageBaseConstantAlgebra : Algebra C N := + bridgeBaseConstantAlgebra C N + +local instance finiteAverageBaseConstantTower : + IsScalarTower C (RatFunc C) N := + IsScalarTower.of_algebraMap_eq' rfl + +local instance finiteAverageTargetPolynomialAlgebra : + Algebra S[X] (ExactConstantExtension C N S) := + bridgeTargetPolynomialAlgebra C S N + +local instance finiteAverageRatFuncClosureConstantAlgebra : + Algebra C (RatFuncFiniteIntegralClosure C (RatFunc C)) := + RingHom.toAlgebra + ((algebraMap C[X] (RatFuncFiniteIntegralClosure C (RatFunc C))).comp + (algebraMap C C[X])) + +local instance finiteAverageRatFuncClosureConstantTower : + IsScalarTower C C[X] + (RatFuncFiniteIntegralClosure C (RatFunc C)) := + IsScalarTower.of_algebraMap_eq' rfl + +/-- The chart-normalization equivalence over the polynomial base ring. -/ +noncomputable def ratFuncFiniteBasePolynomialAlgEquivChart : + C[X] ≃ₐ[C[X]] RatFuncFiniteIntegralClosure C (RatFunc C) := + { ratFuncFiniteBaseRingEquivChart C with + commutes' := fun r => by + apply Subtype.ext + change algebraMap (FunctionField.ringOfIntegers C (RatFunc C)) + (RatFunc C) + (ratFuncFiniteBaseRingEquivChart C r) = + algebraMap (FunctionField.ringOfIntegers C (RatFunc C)) + (RatFunc C) + (algebraMap C[X] (FunctionField.ringOfIntegers C (RatFunc C)) r) + rw [ratFuncFiniteBaseRingEquivChart_algebraMap] + rfl } + +/-- The same equivalence over the constant field. -/ +noncomputable def ratFuncFiniteBaseAlgEquivChart : + C[X] ≃ₐ[C] RatFuncFiniteIntegralClosure C (RatFunc C) := + (ratFuncFiniteBasePolynomialAlgEquivChart C).restrictScalars C + +local instance finiteAverageRatFuncClosureModuleFinite : + Module.Finite C[X] (RatFuncFiniteIntegralClosure C (RatFunc C)) := + Module.Finite.equiv + (ratFuncFiniteBasePolynomialAlgEquivChart C).toLinearEquiv + +/-- The finite-chart normalization of `C[X]` in `C(X)` is canonically +equivalent to `C[X]` itself, hence their finite-place models agree. -/ +noncomputable def ratFuncFinitePlaceEquivFiniteExtension : + IsDedekindDomain.HeightOneSpectrum C[X] ≃ + FiniteExtensionFinitePlace C (RatFunc C) := + heightOneSpectrumEquivOfAlgEquiv + (ratFuncFiniteBasePolynomialAlgEquivChart C) + +private theorem finrank_mul_finrank_of_fields + (K F E : Type*) [Field K] [Field F] [Field E] + [Algebra K F] [Algebra K E] [Algebra F E] [IsScalarTower K F E] : + Module.finrank K F * Module.finrank F E = Module.finrank K E := + Module.finrank_mul_finrank K F E + +omit [Fintype C] in +/-- A finite-place degree is the dimension of its residue field over the +constant field. -/ +private theorem finiteExtensionPlaceDegree_inl_eq_finrank_residueField_ratFunc + (Q : FiniteExtensionFinitePlace C (RatFunc C)) : + finiteExtensionPlaceDegree C (RatFunc C) (.inl Q) = + Module.finrank C Q.asIdeal.ResidueField := by + let P := IsDedekindDomain.HeightOneSpectrum.under C[X] Q + let : Q.asIdeal.LiesOver P.asIdeal := ⟨rfl⟩ + let hLocalAlg := + Localization.AtPrime.algebraOfLiesOver P.asIdeal Q.asIdeal + let : IsScalarTower C[X] (Localization.AtPrime P.asIdeal) + (Localization.AtPrime Q.asIdeal) := inferInstance + rw [finiteExtensionPlaceDegree, Ideal.inertiaDeg_eq P.asIdeal Q.asIdeal] + rw [ratFuncFinitePlaceDegree_eq_finrank_residueField C P] + rw [mul_comm, finrank_mul_finrank_of_fields] + +/-- The chart-normalization equivalence preserves finite-place degree. -/ +@[simp] +theorem finiteExtensionPlaceDegree_ratFuncFinitePlaceEquivFiniteExtension + (P : IsDedekindDomain.HeightOneSpectrum C[X]) : + finiteExtensionPlaceDegree C (RatFunc C) + (.inl (ratFuncFinitePlaceEquivFiniteExtension C P)) = + ratFuncFinitePlaceDegree P := by + let Q := ratFuncFinitePlaceEquivFiniteExtension C P + have hres := heightOneSpectrum_residueField_finrank_eq + (ratFuncFiniteBaseAlgEquivChart C) P + calc + finiteExtensionPlaceDegree C (RatFunc C) (.inl Q) = + Module.finrank C Q.asIdeal.ResidueField := + finiteExtensionPlaceDegree_inl_eq_finrank_residueField_ratFunc C Q + _ = Module.finrank C P.asIdeal.ResidueField := hres.symm + _ = ratFuncFinitePlaceDegree P := + (ratFuncFinitePlaceDegree_eq_finrank_residueField C P).symm + +/-- Degree-one finite places in the direct `C[X]` chart and in the generic +finite-extension place model of `C(X)` are canonically equivalent. -/ +noncomputable def ratFuncRationalFinitePlaceEquivFiniteExtension : + RatFuncRationalFinitePlace C ≃ + FiniteExtensionRationalFinitePlace C (RatFunc C) := + Equiv.subtypeEquiv (ratFuncFinitePlaceEquivFiniteExtension C) (by + intro P + rw [finiteExtensionPlaceDegree_ratFuncFinitePlaceEquivFiniteExtension]) + +variable (hExact : algebraicClosure C N = + (⊥ : IntermediateField C N)) + +omit [DecidableEq (RatFunc S)] in +/-- Choose the explicit `S[X]` presentation of an actual top finite place, +while transporting rationality of its restriction to the downstairs place. +This is the only point where the nested integral-closure contraction tower is +expanded in this file. -/ +private theorem exists_presentedFinitePlace_of_under_rational : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + letI : SMul (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toSMul + letI : Module (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toModule + letI : DistribMulAction (RatFunc C) + (ExactConstantExtension C N S) := Module.toDistribMulAction + letI : MulAction (RatFunc C) (ExactConstantExtension C N S) := + DistribMulAction.toMulAction + letI : FiniteDimensional (RatFunc C) + (ExactConstantExtension C N S) := + finiteDimensional_exactConstantExtension_over_baseRatFunc C S N hExact + letI : Algebra.IsSeparable (RatFunc C) + (ExactConstantExtension C N S) := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + ∀ Q : FiniteExtensionFinitePlace C (ExactConstantExtension C N S), + finiteExtensionPlaceDegree C (RatFunc C) + (.inl (finitePlaceUnder C (RatFunc C) + (ExactConstantExtension C N S) Q)) = 1 → + ∃ q : IsDedekindDomain.HeightOneSpectrum + (integralClosure S[X] (ExactConstantExtension C N S)), + exactConstantExtensionCompatibleBaseFinitePlace C S N hExact q = Q ∧ + finiteExtensionPlaceDegree C (RatFunc C) + (.inl (finitePlaceUnder C (RatFunc C) N + (exactConstantExtensionDownstairsFinitePlace + C S N hExact q))) = 1 := by + let T := ExactConstantExtension C N S + let : Field T := exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) T := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : SMul (RatFunc C) T := Algebra.toSMul + let : Module (RatFunc C) T := Algebra.toModule + let : DistribMulAction (RatFunc C) T := Module.toDistribMulAction + let : MulAction (RatFunc C) T := DistribMulAction.toMulAction + let : FiniteDimensional (RatFunc C) T := + finiteDimensional_exactConstantExtension_over_baseRatFunc C S N hExact + let : Algebra.IsSeparable (RatFunc C) T := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + let : Algebra (RatFunc S) T := + ratFuncExactConstantExtensionAlgebra C S N hExact + let : Algebra N T := exactConstantExtensionAlgebra C N S + let : SMul N T := Algebra.toSMul + let : Module N T := Algebra.toModule + let : IsScalarTower (RatFunc C) N T := + exactConstantExtensionBaseTower C (RatFunc C) N S + intro Q hBase + let e := exactConstantExtensionPresentedFinitePlaceEquiv C S N hExact + let q := e.symm Q + have heq : exactConstantExtensionCompatibleBaseFinitePlace + C S N hExact q = Q := by + calc + exactConstantExtensionCompatibleBaseFinitePlace C S N hExact q = + e q := + (exactConstantExtensionPresentedFinitePlaceEquiv_apply + C S N hExact q).symm + _ = Q := e.apply_symm_apply Q + have hDownstairs : finitePlaceUnder C N T Q = + exactConstantExtensionDownstairsFinitePlace C S N hExact q := by + calc + finitePlaceUnder C N T Q = + finitePlaceUnder C N T + (exactConstantExtensionCompatibleBaseFinitePlace + C S N hExact q) := congrArg _ heq.symm + _ = exactConstantExtensionDownstairsFinitePlace C S N hExact q := + exactConstantExtensionCompatibleBaseFinitePlace_under_original + C S N hExact q + have hUnderTower : finitePlaceUnder C (RatFunc C) N + (finitePlaceUnder C N T Q) = + finitePlaceUnder C (RatFunc C) T Q := + finitePlaceUnder_ratFunc_under C N T Q + refine ⟨q, heq, ?_⟩ + rw [← hDownstairs, hUnderTower] + exact hBase + +/-- Every actual top finite place over a rational finite place of `C(X)` has +ambient degree `[S : C]`, provided the constant-extension degree is divisible +by the original Galois degree. -/ +theorem exactConstantExtensionFinitePlace_degree_eq_finrank_of_under_rational + (hDegreeDiv : Module.finrank (RatFunc C) N ∣ Module.finrank C S) : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + letI : SMul (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toSMul + letI : Module (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toModule + letI : DistribMulAction (RatFunc C) + (ExactConstantExtension C N S) := Module.toDistribMulAction + letI : MulAction (RatFunc C) (ExactConstantExtension C N S) := + DistribMulAction.toMulAction + letI : FiniteDimensional (RatFunc C) + (ExactConstantExtension C N S) := + finiteDimensional_exactConstantExtension_over_baseRatFunc C S N hExact + letI : Algebra.IsSeparable (RatFunc C) + (ExactConstantExtension C N S) := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + ∀ Q : FiniteExtensionFinitePlace C (ExactConstantExtension C N S), + finiteExtensionPlaceDegree C (RatFunc C) + (.inl (finitePlaceUnder C (RatFunc C) + (ExactConstantExtension C N S) Q)) = 1 → + finiteExtensionPlaceDegree C (ExactConstantExtension C N S) (.inl Q) = + Module.finrank C S := by + let T := ExactConstantExtension C N S + let : Field T := exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) T := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : SMul (RatFunc C) T := Algebra.toSMul + let : Module (RatFunc C) T := Algebra.toModule + let : DistribMulAction (RatFunc C) T := Module.toDistribMulAction + let : MulAction (RatFunc C) T := DistribMulAction.toMulAction + let : FiniteDimensional (RatFunc C) T := + finiteDimensional_exactConstantExtension_over_baseRatFunc C S N hExact + let : Algebra.IsSeparable (RatFunc C) T := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + let : Algebra (RatFunc S) T := + ratFuncExactConstantExtensionAlgebra C S N hExact + let : SMul (RatFunc S) T := Algebra.toSMul + let : Module (RatFunc S) T := Algebra.toModule + let : FiniteDimensional (RatFunc S) T := + finiteDimensional_over_extendedRatFunc C S N hExact + let : Algebra.IsSeparable (RatFunc S) T := + isSeparable_over_extendedRatFunc C S N hExact + let : Algebra N T := exactConstantExtensionAlgebra C N S + let : SMul N T := Algebra.toSMul + let : Module N T := Algebra.toModule + let : IsScalarTower (RatFunc C) N T := + exactConstantExtensionBaseTower C (RatFunc C) N S + intro Q hBase + obtain ⟨q, heq, hBaseQ⟩ := + exists_presentedFinitePlace_of_under_rational C S N hExact Q hBase + have hS : finiteExtensionPlaceDegree S T + (.inl (exactConstantExtensionUpstairsFinitePlace C S N hExact q)) = 1 := + exactConstantExtensionUpstairsFinitePlace_degree_eq_one_of_under_degree_one + C S N hExact q hBaseQ hDegreeDiv + have hDegree := exactConstantExtensionCompatibleBaseFinitePlace_degree_eq + C S N hExact q hS + rw [heq] at hDegree + exact hDegree + +/-- Presentation-free local Frobenius-coset identity above an arbitrary +rational finite base place. -/ +theorem exactConstantExtensionFinitePlace_frobeniusFiber_fixedPoint_sum_of_under_rational + (hDegreeDiv : Module.finrank (RatFunc C) N ∣ Module.finrank C S) : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + letI : SMul (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toSMul + letI : Module (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toModule + letI : DistribMulAction (RatFunc C) + (ExactConstantExtension C N S) := Module.toDistribMulAction + letI : MulAction (RatFunc C) (ExactConstantExtension C N S) := + DistribMulAction.toMulAction + letI : FiniteDimensional (RatFunc C) + (ExactConstantExtension C N S) := + finiteDimensional_exactConstantExtension_over_baseRatFunc C S N hExact + letI : Algebra.IsSeparable (RatFunc C) + (ExactConstantExtension C N S) := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + letI : IsGalois (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtension_isGalois C (RatFunc C) N S hExact + ∀ (Q : FiniteExtensionFinitePlace C (ExactConstantExtension C N S)), + finiteExtensionPlaceDegree C (RatFunc C) + (.inl (finitePlaceUnder C (RatFunc C) + (ExactConstantExtension C N S) Q)) = 1 → + let P := finitePlaceUnder C (RatFunc C) + (ExactConstantExtension C N S) Q + let pi := exactConstantExtensionConstantQuotient + C (RatFunc C) N S hExact + letI : DecidableEq (S ≃ₐ[C] S) := Classical.decEq _ + letI : Fintype + (ExactConstantExtension C N S ≃ₐ[RatFunc C] + ExactConstantExtension C N S) := Fintype.ofFinite _ + letI : Fintype (S ≃ₐ[C] S) := Fintype.ofFinite _ + letI : Fintype + (pi ⁻¹' ({FiniteField.frobeniusAlgEquivOfAlgebraic C S} : + Set (S ≃ₐ[C] S))) := Fintype.ofFinite _ + letI := finiteIntegralClosureGalAction C (RatFunc C) + (ExactConstantExtension C N S) + letI := finitePlaceUnderFiberGalAction C (RatFunc C) + (ExactConstantExtension C N S) P + (∑ g : pi ⁻¹' ({FiniteField.frobeniusAlgEquivOfAlgebraic C S} : + Set (S ≃ₐ[C] S)), + Nat.card (MulAction.fixedBy + (FinitePlaceUnderFiber C (RatFunc C) + (ExactConstantExtension C N S) P) g.1)) = + Nat.card (N ≃ₐ[RatFunc C] N) := by + let T := ExactConstantExtension C N S + let : Field T := exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) T := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : SMul (RatFunc C) T := Algebra.toSMul + let : Module (RatFunc C) T := Algebra.toModule + let : DistribMulAction (RatFunc C) T := Module.toDistribMulAction + let : MulAction (RatFunc C) T := DistribMulAction.toMulAction + let : FiniteDimensional (RatFunc C) T := + finiteDimensional_exactConstantExtension_over_baseRatFunc C S N hExact + let : Algebra.IsSeparable (RatFunc C) T := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + let : IsGalois (RatFunc C) T := + exactConstantExtension_isGalois C (RatFunc C) N S hExact + let : Algebra (RatFunc S) T := + ratFuncExactConstantExtensionAlgebra C S N hExact + let : Algebra N T := exactConstantExtensionAlgebra C N S + let : SMul N T := Algebra.toSMul + let : Module N T := Algebra.toModule + let : IsScalarTower (RatFunc C) N T := + exactConstantExtensionBaseTower C (RatFunc C) N S + intro Q hBase + obtain ⟨q, heq, hBaseQ⟩ := + exists_presentedFinitePlace_of_under_rational C S N hExact Q hBase + rw [← heq] + exact exactConstantExtensionFinitePlace_frobeniusFiber_fixedPoint_sum + C S N hExact (RatFunc C) q hBaseQ hDegreeDiv + +omit [Finite S] [DecidableEq C] [DecidableEq S] [DecidableEq (RatFunc C)] + [DecidableEq (RatFunc S)] in +/-- The Frobenius-fiber parametrization sends `g` to the ambient +Frobenius-twist automorphism `(Frob, g)`. -/ +@[simp] +theorem exactConstantExtensionFrobeniusFiberEquiv_apply_val + (g : N ≃ₐ[RatFunc C] N) : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + ((exactConstantExtensionFrobeniusFiberEquiv + C (RatFunc C) N S hExact) g).1 = + exactConstantExtensionFrobeniusTwist + C (RatFunc C) N S hExact g := by + let : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + rfl + +/-- Above one rational finite place of `C(X)`, summing fixed top places over +all canonical Frobenius twists contributes exactly `|Gal(N/C(X))|`. -/ +theorem sum_card_finitePlaceUnderFiber_fixedBy_frobeniusTwist_eq_card_galois + (hDegreeDiv : Module.finrank (RatFunc C) N ∣ Module.finrank C S) + (P : RatFuncRationalFinitePlace C) : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + letI : SMul (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toSMul + letI : Module (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toModule + letI : DistribMulAction (RatFunc C) + (ExactConstantExtension C N S) := Module.toDistribMulAction + letI : MulAction (RatFunc C) (ExactConstantExtension C N S) := + DistribMulAction.toMulAction + letI : FiniteDimensional (RatFunc C) + (ExactConstantExtension C N S) := + finiteDimensional_exactConstantExtension_over_baseRatFunc C S N hExact + letI : Algebra.IsSeparable (RatFunc C) + (ExactConstantExtension C N S) := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + letI : IsGalois (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtension_isGalois C (RatFunc C) N S hExact + let P₀ := ratFuncRationalFinitePlaceEquivFiniteExtension C P + letI := finiteIntegralClosureGalAction C (RatFunc C) + (ExactConstantExtension C N S) + letI := finitePlaceUnderFiberGalAction C (RatFunc C) + (ExactConstantExtension C N S) P₀.1 + (∑ g : N ≃ₐ[RatFunc C] N, + Nat.card (MulAction.fixedBy + (FinitePlaceUnderFiber C (RatFunc C) + (ExactConstantExtension C N S) P₀.1) + (exactConstantExtensionFrobeniusTwist + C (RatFunc C) N S hExact g))) = + Nat.card (N ≃ₐ[RatFunc C] N) := by + let T := ExactConstantExtension C N S + let : Field T := exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) T := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : SMul (RatFunc C) T := Algebra.toSMul + let : Module (RatFunc C) T := Algebra.toModule + let : DistribMulAction (RatFunc C) T := Module.toDistribMulAction + let : MulAction (RatFunc C) T := DistribMulAction.toMulAction + let : FiniteDimensional (RatFunc C) T := + finiteDimensional_exactConstantExtension_over_baseRatFunc C S N hExact + let : Algebra.IsSeparable (RatFunc C) T := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + let : IsGalois (RatFunc C) T := + exactConstantExtension_isGalois C (RatFunc C) N S hExact + let P₀ := ratFuncRationalFinitePlaceEquivFiniteExtension C P + let := finiteIntegralClosureGalAction C (RatFunc C) T + let := finitePlaceUnderFiberGalAction C (RatFunc C) T P₀.1 + let pi := exactConstantExtensionConstantQuotient + C (RatFunc C) N S hExact + let : DecidableEq (S ≃ₐ[C] S) := Classical.decEq _ + let : Fintype (T ≃ₐ[RatFunc C] T) := Fintype.ofFinite _ + let : Fintype (S ≃ₐ[C] S) := Fintype.ofFinite _ + let : Fintype + (pi ⁻¹' ({FiniteField.frobeniusAlgEquivOfAlgebraic C S} : + Set (S ≃ₐ[C] S))) := Fintype.ofFinite _ + obtain ⟨Q, hQ⟩ := finitePlaceUnder_surjective C (RatFunc C) T P₀.1 + have hBase : finiteExtensionPlaceDegree C (RatFunc C) + (.inl (finitePlaceUnder C (RatFunc C) T Q)) = 1 := by + rw [hQ] + exact P₀.2 + have hlocal := + exactConstantExtensionFinitePlace_frobeniusFiber_fixedPoint_sum_of_under_rational + C S N hExact hDegreeDiv Q hBase + rw [hQ] at hlocal + let e := exactConstantExtensionFrobeniusFiberEquiv + C (RatFunc C) N S hExact + calc + (∑ g : N ≃ₐ[RatFunc C] N, + Nat.card (MulAction.fixedBy + (FinitePlaceUnderFiber C (RatFunc C) T P₀.1) + (exactConstantExtensionFrobeniusTwist + C (RatFunc C) N S hExact g))) = + ∑ g : N ≃ₐ[RatFunc C] N, + Nat.card (MulAction.fixedBy + (FinitePlaceUnderFiber C (RatFunc C) T P₀.1) (e g).1) := by + apply Finset.sum_congr rfl + intro g _ + rw [exactConstantExtensionFrobeniusFiberEquiv_apply_val] + _ = ∑ x : pi ⁻¹' + ({FiniteField.frobeniusAlgEquivOfAlgebraic C S} : + Set (S ≃ₐ[C] S)), + Nat.card (MulAction.fixedBy + (FinitePlaceUnderFiber C (RatFunc C) T P₀.1) x.1) := + e.sum_comp (fun x => Nat.card (MulAction.fixedBy + (FinitePlaceUnderFiber C (RatFunc C) T P₀.1) x.1)) + _ = Nat.card (N ≃ₐ[RatFunc C] N) := hlocal + +/-- Fixed top finite places in the restriction fiber above one rational +finite place of `C(X)`, for one canonical Frobenius twist. -/ +abbrev FrobeniusTwistFinitePlaceFiberFixedBy + (hExact : algebraicClosure C N = (⊥ : IntermediateField C N)) + (g : N ≃ₐ[RatFunc C] N) (P : RatFuncRationalFinitePlace C) : + Type _ := + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + letI : SMul (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toSMul + letI : Module (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toModule + letI : DistribMulAction (RatFunc C) + (ExactConstantExtension C N S) := Module.toDistribMulAction + letI : MulAction (RatFunc C) (ExactConstantExtension C N S) := + DistribMulAction.toMulAction + letI : FiniteDimensional (RatFunc C) + (ExactConstantExtension C N S) := + finiteDimensional_exactConstantExtension_over_baseRatFunc C S N hExact + letI : Algebra.IsSeparable (RatFunc C) + (ExactConstantExtension C N S) := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + letI : IsGalois (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtension_isGalois C (RatFunc C) N S hExact + let P₀ := ratFuncRationalFinitePlaceEquivFiniteExtension C P + @MulAction.fixedBy + (ExactConstantExtension C N S ≃ₐ[RatFunc C] + ExactConstantExtension C N S) + (FinitePlaceUnderFiber C (RatFunc C) + (ExactConstantExtension C N S) P₀.1) + _ + (finitePlaceUnderFiberGalAction C (RatFunc C) + (ExactConstantExtension C N S) P₀.1) + (exactConstantExtensionFrobeniusTwist + C (RatFunc C) N S hExact g) + +/-- A sigma-family value map is injective when fibers are injective and their indices +can be recovered injectively from the values. -/ +theorem sigma_value_injective + {I A B : Type*} {V : I → Type*} + (index : I → A) (hindex : Function.Injective index) + (value : ∀ i, V i → B) (under : B → A) + (hunder : ∀ i x, under (value i x) = index i) + (hvalue : ∀ i, Function.Injective (value i)) : + Function.Injective (fun x : Sigma V => value x.1 x.2) := by + rintro ⟨i, x⟩ ⟨j, y⟩ h + have hij : i = j := hindex ((hunder i x).symm.trans ((congrArg under h).trans + (hunder j y))) + subst j + exact congrArg (Sigma.mk i) (hvalue i h) + +/-- Rational finite places of one Frobenius-twist field are the disjoint +union, over rational finite places of `C(X)`, of the ambient fixed top places +in the corresponding restriction fiber. -/ +noncomputable def + frobeniusTwistField_rationalFinitePlace_equiv_sigma_fiberFixedBy + (hdiv : Nat.card (N ≃ₐ[RatFunc C] N) ∣ Module.finrank C S) + (g : N ≃ₐ[RatFunc C] N) : + let : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : SMul (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toSMul + let : Module (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toModule + let : DistribMulAction (RatFunc C) + (ExactConstantExtension C N S) := Module.toDistribMulAction + let : MulAction (RatFunc C) (ExactConstantExtension C N S) := + DistribMulAction.toMulAction + let : FiniteDimensional (RatFunc C) + (ExactConstantExtension C N S) := + finiteDimensional_exactConstantExtension_over_baseRatFunc C S N hExact + let : IsGalois (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtension_isGalois C (RatFunc C) N S hExact + let : Algebra.IsSeparable (RatFunc C) + (ExactConstantExtension C N S) := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + let F := exactConstantExtensionFrobeniusTwistField + C (RatFunc C) N S hExact g + let : Algebra (RatFunc C) F := + SubalgebraClass.toAlgebra F.toSubalgebra + let : SMul (RatFunc C) F := Algebra.toSMul + let : Module (RatFunc C) F := Algebra.toModule + let : FiniteDimensional (RatFunc C) F := + finiteDimensional_frobeniusTwistField_over_ratFunc C N S hExact g + let : Algebra.IsSeparable (RatFunc C) F := + isSeparable_frobeniusTwistField_over_ratFunc C N S hExact g + let : Algebra F (ExactConstantExtension C N S) := F.toAlgebra + let : SMul F (ExactConstantExtension C N S) := Algebra.toSMul + let : Module F (ExactConstantExtension C N S) := Algebra.toModule + let : IsScalarTower (RatFunc C) F + (ExactConstantExtension C N S) := inferInstance + let : FiniteDimensional F (ExactConstantExtension C N S) := + finiteDimensional_exactConstantExtension_over_frobeniusTwistField + C (RatFunc C) N S hExact g + let : IsGalois F (ExactConstantExtension C N S) := + isGalois_exactConstantExtension_over_frobeniusTwistField + C (RatFunc C) N S hExact g + FiniteExtensionRationalFinitePlace C F ≃ + Σ P : RatFuncRationalFinitePlace C, + FrobeniusTwistFinitePlaceFiberFixedBy C S N hExact g P := by + intro model0 model1 model2 model3 model4 model5 model6 model7 model8 F model10 model11 model12 + model13 model14 model15 model16 model17 model18 model19 model20 + let T := ExactConstantExtension C N S + let sigma := exactConstantExtensionFrobeniusTwist + C (RatFunc C) N S hExact g + let baseEquiv := ratFuncRationalFinitePlaceEquivFiniteExtension C + have hDegreeDiv : Module.finrank (RatFunc C) N ∣ Module.finrank C S := by + rw [← IsGalois.card_aut_eq_finrank] + exact hdiv + let AmbientFixed := + {Q : FiniteExtensionFinitePlace C T // + finiteExtensionPlaceDegree C T (.inl Q) = Module.finrank C S ∧ + finitePlaceGalSmul C (RatFunc C) T sigma Q = Q} + let SigmaFixed := Σ P : RatFuncRationalFinitePlace C, + FrobeniusTwistFinitePlaceFiberFixedBy C S N hExact g P + let toAmbient : SigmaFixed → AmbientFixed := fun x => by + let P₀ := baseEquiv x.1 + let Q := x.2.1.1 + have hBase : finiteExtensionPlaceDegree C (RatFunc C) + (.inl (finitePlaceUnder C (RatFunc C) T Q)) = 1 := by + rw [x.2.1.2] + exact P₀.2 + refine ⟨Q, + exactConstantExtensionFinitePlace_degree_eq_finrank_of_under_rational + C S N hExact hDegreeDiv Q hBase, ?_⟩ + exact congrArg Subtype.val x.2.2 + have hInjective : Function.Injective toAmbient := by + intro x y hxy + apply sigma_value_injective (fun P => (baseEquiv P).1) + (fun _ _ h => baseEquiv.injective (Subtype.ext h)) + (fun _ x => x.1.1) (finitePlaceUnder C (RatFunc C) T) + (fun _ x => x.1.2) + (fun _ _ _ h => Subtype.ext (Subtype.ext h)) + exact congrArg Subtype.val hxy + have hSurjective : Function.Surjective toAmbient := by + intro z + let Q := z.1 + have hFdegree : finiteExtensionPlaceDegree C F + (.inl (finitePlaceUnder C F T Q)) = 1 := + frobeniusTwistField_ambientFixed_finitePlace_under_degree_eq_one + C N S hExact g hdiv Q z.2.1 z.2.2 + let R₀ : FiniteExtensionRationalFinitePlace C F := + ⟨finitePlaceUnder C F T Q, hFdegree⟩ + let P₀ : FiniteExtensionRationalFinitePlace C (RatFunc C) := + rationalFinitePlaceUnder C (RatFunc C) F R₀ + let P : RatFuncRationalFinitePlace C := baseEquiv.symm P₀ + have hP : baseEquiv P = P₀ := baseEquiv.apply_symm_apply P₀ + have hFiber : finitePlaceUnder C (RatFunc C) T Q = (baseEquiv P).1 := by + calc + finitePlaceUnder C (RatFunc C) T Q = + finitePlaceUnder C (RatFunc C) F (finitePlaceUnder C F T Q) := + (finitePlaceUnder_ratFunc_under C F T Q).symm + _ = P₀.1 := rfl + _ = (baseEquiv P).1 := congrArg Subtype.val hP.symm + let xFiber : FinitePlaceUnderFiber C (RatFunc C) T (baseEquiv P).1 := + ⟨Q, hFiber⟩ + let xFixed : FrobeniusTwistFinitePlaceFiberFixedBy + C S N hExact g P := ⟨xFiber, by + apply Subtype.ext + exact z.2.2⟩ + refine ⟨⟨P, xFixed⟩, ?_⟩ + apply Subtype.ext + change Q = z.1 + rfl + let eSigma : SigmaFixed ≃ AmbientFixed := + Equiv.ofBijective toAmbient ⟨hInjective, hSurjective⟩ + exact (frobeniusTwistField_rationalFinitePlace_equiv_ambientFixedFinitePlace + C N S hExact g hdiv).trans eSigma.symm + +/-- The number of rational finite places of the fixed field attached to one +canonical Frobenius twist. The instances are fixed explicitly so that this +number can be summed over the original Galois group. -/ +noncomputable def frobeniusTwistFieldRationalFinitePlaceCount + (hExact : algebraicClosure C N = (⊥ : IntermediateField C N)) + (g : N ≃ₐ[RatFunc C] N) : ℕ := + let T := ExactConstantExtension C N S + letI : Field T := exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) T := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + letI : SMul (RatFunc C) T := Algebra.toSMul + letI : Module (RatFunc C) T := Algebra.toModule + letI : DistribMulAction (RatFunc C) T := Module.toDistribMulAction + letI : MulAction (RatFunc C) T := DistribMulAction.toMulAction + letI : FiniteDimensional (RatFunc C) T := + finiteDimensional_exactConstantExtension_over_baseRatFunc C S N hExact + letI : IsGalois (RatFunc C) T := + exactConstantExtension_isGalois C (RatFunc C) N S hExact + letI : Algebra.IsSeparable (RatFunc C) T := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + let F := exactConstantExtensionFrobeniusTwistField + C (RatFunc C) N S hExact g + letI : Algebra (RatFunc C) F := + SubalgebraClass.toAlgebra F.toSubalgebra + letI : SMul (RatFunc C) F := Algebra.toSMul + letI : Module (RatFunc C) F := Algebra.toModule + letI : FiniteDimensional (RatFunc C) F := + finiteDimensional_frobeniusTwistField_over_ratFunc C N S hExact g + letI : Algebra.IsSeparable (RatFunc C) F := + isSeparable_frobeniusTwistField_over_ratFunc C N S hExact g + Nat.card (FiniteExtensionRationalFinitePlace C F) + +/-- For one twist, rational finite places split as the finite sum of fixed +restriction fibers above the rational finite places of `C(X)`. -/ +theorem frobeniusTwistFieldRationalFinitePlaceCount_eq_sum_fiberFixedBy + (hExact : algebraicClosure C N = (⊥ : IntermediateField C N)) + (hdiv : Nat.card (N ≃ₐ[RatFunc C] N) ∣ Module.finrank C S) + (g : N ≃ₐ[RatFunc C] N) : + frobeniusTwistFieldRationalFinitePlaceCount C S N hExact g = + ∑ P : RatFuncRationalFinitePlace C, + Nat.card (FrobeniusTwistFinitePlaceFiberFixedBy + C S N hExact g P) := by + let T := ExactConstantExtension C N S + let : Field T := exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) T := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : SMul (RatFunc C) T := Algebra.toSMul + let : Module (RatFunc C) T := Algebra.toModule + let : DistribMulAction (RatFunc C) T := Module.toDistribMulAction + let : MulAction (RatFunc C) T := DistribMulAction.toMulAction + let : FiniteDimensional (RatFunc C) T := + finiteDimensional_exactConstantExtension_over_baseRatFunc C S N hExact + let : IsGalois (RatFunc C) T := + exactConstantExtension_isGalois C (RatFunc C) N S hExact + let : Algebra.IsSeparable (RatFunc C) T := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + let F := exactConstantExtensionFrobeniusTwistField + C (RatFunc C) N S hExact g + let : Algebra (RatFunc C) F := + SubalgebraClass.toAlgebra F.toSubalgebra + let : SMul (RatFunc C) F := Algebra.toSMul + let : Module (RatFunc C) F := Algebra.toModule + let : FiniteDimensional (RatFunc C) F := + finiteDimensional_frobeniusTwistField_over_ratFunc C N S hExact g + let : Algebra.IsSeparable (RatFunc C) F := + isSeparable_frobeniusTwistField_over_ratFunc C N S hExact g + let : Algebra F T := F.toAlgebra + let : SMul F T := Algebra.toSMul + let : Module F T := Algebra.toModule + let : IsScalarTower (RatFunc C) F T := inferInstance + let : FiniteDimensional F T := + finiteDimensional_exactConstantExtension_over_frobeniusTwistField + C (RatFunc C) N S hExact g + let : IsGalois F T := + isGalois_exactConstantExtension_over_frobeniusTwistField + C (RatFunc C) N S hExact g + change Nat.card (FiniteExtensionRationalFinitePlace C F) = _ + rw [Nat.card_congr + (frobeniusTwistField_rationalFinitePlace_equiv_sigma_fiberFixedBy + C S N hExact hdiv g), Nat.card_sigma] + +/-- Summed over all canonical Frobenius twists, the number of rational +finite places is exactly the order of the original Galois group times the +number of constants. -/ +theorem sum_frobeniusTwistFieldRationalFinitePlaceCount_eq_card_galois_mul_card + (hExact : algebraicClosure C N = (⊥ : IntermediateField C N)) + (hdiv : Nat.card (N ≃ₐ[RatFunc C] N) ∣ Module.finrank C S) : + (∑ g : N ≃ₐ[RatFunc C] N, + frobeniusTwistFieldRationalFinitePlaceCount C S N hExact g) = + Nat.card (N ≃ₐ[RatFunc C] N) * Nat.card C := by + have hDegreeDiv : + Module.finrank (RatFunc C) N ∣ Module.finrank C S := by + rw [← IsGalois.card_aut_eq_finrank] + exact hdiv + calc + (∑ g : N ≃ₐ[RatFunc C] N, + frobeniusTwistFieldRationalFinitePlaceCount C S N hExact g) = + ∑ g : N ≃ₐ[RatFunc C] N, + ∑ P : RatFuncRationalFinitePlace C, + Nat.card (FrobeniusTwistFinitePlaceFiberFixedBy + C S N hExact g P) := by + apply Finset.sum_congr rfl + intro g _ + exact frobeniusTwistFieldRationalFinitePlaceCount_eq_sum_fiberFixedBy + C S N hExact hdiv g + _ = ∑ P : RatFuncRationalFinitePlace C, + ∑ g : N ≃ₐ[RatFunc C] N, + Nat.card (FrobeniusTwistFinitePlaceFiberFixedBy + C S N hExact g P) := by + rw [Finset.sum_comm] + _ = ∑ _P : RatFuncRationalFinitePlace C, + Nat.card (N ≃ₐ[RatFunc C] N) := by + apply Finset.sum_congr rfl + intro P _ + simpa only [FrobeniusTwistFinitePlaceFiberFixedBy] using + (sum_card_finitePlaceUnderFiber_fixedBy_frobeniusTwist_eq_card_galois + C S N hExact hDegreeDiv P) + _ = Nat.card (RatFuncRationalFinitePlace C) * + Nat.card (N ≃ₐ[RatFunc C] N) := by + simp [Nat.card_eq_fintype_card] + _ = Nat.card C * Nat.card (N ≃ₐ[RatFunc C] N) := by + rw [Nat.card_congr (ratFuncRationalFinitePlaceEquiv C)] + _ = Nat.card (N ≃ₐ[RatFunc C] N) * Nat.card C := Nat.mul_comm _ _ + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionFrobeniusTwistFinitePlaceBridge.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionFrobeniusTwistFinitePlaceBridge.lean new file mode 100644 index 0000000000..04b294a983 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionFrobeniusTwistFinitePlaceBridge.lean @@ -0,0 +1,475 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionFinitePlaceFrobeniusAverage +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionFrobeniusTwistRiemannLower + +/-! +# Finite places of Frobenius-twist fields + +This file connects the fixed finite places occurring in Frobenius-coset +averaging with finite places of the corresponding Frobenius-twist fixed +field. The first step is the arithmetic core of that comparison: every +rational finite place of a twist field has a unique finite place above it in +the exact constant extension. + +Indeed, the top residue field contains the enlarged constant field `S`, so +its degree over `C` is divisible by `[S : C]`. Multiplicativity of place +degree identifies that degree with the relative residue degree above a +rational twist-field place. Since the entire extension has degree +`[S : C]`, the Galois decomposition formula forces both the number of places +above the rational place and the ramification index to be one. + +Only this rational-place-to-fixed-lift direction is asserted here. The +reverse implication for an arbitrary twist-fixed top place additionally +requires the unramified residue-field descent for the constant extension; +that result is not hidden in the interface below. +-/ + +@[expose] public section + +open scoped Pointwise Polynomial TensorProduct + +namespace BGS.HasseWeil + +noncomputable section + +open BGS.CorvajaZannier + + +variable (C N S : Type*) [Field C] [Fintype C] + [DecidableEq C] [DecidableEq (RatFunc C)] + [Field N] [Algebra (RatFunc C) N] + [FiniteDimensional (RatFunc C) N] + [Algebra.IsSeparable (RatFunc C) N] + [Field S] [Algebra C S] [FiniteDimensional C S] [IsGalois C S] + [Finite S] [DecidableEq S] [DecidableEq (RatFunc S)] + +local instance twistBridgeConstantAlgebra : Algebra C N := + bridgeBaseConstantAlgebra C N + +local instance twistBridgeConstantTower : + IsScalarTower C (RatFunc C) N := + IsScalarTower.of_algebraMap_eq' rfl + +section GenericUniqueFiber + +variable (K M T : Type*) [Field K] [DecidableEq K] + [DecidableEq (RatFunc K)] [Field M] [Field T] + [Algebra (RatFunc K) M] [FiniteDimensional (RatFunc K) M] + [Algebra.IsSeparable (RatFunc K) M] + [Algebra (RatFunc K) T] [FiniteDimensional (RatFunc K) T] + [Algebra.IsSeparable (RatFunc K) T] + [Algebra M T] [IsScalarTower (RatFunc K) M T] + [FiniteDimensional M T] [IsGalois M T] + +/-- If every top finite-place degree is divisible by the relative field +degree, then every rational finite place downstairs has a unique place above +it. The proof uses only degree multiplicativity and the Galois +decomposition formula. -/ +theorem rationalFinitePlace_fiber_card_eq_one_of_finrank_dvd_degree + (hdegree : ∀ Q : FiniteExtensionFinitePlace K T, + Module.finrank M T ∣ finiteExtensionPlaceDegree K T (.inl Q)) + (P : FiniteExtensionRationalFinitePlace K M) : + Fintype.card (FinitePlaceUnderFiber K M T P.1) = 1 := by + obtain ⟨Q, hQ⟩ := finitePlaceUnder_surjective K M T P.1 + let Q₀ : FinitePlaceUnderFiber K M T P.1 := ⟨Q, hQ⟩ + have hplaceDegree := + finiteExtensionPlaceDegree_inl_eq_mul_relativeInertiaDeg K M T Q + have hrelative : finitePlaceRelativeInertiaDeg K M T Q = + finiteExtensionPlaceDegree K T (.inl Q) := by + rw [hQ] at hplaceDegree + simpa [P.2] using hplaceDegree.symm + have hm_dvd_f : Module.finrank M T ∣ + finitePlaceRelativeInertiaDeg K M T Q := by + rw [hrelative] + exact hdegree Q + have hfiber := + finitePlaceUnderFiber_card_mul_ramificationIdx_mul_inertiaDeg_eq_field_finrank + K M T P.1 Q₀ + dsimp [Q₀] at hfiber + have hf_dvd_m : finitePlaceRelativeInertiaDeg K M T Q ∣ + Module.finrank M T := by + rw [← hfiber] + exact dvd_mul_left _ _ + have hf : finitePlaceRelativeInertiaDeg K M T Q = + Module.finrank M T := Nat.dvd_antisymm hf_dvd_m hm_dvd_f + have hmpos : 0 < Module.finrank M T := Module.finrank_pos + have hproduct : + Fintype.card (FinitePlaceUnderFiber K M T P.1) * + finitePlaceRelativeRamificationIdx K M T Q = 1 := by + apply Nat.eq_of_mul_eq_mul_right hmpos + simpa [Nat.mul_assoc, hf] using hfiber + exact Nat.eq_one_of_dvd_one + ⟨finitePlaceRelativeRamificationIdx K M T Q, hproduct.symm⟩ + +/-- Under the same degree-divisibility hypothesis, every relative Galois +automorphism fixes every finite place above a rational finite place. This is +the action form of the singleton-fiber theorem. -/ +theorem finitePlaceGalSmul_eq_self_over_rationalFinitePlace_of_finrank_dvd_degree + (hdegree : ∀ Q : FiniteExtensionFinitePlace K T, + Module.finrank M T ∣ finiteExtensionPlaceDegree K T (.inl Q)) + (P : FiniteExtensionRationalFinitePlace K M) + (Q : FiniteExtensionFinitePlace K T) + (hQ : finitePlaceUnder K M T Q = P.1) + (sigma : T ≃ₐ[M] T) : + finitePlaceGalSmul K M T sigma Q = Q := by + let := finiteIntegralClosureGalAction K M T + let := finitePlaceUnderFiberGalAction K M T P.1 + have hcard := + rationalFinitePlace_fiber_card_eq_one_of_finrank_dvd_degree + K M T hdegree P + obtain ⟨Q₀, hQ₀⟩ := Fintype.card_eq_one_iff.mp hcard + let x : FinitePlaceUnderFiber K M T P.1 := ⟨Q, hQ⟩ + let y : FinitePlaceUnderFiber K M T P.1 := + ⟨finitePlaceGalSmul K M T sigma Q, by + rw [finitePlaceUnder_finitePlaceGalSmul, hQ]⟩ + have hxy : x = y := (hQ₀ x).trans (hQ₀ y).symm + exact congrArg Subtype.val hxy |>.symm + +end GenericUniqueFiber + +omit [Fintype C] [Finite S] in +/-- Every finite place of the exact constant extension, viewed over the +original constants `C`, has degree divisible by `[S : C]`. This is the +degree-theoretic expression of the inclusion of `S` in every top residue +field. -/ +theorem exactConstantExtensionFinitePlace_finrank_constants_dvd_degree + (hExact : algebraicClosure C N = + (⊥ : IntermediateField C N)) + (Q : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + FiniteExtensionFinitePlace C (ExactConstantExtension C N S)) : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + Module.finrank C S ∣ finiteExtensionPlaceDegree C + (ExactConstantExtension C N S) (.inl Q) := by + let T := ExactConstantExtension C N S + let : Field T := exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) T := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : SMul (RatFunc C) T := Algebra.toSMul + let : Module (RatFunc C) T := Algebra.toModule + let : FiniteDimensional (RatFunc C) T := + finiteDimensional_exactConstantExtension_over_baseRatFunc C S N hExact + let : Algebra (RatFunc S) T := + ratFuncExactConstantExtensionAlgebra C S N hExact + let : Algebra.IsSeparable (RatFunc C) T := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + let : SMul (RatFunc S) T := Algebra.toSMul + let : Module (RatFunc S) T := Algebra.toModule + let : FiniteDimensional (RatFunc S) T := + finiteDimensional_over_extendedRatFunc C S N hExact + let : Algebra.IsSeparable (RatFunc S) T := + isSeparable_over_extendedRatFunc C S N hExact + rw [finiteExtensionFinitePlace_degree_baseChange C S T + (exactConstantExtension_ratFunc_polynomialCompatibility C S N hExact) + Q] + exact dvd_mul_right _ _ + +/-- The Frobenius-twist generator, regarded as an automorphism over its own +fixed field. Its underlying field automorphism is definitionally the same +twist used in the Frobenius fiber over `C(X)`. -/ +noncomputable def exactConstantExtensionFrobeniusTwistOverFixedField + (hExact : algebraicClosure C N = + (⊥ : IntermediateField C N)) + (g : N ≃ₐ[RatFunc C] N) : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + ExactConstantExtension C N S ≃ₐ[ + exactConstantExtensionFrobeniusTwistField + C (RatFunc C) N S hExact g] + ExactConstantExtension C N S := by + let T := ExactConstantExtension C N S + letI : Field T := exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) T := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + letI : SMul (RatFunc C) T := Algebra.toSMul + letI : Module (RatFunc C) T := Algebra.toModule + letI : FiniteDimensional (RatFunc C) T := + finiteDimensional_exactConstantExtension_over_baseRatFunc C S N hExact + let sigma := exactConstantExtensionFrobeniusTwist + C (RatFunc C) N S hExact g + let H := exactConstantExtensionFrobeniusTwistSubgroup + C (RatFunc C) N S hExact g + exact IntermediateField.subgroupEquivAlgEquiv H + ⟨sigma, Subgroup.mem_zpowers sigma⟩ + +omit [DecidableEq C] [DecidableEq (RatFunc C)] [Algebra.IsSeparable (RatFunc C) N] [Finite S] + [DecidableEq S] [DecidableEq (RatFunc S)] in +@[simp] +theorem exactConstantExtensionFrobeniusTwistOverFixedField_apply + (hExact : algebraicClosure C N = + (⊥ : IntermediateField C N)) + (g : N ≃ₐ[RatFunc C] N) + (x : ExactConstantExtension C N S) : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + exactConstantExtensionFrobeniusTwistOverFixedField + C N S hExact g x = + exactConstantExtensionFrobeniusTwist + C (RatFunc C) N S hExact g x := by + let T := ExactConstantExtension C N S + let : Field T := exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) T := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + change + (exactConstantExtensionFrobeniusTwist + C (RatFunc C) N S hExact g).toEquiv x = + exactConstantExtensionFrobeniusTwist + C (RatFunc C) N S hExact g x + rfl + +/-- A rational finite place of a Frobenius-twist field has exactly one finite +place above it in the exact constant extension. -/ +theorem frobeniusTwistField_rationalFinitePlace_fiber_card_eq_one + (hExact : algebraicClosure C N = + (⊥ : IntermediateField C N)) + (g : N ≃ₐ[RatFunc C] N) + (hdiv : Nat.card (N ≃ₐ[RatFunc C] N) ∣ Module.finrank C S) : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + letI : SMul (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toSMul + letI : Module (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toModule + letI : FiniteDimensional (RatFunc C) + (ExactConstantExtension C N S) := + finiteDimensional_exactConstantExtension_over_baseRatFunc + C S N hExact + letI : Algebra.IsSeparable (RatFunc C) + (ExactConstantExtension C N S) := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + let F := exactConstantExtensionFrobeniusTwistField + C (RatFunc C) N S hExact g + letI : Algebra (RatFunc C) F := + SubalgebraClass.toAlgebra F.toSubalgebra + letI : SMul (RatFunc C) F := Algebra.toSMul + letI : Module (RatFunc C) F := Algebra.toModule + letI : FiniteDimensional (RatFunc C) F := + finiteDimensional_frobeniusTwistField_over_ratFunc C N S hExact g + letI : Algebra.IsSeparable (RatFunc C) F := + isSeparable_frobeniusTwistField_over_ratFunc C N S hExact g + letI : Algebra F (ExactConstantExtension C N S) := F.toAlgebra + letI : SMul F (ExactConstantExtension C N S) := Algebra.toSMul + letI : Module F (ExactConstantExtension C N S) := Algebra.toModule + letI : IsScalarTower (RatFunc C) F + (ExactConstantExtension C N S) := inferInstance + letI : FiniteDimensional F (ExactConstantExtension C N S) := + finiteDimensional_exactConstantExtension_over_frobeniusTwistField + C (RatFunc C) N S hExact g + letI : IsGalois F (ExactConstantExtension C N S) := + isGalois_exactConstantExtension_over_frobeniusTwistField + C (RatFunc C) N S hExact g + ∀ P : FiniteExtensionRationalFinitePlace C F, + Fintype.card (FinitePlaceUnderFiber C F + (ExactConstantExtension C N S) P.1) = 1 := by + let T := ExactConstantExtension C N S + let : Field T := exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) T := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : SMul (RatFunc C) T := Algebra.toSMul + let : Module (RatFunc C) T := Algebra.toModule + let : FiniteDimensional (RatFunc C) T := + finiteDimensional_exactConstantExtension_over_baseRatFunc C S N hExact + let : Algebra.IsSeparable (RatFunc C) T := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + let F := exactConstantExtensionFrobeniusTwistField + C (RatFunc C) N S hExact g + let : Algebra (RatFunc C) F := + SubalgebraClass.toAlgebra F.toSubalgebra + let : SMul (RatFunc C) F := Algebra.toSMul + let : Module (RatFunc C) F := Algebra.toModule + let : FiniteDimensional (RatFunc C) F := + finiteDimensional_frobeniusTwistField_over_ratFunc C N S hExact g + let : Algebra.IsSeparable (RatFunc C) F := + isSeparable_frobeniusTwistField_over_ratFunc C N S hExact g + let : Algebra F T := F.toAlgebra + let : SMul F T := Algebra.toSMul + let : Module F T := Algebra.toModule + let : IsScalarTower (RatFunc C) F T := inferInstance + let : FiniteDimensional F T := + finiteDimensional_exactConstantExtension_over_frobeniusTwistField + C (RatFunc C) N S hExact g + let : IsGalois F T := + isGalois_exactConstantExtension_over_frobeniusTwistField + C (RatFunc C) N S hExact g + dsimp only + intro P + apply rationalFinitePlace_fiber_card_eq_one_of_finrank_dvd_degree + C F T ?_ P + intro Q + rw [finrank_exactConstantExtension_over_frobeniusTwistField + C (RatFunc C) N S hExact g hdiv] + exact exactConstantExtensionFinitePlace_finrank_constants_dvd_degree + C N S hExact Q + +/-- Every finite-place lift of a rational Frobenius-twist-field place is +fixed by the canonical twist generator over its fixed field. -/ +theorem frobeniusTwistField_rationalFinitePlace_lift_fixed + (hExact : algebraicClosure C N = + (⊥ : IntermediateField C N)) + (g : N ≃ₐ[RatFunc C] N) + (hdiv : Nat.card (N ≃ₐ[RatFunc C] N) ∣ Module.finrank C S) : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + letI : SMul (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toSMul + letI : Module (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toModule + letI : FiniteDimensional (RatFunc C) + (ExactConstantExtension C N S) := + finiteDimensional_exactConstantExtension_over_baseRatFunc + C S N hExact + letI : Algebra.IsSeparable (RatFunc C) + (ExactConstantExtension C N S) := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + let F := exactConstantExtensionFrobeniusTwistField + C (RatFunc C) N S hExact g + letI : Algebra (RatFunc C) F := + SubalgebraClass.toAlgebra F.toSubalgebra + letI : SMul (RatFunc C) F := Algebra.toSMul + letI : Module (RatFunc C) F := Algebra.toModule + letI : FiniteDimensional (RatFunc C) F := + finiteDimensional_frobeniusTwistField_over_ratFunc C N S hExact g + letI : Algebra.IsSeparable (RatFunc C) F := + isSeparable_frobeniusTwistField_over_ratFunc C N S hExact g + letI : Algebra F (ExactConstantExtension C N S) := F.toAlgebra + letI : SMul F (ExactConstantExtension C N S) := Algebra.toSMul + letI : Module F (ExactConstantExtension C N S) := Algebra.toModule + letI : IsScalarTower (RatFunc C) F + (ExactConstantExtension C N S) := inferInstance + letI : FiniteDimensional F (ExactConstantExtension C N S) := + finiteDimensional_exactConstantExtension_over_frobeniusTwistField + C (RatFunc C) N S hExact g + letI : IsGalois F (ExactConstantExtension C N S) := + isGalois_exactConstantExtension_over_frobeniusTwistField + C (RatFunc C) N S hExact g + ∀ (P : FiniteExtensionRationalFinitePlace C F) + (Q : FiniteExtensionFinitePlace C (ExactConstantExtension C N S)), + finitePlaceUnder C F (ExactConstantExtension C N S) Q = P.1 → + finitePlaceGalSmul C F (ExactConstantExtension C N S) + (exactConstantExtensionFrobeniusTwistOverFixedField + C N S hExact g) Q = Q := by + let T := ExactConstantExtension C N S + let : Field T := exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) T := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : SMul (RatFunc C) T := Algebra.toSMul + let : Module (RatFunc C) T := Algebra.toModule + let : FiniteDimensional (RatFunc C) T := + finiteDimensional_exactConstantExtension_over_baseRatFunc C S N hExact + let : Algebra.IsSeparable (RatFunc C) T := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + let F := exactConstantExtensionFrobeniusTwistField + C (RatFunc C) N S hExact g + let : Algebra (RatFunc C) F := + SubalgebraClass.toAlgebra F.toSubalgebra + let : SMul (RatFunc C) F := Algebra.toSMul + let : Module (RatFunc C) F := Algebra.toModule + let : FiniteDimensional (RatFunc C) F := + finiteDimensional_frobeniusTwistField_over_ratFunc C N S hExact g + let : Algebra.IsSeparable (RatFunc C) F := + isSeparable_frobeniusTwistField_over_ratFunc C N S hExact g + let : Algebra F T := F.toAlgebra + let : SMul F T := Algebra.toSMul + let : Module F T := Algebra.toModule + let : IsScalarTower (RatFunc C) F T := inferInstance + let : FiniteDimensional F T := + finiteDimensional_exactConstantExtension_over_frobeniusTwistField + C (RatFunc C) N S hExact g + let : IsGalois F T := + isGalois_exactConstantExtension_over_frobeniusTwistField + C (RatFunc C) N S hExact g + dsimp only + intro P Q hQ + apply + finitePlaceGalSmul_eq_self_over_rationalFinitePlace_of_finrank_dvd_degree + C F T ?_ P Q hQ + intro R + rw [finrank_exactConstantExtension_over_frobeniusTwistField + C (RatFunc C) N S hExact g hdiv] + exact exactConstantExtensionFinitePlace_finrank_constants_dvd_degree + C N S hExact R + +section RationalFinitePlaceLifts + +variable (K M T : Type*) [Field K] [DecidableEq K] + [DecidableEq (RatFunc K)] [Field M] [Field T] + [Algebra (RatFunc K) M] [FiniteDimensional (RatFunc K) M] + [Algebra.IsSeparable (RatFunc K) M] + [Algebra (RatFunc K) T] [FiniteDimensional (RatFunc K) T] + [Algebra.IsSeparable (RatFunc K) T] + [Algebra M T] [IsScalarTower (RatFunc K) M T] + [FiniteDimensional M T] [IsGalois M T] + +/-- A rational finite place together with a finite place above it. -/ +abbrev RationalFinitePlaceLift := + Σ P : FiniteExtensionRationalFinitePlace K M, + FinitePlaceUnderFiber K M T P.1 + +/-- If the relative degree divides every top place degree, projection from +rational finite-place lifts is an equivalence. Equivalently, every rational +finite place has exactly one top lift. -/ +noncomputable def rationalFinitePlaceEquivLift + (hdegree : ∀ Q : FiniteExtensionFinitePlace K T, + Module.finrank M T ∣ finiteExtensionPlaceDegree K T (.inl Q)) : + FiniteExtensionRationalFinitePlace K M ≃ + RationalFinitePlaceLift K M T := by + let projection : RationalFinitePlaceLift K M T → + FiniteExtensionRationalFinitePlace K M := fun x => x.1 + refine (Equiv.ofBijective projection ⟨?_, ?_⟩).symm + · rintro ⟨P, Q⟩ ⟨P', Q'⟩ h + dsimp only [projection] at h + subst P' + have hcard := + rationalFinitePlace_fiber_card_eq_one_of_finrank_dvd_degree + K M T hdegree P + obtain ⟨Q₀, hQ₀⟩ := Fintype.card_eq_one_iff.mp hcard + exact Sigma.ext rfl <| heq_of_eq <| + (hQ₀ Q).trans (hQ₀ Q').symm + · intro P + obtain ⟨Q, hQ⟩ := finitePlaceUnder_surjective K M T P.1 + exact ⟨⟨P, Q, hQ⟩, rfl⟩ + +/-- Every top lift of a rational finite place is fixed by every relative +Galois automorphism under the degree-divisibility hypothesis. -/ +theorem rationalFinitePlaceLift_fixed + (hdegree : ∀ Q : FiniteExtensionFinitePlace K T, + Module.finrank M T ∣ finiteExtensionPlaceDegree K T (.inl Q)) + (sigma : T ≃ₐ[M] T) (x : RationalFinitePlaceLift K M T) : + finitePlaceGalSmul K M T sigma x.2.1 = x.2.1 := + finitePlaceGalSmul_eq_self_over_rationalFinitePlace_of_finrank_dvd_degree + K M T hdegree x.1 x.2.1 x.2.2 sigma + +/-- Cardinal form of the rational-place/unique-lift correspondence. -/ +theorem natCard_rationalFinitePlaceLift_eq + (hdegree : ∀ Q : FiniteExtensionFinitePlace K T, + Module.finrank M T ∣ finiteExtensionPlaceDegree K T (.inl Q)) : + Nat.card (RationalFinitePlaceLift K M T) = + Nat.card (FiniteExtensionRationalFinitePlace K M) := + Nat.card_congr (rationalFinitePlaceEquivLift K M T hdegree).symm + +end RationalFinitePlaceLifts + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionFrobeniusTwistFinitePlaceUnramified.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionFrobeniusTwistFinitePlaceUnramified.lean new file mode 100644 index 0000000000..a8ef4aaaab --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionFrobeniusTwistFinitePlaceUnramified.lean @@ -0,0 +1,1010 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionFrobeniusTwistFinitePlaceBridge + +/-! +# Unramified finite places over Frobenius-twist fields + +The Galois group of the exact constant extension over a Frobenius-twist +field is the cyclic subgroup generated by the twist. Restriction to the +enlarged constants is injective on this subgroup. An inertia automorphism +acts trivially on every residue class, hence in particular on the embedded +constant field. It therefore lies in the kernel of constant restriction and +must be the identity. Thus every finite place is unramified in the exact +constant extension over a twist field. +-/ + +@[expose] public section + +open scoped Pointwise Polynomial TensorProduct + +namespace BGS.HasseWeil + +noncomputable section + +open BGS.CorvajaZannier +open IsDedekindDomain + + +variable (C N S : Type*) [Field C] [Fintype C] + [DecidableEq C] [DecidableEq (RatFunc C)] + [Field N] [Algebra (RatFunc C) N] + [FiniteDimensional (RatFunc C) N] + [Algebra.IsSeparable (RatFunc C) N] + [Field S] [Algebra C S] [FiniteDimensional C S] [IsGalois C S] + [Finite S] [DecidableEq S] [DecidableEq (RatFunc S)] + +local instance unramifiedConstantAlgebra : Algebra C N := + bridgeBaseConstantAlgebra C N + +local instance unramifiedConstantTower : + IsScalarTower C (RatFunc C) N := + IsScalarTower.of_algebraMap_eq' rfl + +omit [DecidableEq C] [DecidableEq (RatFunc C)] + [FiniteDimensional (RatFunc C) N] + [Algebra.IsSeparable (RatFunc C) N] + [Finite S] + [DecidableEq S] [DecidableEq (RatFunc S)] in +/-- A power of the canonical twist acts on the enlarged constants by the +same power of finite-field Frobenius. This is the constant-factor part of +the tensor-product action and does not require `N / C(X)` to be normal. -/ +private theorem exactConstantExtensionFrobeniusTwist_zpow_includeLeft + (hExact : algebraicClosure C N = + (⊥ : IntermediateField C N)) + (g : N ≃ₐ[RatFunc C] N) (k : ℤ) (s : S) : + let : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + ((exactConstantExtensionFrobeniusTwist + C (RatFunc C) N S hExact g) ^ k) + (Algebra.TensorProduct.includeLeft + (R := C) (S := C) (A := S) (B := N) s) = + Algebra.TensorProduct.includeLeft + (R := C) (S := C) (A := S) (B := N) + (((FiniteField.frobeniusAlgEquivOfAlgebraic C S) ^ k) s) := by + let : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + change + ((exactConstantExtensionCombinedAutHom C (RatFunc C) N S + (FiniteField.frobeniusAlgEquivOfAlgebraic C S, g)) ^ k) + (Algebra.TensorProduct.includeLeft + (R := C) (S := C) (A := S) (B := N) s) = _ + rw [← map_zpow] + simp [Algebra.TensorProduct.includeLeft_apply, + exactConstantExtensionCombinedAutHom, + exactConstantExtensionConstantAutHom, + exactConstantExtensionFunctionAutHom, + exactConstantExtensionConstantAlgEquivOverBase, + exactConstantExtensionFunctionAlgEquivOverBase] + +omit [DecidableEq C] [DecidableEq (RatFunc C)] [Algebra.IsSeparable (RatFunc C) N] [Finite S] + [DecidableEq S] [DecidableEq (RatFunc S)] in +/-- The canonical twist generates the full Galois group over its fixed +field. This is a direct consequence of defining that fixed field from the +cyclic subgroup generated by the ambient twist. -/ +theorem exactConstantExtensionFrobeniusTwistOverFixedField_zpowers_eq_top + (hExact : algebraicClosure C N = + (⊥ : IntermediateField C N)) + (g : N ≃ₐ[RatFunc C] N) : + let : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + Subgroup.zpowers + (exactConstantExtensionFrobeniusTwistOverFixedField + C N S hExact g) = ⊤ := by + let T := ExactConstantExtension C N S + let : Field T := exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) T := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : SMul (RatFunc C) T := Algebra.toSMul + let : Module (RatFunc C) T := Algebra.toModule + let : FiniteDimensional (RatFunc C) T := + finiteDimensional_exactConstantExtension_over_baseRatFunc C S N hExact + let sigma := exactConstantExtensionFrobeniusTwist + C (RatFunc C) N S hExact g + let H := exactConstantExtensionFrobeniusTwistSubgroup + C (RatFunc C) N S hExact g + let e := IntermediateField.subgroupEquivAlgEquiv H + let u : H := ⟨sigma, Subgroup.mem_zpowers sigma⟩ + change Subgroup.zpowers (e u) = ⊤ + apply (Subgroup.eq_top_iff' _).mpr + intro tau + let h : H := e.symm tau + obtain ⟨k, hk⟩ := Subgroup.mem_zpowers_iff.mp h.2 + apply Subgroup.mem_zpowers_iff.mpr + refine ⟨k, ?_⟩ + calc + (e u) ^ k = e (u ^ k) := (map_zpow e u k).symm + _ = e h := congrArg e (Subtype.ext hk) + _ = tau := e.apply_symm_apply tau + +/-- If one generator of a relative Galois group fixes a top finite place, +then generation, unramifiedness, and maximal possible top degree force the +restricted finite place to have degree one. -/ +theorem finitePlaceUnder_degree_eq_one_of_generator_fixed + (K M T : Type*) [Field K] [DecidableEq K] + [DecidableEq (RatFunc K)] + [Field M] [Algebra (RatFunc K) M] + [FiniteDimensional (RatFunc K) M] + [Algebra.IsSeparable (RatFunc K) M] + [Field T] [Algebra (RatFunc K) T] + [FiniteDimensional (RatFunc K) T] + [Algebra.IsSeparable (RatFunc K) T] + [Algebra M T] [IsScalarTower (RatFunc K) M T] + [FiniteDimensional M T] [IsGalois M T] + (sigma : T ≃ₐ[M] T) + (hgen : Subgroup.zpowers sigma = ⊤) + (Q : FiniteExtensionFinitePlace K T) + (hfixed : finitePlaceGalSmul K M T sigma Q = Q) + (hunramified : finitePlaceRelativeRamificationIdx K M T Q = 1) + (htopDegree : finiteExtensionPlaceDegree K T (.inl Q) = + Module.finrank M T) : + finiteExtensionPlaceDegree K M + (.inl (finitePlaceUnder K M T Q)) = 1 := by + let P := finitePlaceUnder K M T Q + let Q₀ : FinitePlaceUnderFiber K M T P := ⟨Q, rfl⟩ + let := finitePlaceGalAction K M T + have hsigma : sigma ∈ + MulAction.stabilizer (T ≃ₐ[M] T) Q := by + rw [MulAction.mem_stabilizer_iff] + exact hfixed + have hall (tau : T ≃ₐ[M] T) : + finitePlaceGalSmul K M T tau Q = Q := by + have hle : Subgroup.zpowers sigma ≤ + MulAction.stabilizer (T ≃ₐ[M] T) Q := + Subgroup.zpowers_le.mpr hsigma + have htau : tau ∈ MulAction.stabilizer (T ≃ₐ[M] T) Q := by + apply hle + rw [hgen] + exact Subgroup.mem_top tau + have hfix := MulAction.mem_stabilizer_iff.mp htau + change finitePlaceGalSmul K M T tau Q = Q at hfix + exact hfix + let := finitePlaceUnderFiberGalAction K M T P + let : MulAction.IsPretransitive (T ≃ₐ[M] T) + (FinitePlaceUnderFiber K M T P) := + finitePlaceUnderFiberGalAction_isPretransitive K M T P + have hcard : Fintype.card (FinitePlaceUnderFiber K M T P) = 1 := by + apply Fintype.card_eq_one_iff.mpr + refine ⟨Q₀, ?_⟩ + intro R + obtain ⟨tau, htau⟩ := + MulAction.exists_smul_eq (T ≃ₐ[M] T) Q₀ R + calc + R = tau • Q₀ := htau.symm + _ = Q₀ := by + apply Subtype.ext + exact hall tau + have hfundamental := + finitePlaceUnderFiber_card_mul_ramificationIdx_mul_inertiaDeg_eq_field_finrank + K M T P Q₀ + dsimp [Q₀] at hfundamental + have hinertia : finitePlaceRelativeInertiaDeg K M T Q = + Module.finrank M T := by + simpa only [hcard, hunramified, one_mul] using hfundamental + have htower := + finiteExtensionPlaceDegree_inl_eq_mul_relativeInertiaDeg K M T Q + rw [htopDegree, hinertia] at htower + apply Nat.eq_of_mul_eq_mul_right (Module.finrank_pos (R := M) (M := T)) + simpa only [one_mul] using htower.symm + +/-- Conversely, under the same degree-divisibility hypothesis used for the +unique-lift theorem, every lift of a rational finite place has top degree +equal to the relative field degree. -/ +theorem rationalFinitePlace_lift_degree_eq_finrank_of_finrank_dvd_degree + (K M T : Type*) [Field K] [DecidableEq K] + [DecidableEq (RatFunc K)] + [Field M] [Algebra (RatFunc K) M] + [FiniteDimensional (RatFunc K) M] + [Algebra.IsSeparable (RatFunc K) M] + [Field T] [Algebra (RatFunc K) T] + [FiniteDimensional (RatFunc K) T] + [Algebra.IsSeparable (RatFunc K) T] + [Algebra M T] [IsScalarTower (RatFunc K) M T] + [FiniteDimensional M T] [IsGalois M T] + (hdegree : ∀ Q : FiniteExtensionFinitePlace K T, + Module.finrank M T ∣ finiteExtensionPlaceDegree K T (.inl Q)) + (P : FiniteExtensionRationalFinitePlace K M) + (Q : FiniteExtensionFinitePlace K T) + (hQ : finitePlaceUnder K M T Q = P.1) : + finiteExtensionPlaceDegree K T (.inl Q) = Module.finrank M T := by + let Q₀ : FinitePlaceUnderFiber K M T P.1 := ⟨Q, hQ⟩ + have htower := + finiteExtensionPlaceDegree_inl_eq_mul_relativeInertiaDeg K M T Q + have hrelative : finitePlaceRelativeInertiaDeg K M T Q = + finiteExtensionPlaceDegree K T (.inl Q) := by + rw [hQ] at htower + simpa only [P.2, one_mul] using htower.symm + have hm_dvd_f : Module.finrank M T ∣ + finitePlaceRelativeInertiaDeg K M T Q := by + rw [hrelative] + exact hdegree Q + have hfundamental := + finitePlaceUnderFiber_card_mul_ramificationIdx_mul_inertiaDeg_eq_field_finrank + K M T P.1 Q₀ + dsimp [Q₀] at hfundamental + have hf_dvd_m : finitePlaceRelativeInertiaDeg K M T Q ∣ + Module.finrank M T := by + rw [← hfundamental] + exact dvd_mul_left _ _ + exact hrelative.symm.trans (Nat.dvd_antisymm hf_dvd_m hm_dvd_f) + +/-- Rational finite places are equivalent to generator-fixed top finite +places of relative-degree-sized absolute degree, once the relative extension +is unramified and every top degree is divisible by the relative degree. -/ +noncomputable def rationalFinitePlaceEquivGeneratorFixedPlace + (K M T : Type*) [Field K] [DecidableEq K] + [DecidableEq (RatFunc K)] + [Field M] [Algebra (RatFunc K) M] + [FiniteDimensional (RatFunc K) M] + [Algebra.IsSeparable (RatFunc K) M] + [Field T] [Algebra (RatFunc K) T] + [FiniteDimensional (RatFunc K) T] + [Algebra.IsSeparable (RatFunc K) T] + [Algebra M T] [IsScalarTower (RatFunc K) M T] + [FiniteDimensional M T] [IsGalois M T] + (hdegree : ∀ Q : FiniteExtensionFinitePlace K T, + Module.finrank M T ∣ finiteExtensionPlaceDegree K T (.inl Q)) + (sigma : T ≃ₐ[M] T) + (hgen : Subgroup.zpowers sigma = ⊤) + (hunramified : ∀ Q : FiniteExtensionFinitePlace K T, + finitePlaceRelativeRamificationIdx K M T Q = 1) : + FiniteExtensionRationalFinitePlace K M ≃ + {Q : FiniteExtensionFinitePlace K T // + finiteExtensionPlaceDegree K T (.inl Q) = Module.finrank M T ∧ + finitePlaceGalSmul K M T sigma Q = Q} := by + let e := rationalFinitePlaceEquivLift K M T hdegree + refine + { toFun := fun P => by + let x := e P + exact ⟨x.2.1, + rationalFinitePlace_lift_degree_eq_finrank_of_finrank_dvd_degree + K M T hdegree x.1 x.2.1 x.2.2, + rationalFinitePlaceLift_fixed K M T hdegree sigma x⟩ + invFun := fun Q => + ⟨finitePlaceUnder K M T Q.1, + finitePlaceUnder_degree_eq_one_of_generator_fixed K M T sigma + hgen Q.1 Q.2.2 (hunramified Q.1) Q.2.1⟩ + left_inv := ?_ + right_inv := ?_ } + · intro P + apply Subtype.ext + let x := e P + have hx1 : x.1 = P := by + change e.symm (e P) = P + exact e.symm_apply_apply P + exact x.2.2.trans (congrArg Subtype.val hx1) + · intro Q + apply Subtype.ext + let P : FiniteExtensionRationalFinitePlace K M := + ⟨finitePlaceUnder K M T Q.1, + finitePlaceUnder_degree_eq_one_of_generator_fixed K M T sigma + hgen Q.1 Q.2.2 (hunramified Q.1) Q.2.1⟩ + let x := e P + have hx1 : x.1 = P := by + change e.symm (e P) = P + exact e.symm_apply_apply P + let xFiber : FinitePlaceUnderFiber K M T P.1 := + ⟨x.2.1, x.2.2.trans (congrArg Subtype.val hx1)⟩ + let qFiber : FinitePlaceUnderFiber K M T P.1 := ⟨Q.1, rfl⟩ + have hcard := + rationalFinitePlace_fiber_card_eq_one_of_finrank_dvd_degree + K M T hdegree P + obtain ⟨z, hz⟩ := Fintype.card_eq_one_iff.mp hcard + have hxy : xFiber = qFiber := (hz xFiber).trans (hz qFiber).symm + change x.2.1 = Q.1 + exact congrArg Subtype.val hxy + +/-- Relative automorphisms over two intermediate fields induce the same +action on top finite places when their underlying top-field maps agree. -/ +theorem finitePlaceGalSmul_eq_of_apply_eq + (K M₁ M₂ T : Type*) [Field K] [DecidableEq K] + [DecidableEq (RatFunc K)] + [Field M₁] [Algebra (RatFunc K) M₁] + [FiniteDimensional (RatFunc K) M₁] + [Algebra.IsSeparable (RatFunc K) M₁] + [Field M₂] [Algebra (RatFunc K) M₂] + [FiniteDimensional (RatFunc K) M₂] + [Algebra.IsSeparable (RatFunc K) M₂] + [Field T] [Algebra (RatFunc K) T] + [FiniteDimensional (RatFunc K) T] + [Algebra.IsSeparable (RatFunc K) T] + [Algebra M₁ T] [IsScalarTower (RatFunc K) M₁ T] + [FiniteDimensional M₁ T] [IsGalois M₁ T] + [Algebra M₂ T] [IsScalarTower (RatFunc K) M₂ T] + [FiniteDimensional M₂ T] [IsGalois M₂ T] + (g₁ : T ≃ₐ[M₁] T) (g₂ : T ≃ₐ[M₂] T) + (happly : ∀ x : T, g₁ x = g₂ x) + (Q : FiniteExtensionFinitePlace K T) : + finitePlaceGalSmul K M₁ T g₁ Q = + finitePlaceGalSmul K M₂ T g₂ Q := by + let A := RatFuncFiniteIntegralClosure K T + let A₁ := RatFuncFiniteIntegralClosure K M₁ + let A₂ := RatFuncFiniteIntegralClosure K M₂ + let : Algebra K[X] M₁ := + RingHom.toAlgebra + ((algebraMap (RatFunc K) M₁).comp (algebraMap K[X] (RatFunc K))) + let : IsScalarTower K[X] (RatFunc K) M₁ := + IsScalarTower.of_algebraMap_eq' rfl + let : Algebra K[X] M₂ := + RingHom.toAlgebra + ((algebraMap (RatFunc K) M₂).comp (algebraMap K[X] (RatFunc K))) + let : IsScalarTower K[X] (RatFunc K) M₂ := + IsScalarTower.of_algebraMap_eq' rfl + let : Algebra K[X] T := + RingHom.toAlgebra + ((algebraMap (RatFunc K) T).comp (algebraMap K[X] (RatFunc K))) + let : IsScalarTower K[X] (RatFunc K) T := + IsScalarTower.of_algebraMap_eq' rfl + let : Algebra A₁ A := (finiteIntegralClosureMap K M₁ T).toAlgebra + let : SMul A₁ A := Algebra.toSMul + let : Module A₁ A := Algebra.toModule + let : IsScalarTower A₁ M₁ T := inferInstance + let : Algebra.IsIntegral K[X] A₁ := + IsIntegralClosure.isIntegral_algebra K[X] M₁ + let : IsScalarTower K[X] A₁ T := by + apply IsScalarTower.of_algebraMap_eq + intro x + change algebraMap (RatFunc K) T + (algebraMap K[X] (RatFunc K) x) = + algebraMap M₁ T + (algebraMap (RatFunc K) M₁ + (algebraMap K[X] (RatFunc K) x)) + exact IsScalarTower.algebraMap_apply (RatFunc K) M₁ T _ + let : IsScalarTower A₁ A T := + ⟨fun r t x => by + simp only [Algebra.smul_def, map_mul] + rw [show algebraMap A T (algebraMap A₁ A r) = + algebraMap A₁ T r by rfl] + ring⟩ + let : IsIntegralClosure A A₁ T := + IsIntegralClosure.tower_top (R := K[X]) + let : Algebra A₂ A := (finiteIntegralClosureMap K M₂ T).toAlgebra + let : SMul A₂ A := Algebra.toSMul + let : Module A₂ A := Algebra.toModule + let : IsScalarTower A₂ M₂ T := inferInstance + let : Algebra.IsIntegral K[X] A₂ := + IsIntegralClosure.isIntegral_algebra K[X] M₂ + let : IsScalarTower K[X] A₂ T := by + apply IsScalarTower.of_algebraMap_eq + intro x + change algebraMap (RatFunc K) T + (algebraMap K[X] (RatFunc K) x) = + algebraMap M₂ T + (algebraMap (RatFunc K) M₂ + (algebraMap K[X] (RatFunc K) x)) + exact IsScalarTower.algebraMap_apply (RatFunc K) M₂ T _ + let : IsScalarTower A₂ A T := + ⟨fun r t x => by + simp only [Algebra.smul_def, map_mul] + rw [show algebraMap A T (algebraMap A₂ A r) = + algebraMap A₂ T r by rfl] + ring⟩ + let : IsIntegralClosure A A₂ T := + IsIntegralClosure.tower_top (R := K[X]) + let : MulSemiringAction (T ≃ₐ[M₁] T) A := + finiteIntegralClosureGalAction K M₁ T + let : MulSemiringAction (T ≃ₐ[M₂] T) A := + finiteIntegralClosureGalAction K M₂ T + have hsmul (a₁ : T ≃ₐ[M₁] T) (a₂ : T ≃ₐ[M₂] T) + (ha : ∀ x : T, a₁ x = a₂ x) (x : A) : a₁ • x = a₂ • x := by + apply Subtype.ext + calc + ((a₁ • x : A) : T) = a₁ (x : T) := by + change algebraMap A T ((galRestrict A₁ M₁ T A a₁) x) = + a₁ (algebraMap A T x) + exact algebraMap_galRestrict_apply A₁ a₁ x + _ = a₂ (x : T) := ha _ + _ = ((a₂ • x : A) : T) := by + change a₂ (algebraMap A T x) = + algebraMap A T ((galRestrict A₂ M₂ T A a₂) x) + exact (algebraMap_galRestrict_apply A₂ a₂ x).symm + have happly_inv (x : T) : g₁⁻¹ x = g₂⁻¹ x := by + apply g₂.injective + calc + g₂ (g₁⁻¹ x) = g₁ (g₁⁻¹ x) := (happly _).symm + _ = x := g₁.apply_symm_apply x + _ = g₂ (g₂⁻¹ x) := (g₂.apply_symm_apply x).symm + apply HeightOneSpectrum.ext + change g₁ • Q.asIdeal = g₂ • Q.asIdeal + ext x + rw [Ideal.mem_pointwise_smul_iff_inv_smul_mem, + Ideal.mem_pointwise_smul_iff_inv_smul_mem, + hsmul g₁⁻¹ g₂⁻¹ happly_inv x] + +omit [DecidableEq C] [DecidableEq (RatFunc C)] [DecidableEq S] [DecidableEq (RatFunc S)] in +/-- Every finite place of the exact constant extension is unramified over a +Frobenius-twist fixed field, provided the twist has the full +constant-extension order. -/ +theorem frobeniusTwistField_finitePlace_ramificationIdx_eq_one + (hExact : algebraicClosure C N = + (⊥ : IntermediateField C N)) + (g : N ≃ₐ[RatFunc C] N) + (hdiv : Nat.card (N ≃ₐ[RatFunc C] N) ∣ Module.finrank C S) : + let : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : SMul (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toSMul + let : Module (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toModule + let : FiniteDimensional (RatFunc C) + (ExactConstantExtension C N S) := + finiteDimensional_exactConstantExtension_over_baseRatFunc + C S N hExact + let : Algebra.IsSeparable (RatFunc C) + (ExactConstantExtension C N S) := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + let F := exactConstantExtensionFrobeniusTwistField + C (RatFunc C) N S hExact g + let : Algebra (RatFunc C) F := + SubalgebraClass.toAlgebra F.toSubalgebra + let : SMul (RatFunc C) F := Algebra.toSMul + let : Module (RatFunc C) F := Algebra.toModule + let : FiniteDimensional (RatFunc C) F := + finiteDimensional_frobeniusTwistField_over_ratFunc C N S hExact g + let : Algebra.IsSeparable (RatFunc C) F := + isSeparable_frobeniusTwistField_over_ratFunc C N S hExact g + let : Algebra F (ExactConstantExtension C N S) := F.toAlgebra + let : SMul F (ExactConstantExtension C N S) := Algebra.toSMul + let : Module F (ExactConstantExtension C N S) := Algebra.toModule + let : IsScalarTower (RatFunc C) F + (ExactConstantExtension C N S) := inferInstance + let : FiniteDimensional F (ExactConstantExtension C N S) := + finiteDimensional_exactConstantExtension_over_frobeniusTwistField + C (RatFunc C) N S hExact g + let : IsGalois F (ExactConstantExtension C N S) := + isGalois_exactConstantExtension_over_frobeniusTwistField + C (RatFunc C) N S hExact g + ∀ Q : FiniteExtensionFinitePlace C (ExactConstantExtension C N S), + finitePlaceRelativeRamificationIdx C F + (ExactConstantExtension C N S) Q = 1 := by + intro model0 model1 model2 model3 model4 model5 F model7 model8 + model9 model10 model11 model12 model13 model14 model15 model16 model17 + let T := ExactConstantExtension C N S + let : Algebra C[X] T := + RingHom.toAlgebra + ((algebraMap (RatFunc C) T).comp (algebraMap C[X] (RatFunc C))) + let : IsScalarTower C[X] (RatFunc C) T := + IsScalarTower.of_algebraMap_eq' rfl + let A := RatFuncFiniteIntegralClosure C T + let AF := RatFuncFiniteIntegralClosure C F + let : Algebra AF A := (finiteIntegralClosureMap C F T).toAlgebra + let : SMul AF A := Algebra.toSMul + let : Module AF A := Algebra.toModule + let : Algebra S A := + exactConstantExtensionFiniteIntegralClosureConstantAlgebra C N S hExact + let : IsScalarTower AF F T := inferInstance + let : Algebra.IsIntegral C[X] AF := + IsIntegralClosure.isIntegral_algebra C[X] F + let : IsScalarTower C[X] AF T := by + apply IsScalarTower.of_algebraMap_eq + intro x + change algebraMap (RatFunc C) T + (algebraMap C[X] (RatFunc C) x) = + algebraMap F T + (algebraMap (RatFunc C) F + (algebraMap C[X] (RatFunc C) x)) + exact IsScalarTower.algebraMap_apply (RatFunc C) F T _ + let : IsScalarTower AF A T := + ⟨fun r t x => by + simp only [Algebra.smul_def, map_mul] + rw [show algebraMap A T (algebraMap AF A r) = + algebraMap AF T r by rfl] + ring⟩ + let : IsIntegralClosure A AF T := + IsIntegralClosure.tower_top (R := C[X]) + let : IsDedekindDomain A := inferInstance + let : MulSemiringAction (T ≃ₐ[F] T) A := + finiteIntegralClosureGalAction C F T + intro Q + let : Q.asIdeal.IsMaximal := Q.isMaximal + rw [← finitePlaceInertiaGroup_card_eq_ramificationIdx C F T Q] + have hInertia : finitePlaceInertiaGroup C F T Q = ⊥ := by + ext tau + constructor + · intro htau + rw [Subgroup.mem_bot] + let sigma := exactConstantExtensionFrobeniusTwist + C (RatFunc C) N S hExact g + let H := exactConstantExtensionFrobeniusTwistSubgroup + C (RatFunc C) N S hExact g + let e := IntermediateField.subgroupEquivAlgEquiv H + let h : H := e.symm tau + have he_apply (z : H) (x : T) : e z x = z.1 x := by + change z.1.toEquiv x = z.1 x + rfl + have htau_apply (x : T) : tau x = h.1 x := by + calc + tau x = e h x := by + exact congrArg (fun z : T ≃ₐ[F] T => z x) + (e.apply_symm_apply tau).symm + _ = h.1 x := he_apply h x + obtain ⟨k, hk⟩ := Subgroup.mem_zpowers_iff.mp h.2 + let frob := FiniteField.frobeniusAlgEquivOfAlgebraic C S + have hfrob_apply (s : S) : (frob ^ k) s = s := by + let a : A := algebraMap S A s + have haction : tau • a = algebraMap S A ((frob ^ k) s) := by + apply Subtype.ext + calc + ((tau • a : A) : T) = tau (a : T) := by + change algebraMap A T ((galRestrict AF F T A tau) a) = + tau (algebraMap A T a) + exact algebraMap_galRestrict_apply AF tau a + _ = h.1 (a : T) := htau_apply (a : T) + _ = h.1 (Algebra.TensorProduct.includeLeft + (R := C) (S := C) (A := S) (B := N) s) := by + exact congrArg h.1 + (exactConstantExtensionFiniteIntegralClosure_algebraMap_val + C N S hExact s) + _ = (sigma ^ k) (Algebra.TensorProduct.includeLeft + (R := C) (S := C) (A := S) (B := N) s) := by + exact congrArg + (fun z : T ≃ₐ[RatFunc C] T => + z (Algebra.TensorProduct.includeLeft + (R := C) (S := C) (A := S) (B := N) s)) + hk |>.symm + _ = Algebra.TensorProduct.includeLeft + (R := C) (S := C) (A := S) (B := N) + ((frob ^ k) s) := by + exact exactConstantExtensionFrobeniusTwist_zpow_includeLeft + C N S hExact g k s + _ = ((algebraMap S A ((frob ^ k) s) : A) : T) := by + exact + (exactConstantExtensionFiniteIntegralClosure_algebraMap_val + C N S hExact ((frob ^ k) s)).symm + have hmem : tau • a - a ∈ Q.asIdeal := htau a + have hmem' : algebraMap S A ((frob ^ k) s - s) ∈ Q.asIdeal := by + have heq : algebraMap S A ((frob ^ k) s - s) = tau • a - a := by + calc + algebraMap S A ((frob ^ k) s - s) = + algebraMap S A ((frob ^ k) s) - algebraMap S A s := + map_sub (algebraMap S A) _ _ + _ = algebraMap S A ((frob ^ k) s) - a := rfl + _ = tau • a - a := congrArg (fun z : A => z - a) haction.symm + exact heq.symm ▸ hmem + let J : Ideal S := Q.asIdeal.comap (algebraMap S A) + have hmemJ : (frob ^ k) s - s ∈ J := hmem' + have hJne : J ≠ ⊤ := by + exact Ideal.comap_ne_top (algebraMap S A) Q.isPrime.ne_top + have hJ : J = ⊥ := (Ideal.eq_bot_or_top J).resolve_right hJne + have hs : (frob ^ k) s - s = 0 := by + rw [hJ] at hmemJ + simpa only [Ideal.mem_bot] using hmemJ + exact sub_eq_zero.mp hs + have hFrob : frob ^ k = 1 := by + ext s + exact hfrob_apply s + have hkdiv : (Module.finrank C S : ℤ) ∣ k := by + rw [← FiniteField.orderOf_frobeniusAlgEquivOfAlgebraic C S] + exact orderOf_dvd_iff_zpow_eq_one.mpr hFrob + have hsigma : sigma ^ k = 1 := by + rw [← orderOf_dvd_iff_zpow_eq_one, + orderOf_exactConstantExtensionFrobeniusTwist + C (RatFunc C) N S hExact g hdiv] + exact hkdiv + have hambient : (h.1 : T ≃ₐ[RatFunc C] T) = 1 := by + calc + (h.1 : T ≃ₐ[RatFunc C] T) = sigma ^ k := hk.symm + _ = 1 := hsigma + have hh : h = 1 := Subtype.ext hambient + exact (e.apply_symm_apply tau).symm.trans + ((congrArg e hh).trans (map_one e)) + · intro htau + rw [Subgroup.mem_bot] at htau + simp [htau] + rw [hInertia] + exact Nat.card_unique + +omit [DecidableEq S] [DecidableEq (RatFunc S)] in +/-- A top finite place of degree `[S : C]` fixed by the canonical twist +descends to a rational finite place of the Frobenius-twist fixed field. -/ +theorem frobeniusTwistField_fixed_finitePlace_under_degree_eq_one + (hExact : algebraicClosure C N = + (⊥ : IntermediateField C N)) + (g : N ≃ₐ[RatFunc C] N) + (hdiv : Nat.card (N ≃ₐ[RatFunc C] N) ∣ Module.finrank C S) : + let : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : SMul (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toSMul + let : Module (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toModule + let : FiniteDimensional (RatFunc C) + (ExactConstantExtension C N S) := + finiteDimensional_exactConstantExtension_over_baseRatFunc + C S N hExact + let : Algebra.IsSeparable (RatFunc C) + (ExactConstantExtension C N S) := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + let F := exactConstantExtensionFrobeniusTwistField + C (RatFunc C) N S hExact g + let : Algebra (RatFunc C) F := + SubalgebraClass.toAlgebra F.toSubalgebra + let : SMul (RatFunc C) F := Algebra.toSMul + let : Module (RatFunc C) F := Algebra.toModule + let : FiniteDimensional (RatFunc C) F := + finiteDimensional_frobeniusTwistField_over_ratFunc C N S hExact g + let : Algebra.IsSeparable (RatFunc C) F := + isSeparable_frobeniusTwistField_over_ratFunc C N S hExact g + let : Algebra F (ExactConstantExtension C N S) := F.toAlgebra + let : SMul F (ExactConstantExtension C N S) := Algebra.toSMul + let : Module F (ExactConstantExtension C N S) := Algebra.toModule + let : IsScalarTower (RatFunc C) F + (ExactConstantExtension C N S) := inferInstance + let : FiniteDimensional F (ExactConstantExtension C N S) := + finiteDimensional_exactConstantExtension_over_frobeniusTwistField + C (RatFunc C) N S hExact g + let : IsGalois F (ExactConstantExtension C N S) := + isGalois_exactConstantExtension_over_frobeniusTwistField + C (RatFunc C) N S hExact g + ∀ Q : FiniteExtensionFinitePlace C (ExactConstantExtension C N S), + finiteExtensionPlaceDegree C (ExactConstantExtension C N S) (.inl Q) = + Module.finrank C S → + finitePlaceGalSmul C F (ExactConstantExtension C N S) + (exactConstantExtensionFrobeniusTwistOverFixedField + C N S hExact g) Q = Q → + finiteExtensionPlaceDegree C F + (.inl (finitePlaceUnder C F + (ExactConstantExtension C N S) Q)) = 1 := by + let T := ExactConstantExtension C N S + let : Field T := exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) T := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : SMul (RatFunc C) T := Algebra.toSMul + let : Module (RatFunc C) T := Algebra.toModule + let : FiniteDimensional (RatFunc C) T := + finiteDimensional_exactConstantExtension_over_baseRatFunc C S N hExact + let : Algebra.IsSeparable (RatFunc C) T := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + let F := exactConstantExtensionFrobeniusTwistField + C (RatFunc C) N S hExact g + let : Algebra (RatFunc C) F := + SubalgebraClass.toAlgebra F.toSubalgebra + let : SMul (RatFunc C) F := Algebra.toSMul + let : Module (RatFunc C) F := Algebra.toModule + let : FiniteDimensional (RatFunc C) F := + finiteDimensional_frobeniusTwistField_over_ratFunc C N S hExact g + let : Algebra.IsSeparable (RatFunc C) F := + isSeparable_frobeniusTwistField_over_ratFunc C N S hExact g + let : Algebra F T := F.toAlgebra + let : SMul F T := Algebra.toSMul + let : Module F T := Algebra.toModule + let : IsScalarTower (RatFunc C) F T := inferInstance + let : FiniteDimensional F T := + finiteDimensional_exactConstantExtension_over_frobeniusTwistField + C (RatFunc C) N S hExact g + let : IsGalois F T := + isGalois_exactConstantExtension_over_frobeniusTwistField + C (RatFunc C) N S hExact g + dsimp only + intro Q hdegree hfixed + apply finitePlaceUnder_degree_eq_one_of_generator_fixed + C F T + (exactConstantExtensionFrobeniusTwistOverFixedField C N S hExact g) + (exactConstantExtensionFrobeniusTwistOverFixedField_zpowers_eq_top + C N S hExact g) + Q hfixed + · exact frobeniusTwistField_finitePlace_ramificationIdx_eq_one + C N S hExact g hdiv Q + · calc + finiteExtensionPlaceDegree C T (.inl Q) = Module.finrank C S := hdegree + _ = Module.finrank F T := + (finrank_exactConstantExtension_over_frobeniusTwistField + C (RatFunc C) N S hExact g hdiv).symm + +omit [Finite S] [DecidableEq S] [DecidableEq (RatFunc S)] in +/-- The canonical twist over its fixed field and the ambient twist over +`C(X)` induce exactly the same action on finite places. -/ +theorem exactConstantExtensionFrobeniusTwist_finitePlaceGalSmul_eq_overFixedField + [IsGalois (RatFunc C) N] + (hExact : algebraicClosure C N = + (⊥ : IntermediateField C N)) + (g : N ≃ₐ[RatFunc C] N) : + let : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : SMul (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toSMul + let : Module (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toModule + let : DistribMulAction (RatFunc C) + (ExactConstantExtension C N S) := Module.toDistribMulAction + let : MulAction (RatFunc C) (ExactConstantExtension C N S) := + DistribMulAction.toMulAction + let : FiniteDimensional (RatFunc C) + (ExactConstantExtension C N S) := + finiteDimensional_exactConstantExtension_over_baseRatFunc + C S N hExact + let : IsGalois (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtension_isGalois C (RatFunc C) N S hExact + let : Algebra.IsSeparable (RatFunc C) + (ExactConstantExtension C N S) := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + let F := exactConstantExtensionFrobeniusTwistField + C (RatFunc C) N S hExact g + let : Algebra (RatFunc C) F := + SubalgebraClass.toAlgebra F.toSubalgebra + let : SMul (RatFunc C) F := Algebra.toSMul + let : Module (RatFunc C) F := Algebra.toModule + let : FiniteDimensional (RatFunc C) F := + finiteDimensional_frobeniusTwistField_over_ratFunc C N S hExact g + let : Algebra.IsSeparable (RatFunc C) F := + isSeparable_frobeniusTwistField_over_ratFunc C N S hExact g + let : Algebra F (ExactConstantExtension C N S) := F.toAlgebra + let : SMul F (ExactConstantExtension C N S) := Algebra.toSMul + let : Module F (ExactConstantExtension C N S) := Algebra.toModule + let : IsScalarTower (RatFunc C) F + (ExactConstantExtension C N S) := inferInstance + let : FiniteDimensional F (ExactConstantExtension C N S) := + finiteDimensional_exactConstantExtension_over_frobeniusTwistField + C (RatFunc C) N S hExact g + let : IsGalois F (ExactConstantExtension C N S) := + isGalois_exactConstantExtension_over_frobeniusTwistField + C (RatFunc C) N S hExact g + ∀ Q : FiniteExtensionFinitePlace C (ExactConstantExtension C N S), + finitePlaceGalSmul C F (ExactConstantExtension C N S) + (exactConstantExtensionFrobeniusTwistOverFixedField + C N S hExact g) Q = + finitePlaceGalSmul C (RatFunc C) (ExactConstantExtension C N S) + (exactConstantExtensionFrobeniusTwist + C (RatFunc C) N S hExact g) Q := by + let T := ExactConstantExtension C N S + let : Field T := exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) T := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : SMul (RatFunc C) T := Algebra.toSMul + let : Module (RatFunc C) T := Algebra.toModule + let : DistribMulAction (RatFunc C) T := Module.toDistribMulAction + let : MulAction (RatFunc C) T := DistribMulAction.toMulAction + let : FiniteDimensional (RatFunc C) T := + finiteDimensional_exactConstantExtension_over_baseRatFunc C S N hExact + let : IsGalois (RatFunc C) T := + exactConstantExtension_isGalois C (RatFunc C) N S hExact + let : Algebra.IsSeparable (RatFunc C) T := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + let F := exactConstantExtensionFrobeniusTwistField + C (RatFunc C) N S hExact g + let : Algebra (RatFunc C) F := + SubalgebraClass.toAlgebra F.toSubalgebra + let : SMul (RatFunc C) F := Algebra.toSMul + let : Module (RatFunc C) F := Algebra.toModule + let : FiniteDimensional (RatFunc C) F := + finiteDimensional_frobeniusTwistField_over_ratFunc C N S hExact g + let : Algebra.IsSeparable (RatFunc C) F := + isSeparable_frobeniusTwistField_over_ratFunc C N S hExact g + let : Algebra F T := F.toAlgebra + let : SMul F T := Algebra.toSMul + let : Module F T := Algebra.toModule + let : IsScalarTower (RatFunc C) F T := inferInstance + let : FiniteDimensional F T := + finiteDimensional_exactConstantExtension_over_frobeniusTwistField + C (RatFunc C) N S hExact g + let : IsGalois F T := + isGalois_exactConstantExtension_over_frobeniusTwistField + C (RatFunc C) N S hExact g + dsimp only + intro Q + apply finitePlaceGalSmul_eq_of_apply_eq C F (RatFunc C) T + intro x + exact exactConstantExtensionFrobeniusTwistOverFixedField_apply + C N S hExact g x + +/-- Ambient fixedness by the Frobenius twist is therefore the exact +fixedness condition needed for descent to a rational twist-field place. -/ +theorem frobeniusTwistField_ambientFixed_finitePlace_under_degree_eq_one + [IsGalois (RatFunc C) N] + (hExact : algebraicClosure C N = + (⊥ : IntermediateField C N)) + (g : N ≃ₐ[RatFunc C] N) + (hdiv : Nat.card (N ≃ₐ[RatFunc C] N) ∣ Module.finrank C S) : + let : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : SMul (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toSMul + let : Module (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toModule + let : DistribMulAction (RatFunc C) + (ExactConstantExtension C N S) := Module.toDistribMulAction + let : MulAction (RatFunc C) (ExactConstantExtension C N S) := + DistribMulAction.toMulAction + let : FiniteDimensional (RatFunc C) + (ExactConstantExtension C N S) := + finiteDimensional_exactConstantExtension_over_baseRatFunc + C S N hExact + let : Algebra.IsSeparable (RatFunc C) + (ExactConstantExtension C N S) := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + let : IsGalois (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtension_isGalois C (RatFunc C) N S hExact + let F := exactConstantExtensionFrobeniusTwistField + C (RatFunc C) N S hExact g + let : Algebra (RatFunc C) F := + SubalgebraClass.toAlgebra F.toSubalgebra + let : SMul (RatFunc C) F := Algebra.toSMul + let : Module (RatFunc C) F := Algebra.toModule + let : FiniteDimensional (RatFunc C) F := + finiteDimensional_frobeniusTwistField_over_ratFunc C N S hExact g + let : Algebra.IsSeparable (RatFunc C) F := + isSeparable_frobeniusTwistField_over_ratFunc C N S hExact g + let : Algebra F (ExactConstantExtension C N S) := F.toAlgebra + let : SMul F (ExactConstantExtension C N S) := Algebra.toSMul + let : Module F (ExactConstantExtension C N S) := Algebra.toModule + let : IsScalarTower (RatFunc C) F + (ExactConstantExtension C N S) := inferInstance + let : FiniteDimensional F (ExactConstantExtension C N S) := + finiteDimensional_exactConstantExtension_over_frobeniusTwistField + C (RatFunc C) N S hExact g + let : IsGalois F (ExactConstantExtension C N S) := + isGalois_exactConstantExtension_over_frobeniusTwistField + C (RatFunc C) N S hExact g + ∀ Q : FiniteExtensionFinitePlace C (ExactConstantExtension C N S), + finiteExtensionPlaceDegree C (ExactConstantExtension C N S) (.inl Q) = + Module.finrank C S → + finitePlaceGalSmul C (RatFunc C) (ExactConstantExtension C N S) + (exactConstantExtensionFrobeniusTwist + C (RatFunc C) N S hExact g) Q = Q → + finiteExtensionPlaceDegree C F + (.inl (finitePlaceUnder C F + (ExactConstantExtension C N S) Q)) = 1 := by + intro model0 model1 model2 model3 model4 model5 model6 model7 model8 + F model10 model11 model12 model13 model14 model15 model16 model17 model18 model19 model20 + let T := ExactConstantExtension C N S + intro Q hdegree hfixed + apply frobeniusTwistField_fixed_finitePlace_under_degree_eq_one + C N S hExact g hdiv Q hdegree + rw [exactConstantExtensionFrobeniusTwist_finitePlaceGalSmul_eq_overFixedField + C N S hExact g Q] + exact hfixed + +/-- Rational finite places of the Frobenius-twist field are exactly the +degree-`[S : C]` top finite places fixed by the ambient Frobenius twist. -/ +noncomputable def + frobeniusTwistField_rationalFinitePlace_equiv_ambientFixedFinitePlace + [IsGalois (RatFunc C) N] + (hExact : algebraicClosure C N = + (⊥ : IntermediateField C N)) + (g : N ≃ₐ[RatFunc C] N) + (hdiv : Nat.card (N ≃ₐ[RatFunc C] N) ∣ Module.finrank C S) : + let : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : SMul (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toSMul + let : Module (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toModule + let : DistribMulAction (RatFunc C) + (ExactConstantExtension C N S) := Module.toDistribMulAction + let : MulAction (RatFunc C) (ExactConstantExtension C N S) := + DistribMulAction.toMulAction + let : FiniteDimensional (RatFunc C) + (ExactConstantExtension C N S) := + finiteDimensional_exactConstantExtension_over_baseRatFunc + C S N hExact + let : IsGalois (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtension_isGalois C (RatFunc C) N S hExact + let : Algebra.IsSeparable (RatFunc C) + (ExactConstantExtension C N S) := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + let F := exactConstantExtensionFrobeniusTwistField + C (RatFunc C) N S hExact g + let : Algebra (RatFunc C) F := + SubalgebraClass.toAlgebra F.toSubalgebra + let : SMul (RatFunc C) F := Algebra.toSMul + let : Module (RatFunc C) F := Algebra.toModule + let : FiniteDimensional (RatFunc C) F := + finiteDimensional_frobeniusTwistField_over_ratFunc C N S hExact g + let : Algebra.IsSeparable (RatFunc C) F := + isSeparable_frobeniusTwistField_over_ratFunc C N S hExact g + let : Algebra F (ExactConstantExtension C N S) := F.toAlgebra + let : SMul F (ExactConstantExtension C N S) := Algebra.toSMul + let : Module F (ExactConstantExtension C N S) := Algebra.toModule + let : IsScalarTower (RatFunc C) F + (ExactConstantExtension C N S) := inferInstance + let : FiniteDimensional F (ExactConstantExtension C N S) := + finiteDimensional_exactConstantExtension_over_frobeniusTwistField + C (RatFunc C) N S hExact g + let : IsGalois F (ExactConstantExtension C N S) := + isGalois_exactConstantExtension_over_frobeniusTwistField + C (RatFunc C) N S hExact g + FiniteExtensionRationalFinitePlace C F ≃ + {Q : FiniteExtensionFinitePlace C (ExactConstantExtension C N S) // + finiteExtensionPlaceDegree C (ExactConstantExtension C N S) (.inl Q) = + Module.finrank C S ∧ + finitePlaceGalSmul C (RatFunc C) (ExactConstantExtension C N S) + (exactConstantExtensionFrobeniusTwist + C (RatFunc C) N S hExact g) Q = Q} := by + let T := ExactConstantExtension C N S + let : Field T := exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) T := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : SMul (RatFunc C) T := Algebra.toSMul + let : Module (RatFunc C) T := Algebra.toModule + let : DistribMulAction (RatFunc C) T := Module.toDistribMulAction + let : MulAction (RatFunc C) T := DistribMulAction.toMulAction + let : FiniteDimensional (RatFunc C) T := + finiteDimensional_exactConstantExtension_over_baseRatFunc C S N hExact + let : IsGalois (RatFunc C) T := + exactConstantExtension_isGalois C (RatFunc C) N S hExact + let : Algebra.IsSeparable (RatFunc C) T := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + let F := exactConstantExtensionFrobeniusTwistField + C (RatFunc C) N S hExact g + let : Algebra (RatFunc C) F := + SubalgebraClass.toAlgebra F.toSubalgebra + let : SMul (RatFunc C) F := Algebra.toSMul + let : Module (RatFunc C) F := Algebra.toModule + let : FiniteDimensional (RatFunc C) F := + finiteDimensional_frobeniusTwistField_over_ratFunc C N S hExact g + let : Algebra.IsSeparable (RatFunc C) F := + isSeparable_frobeniusTwistField_over_ratFunc C N S hExact g + let : Algebra F T := F.toAlgebra + let : SMul F T := Algebra.toSMul + let : Module F T := Algebra.toModule + let : IsScalarTower (RatFunc C) F T := inferInstance + let : FiniteDimensional F T := + finiteDimensional_exactConstantExtension_over_frobeniusTwistField + C (RatFunc C) N S hExact g + let : IsGalois F T := + isGalois_exactConstantExtension_over_frobeniusTwistField + C (RatFunc C) N S hExact g + dsimp only + have hfinrank : Module.finrank F T = Module.finrank C S := + finrank_exactConstantExtension_over_frobeniusTwistField + C (RatFunc C) N S hExact g hdiv + have hdegree : ∀ Q : FiniteExtensionFinitePlace C T, + Module.finrank F T ∣ finiteExtensionPlaceDegree C T (.inl Q) := by + intro Q + rw [hfinrank] + exact exactConstantExtensionFinitePlace_finrank_constants_dvd_degree + C N S hExact Q + let sigmaF := + exactConstantExtensionFrobeniusTwistOverFixedField C N S hExact g + let eFixed := rationalFinitePlaceEquivGeneratorFixedPlace + C F T hdegree sigmaF + (exactConstantExtensionFrobeniusTwistOverFixedField_zpowers_eq_top + C N S hExact g) + (frobeniusTwistField_finitePlace_ramificationIdx_eq_one + C N S hExact g hdiv) + let eCompare : + {Q : FiniteExtensionFinitePlace C T // + finiteExtensionPlaceDegree C T (.inl Q) = Module.finrank F T ∧ + finitePlaceGalSmul C F T sigmaF Q = Q} ≃ + {Q : FiniteExtensionFinitePlace C T // + finiteExtensionPlaceDegree C T (.inl Q) = Module.finrank C S ∧ + finitePlaceGalSmul C (RatFunc C) T + (exactConstantExtensionFrobeniusTwist + C (RatFunc C) N S hExact g) Q = Q} := + { toFun := fun Q => ⟨Q.1, + Q.2.1.trans hfinrank, + (exactConstantExtensionFrobeniusTwist_finitePlaceGalSmul_eq_overFixedField + C N S hExact g Q.1).symm.trans Q.2.2⟩ + invFun := fun Q => ⟨Q.1, + Q.2.1.trans hfinrank.symm, + (exactConstantExtensionFrobeniusTwist_finitePlaceGalSmul_eq_overFixedField + C N S hExact g Q.1).trans Q.2.2⟩ + left_inv := fun Q => Subtype.ext rfl + right_inv := fun Q => Subtype.ext rfl } + exact eFixed.trans eCompare + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionFrobeniusTwistGenus.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionFrobeniusTwistGenus.lean new file mode 100644 index 0000000000..76e74f4f09 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionFrobeniusTwistGenus.lean @@ -0,0 +1,102 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionDifferentCoefficient +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionFrobeniusTwistMultiplication +public import LeanPool.MarkoffModP.RiemannRoch.CoordinateFree.AlgEquiv + +/-! +# Genus of Frobenius-twist fixed fields + +Extending the constants of a Frobenius-twist fixed field gives the common +exact constant extension. Genus invariance under exact extension of finite +constants therefore identifies the genus of every twist with the genus of +the original function field. This is Proposition 5.2.8(b) in the form used +by the uniform Stepanov estimate. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +noncomputable section + + +variable (C S N : Type*) [Field C] [Field S] [Field N] + [Fintype C] [Finite S] + [DecidableEq C] [DecidableEq S] + [DecidableEq (RatFunc C)] [DecidableEq (RatFunc S)] + [Algebra (RatFunc C) N] [FiniteDimensional (RatFunc C) N] + [IsGalois (RatFunc C) N] + [Algebra C S] [FiniteDimensional C S] [IsGalois C S] + +local instance twistGenusBaseConstantAlgebra : Algebra C N := + bridgeBaseConstantAlgebra C N + +local instance twistGenusBaseConstantTower : + IsScalarTower C (RatFunc C) N := + IsScalarTower.of_algebraMap_eq' rfl + +omit [DecidableEq C] [DecidableEq S] [DecidableEq (RatFunc C)] [DecidableEq (RatFunc S)] in +/-- Every canonical Frobenius-twist fixed field has the genus of the +original exact-constant Galois function field. The equality is independent +of the auxiliary constant extension. -/ +theorem genus_frobeniusTwistField_eq_original + (hExact : algebraicClosure C N = + (⊥ : IntermediateField C N)) + (hdiv : Nat.card (N ≃ₐ[RatFunc C] N) ∣ Module.finrank C S) + (g : N ≃ₐ[RatFunc C] N) : + let T := ExactConstantExtension C N S + letI : Field T := exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) T := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let F := exactConstantExtensionFrobeniusTwistField + C (RatFunc C) N S hExact g + letI : Algebra (RatFunc C) F := SubalgebraClass.toAlgebra F.toSubalgebra + FunctionField.genus C F = FunctionField.genus C N := by + let T := ExactConstantExtension C N S + let : Field T := exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) T := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : SMul (RatFunc C) T := Algebra.toSMul + let : Module (RatFunc C) T := Algebra.toModule + let F := exactConstantExtensionFrobeniusTwistField + C (RatFunc C) N S hExact g + let : Algebra (RatFunc C) F := SubalgebraClass.toAlgebra F.toSubalgebra + let : SMul (RatFunc C) F := Algebra.toSMul + let : Module (RatFunc C) F := Algebra.toModule + let : FiniteDimensional (RatFunc C) F := + finiteDimensional_frobeniusTwistField_over_ratFunc C N S hExact g + let : Algebra.IsSeparable (RatFunc C) F := + isSeparable_frobeniusTwistField_over_ratFunc C N S hExact g + let : Algebra C F := Algebra.restrictScalars C (RatFunc C) F + let : IsScalarTower C (RatFunc C) F := + IsScalarTower.of_algebraMap_eq' rfl + have hExactF : algebraicClosure C F = + (⊥ : IntermediateField C F) := + exactConstantExtensionFrobeniusTwistField_algebraicClosure_eq_bot + C (RatFunc C) N S hExact g + let U := ExactConstantExtension C F S + let : Field U := exactConstantExtensionField C F S hExactF + let : Algebra S U := Algebra.TensorProduct.leftAlgebra + let : Algebra S T := Algebra.TensorProduct.leftAlgebra + let e : U ≃ₐ[S] T := + exactConstantExtensionFrobeniusTwistMultiplicationAlgEquivOverConstants + C (RatFunc C) N S hExact g hdiv + have hF : FunctionField.genus S U = FunctionField.genus C F := + exactConstantExtension_genus_eq C S F hExactF + have hN : FunctionField.genus S T = FunctionField.genus C N := + exactConstantExtension_genus_eq C S N hExact + calc + FunctionField.genus C F = FunctionField.genus S U := hF.symm + _ = FunctionField.genus S T := FunctionField.genus_eq_of_algEquiv e + _ = FunctionField.genus C N := hN + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionFrobeniusTwistInfinityPlaceDescent.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionFrobeniusTwistInfinityPlaceDescent.lean new file mode 100644 index 0000000000..792eab5379 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionFrobeniusTwistInfinityPlaceDescent.lean @@ -0,0 +1,778 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.ConstantExtensionInfinityPlaceDegreeTower +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionFrobeniusTwistFinitePlaceUnramified + +/-! +# Infinity places of Frobenius-twist fields + +This file proves the infinity-place counterpart of the finite-place descent +used in Frobenius-coset averaging. The generic part first identifies rational +infinity places of an intermediate function field with the unique top places +above them. Under unramifiedness, a top infinity place of maximal possible +degree fixed by a generator of the relative Galois group descends to a +rational infinity place. + +For an exact constant extension, every top infinity-place degree is divisible +by the constant-field degree. This is obtained from the reciprocal +normalization presentation, whose equivalence with the actual infinity-place +type is already exhaustive. +-/ + +@[expose] public section + +open scoped Pointwise Polynomial TensorProduct + +namespace BGS.HasseWeil + +noncomputable section + +open BGS.CorvajaZannier + + +section GenericInfinityDescent + +variable (K M T : Type*) [Field K] [DecidableEq K] + [DecidableEq (RatFunc K)] [Field M] [Field T] + [Algebra (RatFunc K) M] [FiniteDimensional (RatFunc K) M] + [Algebra.IsSeparable (RatFunc K) M] + [Algebra (RatFunc K) T] [FiniteDimensional (RatFunc K) T] + [Algebra.IsSeparable (RatFunc K) T] + [Algebra M T] [IsScalarTower (RatFunc K) M T] + [FiniteDimensional M T] [IsGalois M T] + +/-- If every top infinity-place degree is divisible by the relative field +degree, then every rational infinity place downstairs has a unique top place +above it. -/ +theorem rationalInfinityPlace_fiber_card_eq_one_of_finrank_dvd_degree + (hdegree : ∀ Q : FiniteExtensionInfinityPlace K T, + Module.finrank M T ∣ finiteExtensionPlaceDegree K T (.inr Q)) + (P : FiniteExtensionRationalInfinityPlace K M) : + Fintype.card (InfinityPlaceUnderFiber K M T P.1) = 1 := by + obtain ⟨Q, hQ⟩ := infinityPlaceUnder_surjective K M T P.1 + let Q₀ : InfinityPlaceUnderFiber K M T P.1 := ⟨Q, hQ⟩ + have hplaceDegree := + finiteExtensionPlaceDegree_inr_eq_mul_relativeInertiaDeg K M T Q + have hrelative : infinityPlaceRelativeInertiaDeg K M T Q = + finiteExtensionPlaceDegree K T (.inr Q) := by + rw [hQ] at hplaceDegree + simpa [P.2] using hplaceDegree.symm + have hm_dvd_f : Module.finrank M T ∣ + infinityPlaceRelativeInertiaDeg K M T Q := by + rw [hrelative] + exact hdegree Q + have hfiber := + infinityPlaceUnderFiber_card_mul_ramificationIdx_mul_inertiaDeg_eq_field_finrank + K M T P.1 Q₀ + dsimp [Q₀] at hfiber + have hf_dvd_m : infinityPlaceRelativeInertiaDeg K M T Q ∣ + Module.finrank M T := by + rw [← hfiber] + exact dvd_mul_left _ _ + have hf : infinityPlaceRelativeInertiaDeg K M T Q = + Module.finrank M T := Nat.dvd_antisymm hf_dvd_m hm_dvd_f + have hmpos : 0 < Module.finrank M T := Module.finrank_pos + have hproduct : + Fintype.card (InfinityPlaceUnderFiber K M T P.1) * + infinityPlaceRelativeRamificationIdx K M T Q = 1 := by + apply Nat.eq_of_mul_eq_mul_right hmpos + simpa [Nat.mul_assoc, hf] using hfiber + exact Nat.eq_one_of_dvd_one + ⟨infinityPlaceRelativeRamificationIdx K M T Q, hproduct.symm⟩ + +/-- Under the same degree-divisibility hypothesis, every relative Galois +automorphism fixes every infinity place above a rational infinity place. -/ +theorem infinityPlaceGalSmul_eq_self_over_rationalInfinityPlace_of_finrank_dvd_degree + (hdegree : ∀ Q : FiniteExtensionInfinityPlace K T, + Module.finrank M T ∣ finiteExtensionPlaceDegree K T (.inr Q)) + (P : FiniteExtensionRationalInfinityPlace K M) + (Q : FiniteExtensionInfinityPlace K T) + (hQ : infinityPlaceUnder K M T Q = P.1) + (sigma : T ≃ₐ[M] T) : + infinityPlaceGalSmul K M T sigma Q = Q := by + let := infinityIntegralClosureGalAction K M T + let := infinityPlaceUnderFiberGalAction K M T P.1 + have hcard := + rationalInfinityPlace_fiber_card_eq_one_of_finrank_dvd_degree + K M T hdegree P + obtain ⟨Q₀, hQ₀⟩ := Fintype.card_eq_one_iff.mp hcard + let x : InfinityPlaceUnderFiber K M T P.1 := ⟨Q, hQ⟩ + let y : InfinityPlaceUnderFiber K M T P.1 := + ⟨infinityPlaceGalSmul K M T sigma Q, by + rw [infinityPlaceUnder_infinityPlaceGalSmul, hQ]⟩ + have hxy : x = y := (hQ₀ x).trans (hQ₀ y).symm + exact congrArg Subtype.val hxy |>.symm + +/-- A rational infinity place together with its top infinity-place lift. -/ +abbrev RationalInfinityPlaceLift := + Σ P : FiniteExtensionRationalInfinityPlace K M, + InfinityPlaceUnderFiber K M T P.1 + +/-- Projection from rational infinity-place lifts is an equivalence when +every top degree is divisible by the relative degree. -/ +noncomputable def rationalInfinityPlaceEquivLift + (hdegree : ∀ Q : FiniteExtensionInfinityPlace K T, + Module.finrank M T ∣ finiteExtensionPlaceDegree K T (.inr Q)) : + FiniteExtensionRationalInfinityPlace K M ≃ + RationalInfinityPlaceLift K M T := by + let projection : RationalInfinityPlaceLift K M T → + FiniteExtensionRationalInfinityPlace K M := fun x => x.1 + refine (Equiv.ofBijective projection ⟨?_, ?_⟩).symm + · rintro ⟨P, Q⟩ ⟨P', Q'⟩ h + dsimp only [projection] at h + subst P' + have hcard := + rationalInfinityPlace_fiber_card_eq_one_of_finrank_dvd_degree + K M T hdegree P + obtain ⟨Q₀, hQ₀⟩ := Fintype.card_eq_one_iff.mp hcard + exact Sigma.ext rfl <| heq_of_eq <| + (hQ₀ Q).trans (hQ₀ Q').symm + · intro P + obtain ⟨Q, hQ⟩ := infinityPlaceUnder_surjective K M T P.1 + exact ⟨⟨P, Q, hQ⟩, rfl⟩ + +/-- Every lift of a rational infinity place is fixed by every relative +Galois automorphism under the degree-divisibility hypothesis. -/ +theorem rationalInfinityPlaceLift_fixed + (hdegree : ∀ Q : FiniteExtensionInfinityPlace K T, + Module.finrank M T ∣ finiteExtensionPlaceDegree K T (.inr Q)) + (sigma : T ≃ₐ[M] T) (x : RationalInfinityPlaceLift K M T) : + infinityPlaceGalSmul K M T sigma x.2.1 = x.2.1 := + infinityPlaceGalSmul_eq_self_over_rationalInfinityPlace_of_finrank_dvd_degree + K M T hdegree x.1 x.2.1 x.2.2 sigma + +/-- If a generator fixes a top infinity place, then generation, +unramifiedness, and maximal top degree force its restriction to have degree +one. -/ +theorem infinityPlaceUnder_degree_eq_one_of_generator_fixed + (sigma : T ≃ₐ[M] T) + (hgen : Subgroup.zpowers sigma = ⊤) + (Q : FiniteExtensionInfinityPlace K T) + (hfixed : infinityPlaceGalSmul K M T sigma Q = Q) + (hunramified : infinityPlaceRelativeRamificationIdx K M T Q = 1) + (htopDegree : finiteExtensionPlaceDegree K T (.inr Q) = + Module.finrank M T) : + finiteExtensionPlaceDegree K M + (.inr (infinityPlaceUnder K M T Q)) = 1 := by + let P := infinityPlaceUnder K M T Q + let Q₀ : InfinityPlaceUnderFiber K M T P := ⟨Q, rfl⟩ + let := infinityPlaceGalAction K M T + have hsigma : sigma ∈ + MulAction.stabilizer (T ≃ₐ[M] T) Q := by + rw [MulAction.mem_stabilizer_iff] + exact hfixed + have hall (tau : T ≃ₐ[M] T) : + infinityPlaceGalSmul K M T tau Q = Q := by + have hle : Subgroup.zpowers sigma ≤ + MulAction.stabilizer (T ≃ₐ[M] T) Q := + Subgroup.zpowers_le.mpr hsigma + have htau : tau ∈ MulAction.stabilizer (T ≃ₐ[M] T) Q := by + apply hle + rw [hgen] + exact Subgroup.mem_top tau + have hfix := MulAction.mem_stabilizer_iff.mp htau + change infinityPlaceGalSmul K M T tau Q = Q at hfix + exact hfix + let := infinityPlaceUnderFiberGalAction K M T P + let : MulAction.IsPretransitive (T ≃ₐ[M] T) + (InfinityPlaceUnderFiber K M T P) := + infinityPlaceUnderFiberGalAction_isPretransitive K M T P + have hcard : Fintype.card (InfinityPlaceUnderFiber K M T P) = 1 := by + apply Fintype.card_eq_one_iff.mpr + refine ⟨Q₀, ?_⟩ + intro R + obtain ⟨tau, htau⟩ := + MulAction.exists_smul_eq (T ≃ₐ[M] T) Q₀ R + calc + R = tau • Q₀ := htau.symm + _ = Q₀ := by + apply Subtype.ext + exact hall tau + have hfundamental := + infinityPlaceUnderFiber_card_mul_ramificationIdx_mul_inertiaDeg_eq_field_finrank + K M T P Q₀ + dsimp [Q₀] at hfundamental + have hinertia : infinityPlaceRelativeInertiaDeg K M T Q = + Module.finrank M T := by + simpa only [hcard, hunramified, one_mul] using hfundamental + have htower := + finiteExtensionPlaceDegree_inr_eq_mul_relativeInertiaDeg K M T Q + rw [htopDegree, hinertia] at htower + apply Nat.eq_of_mul_eq_mul_right (Module.finrank_pos (R := M) (M := T)) + simpa only [one_mul] using htower.symm + +omit [FiniteDimensional M T] in +/-- Every lift of a rational infinity place has top degree equal to the +relative field degree under the degree-divisibility hypothesis. -/ +theorem rationalInfinityPlace_lift_degree_eq_finrank_of_finrank_dvd_degree + (hdegree : ∀ Q : FiniteExtensionInfinityPlace K T, + Module.finrank M T ∣ finiteExtensionPlaceDegree K T (.inr Q)) + (P : FiniteExtensionRationalInfinityPlace K M) + (Q : FiniteExtensionInfinityPlace K T) + (hQ : infinityPlaceUnder K M T Q = P.1) : + finiteExtensionPlaceDegree K T (.inr Q) = Module.finrank M T := by + let Q₀ : InfinityPlaceUnderFiber K M T P.1 := ⟨Q, hQ⟩ + have htower := + finiteExtensionPlaceDegree_inr_eq_mul_relativeInertiaDeg K M T Q + have hrelative : infinityPlaceRelativeInertiaDeg K M T Q = + finiteExtensionPlaceDegree K T (.inr Q) := by + rw [hQ] at htower + simpa only [P.2, one_mul] using htower.symm + have hm_dvd_f : Module.finrank M T ∣ + infinityPlaceRelativeInertiaDeg K M T Q := by + rw [hrelative] + exact hdegree Q + have hfundamental := + infinityPlaceUnderFiber_card_mul_ramificationIdx_mul_inertiaDeg_eq_field_finrank + K M T P.1 Q₀ + dsimp [Q₀] at hfundamental + have hf_dvd_m : infinityPlaceRelativeInertiaDeg K M T Q ∣ + Module.finrank M T := by + rw [← hfundamental] + exact dvd_mul_left _ _ + exact hrelative.symm.trans (Nat.dvd_antisymm hf_dvd_m hm_dvd_f) + +/-- Rational infinity places are equivalent to generator-fixed top infinity +places of relative-degree-sized absolute degree, once the relative extension +is unramified and every top degree is divisible by the relative degree. -/ +noncomputable def rationalInfinityPlaceEquivGeneratorFixedPlace + (hdegree : ∀ Q : FiniteExtensionInfinityPlace K T, + Module.finrank M T ∣ finiteExtensionPlaceDegree K T (.inr Q)) + (sigma : T ≃ₐ[M] T) + (hgen : Subgroup.zpowers sigma = ⊤) + (hunramified : ∀ Q : FiniteExtensionInfinityPlace K T, + infinityPlaceRelativeRamificationIdx K M T Q = 1) : + FiniteExtensionRationalInfinityPlace K M ≃ + {Q : FiniteExtensionInfinityPlace K T // + finiteExtensionPlaceDegree K T (.inr Q) = Module.finrank M T ∧ + infinityPlaceGalSmul K M T sigma Q = Q} := by + let e := rationalInfinityPlaceEquivLift K M T hdegree + refine + { toFun := fun P => by + let x := e P + exact ⟨x.2.1, + rationalInfinityPlace_lift_degree_eq_finrank_of_finrank_dvd_degree + K M T hdegree x.1 x.2.1 x.2.2, + rationalInfinityPlaceLift_fixed K M T hdegree sigma x⟩ + invFun := fun Q => + ⟨infinityPlaceUnder K M T Q.1, + infinityPlaceUnder_degree_eq_one_of_generator_fixed K M T sigma + hgen Q.1 Q.2.2 (hunramified Q.1) Q.2.1⟩ + left_inv := ?_ + right_inv := ?_ } + · intro P + apply Subtype.ext + let x := e P + have hx1 : x.1 = P := by + change e.symm (e P) = P + exact e.symm_apply_apply P + exact x.2.2.trans (congrArg Subtype.val hx1) + · intro Q + apply Subtype.ext + let P : FiniteExtensionRationalInfinityPlace K M := + ⟨infinityPlaceUnder K M T Q.1, + infinityPlaceUnder_degree_eq_one_of_generator_fixed K M T sigma + hgen Q.1 Q.2.2 (hunramified Q.1) Q.2.1⟩ + let x := e P + have hx1 : x.1 = P := by + change e.symm (e P) = P + exact e.symm_apply_apply P + let xFiber : InfinityPlaceUnderFiber K M T P.1 := + ⟨x.2.1, x.2.2.trans (congrArg Subtype.val hx1)⟩ + let qFiber : InfinityPlaceUnderFiber K M T P.1 := ⟨Q.1, rfl⟩ + have hcard := + rationalInfinityPlace_fiber_card_eq_one_of_finrank_dvd_degree + K M T hdegree P + obtain ⟨z, hz⟩ := Fintype.card_eq_one_iff.mp hcard + have hxy : xFiber = qFiber := (hz xFiber).trans (hz qFiber).symm + change x.2.1 = Q.1 + exact congrArg Subtype.val hxy + +/-- Relative automorphisms over two intermediate fields induce the same +action on top infinity places when their underlying top-field maps agree. -/ +theorem infinityPlaceGalSmul_eq_of_apply_eq + (K M₁ M₂ T : Type*) [Field K] [DecidableEq K] + [DecidableEq (RatFunc K)] + [Field M₁] [Algebra (RatFunc K) M₁] + [FiniteDimensional (RatFunc K) M₁] + [Algebra.IsSeparable (RatFunc K) M₁] + [Field M₂] [Algebra (RatFunc K) M₂] + [FiniteDimensional (RatFunc K) M₂] + [Algebra.IsSeparable (RatFunc K) M₂] + [Field T] [Algebra (RatFunc K) T] + [FiniteDimensional (RatFunc K) T] + [Algebra.IsSeparable (RatFunc K) T] + [Algebra M₁ T] [IsScalarTower (RatFunc K) M₁ T] + [FiniteDimensional M₁ T] [IsGalois M₁ T] + [Algebra M₂ T] [IsScalarTower (RatFunc K) M₂ T] + [FiniteDimensional M₂ T] [IsGalois M₂ T] + (g₁ : T ≃ₐ[M₁] T) (g₂ : T ≃ₐ[M₂] T) + (happly : ∀ x : T, g₁ x = g₂ x) + (Q : FiniteExtensionInfinityPlace K T) : + infinityPlaceGalSmul K M₁ T g₁ Q = + infinityPlaceGalSmul K M₂ T g₂ Q := by + let V := RatFuncInfinityIntegers K + let A := RatFuncInfinityIntegralClosure K T + let A₁ := RatFuncInfinityIntegralClosure K M₁ + let A₂ := RatFuncInfinityIntegralClosure K M₂ + let : Algebra V (RatFunc K) := + RingHom.toAlgebra + (SubringClass.subtype ((RatFunc.inftyValuation K).integer)) + let : SMul V (RatFunc K) := Algebra.toSMul + let : Module V (RatFunc K) := Algebra.toModule + let : IsFractionRing V (RatFunc K) := + (Valuation.integer.integers (RatFunc.inftyValuation K)).isFractionRing + let : Algebra V M₁ := + RingHom.toAlgebra + ((algebraMap (RatFunc K) M₁).comp (algebraMap V (RatFunc K))) + let : SMul V M₁ := Algebra.toSMul + let : Module V M₁ := Algebra.toModule + let : IsScalarTower V (RatFunc K) M₁ := + IsScalarTower.of_algebraMap_eq' rfl + let : Algebra V M₂ := + RingHom.toAlgebra + ((algebraMap (RatFunc K) M₂).comp (algebraMap V (RatFunc K))) + let : SMul V M₂ := Algebra.toSMul + let : Module V M₂ := Algebra.toModule + let : IsScalarTower V (RatFunc K) M₂ := + IsScalarTower.of_algebraMap_eq' rfl + let : Algebra V T := + RingHom.toAlgebra + ((algebraMap (RatFunc K) T).comp (algebraMap V (RatFunc K))) + let : SMul V T := Algebra.toSMul + let : Module V T := Algebra.toModule + let : IsScalarTower V (RatFunc K) T := + IsScalarTower.of_algebraMap_eq' rfl + let : IsIntegralClosure A₁ V M₁ := + integralClosure.isIntegralClosure V M₁ + let : IsScalarTower V A₁ M₁ := + IsScalarTower.of_algebraMap_eq' rfl + let : IsFractionRing A₁ M₁ := + IsIntegralClosure.isFractionRing_of_finite_extension V (RatFunc K) M₁ A₁ + let : IsIntegralClosure A₂ V M₂ := + integralClosure.isIntegralClosure V M₂ + let : IsScalarTower V A₂ M₂ := + IsScalarTower.of_algebraMap_eq' rfl + let : IsFractionRing A₂ M₂ := + IsIntegralClosure.isFractionRing_of_finite_extension V (RatFunc K) M₂ A₂ + let : IsIntegralClosure A V T := + integralClosure.isIntegralClosure V T + let : IsScalarTower V A T := + IsScalarTower.of_algebraMap_eq' rfl + let : IsFractionRing A T := + IsIntegralClosure.isFractionRing_of_finite_extension V (RatFunc K) T A + let : Algebra A₁ A := (infinityIntegralClosureMap K M₁ T).toAlgebra + let : SMul A₁ A := Algebra.toSMul + let : Module A₁ A := Algebra.toModule + let : IsScalarTower A₁ M₁ T := inferInstance + let : Algebra.IsIntegral V A₁ := + IsIntegralClosure.isIntegral_algebra V M₁ + let : IsScalarTower V A₁ T := by + apply IsScalarTower.of_algebraMap_eq + intro x + change algebraMap (RatFunc K) T + (algebraMap V (RatFunc K) x) = + algebraMap M₁ T + (algebraMap (RatFunc K) M₁ + (algebraMap V (RatFunc K) x)) + exact IsScalarTower.algebraMap_apply (RatFunc K) M₁ T _ + let : IsScalarTower A₁ A T := + ⟨fun r t x => by + simp only [Algebra.smul_def, map_mul] + rw [show algebraMap A T (algebraMap A₁ A r) = + algebraMap A₁ T r by rfl] + ring⟩ + let : IsIntegralClosure A A₁ T := + IsIntegralClosure.tower_top (R := V) + let : Algebra A₂ A := (infinityIntegralClosureMap K M₂ T).toAlgebra + let : SMul A₂ A := Algebra.toSMul + let : Module A₂ A := Algebra.toModule + let : IsScalarTower A₂ M₂ T := inferInstance + let : Algebra.IsIntegral V A₂ := + IsIntegralClosure.isIntegral_algebra V M₂ + let : IsScalarTower V A₂ T := by + apply IsScalarTower.of_algebraMap_eq + intro x + change algebraMap (RatFunc K) T + (algebraMap V (RatFunc K) x) = + algebraMap M₂ T + (algebraMap (RatFunc K) M₂ + (algebraMap V (RatFunc K) x)) + exact IsScalarTower.algebraMap_apply (RatFunc K) M₂ T _ + let : IsScalarTower A₂ A T := + ⟨fun r t x => by + simp only [Algebra.smul_def, map_mul] + rw [show algebraMap A T (algebraMap A₂ A r) = + algebraMap A₂ T r by rfl] + ring⟩ + let : IsIntegralClosure A A₂ T := + IsIntegralClosure.tower_top (R := V) + let : MulSemiringAction (T ≃ₐ[M₁] T) A := + infinityIntegralClosureGalAction K M₁ T + let : MulSemiringAction (T ≃ₐ[M₂] T) A := + infinityIntegralClosureGalAction K M₂ T + have hsmul (a₁ : T ≃ₐ[M₁] T) (a₂ : T ≃ₐ[M₂] T) + (ha : ∀ x : T, a₁ x = a₂ x) (x : A) : a₁ • x = a₂ • x := by + apply Subtype.ext + calc + ((a₁ • x : A) : T) = a₁ (x : T) := by + change algebraMap A T ((galRestrict A₁ M₁ T A a₁) x) = + a₁ (algebraMap A T x) + exact algebraMap_galRestrict_apply A₁ a₁ x + _ = a₂ (x : T) := ha _ + _ = ((a₂ • x : A) : T) := by + change a₂ (algebraMap A T x) = + algebraMap A T ((galRestrict A₂ M₂ T A a₂) x) + exact (algebraMap_galRestrict_apply A₂ a₂ x).symm + have happly_inv (x : T) : g₁⁻¹ x = g₂⁻¹ x := by + apply g₂.injective + calc + g₂ (g₁⁻¹ x) = g₁ (g₁⁻¹ x) := (happly _).symm + _ = x := g₁.apply_symm_apply x + _ = g₂ (g₂⁻¹ x) := (g₂.apply_symm_apply x).symm + apply Subtype.ext + change g₁ • Q.1 = g₂ • Q.1 + ext x + rw [Ideal.mem_pointwise_smul_iff_inv_smul_mem, + Ideal.mem_pointwise_smul_iff_inv_smul_mem, + hsmul g₁⁻¹ g₂⁻¹ happly_inv x] + +end GenericInfinityDescent + +variable (C N S : Type*) [Field C] [Fintype C] + [DecidableEq C] [DecidableEq (RatFunc C)] + [Field N] [Algebra (RatFunc C) N] + [FiniteDimensional (RatFunc C) N] + [Algebra.IsSeparable (RatFunc C) N] + [Field S] [Algebra C S] [FiniteDimensional C S] [IsGalois C S] + [Finite S] [DecidableEq S] [DecidableEq (RatFunc S)] + +local instance twistInfinityConstantAlgebra : Algebra C N := + bridgeBaseConstantAlgebra C N + +local instance twistInfinityConstantTower : + IsScalarTower C (RatFunc C) N := + IsScalarTower.of_algebraMap_eq' rfl + +section ExactConstantExtensionInfinityDegree + +variable (hExact : algebraicClosure C N = + (⊥ : IntermediateField C N)) + +omit [DecidableEq C] [DecidableEq (RatFunc C)] [DecidableEq S] [DecidableEq (RatFunc S)] in +/-- Every infinity place of the exact constant extension, viewed over the +original constants `C`, has degree divisible by `[S : C]`. -/ +theorem exactConstantExtensionInfinityPlace_finrank_constants_dvd_degree + (Q : + letI : DecidableEq C := infinityBridgeDecidableEqConstants C + letI : DecidableEq (RatFunc C) := + infinityBridgeDecidableEqRatFuncConstants C + letI : DecidableEq S := infinityBridgeDecidableEqConstants S + letI : DecidableEq (RatFunc S) := + infinityBridgeDecidableEqRatFuncConstants S + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + FiniteExtensionInfinityPlace C (ExactConstantExtension C N S)) : + letI : DecidableEq C := infinityBridgeDecidableEqConstants C + letI : DecidableEq (RatFunc C) := + infinityBridgeDecidableEqRatFuncConstants C + letI : DecidableEq S := infinityBridgeDecidableEqConstants S + letI : DecidableEq (RatFunc S) := + infinityBridgeDecidableEqRatFuncConstants S + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + Module.finrank C S ∣ finiteExtensionPlaceDegree C + (ExactConstantExtension C N S) (.inr Q) := by + let : DecidableEq C := infinityBridgeDecidableEqConstants C + let : DecidableEq (RatFunc C) := + infinityBridgeDecidableEqRatFuncConstants C + let : DecidableEq S := infinityBridgeDecidableEqConstants S + let : DecidableEq (RatFunc S) := + infinityBridgeDecidableEqRatFuncConstants S + let T := ExactConstantExtension C N S + let : Field T := exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) T := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : SMul (RatFunc C) T := Algebra.toSMul + let : Module (RatFunc C) T := Algebra.toModule + let : FiniteDimensional (RatFunc C) T := + finiteDimensional_exactConstantExtension_over_baseRatFunc C S N hExact + let : Algebra.IsSeparable (RatFunc C) T := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + let : Algebra (RatFunc S) T := + ratFuncExactConstantExtensionAlgebra C S N hExact + let : SMul (RatFunc S) T := Algebra.toSMul + let : Module (RatFunc S) T := Algebra.toModule + let : FiniteDimensional (RatFunc S) T := + finiteDimensional_over_extendedRatFunc C S N hExact + let : Algebra.IsSeparable (RatFunc S) T := + isSeparable_over_extendedRatFunc C S N hExact + let e := exactConstantExtensionPresentedInfinityPlaceEquiv + C S N hExact + let q := e.symm Q + have hdegree := + exactConstantExtensionPresentedInfinityPlace_degree_baseChange + C S N hExact q + have heq : e q = Q := e.apply_symm_apply Q + rw [heq] at hdegree + rw [hdegree] + exact dvd_mul_right _ _ + +end ExactConstantExtensionInfinityDegree + +section FrobeniusTwistInfinityUnramified + +omit [DecidableEq C] [DecidableEq (RatFunc C)] [FiniteDimensional (RatFunc C) N] + [Algebra.IsSeparable (RatFunc C) N] [Finite S] [DecidableEq S] [DecidableEq (RatFunc S)] in +/-- Powers of the ambient twist act on enlarged constants by the +corresponding powers of finite-field Frobenius. -/ +private theorem exactConstantExtensionFrobeniusTwist_zpow_includeLeft_infinity + (hExact : algebraicClosure C N = + (⊥ : IntermediateField C N)) + (g : N ≃ₐ[RatFunc C] N) (k : ℤ) (s : S) : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + ((exactConstantExtensionFrobeniusTwist + C (RatFunc C) N S hExact g) ^ k) + (Algebra.TensorProduct.includeLeft + (R := C) (S := C) (A := S) (B := N) s) = + Algebra.TensorProduct.includeLeft + (R := C) (S := C) (A := S) (B := N) + (((FiniteField.frobeniusAlgEquivOfAlgebraic C S) ^ k) s) := by + let : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + change + ((exactConstantExtensionCombinedAutHom C (RatFunc C) N S + (FiniteField.frobeniusAlgEquivOfAlgebraic C S, g)) ^ k) + (Algebra.TensorProduct.includeLeft + (R := C) (S := C) (A := S) (B := N) s) = _ + rw [← map_zpow] + simp [Algebra.TensorProduct.includeLeft_apply, + exactConstantExtensionCombinedAutHom, + exactConstantExtensionConstantAutHom, + exactConstantExtensionFunctionAutHom, + exactConstantExtensionConstantAlgEquivOverBase, + exactConstantExtensionFunctionAlgEquivOverBase] + +omit [DecidableEq C] [DecidableEq S] [DecidableEq (RatFunc S)] in +/-- Every infinity place of the exact constant extension is unramified over a +Frobenius-twist fixed field, provided the twist has the full +constant-extension order. -/ +theorem frobeniusTwistField_infinityPlace_ramificationIdx_eq_one + (hExact : algebraicClosure C N = + (⊥ : IntermediateField C N)) + (g : N ≃ₐ[RatFunc C] N) + (hdiv : Nat.card (N ≃ₐ[RatFunc C] N) ∣ Module.finrank C S) : + let : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : SMul (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toSMul + let : Module (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toModule + let : FiniteDimensional (RatFunc C) + (ExactConstantExtension C N S) := + finiteDimensional_exactConstantExtension_over_baseRatFunc + C S N hExact + let : Algebra.IsSeparable (RatFunc C) + (ExactConstantExtension C N S) := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + let F := exactConstantExtensionFrobeniusTwistField + C (RatFunc C) N S hExact g + let : Algebra (RatFunc C) F := + SubalgebraClass.toAlgebra F.toSubalgebra + let : SMul (RatFunc C) F := Algebra.toSMul + let : Module (RatFunc C) F := Algebra.toModule + let : FiniteDimensional (RatFunc C) F := + finiteDimensional_frobeniusTwistField_over_ratFunc C N S hExact g + let : Algebra.IsSeparable (RatFunc C) F := + isSeparable_frobeniusTwistField_over_ratFunc C N S hExact g + let : Algebra F (ExactConstantExtension C N S) := F.toAlgebra + let : SMul F (ExactConstantExtension C N S) := Algebra.toSMul + let : Module F (ExactConstantExtension C N S) := Algebra.toModule + let : IsScalarTower (RatFunc C) F + (ExactConstantExtension C N S) := inferInstance + let : FiniteDimensional F (ExactConstantExtension C N S) := + finiteDimensional_exactConstantExtension_over_frobeniusTwistField + C (RatFunc C) N S hExact g + let : IsGalois F (ExactConstantExtension C N S) := + isGalois_exactConstantExtension_over_frobeniusTwistField + C (RatFunc C) N S hExact g + ∀ Q : FiniteExtensionInfinityPlace C (ExactConstantExtension C N S), + infinityPlaceRelativeRamificationIdx C F + (ExactConstantExtension C N S) Q = 1 := by + intro model0 model1 model2 model3 model4 model5 F model7 model8 model9 model10 model11 model12 + model13 model14 model15 model16 model17 + let T := ExactConstantExtension C N S + let V := RatFuncInfinityIntegers C + let : Algebra V (RatFunc C) := + RingHom.toAlgebra + (SubringClass.subtype ((RatFunc.inftyValuation C).integer)) + let : SMul V (RatFunc C) := Algebra.toSMul + let : Module V (RatFunc C) := Algebra.toModule + let : IsFractionRing V (RatFunc C) := + (Valuation.integer.integers (RatFunc.inftyValuation C)).isFractionRing + let : Algebra V T := + RingHom.toAlgebra + ((algebraMap (RatFunc C) T).comp (algebraMap V (RatFunc C))) + let : SMul V T := Algebra.toSMul + let : Module V T := Algebra.toModule + let : IsScalarTower V (RatFunc C) T := + IsScalarTower.of_algebraMap_eq' rfl + let A := RatFuncInfinityIntegralClosure C T + let AF := RatFuncInfinityIntegralClosure C F + let : IsIntegralClosure AF V F := + integralClosure.isIntegralClosure V F + let : IsScalarTower V AF F := + IsScalarTower.of_algebraMap_eq' rfl + let : IsFractionRing AF F := + IsIntegralClosure.isFractionRing_of_finite_extension V (RatFunc C) F AF + let : IsIntegralClosure A V T := + integralClosure.isIntegralClosure V T + let : IsScalarTower V A T := + IsScalarTower.of_algebraMap_eq' rfl + let : IsFractionRing A T := + IsIntegralClosure.isFractionRing_of_finite_extension V (RatFunc C) T A + let : Algebra AF A := (infinityIntegralClosureMap C F T).toAlgebra + let : SMul AF A := Algebra.toSMul + let : Module AF A := Algebra.toModule + let : Algebra S A := + exactConstantExtensionInfinityIntegralClosureConstantAlgebra C S N hExact + let : IsScalarTower AF F T := inferInstance + let : Algebra.IsIntegral V AF := + IsIntegralClosure.isIntegral_algebra V F + let : IsScalarTower V AF T := by + apply IsScalarTower.of_algebraMap_eq + intro x + change algebraMap (RatFunc C) T + (algebraMap V (RatFunc C) x) = + algebraMap F T + (algebraMap (RatFunc C) F + (algebraMap V (RatFunc C) x)) + exact IsScalarTower.algebraMap_apply (RatFunc C) F T _ + let : IsScalarTower AF A T := + ⟨fun r t x => by + simp only [Algebra.smul_def, map_mul] + rw [show algebraMap A T (algebraMap AF A r) = + algebraMap AF T r by rfl] + ring⟩ + let : IsIntegralClosure A AF T := + IsIntegralClosure.tower_top (R := V) + let : IsDedekindDomain A := + IsIntegralClosure.isDedekindDomain V (RatFunc C) T A + let : MulSemiringAction (T ≃ₐ[F] T) A := + infinityIntegralClosureGalAction C F T + intro Q + rw [← infinityPlaceInertiaGroup_card_eq_ramificationIdx C F T Q] + have hInertia : infinityPlaceInertiaGroup C F T Q = ⊥ := by + ext tau + constructor + · intro htau + rw [Subgroup.mem_bot] + let sigma := exactConstantExtensionFrobeniusTwist + C (RatFunc C) N S hExact g + let H := exactConstantExtensionFrobeniusTwistSubgroup + C (RatFunc C) N S hExact g + let e := IntermediateField.subgroupEquivAlgEquiv H + let h : H := e.symm tau + have he_apply (z : H) (x : T) : e z x = z.1 x := by + change z.1.toEquiv x = z.1 x + rfl + have htau_apply (x : T) : tau x = h.1 x := by + calc + tau x = e h x := by + exact congrArg (fun z : T ≃ₐ[F] T => z x) + (e.apply_symm_apply tau).symm + _ = h.1 x := he_apply h x + obtain ⟨k, hk⟩ := Subgroup.mem_zpowers_iff.mp h.2 + let frob := FiniteField.frobeniusAlgEquivOfAlgebraic C S + have hfrob_apply (s : S) : (frob ^ k) s = s := by + let a : A := algebraMap S A s + have haction : tau • a = algebraMap S A ((frob ^ k) s) := by + apply Subtype.ext + calc + ((tau • a : A) : T) = tau (a : T) := by + change algebraMap A T ((galRestrict AF F T A tau) a) = + tau (algebraMap A T a) + exact algebraMap_galRestrict_apply AF tau a + _ = h.1 (a : T) := htau_apply (a : T) + _ = h.1 (Algebra.TensorProduct.includeLeft + (R := C) (S := C) (A := S) (B := N) s) := by + rfl + _ = (sigma ^ k) (Algebra.TensorProduct.includeLeft + (R := C) (S := C) (A := S) (B := N) s) := by + exact congrArg + (fun z : T ≃ₐ[RatFunc C] T => + z (Algebra.TensorProduct.includeLeft + (R := C) (S := C) (A := S) (B := N) s)) + hk |>.symm + _ = Algebra.TensorProduct.includeLeft + (R := C) (S := C) (A := S) (B := N) + ((frob ^ k) s) := by + exact exactConstantExtensionFrobeniusTwist_zpow_includeLeft_infinity + C N S hExact g k s + _ = ((algebraMap S A ((frob ^ k) s) : A) : T) := by + rfl + have hmem : tau • a - a ∈ Q.1 := htau a + have hmem' : algebraMap S A ((frob ^ k) s - s) ∈ Q.1 := by + have heq : algebraMap S A ((frob ^ k) s - s) = tau • a - a := by + calc + algebraMap S A ((frob ^ k) s - s) = + algebraMap S A ((frob ^ k) s) - algebraMap S A s := + map_sub (algebraMap S A) _ _ + _ = algebraMap S A ((frob ^ k) s) - a := rfl + _ = tau • a - a := congrArg (fun z : A => z - a) haction.symm + exact heq.symm ▸ hmem + let J : Ideal S := Q.1.comap (algebraMap S A) + have hmemJ : (frob ^ k) s - s ∈ J := hmem' + have hJne : J ≠ ⊤ := by + exact Ideal.comap_ne_top (algebraMap S A) Q.2.1.ne_top + have hJ : J = ⊥ := (Ideal.eq_bot_or_top J).resolve_right hJne + have hs : (frob ^ k) s - s = 0 := by + rw [hJ] at hmemJ + simpa only [Ideal.mem_bot] using hmemJ + exact sub_eq_zero.mp hs + have hFrob : frob ^ k = 1 := by + ext s + exact hfrob_apply s + have hkdiv : (Module.finrank C S : ℤ) ∣ k := by + rw [← FiniteField.orderOf_frobeniusAlgEquivOfAlgebraic C S] + exact orderOf_dvd_iff_zpow_eq_one.mpr hFrob + have hsigma : sigma ^ k = 1 := by + rw [← orderOf_dvd_iff_zpow_eq_one, + orderOf_exactConstantExtensionFrobeniusTwist + C (RatFunc C) N S hExact g hdiv] + exact hkdiv + have hambient : (h.1 : T ≃ₐ[RatFunc C] T) = 1 := by + calc + (h.1 : T ≃ₐ[RatFunc C] T) = sigma ^ k := hk.symm + _ = 1 := hsigma + have hh : h = 1 := Subtype.ext hambient + exact (e.apply_symm_apply tau).symm.trans + ((congrArg e hh).trans (map_one e)) + · intro htau + rw [Subgroup.mem_bot] at htau + simp [htau] + rw [hInertia] + exact Nat.card_unique + +end FrobeniusTwistInfinityUnramified + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionFrobeniusTwistInfinityPlaceEquivalence.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionFrobeniusTwistInfinityPlaceEquivalence.lean new file mode 100644 index 0000000000..bb67df1dc6 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionFrobeniusTwistInfinityPlaceEquivalence.lean @@ -0,0 +1,490 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionFrobeniusTwistInfinityPlaceDescent + +/-! +# Exact Frobenius-twist descent for infinity places + +This file specializes the generic infinity-place descent theory to an exact +constant extension. It identifies rational infinity places of the +Frobenius-twist fixed field with degree-`[S : C]` infinity places upstairs +fixed by the ambient Frobenius twist. +-/ + +@[expose] public section + +open scoped Pointwise Polynomial TensorProduct + +namespace BGS.HasseWeil + +noncomputable section + +open BGS.CorvajaZannier + + +variable (C N S : Type*) [Field C] [Fintype C] + [DecidableEq C] [DecidableEq (RatFunc C)] + [Field N] [Algebra (RatFunc C) N] + [FiniteDimensional (RatFunc C) N] + [Algebra.IsSeparable (RatFunc C) N] + [Field S] [Algebra C S] [FiniteDimensional C S] [IsGalois C S] + [Finite S] [DecidableEq S] [DecidableEq (RatFunc S)] + +local instance twistInfinityEquivalenceConstantAlgebra : Algebra C N := + bridgeBaseConstantAlgebra C N + +local instance twistInfinityEquivalenceConstantTower : + IsScalarTower C (RatFunc C) N := + IsScalarTower.of_algebraMap_eq' rfl + +section FrobeniusTwistInfinitySpecialization + +variable (hExact : algebraicClosure C N = + (⊥ : IntermediateField C N)) +variable (g : N ≃ₐ[RatFunc C] N) + +omit [DecidableEq C] [DecidableEq (RatFunc C)] + [DecidableEq S] [DecidableEq (RatFunc S)] in +/-- A top infinity place of degree `[S : C]` fixed by the canonical twist +descends to a rational infinity place of the Frobenius-twist fixed field. -/ +theorem frobeniusTwistField_fixed_infinityPlace_under_degree_eq_one + (hdiv : Nat.card (N ≃ₐ[RatFunc C] N) ∣ Module.finrank C S) : + letI : DecidableEq C := infinityBridgeDecidableEqConstants C + letI : DecidableEq (RatFunc C) := + infinityBridgeDecidableEqRatFuncConstants C + letI : DecidableEq S := infinityBridgeDecidableEqConstants S + letI : DecidableEq (RatFunc S) := + infinityBridgeDecidableEqRatFuncConstants S + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + letI : SMul (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toSMul + letI : Module (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toModule + letI : DistribMulAction (RatFunc C) + (ExactConstantExtension C N S) := Module.toDistribMulAction + letI : MulAction (RatFunc C) (ExactConstantExtension C N S) := + DistribMulAction.toMulAction + letI : FiniteDimensional (RatFunc C) + (ExactConstantExtension C N S) := + finiteDimensional_exactConstantExtension_over_baseRatFunc + C S N hExact + letI : Algebra.IsSeparable (RatFunc C) + (ExactConstantExtension C N S) := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + let F := exactConstantExtensionFrobeniusTwistField + C (RatFunc C) N S hExact g + letI : Algebra (RatFunc C) F := + SubalgebraClass.toAlgebra F.toSubalgebra + letI : SMul (RatFunc C) F := Algebra.toSMul + letI : Module (RatFunc C) F := Algebra.toModule + letI : DistribMulAction (RatFunc C) F := Module.toDistribMulAction + letI : MulAction (RatFunc C) F := DistribMulAction.toMulAction + letI : FiniteDimensional (RatFunc C) F := + finiteDimensional_frobeniusTwistField_over_ratFunc C N S hExact g + letI : Algebra.IsSeparable (RatFunc C) F := + isSeparable_frobeniusTwistField_over_ratFunc C N S hExact g + letI : Algebra F (ExactConstantExtension C N S) := F.toAlgebra + letI : SMul F (ExactConstantExtension C N S) := Algebra.toSMul + letI : Module F (ExactConstantExtension C N S) := Algebra.toModule + letI : DistribMulAction F (ExactConstantExtension C N S) := + Module.toDistribMulAction + letI : MulAction F (ExactConstantExtension C N S) := + DistribMulAction.toMulAction + letI : IsScalarTower (RatFunc C) F + (ExactConstantExtension C N S) := inferInstance + letI : FiniteDimensional F (ExactConstantExtension C N S) := + finiteDimensional_exactConstantExtension_over_frobeniusTwistField + C (RatFunc C) N S hExact g + letI : IsGalois F (ExactConstantExtension C N S) := + isGalois_exactConstantExtension_over_frobeniusTwistField + C (RatFunc C) N S hExact g + ∀ (Q : FiniteExtensionInfinityPlace C (ExactConstantExtension C N S)), + finiteExtensionPlaceDegree C (ExactConstantExtension C N S) (.inr Q) = + Module.finrank C S → + infinityPlaceGalSmul C F (ExactConstantExtension C N S) + (exactConstantExtensionFrobeniusTwistOverFixedField + C N S hExact g) Q = Q → + finiteExtensionPlaceDegree C F + (.inr (infinityPlaceUnder C F + (ExactConstantExtension C N S) Q)) = 1 := by + let : DecidableEq C := infinityBridgeDecidableEqConstants C + let : DecidableEq (RatFunc C) := + infinityBridgeDecidableEqRatFuncConstants C + let : DecidableEq S := infinityBridgeDecidableEqConstants S + let : DecidableEq (RatFunc S) := + infinityBridgeDecidableEqRatFuncConstants S + let T := ExactConstantExtension C N S + let : Field T := exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) T := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : SMul (RatFunc C) T := Algebra.toSMul + let : Module (RatFunc C) T := Algebra.toModule + let : DistribMulAction (RatFunc C) T := Module.toDistribMulAction + let : MulAction (RatFunc C) T := DistribMulAction.toMulAction + let : FiniteDimensional (RatFunc C) T := + finiteDimensional_exactConstantExtension_over_baseRatFunc C S N hExact + let : Algebra.IsSeparable (RatFunc C) T := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + let F := exactConstantExtensionFrobeniusTwistField + C (RatFunc C) N S hExact g + let : Algebra (RatFunc C) F := + SubalgebraClass.toAlgebra F.toSubalgebra + let : SMul (RatFunc C) F := Algebra.toSMul + let : Module (RatFunc C) F := Algebra.toModule + let : DistribMulAction (RatFunc C) F := Module.toDistribMulAction + let : MulAction (RatFunc C) F := DistribMulAction.toMulAction + let : FiniteDimensional (RatFunc C) F := + finiteDimensional_frobeniusTwistField_over_ratFunc C N S hExact g + let : Algebra.IsSeparable (RatFunc C) F := + isSeparable_frobeniusTwistField_over_ratFunc C N S hExact g + let : Algebra F T := F.toAlgebra + let : SMul F T := Algebra.toSMul + let : Module F T := Algebra.toModule + let : DistribMulAction F T := Module.toDistribMulAction + let : MulAction F T := DistribMulAction.toMulAction + let : IsScalarTower (RatFunc C) F T := inferInstance + let : FiniteDimensional F T := + finiteDimensional_exactConstantExtension_over_frobeniusTwistField + C (RatFunc C) N S hExact g + let : IsGalois F T := + isGalois_exactConstantExtension_over_frobeniusTwistField + C (RatFunc C) N S hExact g + dsimp only + intro Q hdegree hfixed + apply infinityPlaceUnder_degree_eq_one_of_generator_fixed + C F T + (exactConstantExtensionFrobeniusTwistOverFixedField C N S hExact g) + (exactConstantExtensionFrobeniusTwistOverFixedField_zpowers_eq_top + C N S hExact g) + Q hfixed + · exact frobeniusTwistField_infinityPlace_ramificationIdx_eq_one + C N S hExact g hdiv Q + · calc + finiteExtensionPlaceDegree C T (.inr Q) = Module.finrank C S := hdegree + _ = Module.finrank F T := + (finrank_exactConstantExtension_over_frobeniusTwistField + C (RatFunc C) N S hExact g hdiv).symm + +omit [DecidableEq C] [DecidableEq (RatFunc C)] + [DecidableEq S] [DecidableEq (RatFunc S)] in +/-- The canonical twist over its fixed field and the ambient twist over +`C(X)` induce the same action on infinity places. -/ +theorem exactConstantExtensionFrobeniusTwist_infinityPlaceGalSmul_eq_overFixedField + [IsGalois (RatFunc C) N] : + letI : DecidableEq C := infinityBridgeDecidableEqConstants C + letI : DecidableEq (RatFunc C) := + infinityBridgeDecidableEqRatFuncConstants C + letI : DecidableEq S := infinityBridgeDecidableEqConstants S + letI : DecidableEq (RatFunc S) := + infinityBridgeDecidableEqRatFuncConstants S + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + letI : SMul (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toSMul + letI : Module (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toModule + letI : DistribMulAction (RatFunc C) + (ExactConstantExtension C N S) := Module.toDistribMulAction + letI : MulAction (RatFunc C) (ExactConstantExtension C N S) := + DistribMulAction.toMulAction + letI : FiniteDimensional (RatFunc C) + (ExactConstantExtension C N S) := + finiteDimensional_exactConstantExtension_over_baseRatFunc + C S N hExact + letI : Algebra.IsSeparable (RatFunc C) + (ExactConstantExtension C N S) := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + letI : IsGalois (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtension_isGalois C (RatFunc C) N S hExact + let F := exactConstantExtensionFrobeniusTwistField + C (RatFunc C) N S hExact g + letI : Algebra (RatFunc C) F := + SubalgebraClass.toAlgebra F.toSubalgebra + letI : SMul (RatFunc C) F := Algebra.toSMul + letI : Module (RatFunc C) F := Algebra.toModule + letI : DistribMulAction (RatFunc C) F := Module.toDistribMulAction + letI : MulAction (RatFunc C) F := DistribMulAction.toMulAction + letI : FiniteDimensional (RatFunc C) F := + finiteDimensional_frobeniusTwistField_over_ratFunc C N S hExact g + letI : Algebra.IsSeparable (RatFunc C) F := + isSeparable_frobeniusTwistField_over_ratFunc C N S hExact g + letI : Algebra F (ExactConstantExtension C N S) := F.toAlgebra + letI : SMul F (ExactConstantExtension C N S) := Algebra.toSMul + letI : Module F (ExactConstantExtension C N S) := Algebra.toModule + letI : DistribMulAction F (ExactConstantExtension C N S) := + Module.toDistribMulAction + letI : MulAction F (ExactConstantExtension C N S) := + DistribMulAction.toMulAction + letI : IsScalarTower (RatFunc C) F + (ExactConstantExtension C N S) := inferInstance + letI : FiniteDimensional F (ExactConstantExtension C N S) := + finiteDimensional_exactConstantExtension_over_frobeniusTwistField + C (RatFunc C) N S hExact g + letI : IsGalois F (ExactConstantExtension C N S) := + isGalois_exactConstantExtension_over_frobeniusTwistField + C (RatFunc C) N S hExact g + ∀ Q : FiniteExtensionInfinityPlace C (ExactConstantExtension C N S), + infinityPlaceGalSmul C F (ExactConstantExtension C N S) + (exactConstantExtensionFrobeniusTwistOverFixedField + C N S hExact g) Q = + infinityPlaceGalSmul C (RatFunc C) (ExactConstantExtension C N S) + (exactConstantExtensionFrobeniusTwist + C (RatFunc C) N S hExact g) Q := by + let : DecidableEq C := infinityBridgeDecidableEqConstants C + let : DecidableEq (RatFunc C) := + infinityBridgeDecidableEqRatFuncConstants C + let : DecidableEq S := infinityBridgeDecidableEqConstants S + let : DecidableEq (RatFunc S) := + infinityBridgeDecidableEqRatFuncConstants S + let T := ExactConstantExtension C N S + let : Field T := exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) T := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : SMul (RatFunc C) T := Algebra.toSMul + let : Module (RatFunc C) T := Algebra.toModule + let : DistribMulAction (RatFunc C) T := Module.toDistribMulAction + let : MulAction (RatFunc C) T := DistribMulAction.toMulAction + let : FiniteDimensional (RatFunc C) T := + finiteDimensional_exactConstantExtension_over_baseRatFunc C S N hExact + let : Algebra.IsSeparable (RatFunc C) T := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + let : IsGalois (RatFunc C) T := + exactConstantExtension_isGalois C (RatFunc C) N S hExact + let F := exactConstantExtensionFrobeniusTwistField + C (RatFunc C) N S hExact g + let : Algebra (RatFunc C) F := + SubalgebraClass.toAlgebra F.toSubalgebra + let : SMul (RatFunc C) F := Algebra.toSMul + let : Module (RatFunc C) F := Algebra.toModule + let : DistribMulAction (RatFunc C) F := Module.toDistribMulAction + let : MulAction (RatFunc C) F := DistribMulAction.toMulAction + let : FiniteDimensional (RatFunc C) F := + finiteDimensional_frobeniusTwistField_over_ratFunc C N S hExact g + let : Algebra.IsSeparable (RatFunc C) F := + isSeparable_frobeniusTwistField_over_ratFunc C N S hExact g + let : Algebra F T := F.toAlgebra + let : SMul F T := Algebra.toSMul + let : Module F T := Algebra.toModule + let : DistribMulAction F T := Module.toDistribMulAction + let : MulAction F T := DistribMulAction.toMulAction + let : IsScalarTower (RatFunc C) F T := inferInstance + let : FiniteDimensional F T := + finiteDimensional_exactConstantExtension_over_frobeniusTwistField + C (RatFunc C) N S hExact g + let : IsGalois F T := + isGalois_exactConstantExtension_over_frobeniusTwistField + C (RatFunc C) N S hExact g + dsimp only + intro Q + apply infinityPlaceGalSmul_eq_of_apply_eq C F (RatFunc C) T + intro x + exact exactConstantExtensionFrobeniusTwistOverFixedField_apply + C N S hExact g x + +omit [DecidableEq C] [DecidableEq (RatFunc C)] + [DecidableEq S] [DecidableEq (RatFunc S)] in +/-- Ambient fixedness by the Frobenius twist is exactly the fixedness +condition needed for infinity-place descent. -/ +theorem frobeniusTwistField_ambientFixed_infinityPlace_under_degree_eq_one + [IsGalois (RatFunc C) N] + (hdiv : Nat.card (N ≃ₐ[RatFunc C] N) ∣ Module.finrank C S) : + let : DecidableEq C := infinityBridgeDecidableEqConstants C + let : DecidableEq (RatFunc C) := + infinityBridgeDecidableEqRatFuncConstants C + let : DecidableEq S := infinityBridgeDecidableEqConstants S + let : DecidableEq (RatFunc S) := + infinityBridgeDecidableEqRatFuncConstants S + let : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : SMul (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toSMul + let : Module (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toModule + let : DistribMulAction (RatFunc C) + (ExactConstantExtension C N S) := Module.toDistribMulAction + let : MulAction (RatFunc C) (ExactConstantExtension C N S) := + DistribMulAction.toMulAction + let : FiniteDimensional (RatFunc C) + (ExactConstantExtension C N S) := + finiteDimensional_exactConstantExtension_over_baseRatFunc + C S N hExact + let : Algebra.IsSeparable (RatFunc C) + (ExactConstantExtension C N S) := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + let : IsGalois (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtension_isGalois C (RatFunc C) N S hExact + let F := exactConstantExtensionFrobeniusTwistField + C (RatFunc C) N S hExact g + let : Algebra (RatFunc C) F := + SubalgebraClass.toAlgebra F.toSubalgebra + let : SMul (RatFunc C) F := Algebra.toSMul + let : Module (RatFunc C) F := Algebra.toModule + let : DistribMulAction (RatFunc C) F := Module.toDistribMulAction + let : MulAction (RatFunc C) F := DistribMulAction.toMulAction + let : FiniteDimensional (RatFunc C) F := + finiteDimensional_frobeniusTwistField_over_ratFunc C N S hExact g + let : Algebra.IsSeparable (RatFunc C) F := + isSeparable_frobeniusTwistField_over_ratFunc C N S hExact g + let : Algebra F (ExactConstantExtension C N S) := F.toAlgebra + let : SMul F (ExactConstantExtension C N S) := Algebra.toSMul + let : Module F (ExactConstantExtension C N S) := Algebra.toModule + let : DistribMulAction F (ExactConstantExtension C N S) := + Module.toDistribMulAction + let : MulAction F (ExactConstantExtension C N S) := + DistribMulAction.toMulAction + let : IsScalarTower (RatFunc C) F + (ExactConstantExtension C N S) := inferInstance + let : FiniteDimensional F (ExactConstantExtension C N S) := + finiteDimensional_exactConstantExtension_over_frobeniusTwistField + C (RatFunc C) N S hExact g + let : IsGalois F (ExactConstantExtension C N S) := + isGalois_exactConstantExtension_over_frobeniusTwistField + C (RatFunc C) N S hExact g + ∀ (Q : FiniteExtensionInfinityPlace C (ExactConstantExtension C N S)), + finiteExtensionPlaceDegree C (ExactConstantExtension C N S) (.inr Q) = + Module.finrank C S → + infinityPlaceGalSmul C (RatFunc C) (ExactConstantExtension C N S) + (exactConstantExtensionFrobeniusTwist + C (RatFunc C) N S hExact g) Q = Q → + finiteExtensionPlaceDegree C F + (.inr (infinityPlaceUnder C F + (ExactConstantExtension C N S) Q)) = 1 := by + intro model0 model1 model2 model3 model4 model5 model6 model7 model8 model9 model10 model11 + model12 F model14 model15 model16 model17 model18 model19 model20 model21 model22 model23 + model24 model25 model26 model27 model28 + let T := ExactConstantExtension C N S + intro Q hdegree hfixed + apply frobeniusTwistField_fixed_infinityPlace_under_degree_eq_one + C N S hExact g hdiv Q hdegree + rw [exactConstantExtensionFrobeniusTwist_infinityPlaceGalSmul_eq_overFixedField + C N S hExact g Q] + exact hfixed + +/-- Rational infinity places of the Frobenius-twist field are exactly the +degree-`[S : C]` top infinity places fixed by the ambient Frobenius twist. -/ +noncomputable def + frobeniusTwistField_rationalInfinityPlace_equiv_ambientFixedInfinityPlace + [IsGalois (RatFunc C) N] + (hdiv : Nat.card (N ≃ₐ[RatFunc C] N) ∣ Module.finrank C S) : + let : DecidableEq C := infinityBridgeDecidableEqConstants C + let : DecidableEq (RatFunc C) := + infinityBridgeDecidableEqRatFuncConstants C + let : DecidableEq S := infinityBridgeDecidableEqConstants S + let : DecidableEq (RatFunc S) := + infinityBridgeDecidableEqRatFuncConstants S + let : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : SMul (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toSMul + let : Module (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toModule + let : DistribMulAction (RatFunc C) + (ExactConstantExtension C N S) := Module.toDistribMulAction + let : MulAction (RatFunc C) (ExactConstantExtension C N S) := + DistribMulAction.toMulAction + let : FiniteDimensional (RatFunc C) + (ExactConstantExtension C N S) := + finiteDimensional_exactConstantExtension_over_baseRatFunc + C S N hExact + let : Algebra.IsSeparable (RatFunc C) + (ExactConstantExtension C N S) := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + let : IsGalois (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtension_isGalois C (RatFunc C) N S hExact + let F := exactConstantExtensionFrobeniusTwistField + C (RatFunc C) N S hExact g + let : Algebra (RatFunc C) F := + SubalgebraClass.toAlgebra F.toSubalgebra + let : SMul (RatFunc C) F := Algebra.toSMul + let : Module (RatFunc C) F := Algebra.toModule + let : DistribMulAction (RatFunc C) F := Module.toDistribMulAction + let : MulAction (RatFunc C) F := DistribMulAction.toMulAction + let : FiniteDimensional (RatFunc C) F := + finiteDimensional_frobeniusTwistField_over_ratFunc C N S hExact g + let : Algebra.IsSeparable (RatFunc C) F := + isSeparable_frobeniusTwistField_over_ratFunc C N S hExact g + let : Algebra F (ExactConstantExtension C N S) := F.toAlgebra + let : SMul F (ExactConstantExtension C N S) := Algebra.toSMul + let : Module F (ExactConstantExtension C N S) := Algebra.toModule + let : DistribMulAction F (ExactConstantExtension C N S) := + Module.toDistribMulAction + let : MulAction F (ExactConstantExtension C N S) := + DistribMulAction.toMulAction + let : IsScalarTower (RatFunc C) F + (ExactConstantExtension C N S) := inferInstance + let : FiniteDimensional F (ExactConstantExtension C N S) := + finiteDimensional_exactConstantExtension_over_frobeniusTwistField + C (RatFunc C) N S hExact g + let : IsGalois F (ExactConstantExtension C N S) := + isGalois_exactConstantExtension_over_frobeniusTwistField + C (RatFunc C) N S hExact g + FiniteExtensionRationalInfinityPlace C F ≃ + {Q : FiniteExtensionInfinityPlace C (ExactConstantExtension C N S) // + finiteExtensionPlaceDegree C (ExactConstantExtension C N S) (.inr Q) = + Module.finrank C S ∧ + infinityPlaceGalSmul C (RatFunc C) (ExactConstantExtension C N S) + (exactConstantExtensionFrobeniusTwist + C (RatFunc C) N S hExact g) Q = Q} := by + intro model0 model1 model2 model3 model4 model5 model6 model7 model8 model9 model10 model11 + model12 F model14 model15 model16 model17 model18 model19 model20 model21 model22 model23 + model24 model25 model26 model27 model28 + let T := ExactConstantExtension C N S + have hfinrank : Module.finrank F T = Module.finrank C S := + finrank_exactConstantExtension_over_frobeniusTwistField + C (RatFunc C) N S hExact g hdiv + have hdegree : ∀ Q : FiniteExtensionInfinityPlace C T, + Module.finrank F T ∣ finiteExtensionPlaceDegree C T (.inr Q) := by + intro Q + rw [hfinrank] + exact exactConstantExtensionInfinityPlace_finrank_constants_dvd_degree + C N S hExact Q + let sigmaF := + exactConstantExtensionFrobeniusTwistOverFixedField C N S hExact g + let eFixed := rationalInfinityPlaceEquivGeneratorFixedPlace + C F T hdegree sigmaF + (exactConstantExtensionFrobeniusTwistOverFixedField_zpowers_eq_top + C N S hExact g) + (frobeniusTwistField_infinityPlace_ramificationIdx_eq_one + C N S hExact g hdiv) + let eCompare : + {Q : FiniteExtensionInfinityPlace C T // + finiteExtensionPlaceDegree C T (.inr Q) = Module.finrank F T ∧ + infinityPlaceGalSmul C F T sigmaF Q = Q} ≃ + {Q : FiniteExtensionInfinityPlace C T // + finiteExtensionPlaceDegree C T (.inr Q) = Module.finrank C S ∧ + infinityPlaceGalSmul C (RatFunc C) T + (exactConstantExtensionFrobeniusTwist + C (RatFunc C) N S hExact g) Q = Q} := + { toFun := fun Q => ⟨Q.1, + Q.2.1.trans hfinrank, + (exactConstantExtensionFrobeniusTwist_infinityPlaceGalSmul_eq_overFixedField + C N S hExact g Q.1).symm.trans Q.2.2⟩ + invFun := fun Q => ⟨Q.1, + Q.2.1.trans hfinrank.symm, + (exactConstantExtensionFrobeniusTwist_infinityPlaceGalSmul_eq_overFixedField + C N S hExact g Q.1).trans Q.2.2⟩ + left_inv := fun Q => Subtype.ext rfl + right_inv := fun Q => Subtype.ext rfl } + exact eFixed.trans eCompare + +end FrobeniusTwistInfinitySpecialization + + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionFrobeniusTwistMultiplication.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionFrobeniusTwistMultiplication.lean new file mode 100644 index 0000000000..01e8b1e818 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionFrobeniusTwistMultiplication.lean @@ -0,0 +1,221 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionFrobeniusTwistConstants +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionFrobeniusTwistDegree + +/-! +# Multiplication presentation of Frobenius-twist constant extensions + +Let `T = S ⊗[C] N`, and let `F_g` be a Frobenius-twist fixed field in +`T`. The multiplication map from `S ⊗[C] F_g` to `T` is an equivalence +over the original function-field base. Thus every twist becomes the same +top field after extending constants from `C` to `S`. + +This is the field-level transport needed to compare the differents, genera, +and Riemann budgets of all twists without identifying the twist fields over +`C(X)` themselves. +-/ + +@[expose] public section + +open scoped TensorProduct + +namespace BGS.HasseWeil + +noncomputable section + + +variable (C L N S : Type*) [Field C] [Field L] [Field N] [Field S] + [Algebra C L] [Algebra L N] [Algebra C N] [IsScalarTower C L N] + [Algebra C S] [FiniteDimensional C S] [IsGalois C S] + [FiniteDimensional L N] [IsGalois L N] + [Fintype C] [Finite S] + +/-- Multiplication identifies the constant extension of a Frobenius-twist +field with the common exact constant extension. -/ +noncomputable def exactConstantExtensionFrobeniusTwistMultiplicationAlgEquiv + (hExact : algebraicClosure C N = + (⊥ : IntermediateField C N)) + (g : N ≃ₐ[L] N) + (hdiv : Nat.card (N ≃ₐ[L] N) ∣ Module.finrank C S) : + letI := exactConstantExtensionField C N S hExact + letI := exactConstantExtensionBaseAlgebra C L N S + let F := exactConstantExtensionFrobeniusTwistField C L N S hExact g + letI : Algebra C F := Algebra.restrictScalars C L F + let hExactF := + exactConstantExtensionFrobeniusTwistField_algebraicClosure_eq_bot + C L N S hExact g + letI := exactConstantExtensionField C F S hExactF + letI := exactConstantExtensionBaseAlgebra C L F S + ExactConstantExtension C F S ≃ₐ[L] ExactConstantExtension C N S := by + let T := ExactConstantExtension C N S + letI : Field T := exactConstantExtensionField C N S hExact + letI : Algebra L T := exactConstantExtensionBaseAlgebra C L N S + have hCLT : algebraMap C T = + (algebraMap L T).comp (algebraMap C L) := by + ext c + change algebraMap C S c ⊗ₜ[C] (1 : N) = + (1 : S) ⊗ₜ[C] algebraMap L N (algebraMap C L c) + rw [← IsScalarTower.algebraMap_apply C L N] + exact Algebra.TensorProduct.tmul_one_eq_one_tmul c + letI : IsScalarTower C L T := IsScalarTower.of_algebraMap_eq' hCLT + let F := exactConstantExtensionFrobeniusTwistField C L N S hExact g + letI : Algebra C F := Algebra.restrictScalars C L F + letI : SMul C F := Algebra.toSMul + letI : Module C F := Algebra.toModule + letI : IsScalarTower C L F := IsScalarTower.of_algebraMap_eq' rfl + have hExactF : algebraicClosure C F = + (⊥ : IntermediateField C F) := + exactConstantExtensionFrobeniusTwistField_algebraicClosure_eq_bot + C L N S hExact g + let U := ExactConstantExtension C F S + letI : Field U := exactConstantExtensionField C F S hExactF + letI : Algebra L U := exactConstantExtensionBaseAlgebra C L F S + let fS : S →ₐ[C] T := Algebra.TensorProduct.includeLeft + let fF : F →ₐ[C] T := F.val.restrictScalars C + let fC : U →ₐ[C] T := Algebra.TensorProduct.productMap fS fF + let f : U →ₐ[L] T := + { fC.toRingHom with + commutes' := fun l => by + change fC ((1 : S) ⊗ₜ[C] algebraMap L F l) = + (1 : S) ⊗ₜ[C] algebraMap L N l + rw [Algebra.TensorProduct.productMap_right_apply] + rfl } + letI : Algebra N T := exactConstantExtensionAlgebra C N S + letI : IsScalarTower L N T := exactConstantExtensionBaseTower C L N S + let eT := exactConstantExtensionLinearEquiv C N S + letI : Module.Finite N (N ⊗[C] S) := Module.Finite.base_change C N S + letI : Module.Finite N T := Module.Finite.equiv eT + letI : Module.Finite L T := Module.Finite.trans N T + letI : Module.Finite L F := Module.Finite.left L F T + letI : Algebra F U := exactConstantExtensionAlgebra C F S + letI : IsScalarTower L F U := exactConstantExtensionBaseTower C L F S + let eU := exactConstantExtensionLinearEquiv C F S + letI : Module.Finite F (F ⊗[C] S) := Module.Finite.base_change C F S + letI : Module.Finite F U := Module.Finite.equiv eU + letI : Module.Finite L U := Module.Finite.trans F U + have hdim : Module.finrank L U = Module.finrank L T := by + calc + Module.finrank L U = Module.finrank L F * Module.finrank C S := + exactConstantExtension_finrank_over_base C L F S + _ = Module.finrank L N * Module.finrank C S := by + rw [finrank_frobeniusTwistField_over_base + C L N S hExact g hdiv] + _ = Module.finrank L T := + (exactConstantExtension_finrank_over_base C L N S).symm + have hinj : Function.Injective f := f.injective + have hsurj : Function.Surjective f := + (LinearMap.injective_iff_surjective_of_finrank_eq_finrank + (f := f.toLinearMap) hdim).mp hinj + exact AlgEquiv.ofBijective f ⟨hinj, hsurj⟩ + +/-- Multiplication also identifies the constant extension of a +Frobenius-twist field with the common top field as an algebra over the +enlarged constant field `S`. This is the scalar structure used to transport +the intrinsic genus. -/ +noncomputable def + exactConstantExtensionFrobeniusTwistMultiplicationAlgEquivOverConstants + (hExact : algebraicClosure C N = + (⊥ : IntermediateField C N)) + (g : N ≃ₐ[L] N) + (hdiv : Nat.card (N ≃ₐ[L] N) ∣ Module.finrank C S) : + letI := exactConstantExtensionField C N S hExact + letI := exactConstantExtensionBaseAlgebra C L N S + let F := exactConstantExtensionFrobeniusTwistField C L N S hExact g + letI : Algebra C F := Algebra.restrictScalars C L F + let hExactF := + exactConstantExtensionFrobeniusTwistField_algebraicClosure_eq_bot + C L N S hExact g + letI := exactConstantExtensionField C F S hExactF + letI : Algebra S (ExactConstantExtension C F S) := + Algebra.TensorProduct.leftAlgebra + letI : Algebra S (ExactConstantExtension C N S) := + Algebra.TensorProduct.leftAlgebra + ExactConstantExtension C F S ≃ₐ[S] ExactConstantExtension C N S := by + let T := ExactConstantExtension C N S + letI : Field T := exactConstantExtensionField C N S hExact + letI : Algebra L T := exactConstantExtensionBaseAlgebra C L N S + have hCLT : algebraMap C T = + (algebraMap L T).comp (algebraMap C L) := by + ext c + change algebraMap C S c ⊗ₜ[C] (1 : N) = + (1 : S) ⊗ₜ[C] algebraMap L N (algebraMap C L c) + rw [← IsScalarTower.algebraMap_apply C L N] + exact Algebra.TensorProduct.tmul_one_eq_one_tmul c + letI : IsScalarTower C L T := IsScalarTower.of_algebraMap_eq' hCLT + let F := exactConstantExtensionFrobeniusTwistField C L N S hExact g + letI : Algebra C F := Algebra.restrictScalars C L F + letI : SMul C F := Algebra.toSMul + letI : Module C F := Algebra.toModule + letI : IsScalarTower C L F := IsScalarTower.of_algebraMap_eq' rfl + have hExactF : algebraicClosure C F = + (⊥ : IntermediateField C F) := + exactConstantExtensionFrobeniusTwistField_algebraicClosure_eq_bot + C L N S hExact g + let U := ExactConstantExtension C F S + letI : Field U := exactConstantExtensionField C F S hExactF + letI : Algebra L U := exactConstantExtensionBaseAlgebra C L F S + let fConst : S →ₐ[C] T := Algebra.TensorProduct.includeLeft + let fTwist : F →ₐ[C] T := F.val.restrictScalars C + let fC : U →ₐ[C] T := + Algebra.TensorProduct.productMap fConst fTwist + let fL : U →ₐ[L] T := + { fC.toRingHom with + commutes' := fun l => by + change fC ((1 : S) ⊗ₜ[C] algebraMap L F l) = + (1 : S) ⊗ₜ[C] algebraMap L N l + rw [Algebra.TensorProduct.productMap_right_apply] + rfl } + letI : Algebra S U := Algebra.TensorProduct.leftAlgebra + letI : Algebra S T := Algebra.TensorProduct.leftAlgebra + let fS : U →ₐ[S] T := + { fC.toRingHom with + commutes' := fun s => by + change fC (s ⊗ₜ[C] (1 : F)) = s ⊗ₜ[C] (1 : N) + rw [Algebra.TensorProduct.productMap_left_apply] + rfl } + letI : Algebra N T := exactConstantExtensionAlgebra C N S + letI : IsScalarTower L N T := exactConstantExtensionBaseTower C L N S + let eT := exactConstantExtensionLinearEquiv C N S + letI : Module.Finite N (N ⊗[C] S) := Module.Finite.base_change C N S + letI : Module.Finite N T := Module.Finite.equiv eT + letI : Module.Finite L T := Module.Finite.trans N T + letI : Module.Finite L F := Module.Finite.left L F T + letI : Algebra F U := exactConstantExtensionAlgebra C F S + letI : IsScalarTower L F U := exactConstantExtensionBaseTower C L F S + let eU := exactConstantExtensionLinearEquiv C F S + letI : Module.Finite F (F ⊗[C] S) := Module.Finite.base_change C F S + letI : Module.Finite F U := Module.Finite.equiv eU + letI : Module.Finite L U := Module.Finite.trans F U + have hdim : Module.finrank L U = Module.finrank L T := by + calc + Module.finrank L U = Module.finrank L F * Module.finrank C S := + exactConstantExtension_finrank_over_base C L F S + _ = Module.finrank L N * Module.finrank C S := by + rw [finrank_frobeniusTwistField_over_base + C L N S hExact g hdiv] + _ = Module.finrank L T := + (exactConstantExtension_finrank_over_base C L N S).symm + have hinjL : Function.Injective fL := fL.injective + have hsurjL : Function.Surjective fL := + (LinearMap.injective_iff_surjective_of_finrank_eq_finrank + (f := fL.toLinearMap) hdim).mp hinjL + have hinjS : Function.Injective fS := by + intro x y hxy + apply hinjL + exact hxy + have hsurjS : Function.Surjective fS := by + intro y + obtain ⟨x, hx⟩ := hsurjL y + exact ⟨x, hx⟩ + exact AlgEquiv.ofBijective fS ⟨hinjS, hsurjS⟩ + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionFrobeniusTwistRationalPlaceAverage.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionFrobeniusTwistRationalPlaceAverage.lean new file mode 100644 index 0000000000..adb6b977e6 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionFrobeniusTwistRationalPlaceAverage.lean @@ -0,0 +1,314 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionFrobeniusTwistDegree +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionFrobeniusTwistFinitePlaceAverage +public import LeanPool.MarkoffModP.BGS.HasseWeil.GaloisAverage + +/-! +# Complete rational-place averaging for Frobenius twists + +The finite-place Frobenius average is exact, including above ramified base +places. Passing from finite rational places to the complete rational-place +count therefore introduces only the places above infinity. Their number on +each twist is bounded by the degree of the original function field, uniformly +in the auxiliary constant extension. + +This file records both the exact aggregate identity and the resulting uniform +bound for the centered aggregate error. No branch-locus estimate is needed at +this boundary. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +noncomputable section + +open BGS.CorvajaZannier +open scoped BigOperators TensorProduct + + +variable (C S N : Type*) [Field C] [Field S] [Field N] + [Fintype C] [Finite S] + [DecidableEq C] [DecidableEq S] + [DecidableEq (RatFunc C)] [DecidableEq (RatFunc S)] + [Algebra (RatFunc C) N] [FiniteDimensional (RatFunc C) N] + [IsGalois (RatFunc C) N] + [Algebra C S] [FiniteDimensional C S] [IsGalois C S] + +local instance rationalPlaceAverageBaseConstantAlgebra : Algebra C N := + bridgeBaseConstantAlgebra C N + +local instance rationalPlaceAverageBaseConstantTower : + IsScalarTower C (RatFunc C) N := + IsScalarTower.of_algebraMap_eq' rfl + +/-- The number of rational places above infinity on one Frobenius-twist +field. -/ +noncomputable def frobeniusTwistFieldRationalInfinityPlaceCount + (hExact : algebraicClosure C N = + (⊥ : IntermediateField C N)) + (g : N ≃ₐ[RatFunc C] N) : ℕ := + let T := ExactConstantExtension C N S + letI : Field T := exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) T := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + letI : SMul (RatFunc C) T := Algebra.toSMul + letI : Module (RatFunc C) T := Algebra.toModule + letI : DistribMulAction (RatFunc C) T := Module.toDistribMulAction + letI : MulAction (RatFunc C) T := DistribMulAction.toMulAction + letI : FiniteDimensional (RatFunc C) T := + finiteDimensional_exactConstantExtension_over_baseRatFunc C S N hExact + letI : IsGalois (RatFunc C) T := + exactConstantExtension_isGalois C (RatFunc C) N S hExact + letI : Algebra.IsSeparable (RatFunc C) T := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + let F := exactConstantExtensionFrobeniusTwistField + C (RatFunc C) N S hExact g + letI : Algebra (RatFunc C) F := + SubalgebraClass.toAlgebra F.toSubalgebra + letI : SMul (RatFunc C) F := Algebra.toSMul + letI : Module (RatFunc C) F := Algebra.toModule + letI : FiniteDimensional (RatFunc C) F := + finiteDimensional_frobeniusTwistField_over_ratFunc C N S hExact g + letI : Algebra.IsSeparable (RatFunc C) F := + isSeparable_frobeniusTwistField_over_ratFunc C N S hExact g + Nat.card (FiniteExtensionRationalInfinityPlace C F) + +/-- The complete rational-place count of one Frobenius-twist field, split +into its finite and infinity parts. -/ +noncomputable def frobeniusTwistFieldRationalPlaceCount + (hExact : algebraicClosure C N = + (⊥ : IntermediateField C N)) + (g : N ≃ₐ[RatFunc C] N) : ℕ := + frobeniusTwistFieldRationalFinitePlaceCount C S N hExact g + + frobeniusTwistFieldRationalInfinityPlaceCount C S N hExact g + +omit [Finite S] [DecidableEq S] [DecidableEq (RatFunc S)] in +/-- The split definition is the actual complete degree-one place count of +the twist field. -/ +theorem frobeniusTwistFieldRationalPlaceCount_eq_finiteExtensionRationalPlaceCount + (hExact : algebraicClosure C N = + (⊥ : IntermediateField C N)) + (g : N ≃ₐ[RatFunc C] N) : + let T := ExactConstantExtension C N S + letI : Field T := exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) T := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + letI : SMul (RatFunc C) T := Algebra.toSMul + letI : Module (RatFunc C) T := Algebra.toModule + letI : DistribMulAction (RatFunc C) T := Module.toDistribMulAction + letI : MulAction (RatFunc C) T := DistribMulAction.toMulAction + letI : FiniteDimensional (RatFunc C) T := + finiteDimensional_exactConstantExtension_over_baseRatFunc C S N hExact + letI : IsGalois (RatFunc C) T := + exactConstantExtension_isGalois C (RatFunc C) N S hExact + letI : Algebra.IsSeparable (RatFunc C) T := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + let F := exactConstantExtensionFrobeniusTwistField + C (RatFunc C) N S hExact g + letI : Algebra (RatFunc C) F := + SubalgebraClass.toAlgebra F.toSubalgebra + letI : SMul (RatFunc C) F := Algebra.toSMul + letI : Module (RatFunc C) F := Algebra.toModule + letI : FiniteDimensional (RatFunc C) F := + finiteDimensional_frobeniusTwistField_over_ratFunc C N S hExact g + letI : Algebra.IsSeparable (RatFunc C) F := + isSeparable_frobeniusTwistField_over_ratFunc C N S hExact g + frobeniusTwistFieldRationalPlaceCount C S N hExact g = + finiteExtensionRationalPlaceCount C F := by + let T := ExactConstantExtension C N S + let : Field T := exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) T := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : SMul (RatFunc C) T := Algebra.toSMul + let : Module (RatFunc C) T := Algebra.toModule + let : DistribMulAction (RatFunc C) T := Module.toDistribMulAction + let : MulAction (RatFunc C) T := DistribMulAction.toMulAction + let : FiniteDimensional (RatFunc C) T := + finiteDimensional_exactConstantExtension_over_baseRatFunc C S N hExact + let : IsGalois (RatFunc C) T := + exactConstantExtension_isGalois C (RatFunc C) N S hExact + let : Algebra.IsSeparable (RatFunc C) T := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + let F := exactConstantExtensionFrobeniusTwistField + C (RatFunc C) N S hExact g + let : Algebra (RatFunc C) F := + SubalgebraClass.toAlgebra F.toSubalgebra + let : SMul (RatFunc C) F := Algebra.toSMul + let : Module (RatFunc C) F := Algebra.toModule + let : FiniteDimensional (RatFunc C) F := + finiteDimensional_frobeniusTwistField_over_ratFunc C N S hExact g + let : Algebra.IsSeparable (RatFunc C) F := + isSeparable_frobeniusTwistField_over_ratFunc C N S hExact g + let : Finite (FiniteExtensionRationalFinitePlace C F) := inferInstance + let : Finite (FiniteExtensionRationalInfinityPlace C F) := inferInstance + unfold frobeniusTwistFieldRationalPlaceCount + rw [frobeniusTwistFieldRationalFinitePlaceCount, + frobeniusTwistFieldRationalInfinityPlaceCount] + change Nat.card (FiniteExtensionRationalFinitePlace C F) + + Nat.card (FiniteExtensionRationalInfinityPlace C F) = + Nat.card (FiniteExtensionRationalFinitePlace C F ⊕ + FiniteExtensionRationalInfinityPlace C F) + exact Nat.card_sum.symm + +omit [DecidableEq S] [DecidableEq (RatFunc S)] in +/-- The infinity contribution of each twist is bounded by the degree of the +original function field, independently of the auxiliary constant extension. +-/ +theorem frobeniusTwistFieldRationalInfinityPlaceCount_le_original_finrank + (hExact : algebraicClosure C N = + (⊥ : IntermediateField C N)) + (g : N ≃ₐ[RatFunc C] N) + (hdiv : Nat.card (N ≃ₐ[RatFunc C] N) ∣ Module.finrank C S) : + frobeniusTwistFieldRationalInfinityPlaceCount C S N hExact g ≤ + Module.finrank (RatFunc C) N := by + let T := ExactConstantExtension C N S + let : Field T := exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) T := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : SMul (RatFunc C) T := Algebra.toSMul + let : Module (RatFunc C) T := Algebra.toModule + let : DistribMulAction (RatFunc C) T := Module.toDistribMulAction + let : MulAction (RatFunc C) T := DistribMulAction.toMulAction + let : FiniteDimensional (RatFunc C) T := + finiteDimensional_exactConstantExtension_over_baseRatFunc C S N hExact + let : IsGalois (RatFunc C) T := + exactConstantExtension_isGalois C (RatFunc C) N S hExact + let : Algebra.IsSeparable (RatFunc C) T := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + let F := exactConstantExtensionFrobeniusTwistField + C (RatFunc C) N S hExact g + let : Algebra (RatFunc C) F := + SubalgebraClass.toAlgebra F.toSubalgebra + let : SMul (RatFunc C) F := Algebra.toSMul + let : Module (RatFunc C) F := Algebra.toModule + let : FiniteDimensional (RatFunc C) F := + finiteDimensional_frobeniusTwistField_over_ratFunc C N S hExact g + let : Algebra.IsSeparable (RatFunc C) F := + isSeparable_frobeniusTwistField_over_ratFunc C N S hExact g + change Nat.card (FiniteExtensionRationalInfinityPlace C F) ≤ + Module.finrank (RatFunc C) N + calc + Nat.card (FiniteExtensionRationalInfinityPlace C F) ≤ + Module.finrank (RatFunc C) F := + rationalInfinityPlace_card_le_finrank C F + _ = Module.finrank (RatFunc C) N := + finrank_frobeniusTwistField_over_ratFunc_eq_original + C N S hExact g hdiv + +omit [DecidableEq S] [DecidableEq (RatFunc S)] in +/-- The total infinity contribution of all twists is uniformly bounded by +the Galois-group order times the original function-field degree. -/ +theorem sum_frobeniusTwistFieldRationalInfinityPlaceCount_le + (hExact : algebraicClosure C N = + (⊥ : IntermediateField C N)) + (hdiv : Nat.card (N ≃ₐ[RatFunc C] N) ∣ Module.finrank C S) : + (∑ g : N ≃ₐ[RatFunc C] N, + frobeniusTwistFieldRationalInfinityPlaceCount C S N hExact g) ≤ + Nat.card (N ≃ₐ[RatFunc C] N) * + Module.finrank (RatFunc C) N := by + calc + (∑ g : N ≃ₐ[RatFunc C] N, + frobeniusTwistFieldRationalInfinityPlaceCount C S N hExact g) ≤ + ∑ _g : N ≃ₐ[RatFunc C] N, + Module.finrank (RatFunc C) N := by + exact Finset.sum_le_sum fun g _ => + frobeniusTwistFieldRationalInfinityPlaceCount_le_original_finrank + C S N hExact g hdiv + _ = Nat.card (N ≃ₐ[RatFunc C] N) * + Module.finrank (RatFunc C) N := by + simp [Nat.card_eq_fintype_card] + +/-- Exact finite-plus-infinity aggregate identity. All finite rational +places contribute exactly `|Gal(N/C(X))| * |C|`; the displayed infinity sum +is the entire correction to the complete rational-place count. -/ +theorem sum_frobeniusTwistFieldRationalPlaceCount_eq + (hExact : algebraicClosure C N = + (⊥ : IntermediateField C N)) + (hdiv : Nat.card (N ≃ₐ[RatFunc C] N) ∣ Module.finrank C S) : + (∑ g : N ≃ₐ[RatFunc C] N, + frobeniusTwistFieldRationalPlaceCount C S N hExact g) = + Nat.card (N ≃ₐ[RatFunc C] N) * Nat.card C + + ∑ g : N ≃ₐ[RatFunc C] N, + frobeniusTwistFieldRationalInfinityPlaceCount C S N hExact g := by + simp_rw [frobeniusTwistFieldRationalPlaceCount] + rw [Finset.sum_add_distrib, + sum_frobeniusTwistFieldRationalFinitePlaceCount_eq_card_galois_mul_card + C S N hExact hdiv] + +/-- Exact centered aggregate-error identity over the reals. It makes +explicit that the complete-place error is the infinity contribution minus +one point for each twist. -/ +theorem sum_frobeniusTwistFieldRationalPlaceError_eq + (hExact : algebraicClosure C N = + (⊥ : IntermediateField C N)) + (hdiv : Nat.card (N ≃ₐ[RatFunc C] N) ∣ Module.finrank C S) : + (∑ g : N ≃ₐ[RatFunc C] N, + ((frobeniusTwistFieldRationalPlaceCount C S N hExact g : ℝ) - + (Nat.card C : ℝ) - 1)) = + (∑ g : N ≃ₐ[RatFunc C] N, + (frobeniusTwistFieldRationalInfinityPlaceCount + C S N hExact g : ℝ)) - + (Nat.card (N ≃ₐ[RatFunc C] N) : ℝ) := by + have htotal := sum_frobeniusTwistFieldRationalPlaceCount_eq + C S N hExact hdiv + have htotalReal : + (∑ g : N ≃ₐ[RatFunc C] N, + (frobeniusTwistFieldRationalPlaceCount C S N hExact g : ℝ)) = + (Nat.card (N ≃ₐ[RatFunc C] N) : ℝ) * + (Nat.card C : ℝ) + + ∑ g : N ≃ₐ[RatFunc C] N, + (frobeniusTwistFieldRationalInfinityPlaceCount + C S N hExact g : ℝ) := by + exact_mod_cast htotal + rw [Finset.sum_sub_distrib, Finset.sum_sub_distrib, htotalReal] + simp only [Finset.sum_const, Finset.card_univ, nsmul_eq_mul, + mul_one, Nat.card_eq_fintype_card] + ring + +/-- The centered aggregate error is bounded uniformly in the auxiliary +constant extension. The sharper factor `finrank`, rather than +`finrank + 1`, follows because the original function-field degree is positive. +-/ +theorem abs_sum_frobeniusTwistFieldRationalPlaceError_le + (hExact : algebraicClosure C N = + (⊥ : IntermediateField C N)) + (hdiv : Nat.card (N ≃ₐ[RatFunc C] N) ∣ Module.finrank C S) : + |∑ g : N ≃ₐ[RatFunc C] N, + ((frobeniusTwistFieldRationalPlaceCount C S N hExact g : ℝ) - + (Nat.card C : ℝ) - 1)| ≤ + (Nat.card (N ≃ₐ[RatFunc C] N) : ℝ) * + Module.finrank (RatFunc C) N := by + rw [sum_frobeniusTwistFieldRationalPlaceError_eq C S N hExact hdiv] + let infinitySum : ℝ := + ∑ g : N ≃ₐ[RatFunc C] N, + (frobeniusTwistFieldRationalInfinityPlaceCount C S N hExact g : ℝ) + let groupCard : ℝ := Nat.card (N ≃ₐ[RatFunc C] N) + let degree : ℝ := Module.finrank (RatFunc C) N + have hinfinity_nonneg : 0 ≤ infinitySum := by + dsimp only [infinitySum] + positivity + have hgroup_nonneg : 0 ≤ groupCard := by + dsimp only [groupCard] + positivity + have hdegree_one : 1 ≤ degree := by + dsimp only [degree] + exact_mod_cast (Module.finrank_pos (R := RatFunc C) (M := N)) + have hinfinity_le : infinitySum ≤ groupCard * degree := by + dsimp only [infinitySum, groupCard, degree] + exact_mod_cast + (sum_frobeniusTwistFieldRationalInfinityPlaceCount_le + C S N hExact hdiv) + apply abs_le.mpr + constructor <;> nlinarith + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionFrobeniusTwistRiemannLower.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionFrobeniusTwistRiemannLower.lean new file mode 100644 index 0000000000..12182e98cb --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionFrobeniusTwistRiemannLower.lean @@ -0,0 +1,210 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionFrobeniusTwistConstants +public import LeanPool.MarkoffModP.BGS.HasseWeil.GeneralFiniteExtensionRiemannLower + +/-! +# A common Riemann budget for Frobenius-twist fields + +For a fixed finite constant extension `S / C`, there are only finitely many +Frobenius-twist fields attached to the elements of `Gal(N / C(X))`. The +primitive-element Riemann inequality supplies a finite-place budget for each +twist. Summing these finitely many budgets gives one budget which works for +every twist field simultaneously. + +This file also records that the same twist fields have exact constant field +`C`, so the common budget and the constant-field input needed by the intrinsic +Stepanov estimate are available at the same boundary. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +open BGS.CorvajaZannier +open scoped TensorProduct + +noncomputable section + + +variable (C N S : Type*) [Field C] [Fintype C] [DecidableEq C] + [DecidableEq (RatFunc C)] + [Field N] [Algebra (RatFunc C) N] [Algebra C N] + [IsScalarTower C (RatFunc C) N] + [FiniteDimensional (RatFunc C) N] + [Algebra.IsSeparable (RatFunc C) N] + [Field S] [Algebra C S] [FiniteDimensional C S] [IsGalois C S] + [Finite S] + +omit [DecidableEq C] [DecidableEq (RatFunc C)] + [Algebra.IsSeparable (RatFunc C) N] [Finite S] in +/-- A twist fixed field is finite-dimensional over the rational-function +base because it embeds into the finite exact constant extension. -/ +theorem finiteDimensional_frobeniusTwistField_over_ratFunc + (hExact : algebraicClosure C N = + (⊥ : IntermediateField C N)) + (g : N ≃ₐ[RatFunc C] N) : + letI := exactConstantExtensionField C N S hExact + letI := exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let F := exactConstantExtensionFrobeniusTwistField + C (RatFunc C) N S hExact g + FiniteDimensional (RatFunc C) F := by + let T := ExactConstantExtension C N S + let : Field T := exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) T := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : Algebra N T := exactConstantExtensionAlgebra C N S + let : IsScalarTower (RatFunc C) N T := + exactConstantExtensionBaseTower C (RatFunc C) N S + let tensorEquiv := exactConstantExtensionLinearEquiv C N S + let : Module.Finite N (N ⊗[C] S) := Module.Finite.base_change C N S + let : Module.Finite N T := Module.Finite.equiv tensorEquiv + let : Module.Finite (RatFunc C) T := Module.Finite.trans N T + let F := exactConstantExtensionFrobeniusTwistField + C (RatFunc C) N S hExact g + exact Module.Finite.left (RatFunc C) F T + +omit [DecidableEq C] [DecidableEq (RatFunc C)] + [FiniteDimensional (RatFunc C) N] [Finite S] in +/-- Separability descends from the finite separable exact constant extension +to each intermediate twist fixed field. -/ +theorem isSeparable_frobeniusTwistField_over_ratFunc + (hExact : algebraicClosure C N = + (⊥ : IntermediateField C N)) + (g : N ≃ₐ[RatFunc C] N) : + letI := exactConstantExtensionField C N S hExact + letI := exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let F := exactConstantExtensionFrobeniusTwistField + C (RatFunc C) N S hExact g + Algebra.IsSeparable (RatFunc C) F := by + let T := ExactConstantExtension C N S + let : Field T := exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) T := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let F := exactConstantExtensionFrobeniusTwistField + C (RatFunc C) N S hExact g + let : SMul (RatFunc C) T := Algebra.toSMul + let : Module (RatFunc C) T := Algebra.toModule + let : Algebra N T := exactConstantExtensionAlgebra C N S + let : SMul N T := Algebra.toSMul + let : Module N T := Algebra.toModule + let : IsScalarTower (RatFunc C) N T := + exactConstantExtensionBaseTower C (RatFunc C) N S + let : IsGalois N T := + exactConstantExtension_isGalois C N N S hExact + let : Algebra.IsSeparable (RatFunc C) T := + Algebra.IsSeparable.trans (RatFunc C) N T + exact Algebra.isSeparable_tower_bot_of_isSeparable (RatFunc C) F T + +omit [Finite S] in +/-- Each Frobenius-twist field is a finite separable function field over +`C(X)`, hence has a finite-place Riemann budget. -/ +private theorem exists_frobeniusTwistField_finitePlace_riemann_lower_budget + (hExact : algebraicClosure C N = + (⊥ : IntermediateField C N)) + (g : N ≃ₐ[RatFunc C] N) : + letI := exactConstantExtensionField C N S hExact + letI := exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let F := exactConstantExtensionFrobeniusTwistField + C (RatFunc C) N S hExact g + letI : FiniteDimensional (RatFunc C) F := + finiteDimensional_frobeniusTwistField_over_ratFunc C N S hExact g + letI : Algebra.IsSeparable (RatFunc C) F := + isSeparable_frobeniusTwistField_over_ratFunc C N S hExact g + ∃ budget : ℕ, + ∀ (q : FiniteExtensionFinitePlace C F) (poleOrder : ℕ), + poleOrder * finiteExtensionPlaceDegree C F (.inl q) + 1 ≤ + Module.finrank C + (finiteExtensionOnePointRiemannSpace C F (.inl q) poleOrder) + + budget := by + let := exactConstantExtensionField C N S hExact + let := exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let F := exactConstantExtensionFrobeniusTwistField + C (RatFunc C) N S hExact g + let : FiniteDimensional (RatFunc C) F := + finiteDimensional_frobeniusTwistField_over_ratFunc C N S hExact g + let : Algebra.IsSeparable (RatFunc C) F := + isSeparable_frobeniusTwistField_over_ratFunc C N S hExact g + exact exists_finitePlace_riemann_lower_budget C F + +omit [Finite S] in +/-- For one fixed finite extension of the constants, a single natural-number +budget works for the finite-place Riemann inequality in every Frobenius-twist +field. -/ +theorem exists_common_frobeniusTwistField_finitePlace_riemann_lower_budget + (hExact : algebraicClosure C N = + (⊥ : IntermediateField C N)) : + letI := exactConstantExtensionField C N S hExact + letI := exactConstantExtensionBaseAlgebra C (RatFunc C) N S + ∃ budget : ℕ, + ∀ (g : N ≃ₐ[RatFunc C] N), + let F := exactConstantExtensionFrobeniusTwistField + C (RatFunc C) N S hExact g + letI : FiniteDimensional (RatFunc C) F := + finiteDimensional_frobeniusTwistField_over_ratFunc C N S hExact g + letI : Algebra.IsSeparable (RatFunc C) F := + isSeparable_frobeniusTwistField_over_ratFunc C N S hExact g + ∀ (q : FiniteExtensionFinitePlace C F) (poleOrder : ℕ), + poleOrder * finiteExtensionPlaceDegree C F (.inl q) + 1 ≤ + Module.finrank C + (finiteExtensionOnePointRiemannSpace C F (.inl q) poleOrder) + + budget := by + let := exactConstantExtensionField C N S hExact + let := exactConstantExtensionBaseAlgebra C (RatFunc C) N S + choose twistBudget htwistBudget using fun g : N ≃ₐ[RatFunc C] N => + exists_frobeniusTwistField_finitePlace_riemann_lower_budget + C N S hExact g + let budget : ℕ := ∑ g : N ≃ₐ[RatFunc C] N, twistBudget g + refine ⟨budget, ?_⟩ + intro g + dsimp only + have hle : twistBudget g ≤ budget := by + dsimp only [budget] + exact Finset.single_le_sum (fun _ _ => Nat.zero_le _) (Finset.mem_univ g) + intro q poleOrder + exact (htwistBudget g q poleOrder).trans + (Nat.add_le_add_left hle _) + +/-- The common Riemann budget can be chosen simultaneously with the statement +that every Frobenius-twist field has exact constant field `C`. -/ +theorem exists_common_frobeniusTwistField_exactConstants_and_riemann_budget + (hExact : algebraicClosure C N = + (⊥ : IntermediateField C N)) : + letI := exactConstantExtensionField C N S hExact + letI := exactConstantExtensionBaseAlgebra C (RatFunc C) N S + ∃ budget : ℕ, + ∀ (g : N ≃ₐ[RatFunc C] N), + let F := exactConstantExtensionFrobeniusTwistField + C (RatFunc C) N S hExact g + letI : FiniteDimensional (RatFunc C) F := + finiteDimensional_frobeniusTwistField_over_ratFunc C N S hExact g + letI : Algebra.IsSeparable (RatFunc C) F := + isSeparable_frobeniusTwistField_over_ratFunc C N S hExact g + letI : Algebra C F := Algebra.restrictScalars C (RatFunc C) F + algebraicClosure C F = (⊥ : IntermediateField C F) ∧ + ∀ (q : FiniteExtensionFinitePlace C F) (poleOrder : ℕ), + poleOrder * finiteExtensionPlaceDegree C F (.inl q) + 1 ≤ + Module.finrank C + (finiteExtensionOnePointRiemannSpace C F (.inl q) poleOrder) + + budget := by + let := exactConstantExtensionField C N S hExact + let := exactConstantExtensionBaseAlgebra C (RatFunc C) N S + obtain ⟨budget, hbudget⟩ := + exists_common_frobeniusTwistField_finitePlace_riemann_lower_budget + C N S hExact + refine ⟨budget, ?_⟩ + intro g + dsimp only + refine ⟨?_, hbudget g⟩ + exact exactConstantExtensionFrobeniusTwistField_algebraicClosure_eq_bot + C (RatFunc C) N S hExact g + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionFrobeniusTwistStepanovUpper.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionFrobeniusTwistStepanovUpper.lean new file mode 100644 index 0000000000..62bf1d5520 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionFrobeniusTwistStepanovUpper.lean @@ -0,0 +1,259 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionFrobeniusTwistDegree +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionFrobeniusTwistBoundedError +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionFrobeniusTwistGenus +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionRiemannLowerFromGenus +public import LeanPool.MarkoffModP.BGS.HasseWeil.GeneralSquareFieldStepanovCount + +/-! +# A uniform Stepanov upper bound for exact-constant Frobenius twists + +For one fixed exact extension of the constants, the Frobenius-twist fixed +fields have a common finite-place Riemann budget and exact constant field. +When the ground constant field is a square, the intrinsic one-point +Stepanov theorem therefore applies to every twist with the same numerical +budget. The degree theorem for the twists replaces the residual +function-field degree term by the degree of the original field. + +This is the uniform upper estimate used in the fixed-field averaging route to +Hasse--Weil. It does not require a separate genus-invariance hypothesis: the +common Riemann budget is the exact input consumed by the Stepanov theorem. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +noncomputable section + +open BGS.CorvajaZannier + + +variable (K C N S : Type*) + [Field K] [Fintype K] + [Field C] [Fintype C] [DecidableEq C] [Algebra K C] + [DecidableEq (RatFunc C)] + [Field N] [Algebra (RatFunc C) N] + [FiniteDimensional (RatFunc C) N] + [Algebra.IsSeparable (RatFunc C) N] [IsGalois (RatFunc C) N] + [Field S] [Algebra C S] [FiniteDimensional C S] [IsGalois C S] + [Finite S] + +local instance twistStepanovBaseConstantAlgebra : Algebra C N := + bridgeBaseConstantAlgebra C N + +local instance twistStepanovBaseConstantTower : + IsScalarTower C (RatFunc C) N := + IsScalarTower.of_algebraMap_eq' rfl + +local instance (priority := 10000) twistStepanovFieldDecidableEq + (F : Type*) [Field F] : DecidableEq F := Classical.decEq _ + +local instance (priority := 10001) twistStepanovRatFuncDecidableEq + (F : Type*) [Field F] : DecidableEq (RatFunc F) := Classical.decEq _ + +omit [IsGalois (RatFunc C) N] in +/-- A single Stepanov budget gives the square-field rational-place upper +bound for every Frobenius-twist fixed field. The final degree term is uniform: +it is the degree of the original function field `N / C(X)`. + +The divisibility condition is exactly the one used to prove that every twist +has the same degree as `N`; in the Stichtenoth construction it is ensured by +the chosen constant-extension degree. -/ +theorem exists_uniform_frobeniusTwistField_squareFieldStepanov_budget + (hcard : Fintype.card C = (Fintype.card K) ^ 2) + (hExact : algebraicClosure C N = + (⊥ : IntermediateField C N)) + (hdiv : Nat.card (N ≃ₐ[RatFunc C] N) ∣ Module.finrank C S) : + let T := ExactConstantExtension C N S + letI : Field T := exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) T := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + letI : SMul (RatFunc C) T := Algebra.toSMul + letI : Module (RatFunc C) T := Algebra.toModule + letI : DistribMulAction (RatFunc C) T := Module.toDistribMulAction + letI : MulAction (RatFunc C) T := DistribMulAction.toMulAction + ∃ budget : ℕ, + ∀ (g : N ≃ₐ[RatFunc C] N), + let F := exactConstantExtensionFrobeniusTwistField + C (RatFunc C) N S hExact g + letI : Algebra (RatFunc C) F := + SubalgebraClass.toAlgebra F.toSubalgebra + letI : SMul (RatFunc C) F := Algebra.toSMul + letI : Module (RatFunc C) F := Algebra.toModule + letI : FiniteDimensional (RatFunc C) F := + finiteDimensional_frobeniusTwistField_over_ratFunc + C N S hExact g + letI : Algebra.IsSeparable (RatFunc C) F := + isSeparable_frobeniusTwistField_over_ratFunc + C N S hExact g + (budget + 1) * (budget + 2) ≤ Fintype.card K → + finiteExtensionRationalPlaceCount C F ≤ + Fintype.card C + (2 * budget + 1) * Fintype.card K + + Module.finrank (RatFunc C) N := by + let T := ExactConstantExtension C N S + let : Field T := exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) T := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : SMul (RatFunc C) T := Algebra.toSMul + let : Module (RatFunc C) T := Algebra.toModule + let : DistribMulAction (RatFunc C) T := Module.toDistribMulAction + let : MulAction (RatFunc C) T := DistribMulAction.toMulAction + obtain ⟨budget, hbudget⟩ := + exists_common_frobeniusTwistField_exactConstants_and_riemann_budget + C N S hExact + refine ⟨budget, ?_⟩ + intro g + dsimp only + let F := exactConstantExtensionFrobeniusTwistField + C (RatFunc C) N S hExact g + let : Algebra (RatFunc C) F := + SubalgebraClass.toAlgebra F.toSubalgebra + let : SMul (RatFunc C) F := Algebra.toSMul + let : Module (RatFunc C) F := Algebra.toModule + let : FiniteDimensional (RatFunc C) F := + finiteDimensional_frobeniusTwistField_over_ratFunc + C N S hExact g + let : Algebra.IsSeparable (RatFunc C) F := + isSeparable_frobeniusTwistField_over_ratFunc + C N S hExact g + let : Algebra C F := Algebra.restrictScalars C (RatFunc C) F + intro hlarge + have hstepanov := + finiteExtensionRationalPlaceCount_le_squareFieldStepanov_of_finitePlaceRiemann + K C F budget hcard (hbudget g).1 (fun Q poleOrder => by + have h := (hbudget g).2 Q.1 poleOrder + have hdeg : finiteExtensionPlaceDegree C F (.inl Q.1) = 1 := Q.2 + change poleOrder * finiteExtensionPlaceDegree C F (.inl Q.1) + 1 ≤ _ at h + rw [hdeg, Nat.mul_one] at h + exact h) hlarge + calc + finiteExtensionRationalPlaceCount C F ≤ + Fintype.card C + (2 * budget + 1) * Fintype.card K + + Module.finrank (RatFunc C) F := hstepanov + _ = Fintype.card C + (2 * budget + 1) * Fintype.card K + + Module.finrank (RatFunc C) N := by + rw [finrank_frobeniusTwistField_over_ratFunc_eq_original + C N S hExact g hdiv] + +/-- The uniform twist estimate with the intrinsic genus of the original +field as its fixed budget. Unlike the existential compatibility theorem +above, every constant in this statement is independent of the auxiliary +constant extension `S`. -/ +theorem frobeniusTwistFieldRationalPlaceCount_le_squareField_of_genus + (hcard : Fintype.card C = (Fintype.card K) ^ 2) + (hExact : algebraicClosure C N = + (⊥ : IntermediateField C N)) + (hdiv : Nat.card (N ≃ₐ[RatFunc C] N) ∣ Module.finrank C S) + (g : N ≃ₐ[RatFunc C] N) + (hlarge : (FunctionField.genus C N + 1) * + (FunctionField.genus C N + 2) ≤ Fintype.card K) : + frobeniusTwistFieldRationalPlaceCount C S N hExact g ≤ + Fintype.card C + (2 * FunctionField.genus C N + 1) * + Fintype.card K + Module.finrank (RatFunc C) N := by + let T := ExactConstantExtension C N S + let : Field T := exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) T := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : SMul (RatFunc C) T := Algebra.toSMul + let : Module (RatFunc C) T := Algebra.toModule + let : DistribMulAction (RatFunc C) T := Module.toDistribMulAction + let : MulAction (RatFunc C) T := DistribMulAction.toMulAction + let F := exactConstantExtensionFrobeniusTwistField + C (RatFunc C) N S hExact g + let : Algebra (RatFunc C) F := SubalgebraClass.toAlgebra F.toSubalgebra + let : SMul (RatFunc C) F := Algebra.toSMul + let : Module (RatFunc C) F := Algebra.toModule + let : FiniteDimensional (RatFunc C) F := + finiteDimensional_frobeniusTwistField_over_ratFunc C N S hExact g + let : Algebra.IsSeparable (RatFunc C) F := + isSeparable_frobeniusTwistField_over_ratFunc C N S hExact g + let : Algebra C F := Algebra.restrictScalars C (RatFunc C) F + let : IsScalarTower C (RatFunc C) F := + IsScalarTower.of_algebraMap_eq' rfl + have hExactF : algebraicClosure C F = + (⊥ : IntermediateField C F) := + exactConstantExtensionFrobeniusTwistField_algebraicClosure_eq_bot + C (RatFunc C) N S hExact g + let : FunctionField.IsFullConstantField C F := + (FunctionField.isFullConstantField_iff_algebraicClosure_eq_bot C F).2 + hExactF + have hgenus : FunctionField.genus C F = FunctionField.genus C N := + genus_frobeniusTwistField_eq_original C S N hExact hdiv g + have hriemann : ∀ (Q : FiniteExtensionRationalFinitePlace C F) m, + m + 1 ≤ Module.finrank C + (finiteExtensionOnePointRiemannSpace C F (.inl Q.1) m) + + FunctionField.genus C N := by + intro Q m + have h := finiteExtension_onePoint_riemann_lower_of_genus + C F (.inl Q.1) m + simpa only [Q.2, Nat.mul_one, hgenus] using h + have hstepanov := + finiteExtensionRationalPlaceCount_le_squareFieldStepanov_of_finitePlaceRiemann + K C F (FunctionField.genus C N) hcard hExactF hriemann hlarge + rw [← frobeniusTwistFieldRationalPlaceCount_eq_finiteExtensionRationalPlaceCount + C S N hExact g] at hstepanov + calc + frobeniusTwistFieldRationalPlaceCount C S N hExact g ≤ + Fintype.card C + (2 * FunctionField.genus C N + 1) * + Fintype.card K + Module.finrank (RatFunc C) F := hstepanov + _ = Fintype.card C + (2 * FunctionField.genus C N + 1) * + Fintype.card K + Module.finrank (RatFunc C) N := by + rw [finrank_frobeniusTwistField_over_ratFunc_eq_original + C N S hExact g hdiv] + +/-- Combining the genus-uniform Stepanov upper bound with the bounded +complete-place average gives a two-sided estimate for every rational-base +twist. All constants shown here are independent of `S`. -/ +theorem abs_frobeniusTwistFieldRationalPlaceError_le_squareField_of_genus + (hcard : Fintype.card C = (Fintype.card K) ^ 2) + (hExact : algebraicClosure C N = + (⊥ : IntermediateField C N)) + (hdiv : Nat.card (N ≃ₐ[RatFunc C] N) ∣ Module.finrank C S) + (hlarge : (FunctionField.genus C N + 1) * + (FunctionField.genus C N + 2) ≤ Fintype.card K) + (g : N ≃ₐ[RatFunc C] N) : + |(frobeniusTwistFieldRationalPlaceCount C S N hExact g : ℝ) - + (Nat.card C : ℝ) - 1| ≤ + (Nat.card (N ≃ₐ[RatFunc C] N) : ℝ) * + Module.finrank (RatFunc C) N + + (Nat.card (N ≃ₐ[RatFunc C] N) - 1 : ℕ) * + (((2 * FunctionField.genus C N + 1) * Fintype.card K + + Module.finrank (RatFunc C) N : ℕ) : ℝ) := by + let B : ℝ := + (((2 * FunctionField.genus C N + 1) * Fintype.card K + + Module.finrank (RatFunc C) N : ℕ) : ℝ) + apply abs_frobeniusTwistFieldRationalPlaceError_le_of_uniform_upper + C S N hExact hdiv g B + · dsimp only [B] + positivity + · intro τ + have hnat := + frobeniusTwistFieldRationalPlaceCount_le_squareField_of_genus + K C N S hcard hExact hdiv τ hlarge + have hreal : + (frobeniusTwistFieldRationalPlaceCount C S N hExact τ : ℝ) ≤ + (Fintype.card C : ℝ) + + (((2 * FunctionField.genus C N + 1) * Fintype.card K + + Module.finrank (RatFunc C) N : ℕ) : ℝ) := by + have hnat' : + frobeniusTwistFieldRationalPlaceCount C S N hExact τ ≤ + Fintype.card C + + ((2 * FunctionField.genus C N + 1) * Fintype.card K + + Module.finrank (RatFunc C) N) := by + simpa only [Nat.add_assoc] using hnat + exact_mod_cast hnat' + dsimp only [B] + rw [Nat.card_eq_fintype_card] + linarith + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionGenusDegree.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionGenusDegree.lean new file mode 100644 index 0000000000..8b48ee2723 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionGenusDegree.lean @@ -0,0 +1,273 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionCanonicalDifferentLocalMaximality +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionConstants +public import LeanPool.MarkoffModP.BGS.HasseWeil.RatFuncExactConstantExtension + +/-! +# Genus and extension degree under exact constant extension + +This file records two numerical consequences needed to compare a function +field with an exact finite extension of its constants. First, cotrace +canonicality identifies the total finite-and-infinite trace-different degree +with the Riemann--Hurwitz expression. Second, extending the constants from +`C` to `S` preserves the degree over the corresponding rational function +field. +-/ + +@[expose] public section + +open scoped Polynomial TensorProduct + +namespace BGS.HasseWeil + +noncomputable section + +open BGS.CorvajaZannier + + +section RiemannHurwitzDegree + +variable (K : Type*) [Field K] [Finite K] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +local instance genusDegreeFintype : Fintype K := Fintype.ofFinite K +local instance genusDegreeDecidableEq : DecidableEq K := Classical.decEq K +local instance genusDegreeRatFuncDecidableEq : DecidableEq (RatFunc K) := + Classical.decEq (RatFunc K) +local instance genusDegreeConstantAlgebra : Algebra K L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K (RatFunc K))) +local instance genusDegreeConstantTower : IsScalarTower K (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl +local instance (priority := 10) genusDegreePolynomialAlgebra : Algebra K[X] L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K[X] (RatFunc K))) +local instance genusDegreePolynomialTower : + IsScalarTower K[X] (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl +local instance genusDegreeConstantPolynomialTower : + IsScalarTower K K[X] L := + IsScalarTower.of_algebraMap_eq' rfl + +/-- Cotrace canonicality gives the Riemann--Hurwitz equality for the weighted +finite and infinite trace-different degrees. -/ +theorem finiteExtension_totalDifferentDegree_eq_two_finrank_add_two_genus_sub_two + [FunctionField.IsFullConstantField K L] : + (finiteExtensionFiniteDifferentDegree K L + (finiteExtensionFiniteDifferentIdeal_ne_bot K L) : ℤ) + + (infinityDifferentDegree K L : ℤ) = + 2 * (Module.finrank (RatFunc K) L : ℤ) + + 2 * (FunctionField.Chart.genus K L : ℤ) - 2 := by + apply + (finiteExtensionCanonicalDifferent_degree_eq_two_genus_sub_two_iff K L).mp + rw [finiteExtensionDivisorDegree_eq_chart] + exact FunctionField.Chart.deg_canonical K L + (finiteExtensionCanonicalDifferent_isCanonical_of_cotrace K L) + +/-- The same Riemann--Hurwitz identity stated with the intrinsic genus. This +form no longer remembers which compatible polynomial chart was installed. -/ +theorem finiteExtension_totalDifferentDegree_eq_two_finrank_add_two_genus_sub_two_intrinsic + [FunctionField.IsFullConstantField K L] : + (finiteExtensionFiniteDifferentDegree K L + (finiteExtensionFiniteDifferentIdeal_ne_bot K L) : ℤ) + + (infinityDifferentDegree K L : ℤ) = + 2 * (Module.finrank (RatFunc K) L : ℤ) + + 2 * (FunctionField.genus K L : ℤ) - 2 := by + rw [FunctionField.genus_eq_genusChart K L] + exact finiteExtension_totalDifferentDegree_eq_two_finrank_add_two_genus_sub_two K L + +end RiemannHurwitzDegree + +section RiemannHurwitzDegreeCompatibleChart + +variable (K : Type*) [Field K] [Finite K] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + [Algebra K[X] L] [IsScalarTower K[X] (RatFunc K) L] + +local instance compatibleGenusDegreeFintype : Fintype K := Fintype.ofFinite K +local instance compatibleGenusDegreeDecidableEq : DecidableEq K := Classical.decEq K +local instance compatibleGenusDegreeRatFuncDecidableEq : DecidableEq (RatFunc K) := + Classical.decEq (RatFunc K) +local instance compatibleGenusDegreeConstantAlgebra : Algebra K L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K (RatFunc K))) +local instance compatibleGenusDegreeConstantTower : + IsScalarTower K (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + +variable [IsScalarTower K K[X] L] + +/-- Riemann--Hurwitz for any polynomial chart whose action is compatible +with the fixed rational-function-field action. This is the same statement +as `finiteExtension_totalDifferentDegree_eq_two_finrank_add_two_genus_sub_two`, +but it keeps an explicitly installed chart instead of replacing it by the +induced one. -/ +theorem finiteExtension_totalDifferentDegree_eq_two_finrank_add_two_genus_sub_two_of_compatibleChart + [FunctionField.IsFullConstantField K L] : + (finiteExtensionFiniteDifferentDegree K L + (finiteExtensionFiniteDifferentIdeal_ne_bot K L) : ℤ) + + (infinityDifferentDegree K L : ℤ) = + 2 * (Module.finrank (RatFunc K) L : ℤ) + + 2 * (FunctionField.Chart.genus K L : ℤ) - 2 := by + rw [← FunctionField.genus_eq_genusChart K L] + exact + finiteExtension_totalDifferentDegree_eq_two_finrank_add_two_genus_sub_two_intrinsic K L + +end RiemannHurwitzDegreeCompatibleChart + +section ExactConstantExtensionConstants + +variable (C S N : Type*) [Field C] [Field S] [Field N] + [Finite C] [Finite S] + [Algebra (RatFunc C) N] + [Algebra C S] [FiniteDimensional C S] [IsGalois C S] + +local instance exactConstantExtensionGenusConstantAlgebra : Algebra C N := + RingHom.toAlgebra ((algebraMap (RatFunc C) N).comp + (algebraMap C (RatFunc C))) + +/-- Exactness of the extended constants for the constant algebra induced by +the canonical `S(X)`-algebra structure on the exact constant extension. -/ +theorem exactConstantExtension_extended_algebraicClosure_eq_bot + (hExact : algebraicClosure C N = + (⊥ : IntermediateField C N)) : + let L := ExactConstantExtension C N S + letI : Field L := exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc S) L := + ratFuncExactConstantExtensionAlgebra C S N hExact + letI : Algebra S L := + RingHom.toAlgebra ((algebraMap (RatFunc S) L).comp + (algebraMap S (RatFunc S))) + algebraicClosure S L = (⊥ : IntermediateField S L) := by + let L := ExactConstantExtension C N S + let : Field L := exactConstantExtensionField C N S hExact + let : Algebra (RatFunc S) L := + ratFuncExactConstantExtensionAlgebra C S N hExact + let extendedConstantAlgebra : Algebra S L := + RingHom.toAlgebra ((algebraMap (RatFunc S) L).comp + (algebraMap S (RatFunc S))) + let tensorConstantAlgebra : Algebra S L := + Algebra.TensorProduct.leftAlgebra + have hconstantMap (s : S) : + (@algebraMap S L _ _ extendedConstantAlgebra) s = + (@algebraMap S L _ _ tensorConstantAlgebra) s := by + exact (ratFuncToExactConstantExtension C S N hExact).commutes s + have hAlgebraicTransfer (z : L) + (hz : @IsAlgebraic S L _ _ extendedConstantAlgebra z) : + @IsAlgebraic S L _ _ tensorConstantAlgebra z := by + rcases hz with ⟨p, hp, hpz⟩ + refine ⟨p, hp, ?_⟩ + have hmapEq : + (@algebraMap S L _ _ extendedConstantAlgebra) = + (@algebraMap S L _ _ tensorConstantAlgebra) := by + ext s + exact hconstantMap s + change Polynomial.eval₂ + (@algebraMap S L _ _ extendedConstantAlgebra) z p = 0 at hpz + change Polynomial.eval₂ + (@algebraMap S L _ _ tensorConstantAlgebra) z p = 0 + rw [← hmapEq] + exact hpz + have hTensorRange (z : L) + (hz : @IsAlgebraic S L _ _ tensorConstantAlgebra z) : + z ∈ Set.range (@algebraMap S L _ _ tensorConstantAlgebra) := by + let : Algebra S L := tensorConstantAlgebra + have hTensorExact : algebraicClosure S L = + (⊥ : IntermediateField S L) := + exactConstantExtension_algebraicClosure_eq_bot C N S hExact + have hzClosure : z ∈ algebraicClosure S L := + mem_algebraicClosure_iff.mpr hz + have hzBot : z ∈ (⊥ : IntermediateField S L) := by + rw [← hTensorExact] + exact hzClosure + exact hzBot + let : Algebra S L := extendedConstantAlgebra + apply eq_bot_iff.mpr + intro z hz + have hzExtended : @IsAlgebraic S L _ _ extendedConstantAlgebra z := + mem_algebraicClosure_iff.mp hz + obtain ⟨s, hs⟩ := hTensorRange z + (hAlgebraicTransfer z hzExtended) + exact ⟨s, (hconstantMap s).trans hs⟩ + +end ExactConstantExtensionConstants + +section ExactConstantExtensionDegree + +variable (C S N : Type*) [Field C] [Field S] [Field N] + [Algebra (RatFunc C) N] [FiniteDimensional (RatFunc C) N] + [Algebra C S] [FiniteDimensional C S] [IsGalois C S] + +local instance exactConstantExtensionDegreeConstantAlgebra : Algebra C N := + RingHom.toAlgebra ((algebraMap (RatFunc C) N).comp + (algebraMap C (RatFunc C))) + +/-- Exact finite extension of the constants preserves the function-field +degree: `[S ⊗_C N : S(X)] = [N : C(X)]`. -/ +theorem exactConstantExtension_finrank_over_extendedRatFunc_eq + (hExact : algebraicClosure C N = + (⊥ : IntermediateField C N)) : + let L := ExactConstantExtension C N S + letI : Field L := exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) (RatFunc S) := + ratFuncCoefficientAlgebra C S + letI : Algebra (RatFunc C) L := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + letI : Algebra (RatFunc S) L := + ratFuncExactConstantExtensionAlgebra C S N hExact + letI : SMul (RatFunc S) L := Algebra.toSMul + letI : Module (RatFunc S) L := Algebra.toModule + Module.finrank (RatFunc S) L = Module.finrank (RatFunc C) N := by + let L := ExactConstantExtension C N S + let : Field L := exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) (RatFunc S) := + ratFuncCoefficientAlgebra C S + let : Algebra (RatFunc C) L := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : Algebra (RatFunc S) L := + ratFuncExactConstantExtensionAlgebra C S N hExact + let : SMul (RatFunc C) (RatFunc S) := Algebra.toSMul + let : SMul (RatFunc C) L := Algebra.toSMul + let : SMul (RatFunc S) L := Algebra.toSMul + let : Module (RatFunc C) (RatFunc S) := Algebra.toModule + let : Module (RatFunc C) L := Algebra.toModule + let : Module (RatFunc S) L := Algebra.toModule + let : IsScalarTower (RatFunc C) (RatFunc S) L := + rationalBase_scalarTower C S N hExact + let : FiniteDimensional (RatFunc S) L := + finiteDimensional_over_extendedRatFunc C S N hExact + have hdegree : + Module.finrank (RatFunc C) (RatFunc S) * + Module.finrank (RatFunc S) L = + Module.finrank (RatFunc C) N * Module.finrank C S := by + calc + Module.finrank (RatFunc C) (RatFunc S) * + Module.finrank (RatFunc S) L = + Module.finrank (RatFunc C) L := + Module.finrank_mul_finrank (RatFunc C) (RatFunc S) L + _ = Module.finrank (RatFunc C) N * Module.finrank C S := + exactConstantExtension_finrank_over_base + C (RatFunc C) N S + have hcancel : + Module.finrank C S * Module.finrank (RatFunc S) L = + Module.finrank C S * Module.finrank (RatFunc C) N := by + simpa only [ratFuncCoefficient_finrank, mul_comm] using hdegree + exact Nat.mul_left_cancel + (Module.finrank_pos (R := C) (M := S)) hcancel + +end ExactConstantExtensionDegree + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionGenusInvariance.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionGenusInvariance.lean new file mode 100644 index 0000000000..24bcaa9f79 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionGenusInvariance.lean @@ -0,0 +1,241 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionGenusDegree +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionTotalDifferentDegree + +/-! +# Genus invariance under exact constant extension + +Equality of the presented total-different multiplicities preserves the total +different degree. Riemann--Hurwitz and preservation of the rational-function +extension degree then identify the two chart genera. +-/ + +@[expose] public section + +open scoped Polynomial + +namespace BGS.HasseWeil + +noncomputable section + +open BGS.CorvajaZannier + + +variable (C S N : Type*) [Field C] [Field S] [Field N] + [Fintype C] [Finite S] + [Algebra (RatFunc C) N] [FiniteDimensional (RatFunc C) N] + [Algebra.IsSeparable (RatFunc C) N] + [Algebra C S] [FiniteDimensional C S] [IsGalois C S] + +local instance (priority := 10000) + exactConstantGenusInvarianceConstantsDecidableEq + (K : Type*) [Field K] : DecidableEq K := + infinityBridgeDecidableEqConstants K + +local instance (priority := 10001) + exactConstantGenusInvarianceRatFuncDecidableEq + (K : Type*) [Field K] : DecidableEq (RatFunc K) := + infinityBridgeDecidableEqRatFuncConstants K + +local instance exactConstantGenusInvarianceBaseConstantAlgebra : Algebra C N := + bridgeBaseConstantAlgebra C N + +local instance exactConstantGenusInvarianceBaseConstantTower : + IsScalarTower C (RatFunc C) N := + IsScalarTower.of_algebraMap_eq' rfl + +local instance (priority := 10) + exactConstantGenusInvarianceBasePolynomialAlgebra : Algebra C[X] N := + RingHom.toAlgebra ((algebraMap (RatFunc C) N).comp + (algebraMap C[X] (RatFunc C))) + +local instance exactConstantGenusInvarianceBasePolynomialTower : + IsScalarTower C[X] (RatFunc C) N := + IsScalarTower.of_algebraMap_eq' rfl + +local instance exactConstantGenusInvarianceBaseConstantPolynomialTower : + IsScalarTower C C[X] N := + IsScalarTower.of_algebraMap_eq' rfl + +/-- Exact finite extension of constants preserves chart genus once the +pointwise total-different multiplicity compatibility is known. -/ +theorem exactConstantExtension_chart_genus_eq_of_presentedMultiplicity + (hExact : algebraicClosure C N = + (⊥ : IntermediateField C N)) : + let E := ExactConstantExtension C N S + letI : Field E := exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) E := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + letI : SMul (RatFunc C) E := Algebra.toSMul + letI : Module (RatFunc C) E := Algebra.toModule + letI : FiniteDimensional (RatFunc C) E := + finiteDimensional_exactConstantExtension_over_baseRatFunc + C S N hExact + letI : Algebra.IsSeparable (RatFunc C) E := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + letI : Algebra (RatFunc S) E := + ratFuncExactConstantExtensionAlgebra C S N hExact + letI : SMul (RatFunc S) E := Algebra.toSMul + letI : Module (RatFunc S) E := Algebra.toModule + letI : FiniteDimensional (RatFunc S) E := + finiteDimensional_over_extendedRatFunc C S N hExact + letI : Algebra.IsSeparable (RatFunc S) E := + isSeparable_over_extendedRatFunc C S N hExact + let extendedConstantAlgebra : Algebra S E := + RingHom.toAlgebra ((algebraMap (RatFunc S) E).comp + (algebraMap S (RatFunc S))) + let tensorConstantAlgebra : Algebra S E := + Algebra.TensorProduct.leftAlgebra + let hconstantMap : ∀ s : S, + (@algebraMap S E _ _ extendedConstantAlgebra) s = + (@algebraMap S E _ _ tensorConstantAlgebra) s := by + intro s + exact (ratFuncToExactConstantExtension C S N hExact).commutes s + let htensorPolynomialMap : ∀ s : S, + (@algebraMap S E _ _ tensorConstantAlgebra) s = + (@algebraMap S[X] E _ _ + (constantExtensionTensorPolynomialAlgebra C S N)) + (algebraMap S S[X] s) := by + intro s + change (s ⊗ₜ[C] (1 : N)) = + Polynomial.aeval + (polynomialTensorCancelEvaluationPoint C S N) + (Polynomial.C s) + simp + letI : Algebra S E := extendedConstantAlgebra + letI : SMul S E := Algebra.toSMul + letI : Algebra S[X] E := + constantExtensionTensorPolynomialAlgebra C S N + letI : SMul S[X] E := Algebra.toSMul + letI : IsScalarTower S[X] (RatFunc S) E := + IsScalarTower.of_algebraMap_eq' (by + apply DFunLike.ext _ _ + intro p + change algebraMap S[X] E p = + ratFuncToExactConstantExtension C S N hExact + (algebraMap S[X] (RatFunc S) p) + exact + (ratFuncToExactConstantExtension_algebraMap C S N hExact p).symm) + letI : IsScalarTower S S[X] E := + IsScalarTower.of_algebraMap_eq' (by + apply DFunLike.ext _ _ + intro s + exact (hconstantMap s).trans (htensorPolynomialMap s)) + letI : FunctionField.IsFullConstantField C N := + (FunctionField.isFullConstantField_iff_algebraicClosure_eq_bot C N).2 + hExact + letI : FunctionField.IsFullConstantField S E := + (FunctionField.isFullConstantField_iff_algebraicClosure_eq_bot S E).2 + (exactConstantExtension_extended_algebraicClosure_eq_bot + C S N hExact) + (∀ q : ExactConstantExtensionPresentedPlace C S N, + finiteExtensionTotalDifferentEffectiveDivisor S E + (exactConstantExtensionPresentedUpstairsPlaceEquiv + C S N hExact q) = + finiteExtensionTotalDifferentEffectiveDivisor C N + (exactConstantExtensionPresentedDownstairsPlace + C S N hExact q)) → + FunctionField.Chart.genus S E = FunctionField.Chart.genus C N := by + dsimp only + let E := ExactConstantExtension C N S + let : Field E := exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) (RatFunc S) := + ratFuncCoefficientAlgebra C S + let : Algebra (RatFunc C) E := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : SMul (RatFunc C) E := Algebra.toSMul + let : Module (RatFunc C) E := Algebra.toModule + let : FiniteDimensional (RatFunc C) E := + finiteDimensional_exactConstantExtension_over_baseRatFunc + C S N hExact + let : Algebra.IsSeparable (RatFunc C) E := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + let : Algebra (RatFunc S) E := + ratFuncExactConstantExtensionAlgebra C S N hExact + let : SMul (RatFunc S) E := Algebra.toSMul + let : Module (RatFunc S) E := Algebra.toModule + let : FiniteDimensional (RatFunc S) E := + finiteDimensional_over_extendedRatFunc C S N hExact + let : Algebra.IsSeparable (RatFunc S) E := + isSeparable_over_extendedRatFunc C S N hExact + let extendedConstantAlgebra : Algebra S E := + RingHom.toAlgebra ((algebraMap (RatFunc S) E).comp + (algebraMap S (RatFunc S))) + let tensorConstantAlgebra : Algebra S E := + Algebra.TensorProduct.leftAlgebra + have hconstantMap (s : S) : + (@algebraMap S E _ _ extendedConstantAlgebra) s = + (@algebraMap S E _ _ tensorConstantAlgebra) s := by + exact (ratFuncToExactConstantExtension C S N hExact).commutes s + have htensorPolynomialMap (s : S) : + (@algebraMap S E _ _ tensorConstantAlgebra) s = + (@algebraMap S[X] E _ _ + (constantExtensionTensorPolynomialAlgebra C S N)) + (algebraMap S S[X] s) := by + change (s ⊗ₜ[C] (1 : N)) = + Polynomial.aeval + (polynomialTensorCancelEvaluationPoint C S N) + (Polynomial.C s) + simp + let : Algebra S E := extendedConstantAlgebra + let : SMul S E := Algebra.toSMul + let : Algebra S[X] E := + constantExtensionTensorPolynomialAlgebra C S N + let : SMul S[X] E := Algebra.toSMul + let : IsScalarTower S[X] (RatFunc S) E := + IsScalarTower.of_algebraMap_eq' (by + apply DFunLike.ext _ _ + intro p + change algebraMap S[X] E p = + ratFuncToExactConstantExtension C S N hExact + (algebraMap S[X] (RatFunc S) p) + exact + (ratFuncToExactConstantExtension_algebraMap C S N hExact p).symm) + let : IsScalarTower S S[X] E := + IsScalarTower.of_algebraMap_eq' (by + apply DFunLike.ext _ _ + intro s + exact (hconstantMap s).trans (htensorPolynomialMap s)) + intro hPresentedMultiplicity + let : FunctionField.IsFullConstantField C N := + (FunctionField.isFullConstantField_iff_algebraicClosure_eq_bot C N).2 + hExact + have hExtendedExact : algebraicClosure S E = + (⊥ : IntermediateField S E) := + exactConstantExtension_extended_algebraicClosure_eq_bot C S N hExact + let : FunctionField.IsFullConstantField S E := + (FunctionField.isFullConstantField_iff_algebraicClosure_eq_bot S E).2 + hExtendedExact + have hTotalNat := + exactConstantExtension_totalDifferentDegree_eq_of_presentedMultiplicity + C S N hExact hPresentedMultiplicity + have hTotalInt : + (finiteExtensionFiniteDifferentDegree S E + (finiteExtensionFiniteDifferentIdeal_ne_bot S E) : ℤ) + + (infinityDifferentDegree S E : ℤ) = + (finiteExtensionFiniteDifferentDegree C N + (finiteExtensionFiniteDifferentIdeal_ne_bot C N) : ℤ) + + (infinityDifferentDegree C N : ℤ) := by + exact_mod_cast hTotalNat + have hUp := + finiteExtension_totalDifferentDegree_eq_two_finrank_add_two_genus_sub_two_of_compatibleChart + S E + have hDown := + finiteExtension_totalDifferentDegree_eq_two_finrank_add_two_genus_sub_two_of_compatibleChart + C N + have hRank : Module.finrank (RatFunc S) E = + Module.finrank (RatFunc C) N := + exactConstantExtension_finrank_over_extendedRatFunc_eq C S N hExact + dsimp only [E] at hTotalInt hUp hDown hRank ⊢ + omega + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionInfinityDifferent.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionInfinityDifferent.lean new file mode 100644 index 0000000000..a01e1f8bd9 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionInfinityDifferent.lean @@ -0,0 +1,466 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionFiniteDifferent +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteFieldInfinityDifferent + +/-! +# The infinity different after exact constant extension + +For an exact finite extension of constants, the old infinity normalization +maps into the new infinity normalization through the canonical embedding of +the original function field. The two rational-function subfields remain +linearly disjoint, while the coefficient extension of infinity valuation +rings has unit different. The linear-disjoint different theorem therefore +identifies the new infinity different with the extension of the old one. +-/ + +@[expose] public section + +open scoped Polynomial TensorProduct + +namespace BGS.HasseWeil + +open BGS.CorvajaZannier + +noncomputable section + + +variable (C S N : Type*) [Field C] [Field S] [Field N] + [Algebra (RatFunc C) N] [FiniteDimensional (RatFunc C) N] + [Algebra.IsSeparable (RatFunc C) N] + [Algebra C S] [FiniteDimensional C S] [IsGalois C S] + +local instance exactConstantExtensionInfinityDifferentBaseConstantAlgebra : Algebra C N := + RingHom.toAlgebra ((algebraMap (RatFunc C) N).comp + (algebraMap C (RatFunc C))) + +local instance exactConstantExtensionInfinityDifferentDecidableEqBaseRatFunc : + DecidableEq (RatFunc C) := Classical.decEq _ +local instance exactConstantExtensionInfinityDifferentDecidableEqExtendedRatFunc : + DecidableEq (RatFunc S) := Classical.decEq _ + +variable (hExact : algebraicClosure C N = + (⊥ : IntermediateField C N)) + +/-- The ambient constant-extension embedding restricts to the infinity integral closures. -/ +noncomputable def exactConstantExtensionInfinityDifferentNormalizationRingHom + [Fintype C] [Finite S] : + let L := ExactConstantExtension C N S + let : Field L := exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) L := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : Algebra N L := exactConstantExtensionAlgebra C N S + let : Algebra (RatFunc S) L := + ratFuncExactConstantExtensionAlgebra C S N hExact + let : Algebra (RatFuncInfinityIntegers C) (RatFunc C) := + Algebra.ofSubsemiring (RatFuncInfinityIntegers C) + let : Algebra (RatFuncInfinityIntegers S) (RatFunc S) := + Algebra.ofSubsemiring (RatFuncInfinityIntegers S) + let : Algebra (RatFuncInfinityIntegers C) N := + Algebra.ofSubsemiring (RatFuncInfinityIntegers C) + let : Algebra (RatFuncInfinityIntegers C) L := + Algebra.ofSubsemiring (RatFuncInfinityIntegers C) + let : Algebra (RatFuncInfinityIntegers S) L := + Algebra.ofSubsemiring (RatFuncInfinityIntegers S) + let : Algebra (RatFuncInfinityIntegers C) + (RatFuncInfinityIntegers S) := RingHom.toAlgebra (ratFuncInfinityIntegersRingHom C S) + RatFuncInfinityIntegralClosure C N →+* + RatFuncInfinityIntegralClosure S L := by + let L := ExactConstantExtension C N S + let : Field L := exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) L := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : SMul (RatFunc C) L := Algebra.toSMul + let : Module (RatFunc C) L := Algebra.toModule + let : Algebra N L := exactConstantExtensionAlgebra C N S + let : SMul N L := Algebra.toSMul + let : Module N L := Algebra.toModule + let : IsScalarTower (RatFunc C) N L := + exactConstantExtensionBaseTower C (RatFunc C) N S + let : Algebra (RatFunc C) (RatFunc S) := + ratFuncCoefficientAlgebra C S + let : SMul (RatFunc C) (RatFunc S) := Algebra.toSMul + let : Module (RatFunc C) (RatFunc S) := Algebra.toModule + let : Algebra (RatFunc S) L := + ratFuncExactConstantExtensionAlgebra C S N hExact + let : SMul (RatFunc S) L := Algebra.toSMul + let : Module (RatFunc S) L := Algebra.toModule + let : Algebra (RatFuncInfinityIntegers C) (RatFunc C) := + Algebra.ofSubsemiring (RatFuncInfinityIntegers C) + let : SMul (RatFuncInfinityIntegers C) (RatFunc C) := Algebra.toSMul + let : Module (RatFuncInfinityIntegers C) (RatFunc C) := Algebra.toModule + let : Algebra (RatFuncInfinityIntegers S) (RatFunc S) := + Algebra.ofSubsemiring (RatFuncInfinityIntegers S) + let : SMul (RatFuncInfinityIntegers S) (RatFunc S) := Algebra.toSMul + let : Module (RatFuncInfinityIntegers S) (RatFunc S) := Algebra.toModule + let : Algebra (RatFuncInfinityIntegers C) N := + Algebra.ofSubsemiring (RatFuncInfinityIntegers C) + let : SMul (RatFuncInfinityIntegers C) N := Algebra.toSMul + let : Module (RatFuncInfinityIntegers C) N := Algebra.toModule + let : Algebra (RatFuncInfinityIntegers C) L := + Algebra.ofSubsemiring (RatFuncInfinityIntegers C) + let : SMul (RatFuncInfinityIntegers C) L := Algebra.toSMul + let : Module (RatFuncInfinityIntegers C) L := Algebra.toModule + let : Algebra (RatFuncInfinityIntegers S) L := + Algebra.ofSubsemiring (RatFuncInfinityIntegers S) + let : SMul (RatFuncInfinityIntegers S) L := Algebra.toSMul + let : Module (RatFuncInfinityIntegers S) L := Algebra.toModule + let : Algebra (RatFuncInfinityIntegers C) + (RatFuncInfinityIntegers S) := RingHom.toAlgebra (ratFuncInfinityIntegersRingHom C S) + let : SMul (RatFuncInfinityIntegers C) + (RatFuncInfinityIntegers S) := Algebra.toSMul + let : Module (RatFuncInfinityIntegers C) + (RatFuncInfinityIntegers S) := Algebra.toModule + let : Module.Finite (RatFuncInfinityIntegers C) + (RatFuncInfinityIntegers S) := + ratFuncInfinityIntegers_coefficient_moduleFinite C S + let : IsScalarTower (RatFuncInfinityIntegers C) + (RatFuncInfinityIntegers S) L := + IsScalarTower.of_algebraMap_eq' (by + ext z + change algebraMap (RatFunc C) L z.1 = + algebraMap (RatFunc S) L + (ratFuncCoefficientAlgHom C S z.1) + exact DFunLike.congr_fun + (rationalBase_algebraMap_eq C S N hExact) z.1) + let : IsScalarTower (RatFuncInfinityIntegers C) N L := + IsScalarTower.of_algebraMap_eq' (by + ext z + change algebraMap (RatFunc C) L z.1 = + algebraMap N L (algebraMap (RatFunc C) N z.1) + exact IsScalarTower.algebraMap_apply (RatFunc C) N L z.1) + let f : N →ₐ[RatFuncInfinityIntegers C] L := + IsScalarTower.toAlgHom (RatFuncInfinityIntegers C) N L + let e : integralClosure (RatFuncInfinityIntegers C) L ≃+* + integralClosure (RatFuncInfinityIntegers S) L := + integralClosureRingEquivOfIntegralTower + (RatFuncInfinityIntegers C) (RatFuncInfinityIntegers S) L + exact e.toRingHom.comp f.mapIntegralClosure.toRingHom + +/-- The original infinity normalization acts on the infinity normalization +after exact constant extension through the canonical embedding of the +original function field. -/ +@[reducible] noncomputable def + exactConstantExtensionInfinityNormalizationAlgebra + [Fintype C] [Finite S] : + let L := ExactConstantExtension C N S + let : Field L := exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) L := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : Algebra N L := exactConstantExtensionAlgebra C N S + let : Algebra (RatFunc S) L := + ratFuncExactConstantExtensionAlgebra C S N hExact + let : Algebra (RatFuncInfinityIntegers C) (RatFunc C) := + Algebra.ofSubsemiring (RatFuncInfinityIntegers C) + let : Algebra (RatFuncInfinityIntegers S) (RatFunc S) := + Algebra.ofSubsemiring (RatFuncInfinityIntegers S) + let : Algebra (RatFuncInfinityIntegers C) N := + Algebra.ofSubsemiring (RatFuncInfinityIntegers C) + let : Algebra (RatFuncInfinityIntegers C) + (RatFuncInfinityIntegers S) := RingHom.toAlgebra (ratFuncInfinityIntegersRingHom C S) + Algebra (RatFuncInfinityIntegralClosure C N) + (RatFuncInfinityIntegralClosure S L) := + RingHom.toAlgebra + (exactConstantExtensionInfinityDifferentNormalizationRingHom C S N hExact) + +omit [FiniteDimensional (RatFunc C) N] + [Algebra.IsSeparable (RatFunc C) N] in +/-- The infinity-normalization algebra map is the ambient embedding of the +original function field into the exact constant extension. -/ +theorem exactConstantExtensionInfinityNormalizationAlgebra_coe + [Fintype C] [Finite S] + (x : + let L := ExactConstantExtension C N S + let : Field L := exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) L := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : Algebra N L := exactConstantExtensionAlgebra C N S + let : Algebra (RatFunc S) L := + ratFuncExactConstantExtensionAlgebra C S N hExact + let : Algebra (RatFuncInfinityIntegers C) (RatFunc C) := + Algebra.ofSubsemiring (RatFuncInfinityIntegers C) + let : Algebra (RatFuncInfinityIntegers S) (RatFunc S) := + Algebra.ofSubsemiring (RatFuncInfinityIntegers S) + let : Algebra (RatFuncInfinityIntegers C) N := + Algebra.ofSubsemiring (RatFuncInfinityIntegers C) + RatFuncInfinityIntegralClosure C N) : + let L := ExactConstantExtension C N S + let : Field L := exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) L := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : Algebra N L := exactConstantExtensionAlgebra C N S + let : Algebra (RatFunc S) L := + ratFuncExactConstantExtensionAlgebra C S N hExact + let : Algebra (RatFuncInfinityIntegers C) (RatFunc C) := + Algebra.ofSubsemiring (RatFuncInfinityIntegers C) + let : Algebra (RatFuncInfinityIntegers S) (RatFunc S) := + Algebra.ofSubsemiring (RatFuncInfinityIntegers S) + let : Algebra (RatFuncInfinityIntegers C) N := + Algebra.ofSubsemiring (RatFuncInfinityIntegers C) + let : Algebra (RatFuncInfinityIntegers C) + (RatFuncInfinityIntegers S) := RingHom.toAlgebra (ratFuncInfinityIntegersRingHom C S) + let : Algebra (RatFuncInfinityIntegralClosure C N) + (RatFuncInfinityIntegralClosure S L) := + exactConstantExtensionInfinityNormalizationAlgebra C S N hExact + ((algebraMap (RatFuncInfinityIntegralClosure C N) + (RatFuncInfinityIntegralClosure S L) x : + RatFuncInfinityIntegralClosure S L) : L) = + algebraMap N L x.1 := by + rfl + +/-- Changing the infinity coefficient valuation ring from `C` to `S` does +not change the integral closure inside an exact constant extension. The +underlying ring equivalence is the identity on the ambient function field. -/ +noncomputable def exactConstantExtensionInfinityNormalizationBaseChangeRingEquiv + [Fintype C] [Finite S] : + let L := ExactConstantExtension C N S + let : Field L := exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) L := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : Algebra (RatFunc S) L := + ratFuncExactConstantExtensionAlgebra C S N hExact + RatFuncInfinityIntegralClosure C L ≃+* + RatFuncInfinityIntegralClosure S L := by + let L := ExactConstantExtension C N S + let A := RatFuncInfinityIntegers C + let R₁ := RatFuncInfinityIntegers S + let : Field L := exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) L := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : SMul (RatFunc C) L := Algebra.toSMul + let : Module (RatFunc C) L := Algebra.toModule + let : Algebra (RatFunc S) L := + ratFuncExactConstantExtensionAlgebra C S N hExact + let : SMul (RatFunc S) L := Algebra.toSMul + let : Module (RatFunc S) L := Algebra.toModule + let : Algebra A (RatFunc C) := Algebra.ofSubsemiring A + let : SMul A (RatFunc C) := Algebra.toSMul + let : Module A (RatFunc C) := Algebra.toModule + let : Algebra R₁ (RatFunc S) := Algebra.ofSubsemiring R₁ + let : SMul R₁ (RatFunc S) := Algebra.toSMul + let : Module R₁ (RatFunc S) := Algebra.toModule + let : Algebra A L := Algebra.ofSubsemiring A + let : SMul A L := Algebra.toSMul + let : Module A L := Algebra.toModule + let : Algebra R₁ L := Algebra.ofSubsemiring R₁ + let : SMul R₁ L := Algebra.toSMul + let : Module R₁ L := Algebra.toModule + let : Algebra A R₁ := + RingHom.toAlgebra (ratFuncInfinityIntegersRingHom C S) + let : SMul A R₁ := Algebra.toSMul + let : Module A R₁ := Algebra.toModule + let : Module.Finite A R₁ := + ratFuncInfinityIntegers_coefficient_moduleFinite C S + let : Algebra.IsIntegral A R₁ := by infer_instance + let : IsScalarTower A R₁ L := + IsScalarTower.of_algebraMap_eq' (by + ext z + change algebraMap (RatFunc C) L z.1 = + algebraMap (RatFunc S) L (ratFuncCoefficientAlgHom C S z.1) + exact DFunLike.congr_fun + (rationalBase_algebraMap_eq C S N hExact) z.1) + exact integralClosureRingEquivOfIntegralTower A R₁ L + +omit [FiniteDimensional (RatFunc C) N] [Algebra.IsSeparable (RatFunc C) N] in +/-- The infinity-normalization base-change equivalence preserves the ambient +function-field element. -/ +theorem exactConstantExtensionInfinityNormalizationBaseChangeRingEquiv_coe + [Fintype C] [Finite S] + (x : + let L := ExactConstantExtension C N S + let : Field L := exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) L := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : Algebra (RatFunc S) L := + ratFuncExactConstantExtensionAlgebra C S N hExact + RatFuncInfinityIntegralClosure C L) : + let L := ExactConstantExtension C N S + let : Field L := exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) L := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : Algebra (RatFunc S) L := + ratFuncExactConstantExtensionAlgebra C S N hExact + (((exactConstantExtensionInfinityNormalizationBaseChangeRingEquiv + C S N hExact) x : RatFuncInfinityIntegralClosure S L) : L) = x := by + rfl + +/-- In an exact finite constant extension, the infinity different of the +extended normalization is the extension of the original infinity different. -/ +theorem exactConstantExtension_infinityDifferent_eq_map + [Fintype C] [Finite S] : + let L := ExactConstantExtension C N S + let A := RatFuncInfinityIntegers C + let R₁ := RatFuncInfinityIntegers S + let : Field L := exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) L := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : Algebra N L := exactConstantExtensionAlgebra C N S + let : Algebra (RatFunc S) L := + ratFuncExactConstantExtensionAlgebra C S N hExact + let : SMul (RatFunc S) L := Algebra.toSMul + let : Module (RatFunc S) L := Algebra.toModule + let : Algebra A (RatFunc C) := Algebra.ofSubsemiring (RatFuncInfinityIntegers C) + let : SMul A (RatFunc C) := Algebra.toSMul + let : Module A (RatFunc C) := Algebra.toModule + let : Algebra R₁ (RatFunc S) := Algebra.ofSubsemiring (RatFuncInfinityIntegers S) + let : SMul R₁ (RatFunc S) := Algebra.toSMul + let : Module R₁ (RatFunc S) := Algebra.toModule + let : IsFractionRing A (RatFunc C) := + IsFractionRing.of_algEquiv (ratFuncInfinityFractionRingEquiv C) + let : IsFractionRing R₁ (RatFunc S) := + IsFractionRing.of_algEquiv (ratFuncInfinityFractionRingEquiv S) + let : Algebra A N := + Algebra.ofSubsemiring A + let : SMul A N := Algebra.toSMul + let : Module A N := Algebra.toModule + let : IsScalarTower A (RatFunc C) N := + IsScalarTower.of_algebraMap_eq' rfl + let : Algebra A R₁ := RingHom.toAlgebra (ratFuncInfinityIntegersRingHom C S) + let : Algebra R₁ L := + Algebra.ofSubsemiring R₁ + let : SMul R₁ L := Algebra.toSMul + let : Module R₁ L := Algebra.toModule + let : IsScalarTower R₁ (RatFunc S) L := + IsScalarTower.of_algebraMap_eq' rfl + let R₂ := RatFuncInfinityIntegralClosure C N + let B := RatFuncInfinityIntegralClosure S L + let : Algebra A R₂ := Subalgebra.algebra R₂ + let : SMul A R₂ := Algebra.toSMul + let : Module A R₂ := Algebra.toModule + let : Algebra R₁ B := Subalgebra.algebra B + let : SMul R₁ B := Algebra.toSMul + let : Module R₁ B := Algebra.toModule + let : IsIntegralClosure R₂ A N := + integralClosure.isIntegralClosure A N + let : IsIntegralClosure B R₁ L := + integralClosure.isIntegralClosure R₁ L + let : FiniteDimensional (RatFunc S) L := + finiteDimensional_over_extendedRatFunc C S N hExact + let : Algebra.IsSeparable (RatFunc S) L := + isSeparable_over_extendedRatFunc C S N hExact + let : IsDedekindDomain R₂ := + integralClosure.isDedekindDomain A (RatFunc C) N + let : IsDedekindDomain B := + integralClosure.isDedekindDomain R₁ (RatFunc S) L + let : Module.IsTorsionFree A R₂ := IsIntegralClosure.isTorsionFree A N + let : Module.IsTorsionFree R₁ B := IsIntegralClosure.isTorsionFree R₁ L + let : Algebra R₂ B := + exactConstantExtensionInfinityNormalizationAlgebra C S N hExact + differentIdeal R₁ B = + Ideal.map (algebraMap R₂ B) (differentIdeal A R₂) := by + intro L A R₁ model3 model4 model5 model6 model7 model8 model9 + model10 model11 model12 model13 model14 model15 model16 model17 model18 model19 model20 model21 + model22 model23 model24 model25 R₂ B model28 model29 model30 model31 model32 model33 + model34 model35 model36 model37 model38 model39 model40 model41 model42 + let : SMul (RatFunc C) L := Algebra.toSMul + let : Module (RatFunc C) L := Algebra.toModule + let : DistribMulAction (RatFunc C) L := Module.toDistribMulAction + let : MulAction (RatFunc C) L := DistribMulAction.toMulAction + let : SMul N L := Algebra.toSMul + let : Module N L := Algebra.toModule + let : IsScalarTower (RatFunc C) N L := + exactConstantExtensionBaseTower C (RatFunc C) N S + let : Algebra (RatFunc C) (RatFunc S) := + ratFuncCoefficientAlgebra C S + let : SMul (RatFunc C) (RatFunc S) := Algebra.toSMul + let : Module (RatFunc C) (RatFunc S) := Algebra.toModule + let : IsScalarTower (RatFunc C) (RatFunc S) L := + rationalBase_scalarTower C S N hExact + let : SMul A R₁ := Algebra.toSMul + let : Module A R₁ := Algebra.toModule + let : Module.Finite A R₁ := + ratFuncInfinityIntegers_coefficient_moduleFinite C S + let : Module.IsTorsionFree A R₁ := by + rw [Module.isTorsionFree_iff_algebraMap_injective] + change Function.Injective (ratFuncInfinityIntegersRingHom C S) + exact ratFuncInfinityIntegersRingHom_injective C S + let : Algebra.IsIntegral A R₁ := by infer_instance + let : Algebra A L := + Algebra.ofSubsemiring A + let : SMul A L := Algebra.toSMul + let : Module A L := Algebra.toModule + let : IsScalarTower A (RatFunc C) L := + IsScalarTower.of_algebraMap_eq' rfl + let : DistribMulAction R₁ L := Module.toDistribMulAction + let : MulAction R₁ L := DistribMulAction.toMulAction + let : IsScalarTower A R₁ L := + IsScalarTower.of_algebraMap_eq' (by + ext z + change algebraMap (RatFunc C) L z.1 = + algebraMap (RatFunc S) L (ratFuncCoefficientAlgHom C S z.1) + exact DFunLike.congr_fun + (rationalBase_algebraMap_eq C S N hExact) z.1) + let : Algebra R₂ N := Algebra.ofSubsemiring R₂ + let : SMul R₂ N := Algebra.toSMul + let : Module R₂ N := Algebra.toModule + let : IsScalarTower A R₂ N := + IsScalarTower.of_algebraMap_eq' (by ext z; rfl) + let : Algebra B L := Algebra.ofSubsemiring B + let : SMul B L := Algebra.toSMul + let : Module B L := Algebra.toModule + let : IsScalarTower R₁ B L := + IsScalarTower.of_algebraMap_eq' (by ext z; rfl) + let : IsIntegralClosure R₂ A N := integralClosure.isIntegralClosure A N + let : IsIntegralClosure B R₁ L := integralClosure.isIntegralClosure R₁ L + let : IsDomain R₂ := inferInstance + let : IsDomain B := inferInstance + let : Module.IsTorsionFree R₁ L := by + rw [Module.isTorsionFree_iff_algebraMap_injective] + exact (algebraMap (RatFunc S) L).injective.comp + (IsFractionRing.injective R₁ (RatFunc S)) + let eNL := exactConstantExtensionLinearEquiv C N S + let : Module.Finite N (N ⊗[C] S) := Module.Finite.base_change C N S + let : Module.Finite N L := Module.Finite.equiv eNL + let : FiniteDimensional (RatFunc C) L := Module.Finite.trans N L + let : Algebra.IsSeparable (RatFunc C) L := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + let : Algebra R₂ L := + RingHom.toAlgebra ((algebraMap N L).comp (algebraMap R₂ N)) + let : SMul R₂ L := Algebra.toSMul + let : Module R₂ L := Algebra.toModule + let : IsScalarTower R₂ N L := IsScalarTower.of_algebraMap_eq' rfl + let : IsScalarTower A N L := IsScalarTower.of_algebraMap_eq (fun z => by + change algebraMap (RatFunc C) L z.1 = + algebraMap N L (algebraMap (RatFunc C) N z.1) + exact IsScalarTower.algebraMap_apply (RatFunc C) N L z.1) + let : IsScalarTower A R₂ L := IsScalarTower.of_algebraMap_eq (fun z => by + change algebraMap A L z = algebraMap N L (algebraMap R₂ N (algebraMap A R₂ z)) + rw [← IsScalarTower.algebraMap_apply A R₂ N, + ← IsScalarTower.algebraMap_apply A N L]) + let : IsFractionRing R₂ N := + IsIntegralClosure.isFractionRing_of_finite_extension A (RatFunc C) N R₂ + let : Module.IsTorsionFree R₂ L := by + rw [Module.isTorsionFree_iff_algebraMap_injective] + exact (algebraMap N L).injective.comp (IsFractionRing.injective R₂ N) + let : SMul R₂ B := Algebra.toSMul + let : Module R₂ B := Algebra.toModule + let : IsScalarTower R₂ B L := IsScalarTower.of_algebraMap_eq' (by + ext x + exact exactConstantExtensionInfinityNormalizationAlgebra_coe C S N hExact x) + let : IsScalarTower A R₂ B := IsScalarTower.of_algebraMap_eq' (by + ext z + calc + ((algebraMap A B z : B) : L) = algebraMap A L z := rfl + _ = algebraMap R₂ L (algebraMap A R₂ z) := + IsScalarTower.algebraMap_apply A R₂ L z + _ = algebraMap B L (algebraMap R₂ B (algebraMap A R₂ z)) := + IsScalarTower.algebraMap_apply R₂ B L _) + let : Module.Finite A R₂ := IsIntegralClosure.finite A (RatFunc C) N R₂ + let : Module.Free A R₂ := Module.free_of_finite_type_torsion_free' + have hranges := exactConstantExtension_rationalFunctionRanges_linearDisjoint C S N hExact + have hcoprime : IsCoprime ((differentIdeal A R₁).map (algebraMap R₁ B)) + ((differentIdeal A R₂).map (algebraMap R₂ B)) := by + rw [ratFuncInfinityIntegers_coefficient_differentIdeal_eq_top C S, Ideal.map_top] + exact Ideal.isCoprime_iff_sup_eq.mpr (top_sup_eq _) + exact different_eq_map_of_linearlyDisjoint_fieldRanges A R₁ R₂ B (RatFunc C) (RatFunc S) N L + hranges.1 hranges.2 hcoprime + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionInfinityNormalization.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionInfinityNormalization.lean new file mode 100644 index 0000000000..78bc946074 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionInfinityNormalization.lean @@ -0,0 +1,318 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.RatFuncExactConstantExtension +public import LeanPool.MarkoffModP.BGS.HasseWeil.RatFuncInfinityLocalization + +/-! +# Normalization at infinity in an exact constant extension + +The affine coordinate at infinity is the reciprocal variable `X⁻¹`. This +file checks that the copy of `S(X)` in the exact constant extension +`S ⊗[C] N` sends that reciprocal variable to the tensor extension of the +reciprocal coordinate on `N`. + +Smooth base change and polynomial tensor cancellation then identify the +constant extension of the reciprocal affine normalization with the +reciprocal affine normalization over `S`. Localizing away from the origin +gives a ring equivalence with the actual infinity integral closure. Thus no +comparison with the finite-place coordinate is used or assumed. +-/ + +@[expose] public section + +open scoped Polynomial TensorProduct + +namespace BGS.HasseWeil + +open BGS.CorvajaZannier + +noncomputable section + + +variable (C S N : Type*) [Field C] [Field S] [Field N] + [Algebra (RatFunc C) N] [Algebra C S] + [FiniteDimensional C S] [IsGalois C S] + +local instance infinityDecidableEqBase : DecidableEq C := Classical.decEq C +local instance infinityDecidableEqRatFuncBase : DecidableEq (RatFunc C) := + Classical.decEq (RatFunc C) +local instance infinityDecidableEqConstants : DecidableEq S := Classical.decEq S +local instance infinityDecidableEqRatFuncConstants : DecidableEq (RatFunc S) := + Classical.decEq (RatFunc S) + +local instance infinityConstantAlgebra : Algebra C N := + RingHom.toAlgebra ((algebraMap (RatFunc C) N).comp + (algebraMap C (RatFunc C))) + +local instance infinityReciprocalPolynomialAlgebra : Algebra C[X] N := + ratFuncExtensionReciprocalPolynomialAlgebra C N + +local instance infinityReciprocalPolynomialTower : + IsScalarTower C C[X] N := by + exact IsScalarTower.of_algebraMap_eq' (by + ext c + change algebraMap (RatFunc C) N (algebraMap C (RatFunc C) c) = + algebraMap (RatFunc C) N + (((reciprocalPolynomialRingHom C (Polynomial.C c) : + RatFuncInfinityIntegers C) : RatFunc C)) + rw [reciprocalPolynomialRingHom_coe] + simp) + +local instance infinityReciprocalNormalizationConstantAlgebra : + Algebra C (integralClosure C[X] N) := + RingHom.toAlgebra + ((algebraMap C[X] (integralClosure C[X] N)).comp + (algebraMap C C[X])) + +local instance infinityReciprocalNormalizationPolynomialTower : + IsScalarTower C C[X] (integralClosure C[X] N) := + IsScalarTower.of_algebraMap_eq' rfl + +local instance infinityCoefficientPolynomialAlgebra : Algebra C[X] S[X] := + Polynomial.algebra C S + +local instance infinitySpanXPrime : + (Ideal.span ({Polynomial.X} : Set S[X])).IsPrime := + (Ideal.span_singleton_prime Polynomial.X_ne_zero).mpr Polynomial.prime_X + +variable (hExact : algebraicClosure C N = + (⊥ : IntermediateField C N)) + +/-- The reciprocal coordinate in the exact constant extension is the tensor +extension of the reciprocal coordinate on `N`. -/ +theorem ratFuncToExactConstantExtension_reciprocal_X : + ratFuncToExactConstantExtension C S N hExact (1 / RatFunc.X) = + polynomialTensorCancelEvaluationPoint C S N := by + let : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + let : Algebra (RatFunc S) (ExactConstantExtension C N S) := + ratFuncExactConstantExtensionAlgebra C S N hExact + rw [one_div] + have hrecip : polynomialTensorCancelEvaluationPoint C S N = + (Algebra.TensorProduct.includeRight : + N →ₐ[C] ExactConstantExtension C N S) + (algebraMap (RatFunc C) N (RatFunc.X⁻¹)) := by + unfold polynomialTensorCancelEvaluationPoint + congr 1 + change algebraMap (RatFunc C) N + (((reciprocalPolynomialRingHom C Polynomial.X : + RatFuncInfinityIntegers C) : RatFunc C)) = + algebraMap (RatFunc C) N (RatFunc.X⁻¹) + rw [reciprocalPolynomialRingHom_coe] + simp + rw [hrecip] + rw [map_inv₀, map_inv₀, map_inv₀, + ratFuncToExactConstantExtension_X] + rfl + +/-- The tensor-product polynomial action in the reciprocal coordinate is +exactly the reciprocal polynomial action induced from `S(X)`. -/ +theorem exactConstantExtensionReciprocalPolynomialAlgebra_eq : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc S) (ExactConstantExtension C N S) := + ratFuncExactConstantExtensionAlgebra C S N hExact + polynomialTensorCancelTargetPolynomialExtensionAlgebra C S N = + ratFuncExtensionReciprocalPolynomialAlgebra S + (ExactConstantExtension C N S) := by + let : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + let : Algebra (RatFunc S) (ExactConstantExtension C N S) := + ratFuncExactConstantExtensionAlgebra C S N hExact + apply Algebra.algebra_ext + intro p + change Polynomial.aeval + (polynomialTensorCancelEvaluationPoint C S N) p = + algebraMap (RatFunc S) (ExactConstantExtension C N S) + (((reciprocalPolynomialRingHom S p : + RatFuncInfinityIntegers S) : RatFunc S)) + rw [reciprocalPolynomialRingHom_coe, Polynomial.hom_eval₂] + have hcoeff : + (algebraMap (RatFunc S) + (ExactConstantExtension C N S)).comp RatFunc.C = + algebraMap S (ExactConstantExtension C N S) := by + ext s + exact (ratFuncToExactConstantExtension C S N hExact).commutes s + rw [hcoeff] + change Polynomial.eval₂ + (algebraMap S (ExactConstantExtension C N S)) + (polynomialTensorCancelEvaluationPoint C S N) p = + Polynomial.eval₂ + (algebraMap S (ExactConstantExtension C N S)) + (ratFuncToExactConstantExtension C S N hExact + (1 / RatFunc.X)) p + rw [ratFuncToExactConstantExtension_reciprocal_X C S N hExact] + +section FiniteConstants + +variable [Fintype C] [Finite S] + +/-- Smooth base change in the reciprocal coordinate, before identifying the +target polynomial action with the one induced from `S(X)`. -/ +noncomputable def finiteFieldReciprocalNormalizationAlgEquiv : + letI : Algebra S[X] + (S ⊗[C] integralClosure C[X] N) := + polynomialTensorCancelTargetPolynomialExtensionAlgebra C S + (integralClosure C[X] N) + letI : Algebra S[X] (ExactConstantExtension C N S) := + polynomialTensorCancelTargetPolynomialExtensionAlgebra C S N + S ⊗[C] integralClosure C[X] N ≃ₐ[S[X]] + integralClosure S[X] (ExactConstantExtension C N S) := by + letI : Algebra S[X] + (S ⊗[C] integralClosure C[X] N) := + polynomialTensorCancelTargetPolynomialExtensionAlgebra C S + (integralClosure C[X] N) + letI : Algebra S[X] (ExactConstantExtension C N S) := + polynomialTensorCancelTargetPolynomialExtensionAlgebra C S N + exact (polynomialTensorCancelOverCoefficientPolynomial C S + (integralClosure C[X] N)).symm |>.trans + (finiteFieldPolynomialIntegralClosureBaseChangeAlgEquiv C S N) |>.trans + (polynomialTensorCancelOverCoefficientPolynomial C S N).mapIntegralClosure + +/-- The constant extension of the reciprocal affine normalization is the +actual reciprocal affine normalization of the exact constant extension. -/ +noncomputable def exactConstantExtensionInfinityAffineNormalizationAlgEquiv : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc S) (ExactConstantExtension C N S) := + ratFuncExactConstantExtensionAlgebra C S N hExact + letI : Algebra S[X] + (S ⊗[C] integralClosure C[X] N) := + polynomialTensorCancelTargetPolynomialExtensionAlgebra C S + (integralClosure C[X] N) + letI : Algebra S[X] (ExactConstantExtension C N S) := + ratFuncExtensionReciprocalPolynomialAlgebra S + (ExactConstantExtension C N S) + S ⊗[C] integralClosure C[X] N ≃ₐ[S[X]] + integralClosure S[X] (ExactConstantExtension C N S) := by + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc S) (ExactConstantExtension C N S) := + ratFuncExactConstantExtensionAlgebra C S N hExact + letI : Algebra S[X] + (S ⊗[C] integralClosure C[X] N) := + polynomialTensorCancelTargetPolynomialExtensionAlgebra C S + (integralClosure C[X] N) + letI : Algebra S[X] (ExactConstantExtension C N S) := + ratFuncExtensionReciprocalPolynomialAlgebra S + (ExactConstantExtension C N S) + have h := exactConstantExtensionReciprocalPolynomialAlgebra_eq + C S N hExact + rw [← h] + exact finiteFieldReciprocalNormalizationAlgEquiv C S N + +/-- The reciprocal affine normalization equivalence carries the natural +localization set away from `X = 0` to the corresponding target set. -/ +theorem exactConstantExtensionInfinityAffineNormalization_map_primeCompl : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc S) (ExactConstantExtension C N S) := + ratFuncExactConstantExtensionAlgebra C S N hExact + letI : Algebra S[X] + (S ⊗[C] integralClosure C[X] N) := + polynomialTensorCancelTargetPolynomialExtensionAlgebra C S + (integralClosure C[X] N) + letI : Algebra S[X] (ExactConstantExtension C N S) := + ratFuncExtensionReciprocalPolynomialAlgebra S + (ExactConstantExtension C N S) + let e := exactConstantExtensionInfinityAffineNormalizationAlgEquiv + C S N hExact + Submonoid.map e + (Algebra.algebraMapSubmonoid + (S ⊗[C] integralClosure C[X] N) + (Ideal.span ({Polynomial.X} : Set S[X])).primeCompl) = + Algebra.algebraMapSubmonoid + (integralClosure S[X] (ExactConstantExtension C N S)) + (Ideal.span ({Polynomial.X} : Set S[X])).primeCompl := by + let : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + let : Algebra (RatFunc S) (ExactConstantExtension C N S) := + ratFuncExactConstantExtensionAlgebra C S N hExact + let : Algebra S[X] + (S ⊗[C] integralClosure C[X] N) := + polynomialTensorCancelTargetPolynomialExtensionAlgebra C S + (integralClosure C[X] N) + let : Algebra S[X] (ExactConstantExtension C N S) := + ratFuncExtensionReciprocalPolynomialAlgebra S + (ExactConstantExtension C N S) + let e := exactConstantExtensionInfinityAffineNormalizationAlgEquiv + C S N hExact + dsimp only + unfold Algebra.algebraMapSubmonoid + ext x + constructor + · rintro ⟨y, ⟨p, hp, rfl⟩, rfl⟩ + exact ⟨p, hp, (e.commutes p).symm⟩ + · rintro ⟨p, hp, rfl⟩ + refine ⟨algebraMap S[X] + (S ⊗[C] integralClosure C[X] N) p, ⟨p, hp, rfl⟩, ?_⟩ + exact e.commutes p + +/-- Localizing the constant extension of the reciprocal normalization gives +the actual integral closure of the infinity valuation ring in the exact +constant extension. As a ring equivalence, this directly transports prime +ideals, local rings, and residue rings. -/ +noncomputable def exactConstantExtensionInfinityNormalizationLocalizationRingEquiv : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc S) (ExactConstantExtension C N S) := + ratFuncExactConstantExtensionAlgebra C S N hExact + letI : Algebra S[X] + (S ⊗[C] integralClosure C[X] N) := + polynomialTensorCancelTargetPolynomialExtensionAlgebra C S + (integralClosure C[X] N) + Localization + (Algebra.algebraMapSubmonoid + (S ⊗[C] integralClosure C[X] N) + (Ideal.span ({Polynomial.X} : Set S[X])).primeCompl) ≃+* + RatFuncInfinityIntegralClosure S + (ExactConstantExtension C N S) := by + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc S) (ExactConstantExtension C N S) := + ratFuncExactConstantExtensionAlgebra C S N hExact + letI : Algebra S[X] + (S ⊗[C] integralClosure C[X] N) := + polynomialTensorCancelTargetPolynomialExtensionAlgebra C S + (integralClosure C[X] N) + letI : Algebra S[X] (ExactConstantExtension C N S) := + ratFuncExtensionReciprocalPolynomialAlgebra S + (ExactConstantExtension C N S) + let R := S ⊗[C] integralClosure C[X] N + let M := Algebra.algebraMapSubmonoid R + (Ideal.span ({Polynomial.X} : Set S[X])).primeCompl + let Tm := Algebra.algebraMapSubmonoid + (integralClosure S[X] (ExactConstantExtension C N S)) + (Ideal.span ({Polynomial.X} : Set S[X])).primeCompl + let L := Localization M + letI : Algebra + (integralClosure S[X] (ExactConstantExtension C N S)) + (RatFuncInfinityIntegralClosure S + (ExactConstantExtension C N S)) := + ratFuncInfinityReciprocalIntegralClosureAlgebra S + (ExactConstantExtension C N S) + letI : IsLocalization Tm + (RatFuncInfinityIntegralClosure S + (ExactConstantExtension C N S)) := + ratFuncInfinityIntegralClosure_isLocalization_reciprocal S + (ExactConstantExtension C N S) + let e := exactConstantExtensionInfinityAffineNormalizationAlgEquiv + C S N hExact + have hmap : Submonoid.map e M = Tm := + exactConstantExtensionInfinityAffineNormalization_map_primeCompl + C S N hExact + exact IsLocalization.ringEquivOfRingEquiv L + (RatFuncInfinityIntegralClosure S + (ExactConstantExtension C N S)) e.toRingEquiv hmap + +end FiniteConstants + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionInfinityPlaceCompatibility.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionInfinityPlaceCompatibility.lean new file mode 100644 index 0000000000..b150a1d0aa --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionInfinityPlaceCompatibility.lean @@ -0,0 +1,432 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.ConstantExtensionInfinityPlaceSplittingMultiplicity +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionInfinityDifferent + +/-! +# Compatibility of infinity places with exact constant extension + +The reciprocal affine normalization of an exact constant extension may be +viewed either over the original constants or over the extended constants. +This module proves that these two presentations commute with localization at +infinity. Consequently, the explicit upstairs infinity prime contracts to the +explicit downstairs infinity prime under the canonical algebra on infinity +normalizations. +-/ + +@[expose] public section + +open scoped Polynomial TensorProduct + +namespace BGS.HasseWeil + +open BGS.CorvajaZannier + +noncomputable section + + +variable (C S N : Type*) [Field C] [Field S] [Field N] + [Algebra (RatFunc C) N] [FiniteDimensional (RatFunc C) N] + [Algebra.IsSeparable (RatFunc C) N] + [Algebra C S] [FiniteDimensional C S] [IsGalois C S] + [Fintype C] [Finite S] + +local instance infinityPlaceCompatibilityBaseConstantAlgebra : Algebra C N := + infinityConstantAlgebra C N + +local instance infinityPlaceCompatibilityBaseReciprocalPolynomialAlgebra : + Algebra C[X] N := infinityReciprocalPolynomialAlgebra C N + +local instance infinityPlaceCompatibilityBaseConstantReciprocalTower : + IsScalarTower C C[X] N := infinityReciprocalPolynomialTower C N + +local instance infinityPlaceCompatibilityOldNormalizationConstantAlgebra : + Algebra C (integralClosure C[X] N) := + RingHom.toAlgebra + ((algebraMap C[X] (integralClosure C[X] N)).comp + (algebraMap C C[X])) + +local instance + infinityPlaceCompatibilityOldNormalizationConstantPolynomialTower : + IsScalarTower C C[X] (integralClosure C[X] N) := + IsScalarTower.of_algebraMap_eq' rfl + +local instance infinityPlaceCompatibilityCoefficientPolynomialAlgebra : + Algebra C[X] S[X] := Polynomial.algebra C S + +local instance infinityPlaceCompatibilityCoefficientPolynomialSMul : + SMul C[X] S[X] := Algebra.toSMul + +local instance infinityPlaceCompatibilityCoefficientPolynomialModule : + Module C[X] S[X] := Algebra.toModule + +local instance (priority := 10000) + infinityPlaceCompatibilityDecidableEqBaseRatFunc : + DecidableEq (RatFunc C) := infinityBridgeDecidableEqRatFuncConstants C + +local instance (priority := 10000) + infinityPlaceCompatibilityDecidableEqExtendedRatFunc : + DecidableEq (RatFunc S) := infinityBridgeDecidableEqRatFuncConstants S + +local instance (priority := 10000) infinityPlaceCompatibilityDecidableEqBase : + DecidableEq C := infinityBridgeDecidableEqConstants C + +local instance (priority := 10000) + infinityPlaceCompatibilityDecidableEqExtended : + DecidableEq S := infinityBridgeDecidableEqConstants S + +private theorem + infinityPlaceCompatibility_integralClosureAlgEquivOfAlgebraEq_coe + {R L T : Type*} [CommRing R] [Field L] [CommRing T] [Algebra R T] + (a b : Algebra R L) (h : a = b) + (e : T ≃ₐ[R] @integralClosure R L _ _ a) (x : T) : + let e' : T ≃ₐ[R] @integralClosure R L _ _ b := by + rw [← h] + exact e + ((e' x : @integralClosure R L _ _ b) : L) = + ((e x : @integralClosure R L _ _ a) : L) := by + subst b + rfl + +omit [FiniteDimensional (RatFunc C) N] [Algebra.IsSeparable (RatFunc C) N] in +/-- The reciprocal affine normalization equivalence sends the old +normalization embedded in the right tensor factor to the same element of the +ambient exact constant extension. -/ +private theorem + exactConstantExtensionInfinityAffineNormalization_includeRight_coe + (hExact : algebraicClosure C N = + (⊥ : IntermediateField C N)) + (x : integralClosure C[X] N) : + let E := ExactConstantExtension C N S + letI : Field E := exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc S) E := + ratFuncExactConstantExtensionAlgebra C S N hExact + letI : Algebra S[X] + (S ⊗[C] integralClosure C[X] N) := + polynomialTensorCancelTargetPolynomialExtensionAlgebra C S + (integralClosure C[X] N) + letI : Algebra S[X] E := + ratFuncExtensionReciprocalPolynomialAlgebra S E + ((exactConstantExtensionInfinityAffineNormalizationAlgEquiv + C S N hExact) + (Algebra.TensorProduct.includeRight + (R := C) (A := S) (B := integralClosure C[X] N) x) : E) = + Algebra.TensorProduct.includeRight (R := C) (A := S) (B := N) x.1 := by + let E := ExactConstantExtension C N S + let : Field E := exactConstantExtensionField C N S hExact + let : Algebra (RatFunc S) E := + ratFuncExactConstantExtensionAlgebra C S N hExact + let : Algebra S[X] + (S ⊗[C] integralClosure C[X] N) := + polynomialTensorCancelTargetPolynomialExtensionAlgebra C S + (integralClosure C[X] N) + let : Algebra S[X] E := + ratFuncExtensionReciprocalPolynomialAlgebra S E + let a := polynomialTensorCancelTargetPolynomialExtensionAlgebra C S N + let b := ratFuncExtensionReciprocalPolynomialAlgebra S E + let h : a = b := + exactConstantExtensionReciprocalPolynomialAlgebra_eq C S N hExact + let y := Algebra.TensorProduct.includeRight + (R := C) (A := S) (B := integralClosure C[X] N) x + have hTransport := + infinityPlaceCompatibility_integralClosureAlgEquivOfAlgebraEq_coe + a b h (finiteFieldReciprocalNormalizationAlgEquiv C S N) y + have hFinite : + (((finiteFieldReciprocalNormalizationAlgEquiv C S N) y : + @integralClosure S[X] E _ _ a) : E) = + (1 : S) ⊗ₜ[C] (x : N) := by + dsimp only [y, a] + simp only [finiteFieldReciprocalNormalizationAlgEquiv, + AlgEquiv.trans_apply, + Algebra.TensorProduct.includeRight_apply, + polynomialTensorCancelOverCoefficientPolynomial_symm_apply, + polynomialTensorCancel_symm_tmul, + finiteFieldPolynomialIntegralClosureBaseChangeAlgEquiv, + polynomialIntegralClosureBaseChangeAlgEquiv, + AlgEquiv.ofBijective_apply, + AlgEquiv.coe_mapIntegralClosure] + rw [polynomialTensorCancelOverCoefficientPolynomial_apply] + change polynomialTensorCancel C S N + (Polynomial.C 1 ⊗ₜ[C[X]] (x : N)) = + (1 : S) ⊗ₜ[C] (x : N) + rw [polynomialTensorCancel_tmul] + simp + have hExactTransport : + ((exactConstantExtensionInfinityAffineNormalizationAlgEquiv + C S N hExact y : @integralClosure S[X] E _ _ b) : E) = + (((finiteFieldReciprocalNormalizationAlgEquiv C S N) y : + @integralClosure S[X] E _ _ a) : E) := by + simpa only [a, b, h, + exactConstantExtensionInfinityAffineNormalizationAlgEquiv] using + hTransport + exact hExactTransport.trans hFinite + +omit [FiniteDimensional (RatFunc C) N] [Algebra.IsSeparable (RatFunc C) N] in +/-- The affine-to-infinity localization square commutes on elements of the +old reciprocal normalization. -/ +private theorem exactConstantExtensionInfinityAffineLocalizationSquare_coe + (hExact : algebraicClosure C N = + (⊥ : IntermediateField C N)) + (x : integralClosure C[X] N) : + let E := ExactConstantExtension C N S + letI : Field E := exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) E := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + letI : Algebra N E := exactConstantExtensionAlgebra C N S + letI : Algebra (RatFunc S) E := + ratFuncExactConstantExtensionAlgebra C S N hExact + letI : Algebra S[X] E := + ratFuncExtensionReciprocalPolynomialAlgebra S E + let R0 := integralClosure C[X] N + let AS := integralClosure S[X] E + let R2 := RatFuncInfinityIntegralClosure C N + let B := RatFuncInfinityIntegralClosure S E + letI : Algebra S[X] (S ⊗[C] R0) := + polynomialTensorCancelTargetPolynomialExtensionAlgebra C S R0 + let eAff := exactConstantExtensionInfinityAffineNormalizationAlgEquiv + C S N hExact + letI : Algebra R0 R2 := + ratFuncInfinityReciprocalIntegralClosureAlgebra C N + letI : Algebra AS B := + ratFuncInfinityReciprocalIntegralClosureAlgebra S E + letI : Algebra R2 B := + exactConstantExtensionInfinityNormalizationAlgebra C S N hExact + (((algebraMap R2 B) ((algebraMap R0 R2) x) : B) : E) = + (((algebraMap AS B) + (eAff (Algebra.TensorProduct.includeRight + (R := C) (A := S) (B := R0) x)) : B) : E) := by + dsimp only + let E := ExactConstantExtension C N S + let R0 := integralClosure C[X] N + let R2 := RatFuncInfinityIntegralClosure C N + let : Field E := exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) E := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : Algebra N E := exactConstantExtensionAlgebra C N S + let : Algebra (RatFunc S) E := + ratFuncExactConstantExtensionAlgebra C S N hExact + let : Algebra S[X] E := + ratFuncExtensionReciprocalPolynomialAlgebra S E + let AS := integralClosure S[X] E + let : Algebra S[X] (S ⊗[C] R0) := + polynomialTensorCancelTargetPolynomialExtensionAlgebra C S R0 + let B := RatFuncInfinityIntegralClosure S E + let eAff := exactConstantExtensionInfinityAffineNormalizationAlgEquiv + C S N hExact + let : Algebra R0 R2 := + ratFuncInfinityReciprocalIntegralClosureAlgebra C N + let : Algebra AS B := + ratFuncInfinityReciprocalIntegralClosureAlgebra S E + let : Algebra R2 B := + exactConstantExtensionInfinityNormalizationAlgebra C S N hExact + calc + (((algebraMap R2 B) ((algebraMap R0 R2) x) : B) : E) = + algebraMap N E x.1 := by + change + (((algebraMap R2 B (algebraMap R0 R2 x) : B) : E)) = + algebraMap N E ((algebraMap R0 R2 x : R2) : N) + exact exactConstantExtensionInfinityNormalizationAlgebra_coe + C S N hExact (algebraMap R0 R2 x) + _ = Algebra.TensorProduct.includeRight + (R := C) (A := S) (B := N) x.1 := rfl + _ = ((eAff (Algebra.TensorProduct.includeRight + (R := C) (A := S) (B := R0) x) : AS) : E) := by + exact + (exactConstantExtensionInfinityAffineNormalization_includeRight_coe + C S N hExact x).symm + _ = (((algebraMap AS B) + (eAff (Algebra.TensorProduct.includeRight + (R := C) (A := S) (B := R0) x)) : B) : E) := rfl + +omit [FiniteDimensional (RatFunc C) N] [Algebra.IsSeparable (RatFunc C) N] in +/-- The extended reciprocal affine prime contracts to the reciprocal affine +prime obtained from the old normalization. -/ +private theorem exactConstantExtensionInfinityAffinePrime_under + (hExact : algebraicClosure C N = + (⊥ : IntermediateField C N)) + (q : ExactConstantExtensionPresentedInfinityPlace C S N) : + let E := ExactConstantExtension C N S + letI : Field E := exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc S) E := + ratFuncExactConstantExtensionAlgebra C S N hExact + letI : Algebra S[X] E := + ratFuncExtensionReciprocalPolynomialAlgebra S E + let R0 := integralClosure C[X] N + let AS := integralClosure S[X] E + letI : Algebra S[X] (S ⊗[C] R0) := + polynomialTensorCancelTargetPolynomialExtensionAlgebra C S R0 + let eAff := exactConstantExtensionInfinityAffineNormalizationAlgEquiv + C S N hExact + let qA : IsDedekindDomain.HeightOneSpectrum AS := + heightOneSpectrumEquivOfAlgEquiv eAff q.1 + let oldToAffine : R0 →+* AS := + eAff.toRingEquiv.toRingHom.comp + (Algebra.TensorProduct.includeRight + (R := C) (A := S) (B := R0)).toRingHom + letI : Algebra R0 AS := oldToAffine.toAlgebra + qA.asIdeal.under R0 = + exactConstantExtensionInfinityDownstairsIdeal C S N q.1 := by + dsimp only + let E := ExactConstantExtension C N S + let R0 := integralClosure C[X] N + let : Field E := exactConstantExtensionField C N S hExact + let : Algebra (RatFunc S) E := + ratFuncExactConstantExtensionAlgebra C S N hExact + let : Algebra S[X] E := + ratFuncExtensionReciprocalPolynomialAlgebra S E + let AS := integralClosure S[X] E + let : Algebra S[X] (S ⊗[C] R0) := + polynomialTensorCancelTargetPolynomialExtensionAlgebra C S R0 + let eAff := exactConstantExtensionInfinityAffineNormalizationAlgEquiv + C S N hExact + let qA : IsDedekindDomain.HeightOneSpectrum AS := + heightOneSpectrumEquivOfAlgEquiv eAff q.1 + let oldToAffine : R0 →+* AS := + eAff.toRingEquiv.toRingHom.comp + (Algebra.TensorProduct.includeRight + (R := C) (A := S) (B := R0)).toRingHom + let : Algebra R0 AS := oldToAffine.toAlgebra + ext x + change eAff + (Algebra.TensorProduct.includeRight + (R := C) (A := S) (B := R0) x) ∈ qA.asIdeal ↔ + Algebra.TensorProduct.includeRight + (R := C) (A := S) (B := R0) x ∈ q.1.asIdeal + rw [show qA.asIdeal = q.1.asIdeal.comap eAff.symm by rfl] + change eAff.symm (eAff + (Algebra.TensorProduct.includeRight + (R := C) (A := S) (B := R0) x)) ∈ q.1.asIdeal ↔ + Algebra.TensorProduct.includeRight + (R := C) (A := S) (B := R0) x ∈ q.1.asIdeal + rw [eAff.symm_apply_apply] + +omit [FiniteDimensional (RatFunc C) N] [Algebra.IsSeparable (RatFunc C) N] + [FiniteDimensional C S] [IsGalois C S] [Fintype C] [Finite S] in +private theorem + exactConstantExtensionDownstairsInfinityMappedIdeal_isMaximal + (q : ExactConstantExtensionPresentedInfinityPlace C S N) : + let R0 := integralClosure C[X] N + let R2 := RatFuncInfinityIntegralClosure C N + letI : Algebra R0 R2 := + ratFuncInfinityReciprocalIntegralClosureAlgebra C N + (Ideal.map (algebraMap R0 R2) + (exactConstantExtensionInfinityDownstairsIdeal C S N q.1)).IsMaximal := by + dsimp only + change (exactConstantExtensionDownstairsInfinityPlace + C S N q.1 q.2).1.IsMaximal + infer_instance + +/-- The explicit upstairs infinity prime of an exact constant extension +contracts, through the canonical algebra on infinity normalizations, to its +explicit downstairs infinity prime. -/ +theorem exactConstantExtensionUpstairsInfinityPlace_under + (hExact : algebraicClosure C N = + (⊥ : IntermediateField C N)) + (q : ExactConstantExtensionPresentedInfinityPlace C S N) : + let E := ExactConstantExtension C N S + letI : Field E := exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) E := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + letI : Algebra (RatFunc S) E := + ratFuncExactConstantExtensionAlgebra C S N hExact + let R2 := RatFuncInfinityIntegralClosure C N + let B := RatFuncInfinityIntegralClosure S E + letI : Algebra R2 B := + exactConstantExtensionInfinityNormalizationAlgebra C S N hExact + (exactConstantExtensionUpstairsInfinityPlace + C S N hExact q.1 q.2).1.under R2 = + (exactConstantExtensionDownstairsInfinityPlace C S N q.1 q.2).1 := by + dsimp only + let E := ExactConstantExtension C N S + let R0 := integralClosure C[X] N + let R2 := RatFuncInfinityIntegralClosure C N + let : Field E := exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) E := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : SMul (RatFunc C) E := Algebra.toSMul + let : Module (RatFunc C) E := Algebra.toModule + let : FiniteDimensional (RatFunc C) E := + finiteDimensional_exactConstantExtension_over_baseRatFunc C S N hExact + let : Algebra.IsSeparable (RatFunc C) E := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + let : Algebra N E := exactConstantExtensionAlgebra C N S + let : SMul N E := Algebra.toSMul + let : Module N E := Algebra.toModule + let : IsScalarTower (RatFunc C) N E := + exactConstantExtensionBaseTower C (RatFunc C) N S + let : Algebra (RatFunc S) E := + ratFuncExactConstantExtensionAlgebra C S N hExact + let : SMul (RatFunc S) E := Algebra.toSMul + let : Module (RatFunc S) E := Algebra.toModule + let : Algebra S[X] E := + ratFuncExtensionReciprocalPolynomialAlgebra S E + let : SMul S[X] E := Algebra.toSMul + let : Module S[X] E := Algebra.toModule + let AS := integralClosure S[X] E + let : Algebra S[X] (S ⊗[C] R0) := + polynomialTensorCancelTargetPolynomialExtensionAlgebra C S R0 + let : SMul S[X] (S ⊗[C] R0) := Algebra.toSMul + let B := RatFuncInfinityIntegralClosure S E + let eAff := exactConstantExtensionInfinityAffineNormalizationAlgEquiv + C S N hExact + let qA : IsDedekindDomain.HeightOneSpectrum AS := + heightOneSpectrumEquivOfAlgEquiv eAff q.1 + let p := exactConstantExtensionInfinityDownstairsIdeal C S N q.1 + let oldToAffine : R0 →+* AS := + eAff.toRingEquiv.toRingHom.comp + (Algebra.TensorProduct.includeRight + (R := C) (A := S) (B := R0)).toRingHom + let : Algebra R0 AS := oldToAffine.toAlgebra + let : SMul R0 AS := Algebra.toSMul + let : Algebra R0 R2 := + ratFuncInfinityReciprocalIntegralClosureAlgebra C N + let : SMul R0 R2 := Algebra.toSMul + let : Algebra AS B := + ratFuncInfinityReciprocalIntegralClosureAlgebra S E + let : SMul AS B := Algebra.toSMul + let : Algebra R2 B := + exactConstantExtensionInfinityNormalizationAlgebra C S N hExact + let : SMul R2 B := Algebra.toSMul + let : Module R2 B := Algebra.toModule + let : Algebra R0 B := + RingHom.toAlgebra + ((algebraMap R2 B).comp (algebraMap R0 R2)) + let : SMul R0 B := Algebra.toSMul + let : IsScalarTower R0 R2 B := + IsScalarTower.of_algebraMap_eq' rfl + let : IsScalarTower R0 AS B := + IsScalarTower.of_algebraMap_eq' (by + ext x + change + (((algebraMap R2 B) ((algebraMap R0 R2) x) : B) : E) = + (((algebraMap AS B) + (eAff (Algebra.TensorProduct.includeRight + (R := C) (A := S) (B := R0) x)) : B) : E) + exact exactConstantExtensionInfinityAffineLocalizationSquare_coe + C S N hExact x) + have hAffine : qA.asIdeal.under R0 = p := by + exact exactConstantExtensionInfinityAffinePrime_under C S N hExact q + have hMaxExplicit := + exactConstantExtensionDownstairsInfinityMappedIdeal_isMaximal C S N q + have hUpstairsNe := + (exactConstantExtensionUpstairsInfinityPlace + C S N hExact q.1 q.2).2.1.ne_top + change (Ideal.map (algebraMap AS B) qA.asIdeal).under R2 = + Ideal.map (algebraMap R0 R2) p + rw [Ideal.under_map_eq_map_under + (A := R0) (B := AS) (C := R2) (D := B) qA.asIdeal + (by rw [hAffine]; exact hMaxExplicit) + (by + change (exactConstantExtensionUpstairsInfinityPlace + C S N hExact q.1 q.2).1 ≠ ⊤ + exact hUpstairsNe), hAffine] + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionIntermediateFrobeniusTwistFinitePlaceAverage.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionIntermediateFrobeniusTwistFinitePlaceAverage.lean new file mode 100644 index 0000000000..ae01c17e27 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionIntermediateFrobeniusTwistFinitePlaceAverage.lean @@ -0,0 +1,1746 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.ConstantExtensionPlaceSplittingMultiplicity +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionFinitePlaceFrobeniusAverage +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionFrobeniusTwistFinitePlaceUnramified +public import LeanPool.MarkoffModP.BGS.HasseWeil.RationalPlaceTower + +/-! +# Finite-place Frobenius-twist averaging over an intermediate base + +This file proves the finite-place part of Stichtenoth's Frobenius-twist +average for `C(X) \subseteq L \subseteq N`. +-/ + +@[expose] public section + +open scoped BigOperators Pointwise Polynomial TensorProduct + +namespace BGS.HasseWeil + +open BGS.CorvajaZannier + +private theorem finitePlaceUnder_trans_of_fields + (C L F T : Type*) [Field C] [Field L] [Field F] [Field T] + [DecidableEq C] [DecidableEq (RatFunc C)] + [Algebra (RatFunc C) L] [Algebra (RatFunc C) F] [Algebra (RatFunc C) T] + [FiniteDimensional (RatFunc C) L] [FiniteDimensional (RatFunc C) F] + [FiniteDimensional (RatFunc C) T] + [Algebra.IsSeparable (RatFunc C) L] [Algebra.IsSeparable (RatFunc C) F] + [Algebra.IsSeparable (RatFunc C) T] + [Algebra L F] [Algebra F T] [Algebra L T] + [IsScalarTower (RatFunc C) L F] [IsScalarTower (RatFunc C) L T] + [IsScalarTower (RatFunc C) F T] [IsScalarTower L F T] + (Q : FiniteExtensionFinitePlace C T) : + finitePlaceUnder C L F (finitePlaceUnder C F T Q) = finitePlaceUnder C L T Q := by + let R₀ := RatFuncFiniteIntegralClosure C L + let R₁ := RatFuncFiniteIntegralClosure C F + let R₂ := RatFuncFiniteIntegralClosure C T + let : Algebra R₀ R₁ := (finiteIntegralClosureMap C L F).toAlgebra + let : Algebra R₁ R₂ := (finiteIntegralClosureMap C F T).toAlgebra + let : Algebra R₀ R₂ := (finiteIntegralClosureMap C L T).toAlgebra + let : SMul R₀ R₁ := Algebra.toSMul + let : Module R₀ R₁ := Algebra.toModule + let : SMul R₁ R₂ := Algebra.toSMul + let : Module R₁ R₂ := Algebra.toModule + let : SMul R₀ R₂ := Algebra.toSMul + let : Module R₀ R₂ := Algebra.toModule + let : IsScalarTower R₀ R₁ R₂ := by + apply IsScalarTower.of_algebraMap_eq' + ext x + change algebraMap L T (x : L) = + algebraMap F T (algebraMap L F (x : L)) + exact IsScalarTower.algebraMap_apply L F T _ + apply IsDedekindDomain.HeightOneSpectrum.ext + exact Ideal.under_under Q.asIdeal + +noncomputable section + +open BGS.CorvajaZannier +open IsDedekindDomain + + +variable (C S N : Type*) [Field C] [Field S] [Field N] + [Fintype C] [Finite S] + [DecidableEq C] [DecidableEq S] + [DecidableEq (RatFunc C)] [DecidableEq (RatFunc S)] + [Algebra (RatFunc C) N] [FiniteDimensional (RatFunc C) N] + [Algebra.IsSeparable (RatFunc C) N] + [Algebra C S] [FiniteDimensional C S] [IsGalois C S] + +local instance intermediateAverageTopConstantAlgebra : Algebra C N := + bridgeBaseConstantAlgebra C N + +local instance intermediateAverageTopConstantTower : + IsScalarTower C (RatFunc C) N := + IsScalarTower.of_algebraMap_eq' rfl + +local instance intermediateAverageTargetPolynomialAlgebra : + Algebra S[X] (ExactConstantExtension C N S) := + bridgeTargetPolynomialAlgebra C S N + +variable (hExact : algebraicClosure C N = + (⊥ : IntermediateField C N)) + +section IntermediateBase + +variable (L : Type*) [Field L] + [Algebra (RatFunc C) L] [FiniteDimensional (RatFunc C) L] + [Algebra.IsSeparable (RatFunc C) L] + [Algebra L N] [IsScalarTower (RatFunc C) L N] + [FiniteDimensional L N] [IsGalois L N] + +local instance intermediateAverageBaseConstantAlgebra : Algebra C L := + RingHom.toAlgebra ((algebraMap (RatFunc C) L).comp + (algebraMap C (RatFunc C))) + +local instance intermediateAverageConstantTower : IsScalarTower C L N := by + apply IsScalarTower.of_algebraMap_eq' + ext c + change algebraMap (RatFunc C) N (algebraMap C (RatFunc C) c) = + algebraMap L N + (algebraMap (RatFunc C) L (algebraMap C (RatFunc C) c)) + exact IsScalarTower.algebraMap_apply (RatFunc C) L N _ + +local instance intermediateAverageRationalFinitePlaceFintype : + Fintype (FiniteExtensionRationalFinitePlace C L) := Fintype.ofFinite _ + +omit [Fintype C] [Finite S] [DecidableEq C] [DecidableEq S] [DecidableEq (RatFunc C)] + [DecidableEq (RatFunc S)] [FiniteDimensional (RatFunc C) N] + [Algebra.IsSeparable (RatFunc C) N] [Algebra (RatFunc C) L] + [FiniteDimensional (RatFunc C) L] [Algebra.IsSeparable (RatFunc C) L] + [IsScalarTower (RatFunc C) L N] [IsGalois L N] in +/-- The exact constant extension is finite-dimensional over every +intermediate function field `L`. -/ +theorem finiteDimensional_exactConstantExtension_over_intermediateBase + (hExact : algebraicClosure C N = + (⊥ : IntermediateField C N)) : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra L (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C L N S + letI : SMul L (ExactConstantExtension C N S) := Algebra.toSMul + letI : Module L (ExactConstantExtension C N S) := Algebra.toModule + FiniteDimensional L (ExactConstantExtension C N S) := by + let T := ExactConstantExtension C N S + let : Field T := exactConstantExtensionField C N S hExact + let : Algebra L T := exactConstantExtensionBaseAlgebra C L N S + let : SMul L T := Algebra.toSMul + let : Module L T := Algebra.toModule + let : Algebra N T := exactConstantExtensionAlgebra C N S + let : SMul N T := Algebra.toSMul + let : Module N T := Algebra.toModule + let : IsScalarTower L N T := + exactConstantExtensionBaseTower C L N S + let tensorEquiv := exactConstantExtensionLinearEquiv C N S + let : Module.Finite N (N ⊗[C] S) := Module.Finite.base_change C N S + let : Module.Finite N T := Module.Finite.equiv tensorEquiv + let : Module.Finite L T := Module.Finite.trans N T + infer_instance + +omit [Fintype C] [Finite S] [DecidableEq C] [DecidableEq S] [DecidableEq (RatFunc C)] + [DecidableEq (RatFunc S)] [FiniteDimensional (RatFunc C) N] + [Algebra.IsSeparable (RatFunc C) N] [FiniteDimensional C S] [IsGalois C S] + [FiniteDimensional (RatFunc C) L] [Algebra.IsSeparable (RatFunc C) L] + [FiniteDimensional L N] [IsGalois L N] in +/-- Compatibility of the rational-function and intermediate-base algebra +maps on the exact constant extension. -/ +theorem exactConstantExtensionIntermediate_ratFuncBaseTower : + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + letI : SMul (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toSMul + letI : Module (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toModule + letI : Algebra L (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C L N S + letI : SMul L (ExactConstantExtension C N S) := Algebra.toSMul + letI : Module L (ExactConstantExtension C N S) := Algebra.toModule + IsScalarTower (RatFunc C) L (ExactConstantExtension C N S) := by + let T := ExactConstantExtension C N S + let : Algebra (RatFunc C) T := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : SMul (RatFunc C) T := Algebra.toSMul + let : Module (RatFunc C) T := Algebra.toModule + let : Algebra L T := exactConstantExtensionBaseAlgebra C L N S + let : Algebra N T := exactConstantExtensionAlgebra C N S + let : SMul L T := Algebra.toSMul + let : Module L T := Algebra.toModule + apply IsScalarTower.of_algebraMap_eq' + ext x + change (1 : S) ⊗ₜ algebraMap (RatFunc C) N x = + (1 : S) ⊗ₜ algebraMap L N (algebraMap (RatFunc C) L x) + congr 1 + exact IsScalarTower.algebraMap_apply (RatFunc C) L N x + +/-- The rational-function algebra on an intermediate-base Frobenius-twist +field is obtained through `C(X) → L → F_g`. -/ +@[implicit_reducible] +noncomputable def intermediateFrobeniusTwistFieldRatFuncAlgebra + (g : N ≃ₐ[L] N) : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra L (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C L N S + Algebra (RatFunc C) + (exactConstantExtensionFrobeniusTwistField C L N S hExact g) := by + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra L (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C L N S + let F := exactConstantExtensionFrobeniusTwistField C L N S hExact g + letI : Algebra L F := SubalgebraClass.toAlgebra F.toSubalgebra + exact RingHom.toAlgebra + ((show L →+* F from algebraMap L F).comp + (show RatFunc C →+* L from algebraMap (RatFunc C) L)) + +omit [Finite S] [DecidableEq C] [DecidableEq S] [DecidableEq (RatFunc C)] + [DecidableEq (RatFunc S)] [FiniteDimensional (RatFunc C) N] + [Algebra.IsSeparable (RatFunc C) N] [FiniteDimensional (RatFunc C) L] + [Algebra.IsSeparable (RatFunc C) L] [FiniteDimensional L N] [IsGalois L N] in +/-- The induced rational-function algebra is compatible with the inclusion +of the twist field into the exact constant extension. -/ +theorem intermediateFrobeniusTwistField_ratFunc_tower + (g : N ≃ₐ[L] N) : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + letI : SMul (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toSMul + letI : Module (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toModule + letI : Algebra L (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C L N S + let F := exactConstantExtensionFrobeniusTwistField C L N S hExact g + letI : Algebra L F := SubalgebraClass.toAlgebra F.toSubalgebra + letI : Algebra (RatFunc C) F := + intermediateFrobeniusTwistFieldRatFuncAlgebra C S N hExact L g + letI : Algebra F (ExactConstantExtension C N S) := F.toAlgebra + letI : SMul (RatFunc C) F := Algebra.toSMul + letI : Module (RatFunc C) F := Algebra.toModule + letI : SMul F (ExactConstantExtension C N S) := Algebra.toSMul + letI : Module F (ExactConstantExtension C N S) := Algebra.toModule + IsScalarTower (RatFunc C) F (ExactConstantExtension C N S) := by + let T := ExactConstantExtension C N S + let : Field T := exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) T := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : SMul (RatFunc C) T := Algebra.toSMul + let : Module (RatFunc C) T := Algebra.toModule + let : Algebra L T := exactConstantExtensionBaseAlgebra C L N S + let : SMul L T := Algebra.toSMul + let : Module L T := Algebra.toModule + let : IsScalarTower (RatFunc C) L T := + exactConstantExtensionIntermediate_ratFuncBaseTower C S N L + let F := exactConstantExtensionFrobeniusTwistField C L N S hExact g + let : Algebra L F := SubalgebraClass.toAlgebra F.toSubalgebra + let : Algebra (RatFunc C) F := + intermediateFrobeniusTwistFieldRatFuncAlgebra C S N hExact L g + let : Algebra F T := F.toAlgebra + let : SMul (RatFunc C) F := Algebra.toSMul + let : Module (RatFunc C) F := Algebra.toModule + let : SMul F T := Algebra.toSMul + let : Module F T := Algebra.toModule + let : IsScalarTower L F T := IsScalarTower.of_algebraMap_eq' rfl + apply IsScalarTower.of_algebraMap_eq' + ext x + calc + algebraMap (RatFunc C) T x = + algebraMap L T (algebraMap (RatFunc C) L x) := + IsScalarTower.algebraMap_apply (RatFunc C) L T x + _ = algebraMap F T (algebraMap L F (algebraMap (RatFunc C) L x)) := + IsScalarTower.algebraMap_apply L F T _ + _ = algebraMap F T (algebraMap (RatFunc C) F x) := rfl + +omit [Finite S] [DecidableEq C] [DecidableEq S] [DecidableEq (RatFunc C)] + [DecidableEq (RatFunc S)] [Algebra.IsSeparable (RatFunc C) N] + [FiniteDimensional (RatFunc C) L] [Algebra.IsSeparable (RatFunc C) L] + [FiniteDimensional L N] [IsGalois L N] in +/-- Every intermediate-base Frobenius-twist field is a finite function field +over `C(X)`. -/ +theorem finiteDimensional_intermediateFrobeniusTwistField_over_ratFunc + (g : N ≃ₐ[L] N) : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + letI : SMul (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toSMul + letI : Module (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toModule + letI : Algebra L (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C L N S + letI : SMul L (ExactConstantExtension C N S) := Algebra.toSMul + letI : Module L (ExactConstantExtension C N S) := Algebra.toModule + let F := exactConstantExtensionFrobeniusTwistField C L N S hExact g + letI : Algebra (RatFunc C) F := + intermediateFrobeniusTwistFieldRatFuncAlgebra C S N hExact L g + letI : SMul (RatFunc C) F := Algebra.toSMul + letI : Module (RatFunc C) F := Algebra.toModule + FiniteDimensional (RatFunc C) F := by + let T := ExactConstantExtension C N S + let : Field T := exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) T := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : SMul (RatFunc C) T := Algebra.toSMul + let : Module (RatFunc C) T := Algebra.toModule + let : Algebra L T := exactConstantExtensionBaseAlgebra C L N S + let F := exactConstantExtensionFrobeniusTwistField C L N S hExact g + let : Algebra L F := SubalgebraClass.toAlgebra F.toSubalgebra + let : Algebra (RatFunc C) F := + intermediateFrobeniusTwistFieldRatFuncAlgebra C S N hExact L g + let : Algebra F T := F.toAlgebra + let : SMul (RatFunc C) F := Algebra.toSMul + let : Module (RatFunc C) F := Algebra.toModule + let : SMul F T := Algebra.toSMul + let : Module F T := Algebra.toModule + let : IsScalarTower (RatFunc C) F T := + intermediateFrobeniusTwistField_ratFunc_tower C S N hExact L g + let : FiniteDimensional (RatFunc C) T := + finiteDimensional_exactConstantExtension_over_baseRatFunc C S N hExact + let : Module.IsTorsionFree F T := by + rw [Module.isTorsionFree_iff_algebraMap_injective] + exact (algebraMap F T).injective + exact Module.Finite.left (RatFunc C) F T + +omit [Finite S] [DecidableEq C] [DecidableEq S] [DecidableEq (RatFunc C)] + [DecidableEq (RatFunc S)] [FiniteDimensional (RatFunc C) N] + [FiniteDimensional (RatFunc C) L] [Algebra.IsSeparable (RatFunc C) L] + [FiniteDimensional L N] [IsGalois L N] in +/-- Separability of the exact constant extension descends to every +intermediate-base Frobenius-twist field. -/ +theorem isSeparable_intermediateFrobeniusTwistField_over_ratFunc + (g : N ≃ₐ[L] N) : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + letI : Algebra L (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C L N S + let F := exactConstantExtensionFrobeniusTwistField C L N S hExact g + letI : Algebra (RatFunc C) F := + intermediateFrobeniusTwistFieldRatFuncAlgebra C S N hExact L g + letI : SMul (RatFunc C) F := Algebra.toSMul + letI : Module (RatFunc C) F := Algebra.toModule + Algebra.IsSeparable (RatFunc C) F := by + let T := ExactConstantExtension C N S + let : Field T := exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) T := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : SMul (RatFunc C) T := Algebra.toSMul + let : Module (RatFunc C) T := Algebra.toModule + let : Algebra L T := exactConstantExtensionBaseAlgebra C L N S + let F := exactConstantExtensionFrobeniusTwistField C L N S hExact g + let : Algebra L F := SubalgebraClass.toAlgebra F.toSubalgebra + let : Algebra (RatFunc C) F := + intermediateFrobeniusTwistFieldRatFuncAlgebra C S N hExact L g + let : Algebra F T := F.toAlgebra + let : SMul (RatFunc C) F := Algebra.toSMul + let : Module (RatFunc C) F := Algebra.toModule + let : SMul F T := Algebra.toSMul + let : Module F T := Algebra.toModule + let : IsScalarTower (RatFunc C) F T := + intermediateFrobeniusTwistField_ratFunc_tower C S N hExact L g + let : Algebra.IsSeparable (RatFunc C) T := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + exact Algebra.isSeparable_tower_bot_of_isSeparable (RatFunc C) F T + +/-- The ambient Frobenius twist regarded as an automorphism over its own +fixed field. -/ +noncomputable def intermediateFrobeniusTwistOverFixedField + (g : N ≃ₐ[L] N) : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra L (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C L N S + ExactConstantExtension C N S ≃ₐ[ + exactConstantExtensionFrobeniusTwistField C L N S hExact g] + ExactConstantExtension C N S := by + let T := ExactConstantExtension C N S + letI : Field T := exactConstantExtensionField C N S hExact + letI : Algebra L T := exactConstantExtensionBaseAlgebra C L N S + letI : SMul L T := Algebra.toSMul + letI : Module L T := Algebra.toModule + letI : FiniteDimensional L T := + finiteDimensional_exactConstantExtension_over_intermediateBase + C S N L hExact + let sigma := exactConstantExtensionFrobeniusTwist C L N S hExact g + let H := exactConstantExtensionFrobeniusTwistSubgroup C L N S hExact g + exact IntermediateField.subgroupEquivAlgEquiv H + ⟨sigma, Subgroup.mem_zpowers sigma⟩ + +omit [Finite S] [DecidableEq C] [DecidableEq S] [DecidableEq (RatFunc C)] + [DecidableEq (RatFunc S)] [FiniteDimensional (RatFunc C) N] + [Algebra.IsSeparable (RatFunc C) N] [FiniteDimensional (RatFunc C) L] + [Algebra.IsSeparable (RatFunc C) L] [IsGalois L N] in +@[simp] +theorem intermediateFrobeniusTwistOverFixedField_apply + (g : N ≃ₐ[L] N) (x : ExactConstantExtension C N S) : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra L (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C L N S + intermediateFrobeniusTwistOverFixedField C S N hExact L g x = + exactConstantExtensionFrobeniusTwist C L N S hExact g x := by + let T := ExactConstantExtension C N S + let : Field T := exactConstantExtensionField C N S hExact + let : Algebra L T := exactConstantExtensionBaseAlgebra C L N S + change (exactConstantExtensionFrobeniusTwist + C L N S hExact g).toEquiv x = _ + rfl + +omit [Finite S] [DecidableEq C] [DecidableEq S] [DecidableEq (RatFunc C)] + [DecidableEq (RatFunc S)] [FiniteDimensional (RatFunc C) N] + [Algebra.IsSeparable (RatFunc C) N] [FiniteDimensional (RatFunc C) L] + [Algebra.IsSeparable (RatFunc C) L] [IsGalois L N] in +/-- The twist over its fixed field generates the full relative Galois +group. -/ +theorem intermediateFrobeniusTwistOverFixedField_zpowers_eq_top + (g : N ≃ₐ[L] N) : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra L (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C L N S + Subgroup.zpowers + (intermediateFrobeniusTwistOverFixedField C S N hExact L g) = ⊤ := by + let T := ExactConstantExtension C N S + let : Field T := exactConstantExtensionField C N S hExact + let : Algebra L T := exactConstantExtensionBaseAlgebra C L N S + let : SMul L T := Algebra.toSMul + let : Module L T := Algebra.toModule + let : FiniteDimensional L T := + finiteDimensional_exactConstantExtension_over_intermediateBase + C S N L hExact + let sigma := exactConstantExtensionFrobeniusTwist C L N S hExact g + let H := exactConstantExtensionFrobeniusTwistSubgroup C L N S hExact g + let e := IntermediateField.subgroupEquivAlgEquiv H + let u : H := ⟨sigma, Subgroup.mem_zpowers sigma⟩ + change Subgroup.zpowers (e u) = ⊤ + apply (Subgroup.eq_top_iff' _).mpr + intro tau + let h : H := e.symm tau + obtain ⟨k, hk⟩ := Subgroup.mem_zpowers_iff.mp h.2 + apply Subgroup.mem_zpowers_iff.mpr + refine ⟨k, ?_⟩ + calc + (e u) ^ k = e (u ^ k) := (map_zpow e u k).symm + _ = e h := congrArg e (Subtype.ext hk) + _ = tau := e.apply_symm_apply tau + +omit [FiniteDimensional (RatFunc C) L] + [Algebra.IsSeparable (RatFunc C) L] + [FiniteDimensional (RatFunc C) N] + [Algebra.IsSeparable (RatFunc C) N] + [FiniteDimensional L N] [IsGalois L N] in +omit [Finite S] [DecidableEq C] [DecidableEq S] [DecidableEq (RatFunc C)] + [DecidableEq (RatFunc S)] in +/-- A power of the generic intermediate-base twist acts on the enlarged +constants by the same power of finite-field Frobenius. -/ +private theorem intermediateFrobeniusTwist_zpow_includeLeft + (g : N ≃ₐ[L] N) (k : ℤ) (s : S) : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra L (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C L N S + ((exactConstantExtensionFrobeniusTwist C L N S hExact g) ^ k) + (Algebra.TensorProduct.includeLeft + (R := C) (S := C) (A := S) (B := N) s) = + Algebra.TensorProduct.includeLeft + (R := C) (S := C) (A := S) (B := N) + (((FiniteField.frobeniusAlgEquivOfAlgebraic C S) ^ k) s) := by + let : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + let : Algebra L (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C L N S + change + ((exactConstantExtensionCombinedAutHom C L N S + (FiniteField.frobeniusAlgEquivOfAlgebraic C S, g)) ^ k) + (Algebra.TensorProduct.includeLeft + (R := C) (S := C) (A := S) (B := N) s) = _ + rw [← map_zpow] + simp [Algebra.TensorProduct.includeLeft_apply, + exactConstantExtensionCombinedAutHom, + exactConstantExtensionConstantAutHom, + exactConstantExtensionFunctionAutHom, + exactConstantExtensionConstantAlgEquivOverBase, + exactConstantExtensionFunctionAlgEquivOverBase] + +/-- Every finite place of the exact constant extension is unramified over an +intermediate-base Frobenius-twist fixed field. -/ +theorem intermediateFrobeniusTwistField_finitePlace_ramificationIdx_eq_one + (g : N ≃ₐ[L] N) + (hdiv : Nat.card (N ≃ₐ[L] N) ∣ Module.finrank C S) : + let : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : SMul (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toSMul + let : Module (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toModule + let : FiniteDimensional (RatFunc C) + (ExactConstantExtension C N S) := + finiteDimensional_exactConstantExtension_over_baseRatFunc C S N hExact + let : Algebra.IsSeparable (RatFunc C) + (ExactConstantExtension C N S) := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + let : Algebra L (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C L N S + let F := exactConstantExtensionFrobeniusTwistField C L N S hExact g + let : Algebra (RatFunc C) F := + intermediateFrobeniusTwistFieldRatFuncAlgebra C S N hExact L g + let : SMul (RatFunc C) F := Algebra.toSMul + let : Module (RatFunc C) F := Algebra.toModule + let : FiniteDimensional (RatFunc C) F := + finiteDimensional_intermediateFrobeniusTwistField_over_ratFunc + C S N hExact L g + let : Algebra.IsSeparable (RatFunc C) F := + isSeparable_intermediateFrobeniusTwistField_over_ratFunc + C S N hExact L g + let : Algebra F (ExactConstantExtension C N S) := F.toAlgebra + let : SMul F (ExactConstantExtension C N S) := Algebra.toSMul + let : Module F (ExactConstantExtension C N S) := Algebra.toModule + let : IsScalarTower (RatFunc C) F + (ExactConstantExtension C N S) := + intermediateFrobeniusTwistField_ratFunc_tower C S N hExact L g + let : FiniteDimensional F (ExactConstantExtension C N S) := + finiteDimensional_exactConstantExtension_over_frobeniusTwistField + C L N S hExact g + let : IsGalois F (ExactConstantExtension C N S) := + isGalois_exactConstantExtension_over_frobeniusTwistField + C L N S hExact g + ∀ Q : FiniteExtensionFinitePlace C (ExactConstantExtension C N S), + finitePlaceRelativeRamificationIdx C F + (ExactConstantExtension C N S) Q = 1 := by + intro model0 model1 model2 model3 model4 model5 model6 F model8 model9 model10 model11 model12 + model13 model14 model15 model16 model17 model18 + let T := ExactConstantExtension C N S + let : SMul L T := Algebra.toSMul + let : Module L T := Algebra.toModule + let : FiniteDimensional L T := + finiteDimensional_exactConstantExtension_over_intermediateBase C S N L hExact + let : Algebra L F := SubalgebraClass.toAlgebra F.toSubalgebra + let : Algebra C[X] F := + RingHom.toAlgebra + ((algebraMap (RatFunc C) F).comp (algebraMap C[X] (RatFunc C))) + let : IsScalarTower C[X] (RatFunc C) F := + IsScalarTower.of_algebraMap_eq' rfl + let : Algebra C[X] T := + RingHom.toAlgebra + ((algebraMap (RatFunc C) T).comp (algebraMap C[X] (RatFunc C))) + let : IsScalarTower C[X] (RatFunc C) T := + IsScalarTower.of_algebraMap_eq' rfl + let A := RatFuncFiniteIntegralClosure C T + let AF := RatFuncFiniteIntegralClosure C F + let : Algebra AF A := (finiteIntegralClosureMap C F T).toAlgebra + let : SMul AF A := Algebra.toSMul + let : Module AF A := Algebra.toModule + let : Algebra S A := + exactConstantExtensionFiniteIntegralClosureConstantAlgebra C N S hExact + let : IsScalarTower AF F T := inferInstance + let : Algebra.IsIntegral C[X] AF := + IsIntegralClosure.isIntegral_algebra C[X] F + let : IsScalarTower C[X] AF T := by + apply IsScalarTower.of_algebraMap_eq + intro x + change algebraMap (RatFunc C) T + (algebraMap C[X] (RatFunc C) x) = + algebraMap F T + (algebraMap (RatFunc C) F (algebraMap C[X] (RatFunc C) x)) + exact IsScalarTower.algebraMap_apply (RatFunc C) F T _ + let : IsScalarTower AF A T := + ⟨fun r t x => by + simp only [Algebra.smul_def, map_mul] + rw [show algebraMap A T (algebraMap AF A r) = + algebraMap AF T r by rfl] + ring⟩ + let : IsIntegralClosure A AF T := + IsIntegralClosure.tower_top (R := C[X]) + let : IsDedekindDomain A := inferInstance + let : MulSemiringAction (T ≃ₐ[F] T) A := + finiteIntegralClosureGalAction C F T + intro Q + let : Q.asIdeal.IsMaximal := Q.isMaximal + rw [← finitePlaceInertiaGroup_card_eq_ramificationIdx C F T Q] + have hInertia : finitePlaceInertiaGroup C F T Q = ⊥ := by + ext tau + constructor + · intro htau + rw [Subgroup.mem_bot] + let sigma := exactConstantExtensionFrobeniusTwist C L N S hExact g + let H := exactConstantExtensionFrobeniusTwistSubgroup C L N S hExact g + let e := IntermediateField.subgroupEquivAlgEquiv H + let h : H := e.symm tau + have he_apply (z : H) (x : T) : e z x = z.1 x := by + change z.1.toEquiv x = z.1 x + rfl + have htau_apply (x : T) : tau x = h.1 x := by + calc + tau x = e h x := by + exact congrArg (fun z : T ≃ₐ[F] T => z x) + (e.apply_symm_apply tau).symm + _ = h.1 x := he_apply h x + obtain ⟨k, hk⟩ := Subgroup.mem_zpowers_iff.mp h.2 + let frob := FiniteField.frobeniusAlgEquivOfAlgebraic C S + have hfrob_apply (s : S) : (frob ^ k) s = s := by + let a : A := algebraMap S A s + have haction : tau • a = algebraMap S A ((frob ^ k) s) := by + apply Subtype.ext + calc + ((tau • a : A) : T) = tau (a : T) := by + change algebraMap A T ((galRestrict AF F T A tau) a) = + tau (algebraMap A T a) + exact algebraMap_galRestrict_apply AF tau a + _ = h.1 (a : T) := htau_apply (a : T) + _ = h.1 (Algebra.TensorProduct.includeLeft + (R := C) (S := C) (A := S) (B := N) s) := by + exact congrArg h.1 + (exactConstantExtensionFiniteIntegralClosure_algebraMap_val + C N S hExact s) + _ = (sigma ^ k) (Algebra.TensorProduct.includeLeft + (R := C) (S := C) (A := S) (B := N) s) := by + exact congrArg + (fun z : T ≃ₐ[L] T => z (Algebra.TensorProduct.includeLeft + (R := C) (S := C) (A := S) (B := N) s)) hk |>.symm + _ = Algebra.TensorProduct.includeLeft + (R := C) (S := C) (A := S) (B := N) ((frob ^ k) s) := + intermediateFrobeniusTwist_zpow_includeLeft + C S N hExact L g k s + _ = ((algebraMap S A ((frob ^ k) s) : A) : T) := + (exactConstantExtensionFiniteIntegralClosure_algebraMap_val + C N S hExact ((frob ^ k) s)).symm + have hmem : tau • a - a ∈ Q.asIdeal := htau a + have hmem' : algebraMap S A ((frob ^ k) s - s) ∈ Q.asIdeal := by + have heq : algebraMap S A ((frob ^ k) s - s) = tau • a - a := by + calc + algebraMap S A ((frob ^ k) s - s) = + algebraMap S A ((frob ^ k) s) - algebraMap S A s := + map_sub (algebraMap S A) _ _ + _ = algebraMap S A ((frob ^ k) s) - a := rfl + _ = tau • a - a := congrArg (fun z : A => z - a) haction.symm + exact heq.symm ▸ hmem + let J : Ideal S := Q.asIdeal.comap (algebraMap S A) + have hmemJ : (frob ^ k) s - s ∈ J := hmem' + have hJne : J ≠ ⊤ := + Ideal.comap_ne_top (algebraMap S A) Q.isPrime.ne_top + have hJ : J = ⊥ := (Ideal.eq_bot_or_top J).resolve_right hJne + have hs : (frob ^ k) s - s = 0 := by + rw [hJ] at hmemJ + simpa only [Ideal.mem_bot] using hmemJ + exact sub_eq_zero.mp hs + have hFrob : frob ^ k = 1 := by + ext s + exact hfrob_apply s + have hkdiv : (Module.finrank C S : ℤ) ∣ k := by + rw [← FiniteField.orderOf_frobeniusAlgEquivOfAlgebraic C S] + exact orderOf_dvd_iff_zpow_eq_one.mpr hFrob + have hsigma : sigma ^ k = 1 := by + rw [← orderOf_dvd_iff_zpow_eq_one, + orderOf_exactConstantExtensionFrobeniusTwist + C L N S hExact g hdiv] + exact hkdiv + have hambient : (h.1 : T ≃ₐ[L] T) = 1 := by + calc + (h.1 : T ≃ₐ[L] T) = sigma ^ k := hk.symm + _ = 1 := hsigma + have hh : h = 1 := Subtype.ext hambient + exact (e.apply_symm_apply tau).symm.trans + ((congrArg e hh).trans (map_one e)) + · intro htau + rw [Subgroup.mem_bot] at htau + simp [htau] + rw [hInertia] + exact Nat.card_unique + +omit [Fintype C] [Finite S] [DecidableEq C] [DecidableEq S] [DecidableEq (RatFunc C)] + [DecidableEq (RatFunc S)] [FiniteDimensional (RatFunc C) L] + [Algebra.IsSeparable (RatFunc C) L] [FiniteDimensional L N] [IsGalois L N] in +/-- Restriction of an exact-constant-extension finite place through `N` +agrees with direct restriction to the intermediate field `L`. -/ +private theorem finitePlaceUnder_intermediate_original + : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + letI : SMul (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toSMul + letI : Module (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toModule + letI : FiniteDimensional (RatFunc C) + (ExactConstantExtension C N S) := + finiteDimensional_exactConstantExtension_over_baseRatFunc C S N hExact + letI : Algebra.IsSeparable (RatFunc C) + (ExactConstantExtension C N S) := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + letI : Algebra L (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C L N S + letI : SMul L (ExactConstantExtension C N S) := Algebra.toSMul + letI : Module L (ExactConstantExtension C N S) := Algebra.toModule + letI : IsScalarTower (RatFunc C) L + (ExactConstantExtension C N S) := + exactConstantExtensionIntermediate_ratFuncBaseTower C S N L + letI : Algebra N (ExactConstantExtension C N S) := + exactConstantExtensionAlgebra C N S + letI : SMul N (ExactConstantExtension C N S) := Algebra.toSMul + letI : Module N (ExactConstantExtension C N S) := Algebra.toModule + letI : IsScalarTower (RatFunc C) N + (ExactConstantExtension C N S) := + exactConstantExtensionBaseTower C (RatFunc C) N S + ∀ Q : FiniteExtensionFinitePlace C (ExactConstantExtension C N S), + finitePlaceUnder C L N + (finitePlaceUnder C N (ExactConstantExtension C N S) Q) = + finitePlaceUnder C L (ExactConstantExtension C N S) Q := by + let T := ExactConstantExtension C N S + let : Field T := exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) T := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : SMul (RatFunc C) T := Algebra.toSMul + let : Module (RatFunc C) T := Algebra.toModule + let : FiniteDimensional (RatFunc C) T := + finiteDimensional_exactConstantExtension_over_baseRatFunc C S N hExact + let : Algebra.IsSeparable (RatFunc C) T := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + let : Algebra L T := exactConstantExtensionBaseAlgebra C L N S + let : SMul L T := Algebra.toSMul + let : Module L T := Algebra.toModule + let : IsScalarTower (RatFunc C) L T := + exactConstantExtensionIntermediate_ratFuncBaseTower C S N L + let : Algebra N T := exactConstantExtensionAlgebra C N S + let : SMul N T := Algebra.toSMul + let : Module N T := Algebra.toModule + let : IsScalarTower (RatFunc C) N T := + exactConstantExtensionBaseTower C (RatFunc C) N S + let : IsScalarTower L N T := + exactConstantExtensionBaseTower C L N S + let R₀ := RatFuncFiniteIntegralClosure C L + let R₁ := RatFuncFiniteIntegralClosure C N + let R₂ := RatFuncFiniteIntegralClosure C T + let : Algebra R₀ R₁ := (finiteIntegralClosureMap C L N).toAlgebra + let : Algebra R₁ R₂ := (finiteIntegralClosureMap C N T).toAlgebra + let : Algebra R₀ R₂ := (finiteIntegralClosureMap C L T).toAlgebra + let : SMul R₀ R₁ := Algebra.toSMul + let : Module R₀ R₁ := Algebra.toModule + let : SMul R₁ R₂ := Algebra.toSMul + let : Module R₁ R₂ := Algebra.toModule + let : SMul R₀ R₂ := Algebra.toSMul + let : Module R₀ R₂ := Algebra.toModule + let : IsScalarTower R₀ R₁ R₂ := by + apply IsScalarTower.of_algebraMap_eq' + ext x + change algebraMap L T (x : L) = + algebraMap N T (algebraMap L N (x : L)) + exact IsScalarTower.algebraMap_apply L N T _ + intro Q + apply IsDedekindDomain.HeightOneSpectrum.ext + exact Ideal.under_under Q.asIdeal + +omit [DecidableEq (RatFunc S)] [FiniteDimensional (RatFunc C) L] + [Algebra.IsSeparable (RatFunc C) L] [FiniteDimensional L N] [IsGalois L N] in +/-- Choose an `S[X]`-presentation of a top finite place while transporting +rationality of its restriction to the intermediate field `L`. -/ +private theorem exists_presentedFinitePlace_of_under_intermediate_rational : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + letI : SMul (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toSMul + letI : Module (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toModule + letI : FiniteDimensional (RatFunc C) + (ExactConstantExtension C N S) := + finiteDimensional_exactConstantExtension_over_baseRatFunc C S N hExact + letI : Algebra.IsSeparable (RatFunc C) + (ExactConstantExtension C N S) := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + letI : Algebra L (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C L N S + letI : SMul L (ExactConstantExtension C N S) := Algebra.toSMul + letI : Module L (ExactConstantExtension C N S) := Algebra.toModule + letI : IsScalarTower (RatFunc C) L + (ExactConstantExtension C N S) := + exactConstantExtensionIntermediate_ratFuncBaseTower C S N L + ∀ Q : FiniteExtensionFinitePlace C (ExactConstantExtension C N S), + finiteExtensionPlaceDegree C L + (.inl (finitePlaceUnder C L (ExactConstantExtension C N S) Q)) = 1 → + ∃ q : IsDedekindDomain.HeightOneSpectrum + (integralClosure S[X] (ExactConstantExtension C N S)), + exactConstantExtensionCompatibleBaseFinitePlace C S N hExact q = Q ∧ + finiteExtensionPlaceDegree C L + (.inl (finitePlaceUnder C L N + (exactConstantExtensionDownstairsFinitePlace + C S N hExact q))) = 1 := by + let T := ExactConstantExtension C N S + let : Field T := exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) T := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : SMul (RatFunc C) T := Algebra.toSMul + let : Module (RatFunc C) T := Algebra.toModule + let : FiniteDimensional (RatFunc C) T := + finiteDimensional_exactConstantExtension_over_baseRatFunc C S N hExact + let : Algebra.IsSeparable (RatFunc C) T := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + let : Algebra L T := exactConstantExtensionBaseAlgebra C L N S + let : SMul L T := Algebra.toSMul + let : Module L T := Algebra.toModule + let : IsScalarTower (RatFunc C) L T := + exactConstantExtensionIntermediate_ratFuncBaseTower C S N L + let : Algebra N T := exactConstantExtensionAlgebra C N S + let : SMul N T := Algebra.toSMul + let : Module N T := Algebra.toModule + let : IsScalarTower (RatFunc C) N T := + exactConstantExtensionBaseTower C (RatFunc C) N S + intro Q hBase + let e := exactConstantExtensionPresentedFinitePlaceEquiv C S N hExact + let q := e.symm Q + have heq : exactConstantExtensionCompatibleBaseFinitePlace + C S N hExact q = Q := by + calc + exactConstantExtensionCompatibleBaseFinitePlace C S N hExact q = e q := + (exactConstantExtensionPresentedFinitePlaceEquiv_apply + C S N hExact q).symm + _ = Q := e.apply_symm_apply Q + have hDownstairs : finitePlaceUnder C N T Q = + exactConstantExtensionDownstairsFinitePlace C S N hExact q := by + calc + finitePlaceUnder C N T Q = + finitePlaceUnder C N T + (exactConstantExtensionCompatibleBaseFinitePlace + C S N hExact q) := congrArg _ heq.symm + _ = exactConstantExtensionDownstairsFinitePlace C S N hExact q := + exactConstantExtensionCompatibleBaseFinitePlace_under_original + C S N hExact q + refine ⟨q, heq, ?_⟩ + rw [← hDownstairs, + finitePlaceUnder_intermediate_original C S N hExact L Q] + exact hBase + +/-- Every top finite place over a rational finite place of `L` has absolute +degree `[S : C]` when `[N : L]` divides the constant-extension degree. -/ +theorem exactConstantExtensionFinitePlace_degree_eq_finrank_of_under_intermediate_rational + (hDegreeDiv : Module.finrank L N ∣ Module.finrank C S) : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + letI : SMul (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toSMul + letI : Module (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toModule + letI : FiniteDimensional (RatFunc C) + (ExactConstantExtension C N S) := + finiteDimensional_exactConstantExtension_over_baseRatFunc C S N hExact + letI : Algebra.IsSeparable (RatFunc C) + (ExactConstantExtension C N S) := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + letI : Algebra L (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C L N S + letI : SMul L (ExactConstantExtension C N S) := Algebra.toSMul + letI : Module L (ExactConstantExtension C N S) := Algebra.toModule + letI : IsScalarTower (RatFunc C) L + (ExactConstantExtension C N S) := + exactConstantExtensionIntermediate_ratFuncBaseTower C S N L + ∀ Q : FiniteExtensionFinitePlace C (ExactConstantExtension C N S), + finiteExtensionPlaceDegree C L + (.inl (finitePlaceUnder C L (ExactConstantExtension C N S) Q)) = 1 → + finiteExtensionPlaceDegree C (ExactConstantExtension C N S) (.inl Q) = + Module.finrank C S := by + let T := ExactConstantExtension C N S + let : Field T := exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) T := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : SMul (RatFunc C) T := Algebra.toSMul + let : Module (RatFunc C) T := Algebra.toModule + let : FiniteDimensional (RatFunc C) T := + finiteDimensional_exactConstantExtension_over_baseRatFunc C S N hExact + let : Algebra.IsSeparable (RatFunc C) T := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + let : Algebra L T := exactConstantExtensionBaseAlgebra C L N S + let : SMul L T := Algebra.toSMul + let : Module L T := Algebra.toModule + let : IsScalarTower (RatFunc C) L T := + exactConstantExtensionIntermediate_ratFuncBaseTower C S N L + let : Algebra N T := exactConstantExtensionAlgebra C N S + let : SMul N T := Algebra.toSMul + let : Module N T := Algebra.toModule + let : IsScalarTower (RatFunc C) N T := + exactConstantExtensionBaseTower C (RatFunc C) N S + let : IsScalarTower L N T := exactConstantExtensionBaseTower C L N S + let : Algebra (RatFunc S) T := + ratFuncExactConstantExtensionAlgebra C S N hExact + let : SMul (RatFunc S) T := Algebra.toSMul + let : Module (RatFunc S) T := Algebra.toModule + let : FiniteDimensional (RatFunc S) T := + finiteDimensional_over_extendedRatFunc C S N hExact + let : Algebra.IsSeparable (RatFunc S) T := + isSeparable_over_extendedRatFunc C S N hExact + intro Q hBase + obtain ⟨q, heq, hBaseQ⟩ := + exists_presentedFinitePlace_of_under_intermediate_rational + C S N hExact L Q hBase + let P := exactConstantExtensionDownstairsFinitePlace C S N hExact q + let P₀ := finitePlaceUnder C L N P + have hInertiaDiv : finitePlaceRelativeInertiaDeg C L N P ∣ + Module.finrank L N := by + let PInFiber : FinitePlaceUnderFiber C L N P₀ := ⟨P, rfl⟩ + have hFiber := + finitePlaceUnderFiber_card_mul_ramificationIdx_mul_inertiaDeg_eq_field_finrank + C L N P₀ PInFiber + refine ⟨Fintype.card (FinitePlaceUnderFiber C L N P₀) * + finitePlaceRelativeRamificationIdx C L N P, ?_⟩ + simpa [PInFiber, Nat.mul_comm, Nat.mul_left_comm, Nat.mul_assoc] + using hFiber.symm + have hDownDegreeEq : finiteExtensionPlaceDegree C N (.inl P) = + finitePlaceRelativeInertiaDeg C L N P := by + have hDegree := finiteExtensionPlaceDegree_inl_eq_mul_relativeInertiaDeg + C L N P + simpa [P₀, P, hBaseQ] using hDegree + have hDownDegreeDiv : finiteExtensionPlaceDegree C N (.inl P) ∣ + Module.finrank C S := by + rw [hDownDegreeEq] + exact hInertiaDiv.trans hDegreeDiv + have hUpstairsRational : + finiteExtensionPlaceDegree S T + (.inl (exactConstantExtensionUpstairsFinitePlace C S N hExact q)) = 1 := by + rw [exactConstantExtensionFinitePlace_degree_eq_div_gcd + C S N hExact q, + (Nat.gcd_eq_right_iff_dvd).2 hDownDegreeDiv] + exact Nat.div_self (finiteExtensionPlaceDegree_pos C N (.inl P)) + have hTop := exactConstantExtensionCompatibleBaseFinitePlace_degree_eq + C S N hExact q hUpstairsRational + rw [heq] at hTop + exact hTop + +/-- Presentation-free local Frobenius-coset identity over a rational finite +place of the intermediate field `L`. -/ +theorem + exactConstantExtensionFinitePlace_frobeniusFiber_fixedPoint_sum_of_under_intermediate_rational + (hDegreeDiv : Module.finrank L N ∣ Module.finrank C S) : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + letI : SMul (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toSMul + letI : Module (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toModule + letI : FiniteDimensional (RatFunc C) + (ExactConstantExtension C N S) := + finiteDimensional_exactConstantExtension_over_baseRatFunc C S N hExact + letI : Algebra.IsSeparable (RatFunc C) + (ExactConstantExtension C N S) := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + letI : Algebra L (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C L N S + letI : SMul L (ExactConstantExtension C N S) := Algebra.toSMul + letI : Module L (ExactConstantExtension C N S) := Algebra.toModule + letI : IsScalarTower (RatFunc C) L + (ExactConstantExtension C N S) := + exactConstantExtensionIntermediate_ratFuncBaseTower C S N L + letI : FiniteDimensional L (ExactConstantExtension C N S) := + finiteDimensional_exactConstantExtension_over_intermediateBase + C S N L hExact + letI : IsGalois L (ExactConstantExtension C N S) := + exactConstantExtension_isGalois C L N S hExact + ∀ Q : FiniteExtensionFinitePlace C (ExactConstantExtension C N S), + finiteExtensionPlaceDegree C L + (.inl (finitePlaceUnder C L (ExactConstantExtension C N S) Q)) = 1 → + let P := finitePlaceUnder C L (ExactConstantExtension C N S) Q + let pi := exactConstantExtensionConstantQuotient C L N S hExact + letI : DecidableEq (S ≃ₐ[C] S) := Classical.decEq _ + letI : Fintype (ExactConstantExtension C N S ≃ₐ[L] + ExactConstantExtension C N S) := Fintype.ofFinite _ + letI : Fintype (S ≃ₐ[C] S) := Fintype.ofFinite _ + letI : Fintype + (pi ⁻¹' ({FiniteField.frobeniusAlgEquivOfAlgebraic C S} : + Set (S ≃ₐ[C] S))) := Fintype.ofFinite _ + letI := finiteIntegralClosureGalAction C L + (ExactConstantExtension C N S) + letI := finitePlaceUnderFiberGalAction C L + (ExactConstantExtension C N S) P + (∑ g : pi ⁻¹' + ({FiniteField.frobeniusAlgEquivOfAlgebraic C S} : + Set (S ≃ₐ[C] S)), + Nat.card (MulAction.fixedBy + (FinitePlaceUnderFiber C L (ExactConstantExtension C N S) P) + g.1)) = + Nat.card (N ≃ₐ[L] N) := by + let T := ExactConstantExtension C N S + let : Field T := exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) T := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : SMul (RatFunc C) T := Algebra.toSMul + let : Module (RatFunc C) T := Algebra.toModule + let : FiniteDimensional (RatFunc C) T := + finiteDimensional_exactConstantExtension_over_baseRatFunc C S N hExact + let : Algebra.IsSeparable (RatFunc C) T := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + let : Algebra L T := exactConstantExtensionBaseAlgebra C L N S + let : SMul L T := Algebra.toSMul + let : Module L T := Algebra.toModule + let : IsScalarTower (RatFunc C) L T := + exactConstantExtensionIntermediate_ratFuncBaseTower C S N L + let : FiniteDimensional L T := + finiteDimensional_exactConstantExtension_over_intermediateBase + C S N L hExact + let : IsGalois L T := exactConstantExtension_isGalois C L N S hExact + intro Q hBase + obtain ⟨q, heq, hBaseQ⟩ := + exists_presentedFinitePlace_of_under_intermediate_rational + C S N hExact L Q hBase + rw [← heq] + exact exactConstantExtensionFinitePlace_frobeniusFiber_fixedPoint_sum + C S N hExact L q hBaseQ hDegreeDiv + +omit [Finite S] [DecidableEq C] [DecidableEq S] [DecidableEq (RatFunc C)] + [DecidableEq (RatFunc S)] [FiniteDimensional (RatFunc C) N] + [Algebra.IsSeparable (RatFunc C) N] [FiniteDimensional (RatFunc C) L] + [Algebra.IsSeparable (RatFunc C) L] in +/-- The Frobenius-fiber parametrization sends `g` to the ambient twist +`(Frob, g)` over the intermediate field. -/ +@[simp] +theorem intermediate_exactConstantExtensionFrobeniusFiberEquiv_apply_val + (g : N ≃ₐ[L] N) : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra L (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C L N S + ((exactConstantExtensionFrobeniusFiberEquiv + C L N S hExact) g).1 = + exactConstantExtensionFrobeniusTwist C L N S hExact g := by + let : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + let : Algebra L (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C L N S + rfl + +/-- Fixed top finite places in the restriction fiber above one rational +finite place of `L`, for one intermediate-base Frobenius twist. -/ +abbrev IntermediateFrobeniusTwistFinitePlaceFiberFixedBy + (g : N ≃ₐ[L] N) (P : FiniteExtensionRationalFinitePlace C L) : Type _ := + let T := ExactConstantExtension C N S + letI : Field T := exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) T := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + letI : SMul (RatFunc C) T := Algebra.toSMul + letI : Module (RatFunc C) T := Algebra.toModule + letI : FiniteDimensional (RatFunc C) T := + finiteDimensional_exactConstantExtension_over_baseRatFunc C S N hExact + letI : Algebra.IsSeparable (RatFunc C) T := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + letI : Algebra L T := exactConstantExtensionBaseAlgebra C L N S + letI : SMul L T := Algebra.toSMul + letI : Module L T := Algebra.toModule + letI : IsScalarTower (RatFunc C) L T := + exactConstantExtensionIntermediate_ratFuncBaseTower C S N L + letI : FiniteDimensional L T := + finiteDimensional_exactConstantExtension_over_intermediateBase + C S N L hExact + letI : IsGalois L T := exactConstantExtension_isGalois C L N S hExact + @MulAction.fixedBy (T ≃ₐ[L] T) (FinitePlaceUnderFiber C L T P.1) _ + (finitePlaceUnderFiberGalAction C L T P.1) + (exactConstantExtensionFrobeniusTwist C L N S hExact g) + +/-- Above one rational finite place of `L`, summing fixed top places over all +intermediate-base Frobenius twists contributes exactly `|Gal(N/L)|`. -/ +theorem sum_card_finitePlaceUnderFiber_fixedBy_intermediateFrobeniusTwist_eq_card_galois + (hDegreeDiv : Module.finrank L N ∣ Module.finrank C S) + (P : FiniteExtensionRationalFinitePlace C L) : + (∑ g : N ≃ₐ[L] N, + Nat.card (IntermediateFrobeniusTwistFinitePlaceFiberFixedBy + C S N hExact L g P)) = Nat.card (N ≃ₐ[L] N) := by + let T := ExactConstantExtension C N S + let : Field T := exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) T := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : SMul (RatFunc C) T := Algebra.toSMul + let : Module (RatFunc C) T := Algebra.toModule + let : FiniteDimensional (RatFunc C) T := + finiteDimensional_exactConstantExtension_over_baseRatFunc C S N hExact + let : Algebra.IsSeparable (RatFunc C) T := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + let : Algebra L T := exactConstantExtensionBaseAlgebra C L N S + let : SMul L T := Algebra.toSMul + let : Module L T := Algebra.toModule + let : IsScalarTower (RatFunc C) L T := + exactConstantExtensionIntermediate_ratFuncBaseTower C S N L + let : FiniteDimensional L T := + finiteDimensional_exactConstantExtension_over_intermediateBase + C S N L hExact + let : IsGalois L T := exactConstantExtension_isGalois C L N S hExact + let : Fintype (T ≃ₐ[L] T) := Fintype.ofFinite _ + let := finiteIntegralClosureGalAction C L T + let := finitePlaceUnderFiberGalAction C L T P.1 + let pi := exactConstantExtensionConstantQuotient C L N S hExact + let : DecidableEq (S ≃ₐ[C] S) := Classical.decEq _ + let : Fintype (S ≃ₐ[C] S) := Fintype.ofFinite _ + let : Fintype + (pi ⁻¹' ({FiniteField.frobeniusAlgEquivOfAlgebraic C S} : + Set (S ≃ₐ[C] S))) := Fintype.ofFinite _ + obtain ⟨Q, hQ⟩ := finitePlaceUnder_surjective C L T P.1 + have hBase : finiteExtensionPlaceDegree C L + (.inl (finitePlaceUnder C L T Q)) = 1 := by + rw [hQ] + exact P.2 + have hlocal := + exactConstantExtensionFinitePlace_frobeniusFiber_fixedPoint_sum_of_under_intermediate_rational + C S N hExact L hDegreeDiv Q hBase + rw [hQ] at hlocal + let e := exactConstantExtensionFrobeniusFiberEquiv C L N S hExact + calc + (∑ g : N ≃ₐ[L] N, + Nat.card (IntermediateFrobeniusTwistFinitePlaceFiberFixedBy + C S N hExact L g P)) = + ∑ g : N ≃ₐ[L] N, + Nat.card (MulAction.fixedBy + (FinitePlaceUnderFiber C L T P.1) (e g).1) := by + apply Finset.sum_congr rfl + intro g _ + rw [intermediate_exactConstantExtensionFrobeniusFiberEquiv_apply_val] + _ = ∑ x : pi ⁻¹' + ({FiniteField.frobeniusAlgEquivOfAlgebraic C S} : + Set (S ≃ₐ[C] S)), + Nat.card (MulAction.fixedBy + (FinitePlaceUnderFiber C L T P.1) x.1) := + e.sum_comp (fun x ↦ Nat.card (MulAction.fixedBy + (FinitePlaceUnderFiber C L T P.1) x.1)) + _ = Nat.card (N ≃ₐ[L] N) := hlocal + +/-- Rational finite places of an intermediate-base twist field are exactly +the degree-`[S : C]` top finite places fixed by its ambient Frobenius twist. -/ +noncomputable def + intermediateFrobeniusTwistField_rationalFinitePlace_equiv_ambientFixedFinitePlace + (g : N ≃ₐ[L] N) + (hdiv : Nat.card (N ≃ₐ[L] N) ∣ Module.finrank C S) : + let T := ExactConstantExtension C N S + letI : Field T := exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) T := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + letI : SMul (RatFunc C) T := Algebra.toSMul + letI : Module (RatFunc C) T := Algebra.toModule + letI : FiniteDimensional (RatFunc C) T := + finiteDimensional_exactConstantExtension_over_baseRatFunc C S N hExact + letI : Algebra.IsSeparable (RatFunc C) T := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + letI : Algebra L T := exactConstantExtensionBaseAlgebra C L N S + letI : SMul L T := Algebra.toSMul + letI : Module L T := Algebra.toModule + letI : IsScalarTower (RatFunc C) L T := + exactConstantExtensionIntermediate_ratFuncBaseTower C S N L + letI : FiniteDimensional L T := + finiteDimensional_exactConstantExtension_over_intermediateBase + C S N L hExact + letI : IsGalois L T := exactConstantExtension_isGalois C L N S hExact + let F := exactConstantExtensionFrobeniusTwistField C L N S hExact g + letI : Algebra L F := SubalgebraClass.toAlgebra F.toSubalgebra + letI : Algebra (RatFunc C) F := + intermediateFrobeniusTwistFieldRatFuncAlgebra C S N hExact L g + letI : SMul (RatFunc C) F := Algebra.toSMul + letI : Module (RatFunc C) F := Algebra.toModule + letI : FiniteDimensional (RatFunc C) F := + finiteDimensional_intermediateFrobeniusTwistField_over_ratFunc + C S N hExact L g + letI : Algebra.IsSeparable (RatFunc C) F := + isSeparable_intermediateFrobeniusTwistField_over_ratFunc + C S N hExact L g + letI : Algebra F T := F.toAlgebra + letI : SMul F T := Algebra.toSMul + letI : Module F T := Algebra.toModule + letI : IsScalarTower (RatFunc C) F T := + intermediateFrobeniusTwistField_ratFunc_tower C S N hExact L g + letI : FiniteDimensional F T := + finiteDimensional_exactConstantExtension_over_frobeniusTwistField + C L N S hExact g + letI : IsGalois F T := + isGalois_exactConstantExtension_over_frobeniusTwistField + C L N S hExact g + FiniteExtensionRationalFinitePlace C F ≃ + {Q : FiniteExtensionFinitePlace C T // + finiteExtensionPlaceDegree C T (.inl Q) = Module.finrank C S ∧ + finitePlaceGalSmul C L T + (exactConstantExtensionFrobeniusTwist C L N S hExact g) Q = Q} := by + let T := ExactConstantExtension C N S + letI : Field T := exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) T := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + letI : SMul (RatFunc C) T := Algebra.toSMul + letI : Module (RatFunc C) T := Algebra.toModule + letI : FiniteDimensional (RatFunc C) T := + finiteDimensional_exactConstantExtension_over_baseRatFunc C S N hExact + letI : Algebra.IsSeparable (RatFunc C) T := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + letI : Algebra L T := exactConstantExtensionBaseAlgebra C L N S + letI : SMul L T := Algebra.toSMul + letI : Module L T := Algebra.toModule + letI : IsScalarTower (RatFunc C) L T := + exactConstantExtensionIntermediate_ratFuncBaseTower C S N L + letI : FiniteDimensional L T := + finiteDimensional_exactConstantExtension_over_intermediateBase + C S N L hExact + letI : IsGalois L T := exactConstantExtension_isGalois C L N S hExact + let F := exactConstantExtensionFrobeniusTwistField C L N S hExact g + letI : Algebra L F := SubalgebraClass.toAlgebra F.toSubalgebra + letI : Algebra (RatFunc C) F := + intermediateFrobeniusTwistFieldRatFuncAlgebra C S N hExact L g + letI : SMul L F := Algebra.toSMul + letI : Module L F := Algebra.toModule + letI : IsScalarTower (RatFunc C) L F := + IsScalarTower.of_algebraMap_eq' rfl + letI : SMul (RatFunc C) F := Algebra.toSMul + letI : Module (RatFunc C) F := Algebra.toModule + letI : FiniteDimensional (RatFunc C) F := + finiteDimensional_intermediateFrobeniusTwistField_over_ratFunc + C S N hExact L g + letI : Algebra.IsSeparable (RatFunc C) F := + isSeparable_intermediateFrobeniusTwistField_over_ratFunc + C S N hExact L g + letI : Algebra F T := F.toAlgebra + letI : SMul F T := Algebra.toSMul + letI : Module F T := Algebra.toModule + letI : IsScalarTower (RatFunc C) F T := + intermediateFrobeniusTwistField_ratFunc_tower C S N hExact L g + letI : FiniteDimensional F T := + finiteDimensional_exactConstantExtension_over_frobeniusTwistField + C L N S hExact g + letI : IsGalois F T := + isGalois_exactConstantExtension_over_frobeniusTwistField + C L N S hExact g + have hfinrank : Module.finrank F T = Module.finrank C S := + finrank_exactConstantExtension_over_frobeniusTwistField + C L N S hExact g hdiv + have hdegree : ∀ Q : FiniteExtensionFinitePlace C T, + Module.finrank F T ∣ finiteExtensionPlaceDegree C T (.inl Q) := by + intro Q + rw [hfinrank] + exact exactConstantExtensionFinitePlace_finrank_constants_dvd_degree + C N S hExact Q + let sigmaF := intermediateFrobeniusTwistOverFixedField + C S N hExact L g + let sigmaL := exactConstantExtensionFrobeniusTwist C L N S hExact g + let eFixed := rationalFinitePlaceEquivGeneratorFixedPlace + C F T hdegree sigmaF + (intermediateFrobeniusTwistOverFixedField_zpowers_eq_top + C S N hExact L g) + (intermediateFrobeniusTwistField_finitePlace_ramificationIdx_eq_one + C S N hExact L g hdiv) + let eCompare : + {Q : FiniteExtensionFinitePlace C T // + finiteExtensionPlaceDegree C T (.inl Q) = Module.finrank F T ∧ + finitePlaceGalSmul C F T sigmaF Q = Q} ≃ + {Q : FiniteExtensionFinitePlace C T // + finiteExtensionPlaceDegree C T (.inl Q) = Module.finrank C S ∧ + finitePlaceGalSmul C L T sigmaL Q = Q} := + { toFun := fun Q ↦ ⟨Q.1, Q.2.1.trans hfinrank, + (finitePlaceGalSmul_eq_of_apply_eq C F L T sigmaF sigmaL + (fun x ↦ intermediateFrobeniusTwistOverFixedField_apply + C S N hExact L g x) Q.1).symm.trans Q.2.2⟩ + invFun := fun Q ↦ ⟨Q.1, Q.2.1.trans hfinrank.symm, + (finitePlaceGalSmul_eq_of_apply_eq C F L T sigmaF sigmaL + (fun x ↦ intermediateFrobeniusTwistOverFixedField_apply + C S N hExact L g x) Q.1).trans Q.2.2⟩ + left_inv := fun Q ↦ Subtype.ext rfl + right_inv := fun Q ↦ Subtype.ext rfl } + exact eFixed.trans eCompare + +/-- Restriction through an intermediate Frobenius-twist field agrees with +direct restriction to `L`. -/ +theorem finitePlaceUnder_intermediateFrobeniusTwist_under + (g : N ≃ₐ[L] N) : + let T := ExactConstantExtension C N S + let : Field T := exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) T := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : SMul (RatFunc C) T := Algebra.toSMul + let : Module (RatFunc C) T := Algebra.toModule + let : FiniteDimensional (RatFunc C) T := + finiteDimensional_exactConstantExtension_over_baseRatFunc C S N hExact + let : Algebra.IsSeparable (RatFunc C) T := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + let : Algebra L T := exactConstantExtensionBaseAlgebra C L N S + let : SMul L T := Algebra.toSMul + let : Module L T := Algebra.toModule + let : IsScalarTower (RatFunc C) L T := + exactConstantExtensionIntermediate_ratFuncBaseTower C S N L + let F := exactConstantExtensionFrobeniusTwistField C L N S hExact g + let : Algebra L F := SubalgebraClass.toAlgebra F.toSubalgebra + let : Algebra (RatFunc C) F := + intermediateFrobeniusTwistFieldRatFuncAlgebra C S N hExact L g + let : SMul L F := Algebra.toSMul + let : Module L F := Algebra.toModule + let : IsScalarTower (RatFunc C) L F := + IsScalarTower.of_algebraMap_eq' rfl + let : SMul (RatFunc C) F := Algebra.toSMul + let : Module (RatFunc C) F := Algebra.toModule + let : FiniteDimensional (RatFunc C) F := + finiteDimensional_intermediateFrobeniusTwistField_over_ratFunc + C S N hExact L g + let : Algebra.IsSeparable (RatFunc C) F := + isSeparable_intermediateFrobeniusTwistField_over_ratFunc + C S N hExact L g + let : Algebra F T := F.toAlgebra + let : SMul F T := Algebra.toSMul + let : Module F T := Algebra.toModule + let : IsScalarTower (RatFunc C) F T := + intermediateFrobeniusTwistField_ratFunc_tower C S N hExact L g + ∀ Q : FiniteExtensionFinitePlace C T, + finitePlaceUnder C L F (finitePlaceUnder C F T Q) = + finitePlaceUnder C L T Q := by + intro T model1 model2 model3 model4 model5 model6 model7 model8 model9 model10 F model12 model13 + model14 model15 model16 model17 model18 model19 model20 model21 model22 model23 model24 + let : IsScalarTower L F T := IsScalarTower.of_algebraMap_eq' rfl + exact finitePlaceUnder_trans_of_fields C L F T + +/-- Rational finite places of one intermediate-base twist field are the +disjoint union, over rational finite places of `L`, of fixed top places in +the corresponding restriction fiber. -/ +noncomputable def + intermediateFrobeniusTwistField_rationalFinitePlace_equiv_sigma_fiberFixedBy + (hdiv : Nat.card (N ≃ₐ[L] N) ∣ Module.finrank C S) + (g : N ≃ₐ[L] N) : + let T := ExactConstantExtension C N S + let : Field T := exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) T := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : SMul (RatFunc C) T := Algebra.toSMul + let : Module (RatFunc C) T := Algebra.toModule + let : FiniteDimensional (RatFunc C) T := + finiteDimensional_exactConstantExtension_over_baseRatFunc C S N hExact + let : Algebra.IsSeparable (RatFunc C) T := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + let : Algebra L T := exactConstantExtensionBaseAlgebra C L N S + let : SMul L T := Algebra.toSMul + let : Module L T := Algebra.toModule + let : IsScalarTower (RatFunc C) L T := + exactConstantExtensionIntermediate_ratFuncBaseTower C S N L + let : FiniteDimensional L T := + finiteDimensional_exactConstantExtension_over_intermediateBase + C S N L hExact + let : IsGalois L T := exactConstantExtension_isGalois C L N S hExact + let F := exactConstantExtensionFrobeniusTwistField C L N S hExact g + let : Algebra L F := SubalgebraClass.toAlgebra F.toSubalgebra + let : Algebra (RatFunc C) F := + intermediateFrobeniusTwistFieldRatFuncAlgebra C S N hExact L g + let : SMul L F := Algebra.toSMul + let : Module L F := Algebra.toModule + let : IsScalarTower (RatFunc C) L F := + IsScalarTower.of_algebraMap_eq' rfl + let : SMul (RatFunc C) F := Algebra.toSMul + let : Module (RatFunc C) F := Algebra.toModule + let : FiniteDimensional (RatFunc C) F := + finiteDimensional_intermediateFrobeniusTwistField_over_ratFunc + C S N hExact L g + let : Algebra.IsSeparable (RatFunc C) F := + isSeparable_intermediateFrobeniusTwistField_over_ratFunc + C S N hExact L g + let : Algebra F T := F.toAlgebra + let : SMul F T := Algebra.toSMul + let : Module F T := Algebra.toModule + let : IsScalarTower (RatFunc C) F T := + intermediateFrobeniusTwistField_ratFunc_tower C S N hExact L g + let : FiniteDimensional F T := + finiteDimensional_exactConstantExtension_over_frobeniusTwistField + C L N S hExact g + let : IsGalois F T := + isGalois_exactConstantExtension_over_frobeniusTwistField + C L N S hExact g + FiniteExtensionRationalFinitePlace C F ≃ + Σ P : FiniteExtensionRationalFinitePlace C L, + IntermediateFrobeniusTwistFinitePlaceFiberFixedBy + C S N hExact L g P := by + intro T model1 model2 model3 model4 model5 model6 model7 model8 model9 model10 model11 model12 F + model14 model15 model16 model17 model18 model19 model20 model21 model22 model23 model24 + model25 model26 model27 model28 + let : IsScalarTower L F T := IsScalarTower.of_algebraMap_eq' rfl + have hDegreeDiv : Module.finrank L N ∣ Module.finrank C S := by + rw [← IsGalois.card_aut_eq_finrank] + exact hdiv + have hfinrank : Module.finrank F T = Module.finrank C S := + finrank_exactConstantExtension_over_frobeniusTwistField + C L N S hExact g hdiv + let sigmaF := intermediateFrobeniusTwistOverFixedField + C S N hExact L g + let sigmaL := exactConstantExtensionFrobeniusTwist C L N S hExact g + let AmbientFixed := + {Q : FiniteExtensionFinitePlace C T // + finiteExtensionPlaceDegree C T (.inl Q) = Module.finrank C S ∧ + finitePlaceGalSmul C L T sigmaL Q = Q} + let SigmaFixed := Σ P : FiniteExtensionRationalFinitePlace C L, + IntermediateFrobeniusTwistFinitePlaceFiberFixedBy + C S N hExact L g P + let toAmbient : SigmaFixed → AmbientFixed := fun x ↦ by + let Q := x.2.1.1 + have hBase : finiteExtensionPlaceDegree C L + (.inl (finitePlaceUnder C L T Q)) = 1 := by + rw [x.2.1.2] + exact x.1.2 + refine ⟨Q, + exactConstantExtensionFinitePlace_degree_eq_finrank_of_under_intermediate_rational + C S N hExact L hDegreeDiv Q hBase, ?_⟩ + exact congrArg Subtype.val x.2.2 + have hInjective : Function.Injective toAmbient := by + rintro ⟨P, x⟩ ⟨R, y⟩ hxy + have hQ : x.1.1 = y.1.1 := congrArg Subtype.val hxy + have hBase : P.1 = R.1 := by + calc + P.1 = finitePlaceUnder C L T x.1.1 := x.1.2.symm + _ = finitePlaceUnder C L T y.1.1 := congrArg _ hQ + _ = R.1 := y.1.2 + have hP : P = R := Subtype.ext hBase + subst R + apply Sigma.ext (by rfl) + apply heq_of_eq + apply Subtype.ext + apply Subtype.ext + exact hQ + have hSurjective : Function.Surjective toAmbient := by + intro z + let Q := z.1 + have hfixedF : finitePlaceGalSmul C F T sigmaF Q = Q := + (finitePlaceGalSmul_eq_of_apply_eq C F L T sigmaF sigmaL + (fun x ↦ intermediateFrobeniusTwistOverFixedField_apply + C S N hExact L g x) Q).trans z.2.2 + have hFdegree : finiteExtensionPlaceDegree C F + (.inl (finitePlaceUnder C F T Q)) = 1 := + finitePlaceUnder_degree_eq_one_of_generator_fixed C F T sigmaF + (intermediateFrobeniusTwistOverFixedField_zpowers_eq_top + C S N hExact L g) Q hfixedF + (intermediateFrobeniusTwistField_finitePlace_ramificationIdx_eq_one + C S N hExact L g hdiv Q) + (z.2.1.trans hfinrank.symm) + let R₀ : FiniteExtensionRationalFinitePlace C F := + ⟨finitePlaceUnder C F T Q, hFdegree⟩ + let P : FiniteExtensionRationalFinitePlace C L := + rationalFinitePlaceUnder C L F R₀ + have hFiber : finitePlaceUnder C L T Q = P.1 := by + calc + finitePlaceUnder C L T Q = + finitePlaceUnder C L F (finitePlaceUnder C F T Q) := + (finitePlaceUnder_intermediateFrobeniusTwist_under + C S N hExact L g Q).symm + _ = P.1 := rfl + let xFiber : FinitePlaceUnderFiber C L T P.1 := ⟨Q, hFiber⟩ + let xFixed : IntermediateFrobeniusTwistFinitePlaceFiberFixedBy + C S N hExact L g P := ⟨xFiber, by + apply Subtype.ext + exact z.2.2⟩ + refine ⟨⟨P, xFixed⟩, ?_⟩ + apply Subtype.ext + change Q = z.1 + rfl + let eSigma : SigmaFixed ≃ AmbientFixed := + Equiv.ofBijective toAmbient ⟨hInjective, hSurjective⟩ + exact + (intermediateFrobeniusTwistField_rationalFinitePlace_equiv_ambientFixedFinitePlace + C S N hExact L g hdiv).trans eSigma.symm + +/-- The rational finite-place count of one intermediate-base Frobenius-twist +field, with its rational-function algebra fixed explicitly. -/ +noncomputable def intermediateFrobeniusTwistFieldRationalFinitePlaceCount + (g : N ≃ₐ[L] N) : ℕ := + let T := ExactConstantExtension C N S + letI : Field T := exactConstantExtensionField C N S hExact + letI : Algebra L T := exactConstantExtensionBaseAlgebra C L N S + let F := exactConstantExtensionFrobeniusTwistField C L N S hExact g + letI : Algebra L F := SubalgebraClass.toAlgebra F.toSubalgebra + letI : Algebra (RatFunc C) F := + intermediateFrobeniusTwistFieldRatFuncAlgebra C S N hExact L g + letI : SMul (RatFunc C) F := Algebra.toSMul + letI : Module (RatFunc C) F := Algebra.toModule + letI : FiniteDimensional (RatFunc C) F := + finiteDimensional_intermediateFrobeniusTwistField_over_ratFunc + C S N hExact L g + letI : Algebra.IsSeparable (RatFunc C) F := + isSeparable_intermediateFrobeniusTwistField_over_ratFunc + C S N hExact L g + Nat.card (FiniteExtensionRationalFinitePlace C F) + +/-- For one twist, rational finite places split as the finite sum of fixed +restriction fibers above the rational finite places of `L`. -/ +theorem intermediateFrobeniusTwistFieldRationalFinitePlaceCount_eq_sum_fiberFixedBy + (hdiv : Nat.card (N ≃ₐ[L] N) ∣ Module.finrank C S) + (g : N ≃ₐ[L] N) : + intermediateFrobeniusTwistFieldRationalFinitePlaceCount + C S N hExact L g = + ∑ P : FiniteExtensionRationalFinitePlace C L, + Nat.card (IntermediateFrobeniusTwistFinitePlaceFiberFixedBy + C S N hExact L g P) := by + let T := ExactConstantExtension C N S + let : Field T := exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) T := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : SMul (RatFunc C) T := Algebra.toSMul + let : Module (RatFunc C) T := Algebra.toModule + let : FiniteDimensional (RatFunc C) T := + finiteDimensional_exactConstantExtension_over_baseRatFunc C S N hExact + let : Algebra.IsSeparable (RatFunc C) T := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + let : Algebra L T := exactConstantExtensionBaseAlgebra C L N S + let : SMul L T := Algebra.toSMul + let : Module L T := Algebra.toModule + let : IsScalarTower (RatFunc C) L T := + exactConstantExtensionIntermediate_ratFuncBaseTower C S N L + let : FiniteDimensional L T := + finiteDimensional_exactConstantExtension_over_intermediateBase + C S N L hExact + let : IsGalois L T := exactConstantExtension_isGalois C L N S hExact + let F := exactConstantExtensionFrobeniusTwistField C L N S hExact g + let : Algebra L F := SubalgebraClass.toAlgebra F.toSubalgebra + let : Algebra (RatFunc C) F := + intermediateFrobeniusTwistFieldRatFuncAlgebra C S N hExact L g + let : SMul (RatFunc C) F := Algebra.toSMul + let : Module (RatFunc C) F := Algebra.toModule + let : FiniteDimensional (RatFunc C) F := + finiteDimensional_intermediateFrobeniusTwistField_over_ratFunc + C S N hExact L g + let : Algebra.IsSeparable (RatFunc C) F := + isSeparable_intermediateFrobeniusTwistField_over_ratFunc + C S N hExact L g + let : Algebra F T := F.toAlgebra + let : SMul F T := Algebra.toSMul + let : Module F T := Algebra.toModule + let : IsScalarTower (RatFunc C) F T := + intermediateFrobeniusTwistField_ratFunc_tower C S N hExact L g + let : FiniteDimensional F T := + finiteDimensional_exactConstantExtension_over_frobeniusTwistField + C L N S hExact g + let : IsGalois F T := + isGalois_exactConstantExtension_over_frobeniusTwistField + C L N S hExact g + change Nat.card (FiniteExtensionRationalFinitePlace C F) = _ + rw [Nat.card_congr + (intermediateFrobeniusTwistField_rationalFinitePlace_equiv_sigma_fiberFixedBy + C S N hExact L hdiv g), Nat.card_sigma] + +/-- Summed over all intermediate-base Frobenius twists, the rational finite +place count is exactly `|Gal(N/L)|` times the rational finite-place count of +`L`. -/ +theorem sum_intermediateFrobeniusTwistFieldRationalFinitePlaceCount_eq_card_galois_mul_card + (hdiv : Nat.card (N ≃ₐ[L] N) ∣ Module.finrank C S) : + (∑ g : N ≃ₐ[L] N, + intermediateFrobeniusTwistFieldRationalFinitePlaceCount + C S N hExact L g) = + Nat.card (N ≃ₐ[L] N) * + Nat.card (FiniteExtensionRationalFinitePlace C L) := by + have hDegreeDiv : Module.finrank L N ∣ Module.finrank C S := by + rw [← IsGalois.card_aut_eq_finrank] + exact hdiv + calc + (∑ g : N ≃ₐ[L] N, + intermediateFrobeniusTwistFieldRationalFinitePlaceCount + C S N hExact L g) = + ∑ g : N ≃ₐ[L] N, + ∑ P : FiniteExtensionRationalFinitePlace C L, + Nat.card (IntermediateFrobeniusTwistFinitePlaceFiberFixedBy + C S N hExact L g P) := by + apply Finset.sum_congr rfl + intro g _ + exact + intermediateFrobeniusTwistFieldRationalFinitePlaceCount_eq_sum_fiberFixedBy + C S N hExact L hdiv g + _ = ∑ P : FiniteExtensionRationalFinitePlace C L, + ∑ g : N ≃ₐ[L] N, + Nat.card (IntermediateFrobeniusTwistFinitePlaceFiberFixedBy + C S N hExact L g P) := by + rw [Finset.sum_comm] + _ = ∑ _P : FiniteExtensionRationalFinitePlace C L, + Nat.card (N ≃ₐ[L] N) := by + apply Finset.sum_congr rfl + intro P _ + exact + sum_card_finitePlaceUnderFiber_fixedBy_intermediateFrobeniusTwist_eq_card_galois + C S N hExact L hDegreeDiv P + _ = Nat.card (FiniteExtensionRationalFinitePlace C L) * + Nat.card (N ≃ₐ[L] N) := by + simp [Nat.card_eq_fintype_card] + _ = Nat.card (N ≃ₐ[L] N) * + Nat.card (FiniteExtensionRationalFinitePlace C L) := Nat.mul_comm _ _ + +omit [Finite S] [DecidableEq C] [DecidableEq S] [DecidableEq (RatFunc C)] + [DecidableEq (RatFunc S)] [FiniteDimensional (RatFunc C) N] + [Algebra.IsSeparable (RatFunc C) N] [FiniteDimensional (RatFunc C) L] + [Algebra.IsSeparable (RatFunc C) L] [FiniteDimensional L N] [IsGalois L N] in +/-- Viewing an intermediate-base Frobenius twist over `C(X)` does not change +its underlying automorphism of the exact constant extension. -/ +theorem exactConstantExtensionFrobeniusTwist_restrictScalars_apply + (g : N ≃ₐ[L] N) (x : ExactConstantExtension C N S) : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + letI : Algebra L (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C L N S + exactConstantExtensionFrobeniusTwist C (RatFunc C) N S hExact + (g.restrictScalars (RatFunc C)) x = + exactConstantExtensionFrobeniusTwist C L N S hExact g x := by + let : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : SMul (RatFunc C) (ExactConstantExtension C N S) := Algebra.toSMul + let : Module (RatFunc C) (ExactConstantExtension C N S) := Algebra.toModule + let : Algebra L (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C L N S + let : SMul L (ExactConstantExtension C N S) := Algebra.toSMul + let : Module L (ExactConstantExtension C N S) := Algebra.toModule + induction x using TensorProduct.inductionOn with + | tmul s n => + simp [exactConstantExtensionFrobeniusTwist, + exactConstantExtensionCombinedAutHom, + exactConstantExtensionConstantAutHom, + exactConstantExtensionFunctionAutHom, + exactConstantExtensionConstantAlgEquivOverBase, + exactConstantExtensionFunctionAlgEquivOverBase] + | add x y hx hy => simp [hx, hy] + +omit [Finite S] [DecidableEq C] [DecidableEq S] [DecidableEq (RatFunc C)] + [DecidableEq (RatFunc S)] [FiniteDimensional (RatFunc C) N] + [Algebra.IsSeparable (RatFunc C) N] [FiniteDimensional (RatFunc C) L] + [Algebra.IsSeparable (RatFunc C) L] [FiniteDimensional L N] [IsGalois L N] in +/-- Equality of the two twists as `C(X)`-automorphisms. -/ +theorem exactConstantExtensionFrobeniusTwist_restrictScalars + (g : N ≃ₐ[L] N) : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + letI : Algebra L (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C L N S + letI : SMul (RatFunc C) (ExactConstantExtension C N S) := Algebra.toSMul + letI : Module (RatFunc C) (ExactConstantExtension C N S) := Algebra.toModule + letI : SMul L (ExactConstantExtension C N S) := Algebra.toSMul + letI : Module L (ExactConstantExtension C N S) := Algebra.toModule + letI : IsScalarTower (RatFunc C) L (ExactConstantExtension C N S) := + exactConstantExtensionIntermediate_ratFuncBaseTower C S N L + (exactConstantExtensionFrobeniusTwist C L N S hExact g).restrictScalars + (RatFunc C) = + exactConstantExtensionFrobeniusTwist C (RatFunc C) N S hExact + (g.restrictScalars (RatFunc C)) := by + let : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : Algebra L (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C L N S + let : SMul (RatFunc C) (ExactConstantExtension C N S) := Algebra.toSMul + let : Module (RatFunc C) (ExactConstantExtension C N S) := Algebra.toModule + let : SMul L (ExactConstantExtension C N S) := Algebra.toSMul + let : Module L (ExactConstantExtension C N S) := Algebra.toModule + let : IsScalarTower (RatFunc C) L (ExactConstantExtension C N S) := + exactConstantExtensionIntermediate_ratFuncBaseTower C S N L + ext x + exact (exactConstantExtensionFrobeniusTwist_restrictScalars_apply + C S N hExact L g x).symm + +/-- The fixed field constructed over `L` is the same function field as the +rational-base twist attached to `g.restrictScalars C(X)`. -/ +noncomputable def + intermediateFrobeniusTwistField_algEquiv_rationalBaseFrobeniusTwistField + (g : N ≃ₐ[L] N) : + let T := ExactConstantExtension C N S + letI : Field T := exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) T := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + letI : SMul (RatFunc C) T := Algebra.toSMul + letI : Module (RatFunc C) T := Algebra.toModule + letI : Algebra L T := exactConstantExtensionBaseAlgebra C L N S + letI : SMul L T := Algebra.toSMul + letI : Module L T := Algebra.toModule + letI : IsScalarTower (RatFunc C) L T := + exactConstantExtensionIntermediate_ratFuncBaseTower C S N L + let Fₗ := exactConstantExtensionFrobeniusTwistField C L N S hExact g + let Fᵣ := exactConstantExtensionFrobeniusTwistField + C (RatFunc C) N S hExact (g.restrictScalars (RatFunc C)) + letI : Algebra L Fₗ := SubalgebraClass.toAlgebra Fₗ.toSubalgebra + letI : Algebra (RatFunc C) Fₗ := + intermediateFrobeniusTwistFieldRatFuncAlgebra C S N hExact L g + letI : Algebra (RatFunc C) Fᵣ := + SubalgebraClass.toAlgebra Fᵣ.toSubalgebra + Fₗ ≃ₐ[RatFunc C] Fᵣ := by + let T := ExactConstantExtension C N S + letI : Field T := exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) T := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + letI : SMul (RatFunc C) T := Algebra.toSMul + letI : Module (RatFunc C) T := Algebra.toModule + letI : Algebra L T := exactConstantExtensionBaseAlgebra C L N S + letI : SMul L T := Algebra.toSMul + letI : Module L T := Algebra.toModule + letI : IsScalarTower (RatFunc C) L T := + exactConstantExtensionIntermediate_ratFuncBaseTower C S N L + let sigmaₗ := exactConstantExtensionFrobeniusTwist C L N S hExact g + let sigmaᵣ := exactConstantExtensionFrobeniusTwist + C (RatFunc C) N S hExact (g.restrictScalars (RatFunc C)) + let Fₗ := exactConstantExtensionFrobeniusTwistField C L N S hExact g + let Fᵣ := exactConstantExtensionFrobeniusTwistField + C (RatFunc C) N S hExact (g.restrictScalars (RatFunc C)) + letI : Algebra L Fₗ := SubalgebraClass.toAlgebra Fₗ.toSubalgebra + letI : Algebra (RatFunc C) Fₗ := + intermediateFrobeniusTwistFieldRatFuncAlgebra C S N hExact L g + letI : Algebra (RatFunc C) Fᵣ := + SubalgebraClass.toAlgebra Fᵣ.toSubalgebra + have hsigma : sigmaₗ.restrictScalars (RatFunc C) = sigmaᵣ := + exactConstantExtensionFrobeniusTwist_restrictScalars + C S N hExact L g + have hto (x : Fₗ) : (x.1 : T) ∈ Fᵣ := by + change x.1 ∈ IntermediateField.fixedField (Subgroup.zpowers sigmaᵣ) + rw [IntermediateField.mem_fixedField_iff] + intro tau htau + obtain ⟨k, hk⟩ := Subgroup.mem_zpowers_iff.mp htau + have hxmem : x.1 ∈ + IntermediateField.fixedField (Subgroup.zpowers sigmaₗ) := x.2 + rw [IntermediateField.mem_fixedField_iff] at hxmem + have hx := hxmem (sigmaₗ ^ k) + (Subgroup.mem_zpowers_iff.mpr ⟨k, rfl⟩) + calc + tau x.1 = (sigmaᵣ ^ k) x.1 := congrArg (fun a ↦ a x.1) hk.symm + _ = ((sigmaₗ.restrictScalars (RatFunc C)) ^ k) x.1 := by rw [hsigma] + _ = ((sigmaₗ ^ k).restrictScalars (RatFunc C)) x.1 := by + exact congrArg (fun a ↦ a x.1) + (map_zpow (AlgEquiv.restrictScalarsHom (RatFunc C)) sigmaₗ k).symm + _ = (sigmaₗ ^ k) x.1 := rfl + _ = x.1 := hx + have hfrom (x : Fᵣ) : (x.1 : T) ∈ Fₗ := by + change x.1 ∈ IntermediateField.fixedField (Subgroup.zpowers sigmaₗ) + rw [IntermediateField.mem_fixedField_iff] + intro tau htau + obtain ⟨k, hk⟩ := Subgroup.mem_zpowers_iff.mp htau + have hxmem : x.1 ∈ + IntermediateField.fixedField (Subgroup.zpowers sigmaᵣ) := x.2 + rw [IntermediateField.mem_fixedField_iff] at hxmem + have hx := hxmem (sigmaᵣ ^ k) + (Subgroup.mem_zpowers_iff.mpr ⟨k, rfl⟩) + calc + tau x.1 = (sigmaₗ ^ k) x.1 := congrArg (fun a ↦ a x.1) hk.symm + _ = ((sigmaₗ ^ k).restrictScalars (RatFunc C)) x.1 := rfl + _ = ((sigmaₗ.restrictScalars (RatFunc C)) ^ k) x.1 := by + exact congrArg (fun a ↦ a x.1) + (map_zpow (AlgEquiv.restrictScalarsHom (RatFunc C)) sigmaₗ k) + _ = (sigmaᵣ ^ k) x.1 := by rw [hsigma] + _ = x.1 := hx + exact + { toFun := fun x ↦ ⟨x.1, hto x⟩ + invFun := fun x ↦ ⟨x.1, hfrom x⟩ + left_inv := fun x ↦ Subtype.ext rfl + right_inv := fun x ↦ Subtype.ext rfl + map_mul' := fun _ _ ↦ Subtype.ext rfl + map_add' := fun _ _ ↦ Subtype.ext rfl + commutes' := fun r ↦ by + apply Subtype.ext + change algebraMap L T (algebraMap (RatFunc C) L r) = + algebraMap (RatFunc C) T r + exact (IsScalarTower.algebraMap_apply (RatFunc C) L T r).symm } + +end IntermediateBase + +end + + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionIntermediateFrobeniusTwistHasseBound.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionIntermediateFrobeniusTwistHasseBound.lean new file mode 100644 index 0000000000..118fca244f --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionIntermediateFrobeniusTwistHasseBound.lean @@ -0,0 +1,338 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionIntermediateFrobeniusTwistRationalPlaceAverage +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionFrobeniusTwistStepanovUpper +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionPlaceAlgEquiv +public import LeanPool.MarkoffModP.BGS.HasseWeil.GaloisTowerFactorialDegree + +/-! +# A fixed-tower Hasse bound from intermediate Frobenius twists + +The complete intermediate-base twist average is combined with the uniform +square-field Stepanov estimate for the corresponding rational-base twists. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +noncomputable section + +open BGS.CorvajaZannier +open scoped BigOperators + + +variable (K C S N : Type*) + [Field K] [Fintype K] + [Field C] [Fintype C] [DecidableEq C] [Algebra K C] + [Field S] [Finite S] [DecidableEq S] + [DecidableEq (RatFunc C)] [DecidableEq (RatFunc S)] + [Field N] [Algebra (RatFunc C) N] + [FiniteDimensional (RatFunc C) N] [IsGalois (RatFunc C) N] + [Algebra C S] [FiniteDimensional C S] [IsGalois C S] + +local instance intermediateHasseBaseConstantAlgebra : Algebra C N := + bridgeBaseConstantAlgebra C N + +local instance intermediateHasseBaseConstantTower : + IsScalarTower C (RatFunc C) N := + IsScalarTower.of_algebraMap_eq' rfl + +variable (hExact : algebraicClosure C N = (⊥ : IntermediateField C N)) + +section IntermediateBase + +variable (L : Type*) [Field L] + [Algebra (RatFunc C) L] [FiniteDimensional (RatFunc C) L] + [Algebra.IsSeparable (RatFunc C) L] + [Algebra L N] [IsScalarTower (RatFunc C) L N] + [FiniteDimensional L N] [IsGalois L N] + +local instance intermediateHasseConstantAlgebra : Algebra C L := + RingHom.toAlgebra ((algebraMap (RatFunc C) L).comp + (algebraMap C (RatFunc C))) + +local instance intermediateHasseConstantTower : IsScalarTower C L N := by + apply IsScalarTower.of_algebraMap_eq' + ext c + change algebraMap (RatFunc C) N (algebraMap C (RatFunc C) c) = + algebraMap L N (algebraMap (RatFunc C) L (algebraMap C (RatFunc C) c)) + exact IsScalarTower.algebraMap_apply (RatFunc C) L N _ + +omit [Fintype C] [DecidableEq C] [Finite S] [DecidableEq S] [DecidableEq (RatFunc C)] + [DecidableEq (RatFunc S)] [FiniteDimensional (RatFunc C) N] [IsGalois (RatFunc C) N] + [FiniteDimensional C S] [IsGalois C S] [FiniteDimensional (RatFunc C) L] + [Algebra.IsSeparable (RatFunc C) L] [FiniteDimensional L N] [IsGalois L N] in +private theorem intermediateHasseRatFuncBaseTower : + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + letI : SMul (RatFunc C) (ExactConstantExtension C N S) := Algebra.toSMul + letI : Module (RatFunc C) (ExactConstantExtension C N S) := Algebra.toModule + letI : Algebra L (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C L N S + letI : SMul L (ExactConstantExtension C N S) := Algebra.toSMul + letI : Module L (ExactConstantExtension C N S) := Algebra.toModule + IsScalarTower (RatFunc C) L (ExactConstantExtension C N S) := by + let T := ExactConstantExtension C N S + let : Algebra (RatFunc C) T := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : SMul (RatFunc C) T := Algebra.toSMul + let : Module (RatFunc C) T := Algebra.toModule + let : Algebra L T := exactConstantExtensionBaseAlgebra C L N S + let : Algebra N T := exactConstantExtensionAlgebra C N S + let : SMul L T := Algebra.toSMul + let : Module L T := Algebra.toModule + apply IsScalarTower.of_algebraMap_eq' + ext x + change (1 : S) ⊗ₜ algebraMap (RatFunc C) N x = + (1 : S) ⊗ₜ algebraMap L N (algebraMap (RatFunc C) L x) + congr 1 + exact IsScalarTower.algebraMap_apply (RatFunc C) L N x + +/-- The complete point count of an intermediate-base twist agrees with that +of its rational-base incarnation. -/ +theorem intermediateFrobeniusTwistFieldRationalPlaceCount_eq_rationalBase + (g : N ≃ₐ[L] N) : + intermediateFrobeniusTwistFieldRationalPlaceCount C S N hExact L g = + frobeniusTwistFieldRationalPlaceCount C S N hExact + (g.restrictScalars (RatFunc C)) := by + let T := ExactConstantExtension C N S + let : Field T := exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) T := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : SMul (RatFunc C) T := Algebra.toSMul + let : Module (RatFunc C) T := Algebra.toModule + let : Algebra L T := exactConstantExtensionBaseAlgebra C L N S + let : SMul L T := Algebra.toSMul + let : Module L T := Algebra.toModule + let : IsScalarTower (RatFunc C) L T := + intermediateHasseRatFuncBaseTower C S N L + let Fₗ := exactConstantExtensionFrobeniusTwistField C L N S hExact g + let Fᵣ := exactConstantExtensionFrobeniusTwistField + C (RatFunc C) N S hExact (g.restrictScalars (RatFunc C)) + let : Algebra L Fₗ := SubalgebraClass.toAlgebra Fₗ.toSubalgebra + let : SMul L Fₗ := Algebra.toSMul + let : Module L Fₗ := Algebra.toModule + let : Algebra (RatFunc C) Fₗ := + intermediateFrobeniusTwistFieldRatFuncAlgebra C S N hExact L g + let : SMul (RatFunc C) Fₗ := Algebra.toSMul + let : Module (RatFunc C) Fₗ := Algebra.toModule + let : FiniteDimensional (RatFunc C) Fₗ := + finiteDimensional_intermediateFrobeniusTwistField_over_ratFunc + C S N hExact L g + let : Algebra.IsSeparable (RatFunc C) Fₗ := + isSeparable_intermediateFrobeniusTwistField_over_ratFunc + C S N hExact L g + let : Algebra (RatFunc C) Fᵣ := SubalgebraClass.toAlgebra Fᵣ.toSubalgebra + let : SMul (RatFunc C) Fᵣ := Algebra.toSMul + let : Module (RatFunc C) Fᵣ := Algebra.toModule + let e := + intermediateFrobeniusTwistField_algEquiv_rationalBaseFrobeniusTwistField + C S N hExact L g + let : FiniteDimensional (RatFunc C) Fᵣ := + Module.Finite.equiv (e.toLinearEquiv : Fₗ ≃ₗ[RatFunc C] Fᵣ) + let : Algebra.IsSeparable (RatFunc C) Fᵣ := + isSeparable_frobeniusTwistField_over_ratFunc + C N S hExact (g.restrictScalars (RatFunc C)) + calc + intermediateFrobeniusTwistFieldRationalPlaceCount C S N hExact L g = + finiteExtensionRationalPlaceCount C Fₗ := + intermediateFrobeniusTwistFieldRationalPlaceCount_eq_finiteExtensionRationalPlaceCount + C S N hExact L g + _ = finiteExtensionRationalPlaceCount C Fᵣ := + finiteExtensionRationalPlaceCount_eq_of_algEquiv C Fₗ Fᵣ e + _ = frobeniusTwistFieldRationalPlaceCount C S N hExact + (g.restrictScalars (RatFunc C)) := + (frobeniusTwistFieldRationalPlaceCount_eq_finiteExtensionRationalPlaceCount + C S N hExact (g.restrictScalars (RatFunc C))).symm + +/-- The complete twist average and the pointwise Stepanov estimate give a +two-sided rational-place bound for the fixed intermediate field. -/ +theorem abs_intermediateBaseRationalPlaceError_le_squareField_of_genus_exact + (hcard : Fintype.card C = (Fintype.card K) ^ 2) + (hExact : algebraicClosure C N = (⊥ : IntermediateField C N)) + (hdivL : Nat.card (N ≃ₐ[L] N) ∣ Module.finrank C S) + (hdivBase : Nat.card (N ≃ₐ[RatFunc C] N) ∣ Module.finrank C S) + (hlarge : (FunctionField.genus C N + 1) * + (FunctionField.genus C N + 2) ≤ Fintype.card K) : + |(finiteExtensionRationalPlaceCount C L : ℝ) - + (Nat.card C : ℝ) - 1| ≤ + 2 * (Module.finrank (RatFunc C) N : ℝ) ^ 2 + + (Nat.card (N ≃ₐ[L] N) : ℝ) * + ((Nat.card (N ≃ₐ[RatFunc C] N) : ℝ) * + Module.finrank (RatFunc C) N + + (Nat.card (N ≃ₐ[RatFunc C] N) - 1 : ℕ) * + (((2 * FunctionField.genus C N + 1) * Fintype.card K + + Module.finrank (RatFunc C) N : ℕ) : ℝ)) := by + let : DecidableEq (N ≃ₐ[L] N) := Classical.decEq _ + let A : ℝ := 2 * (Module.finrank (RatFunc C) N : ℝ) ^ 2 + let B : ℝ := + (Nat.card (N ≃ₐ[RatFunc C] N) : ℝ) * + Module.finrank (RatFunc C) N + + (Nat.card (N ≃ₐ[RatFunc C] N) - 1 : ℕ) * + (((2 * FunctionField.genus C N + 1) * Fintype.card K + + Module.finrank (RatFunc C) N : ℕ) : ℝ) + have haverage : + |∑ g : N ≃ₐ[L] N, + (intermediateFrobeniusTwistFieldRationalPlaceCount + C S N hExact L g : ℝ) - + (Fintype.card (N ≃ₐ[L] N) : ℝ) * + finiteExtensionRationalPlaceCount C L| ≤ A := by + simpa only [A, Nat.card_eq_fintype_card] using + abs_sum_intermediateFrobeniusTwistFieldRationalPlaceCount_sub_card_mul_base_le + C S N hExact L hdivL + have hpointwise : ∀ g : N ≃ₐ[L] N, + |(intermediateFrobeniusTwistFieldRationalPlaceCount + C S N hExact L g : ℝ) - ((Nat.card C : ℝ) + 1)| ≤ B := by + intro g + rw [intermediateFrobeniusTwistFieldRationalPlaceCount_eq_rationalBase + C S N hExact L g] + have h := + abs_frobeniusTwistFieldRationalPlaceError_le_squareField_of_genus + K C N S hcard hExact hdivBase hlarge + (g.restrictScalars (RatFunc C)) + dsimp only [B] + have hcenter : + (frobeniusTwistFieldRationalPlaceCount C S N hExact + (g.restrictScalars (RatFunc C)) : ℝ) - + ((Nat.card C : ℝ) + 1) = + (frobeniusTwistFieldRationalPlaceCount C S N hExact + (g.restrictScalars (RatFunc C)) : ℝ) - + (Nat.card C : ℝ) - 1 := by + ring + rw [hcenter] + exact h + have hbound := abs_base_sub_center_le_of_average_and_pointwise + (x := fun g : N ≃ₐ[L] N ↦ + (intermediateFrobeniusTwistFieldRationalPlaceCount + C S N hExact L g : ℝ)) + (base := (finiteExtensionRationalPlaceCount C L : ℝ)) + (center := (Nat.card C : ℝ) + 1) (A := A) (B := B) + (by dsimp only [A]; positivity) (by dsimp only [B]; positivity) + haverage hpointwise + dsimp only [A, B] at hbound ⊢ + have hcardGal : Nat.card (N ≃ₐ[L] N) = + Fintype.card (N ≃ₐ[L] N) := Nat.card_eq_fintype_card + rw [← hcardGal] at hbound + have hcenter : + (finiteExtensionRationalPlaceCount C L : ℝ) - + ((Nat.card C : ℝ) + 1) = + (finiteExtensionRationalPlaceCount C L : ℝ) - + (Nat.card C : ℝ) - 1 := by + ring + rw [hcenter] at hbound + exact hbound + +/-- A degree-only version of the fixed-tower estimate. Both Galois-group +orders in the exact bound are at most the degree of the top field over +`C(X)`; this deliberately looser polynomial bound is the form used by the +normal-closure argument. -/ +theorem abs_intermediateBaseRationalPlaceError_le_squareField_of_genus + (hcard : Fintype.card C = (Fintype.card K) ^ 2) + (hExact : algebraicClosure C N = (⊥ : IntermediateField C N)) + (hdivL : Nat.card (N ≃ₐ[L] N) ∣ Module.finrank C S) + (hdivBase : Nat.card (N ≃ₐ[RatFunc C] N) ∣ Module.finrank C S) + (hlarge : (FunctionField.genus C N + 1) * + (FunctionField.genus C N + 2) ≤ Fintype.card K) : + |(finiteExtensionRationalPlaceCount C L : ℝ) - + (Nat.card C : ℝ) - 1| ≤ + 2 * (Module.finrank (RatFunc C) N : ℝ) ^ 2 + + 2 * (Module.finrank (RatFunc C) N : ℝ) ^ 3 + + (Module.finrank (RatFunc C) N : ℝ) ^ 2 * + (((2 * FunctionField.genus C N + 1) * Fintype.card K : ℕ) : ℝ) := by + have hbound := + abs_intermediateBaseRationalPlaceError_le_squareField_of_genus_exact + K C S N L hcard hExact hdivL hdivBase hlarge + have hL : + (Nat.card (N ≃ₐ[L] N) : ℝ) ≤ + (Module.finrank (RatFunc C) N : ℝ) := by + exact_mod_cast natCard_aut_le_finrank_of_tower (RatFunc C) L N + have hD : + (1 : ℝ) ≤ (Module.finrank (RatFunc C) N : ℝ) := by + exact_mod_cast Module.finrank_pos (R := RatFunc C) (M := N) + rw [IsGalois.card_aut_eq_finrank (RatFunc C) N] at hbound + have hsub : + ((Module.finrank (RatFunc C) N - 1 : ℕ) : ℝ) ≤ + (Module.finrank (RatFunc C) N : ℝ) := by + exact_mod_cast Nat.sub_le (Module.finrank (RatFunc C) N) 1 + have hsum : + (((2 * FunctionField.genus C N + 1) * Fintype.card K + + Module.finrank (RatFunc C) N : ℕ) : ℝ) = + (((2 * FunctionField.genus C N + 1) * Fintype.card K : ℕ) : ℝ) + + (Module.finrank (RatFunc C) N : ℝ) := by + norm_num + have hinnerNonneg : + 0 ≤ + (Module.finrank (RatFunc C) N : ℝ) * + Module.finrank (RatFunc C) N + + ((Module.finrank (RatFunc C) N - 1 : ℕ) : ℝ) * + (((2 * FunctionField.genus C N + 1) * Fintype.card K + + Module.finrank (RatFunc C) N : ℕ) : ℝ) := by + positivity + have hsumNonneg : + 0 ≤ + (((2 * FunctionField.genus C N + 1) * Fintype.card K : ℕ) : ℝ) + + (Module.finrank (RatFunc C) N : ℝ) := + add_nonneg (Nat.cast_nonneg _) (Nat.cast_nonneg _) + have hinner : + (Module.finrank (RatFunc C) N : ℝ) * + Module.finrank (RatFunc C) N + + ((Module.finrank (RatFunc C) N - 1 : ℕ) : ℝ) * + (((2 * FunctionField.genus C N + 1) * Fintype.card K + + Module.finrank (RatFunc C) N : ℕ) : ℝ) ≤ + (Module.finrank (RatFunc C) N : ℝ) * + Module.finrank (RatFunc C) N + + (Module.finrank (RatFunc C) N : ℝ) * + ((((2 * FunctionField.genus C N + 1) * Fintype.card K : ℕ) : ℝ) + + Module.finrank (RatFunc C) N) := by + rw [hsum] + exact add_le_add_right + (mul_le_mul_of_nonneg_right hsub hsumNonneg) _ + have houter : + (Nat.card (N ≃ₐ[L] N) : ℝ) * + ((Module.finrank (RatFunc C) N : ℝ) * + Module.finrank (RatFunc C) N + + ((Module.finrank (RatFunc C) N - 1 : ℕ) : ℝ) * + (((2 * FunctionField.genus C N + 1) * Fintype.card K + + Module.finrank (RatFunc C) N : ℕ) : ℝ)) ≤ + 2 * (Module.finrank (RatFunc C) N : ℝ) ^ 3 + + (Module.finrank (RatFunc C) N : ℝ) ^ 2 * + (((2 * FunctionField.genus C N + 1) * Fintype.card K : ℕ) : ℝ) := by + calc + (Nat.card (N ≃ₐ[L] N) : ℝ) * + ((Module.finrank (RatFunc C) N : ℝ) * + Module.finrank (RatFunc C) N + + ((Module.finrank (RatFunc C) N - 1 : ℕ) : ℝ) * + (((2 * FunctionField.genus C N + 1) * Fintype.card K + + Module.finrank (RatFunc C) N : ℕ) : ℝ)) ≤ + (Module.finrank (RatFunc C) N : ℝ) * + ((Module.finrank (RatFunc C) N : ℝ) * + Module.finrank (RatFunc C) N + + ((Module.finrank (RatFunc C) N - 1 : ℕ) : ℝ) * + (((2 * FunctionField.genus C N + 1) * Fintype.card K + + Module.finrank (RatFunc C) N : ℕ) : ℝ)) := + mul_le_mul_of_nonneg_right hL hinnerNonneg + _ ≤ (Module.finrank (RatFunc C) N : ℝ) * + ((Module.finrank (RatFunc C) N : ℝ) * + Module.finrank (RatFunc C) N + + (Module.finrank (RatFunc C) N : ℝ) * + ((((2 * FunctionField.genus C N + 1) * Fintype.card K : ℕ) : ℝ) + + Module.finrank (RatFunc C) N)) := + mul_le_mul_of_nonneg_left hinner (by positivity) + _ = 2 * (Module.finrank (RatFunc C) N : ℝ) ^ 3 + + (Module.finrank (RatFunc C) N : ℝ) ^ 2 * + (((2 * FunctionField.genus C N + 1) * Fintype.card K : ℕ) : ℝ) := by + ring + nlinarith + +end IntermediateBase + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionIntermediateFrobeniusTwistRationalPlaceAverage.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionIntermediateFrobeniusTwistRationalPlaceAverage.lean new file mode 100644 index 0000000000..1a1dbe1d72 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionIntermediateFrobeniusTwistRationalPlaceAverage.lean @@ -0,0 +1,341 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionIntermediateFrobeniusTwistFinitePlaceAverage +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionFrobeniusTwistRationalPlaceAverage + +/-! +# Complete rational-place averaging over an intermediate base + +The finite-place average over `Gal(N/L)` is exact. Complete rational-place +counts differ from it only at infinity, and both the twists and `L` have at +most the original degree `[N : C(X)]` rational infinity places. This gives a +uniform aggregate error independent of the auxiliary constant extension. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +private theorem finrank_mul_finrank_of_fields + (K F E : Type*) [Field K] [Field F] [Field E] + [Algebra K F] [Algebra K E] [Algebra F E] [IsScalarTower K F E] : + Module.finrank K F * Module.finrank F E = Module.finrank K E := + Module.finrank_mul_finrank K F E + +noncomputable section + +open BGS.CorvajaZannier +open scoped BigOperators + + +variable (C S N : Type*) [Field C] [Field S] [Field N] + [Fintype C] [Finite S] + [DecidableEq C] [DecidableEq S] + [DecidableEq (RatFunc C)] [DecidableEq (RatFunc S)] + [Algebra (RatFunc C) N] [FiniteDimensional (RatFunc C) N] + [IsGalois (RatFunc C) N] + [Algebra C S] [FiniteDimensional C S] [IsGalois C S] + +local instance intermediateRationalAverageBaseConstantAlgebra : Algebra C N := + bridgeBaseConstantAlgebra C N + +local instance intermediateRationalAverageBaseConstantTower : + IsScalarTower C (RatFunc C) N := + IsScalarTower.of_algebraMap_eq' rfl + +variable (hExact : algebraicClosure C N = (⊥ : IntermediateField C N)) + +section IntermediateBase + +variable (L : Type*) [Field L] + [Algebra (RatFunc C) L] [FiniteDimensional (RatFunc C) L] + [Algebra.IsSeparable (RatFunc C) L] + [Algebra L N] [IsScalarTower (RatFunc C) L N] + [FiniteDimensional L N] [IsGalois L N] + +local instance intermediateRationalAverageConstantAlgebra : Algebra C L := + RingHom.toAlgebra ((algebraMap (RatFunc C) L).comp + (algebraMap C (RatFunc C))) + +local instance intermediateRationalAverageConstantTower : IsScalarTower C L N := by + apply IsScalarTower.of_algebraMap_eq' + ext c + change algebraMap (RatFunc C) N (algebraMap C (RatFunc C) c) = + algebraMap L N (algebraMap (RatFunc C) L (algebraMap C (RatFunc C) c)) + exact IsScalarTower.algebraMap_apply (RatFunc C) L N _ + +omit [Fintype C] [Finite S] [DecidableEq C] [DecidableEq S] [DecidableEq (RatFunc C)] + [DecidableEq (RatFunc S)] [FiniteDimensional (RatFunc C) N] [IsGalois (RatFunc C) N] + [FiniteDimensional C S] [IsGalois C S] [FiniteDimensional (RatFunc C) L] + [Algebra.IsSeparable (RatFunc C) L] [FiniteDimensional L N] [IsGalois L N] in +/-- Compatibility of the rational-function and intermediate-base algebra maps +on the exact constant extension. -/ +private theorem intermediateRationalAverageRatFuncBaseTower : + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + letI : SMul (RatFunc C) (ExactConstantExtension C N S) := Algebra.toSMul + letI : Module (RatFunc C) (ExactConstantExtension C N S) := Algebra.toModule + letI : Algebra L (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C L N S + letI : SMul L (ExactConstantExtension C N S) := Algebra.toSMul + letI : Module L (ExactConstantExtension C N S) := Algebra.toModule + IsScalarTower (RatFunc C) L (ExactConstantExtension C N S) := by + let T := ExactConstantExtension C N S + let : Algebra (RatFunc C) T := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : SMul (RatFunc C) T := Algebra.toSMul + let : Module (RatFunc C) T := Algebra.toModule + let : Algebra L T := exactConstantExtensionBaseAlgebra C L N S + let : Algebra N T := exactConstantExtensionAlgebra C N S + let : SMul L T := Algebra.toSMul + let : Module L T := Algebra.toModule + apply IsScalarTower.of_algebraMap_eq' + ext x + change (1 : S) ⊗ₜ algebraMap (RatFunc C) N x = + (1 : S) ⊗ₜ algebraMap L N (algebraMap (RatFunc C) L x) + congr 1 + exact IsScalarTower.algebraMap_apply (RatFunc C) L N x + +/-- The rational infinity-place count of one intermediate-base twist. -/ +noncomputable def intermediateFrobeniusTwistFieldRationalInfinityPlaceCount + (g : N ≃ₐ[L] N) : ℕ := + let T := ExactConstantExtension C N S + letI : Field T := exactConstantExtensionField C N S hExact + letI : Algebra L T := exactConstantExtensionBaseAlgebra C L N S + let F := exactConstantExtensionFrobeniusTwistField C L N S hExact g + letI : Algebra L F := SubalgebraClass.toAlgebra F.toSubalgebra + letI : Algebra (RatFunc C) F := + intermediateFrobeniusTwistFieldRatFuncAlgebra C S N hExact L g + letI : SMul (RatFunc C) F := Algebra.toSMul + letI : Module (RatFunc C) F := Algebra.toModule + letI : FiniteDimensional (RatFunc C) F := + finiteDimensional_intermediateFrobeniusTwistField_over_ratFunc + C S N hExact L g + letI : Algebra.IsSeparable (RatFunc C) F := + isSeparable_intermediateFrobeniusTwistField_over_ratFunc + C S N hExact L g + Nat.card (FiniteExtensionRationalInfinityPlace C F) + +/-- The complete rational-place count of one intermediate-base twist, split +into finite and infinity parts. -/ +noncomputable def intermediateFrobeniusTwistFieldRationalPlaceCount + (g : N ≃ₐ[L] N) : ℕ := + intermediateFrobeniusTwistFieldRationalFinitePlaceCount + C S N hExact L g + + intermediateFrobeniusTwistFieldRationalInfinityPlaceCount + C S N hExact L g + +/-- The split definition is the actual complete rational-place count. -/ +theorem intermediateFrobeniusTwistFieldRationalPlaceCount_eq_finiteExtensionRationalPlaceCount + (g : N ≃ₐ[L] N) : + let T := ExactConstantExtension C N S + letI : Field T := exactConstantExtensionField C N S hExact + letI : Algebra L T := exactConstantExtensionBaseAlgebra C L N S + let F := exactConstantExtensionFrobeniusTwistField C L N S hExact g + letI : Algebra L F := SubalgebraClass.toAlgebra F.toSubalgebra + letI : Algebra (RatFunc C) F := + intermediateFrobeniusTwistFieldRatFuncAlgebra C S N hExact L g + letI : SMul (RatFunc C) F := Algebra.toSMul + letI : Module (RatFunc C) F := Algebra.toModule + letI : FiniteDimensional (RatFunc C) F := + finiteDimensional_intermediateFrobeniusTwistField_over_ratFunc + C S N hExact L g + letI : Algebra.IsSeparable (RatFunc C) F := + isSeparable_intermediateFrobeniusTwistField_over_ratFunc + C S N hExact L g + intermediateFrobeniusTwistFieldRationalPlaceCount C S N hExact L g = + finiteExtensionRationalPlaceCount C F := by + let T := ExactConstantExtension C N S + let : Field T := exactConstantExtensionField C N S hExact + let : Algebra L T := exactConstantExtensionBaseAlgebra C L N S + let F := exactConstantExtensionFrobeniusTwistField C L N S hExact g + let : Algebra L F := SubalgebraClass.toAlgebra F.toSubalgebra + let : Algebra (RatFunc C) F := + intermediateFrobeniusTwistFieldRatFuncAlgebra C S N hExact L g + let : SMul (RatFunc C) F := Algebra.toSMul + let : Module (RatFunc C) F := Algebra.toModule + let : FiniteDimensional (RatFunc C) F := + finiteDimensional_intermediateFrobeniusTwistField_over_ratFunc + C S N hExact L g + let : Algebra.IsSeparable (RatFunc C) F := + isSeparable_intermediateFrobeniusTwistField_over_ratFunc + C S N hExact L g + let : Finite (FiniteExtensionRationalFinitePlace C F) := inferInstance + let : Finite (FiniteExtensionRationalInfinityPlace C F) := inferInstance + unfold intermediateFrobeniusTwistFieldRationalPlaceCount + rw [intermediateFrobeniusTwistFieldRationalFinitePlaceCount, + intermediateFrobeniusTwistFieldRationalInfinityPlaceCount] + change Nat.card (FiniteExtensionRationalFinitePlace C F) + + Nat.card (FiniteExtensionRationalInfinityPlace C F) = + Nat.card (FiniteExtensionRationalFinitePlace C F ⊕ + FiniteExtensionRationalInfinityPlace C F) + exact Nat.card_sum.symm + +/-- Each intermediate twist has at most `[N : C(X)]` rational infinity +places, provided its intermediate Galois order divides the constant degree. -/ +theorem intermediateFrobeniusTwistFieldRationalInfinityPlaceCount_le_original_finrank + (hdivL : Nat.card (N ≃ₐ[L] N) ∣ Module.finrank C S) + (g : N ≃ₐ[L] N) : + intermediateFrobeniusTwistFieldRationalInfinityPlaceCount + C S N hExact L g ≤ Module.finrank (RatFunc C) N := by + let T := ExactConstantExtension C N S + let : Field T := exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) T := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : SMul (RatFunc C) T := Algebra.toSMul + let : Module (RatFunc C) T := Algebra.toModule + let : Algebra L T := exactConstantExtensionBaseAlgebra C L N S + let : SMul L T := Algebra.toSMul + let : Module L T := Algebra.toModule + let : IsScalarTower (RatFunc C) L T := + intermediateRationalAverageRatFuncBaseTower C S N L + let Fₗ := exactConstantExtensionFrobeniusTwistField C L N S hExact g + let : Algebra L Fₗ := SubalgebraClass.toAlgebra Fₗ.toSubalgebra + let : SMul L Fₗ := Algebra.toSMul + let : Module L Fₗ := Algebra.toModule + let : Algebra (RatFunc C) Fₗ := + intermediateFrobeniusTwistFieldRatFuncAlgebra C S N hExact L g + let : SMul (RatFunc C) Fₗ := Algebra.toSMul + let : Module (RatFunc C) Fₗ := Algebra.toModule + let : FiniteDimensional (RatFunc C) Fₗ := + finiteDimensional_intermediateFrobeniusTwistField_over_ratFunc + C S N hExact L g + let : Algebra.IsSeparable (RatFunc C) Fₗ := + isSeparable_intermediateFrobeniusTwistField_over_ratFunc + C S N hExact L g + let : IsScalarTower (RatFunc C) L Fₗ := + IsScalarTower.of_algebraMap_eq' rfl + let : Module.Finite L Fₗ := + Module.Finite.of_restrictScalars_finite (RatFunc C) L Fₗ + change Nat.card (FiniteExtensionRationalInfinityPlace C Fₗ) ≤ _ + calc + Nat.card (FiniteExtensionRationalInfinityPlace C Fₗ) ≤ + Module.finrank (RatFunc C) Fₗ := + rationalInfinityPlace_card_le_finrank C Fₗ + _ = Module.finrank (RatFunc C) L * Module.finrank L Fₗ := + (finrank_mul_finrank_of_fields (RatFunc C) L Fₗ).symm + _ = Module.finrank (RatFunc C) L * Module.finrank L N := by + rw [finrank_frobeniusTwistField_over_base C L N S hExact g hdivL] + _ = Module.finrank (RatFunc C) N := + finrank_mul_finrank_of_fields (RatFunc C) L N + +omit [Fintype C] [FiniteDimensional L N] [IsGalois L N] in +/-- Rational infinity places of the intermediate field itself are bounded by +the original degree. -/ +theorem intermediateBaseRationalInfinityPlaceCount_le_original_finrank : + Nat.card (FiniteExtensionRationalInfinityPlace C L) ≤ + Module.finrank (RatFunc C) N := by + calc + Nat.card (FiniteExtensionRationalInfinityPlace C L) ≤ + Module.finrank (RatFunc C) L := rationalInfinityPlace_card_le_finrank C L + _ ≤ Module.finrank (RatFunc C) N := by + apply Nat.le_of_dvd Module.finrank_pos + rw [← finrank_mul_finrank_of_fields (RatFunc C) L N] + exact dvd_mul_right _ _ + +/-- The total infinity contribution of the twists is bounded by the group +order times the original degree. -/ +theorem sum_intermediateFrobeniusTwistFieldRationalInfinityPlaceCount_le + (hdivL : Nat.card (N ≃ₐ[L] N) ∣ Module.finrank C S) : + (∑ g : N ≃ₐ[L] N, + intermediateFrobeniusTwistFieldRationalInfinityPlaceCount + C S N hExact L g) ≤ + Nat.card (N ≃ₐ[L] N) * Module.finrank (RatFunc C) N := by + calc + (∑ g : N ≃ₐ[L] N, + intermediateFrobeniusTwistFieldRationalInfinityPlaceCount + C S N hExact L g) ≤ + ∑ _g : N ≃ₐ[L] N, Module.finrank (RatFunc C) N := by + exact Finset.sum_le_sum fun g _ ↦ + intermediateFrobeniusTwistFieldRationalInfinityPlaceCount_le_original_finrank + C S N hExact L hdivL g + _ = Nat.card (N ≃ₐ[L] N) * Module.finrank (RatFunc C) N := by + simp [Nat.card_eq_fintype_card] + +/-- Exact finite-plus-infinity aggregate identity over `Gal(N/L)`. -/ +theorem sum_intermediateFrobeniusTwistFieldRationalPlaceCount_eq + (hdivL : Nat.card (N ≃ₐ[L] N) ∣ Module.finrank C S) : + (∑ g : N ≃ₐ[L] N, + intermediateFrobeniusTwistFieldRationalPlaceCount + C S N hExact L g) = + Nat.card (N ≃ₐ[L] N) * + Nat.card (FiniteExtensionRationalFinitePlace C L) + + ∑ g : N ≃ₐ[L] N, + intermediateFrobeniusTwistFieldRationalInfinityPlaceCount + C S N hExact L g := by + simp_rw [intermediateFrobeniusTwistFieldRationalPlaceCount] + rw [Finset.sum_add_distrib, + sum_intermediateFrobeniusTwistFieldRationalFinitePlaceCount_eq_card_galois_mul_card + C S N hExact L hdivL] + +/-- The complete rational-place aggregate is uniformly close to the group +order times the complete rational-place count of `L`. -/ +theorem abs_sum_intermediateFrobeniusTwistFieldRationalPlaceCount_sub_card_mul_base_le + (hdivL : Nat.card (N ≃ₐ[L] N) ∣ Module.finrank C S) : + |∑ g : N ≃ₐ[L] N, + (intermediateFrobeniusTwistFieldRationalPlaceCount + C S N hExact L g : ℝ) - + (Nat.card (N ≃ₐ[L] N) : ℝ) * + finiteExtensionRationalPlaceCount C L| ≤ + 2 * (Module.finrank (RatFunc C) N : ℝ) ^ 2 := by + let G : ℕ := Nat.card (N ≃ₐ[L] N) + let D : ℕ := Module.finrank (RatFunc C) N + let Iₗ : ℕ := ∑ g : N ≃ₐ[L] N, + intermediateFrobeniusTwistFieldRationalInfinityPlaceCount + C S N hExact L g + let Iₒ : ℕ := Nat.card (FiniteExtensionRationalInfinityPlace C L) + have htotal := sum_intermediateFrobeniusTwistFieldRationalPlaceCount_eq + C S N hExact L hdivL + have hbase : finiteExtensionRationalPlaceCount C L = + Nat.card (FiniteExtensionRationalFinitePlace C L) + Iₒ := by + unfold finiteExtensionRationalPlaceCount + rw [Nat.card_sum] + have herr : + (∑ g : N ≃ₐ[L] N, + (intermediateFrobeniusTwistFieldRationalPlaceCount + C S N hExact L g : ℝ)) - + (G : ℝ) * finiteExtensionRationalPlaceCount C L = + (Iₗ : ℝ) - (G : ℝ) * Iₒ := by + have htotalReal : + (∑ g : N ≃ₐ[L] N, + (intermediateFrobeniusTwistFieldRationalPlaceCount + C S N hExact L g : ℝ)) = + (G : ℝ) * Nat.card (FiniteExtensionRationalFinitePlace C L) + + (Iₗ : ℝ) := by + exact_mod_cast htotal + rw [htotalReal, hbase] + push_cast + ring + have hIₗ : Iₗ ≤ G * D := by + exact sum_intermediateFrobeniusTwistFieldRationalInfinityPlaceCount_le + C S N hExact L hdivL + have hIₒ : Iₒ ≤ D := + intermediateBaseRationalInfinityPlaceCount_le_original_finrank C N L + have hG : G ≤ D := by + dsimp only [G, D] + rw [IsGalois.card_aut_eq_finrank] + apply Nat.le_of_dvd Module.finrank_pos + rw [← finrank_mul_finrank_of_fields (RatFunc C) L N] + exact dvd_mul_left _ _ + rw [herr] + have hIₗ' : (Iₗ : ℝ) ≤ (G : ℝ) * D := by exact_mod_cast hIₗ + have hIₒ' : (Iₒ : ℝ) ≤ D := by exact_mod_cast hIₒ + have hG' : (G : ℝ) ≤ D := by exact_mod_cast hG + have hD : (0 : ℝ) ≤ D := by positivity + have hGnonneg : (0 : ℝ) ≤ G := by positivity + have hIₗnonneg : (0 : ℝ) ≤ Iₗ := by positivity + have hIₒnonneg : (0 : ℝ) ≤ Iₒ := by positivity + apply abs_le.mpr + constructor <;> nlinarith + +end IntermediateBase + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionNormalClosureTower.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionNormalClosureTower.lean new file mode 100644 index 0000000000..2a8e470d8e --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionNormalClosureTower.lean @@ -0,0 +1,1040 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionConstants +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionRationalPlaceCount +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionTower +public import LeanPool.MarkoffModP.BGS.HasseWeil.ConstantExtensionClosedPlaceSplittingFormula +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionClosedPlaceAlgEquiv +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionZetaDegreeIndexOne +public import LeanPool.MarkoffModP.BGS.HasseWeil.FunctionFieldNormalClosureOriginalCompositum + +/-! +# The exact constant-extension tower of a function-field normal closure + +Let `F / K(X)` have exact constant field `K`, let `N` be the chosen normal +closure, let `C` be the full algebraic constant field of `N`, and let +`M = CF ⊆ N` be the original compositum. For a finite Galois extension +`S / C`, this file specializes the generic exact-constant-extension tower to + +`S ⊗[C] M ⊆ S ⊗[C] N`. + +It packages the canonical `S(X)`-linear inclusion, the finite Galois +structure of the top over the bottom, and preservation of both the relative +degree and the two rational-function-field degrees. This is a structural +consumer of the exact constant-extension API; it deliberately does not use +the genus-invariance layer. +-/ + +@[expose] public section + +open scoped Polynomial TensorProduct + +namespace BGS.HasseWeil + +noncomputable section CountOneBridge +open BGS.CorvajaZannier +variable (C S N : Type*) [Field C] [Field S] [Field N] + [Fintype C] [Finite S] + [Algebra (RatFunc C) N] [FiniteDimensional (RatFunc C) N] + [Algebra.IsSeparable (RatFunc C) N] + [Algebra C S] [FiniteDimensional C S] [IsGalois C S] +local instance : Algebra C N := bridgeBaseConstantAlgebra C N +local instance : IsScalarTower C (RatFunc C) N := IsScalarTower.of_algebraMap_eq' rfl + +private theorem exactConstantExtensionClosedPlaceExtensionCount_one_eq_baseCount + (hExact : algebraicClosure C N = (⊥ : IntermediateField C N)) : + let : Fintype S := Fintype.ofFinite S + let : DecidableEq C := Classical.decEq C + let : DecidableEq (RatFunc C) := Classical.decEq (RatFunc C) + exactConstantExtensionClosedPlaceExtensionCount C S N hExact 1 = + finiteExtensionClosedPlaceExtensionCount C N (Module.finrank C S) := by + intro finiteS decideC decideRatFuncC + classical + rw [exactConstantExtensionClosedPlaceExtensionCount_eq_classical_decidableEq] + have h := exactConstantExtensionClosedPlaceExtensionCount_eq C S N hExact 1 + simpa using h + +private theorem rationalExactConstantCount_eq_of_algEquiv + (E : Type*) [Field E] [Algebra (RatFunc C) E] + [FiniteDimensional (RatFunc C) E] [Algebra.IsSeparable (RatFunc C) E] + (hExact : algebraicClosure C N = (⊥ : IntermediateField C N)) + (e : E ≃ₐ[RatFunc C] N) : + let : Fintype S := Fintype.ofFinite S + let : DecidableEq C := Classical.decEq C + let : DecidableEq (RatFunc C) := Classical.decEq (RatFunc C) + let : DecidableEq S := Classical.decEq S + let : DecidableEq (RatFunc S) := Classical.decEq (RatFunc S) + let EM := ExactConstantExtension C N S + let : Field EM := exactConstantExtensionField C N S hExact + let : Algebra (RatFunc S) EM := ratFuncExactConstantExtensionAlgebra C S N hExact + let : SMul (RatFunc S) EM := Algebra.toSMul + let : Module (RatFunc S) EM := Algebra.toModule + let : FiniteDimensional (RatFunc S) EM := + finiteDimensional_over_extendedRatFunc C S N hExact + let : Algebra.IsSeparable (RatFunc S) EM := + isSeparable_over_extendedRatFunc C S N hExact + finiteExtensionRationalPlaceCount S EM = + finiteExtensionClosedPlaceExtensionCount C E (Module.finrank C S) := by + intro finiteS decideC decideRatFuncC decideS decideRatFuncS EM + fieldEM algebraEM smulEM moduleEM finiteEM separableEM + classical + have hFirst := exactConstantExtensionClosedPlaceExtensionCount_one_eq_rationalPlaceCount + C S N hExact + have hMiddle := exactConstantExtensionClosedPlaceExtensionCount_one_eq_baseCount C S N hExact + have hLast := finiteExtensionClosedPlaceExtensionCount_eq_of_algEquiv C E N e + (Module.finrank C S) + exact hFirst.symm.trans (hMiddle.trans hLast.symm) + +end CountOneBridge + +private theorem finite_of_injective_field_tower + (B M N : Type*) [Field B] [Field M] [Field N] + [Algebra B M] [Algebra B N] [Algebra M N] [IsScalarTower B M N] + [Module.Finite B N] : Module.Finite B M := + Module.Finite.of_injective (IsScalarTower.toAlgHom B M N).toLinearMap + (IsScalarTower.toAlgHom B M N).injective + + +noncomputable section + + +variable (K F : Type*) [Field K] [Field F] + [Fintype K] [DecidableEq K] [DecidableEq (RatFunc K)] + [Algebra K F] [Algebra (RatFunc K) F] + [IsScalarTower K (RatFunc K) F] + [FiniteDimensional (RatFunc K) F] + [Algebra.IsSeparable (RatFunc K) F] + +/-- The `C(X)`-algebra on the constant-base field `C K(X)`, transported +through its canonical rational-function presentation. -/ +@[reducible] noncomputable instance + functionFieldNormalClosureConstantBaseConstantRatFuncAlgebra : + Algebra (RatFunc (FunctionFieldNormalClosureConstantField K F)) + (FunctionFieldNormalClosureConstantBase K F) := + (functionFieldNormalClosureConstantBaseRatFuncAlgEquiv K F).toAlgHom.toAlgebra + +/-- The canonical rational-function presentation of the constant-base field, +viewed as an equivalence over `C(X)` itself. -/ +noncomputable def + functionFieldNormalClosureConstantBaseRatFuncSelfAlgEquiv : + RatFunc (FunctionFieldNormalClosureConstantField K F) ≃ₐ[ + RatFunc (FunctionFieldNormalClosureConstantField K F)] + FunctionFieldNormalClosureConstantBase K F := + { functionFieldNormalClosureConstantBaseRatFuncAlgEquiv K F with + commutes' := fun _ => rfl } + +/-- The constant-base field is one-dimensional, hence finite, over its +canonical `C(X)` presentation. -/ +noncomputable instance + functionFieldNormalClosureConstantBase_finiteDimensional_over_constantRatFunc : + FiniteDimensional + (RatFunc (FunctionFieldNormalClosureConstantField K F)) + (FunctionFieldNormalClosureConstantBase K F) := by + let e := functionFieldNormalClosureConstantBaseRatFuncSelfAlgEquiv K F + exact Module.Finite.equiv e.toLinearEquiv + +/-- The canonical `C(X)`-algebra on the normal closure, obtained by including +the constant-base field `C K(X)` into the normal closure. -/ +@[reducible] noncomputable instance + functionFieldNormalClosureConstantRatFuncAlgebra : + Algebra (RatFunc (FunctionFieldNormalClosureConstantField K F)) + (FunctionFieldNormalClosure K F) := + RingHom.toAlgebra + ((algebraMap (FunctionFieldNormalClosureConstantBase K F) + (FunctionFieldNormalClosure K F)).comp + (algebraMap (RatFunc (FunctionFieldNormalClosureConstantField K F)) + (FunctionFieldNormalClosureConstantBase K F))) + +/-- The canonical `C(X)` map to the normal closure factors through the +constant-base field. -/ +noncomputable instance + functionFieldNormalClosureConstantRatFuncBaseTower : + IsScalarTower + (RatFunc (FunctionFieldNormalClosureConstantField K F)) + (FunctionFieldNormalClosureConstantBase K F) + (FunctionFieldNormalClosure K F) := + IsScalarTower.of_algebraMap_eq' rfl + +/-- The normal closure is finite over the canonical copy of `C(X)`. -/ +noncomputable instance + functionFieldNormalClosure_finiteDimensional_over_constantRatFunc : + FiniteDimensional + (RatFunc (FunctionFieldNormalClosureConstantField K F)) + (FunctionFieldNormalClosure K F) := by + exact Module.Finite.trans (FunctionFieldNormalClosureConstantBase K F) + (FunctionFieldNormalClosure K F) + +omit [Algebra K F] [IsScalarTower K (RatFunc K) F] in +omit [Fintype K] [DecidableEq K] [DecidableEq (RatFunc K)] in +/-- The normal closure remains Galois after replacing the constant-base fixed +field by its canonical rational-function presentation `C(X)`. -/ +theorem functionFieldNormalClosure_isGalois_over_constantRatFunc : + IsGalois (RatFunc (FunctionFieldNormalClosureConstantField K F)) + (FunctionFieldNormalClosure K F) := by + let C := FunctionFieldNormalClosureConstantField K F + let B := FunctionFieldNormalClosureConstantBase K F + let N := FunctionFieldNormalClosure K F + let e : RatFunc C ≃ₐ[RatFunc C] B := + functionFieldNormalClosureConstantBaseRatFuncSelfAlgEquiv K F + let : IsGalois B N := + functionFieldNormalClosure_isGalois_over_constantBase K F + refine IsGalois.of_equiv_equiv (F := B) (E := N) + (f := e.symm.toRingEquiv) (g := RingEquiv.refl N) ?_ + ext x + simp only [RingHom.comp_apply] + rw [IsScalarTower.algebraMap_apply (RatFunc C) B N] + rw [← e.commutes] + simp + +omit [Fintype K] [DecidableEq K] [DecidableEq (RatFunc K)] [Algebra K F] + [IsScalarTower K (RatFunc K) F] in +/-- Exactness of the full normal-closure constant field, stated for the +constant algebra obtained by restricting the canonical `C(X)` presentation. +This is the exact instance expected by the generic tower API. -/ +theorem functionFieldNormalClosureConstantField_isExact_for_constantRatFunc : + let C := FunctionFieldNormalClosureConstantField K F + let N := FunctionFieldNormalClosure K F + letI : Algebra C N := + exactConstantExtensionTowerCanonicalConstantAlgebra C N + algebraicClosure C N = (⊥ : IntermediateField C N) := by + let C := FunctionFieldNormalClosureConstantField K F + let B := FunctionFieldNormalClosureConstantBase K F + let N := FunctionFieldNormalClosure K F + let old : Algebra C N := inferInstance + let fresh : Algebra C N := + exactConstantExtensionTowerCanonicalConstantAlgebra C N + have hfresh : fresh = old := by + apply Algebra.algebra_ext + intro c + let : Algebra C N := old + change algebraMap B N + (functionFieldNormalClosureConstantBaseRatFuncAlgEquiv K F + (algebraMap C (RatFunc C) c)) = algebraMap C N c + rw [(functionFieldNormalClosureConstantBaseRatFuncAlgEquiv K F).commutes] + exact (IsScalarTower.algebraMap_apply C B N c).symm + let exactFor : Algebra C N → Prop := fun a => + letI : Algebra C N := a + algebraicClosure C N = (⊥ : IntermediateField C N) + have hOld : exactFor old := + functionFieldNormalClosureConstantField_isExact K F + have hFresh : exactFor fresh := + Eq.mp (congrArg exactFor hfresh).symm hOld + let : Algebra C N := fresh + exact hFresh + +section OriginalCompositum + +variable (hExact : algebraicClosure K F = + (⊥ : IntermediateField K F)) + +/-- The constant-base field embeds into the original compositum `CF`. -/ +@[reducible] noncomputable instance + functionFieldNormalClosureConstantBaseOriginalCompositumAlgebra : + Algebra (FunctionFieldNormalClosureConstantBase K F) + (FunctionFieldNormalClosureOriginalCompositum K F hExact) := + (functionFieldNormalClosureConstantBaseToOriginalCompositum + K F hExact).toAlgebra + +local instance constantBaseOriginalCompositumSmul : + SMul (FunctionFieldNormalClosureConstantBase K F) + (FunctionFieldNormalClosureOriginalCompositum K F hExact) := + (functionFieldNormalClosureConstantBaseOriginalCompositumAlgebra K F hExact).toSMul + +local instance constantBaseOriginalCompositumModule : + Module (FunctionFieldNormalClosureConstantBase K F) + (FunctionFieldNormalClosureOriginalCompositum K F hExact) := + (functionFieldNormalClosureConstantBaseOriginalCompositumAlgebra K F hExact).toModule + +/-- The embeddings of the constant base into `CF` and then into the normal +closure agree with its direct inclusion. -/ +noncomputable instance + functionFieldNormalClosureConstantBaseOriginalCompositumTower : + IsScalarTower (FunctionFieldNormalClosureConstantBase K F) + (FunctionFieldNormalClosureOriginalCompositum K F hExact) + (FunctionFieldNormalClosure K F) := by + apply IsScalarTower.of_algebraMap_eq' + ext b + rfl + +/-- The existing `C(X)` structure on `CF` factors through the constant-base +field. -/ +noncomputable instance + functionFieldNormalClosureOriginalCompositumConstantRatFuncBaseTower : + IsScalarTower + (RatFunc (FunctionFieldNormalClosureConstantField K F)) + (FunctionFieldNormalClosureConstantBase K F) + (FunctionFieldNormalClosureOriginalCompositum K F hExact) := by + apply IsScalarTower.of_algebraMap_eq' + ext r + rfl + +/-- The canonical `C(X)` structures on `CF` and on the normal closure are +compatible with the inclusion `CF ⊆ N`. -/ +noncomputable instance + functionFieldNormalClosureOriginalCompositumConstantRatFuncTower : + IsScalarTower + (RatFunc (FunctionFieldNormalClosureConstantField K F)) + (FunctionFieldNormalClosureOriginalCompositum K F hExact) + (FunctionFieldNormalClosure K F) := by + apply IsScalarTower.of_algebraMap_eq' + ext r + rfl + +/-- The original compositum is finite over its canonical copy of `C(X)`. -/ +noncomputable instance + functionFieldNormalClosureOriginalCompositum_finiteDimensional_over_constantRatFunc : + FiniteDimensional + (RatFunc (FunctionFieldNormalClosureConstantField K F)) + (FunctionFieldNormalClosureOriginalCompositum K F hExact) := by + let B := FunctionFieldNormalClosureConstantBase K F + let M := FunctionFieldNormalClosureOriginalCompositum K F hExact + let N := FunctionFieldNormalClosure K F + let : Module.Finite B M := finite_of_injective_field_tower B M N + exact Module.Finite.trans B M + +end OriginalCompositum + +end + +noncomputable section + +section CanonicalNormalClosureTower + + +variable (K F : Type*) [Field K] [Field F] + [Fintype K] [DecidableEq K] [DecidableEq (RatFunc K)] + [Algebra (RatFunc K) F] + [FiniteDimensional (RatFunc K) F] + [Algebra.IsSeparable (RatFunc K) F] + +local instance canonicalOriginalConstantAlgebra : Algebra K F := + functionFieldCanonicalConstantAlgebra K F + +local instance canonicalOriginalConstantTower : + IsScalarTower K (RatFunc K) F := + IsScalarTower.of_algebraMap_eq' rfl + +omit [DecidableEq K] [DecidableEq (RatFunc K)] in +/-- In the canonical `C(X)` presentation, `C` is also the exact constant +field of the original compositum `CF`. -/ +theorem + functionFieldNormalClosureOriginalCompositumConstantField_isExact_for_constantRatFunc + (hExact : algebraicClosure K F = (⊥ : IntermediateField K F)) : + let C := FunctionFieldNormalClosureConstantField K F + let M := FunctionFieldNormalClosureOriginalCompositum K F hExact + letI : Algebra C M := + exactConstantExtensionTowerCanonicalConstantAlgebra C M + algebraicClosure C M = (⊥ : IntermediateField C M) := by + let C := FunctionFieldNormalClosureConstantField K F + let B := FunctionFieldNormalClosureConstantBase K F + let M := FunctionFieldNormalClosureOriginalCompositum K F hExact + let : Algebra (RatFunc C) M := + functionFieldNormalClosureOriginalCompositumConstantRatFuncAlgebra + K F hExact + let old : Algebra C M := + functionFieldNormalClosureOriginalCompositumConstantAlgebra K F hExact + let fresh : Algebra C M := + exactConstantExtensionTowerCanonicalConstantAlgebra C M + have hfresh : fresh = old := by + apply Algebra.algebra_ext + intro c + let : Algebra C M := old + let : Algebra B M := + functionFieldNormalClosureConstantBaseOriginalCompositumAlgebra + K F hExact + change algebraMap B M + (functionFieldNormalClosureConstantBaseRatFuncAlgEquiv K F + (algebraMap C (RatFunc C) c)) = algebraMap C M c + rw [(functionFieldNormalClosureConstantBaseRatFuncAlgEquiv K F).commutes] + rfl + let exactFor : Algebra C M → Prop := fun a => + letI : Algebra C M := a + algebraicClosure C M = (⊥ : IntermediateField C M) + have hOld : exactFor old := + functionFieldNormalClosureOriginalCompositumConstantField_isExact + K F hExact + have hFresh : exactFor fresh := + Eq.mp (congrArg exactFor hfresh).symm hOld + let : Algebra C M := fresh + exact hFresh + +omit [DecidableEq K] [DecidableEq (RatFunc K)] in +/-- The original compositum remains separable over the canonical rational +function field of the full constant field. This is transported from the +original function field after exact extension of constants. -/ +private theorem originalCompositum_separable_constantRatFunc + (hExact : algebraicClosure K F = (⊥ : IntermediateField K F)) : + Algebra.IsSeparable + (RatFunc (FunctionFieldNormalClosureConstantField K F)) + (FunctionFieldNormalClosureOriginalCompositum K F hExact) := by + let N := FunctionFieldNormalClosure K F + let : Algebra K N := functionFieldNormalClosureConstantAlgebra K F + let C := FunctionFieldNormalClosureConstantField K F + let : Algebra K C := + SubalgebraClass.toAlgebra (algebraicClosure K N) + let E := ExactConstantExtension K F C + let M := FunctionFieldNormalClosureOriginalCompositum K F hExact + let : Field E := exactConstantExtensionField K F C hExact + let : Algebra (RatFunc C) E := + ratFuncExactConstantExtensionAlgebra K C F hExact + let : Algebra.IsSeparable (RatFunc C) E := + isSeparable_over_extendedRatFunc K C F hExact + let e : E ≃ₐ[RatFunc C] M := + exactConstantExtensionOriginalCompositumCanonicalRatFuncAlgEquiv + K F hExact + constructor + intro x + have hx : IsSeparable (RatFunc C) (e.symm x) := + Algebra.IsSeparable.isSeparable (RatFunc C) (e.symm x) + have hex : IsSeparable (RatFunc C) (e (e.symm x)) := + (AlgEquiv.isSeparable_iff e).mpr hx + simpa using hex + +noncomputable instance + functionFieldNormalClosureOriginalCompositum_isSeparable_over_constantRatFunc + (hExact : algebraicClosure K F = (⊥ : IntermediateField K F)) : + Algebra.IsSeparable + (RatFunc (FunctionFieldNormalClosureConstantField K F)) + (FunctionFieldNormalClosureOriginalCompositum K F hExact) := + originalCompositum_separable_constantRatFunc K F hExact + +section ConstantExtension + +variable (S : Type*) [Field S] + [Algebra (FunctionFieldNormalClosureConstantField K F) S] + +local instance normalClosureConstantExtensionModule : + Module (FunctionFieldNormalClosureConstantField K F) S := + Algebra.toModule + +variable [Module.Finite (FunctionFieldNormalClosureConstantField K F) S] + [IsGalois (FunctionFieldNormalClosureConstantField K F) S] + +/-- The field structure on `S ⊗[C] CF` used by the normal-closure tower. -/ +@[reducible] noncomputable def + functionFieldNormalClosureOriginalCompositumConstantExtensionField + (hExact : algebraicClosure K F = (⊥ : IntermediateField K F)) : + let C := FunctionFieldNormalClosureConstantField K F + let M := FunctionFieldNormalClosureOriginalCompositum K F hExact + letI : Algebra C M := + exactConstantExtensionTowerCanonicalConstantAlgebra C M + Field (ExactConstantExtension C M S) := by + let C := FunctionFieldNormalClosureConstantField K F + let M := FunctionFieldNormalClosureOriginalCompositum K F hExact + letI : Algebra C M := + exactConstantExtensionTowerCanonicalConstantAlgebra C M + exact exactConstantExtensionField C M S + (functionFieldNormalClosureOriginalCompositumConstantField_isExact_for_constantRatFunc + K F hExact) + +/-- The field structure on `S ⊗[C] N` in the same canonical +`C(X)` presentation. -/ +@[reducible] noncomputable def + functionFieldNormalClosureConstantExtensionFieldForTower : + let C := FunctionFieldNormalClosureConstantField K F + let N := FunctionFieldNormalClosure K F + letI : Algebra C N := + exactConstantExtensionTowerCanonicalConstantAlgebra C N + Field (ExactConstantExtension C N S) := by + let C := FunctionFieldNormalClosureConstantField K F + let N := FunctionFieldNormalClosure K F + letI : Algebra C N := + exactConstantExtensionTowerCanonicalConstantAlgebra C N + exact exactConstantExtensionField C N S + (functionFieldNormalClosureConstantField_isExact_for_constantRatFunc K F) + +/-- The canonical `S(X)`-algebra on `S ⊗[C] CF`. -/ +@[reducible] noncomputable def + functionFieldNormalClosureOriginalCompositumConstantExtensionRatFuncAlgebra + (hExact : algebraicClosure K F = (⊥ : IntermediateField K F)) : + let C := FunctionFieldNormalClosureConstantField K F + let M := FunctionFieldNormalClosureOriginalCompositum K F hExact + letI : Algebra C M := + exactConstantExtensionTowerCanonicalConstantAlgebra C M + Algebra (RatFunc S) (ExactConstantExtension C M S) := by + let C := FunctionFieldNormalClosureConstantField K F + let M := FunctionFieldNormalClosureOriginalCompositum K F hExact + letI : Algebra C M := + exactConstantExtensionTowerCanonicalConstantAlgebra C M + letI : Field (ExactConstantExtension C M S) := + functionFieldNormalClosureOriginalCompositumConstantExtensionField + K F S hExact + exact ratFuncExactConstantExtensionAlgebra C S M + (functionFieldNormalClosureOriginalCompositumConstantField_isExact_for_constantRatFunc + K F hExact) + +/-- The canonical `S(X)`-algebra on `S ⊗[C] N`. -/ +@[reducible] noncomputable def + functionFieldNormalClosureConstantExtensionRatFuncAlgebraForTower : + let C := FunctionFieldNormalClosureConstantField K F + let N := FunctionFieldNormalClosure K F + letI : Algebra C N := + exactConstantExtensionTowerCanonicalConstantAlgebra C N + Algebra (RatFunc S) (ExactConstantExtension C N S) := by + let C := FunctionFieldNormalClosureConstantField K F + let N := FunctionFieldNormalClosure K F + letI : Algebra C N := + exactConstantExtensionTowerCanonicalConstantAlgebra C N + letI : Field (ExactConstantExtension C N S) := + functionFieldNormalClosureConstantExtensionFieldForTower K F S + exact ratFuncExactConstantExtensionAlgebra C S N + (functionFieldNormalClosureConstantField_isExact_for_constantRatFunc K F) + +/-- The canonical `S(X)`-linear inclusion +`S ⊗[C] CF → S ⊗[C] N`. -/ +noncomputable def functionFieldNormalClosureConstantExtensionTowerAlgHom + (hExact : algebraicClosure K F = (⊥ : IntermediateField K F)) : + let C := FunctionFieldNormalClosureConstantField K F + let M := FunctionFieldNormalClosureOriginalCompositum K F hExact + let N := FunctionFieldNormalClosure K F + letI : Algebra C M := + exactConstantExtensionTowerCanonicalConstantAlgebra C M + letI : Algebra C N := + exactConstantExtensionTowerCanonicalConstantAlgebra C N + let E_M := ExactConstantExtension C M S + let E_N := ExactConstantExtension C N S + letI : Field E_M := + functionFieldNormalClosureOriginalCompositumConstantExtensionField + K F S hExact + letI : Field E_N := + functionFieldNormalClosureConstantExtensionFieldForTower K F S + letI : Algebra (RatFunc S) E_M := + functionFieldNormalClosureOriginalCompositumConstantExtensionRatFuncAlgebra + K F S hExact + letI : Algebra (RatFunc S) E_N := + functionFieldNormalClosureConstantExtensionRatFuncAlgebraForTower K F S + E_M →ₐ[RatFunc S] E_N := by + let C := FunctionFieldNormalClosureConstantField K F + let M := FunctionFieldNormalClosureOriginalCompositum K F hExact + let N := FunctionFieldNormalClosure K F + letI : Algebra (RatFunc C) M := + functionFieldNormalClosureOriginalCompositumConstantRatFuncAlgebra + K F hExact + letI : Algebra (RatFunc C) N := + functionFieldNormalClosureConstantRatFuncAlgebra K F + letI : IsScalarTower (RatFunc C) M N := + functionFieldNormalClosureOriginalCompositumConstantRatFuncTower + K F hExact + letI : Algebra C M := + exactConstantExtensionTowerCanonicalConstantAlgebra C M + letI : Algebra C N := + exactConstantExtensionTowerCanonicalConstantAlgebra C N + let E_M := ExactConstantExtension C M S + let E_N := ExactConstantExtension C N S + letI : Field E_M := + functionFieldNormalClosureOriginalCompositumConstantExtensionField + K F S hExact + letI : Field E_N := + functionFieldNormalClosureConstantExtensionFieldForTower K F S + letI : Algebra (RatFunc S) E_M := + functionFieldNormalClosureOriginalCompositumConstantExtensionRatFuncAlgebra + K F S hExact + letI : Algebra (RatFunc S) E_N := + functionFieldNormalClosureConstantExtensionRatFuncAlgebraForTower K F S + exact exactConstantExtensionTowerRatFuncAlgHom C M N S + (functionFieldNormalClosureConstantField_isExact_for_constantRatFunc K F) + +/-- The algebra structure underlying the specialized tensor inclusion. -/ +@[reducible] noncomputable def + functionFieldNormalClosureConstantExtensionTowerAlgebra + (hExact : algebraicClosure K F = (⊥ : IntermediateField K F)) : + let C := FunctionFieldNormalClosureConstantField K F + let M := FunctionFieldNormalClosureOriginalCompositum K F hExact + let N := FunctionFieldNormalClosure K F + letI : Algebra C M := + exactConstantExtensionTowerCanonicalConstantAlgebra C M + letI : Algebra C N := + exactConstantExtensionTowerCanonicalConstantAlgebra C N + Algebra (ExactConstantExtension C M S) + (ExactConstantExtension C N S) := by + let C := FunctionFieldNormalClosureConstantField K F + let M := FunctionFieldNormalClosureOriginalCompositum K F hExact + let N := FunctionFieldNormalClosure K F + letI : Algebra (RatFunc C) M := + functionFieldNormalClosureOriginalCompositumConstantRatFuncAlgebra + K F hExact + letI : Algebra (RatFunc C) N := + functionFieldNormalClosureConstantRatFuncAlgebra K F + letI : IsScalarTower (RatFunc C) M N := + functionFieldNormalClosureOriginalCompositumConstantRatFuncTower + K F hExact + letI : Algebra C M := + exactConstantExtensionTowerCanonicalConstantAlgebra C M + letI : Algebra C N := + exactConstantExtensionTowerCanonicalConstantAlgebra C N + exact exactConstantExtensionTowerRatFuncAlgebra C M N S + +/-- The specialized inclusion and the canonical `S(X)` structures form a +scalar tower. -/ +theorem functionFieldNormalClosureConstantExtension_ratFuncScalarTower + (hExact : algebraicClosure K F = (⊥ : IntermediateField K F)) : + let C := FunctionFieldNormalClosureConstantField K F + let M := FunctionFieldNormalClosureOriginalCompositum K F hExact + let N := FunctionFieldNormalClosure K F + letI : Algebra C M := + exactConstantExtensionTowerCanonicalConstantAlgebra C M + letI : Algebra C N := + exactConstantExtensionTowerCanonicalConstantAlgebra C N + let E_M := ExactConstantExtension C M S + let E_N := ExactConstantExtension C N S + letI : Field E_M := + functionFieldNormalClosureOriginalCompositumConstantExtensionField + K F S hExact + letI : Field E_N := + functionFieldNormalClosureConstantExtensionFieldForTower K F S + letI : Algebra (RatFunc S) E_M := + functionFieldNormalClosureOriginalCompositumConstantExtensionRatFuncAlgebra + K F S hExact + letI : Algebra (RatFunc S) E_N := + functionFieldNormalClosureConstantExtensionRatFuncAlgebraForTower K F S + letI : Algebra E_M E_N := + functionFieldNormalClosureConstantExtensionTowerAlgebra K F S hExact + letI : SMul (RatFunc S) E_M := Algebra.toSMul + letI : SMul (RatFunc S) E_N := Algebra.toSMul + letI : SMul E_M E_N := Algebra.toSMul + IsScalarTower (RatFunc S) E_M E_N := by + let C := FunctionFieldNormalClosureConstantField K F + let M := FunctionFieldNormalClosureOriginalCompositum K F hExact + let N := FunctionFieldNormalClosure K F + let : Algebra (RatFunc C) M := + functionFieldNormalClosureOriginalCompositumConstantRatFuncAlgebra + K F hExact + let : Algebra (RatFunc C) N := + functionFieldNormalClosureConstantRatFuncAlgebra K F + let : IsScalarTower (RatFunc C) M N := + functionFieldNormalClosureOriginalCompositumConstantRatFuncTower + K F hExact + let : Algebra C M := + exactConstantExtensionTowerCanonicalConstantAlgebra C M + let : Algebra C N := + exactConstantExtensionTowerCanonicalConstantAlgebra C N + let E_M := ExactConstantExtension C M S + let E_N := ExactConstantExtension C N S + let : Field E_M := + functionFieldNormalClosureOriginalCompositumConstantExtensionField + K F S hExact + let : Field E_N := + functionFieldNormalClosureConstantExtensionFieldForTower K F S + let : Algebra (RatFunc S) E_M := + functionFieldNormalClosureOriginalCompositumConstantExtensionRatFuncAlgebra + K F S hExact + let : Algebra (RatFunc S) E_N := + functionFieldNormalClosureConstantExtensionRatFuncAlgebraForTower K F S + let : Algebra E_M E_N := + functionFieldNormalClosureConstantExtensionTowerAlgebra K F S hExact + let : SMul (RatFunc S) E_M := Algebra.toSMul + let : SMul (RatFunc S) E_N := Algebra.toSMul + let : SMul E_M E_N := Algebra.toSMul + exact exactConstantExtensionTower_ratFuncScalarTower C M N S + (functionFieldNormalClosureConstantField_isExact_for_constantRatFunc K F) + +/-- The extended normal closure is finite-dimensional over the extended +original compositum. -/ +theorem + functionFieldNormalClosureConstantExtension_finiteDimensional + (hExact : algebraicClosure K F = (⊥ : IntermediateField K F)) : + let C := FunctionFieldNormalClosureConstantField K F + let M := FunctionFieldNormalClosureOriginalCompositum K F hExact + let N := FunctionFieldNormalClosure K F + letI : Algebra C M := + exactConstantExtensionTowerCanonicalConstantAlgebra C M + letI : Algebra C N := + exactConstantExtensionTowerCanonicalConstantAlgebra C N + let E_M := ExactConstantExtension C M S + let E_N := ExactConstantExtension C N S + letI : Field E_M := + functionFieldNormalClosureOriginalCompositumConstantExtensionField + K F S hExact + letI : Field E_N := + functionFieldNormalClosureConstantExtensionFieldForTower K F S + letI : Algebra E_M E_N := + functionFieldNormalClosureConstantExtensionTowerAlgebra K F S hExact + letI : Module E_M E_N := Algebra.toModule + Module.Finite E_M E_N := by + let C := FunctionFieldNormalClosureConstantField K F + let M := FunctionFieldNormalClosureOriginalCompositum K F hExact + let N := FunctionFieldNormalClosure K F + let : Algebra (RatFunc C) M := + functionFieldNormalClosureOriginalCompositumConstantRatFuncAlgebra + K F hExact + let : Algebra (RatFunc C) N := + functionFieldNormalClosureConstantRatFuncAlgebra K F + let : IsScalarTower (RatFunc C) M N := + functionFieldNormalClosureOriginalCompositumConstantRatFuncTower + K F hExact + let : Algebra C M := + exactConstantExtensionTowerCanonicalConstantAlgebra C M + let : Algebra C N := + exactConstantExtensionTowerCanonicalConstantAlgebra C N + let : SMul C M := Algebra.toSMul + let : SMul C N := Algebra.toSMul + let : SMul M N := Algebra.toSMul + let : IsScalarTower C M N := + exactConstantExtensionTowerCanonicalConstantScalarTower C M N + let E_M := ExactConstantExtension C M S + let E_N := ExactConstantExtension C N S + let : Field E_M := + functionFieldNormalClosureOriginalCompositumConstantExtensionField + K F S hExact + let : Field E_N := + functionFieldNormalClosureConstantExtensionFieldForTower K F S + let : Algebra E_M E_N := + functionFieldNormalClosureConstantExtensionTowerAlgebra K F S hExact + let : Module E_M E_N := Algebra.toModule + let : FiniteDimensional M N := + functionFieldNormalClosure_finiteDimensional_over_originalCompositum + K F hExact + let : IsGalois M N := + functionFieldNormalClosure_isGalois_over_originalCompositum K F hExact + exact exactConstantExtensionTower_finiteDimensional C M N S + (functionFieldNormalClosureConstantField_isExact_for_constantRatFunc K F) + +/-- The extended normal closure remains Galois over the extended original +compositum. -/ +theorem functionFieldNormalClosureConstantExtension_isGalois + (hExact : algebraicClosure K F = (⊥ : IntermediateField K F)) : + let C := FunctionFieldNormalClosureConstantField K F + let M := FunctionFieldNormalClosureOriginalCompositum K F hExact + let N := FunctionFieldNormalClosure K F + letI : Algebra C M := + exactConstantExtensionTowerCanonicalConstantAlgebra C M + letI : Algebra C N := + exactConstantExtensionTowerCanonicalConstantAlgebra C N + let E_M := ExactConstantExtension C M S + let E_N := ExactConstantExtension C N S + letI : Field E_M := + functionFieldNormalClosureOriginalCompositumConstantExtensionField + K F S hExact + letI : Field E_N := + functionFieldNormalClosureConstantExtensionFieldForTower K F S + letI : Algebra E_M E_N := + functionFieldNormalClosureConstantExtensionTowerAlgebra K F S hExact + IsGalois E_M E_N := by + let C := FunctionFieldNormalClosureConstantField K F + let M := FunctionFieldNormalClosureOriginalCompositum K F hExact + let N := FunctionFieldNormalClosure K F + let : Algebra (RatFunc C) M := + functionFieldNormalClosureOriginalCompositumConstantRatFuncAlgebra + K F hExact + let : Algebra (RatFunc C) N := + functionFieldNormalClosureConstantRatFuncAlgebra K F + let : IsScalarTower (RatFunc C) M N := + functionFieldNormalClosureOriginalCompositumConstantRatFuncTower + K F hExact + let : Algebra C M := + exactConstantExtensionTowerCanonicalConstantAlgebra C M + let : Algebra C N := + exactConstantExtensionTowerCanonicalConstantAlgebra C N + let : SMul C M := Algebra.toSMul + let : SMul C N := Algebra.toSMul + let : SMul M N := Algebra.toSMul + let : IsScalarTower C M N := + exactConstantExtensionTowerCanonicalConstantScalarTower C M N + let E_M := ExactConstantExtension C M S + let E_N := ExactConstantExtension C N S + let : Field E_M := + functionFieldNormalClosureOriginalCompositumConstantExtensionField + K F S hExact + let : Field E_N := + functionFieldNormalClosureConstantExtensionFieldForTower K F S + let : Algebra E_M E_N := + functionFieldNormalClosureConstantExtensionTowerAlgebra K F S hExact + let : FiniteDimensional M N := + functionFieldNormalClosure_finiteDimensional_over_originalCompositum + K F hExact + let : IsGalois M N := + functionFieldNormalClosure_isGalois_over_originalCompositum K F hExact + exact exactConstantExtensionTower_isGalois C M N S + (functionFieldNormalClosureConstantField_isExact_for_constantRatFunc K F) + +/-- Extending the full constant field preserves the degree of the normal +closure over the original compositum. -/ +theorem functionFieldNormalClosureConstantExtension_finrank + (hExact : algebraicClosure K F = (⊥ : IntermediateField K F)) : + let C := FunctionFieldNormalClosureConstantField K F + let M := FunctionFieldNormalClosureOriginalCompositum K F hExact + let N := FunctionFieldNormalClosure K F + letI : Algebra C M := + exactConstantExtensionTowerCanonicalConstantAlgebra C M + letI : Algebra C N := + exactConstantExtensionTowerCanonicalConstantAlgebra C N + let E_M := ExactConstantExtension C M S + let E_N := ExactConstantExtension C N S + letI : Field E_M := + functionFieldNormalClosureOriginalCompositumConstantExtensionField + K F S hExact + letI : Field E_N := + functionFieldNormalClosureConstantExtensionFieldForTower K F S + letI : Algebra E_M E_N := + functionFieldNormalClosureConstantExtensionTowerAlgebra K F S hExact + letI : Module E_M E_N := Algebra.toModule + letI : Module.Finite E_M E_N := + functionFieldNormalClosureConstantExtension_finiteDimensional + K F S hExact + Module.finrank E_M E_N = Module.finrank M N := by + let C := FunctionFieldNormalClosureConstantField K F + let M := FunctionFieldNormalClosureOriginalCompositum K F hExact + let N := FunctionFieldNormalClosure K F + let : Algebra (RatFunc C) M := + functionFieldNormalClosureOriginalCompositumConstantRatFuncAlgebra + K F hExact + let : Algebra (RatFunc C) N := + functionFieldNormalClosureConstantRatFuncAlgebra K F + let : IsScalarTower (RatFunc C) M N := + functionFieldNormalClosureOriginalCompositumConstantRatFuncTower + K F hExact + let : Algebra C M := + exactConstantExtensionTowerCanonicalConstantAlgebra C M + let : Algebra C N := + exactConstantExtensionTowerCanonicalConstantAlgebra C N + let : SMul C M := Algebra.toSMul + let : SMul C N := Algebra.toSMul + let : SMul M N := Algebra.toSMul + let : IsScalarTower C M N := + exactConstantExtensionTowerCanonicalConstantScalarTower C M N + let E_M := ExactConstantExtension C M S + let E_N := ExactConstantExtension C N S + let : Field E_M := + functionFieldNormalClosureOriginalCompositumConstantExtensionField + K F S hExact + let : Field E_N := + functionFieldNormalClosureConstantExtensionFieldForTower K F S + let : Algebra E_M E_N := + functionFieldNormalClosureConstantExtensionTowerAlgebra K F S hExact + let : Module E_M E_N := Algebra.toModule + let : Module.Finite E_M E_N := + functionFieldNormalClosureConstantExtension_finiteDimensional + K F S hExact + let : FiniteDimensional M N := + functionFieldNormalClosure_finiteDimensional_over_originalCompositum + K F hExact + let : IsGalois M N := + functionFieldNormalClosure_isGalois_over_originalCompositum K F hExact + exact exactConstantExtensionTower_finrank C M N S + (functionFieldNormalClosureConstantField_isExact_for_constantRatFunc K F) + +/-- Consequently the specialized tower Galois group has the same +cardinality as the normal-closure group over the original compositum. -/ +theorem functionFieldNormalClosureConstantExtension_card_aut_eq + (hExact : algebraicClosure K F = (⊥ : IntermediateField K F)) : + let C := FunctionFieldNormalClosureConstantField K F + let M := FunctionFieldNormalClosureOriginalCompositum K F hExact + let N := FunctionFieldNormalClosure K F + letI : Algebra C M := + exactConstantExtensionTowerCanonicalConstantAlgebra C M + letI : Algebra C N := + exactConstantExtensionTowerCanonicalConstantAlgebra C N + let E_M := ExactConstantExtension C M S + let E_N := ExactConstantExtension C N S + letI : Field E_M := + functionFieldNormalClosureOriginalCompositumConstantExtensionField + K F S hExact + letI : Field E_N := + functionFieldNormalClosureConstantExtensionFieldForTower K F S + letI : Algebra E_M E_N := + functionFieldNormalClosureConstantExtensionTowerAlgebra K F S hExact + letI : Module E_M E_N := Algebra.toModule + letI : Module.Finite E_M E_N := + functionFieldNormalClosureConstantExtension_finiteDimensional + K F S hExact + letI : IsGalois E_M E_N := + functionFieldNormalClosureConstantExtension_isGalois K F S hExact + Nat.card (E_N ≃ₐ[E_M] E_N) = Nat.card (N ≃ₐ[M] N) := by + let C := FunctionFieldNormalClosureConstantField K F + let M := FunctionFieldNormalClosureOriginalCompositum K F hExact + let N := FunctionFieldNormalClosure K F + let : Algebra (RatFunc C) M := + functionFieldNormalClosureOriginalCompositumConstantRatFuncAlgebra + K F hExact + let : Algebra (RatFunc C) N := + functionFieldNormalClosureConstantRatFuncAlgebra K F + let : IsScalarTower (RatFunc C) M N := + functionFieldNormalClosureOriginalCompositumConstantRatFuncTower + K F hExact + let : Algebra C M := + exactConstantExtensionTowerCanonicalConstantAlgebra C M + let : Algebra C N := + exactConstantExtensionTowerCanonicalConstantAlgebra C N + let : SMul C M := Algebra.toSMul + let : SMul C N := Algebra.toSMul + let : SMul M N := Algebra.toSMul + let : IsScalarTower C M N := + exactConstantExtensionTowerCanonicalConstantScalarTower C M N + let E_M := ExactConstantExtension C M S + let E_N := ExactConstantExtension C N S + let : Field E_M := + functionFieldNormalClosureOriginalCompositumConstantExtensionField + K F S hExact + let : Field E_N := + functionFieldNormalClosureConstantExtensionFieldForTower K F S + let : Algebra E_M E_N := + functionFieldNormalClosureConstantExtensionTowerAlgebra K F S hExact + let : Module E_M E_N := Algebra.toModule + let : Module.Finite E_M E_N := + functionFieldNormalClosureConstantExtension_finiteDimensional + K F S hExact + let : IsGalois E_M E_N := + functionFieldNormalClosureConstantExtension_isGalois K F S hExact + let : FiniteDimensional M N := + functionFieldNormalClosure_finiteDimensional_over_originalCompositum + K F hExact + let : IsGalois M N := + functionFieldNormalClosure_isGalois_over_originalCompositum K F hExact + exact exactConstantExtensionTower_card_aut_eq C M N S + (functionFieldNormalClosureConstantField_isExact_for_constantRatFunc K F) + +/-- The rational-place count of the extended original compositum is the +packaged level-one exact constant-extension count of that compositum. -/ +theorem + normalClosureOriginalCompositum_rationalPlaceCount_eq_exactExtensionCount + (hExact : algebraicClosure K F = (⊥ : IntermediateField K F)) : + let C := FunctionFieldNormalClosureConstantField K F + let M := FunctionFieldNormalClosureOriginalCompositum K F hExact + letI : Algebra (RatFunc C) M := + functionFieldNormalClosureOriginalCompositumConstantRatFuncAlgebra + K F hExact + letI : Algebra C M := + exactConstantExtensionTowerCanonicalConstantAlgebra C M + let hExactM := + functionFieldNormalClosureOriginalCompositumConstantField_isExact_for_constantRatFunc + K F hExact + let E_M := ExactConstantExtension C M S + letI : Field E_M := + functionFieldNormalClosureOriginalCompositumConstantExtensionField + K F S hExact + letI : Algebra (RatFunc S) E_M := + functionFieldNormalClosureOriginalCompositumConstantExtensionRatFuncAlgebra + K F S hExact + letI : Module (RatFunc S) E_M := Algebra.toModule + letI : Module.Finite (RatFunc S) E_M := + finiteDimensional_over_extendedRatFunc C S M hExactM + letI : Algebra.IsSeparable (RatFunc S) E_M := + isSeparable_over_extendedRatFunc C S M hExactM + letI : Fintype C := Fintype.ofFinite C + letI : Finite S := Module.finite_of_finite C + letI : Fintype S := + Fintype.ofFinite S + letI : DecidableEq C := Classical.decEq C + letI : DecidableEq (RatFunc C) := Classical.decEq (RatFunc C) + letI : DecidableEq S := Classical.decEq S + letI : DecidableEq (RatFunc S) := Classical.decEq (RatFunc S) + finiteExtensionRationalPlaceCount S E_M = + exactConstantExtensionClosedPlaceExtensionCount C S M hExactM 1 := by + let C := FunctionFieldNormalClosureConstantField K F + let M := FunctionFieldNormalClosureOriginalCompositum K F hExact + let : Algebra (RatFunc C) M := + functionFieldNormalClosureOriginalCompositumConstantRatFuncAlgebra + K F hExact + let : Algebra C M := + exactConstantExtensionTowerCanonicalConstantAlgebra C M + let hExactM := + functionFieldNormalClosureOriginalCompositumConstantField_isExact_for_constantRatFunc + K F hExact + let E_M := ExactConstantExtension C M S + let : Field E_M := + functionFieldNormalClosureOriginalCompositumConstantExtensionField + K F S hExact + let : Algebra (RatFunc S) E_M := + functionFieldNormalClosureOriginalCompositumConstantExtensionRatFuncAlgebra + K F S hExact + let : Module (RatFunc S) E_M := Algebra.toModule + let : Module.Finite (RatFunc S) E_M := + finiteDimensional_over_extendedRatFunc C S M hExactM + let : Algebra.IsSeparable (RatFunc S) E_M := + isSeparable_over_extendedRatFunc C S M hExactM + let : Fintype C := Fintype.ofFinite C + let : Finite S := Module.finite_of_finite C + let : Fintype S := + Fintype.ofFinite S + let : DecidableEq C := Classical.decEq C + let : DecidableEq (RatFunc C) := Classical.decEq (RatFunc C) + let : DecidableEq S := Classical.decEq S + let : DecidableEq (RatFunc S) := Classical.decEq (RatFunc S) + exact + (exactConstantExtensionClosedPlaceExtensionCount_one_eq_rationalPlaceCount + C S M hExactM).symm + +/-- Combining the exact splitting formula with the canonical +`C(X)`-equivalence `C ⊗[K] F ≃ CF` identifies the same rational-place count +with the packaged exact-extension count of the original function field at +level `[S : C]`. -/ +theorem + normalClosureOriginalCompositum_rationalPlaceCount_eq_originalExactExtensionCount + (hExact : algebraicClosure K F = (⊥ : IntermediateField K F)) : + let N := FunctionFieldNormalClosure K F + let : Algebra K N := functionFieldNormalClosureConstantAlgebra K F + let C := FunctionFieldNormalClosureConstantField K F + let : Algebra K C := + SubalgebraClass.toAlgebra (algebraicClosure K N) + let : Module.Finite K C := + functionFieldConstantField_finiteDimensional K N + let : IsGalois K C := functionFieldConstantField_isGalois K N + let M := FunctionFieldNormalClosureOriginalCompositum K F hExact + let : Algebra (RatFunc C) M := + functionFieldNormalClosureOriginalCompositumConstantRatFuncAlgebra + K F hExact + let : Algebra C M := + exactConstantExtensionTowerCanonicalConstantAlgebra C M + let hExactM := + functionFieldNormalClosureOriginalCompositumConstantField_isExact_for_constantRatFunc + K F hExact + let E_M := ExactConstantExtension C M S + let : Field E_M := + functionFieldNormalClosureOriginalCompositumConstantExtensionField + K F S hExact + let : Algebra (RatFunc S) E_M := + functionFieldNormalClosureOriginalCompositumConstantExtensionRatFuncAlgebra + K F S hExact + let : Module (RatFunc S) E_M := Algebra.toModule + let : Module.Finite (RatFunc S) E_M := + finiteDimensional_over_extendedRatFunc C S M hExactM + let : Algebra.IsSeparable (RatFunc S) E_M := + isSeparable_over_extendedRatFunc C S M hExactM + let : Finite C := functionFieldConstantField_finite K N + let : Fintype C := Fintype.ofFinite C + let : Finite S := Module.finite_of_finite C + let : Fintype S := Fintype.ofFinite S + let : DecidableEq C := Classical.decEq C + let : DecidableEq (RatFunc C) := Classical.decEq (RatFunc C) + let : DecidableEq S := Classical.decEq S + let : DecidableEq (RatFunc S) := Classical.decEq (RatFunc S) + finiteExtensionRationalPlaceCount S E_M = + exactConstantExtensionClosedPlaceExtensionCount + K C F hExact (Module.finrank C S) := by + intro N model1 C model3 model4 model5 M model7 model8 hExactM E_M + model11 model12 model13 model14 model15 model16 model17 model18 model19 + model20 model21 model22 model23 + classical + let : Module (RatFunc C) M := model7.toModule + let : FiniteDimensional (RatFunc C) M := + functionFieldNormalClosureOriginalCompositum_finiteDimensional_over_constantRatFunc K F hExact + let : Algebra.IsSeparable (RatFunc C) M := + functionFieldNormalClosureOriginalCompositum_isSeparable_over_constantRatFunc K F hExact + let E := ExactConstantExtension K F C + let : Field E := exactConstantExtensionField K F C hExact + let : Algebra (RatFunc C) E := ratFuncExactConstantExtensionAlgebra K C F hExact + let : Module (RatFunc C) E := Algebra.toModule + let : FiniteDimensional (RatFunc C) E := + finiteDimensional_over_extendedRatFunc K C F hExact + let : Algebra.IsSeparable (RatFunc C) E := + isSeparable_over_extendedRatFunc K C F hExact + let e : E ≃ₐ[RatFunc C] M := + exactConstantExtensionOriginalCompositumCanonicalRatFuncAlgEquiv K F hExact + have hRational := rationalExactConstantCount_eq_of_algEquiv C S M E hExactM e + have hLast := exactConstantExtensionClosedPlaceExtensionCount_eq_classical_decidableEq + K C F hExact (Module.finrank C S) + exact hRational.trans hLast.symm + +end ConstantExtension + +end CanonicalNormalClosureTower + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionQuotient.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionQuotient.lean new file mode 100644 index 0000000000..a9afc18c28 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionQuotient.lean @@ -0,0 +1,263 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionAutomorphism + +/-! +# The Frobenius quotient of an exact constant extension + +The direct-product description of the constant extension gives a canonical +quotient from its full Galois group to the Galois group of the enlarged +constants. Its kernel is exactly the original function-field Galois group. +When the constants are finite, the Frobenius fiber is explicitly equivalent +to that kernel; these are the twists used in the lower-bound argument. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +noncomputable section + +variable (C L N S : Type*) [Field C] [Field L] [Field N] [Field S] + [Algebra C L] [Algebra L N] [Algebra C N] [IsScalarTower C L N] + [Algebra C S] [FiniteDimensional C S] [IsGalois C S] + [FiniteDimensional L N] [IsGalois L N] + +/-- Restriction to the enlarged constants, defined through the proved +direct-product description of the full Galois group. -/ +noncomputable def exactConstantExtensionConstantQuotient + (hExact : algebraicClosure C N = (⊥ : IntermediateField C N)) : + letI := exactConstantExtensionField C N S hExact + letI := exactConstantExtensionBaseAlgebra C L N S + (ExactConstantExtension C N S ≃ₐ[L] ExactConstantExtension C N S) →* + (S ≃ₐ[C] S) := by + letI := exactConstantExtensionField C N S hExact + letI := exactConstantExtensionBaseAlgebra C L N S + exact (MonoidHom.fst (S ≃ₐ[C] S) (N ≃ₐ[L] N)).comp + (exactConstantExtensionAutMulEquiv C L N S hExact).symm.toMonoidHom + +/-- On an automorphism assembled from its two tensor factors, the constant +quotient returns the first factor. -/ +theorem exactConstantExtensionConstantQuotient_combined + (hExact : algebraicClosure C N = (⊥ : IntermediateField C N)) + (σ : S ≃ₐ[C] S) (g : N ≃ₐ[L] N) : + letI := exactConstantExtensionField C N S hExact + letI := exactConstantExtensionBaseAlgebra C L N S + exactConstantExtensionConstantQuotient C L N S hExact + (exactConstantExtensionCombinedAutHom C L N S (σ, g)) = σ := by + let := exactConstantExtensionField C N S hExact + let := exactConstantExtensionBaseAlgebra C L N S + let e := exactConstantExtensionAutMulEquiv C L N S hExact + change (e.symm (e (σ, g))).1 = σ + rw [e.symm_apply_apply] + +/-- The constant quotient records exactly how a full automorphism acts on +the embedded enlarged constant field. -/ +theorem exactConstantExtensionConstantQuotient_action_on_constants + (hExact : algebraicClosure C N = (⊥ : IntermediateField C N)) + (g : letI := exactConstantExtensionField C N S hExact + letI := exactConstantExtensionBaseAlgebra C L N S + ExactConstantExtension C N S ≃ₐ[L] ExactConstantExtension C N S) + (s : S) : + letI := exactConstantExtensionField C N S hExact + letI := exactConstantExtensionBaseAlgebra C L N S + g (Algebra.TensorProduct.includeLeft + (R := C) (S := C) (A := S) (B := N) s) = + Algebra.TensorProduct.includeLeft + (R := C) (S := C) (A := S) (B := N) + (exactConstantExtensionConstantQuotient C L N S hExact g s) := by + let := exactConstantExtensionField C N S hExact + let := exactConstantExtensionBaseAlgebra C L N S + let e := exactConstantExtensionAutMulEquiv C L N S hExact + let p := e.symm g + have hgp : e p = g := e.apply_symm_apply g + rw [← hgp] + have hq := exactConstantExtensionConstantQuotient_combined + C L N S hExact p.1 p.2 + change exactConstantExtensionCombinedAutHom C L N S p + (Algebra.TensorProduct.includeLeft + (R := C) (S := C) (A := S) (B := N) s) = + Algebra.TensorProduct.includeLeft + (R := C) (S := C) (A := S) (B := N) + (exactConstantExtensionConstantQuotient C L N S hExact (e p) s) + rw [show e p = exactConstantExtensionCombinedAutHom C L N S p by rfl] + rw [hq] + simp [exactConstantExtensionCombinedAutHom, + exactConstantExtensionConstantAutHom, + exactConstantExtensionFunctionAutHom, + exactConstantExtensionConstantAlgEquivOverBase, + exactConstantExtensionFunctionAlgEquivOverBase, + Algebra.TensorProduct.includeLeft_apply] + +/-- The constant quotient is onto. -/ +theorem exactConstantExtensionConstantQuotient_surjective + (hExact : algebraicClosure C N = (⊥ : IntermediateField C N)) : + letI := exactConstantExtensionField C N S hExact + letI := exactConstantExtensionBaseAlgebra C L N S + Function.Surjective + (exactConstantExtensionConstantQuotient C L N S hExact) := by + let := exactConstantExtensionField C N S hExact + let := exactConstantExtensionBaseAlgebra C L N S + intro σ + refine ⟨exactConstantExtensionCombinedAutHom C L N S + (σ, (1 : N ≃ₐ[L] N)), ?_⟩ + exact exactConstantExtensionConstantQuotient_combined + C L N S hExact σ 1 + +/-- The kernel of the constant quotient is precisely the image of the +function-field action. -/ +theorem exactConstantExtensionConstantQuotient_ker : + ∀ (hExact : algebraicClosure C N = (⊥ : IntermediateField C N)), + letI := exactConstantExtensionField C N S hExact + letI := exactConstantExtensionBaseAlgebra C L N S + (exactConstantExtensionConstantQuotient C L N S hExact).ker = + (exactConstantExtensionFunctionAutHom C L N S).range := by + intro hExact + let := exactConstantExtensionField C N S hExact + let := exactConstantExtensionBaseAlgebra C L N S + ext x + constructor + · intro hx + let e := exactConstantExtensionAutMulEquiv C L N S hExact + let p := e.symm x + have hpFirst : p.1 = 1 := by + have hx' := (MonoidHom.mem_ker.mp hx) + change p.1 = 1 at hx' + exact hx' + refine ⟨p.2, ?_⟩ + have hp : (1, p.2) = p := by + apply Prod.ext + · exact hpFirst.symm + · rfl + change exactConstantExtensionFunctionAutHom C L N S p.2 = x + calc + exactConstantExtensionFunctionAutHom C L N S p.2 = + exactConstantExtensionCombinedAutHom C L N S (1, p.2) := by + simp [exactConstantExtensionCombinedAutHom] + _ = e (1, p.2) := rfl + _ = e p := congrArg e hp + _ = x := e.apply_symm_apply x + · rintro ⟨g, rfl⟩ + apply MonoidHom.mem_ker.mpr + have h := exactConstantExtensionConstantQuotient_combined + C L N S hExact (1 : S ≃ₐ[C] S) g + simpa [exactConstantExtensionCombinedAutHom] using h + +omit [FiniteDimensional C S] [IsGalois C S] + [FiniteDimensional L N] [IsGalois L N] in +/-- The constant-factor action is faithful. -/ +theorem exactConstantExtensionConstantAutHom_injective : + letI := exactConstantExtensionBaseAlgebra C L N S + Function.Injective (exactConstantExtensionConstantAutHom C L N S) := by + let := exactConstantExtensionBaseAlgebra C L N S + intro σ τ h + have hpair := exactConstantExtensionCombinedAutHom_injective C L N S + (show exactConstantExtensionCombinedAutHom C L N S + (σ, (1 : N ≃ₐ[L] N)) = + exactConstantExtensionCombinedAutHom C L N S + (τ, (1 : N ≃ₐ[L] N)) by + simpa [exactConstantExtensionCombinedAutHom] using h) + exact congrArg Prod.fst hpair + +section Finite + +variable [Fintype C] [Finite S] + +/-- Frobenius on `S / C`, lifted to the tensor compositum while fixing `N`. -/ +noncomputable def exactConstantExtensionFrobenius : + letI := exactConstantExtensionBaseAlgebra C L N S + ExactConstantExtension C N S ≃ₐ[L] ExactConstantExtension C N S := by + letI := exactConstantExtensionBaseAlgebra C L N S + exact exactConstantExtensionConstantAutHom C L N S + (FiniteField.frobeniusAlgEquivOfAlgebraic C S) + +omit [FiniteDimensional C S] [FiniteDimensional L N] [IsGalois L N] in +/-- The lifted Frobenius has order `[S : C]`. -/ +theorem orderOf_exactConstantExtensionFrobenius : + letI := exactConstantExtensionBaseAlgebra C L N S + orderOf (exactConstantExtensionFrobenius C L N S) = + Module.finrank C S := by + let := exactConstantExtensionBaseAlgebra C L N S + change orderOf ((exactConstantExtensionConstantAutHom C L N S) + (FiniteField.frobeniusAlgEquivOfAlgebraic C S)) = _ + rw [orderOf_injective (exactConstantExtensionConstantAutHom C L N S) + (exactConstantExtensionConstantAutHom_injective C L N S)] + exact FiniteField.orderOf_frobeniusAlgEquivOfAlgebraic C S + +omit [Finite S] in +/-- The constant quotient sends the lifted Frobenius to finite-field +Frobenius. -/ +theorem exactConstantExtensionConstantQuotient_frobenius + (hExact : algebraicClosure C N = (⊥ : IntermediateField C N)) : + letI := exactConstantExtensionField C N S hExact + letI := exactConstantExtensionBaseAlgebra C L N S + exactConstantExtensionConstantQuotient C L N S hExact + (exactConstantExtensionFrobenius C L N S) = + FiniteField.frobeniusAlgEquivOfAlgebraic C S := by + let := exactConstantExtensionField C N S hExact + let := exactConstantExtensionBaseAlgebra C L N S + have h := exactConstantExtensionConstantQuotient_combined + C L N S hExact (FiniteField.frobeniusAlgEquivOfAlgebraic C S) + (1 : N ≃ₐ[L] N) + simpa [exactConstantExtensionFrobenius, + exactConstantExtensionCombinedAutHom] using h + +omit [Finite S] in +/-- The Frobenius fiber of the constant quotient is parametrized exactly by +the original function-field Galois group. -/ +noncomputable def exactConstantExtensionFrobeniusFiberEquiv + (hExact : algebraicClosure C N = (⊥ : IntermediateField C N)) : + letI := exactConstantExtensionField C N S hExact + letI := exactConstantExtensionBaseAlgebra C L N S + (N ≃ₐ[L] N) ≃ + (exactConstantExtensionConstantQuotient C L N S hExact ⁻¹' + ({FiniteField.frobeniusAlgEquivOfAlgebraic C S} : Set (S ≃ₐ[C] S))) := by + letI := exactConstantExtensionField C N S hExact + letI := exactConstantExtensionBaseAlgebra C L N S + let e := exactConstantExtensionAutMulEquiv C L N S hExact + let φ := FiniteField.frobeniusAlgEquivOfAlgebraic C S + exact + { toFun := fun g => + ⟨e (φ, g), exactConstantExtensionConstantQuotient_combined + C L N S hExact φ g⟩ + invFun := fun x => (e.symm x.1).2 + left_inv := fun g => by simp + right_inv := fun x => by + apply Subtype.ext + have hfirst : (e.symm x.1).1 = φ := x.2 + have hp : (φ, (e.symm x.1).2) = e.symm x.1 := by + apply Prod.ext + · exact hfirst.symm + · rfl + calc + e (φ, (e.symm x.1).2) = e (e.symm x.1) := congrArg e hp + _ = x.1 := e.apply_symm_apply x.1 } + +omit [Finite S] in +/-- Consequently the Frobenius fiber has the same cardinality as +`Gal(N/L)`. -/ +theorem natCard_exactConstantExtensionFrobeniusFiber + (hExact : algebraicClosure C N = (⊥ : IntermediateField C N)) : + letI := exactConstantExtensionField C N S hExact + letI := exactConstantExtensionBaseAlgebra C L N S + Nat.card + (exactConstantExtensionConstantQuotient C L N S hExact ⁻¹' + ({FiniteField.frobeniusAlgEquivOfAlgebraic C S} : + Set (S ≃ₐ[C] S))) = + Nat.card (N ≃ₐ[L] N) := by + let := exactConstantExtensionField C N S hExact + let := exactConstantExtensionBaseAlgebra C L N S + exact Nat.card_congr + (exactConstantExtensionFrobeniusFiberEquiv C L N S hExact).symm + +end Finite + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionRationalPlaceCount.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionRationalPlaceCount.lean new file mode 100644 index 0000000000..ec5ebacbdf --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionRationalPlaceCount.lean @@ -0,0 +1,82 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionZetaDegreeIndexOne +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneAffineHasseWeilFromZeta + +/-! +# Rational-place count of an exact constant extension + +The packaged exact constant-extension count at level one is definitionally +the complete rational-place count of the scalar-extended function field. +This small bridge keeps the instance choices used by the global splitting +formula explicit. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +noncomputable section + +variable (C S N : Type*) [Field C] [Fintype C] + [DecidableEq C] [DecidableEq (RatFunc C)] + [Field S] [Fintype S] + [Algebra C S] [FiniteDimensional C S] [IsGalois C S] + [Field N] [Algebra (RatFunc C) N] + [FiniteDimensional (RatFunc C) N] + [Algebra.IsSeparable (RatFunc C) N] + +local instance rationalCountBaseConstantAlgebra : Algebra C N := + bridgeBaseConstantAlgebra C N + +local instance rationalCountBaseConstantTower : + IsScalarTower C (RatFunc C) N := + IsScalarTower.of_algebraMap_eq' rfl + +omit [Fintype C] [DecidableEq C] [DecidableEq (RatFunc C)] in +/-- The packaged level-one exact-extension count is the complete rational +place count of the extended function field. -/ +theorem exactConstantExtensionClosedPlaceExtensionCount_one_eq_rationalPlaceCount + (hExact : algebraicClosure C N = + (⊥ : IntermediateField C N)) : + exactConstantExtensionClosedPlaceExtensionCount C S N hExact 1 = + (by + let E := ExactConstantExtension C N S + letI : Field E := exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc S) E := + ratFuncExactConstantExtensionAlgebra C S N hExact + letI : SMul (RatFunc S) E := Algebra.toSMul + letI : Module (RatFunc S) E := Algebra.toModule + letI : FiniteDimensional (RatFunc S) E := + finiteDimensional_over_extendedRatFunc C S N hExact + letI : Algebra.IsSeparable (RatFunc S) E := + isSeparable_over_extendedRatFunc C S N hExact + letI : DecidableEq S := Classical.decEq S + letI : DecidableEq (RatFunc S) := Classical.decEq (RatFunc S) + exact finiteExtensionRationalPlaceCount S E) := by + classical + let E := ExactConstantExtension C N S + let : Field E := exactConstantExtensionField C N S hExact + let : Algebra (RatFunc S) E := + ratFuncExactConstantExtensionAlgebra C S N hExact + let : SMul (RatFunc S) E := Algebra.toSMul + let : Module (RatFunc S) E := Algebra.toModule + let : FiniteDimensional (RatFunc S) E := + finiteDimensional_over_extendedRatFunc C S N hExact + let : Algebra.IsSeparable (RatFunc S) E := + isSeparable_over_extendedRatFunc C S N hExact + change exactConstantExtensionClosedPlaceExtensionCount + C S N hExact 1 = finiteExtensionRationalPlaceCount S E + rw [exactConstantExtensionClosedPlaceExtensionCount_eq_classical_decidableEq] + exact finiteExtensionClosedPlaceExtensionCount_one_eq_rationalPlaceCount + S E + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionRegularity.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionRegularity.lean new file mode 100644 index 0000000000..983e934866 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionRegularity.lean @@ -0,0 +1,198 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.FunctionFieldNormalClosureConstantBase + +/-! +# Regular constant extensions + +An exact constant field makes finite Galois extensions of the constants +linearly disjoint from the function field. The existing tensor-product +construction therefore remains a field and its full Galois group is a direct +product. This file records the corresponding intrinsic statement: the +original function-field Galois group is exactly the subgroup acting trivially +on the enlarged constants. + +The final declarations specialize these facts to the normal closure used in +the Hasse--Weil development. They concern the proved constant base `C(t)`; +they do not assert compatibility with the not-yet-defined compositum `C F` of +an arbitrary intermediate function field `F`. +-/ + +@[expose] public section + +open scoped TensorProduct + +namespace BGS.HasseWeil + +noncomputable section + +variable (C L N S : Type*) [Field C] [Field L] [Field N] [Field S] + [Algebra C L] [Algebra L N] [Algebra C N] [IsScalarTower C L N] + [Algebra C S] [FiniteDimensional C S] [IsGalois C S] + [FiniteDimensional L N] [IsGalois L N] + +/-- The action of the original function-field Galois group, regarded as an +automorphism of the constant extension that acts trivially on the enlarged +constants. -/ +noncomputable def exactConstantExtensionFunctionAutHomToConstantKernel + (hExact : algebraicClosure C N = (⊥ : IntermediateField C N)) : + let := exactConstantExtensionField C N S hExact + let := exactConstantExtensionBaseAlgebra C L N S + (N ≃ₐ[L] N) →* + (exactConstantExtensionConstantQuotient C L N S hExact).ker := by + intro fieldModel algebraModel + let f := exactConstantExtensionFunctionAutHom C L N S + exact + { toFun := fun g => ⟨f g, by + rw [exactConstantExtensionConstantQuotient_ker C L N S hExact] + exact ⟨g, rfl⟩⟩ + map_one' := by + apply Subtype.ext + exact map_one f + map_mul' := by + intro g h + apply Subtype.ext + exact map_mul f g h } + +theorem exactConstantExtensionFunctionAutHomToConstantKernel_injective + (hExact : algebraicClosure C N = (⊥ : IntermediateField C N)) : + let := exactConstantExtensionField C N S hExact + let := exactConstantExtensionBaseAlgebra C L N S + Function.Injective + (exactConstantExtensionFunctionAutHomToConstantKernel C L N S hExact) := by + intro fieldModel algebraModel + intro g h hgh + have hfun : exactConstantExtensionFunctionAutHom C L N S g = + exactConstantExtensionFunctionAutHom C L N S h := + congrArg Subtype.val hgh + have hp := exactConstantExtensionCombinedAutHom_injective C L N S + (show exactConstantExtensionCombinedAutHom C L N S (1, g) = + exactConstantExtensionCombinedAutHom C L N S (1, h) by + simpa [exactConstantExtensionCombinedAutHom] using hfun) + exact congrArg Prod.snd hp + +theorem exactConstantExtensionFunctionAutHomToConstantKernel_surjective + (hExact : algebraicClosure C N = (⊥ : IntermediateField C N)) : + let := exactConstantExtensionField C N S hExact + let := exactConstantExtensionBaseAlgebra C L N S + Function.Surjective + (exactConstantExtensionFunctionAutHomToConstantKernel C L N S hExact) := by + intro fieldModel algebraModel + intro x + have hx : x.1 ∈ (exactConstantExtensionFunctionAutHom C L N S).range := by + rw [← exactConstantExtensionConstantQuotient_ker C L N S hExact] + exact x.property + obtain ⟨g, hg⟩ := hx + refine ⟨g, ?_⟩ + apply Subtype.ext + exact hg + +/-- Exact finite constant extension preserves the function-field Galois group: +it is canonically the kernel of restriction from the full extended Galois +group to the Galois group of the enlarged constants. -/ +noncomputable def exactConstantExtensionFunctionAutMulEquiv + (hExact : algebraicClosure C N = (⊥ : IntermediateField C N)) : + let := exactConstantExtensionField C N S hExact + let := exactConstantExtensionBaseAlgebra C L N S + (N ≃ₐ[L] N) ≃* + (exactConstantExtensionConstantQuotient C L N S hExact).ker := by + intro fieldModel algebraModel + exact MulEquiv.ofBijective + (exactConstantExtensionFunctionAutHomToConstantKernel C L N S hExact) + ⟨exactConstantExtensionFunctionAutHomToConstantKernel_injective + C L N S hExact, + exactConstantExtensionFunctionAutHomToConstantKernel_surjective + C L N S hExact⟩ + +section NormalClosure + +variable (K F S : Type*) [Field K] [Field F] [Field S] + [Fintype K] [DecidableEq K] [DecidableEq (RatFunc K)] + [Algebra (RatFunc K) F] [FiniteDimensional (RatFunc K) F] + [Algebra.IsSeparable (RatFunc K) F] + [Algebra (FunctionFieldNormalClosureConstantField K F) S] + [FiniteDimensional (FunctionFieldNormalClosureConstantField K F) S] + [IsGalois (FunctionFieldNormalClosureConstantField K F) S] + +omit [Fintype K] [DecidableEq K] [DecidableEq (RatFunc K)] [FiniteDimensional (RatFunc K) F] in +/-- A finite Galois extension of the exact constants has field-valued tensor +product with the function-field normal closure. -/ +theorem functionFieldNormalClosureConstantExtensionTensor_isField : + IsField (ExactConstantExtension + (FunctionFieldNormalClosureConstantField K F) + (FunctionFieldNormalClosure K F) S) := + exactConstantExtensionTensor_isField + (FunctionFieldNormalClosureConstantField K F) + (FunctionFieldNormalClosure K F) S + (functionFieldNormalClosureConstantField_isExact K F) + +omit [Fintype K] [DecidableEq K] [DecidableEq (RatFunc K)] [FiniteDimensional (RatFunc K) F] + [FiniteDimensional (↥(FunctionFieldNormalClosureConstantField K F)) S] + [IsGalois (↥(FunctionFieldNormalClosureConstantField K F)) S] in +/-- The constant extension has the expected degree over the original normal +closure. -/ +theorem functionFieldNormalClosureConstantExtension_finrank_over_normalClosure : + let := exactConstantExtensionAlgebra + (FunctionFieldNormalClosureConstantField K F) + (FunctionFieldNormalClosure K F) S + let : SMul (FunctionFieldNormalClosure K F) + (ExactConstantExtension (FunctionFieldNormalClosureConstantField K F) + (FunctionFieldNormalClosure K F) S) := Algebra.toSMul + let : Module (FunctionFieldNormalClosure K F) + (ExactConstantExtension (FunctionFieldNormalClosureConstantField K F) + (FunctionFieldNormalClosure K F) S) := Algebra.toModule + Module.finrank (FunctionFieldNormalClosure K F) + (ExactConstantExtension + (FunctionFieldNormalClosureConstantField K F) + (FunctionFieldNormalClosure K F) S) = + Module.finrank (FunctionFieldNormalClosureConstantField K F) S := by + exact exactConstantExtension_finrank + (FunctionFieldNormalClosureConstantField K F) + (FunctionFieldNormalClosure K F) S + +omit [Fintype K] [DecidableEq K] [DecidableEq (RatFunc K)] in +/-- The normal closure remains Galois over its proved constant base after a +finite Galois extension of the exact constants. -/ +theorem functionFieldNormalClosureConstantExtension_isGalois_over_constantBase : + let C := FunctionFieldNormalClosureConstantField K F + let B := FunctionFieldNormalClosureConstantBase K F + let N := FunctionFieldNormalClosure K F + let hExact := functionFieldNormalClosureConstantField_isExact K F + let := exactConstantExtensionField C N S hExact + let := exactConstantExtensionBaseAlgebra C B N S + IsGalois B (ExactConstantExtension C N S) := by + exact exactConstantExtension_isGalois + (FunctionFieldNormalClosureConstantField K F) + (FunctionFieldNormalClosureConstantBase K F) + (FunctionFieldNormalClosure K F) S + (functionFieldNormalClosureConstantField_isExact K F) + +/-- In the normal-closure setting, the original geometric Galois group is the +kernel of restriction to the enlarged constants. -/ +noncomputable def + functionFieldNormalClosureConstantExtensionFunctionAutMulEquiv : + let C := FunctionFieldNormalClosureConstantField K F + let B := FunctionFieldNormalClosureConstantBase K F + let N := FunctionFieldNormalClosure K F + let hExact := functionFieldNormalClosureConstantField_isExact K F + let := exactConstantExtensionField C N S hExact + let := exactConstantExtensionBaseAlgebra C B N S + (N ≃ₐ[B] N) ≃* + (exactConstantExtensionConstantQuotient C B N S hExact).ker := by + exact exactConstantExtensionFunctionAutMulEquiv + (FunctionFieldNormalClosureConstantField K F) + (FunctionFieldNormalClosureConstantBase K F) + (FunctionFieldNormalClosure K F) S + (functionFieldNormalClosureConstantField_isExact K F) + +end NormalClosure + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionTotalDifferentDegree.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionTotalDifferentDegree.lean new file mode 100644 index 0000000000..b21fb13013 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionTotalDifferentDegree.lean @@ -0,0 +1,222 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.ConstantExtensionClosedPlaceSplittingFormula +public import LeanPool.MarkoffModP.BGS.HasseWeil.FinsuppWeightedFiber +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionTotalDifferentEffectiveDivisor + +/-! +# Total different degree under exact constant extension + +This file separates the global weighted-degree cancellation from the local +normalization compatibility needed for invariance of the different under an +exact extension of finite constants. + +The theorem below assumes only pointwise equality of the total-different +multiplicity on a presented upstairs place and its contracted downstairs +place. The exhaustive presented-place equivalence, the division-by-gcd +degree formula, and the matching gcd fiber cardinality then prove equality of +the total finite-plus-infinity different degrees. The remaining pointwise +hypothesis is intended to be discharged branchwise by the finite and +reciprocal-infinity different-map theorems. +-/ + +@[expose] public section + +open scoped Polynomial + +namespace BGS.HasseWeil + +noncomputable section + +open BGS.CorvajaZannier + +variable (C S N : Type*) [Field C] [Field S] [Field N] + [Fintype C] [Finite S] + [Algebra (RatFunc C) N] [FiniteDimensional (RatFunc C) N] + [Algebra.IsSeparable (RatFunc C) N] + [Algebra C S] [FiniteDimensional C S] [IsGalois C S] + +local instance (priority := 10000) + exactConstantTotalDifferentConstantsDecidableEq + (K : Type*) [Field K] : DecidableEq K := + infinityBridgeDecidableEqConstants K + +local instance (priority := 10001) + exactConstantTotalDifferentRatFuncDecidableEq + (K : Type*) [Field K] : DecidableEq (RatFunc K) := + infinityBridgeDecidableEqRatFuncConstants K + +local instance exactConstantTotalDifferentBaseConstantAlgebra : Algebra C N := + bridgeBaseConstantAlgebra C N + +local instance exactConstantTotalDifferentBaseConstantTower : + IsScalarTower C (RatFunc C) N := + IsScalarTower.of_algebraMap_eq' rfl + +local instance (priority := 10) + exactConstantTotalDifferentBasePolynomialAlgebra : Algebra C[X] N := + RingHom.toAlgebra ((algebraMap (RatFunc C) N).comp + (algebraMap C[X] (RatFunc C))) + +local instance exactConstantTotalDifferentBasePolynomialTower : + IsScalarTower C[X] (RatFunc C) N := + IsScalarTower.of_algebraMap_eq' rfl + +/-- If the total-different multiplicity is preserved at every presented +place, then an exact extension of finite constants preserves the total +finite-plus-infinity different degree. -/ +theorem exactConstantExtension_totalDifferentDegree_eq_of_presentedMultiplicity + (hExact : algebraicClosure C N = + (⊥ : IntermediateField C N)) : + let E := ExactConstantExtension C N S + letI : Field E := exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) E := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + letI : SMul (RatFunc C) E := Algebra.toSMul + letI : Module (RatFunc C) E := Algebra.toModule + letI : FiniteDimensional (RatFunc C) E := + finiteDimensional_exactConstantExtension_over_baseRatFunc + C S N hExact + letI : Algebra.IsSeparable (RatFunc C) E := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + letI : Algebra (RatFunc S) E := + ratFuncExactConstantExtensionAlgebra C S N hExact + letI : SMul (RatFunc S) E := Algebra.toSMul + letI : Module (RatFunc S) E := Algebra.toModule + letI : Algebra S[X] E := + constantExtensionTensorPolynomialAlgebra C S N + letI : SMul S[X] E := Algebra.toSMul + letI : Module S[X] E := Algebra.toModule + letI : IsScalarTower S[X] (RatFunc S) E := + IsScalarTower.of_algebraMap_eq' (by + apply DFunLike.ext _ _ + intro p + change algebraMap S[X] E p = + ratFuncToExactConstantExtension C S N hExact + (algebraMap S[X] (RatFunc S) p) + exact + (ratFuncToExactConstantExtension_algebraMap C S N hExact p).symm) + letI : FiniteDimensional (RatFunc S) E := + finiteDimensional_over_extendedRatFunc C S N hExact + letI : Algebra.IsSeparable (RatFunc S) E := + isSeparable_over_extendedRatFunc C S N hExact + (∀ q : ExactConstantExtensionPresentedPlace C S N, + finiteExtensionTotalDifferentEffectiveDivisor S E + (exactConstantExtensionPresentedUpstairsPlaceEquiv + C S N hExact q) = + finiteExtensionTotalDifferentEffectiveDivisor C N + (exactConstantExtensionPresentedDownstairsPlace + C S N hExact q)) → + finiteExtensionFiniteDifferentDegree S E + (finiteExtensionFiniteDifferentIdeal_ne_bot S E) + + infinityDifferentDegree S E = + finiteExtensionFiniteDifferentDegree C N + (finiteExtensionFiniteDifferentIdeal_ne_bot C N) + + infinityDifferentDegree C N := by + dsimp only + let E := ExactConstantExtension C N S + let : Field E := exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) E := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : SMul (RatFunc C) E := Algebra.toSMul + let : Module (RatFunc C) E := Algebra.toModule + let : FiniteDimensional (RatFunc C) E := + finiteDimensional_exactConstantExtension_over_baseRatFunc + C S N hExact + let : Algebra.IsSeparable (RatFunc C) E := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + let : Algebra (RatFunc S) E := + ratFuncExactConstantExtensionAlgebra C S N hExact + let : SMul (RatFunc S) E := Algebra.toSMul + let : Module (RatFunc S) E := Algebra.toModule + let : Algebra S[X] E := + constantExtensionTensorPolynomialAlgebra C S N + let : SMul S[X] E := Algebra.toSMul + let : Module S[X] E := Algebra.toModule + let : IsScalarTower S[X] (RatFunc S) E := + IsScalarTower.of_algebraMap_eq' (by + apply DFunLike.ext _ _ + intro p + change algebraMap S[X] E p = + ratFuncToExactConstantExtension C S N hExact + (algebraMap S[X] (RatFunc S) p) + exact + (ratFuncToExactConstantExtension_algebraMap C S N hExact p).symm) + let : FiniteDimensional (RatFunc S) E := + finiteDimensional_over_extendedRatFunc C S N hExact + let : Algebra.IsSeparable (RatFunc S) E := + isSeparable_over_extendedRatFunc C S N hExact + intro hPresentedMultiplicity + let Base := FiniteExtensionPlace C N + let Up := ExactConstantExtensionPresentedPlace C S N + let Actual := FiniteExtensionPlace S E + let down : Up → Base := + exactConstantExtensionPresentedDownstairsPlace C S N hExact + let e : Up ≃ Actual := + exactConstantExtensionPresentedUpstairsPlaceEquiv C S N hExact + let Dbase : Base →₀ ℕ := + finiteExtensionTotalDifferentEffectiveDivisor C N + let Dactual : Actual →₀ ℕ := + finiteExtensionTotalDifferentEffectiveDivisor S E + let Dup : Up →₀ ℕ := (Finsupp.domCongr e).symm Dactual + have hDup (q : Up) : Dup q = Dactual (e q) := by + simp [Dup, Finsupp.domCongr_apply] + have hWeighted : + Dup.sum (fun q m => + m * finiteExtensionPlaceDegree S E (e q)) = + Dbase.sum (fun P m => + m * finiteExtensionPlaceDegree C N P) := by + apply Finsupp.sum_mul_degree_eq_of_div_gcd_fibers + down (finiteExtensionPlaceDegree C N) + (fun q => finiteExtensionPlaceDegree S E (e q)) + Dbase Dup (Module.finrank C S) + · intro q + rw [hDup] + exact hPresentedMultiplicity q + · intro q + dsimp [e, down] + rw [exactConstantExtensionPresentedUpstairsPlaceEquiv_apply] + exact exactConstantExtensionPresentedPlace_degree_eq_div_gcd + C S N hExact q + · intro P + exact + exactConstantExtensionPresentedPlaceFiber_natCard_eq_gcd_of_downstairs + C S N hExact P + have hReindex : + Dactual.sum (fun Q m => + m * finiteExtensionPlaceDegree S E Q) = + Dup.sum (fun q m => + m * finiteExtensionPlaceDegree S E (e q)) := by + dsimp [Dup] + rw [Finsupp.domCongr_symm] + change Dactual.sum _ = + (Finsupp.equivMapDomain e.symm Dactual).sum _ + rw [Finsupp.sum_equivMapDomain] + simp only [Equiv.apply_symm_apply] + calc + finiteExtensionFiniteDifferentDegree S E + (finiteExtensionFiniteDifferentIdeal_ne_bot S E) + + infinityDifferentDegree S E = + finiteExtensionEffectiveDivisorDegree S E Dactual := + (finiteExtensionTotalDifferentEffectiveDivisor_degree S E).symm + _ = Dactual.sum (fun Q m => + m * finiteExtensionPlaceDegree S E Q) := rfl + _ = Dup.sum (fun q m => + m * finiteExtensionPlaceDegree S E (e q)) := hReindex + _ = Dbase.sum (fun P m => + m * finiteExtensionPlaceDegree C N P) := hWeighted + _ = finiteExtensionEffectiveDivisorDegree C N Dbase := rfl + _ = finiteExtensionFiniteDifferentDegree C N + (finiteExtensionFiniteDifferentIdeal_ne_bot C N) + + infinityDifferentDegree C N := + finiteExtensionTotalDifferentEffectiveDivisor_degree C N + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionTower.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionTower.lean new file mode 100644 index 0000000000..fd34fdc926 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/ExactConstantExtensionTower.lean @@ -0,0 +1,550 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionAutomorphism +public import LeanPool.MarkoffModP.BGS.HasseWeil.RatFuncExactConstantExtension + +/-! +# Towers of exact constant extensions + +Let `C` be the exact constant field of `N`, let `M` be an intermediate field +in a tower `C ⊆ M ⊆ N`, and let `S / C` be finite Galois. Tensoring the +inclusion `M → N` with the identity of `S` gives + +`S ⊗[C] M → S ⊗[C] N`. + +This file packages that map as the algebra structure needed by the +constant-extension place and Frobenius APIs. It proves that the extended +top is finite Galois over the extended intermediate field, with the same +degree and hence the same Galois-group cardinality as `N / M`. +-/ + +@[expose] public section + +open scoped Polynomial TensorProduct + +namespace BGS.HasseWeil + +noncomputable section + + +variable (C M N S : Type*) [Field C] [Field M] [Field N] [Field S] + [Algebra C M] [Algebra C N] [Algebra M N] [IsScalarTower C M N] + [Algebra C S] [FiniteDimensional C S] [IsGalois C S] + +/-- Exact constants descend from a field to every intermediate field in a +compatible scalar tower. -/ +theorem algebraicClosure_eq_bot_of_tower + (hExactN : algebraicClosure C N = (⊥ : IntermediateField C N)) : + algebraicClosure C M = (⊥ : IntermediateField C M) := by + let i : M →ₐ[C] N := IsScalarTower.toAlgHom C M N + apply eq_bot_iff.mpr + intro x hx + have hxi : i x ∈ algebraicClosure C N := + (map_mem_algebraicClosure_iff i).mpr hx + rw [hExactN] at hxi + obtain ⟨c, hc⟩ := IntermediateField.mem_bot.mp hxi + apply IntermediateField.mem_bot.mpr + refine ⟨c, ?_⟩ + exact i.injective (by simpa using hc) + +/-- Tensor the inclusion `M → N` with the identity on the enlarged +constant field. -/ +noncomputable def exactConstantExtensionTowerAlgHom : + ExactConstantExtension C M S →ₐ[C] ExactConstantExtension C N S := + Algebra.TensorProduct.map (AlgHom.id C S) + (IsScalarTower.toAlgHom C M N) + +omit [FiniteDimensional C S] [IsGalois C S] in +@[simp] +theorem exactConstantExtensionTowerAlgHom_tmul (s : S) (m : M) : + exactConstantExtensionTowerAlgHom C M N S (s ⊗ₜ[C] m) = + s ⊗ₜ[C] algebraMap M N m := by + rw [exactConstantExtensionTowerAlgHom, + Algebra.TensorProduct.map_tmul] + rfl + +/-- The algebra structure on the extended top induced by the tensor map. -/ +@[reducible] noncomputable def exactConstantExtensionTowerAlgebra : + Algebra (ExactConstantExtension C M S) + (ExactConstantExtension C N S) := + (exactConstantExtensionTowerAlgHom C M N S).toAlgebra + +omit [FiniteDimensional C S] [IsGalois C S] in +/-- The tensor map preserves the enlarged constants on the left factor. -/ +theorem exactConstantExtensionTower_leftScalarTower : + letI : Algebra S (ExactConstantExtension C M S) := + Algebra.TensorProduct.leftAlgebra + letI : Algebra S (ExactConstantExtension C N S) := + Algebra.TensorProduct.leftAlgebra + letI : Algebra (ExactConstantExtension C M S) + (ExactConstantExtension C N S) := + exactConstantExtensionTowerAlgebra C M N S + IsScalarTower S (ExactConstantExtension C M S) + (ExactConstantExtension C N S) := by + let : Algebra S (ExactConstantExtension C M S) := + Algebra.TensorProduct.leftAlgebra + let : Algebra S (ExactConstantExtension C N S) := + Algebra.TensorProduct.leftAlgebra + let : Algebra (ExactConstantExtension C M S) + (ExactConstantExtension C N S) := + exactConstantExtensionTowerAlgebra C M N S + apply IsScalarTower.of_algebraMap_eq' + ext s + change s ⊗ₜ[C] (1 : N) = + exactConstantExtensionTowerAlgHom C M N S (s ⊗ₜ[C] (1 : M)) + rw [exactConstantExtensionTowerAlgHom_tmul, map_one] + +/-- The tensor map also preserves the original right factor `M`. -/ +theorem exactConstantExtensionTower_rightScalarTower + (hExactN : algebraicClosure C N = (⊥ : IntermediateField C N)) : + let hExactM := algebraicClosure_eq_bot_of_tower C M N hExactN + letI : Field (ExactConstantExtension C M S) := + exactConstantExtensionField C M S hExactM + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExactN + letI : Algebra M (ExactConstantExtension C M S) := + exactConstantExtensionAlgebra C M S + letI : Algebra M (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C M N S + letI : Algebra (ExactConstantExtension C M S) + (ExactConstantExtension C N S) := + exactConstantExtensionTowerAlgebra C M N S + IsScalarTower M (ExactConstantExtension C M S) + (ExactConstantExtension C N S) := by + let hExactM := algebraicClosure_eq_bot_of_tower C M N hExactN + let : Field (ExactConstantExtension C M S) := + exactConstantExtensionField C M S hExactM + let : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExactN + let : Algebra M (ExactConstantExtension C M S) := + exactConstantExtensionAlgebra C M S + let : Algebra M (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C M N S + let : Algebra (ExactConstantExtension C M S) + (ExactConstantExtension C N S) := + exactConstantExtensionTowerAlgebra C M N S + apply IsScalarTower.of_algebraMap_eq' + ext m + change (1 : S) ⊗ₜ[C] algebraMap M N m = + exactConstantExtensionTowerAlgHom C M N S ((1 : S) ⊗ₜ[C] m) + rw [exactConstantExtensionTowerAlgHom_tmul] + +section Galois + +variable [FiniteDimensional M N] [IsGalois M N] + +omit [IsGalois M N] in +/-- The extended top is finite-dimensional over the extended intermediate +field. -/ +theorem exactConstantExtensionTower_finiteDimensional + (hExactN : algebraicClosure C N = (⊥ : IntermediateField C N)) : + let hExactM := algebraicClosure_eq_bot_of_tower C M N hExactN + letI : Field (ExactConstantExtension C M S) := + exactConstantExtensionField C M S hExactM + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExactN + letI : Algebra M (ExactConstantExtension C M S) := + exactConstantExtensionAlgebra C M S + letI : Algebra M (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C M N S + letI : Algebra (ExactConstantExtension C M S) + (ExactConstantExtension C N S) := + exactConstantExtensionTowerAlgebra C M N S + FiniteDimensional (ExactConstantExtension C M S) + (ExactConstantExtension C N S) := by + let hExactM := algebraicClosure_eq_bot_of_tower C M N hExactN + let : Field (ExactConstantExtension C M S) := + exactConstantExtensionField C M S hExactM + let : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExactN + let : Algebra M (ExactConstantExtension C M S) := + exactConstantExtensionAlgebra C M S + let : Algebra M (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C M N S + let : Algebra (ExactConstantExtension C M S) + (ExactConstantExtension C N S) := + exactConstantExtensionTowerAlgebra C M N S + let : IsScalarTower M (ExactConstantExtension C M S) + (ExactConstantExtension C N S) := + exactConstantExtensionTower_rightScalarTower C M N S hExactN + let : Algebra N (ExactConstantExtension C N S) := + exactConstantExtensionAlgebra C N S + let : IsScalarTower M N (ExactConstantExtension C N S) := + exactConstantExtensionBaseTower C M N S + let e := exactConstantExtensionLinearEquiv C N S + let : Module.Finite N (N ⊗[C] S) := + Module.Finite.base_change C N S + let : Module.Finite N (ExactConstantExtension C N S) := + Module.Finite.equiv e + let : Module.Finite M (ExactConstantExtension C N S) := + Module.Finite.trans N (ExactConstantExtension C N S) + exact Module.Finite.of_restrictScalars_finite M + (ExactConstantExtension C M S) (ExactConstantExtension C N S) + +/-- Base change by finite constants preserves the Galois extension. -/ +theorem exactConstantExtensionTower_isGalois + (hExactN : algebraicClosure C N = (⊥ : IntermediateField C N)) : + let hExactM := algebraicClosure_eq_bot_of_tower C M N hExactN + letI : Field (ExactConstantExtension C M S) := + exactConstantExtensionField C M S hExactM + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExactN + letI : Algebra M (ExactConstantExtension C M S) := + exactConstantExtensionAlgebra C M S + letI : Algebra M (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C M N S + letI : Algebra (ExactConstantExtension C M S) + (ExactConstantExtension C N S) := + exactConstantExtensionTowerAlgebra C M N S + IsGalois (ExactConstantExtension C M S) + (ExactConstantExtension C N S) := by + let hExactM := algebraicClosure_eq_bot_of_tower C M N hExactN + let : Field (ExactConstantExtension C M S) := + exactConstantExtensionField C M S hExactM + let : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExactN + let : Algebra M (ExactConstantExtension C M S) := + exactConstantExtensionAlgebra C M S + let : Algebra M (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C M N S + let : Algebra (ExactConstantExtension C M S) + (ExactConstantExtension C N S) := + exactConstantExtensionTowerAlgebra C M N S + let : IsScalarTower M (ExactConstantExtension C M S) + (ExactConstantExtension C N S) := + exactConstantExtensionTower_rightScalarTower C M N S hExactN + let : IsGalois M (ExactConstantExtension C N S) := + exactConstantExtension_isGalois C M N S hExactN + exact IsGalois.tower_top_of_isGalois M + (ExactConstantExtension C M S) (ExactConstantExtension C N S) + +omit [IsGalois M N] in +/-- Finite constant base change preserves the relative extension degree. -/ +theorem exactConstantExtensionTower_finrank + (hExactN : algebraicClosure C N = (⊥ : IntermediateField C N)) : + let hExactM := algebraicClosure_eq_bot_of_tower C M N hExactN + letI : Field (ExactConstantExtension C M S) := + exactConstantExtensionField C M S hExactM + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExactN + letI : Algebra M (ExactConstantExtension C M S) := + exactConstantExtensionAlgebra C M S + letI : Algebra M (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C M N S + letI : Algebra (ExactConstantExtension C M S) + (ExactConstantExtension C N S) := + exactConstantExtensionTowerAlgebra C M N S + letI : FiniteDimensional (ExactConstantExtension C M S) + (ExactConstantExtension C N S) := + exactConstantExtensionTower_finiteDimensional C M N S hExactN + Module.finrank (ExactConstantExtension C M S) + (ExactConstantExtension C N S) = Module.finrank M N := by + let hExactM := algebraicClosure_eq_bot_of_tower C M N hExactN + let : Field (ExactConstantExtension C M S) := + exactConstantExtensionField C M S hExactM + let : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExactN + let : Algebra M (ExactConstantExtension C M S) := + exactConstantExtensionAlgebra C M S + let : Algebra M (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C M N S + let : Algebra (ExactConstantExtension C M S) + (ExactConstantExtension C N S) := + exactConstantExtensionTowerAlgebra C M N S + let : IsScalarTower M (ExactConstantExtension C M S) + (ExactConstantExtension C N S) := + exactConstantExtensionTower_rightScalarTower C M N S hExactN + let : FiniteDimensional (ExactConstantExtension C M S) + (ExactConstantExtension C N S) := + exactConstantExtensionTower_finiteDimensional C M N S hExactN + apply Nat.eq_of_mul_eq_mul_left (Module.finrank_pos (R := C) (M := S)) + calc + Module.finrank C S * Module.finrank (ExactConstantExtension C M S) + (ExactConstantExtension C N S) = + Module.finrank M (ExactConstantExtension C M S) * + Module.finrank (ExactConstantExtension C M S) + (ExactConstantExtension C N S) := by + rw [exactConstantExtension_finrank C M S] + _ = Module.finrank M (ExactConstantExtension C N S) := + Module.finrank_mul_finrank M (ExactConstantExtension C M S) + (ExactConstantExtension C N S) + _ = Module.finrank M N * Module.finrank C S := + exactConstantExtension_finrank_over_base C M N S + _ = Module.finrank C S * Module.finrank M N := Nat.mul_comm _ _ + +/-- Consequently the Galois group has the same finite cardinality after +constant base change. -/ +theorem exactConstantExtensionTower_card_aut_eq + (hExactN : algebraicClosure C N = (⊥ : IntermediateField C N)) : + let hExactM := algebraicClosure_eq_bot_of_tower C M N hExactN + letI : Field (ExactConstantExtension C M S) := + exactConstantExtensionField C M S hExactM + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExactN + letI : Algebra M (ExactConstantExtension C M S) := + exactConstantExtensionAlgebra C M S + letI : Algebra M (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C M N S + letI : Algebra (ExactConstantExtension C M S) + (ExactConstantExtension C N S) := + exactConstantExtensionTowerAlgebra C M N S + letI : FiniteDimensional (ExactConstantExtension C M S) + (ExactConstantExtension C N S) := + exactConstantExtensionTower_finiteDimensional C M N S hExactN + letI : IsGalois (ExactConstantExtension C M S) + (ExactConstantExtension C N S) := + exactConstantExtensionTower_isGalois C M N S hExactN + Nat.card (ExactConstantExtension C N S ≃ₐ[ + ExactConstantExtension C M S] ExactConstantExtension C N S) = + Nat.card (N ≃ₐ[M] N) := by + let hExactM := algebraicClosure_eq_bot_of_tower C M N hExactN + let : Field (ExactConstantExtension C M S) := + exactConstantExtensionField C M S hExactM + let : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExactN + let : Algebra M (ExactConstantExtension C M S) := + exactConstantExtensionAlgebra C M S + let : Algebra M (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C M N S + let : Algebra (ExactConstantExtension C M S) + (ExactConstantExtension C N S) := + exactConstantExtensionTowerAlgebra C M N S + let : FiniteDimensional (ExactConstantExtension C M S) + (ExactConstantExtension C N S) := + exactConstantExtensionTower_finiteDimensional C M N S hExactN + let : IsGalois (ExactConstantExtension C M S) + (ExactConstantExtension C N S) := + exactConstantExtensionTower_isGalois C M N S hExactN + rw [IsGalois.card_aut_eq_finrank, IsGalois.card_aut_eq_finrank, + exactConstantExtensionTower_finrank C M N S hExactN] + +end Galois + +end + +noncomputable section + +section RatFuncCompatibility + + +variable (C M N S : Type*) [Field C] [Field M] [Field N] [Field S] + [Algebra (RatFunc C) M] [Algebra (RatFunc C) N] + [Algebra M N] [IsScalarTower (RatFunc C) M N] + [Algebra C S] [FiniteDimensional C S] [IsGalois C S] + +/-- The constant algebra obtained by restricting a rational-function-field +algebra along `C → C(X)`. Naming this definition makes the canonical +constant structures in the source and target definitionally transparent. -/ +@[reducible] noncomputable def + exactConstantExtensionTowerCanonicalConstantAlgebra + (C T : Type*) [Field C] [Field T] [Algebra (RatFunc C) T] : + Algebra C T := + RingHom.toAlgebra + ((algebraMap (RatFunc C) T).comp (algebraMap C (RatFunc C))) + +/-- Restricting a compatible `C(X)`-tower along `C → C(X)` gives the +canonical constant scalar tower used by exact constant extensions. -/ +theorem exactConstantExtensionTowerCanonicalConstantScalarTower : + letI : Algebra C M := + exactConstantExtensionTowerCanonicalConstantAlgebra C M + letI : Algebra C N := + exactConstantExtensionTowerCanonicalConstantAlgebra C N + IsScalarTower C M N := by + let : Algebra C M := + exactConstantExtensionTowerCanonicalConstantAlgebra C M + let : Algebra C N := + exactConstantExtensionTowerCanonicalConstantAlgebra C N + apply IsScalarTower.of_algebraMap_eq' + ext c + exact IsScalarTower.algebraMap_apply (RatFunc C) M N + (algebraMap C (RatFunc C) c) + +/-- The tensor map between two exact constant extensions is linear over the +enlarged rational-function field `S(X)` for the canonical structures on both +extensions. -/ +noncomputable def exactConstantExtensionTowerRatFuncAlgHom : + letI : Algebra C M := + exactConstantExtensionTowerCanonicalConstantAlgebra C M + letI : Algebra C N := + exactConstantExtensionTowerCanonicalConstantAlgebra C N + letI : IsScalarTower C M N := IsScalarTower.of_algebraMap_eq' (by + ext c + exact IsScalarTower.algebraMap_apply (RatFunc C) M N + (algebraMap C (RatFunc C) c)) + ∀ (hExactN : algebraicClosure C N = + (⊥ : IntermediateField C N)), + let hExactM := algebraicClosure_eq_bot_of_tower C M N hExactN + let E_M := ExactConstantExtension C M S + let E_N := ExactConstantExtension C N S + letI : Field E_M := exactConstantExtensionField C M S hExactM + letI : Field E_N := exactConstantExtensionField C N S hExactN + letI : Algebra (RatFunc S) E_M := + ratFuncExactConstantExtensionAlgebra C S M hExactM + letI : Algebra (RatFunc S) E_N := + ratFuncExactConstantExtensionAlgebra C S N hExactN + E_M →ₐ[RatFunc S] E_N := by + letI : Algebra C M := + exactConstantExtensionTowerCanonicalConstantAlgebra C M + letI : Algebra C N := + exactConstantExtensionTowerCanonicalConstantAlgebra C N + letI : IsScalarTower C M N := IsScalarTower.of_algebraMap_eq' (by + ext c + exact IsScalarTower.algebraMap_apply (RatFunc C) M N + (algebraMap C (RatFunc C) c)) + intro hExactN + let hExactM := algebraicClosure_eq_bot_of_tower C M N hExactN + let E_M := ExactConstantExtension C M S + let E_N := ExactConstantExtension C N S + letI : Field E_M := exactConstantExtensionField C M S hExactM + letI : Field E_N := exactConstantExtensionField C N S hExactN + letI : Algebra S E_M := Algebra.TensorProduct.leftAlgebra + letI : Algebra S E_N := Algebra.TensorProduct.leftAlgebra + letI : Algebra (RatFunc S) E_M := + ratFuncExactConstantExtensionAlgebra C S M hExactM + letI : Algebra (RatFunc S) E_N := + ratFuncExactConstantExtensionAlgebra C S N hExactN + letI : Algebra C[X] M := + RingHom.toAlgebra + ((algebraMap (RatFunc C) M).comp + (algebraMap C[X] (RatFunc C))) + letI : Algebra C[X] N := + RingHom.toAlgebra + ((algebraMap (RatFunc C) N).comp + (algebraMap C[X] (RatFunc C))) + let φS : E_M →ₐ[S] E_N := + { exactConstantExtensionTowerAlgHom C M N S with + commutes' := by + intro s + change exactConstantExtensionTowerAlgHom C M N S + (s ⊗ₜ[C] (1 : M)) = s ⊗ₜ[C] (1 : N) + rw [exactConstantExtensionTowerAlgHom_tmul, map_one] } + let f : RatFunc S →ₐ[S] E_N := + φS.comp (ratFuncToExactConstantExtension C S M hExactM) + let g : RatFunc S →ₐ[S] E_N := + ratFuncToExactConstantExtension C S N hExactN + have hX : f RatFunc.X = g RatFunc.X := by + change exactConstantExtensionTowerAlgHom C M N S + (ratFuncToExactConstantExtension C S M hExactM RatFunc.X) = + ratFuncToExactConstantExtension C S N hExactN RatFunc.X + rw [ratFuncToExactConstantExtension_X, + ratFuncToExactConstantExtension_X] + simp only [polynomialTensorCancelEvaluationPoint, + Algebra.TensorProduct.includeRight_apply] + rw [exactConstantExtensionTowerAlgHom_tmul] + congr 1 + exact (IsScalarTower.algebraMap_apply (RatFunc C) M N + (algebraMap C[X] (RatFunc C) Polynomial.X)).symm + have hRing : f.toRingHom = g.toRingHom := by + apply IsFractionRing.ringHom_ext (A := S[X]) + intro p + induction p using Polynomial.induction_on' with + | add p q hp hq => + simpa only [map_add] using congrArg₂ (fun x y => x + y) hp hq + | monomial n s => + rw [← Polynomial.C_mul_X_pow_eq_monomial] + simp only [map_mul, map_pow, RatFunc.algebraMap_C, + RatFunc.algebraMap_X] + rw [← RatFunc.algebraMap_eq_C] + have hfs : f.toRingHom (algebraMap S (RatFunc S) s) = + algebraMap S E_N s := f.commutes s + have hgs : g.toRingHom (algebraMap S (RatFunc S) s) = + algebraMap S E_N s := g.commutes s + have hX' : f.toRingHom RatFunc.X = g.toRingHom RatFunc.X := hX + rw [hfs, hgs, hX'] + have hfg : f = g := + DFunLike.ext _ _ (fun r => DFunLike.congr_fun hRing r) + refine { φS with commutes' := ?_ } + intro r + exact DFunLike.congr_fun hfg r + +/-- The algebra structure underlying the `S(X)`-linear tensor map. Its +underlying ring homomorphism is the same tensor map as +`exactConstantExtensionTowerAlgebra`; the separate name records the intended +canonical rational-function-field interface. -/ +@[reducible] noncomputable def exactConstantExtensionTowerRatFuncAlgebra : + letI : Algebra C M := + exactConstantExtensionTowerCanonicalConstantAlgebra C M + letI : Algebra C N := + exactConstantExtensionTowerCanonicalConstantAlgebra C N + letI : IsScalarTower C M N := IsScalarTower.of_algebraMap_eq' (by + ext c + exact IsScalarTower.algebraMap_apply (RatFunc C) M N + (algebraMap C (RatFunc C) c)) + Algebra (ExactConstantExtension C M S) + (ExactConstantExtension C N S) := + by + letI : Algebra C M := + exactConstantExtensionTowerCanonicalConstantAlgebra C M + letI : Algebra C N := + exactConstantExtensionTowerCanonicalConstantAlgebra C N + letI : IsScalarTower C M N := IsScalarTower.of_algebraMap_eq' (by + ext c + exact IsScalarTower.algebraMap_apply (RatFunc C) M N + (algebraMap C (RatFunc C) c)) + exact exactConstantExtensionTowerAlgebra C M N S + +/-- The canonical `S(X)`-algebras on the two exact constant extensions and +the tensor inclusion form a scalar tower. -/ +theorem exactConstantExtensionTower_ratFuncScalarTower + (hExactN : + letI : Algebra C N := + exactConstantExtensionTowerCanonicalConstantAlgebra C N + algebraicClosure C N = (⊥ : IntermediateField C N)) : + letI : Algebra C M := + exactConstantExtensionTowerCanonicalConstantAlgebra C M + letI : Algebra C N := + exactConstantExtensionTowerCanonicalConstantAlgebra C N + letI : IsScalarTower C M N := IsScalarTower.of_algebraMap_eq' (by + ext c + exact IsScalarTower.algebraMap_apply (RatFunc C) M N + (algebraMap C (RatFunc C) c)) + let hExactM := algebraicClosure_eq_bot_of_tower C M N hExactN + let E_M := ExactConstantExtension C M S + let E_N := ExactConstantExtension C N S + letI : Field E_M := exactConstantExtensionField C M S hExactM + letI : Field E_N := exactConstantExtensionField C N S hExactN + letI : Algebra (RatFunc S) E_M := + ratFuncExactConstantExtensionAlgebra C S M hExactM + letI : Algebra (RatFunc S) E_N := + ratFuncExactConstantExtensionAlgebra C S N hExactN + letI : Algebra E_M E_N := + exactConstantExtensionTowerRatFuncAlgebra C M N S + IsScalarTower (RatFunc S) E_M E_N := by + let : Algebra C M := + exactConstantExtensionTowerCanonicalConstantAlgebra C M + let : Algebra C N := + exactConstantExtensionTowerCanonicalConstantAlgebra C N + let : IsScalarTower C M N := IsScalarTower.of_algebraMap_eq' (by + ext c + exact IsScalarTower.algebraMap_apply (RatFunc C) M N + (algebraMap C (RatFunc C) c)) + let hExactM := algebraicClosure_eq_bot_of_tower C M N hExactN + let E_M := ExactConstantExtension C M S + let E_N := ExactConstantExtension C N S + let : Field E_M := exactConstantExtensionField C M S hExactM + let : Field E_N := exactConstantExtensionField C N S hExactN + let : Algebra (RatFunc S) E_M := + ratFuncExactConstantExtensionAlgebra C S M hExactM + let : Algebra (RatFunc S) E_N := + ratFuncExactConstantExtensionAlgebra C S N hExactN + let : Algebra E_M E_N := + exactConstantExtensionTowerRatFuncAlgebra C M N S + apply IsScalarTower.of_algebraMap_eq' + ext r + change ratFuncToExactConstantExtension C S N hExactN r = + exactConstantExtensionTowerAlgHom C M N S + (ratFuncToExactConstantExtension C S M hExactM r) + exact (exactConstantExtensionTowerRatFuncAlgHom C M N S hExactN).commutes r + |>.symm + +end RatFuncCompatibility + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/ExtensionEvenDegreeStepanovBound.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/ExtensionEvenDegreeStepanovBound.lean new file mode 100644 index 0000000000..1b50c66a2a --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/ExtensionEvenDegreeStepanovBound.lean @@ -0,0 +1,214 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExtensionPointCount +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneSquareFieldStepanovCountAutomatic +public import Mathlib.Tactic + +/-! +# A Stepanov upper bound along the even-degree extension sequence + +Let `K_n = FiniteField.Extension K p n` and +`K_{2n} = FiniteField.Extension K p (2 * n)`. Since `n ∣ 2 * n`, finite-field +theory supplies a `K`-algebra embedding `K_n → K_{2n}`. With this algebra +structure the latter is a quadratic extension of the former, so the +square-field Stepanov estimate applies directly to the canonical degree +`2 * n` point count. + +This is only a one-sided affine estimate. It does not assert the missing +lower bound, the sharp Hasse--Weil constant, or a two-sided zeta estimate. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +open BGS.CorvajaZannier + +noncomputable section + + +/-- An injective extension of coefficients preserves a support-wise +bidegree bound. -/ +theorem hasBidegreeAtMost_map_of_injective + {R S : Type*} [CommSemiring R] [CommSemiring S] + (φ : R →+* S) (hφ : Function.Injective φ) + {f : MvPolynomial (Fin 2) R} {firstDegree secondDegree : Nat} + (hdegree : BGS.External.HasBidegreeAtMost + f firstDegree secondDegree) : + BGS.External.HasBidegreeAtMost + (MvPolynomial.map φ f) firstDegree secondDegree := by + intro monomial hmonomial + apply hdegree monomial + rwa [MvPolynomial.support_map_of_injective f hφ] at hmonomial + +/-- An injective extension of coefficients preserves the exact coarse genus +budget used by the plane Stepanov argument. -/ +theorem planeCurveBidegreeGenusBudget_map_of_injective + {R S : Type*} [CommSemiring R] [CommSemiring S] + (φ : R →+* S) (hφ : Function.Injective φ) + (f : MvPolynomial (Fin 2) R) : + planeCurveBidegreeGenusBudget (MvPolynomial.map φ f) = + planeCurveBidegreeGenusBudget f := by + simp only [planeCurveBidegreeGenusBudget, + degreeOf_map_eq_of_injective φ hφ] + +variable (K : Type*) [Field K] [Fintype K] +variable (p n : Nat) [Fact p.Prime] [CharP K p] [NeZero n] + +/-- A chosen `K`-algebra embedding from the degree-`n` extension into the +degree-`2n` extension. Its existence is the finite-field divisibility +criterion `n ∣ 2n`. -/ +def halfExtensionToEvenExtensionAlgHom : + FiniteField.Extension K p n →ₐ[K] + FiniteField.Extension K p (2 * n) := + (FiniteField.nonempty_algHom_of_finrank_dvd (by + rw [FiniteField.finrank_extension K p n, + FiniteField.finrank_extension K p (2 * n)] + exact ⟨2, by omega⟩)).some + +/-- The canonical degree-`2n` finite extension, viewed through the chosen +degree-`n` subfield, has relative degree two. -/ +theorem finrank_evenExtension_over_halfExtension : + let E := FiniteField.Extension K p n + let S := FiniteField.Extension K p (2 * n) + let ι : E →ₐ[K] S := halfExtensionToEvenExtensionAlgHom K p n + letI : Algebra E S := ι.toAlgebra + Module.finrank E S = 2 := by + classical + let E := FiniteField.Extension K p n + let S := FiniteField.Extension K p (2 * n) + let ι : E →ₐ[K] S := halfExtensionToEvenExtensionAlgHom K p n + let : Algebra E S := ι.toAlgebra + let : IsScalarTower K E S := IsScalarTower.of_algebraMap_eq' (by + ext c + exact (ι.commutes c).symm) + let : Module.Finite E S := Module.Finite.of_finite + have hmul : Module.finrank K E * Module.finrank E S = + Module.finrank K S := Module.finrank_mul_finrank K E S + rw [FiniteField.finrank_extension K p n, + FiniteField.finrank_extension K p (2 * n)] at hmul + have hn : 0 < n := NeZero.pos n + apply Nat.eq_of_mul_eq_mul_left hn + calc + n * Module.finrank E S = 2 * n := hmul + _ = n * 2 := Nat.mul_comm 2 n + +/-- The automatic plane Stepanov estimate on the canonical even-degree +extension sequence. The main error term is exactly +`(2 * genusBudget + 1) * (#K)^n`; the final displayed term is the explicit +critical-locus bound coming from the supplied bidegree. + +This theorem is intentionally one-sided and should not be called a +Hasse--Weil theorem. -/ +theorem extensionAffinePointCount_two_mul_le_stepanov + {f : MvPolynomial (Fin 2) K} {firstDegree secondDegree : Nat} + (hdegree : BGS.External.HasBidegreeAtMost + f firstDegree secondDegree) + (habsolute : Irreducible + (MvPolynomial.map (algebraMap K (AlgebraicClosure K)) f)) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (hlarge : + (planeCurveBidegreeGenusBudget f + 1) * + (planeCurveBidegreeGenusBudget f + 2) ≤ + (Fintype.card K) ^ n) : + extensionAffinePointCount K p (2 * n) f ≤ + (Fintype.card K) ^ (2 * n) + + (2 * planeCurveBidegreeGenusBudget f + 1) * + (Fintype.card K) ^ n + + ((2 * secondDegree - 1) * firstDegree) * secondDegree := by + classical + let E := FiniteField.Extension K p n + let S := FiniteField.Extension K p (2 * n) + let ι : E →ₐ[K] S := halfExtensionToEvenExtensionAlgHom K p n + let : Algebra E S := ι.toAlgebra + let : IsScalarTower K E S := IsScalarTower.of_algebraMap_eq' (by + ext c + exact (ι.commutes c).symm) + let : Module.Finite E S := Module.Finite.of_finite + let : Fintype E := Fintype.ofFinite E + let : Fintype S := Fintype.ofFinite S + let fS : MvPolynomial (Fin 2) S := + extensionPlaneCurvePolynomial K p (2 * n) f + have hfinrank : Module.finrank E S = 2 := + finrank_evenExtension_over_halfExtension K p n + have hcardE : Fintype.card E = (Fintype.card K) ^ n := by + rw [Fintype.card_eq_nat_card, Fintype.card_eq_nat_card] + exact FiniteField.natCard_extension K p n + have hcardS : Fintype.card S = (Fintype.card E) ^ 2 := by + rw [Module.card_eq_pow_finrank (K := E), hfinrank] + have hcardSbase : Fintype.card S = (Fintype.card K) ^ (2 * n) := by + rw [Fintype.card_eq_nat_card, Fintype.card_eq_nat_card] + exact FiniteField.natCard_extension K p (2 * n) + have hfS : Irreducible fS := by + exact irreducible_map_of_irreducible_map_algebraicClosure + (algebraMap K S) f habsolute + have hpartialFirstS : MvPolynomial.pderiv 0 fS ≠ 0 := by + exact extensionPlaneCurvePolynomial_pderiv_ne_zero + K p (2 * n) f 0 hpartialFirst + have hpartialSecondS : MvPolynomial.pderiv 1 fS ≠ 0 := by + exact extensionPlaneCurvePolynomial_pderiv_ne_zero + K p (2 * n) f 1 hpartialSecond + have hdegreeS : BGS.External.HasBidegreeAtMost + fS firstDegree secondDegree := by + exact hasBidegreeAtMost_map_of_injective + (algebraMap K S) (algebraMap K S).injective hdegree + have hgenus : planeCurveBidegreeGenusBudget fS = + planeCurveBidegreeGenusBudget f := by + exact planeCurveBidegreeGenusBudget_map_of_injective + (algebraMap K S) (algebraMap K S).injective f + have hlargeS : + (planeCurveBidegreeGenusBudget fS + 1) * + (planeCurveBidegreeGenusBudget fS + 2) ≤ Fintype.card E := by + simpa only [hgenus, hcardE] using hlarge + have habsoluteS : Irreducible + (MvPolynomial.map (algebraMap S (AlgebraicClosure S)) fS) := by + exact extensionPlaneCurvePolynomial_absolutelyIrreducible + K p (2 * n) f habsolute + let : IsDomain (PlaneCurveCoordinateRing fS) := + planeCurveCoordinateRing_isDomain hfS + let hx := firstCoordinate_transcendental hfS + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecondS) + let L := PlaneCurveFunctionField fS + let : Algebra (RatFunc S) L := + planeCurveFirstCoordinateRatFuncAlgebra fS hx + let canonicalAlg : Algebra S L := inferInstance + let constantAlg : Algebra S L := + RingHom.toAlgebra ((algebraMap (RatFunc S) L).comp + (algebraMap S (RatFunc S))) + have hconstantAlg : constantAlg = canonicalAlg := by + apply Algebra.algebra_ext + intro c + change (@ratFuncSpecialization S L _ _ canonicalAlg + (planeCurveFunction fS 0) hx) (RatFunc.C c) = + @algebraMap S L _ _ canonicalAlg c + have h := DFunLike.congr_fun + (@ratFuncSpecialization_comp_polynomial_algebraMap + S L _ _ canonicalAlg (planeCurveFunction fS 0) hx) + (Polynomial.C c) + simpa using h + have hconstantsCanonical : + @algebraicClosure S L _ _ canonicalAlg = ⊥ := by + simpa only [L] using + planeCurveFunctionField_algebraicClosure_eq_bot + fS habsoluteS hpartialSecondS + have hconstants : + @algebraicClosure S L _ _ constantAlg = ⊥ := by + rw [hconstantAlg] + exact hconstantsCanonical + have hbound := planeCurve_affinePoint_card_le_squareField_bidegree + E S hdegreeS hfS hpartialFirstS hpartialSecondS hcardS hlargeS + dsimp only at hbound + specialize hbound hconstants + simpa only [extensionAffinePointCount, affineBivariatePointCount, + fS, hgenus, hcardE, hcardSbase, Fintype.card_eq_nat_card] using hbound + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/ExtensionPointCount.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/ExtensionPointCount.lean new file mode 100644 index 0000000000..a47e052a59 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/ExtensionPointCount.lean @@ -0,0 +1,193 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneConstantField +public import Mathlib.FieldTheory.Finite.Extension +public import Mathlib.Tactic + +/-! +# Affine point counts over canonical finite-field extensions + +For a finite field `K` of characteristic `p`, Mathlib provides a chosen +degree-`n` extension `FiniteField.Extension K p n`. This file base-changes a +bivariate polynomial to that field and counts its affine zeros. It also +records the cardinality of the extension, compatibility with degree one, and +the geometric hypotheses preserved by this base change. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +open BGS.CorvajaZannier + +noncomputable section + +/-- Affine zeros of a bivariate polynomial, represented by ordered pairs. -/ +abbrev AffineBivariatePoint + {F : Type*} [CommRing F] (f : MvPolynomial (Fin 2) F) := + {z : F × F // MvPolynomial.eval ![z.1, z.2] f = 0} + +/-- The number of affine zeros of a bivariate polynomial over a finite +coefficient ring. -/ +def affineBivariatePointCount + {F : Type*} [CommRing F] [Finite F] + (f : MvPolynomial (Fin 2) F) : ℕ := + Nat.card (AffineBivariatePoint f) + +/-- Transport affine zeros along a coefficient-ring equivalence. -/ +def affineBivariatePointMapEquiv + {E F : Type*} [CommRing E] [CommRing F] + (e : E ≃+* F) (f : MvPolynomial (Fin 2) E) : + AffineBivariatePoint f ≃ + AffineBivariatePoint (MvPolynomial.map e.toRingHom f) := + Equiv.subtypeEquiv (e.toEquiv.prodCongr e.toEquiv) (fun z => by + have heval : + MvPolynomial.eval ![e z.1, e z.2] + (MvPolynomial.map e.toRingHom f) = + e (MvPolynomial.eval ![z.1, z.2] f) := by + have hcoordinates : + ![e z.1, e z.2] = e ∘ ![z.1, z.2] := by + funext i + fin_cases i <;> rfl + rw [hcoordinates] + exact (MvPolynomial.map_eval e.toRingHom ![z.1, z.2] f).symm + change MvPolynomial.eval ![z.1, z.2] f = 0 ↔ + MvPolynomial.eval ![e z.1, e z.2] + (MvPolynomial.map e.toRingHom f) = 0 + rw [heval, e.map_eq_zero_iff]) + +section Extension + +variable (K : Type*) [Field K] [Finite K] +variable (p n : ℕ) [Fact p.Prime] [CharP K p] [NeZero n] + +/-- The plane polynomial after extension of constants from `K` to the chosen +degree-`n` finite-field extension. -/ +def extensionPlaneCurvePolynomial + (f : MvPolynomial (Fin 2) K) : + MvPolynomial (Fin 2) (FiniteField.Extension K p n) := + MvPolynomial.map (algebraMap K (FiniteField.Extension K p n)) f + +/-- The number of affine zeros after extension of constants to degree `n`. -/ +def extensionAffinePointCount + (f : MvPolynomial (Fin 2) K) : ℕ := + affineBivariatePointCount (extensionPlaneCurvePolynomial K p n f) + +/-- The chosen degree-`n` extension has exactly `(#K)^n` elements. -/ +theorem extensionField_natCard : + Nat.card (FiniteField.Extension K p n) = Nat.card K ^ n := + FiniteField.natCard_extension K p n + +section DegreeOne + +omit [NeZero n] in +/-- The chosen degree-one extension is noncanonically equivalent to its base +field as a `K`-algebra. -/ +def extensionOneAlgEquiv : + FiniteField.Extension K p 1 ≃ₐ[K] K := + (FiniteField.algEquivExtension K p 1 K (by simp)).symm + +omit [NeZero n] in +/-- Affine zeros over the chosen degree-one extension correspond exactly to +affine zeros over the base field. -/ +def extensionOneAffinePointEquiv + (f : MvPolynomial (Fin 2) K) : + AffineBivariatePoint (extensionPlaneCurvePolynomial K p 1 f) ≃ + AffineBivariatePoint f := by + let e := extensionOneAlgEquiv K p + have hpoly : + MvPolynomial.map e.toRingHom + (extensionPlaneCurvePolynomial K p 1 f) = f := by + rw [extensionPlaneCurvePolynomial, MvPolynomial.map_map] + have hcomp : + e.toRingHom.comp + (algebraMap K (FiniteField.Extension K p 1)) = + RingHom.id K := by + ext c + simp [e, extensionOneAlgEquiv] + rw [hcomp, MvPolynomial.map_id] + simpa only [hpoly] using + affineBivariatePointMapEquiv e.toRingEquiv + (extensionPlaneCurvePolynomial K p 1 f) + +omit [NeZero n] in +/-- The degree-one extension point count is the original base-field point +count. -/ +@[simp] +theorem extensionAffinePointCount_one + (f : MvPolynomial (Fin 2) K) : + extensionAffinePointCount K p 1 f = + affineBivariatePointCount f := by + exact Nat.card_congr (extensionOneAffinePointEquiv K p f) + +end DegreeOne + +/-- Absolute irreducibility is preserved after passing to the chosen finite +extension. -/ +theorem extensionPlaneCurvePolynomial_absolutelyIrreducible + (f : MvPolynomial (Fin 2) K) + (habsolute : Irreducible + (MvPolynomial.map (algebraMap K (AlgebraicClosure K)) f)) : + Irreducible + (MvPolynomial.map + (algebraMap (FiniteField.Extension K p n) + (AlgebraicClosure (FiniteField.Extension K p n))) + (extensionPlaneCurvePolynomial K p n f)) := by + have h := irreducible_map_of_irreducible_map_algebraicClosure + ((algebraMap (FiniteField.Extension K p n) + (AlgebraicClosure (FiniteField.Extension K p n))).comp + (algebraMap K (FiniteField.Extension K p n))) f habsolute + simpa only [extensionPlaneCurvePolynomial, MvPolynomial.map_map] using h + +/-- Partial differentiation commutes with extension of constants. -/ +@[simp] +theorem extensionPlaneCurvePolynomial_pderiv + (f : MvPolynomial (Fin 2) K) (i : Fin 2) : + MvPolynomial.pderiv i (extensionPlaneCurvePolynomial K p n f) = + extensionPlaneCurvePolynomial K p n (MvPolynomial.pderiv i f) := by + rw [extensionPlaneCurvePolynomial, extensionPlaneCurvePolynomial, + MvPolynomial.pderiv_map] + +/-- A nonzero partial derivative remains nonzero after extension of +constants. -/ +theorem extensionPlaneCurvePolynomial_pderiv_ne_zero + (f : MvPolynomial (Fin 2) K) (i : Fin 2) + (hpartial : MvPolynomial.pderiv i f ≠ 0) : + MvPolynomial.pderiv i (extensionPlaneCurvePolynomial K p n f) ≠ 0 := by + rw [extensionPlaneCurvePolynomial_pderiv] + intro hz + apply hpartial + apply MvPolynomial.map_injective + (algebraMap K (FiniteField.Extension K p n)) + (algebraMap K (FiniteField.Extension K p n)).injective + rw [map_zero] + simpa only [extensionPlaneCurvePolynomial] using hz + +/-- The function field of the base-changed absolutely irreducible plane +curve has the chosen extension as its exact constant field. -/ +theorem extensionPlaneCurveFunctionField_algebraicClosure_eq_bot + (f : MvPolynomial (Fin 2) K) + (habsolute : Irreducible + (MvPolynomial.map (algebraMap K (AlgebraicClosure K)) f)) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) : + let fE := MvPolynomial.map + (algebraMap K (FiniteField.Extension K p n)) f + let hfE := irreducible_map_of_irreducible_map_algebraicClosure + (algebraMap K (FiniteField.Extension K p n)) f habsolute + letI := planeCurveCoordinateRing_isDomain hfE + algebraicClosure (FiniteField.Extension K p n) + (PlaneCurveFunctionField fE) = ⊥ := + planeCurveBaseChangeFunctionField_algebraicClosure_eq_bot + (E := FiniteField.Extension K p n) f habsolute hpartialSecond + +end Extension + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/FilteredDimension.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/FilteredDimension.lean new file mode 100644 index 0000000000..cdee11647b --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/FilteredDimension.lean @@ -0,0 +1,101 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import Mathlib.LinearAlgebra.FiniteDimensional.Lemmas + +/-! +# Dimension growth in a one-point filtration + +This file isolates the reusable linear-algebra step in the one-point +filtration used in Stepanov-style arguments. If every element of a larger +subspace is congruent modulo the preceding subspace to a scalar multiple of +one pivot, then adjoining that pivot generates the larger subspace. Hence a +single filtration step increases dimension by at most one. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +variable {K L : Type*} [Field K] [AddCommGroup L] [Module K L] + +/-- If every element of `T` is congruent modulo `S` to a scalar multiple of +`y`, then `T` is generated by `S` and `y`. -/ +theorem eq_sup_span_singleton_of_exists_sub_smul_mem + {S T : Submodule K L} {y : L} + (hST : S ≤ T) (hy : y ∈ T) + (hmod : ∀ x ∈ T, ∃ c : K, x - c • y ∈ S) : + T = S ⊔ K ∙ y := by + apply le_antisymm + · intro x hx + obtain ⟨c, hc⟩ := hmod x hx + rw [← sub_add_cancel x (c • y)] + exact (S ⊔ K ∙ y).add_mem + ((show S ≤ S ⊔ K ∙ y from le_sup_left) hc) + ((show K ∙ y ≤ S ⊔ K ∙ y from le_sup_right) + (Submodule.smul_mem _ c (Submodule.mem_span_singleton_self y))) + · exact sup_le hST ((Submodule.span_singleton_le_iff_mem y T).mpr hy) + +/-- A one-pivot extension of a finite-dimensional subspace is again +finite-dimensional. -/ +theorem moduleFinite_of_exists_sub_smul_mem + {S T : Submodule K L} {y : L} + (hST : S ≤ T) (hy : y ∈ T) + (hmod : ∀ x ∈ T, ∃ c : K, x - c • y ∈ S) + [Module.Finite K S] : + Module.Finite K T := by + rw [eq_sup_span_singleton_of_exists_sub_smul_mem hST hy hmod] + infer_instance + +/-- A one-pivot extension increases finrank by at most one. -/ +theorem finrank_le_add_one_of_exists_sub_smul_mem + {S T : Submodule K L} {y : L} + (hST : S ≤ T) (hy : y ∈ T) + (hmod : ∀ x ∈ T, ∃ c : K, x - c • y ∈ S) + [Module.Finite K S] : + Module.finrank K T ≤ Module.finrank K S + 1 := by + have hspan : Module.finrank K (K ∙ y) ≤ 1 := by + classical + simpa using (finrank_span_le_card (R := K) ({y} : Set L)) + rw [eq_sup_span_singleton_of_exists_sub_smul_mem hST hy hmod] + exact (Submodule.finrank_add_le_finrank_add_finrank S (K ∙ y)).trans + (Nat.add_le_add_left hspan (Module.finrank K S)) + +/-- Along a nested filtration whose successive quotients are generated by one +pivot, every stage is finite-dimensional and stage `n` has finrank at most +the initial finrank plus `n`. -/ +theorem onePointFiltration_moduleFinite_and_finrank_le + (R : ℕ → Submodule K L) (y : ℕ → L) + (hnested : ∀ n, R n ≤ R (n + 1)) + (hpivot : ∀ n, y n ∈ R (n + 1)) + (hmod : ∀ n x, x ∈ R (n + 1) → + ∃ c : K, x - c • y n ∈ R n) + [Module.Finite K (R 0)] : + ∀ n, Module.Finite K (R n) ∧ + Module.finrank K (R n) ≤ Module.finrank K (R 0) + n := by + intro n + induction n with + | zero => + exact ⟨inferInstance, by simp⟩ + | succ n ih => + let : Module.Finite K (R n) := ih.1 + have hfinite : Module.Finite K (R (n + 1)) := + moduleFinite_of_exists_sub_smul_mem + (hnested n) (hpivot n) (hmod n) + let : Module.Finite K (R (n + 1)) := hfinite + refine ⟨hfinite, ?_⟩ + calc + Module.finrank K (R (n + 1)) ≤ Module.finrank K (R n) + 1 := + finrank_le_add_one_of_exists_sub_smul_mem + (hnested n) (hpivot n) (hmod n) + _ ≤ (Module.finrank K (R 0) + n) + 1 := + Nat.add_le_add_right ih.2 1 + _ = Module.finrank K (R 0) + (n + 1) := by + rw [Nat.add_assoc] + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteBranchLocus.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteBranchLocus.lean new file mode 100644 index 0000000000..96dd6e288d --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteBranchLocus.lean @@ -0,0 +1,409 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.DedekindDifferentDivisor +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionPlaceTower + +/-! +# Finiteness of the branch locus + +For a finite separable extension of Dedekind domains, a height-one prime is +ramified exactly when it divides the different. The different is nonzero and +has finite prime support, so both the ramification locus upstairs and its image +in the base are finite. This is the algebraic branch-locus finiteness used for +finite separable morphisms of curves. + +The final theorems attach to every exhaustive closed place its residue-degree +weight over the constant field. The branch support is finite, and the +degree-weighted sum over any selected part of it is at most the full branch +sum. Passing from this closed-place bound to a uniform count of geometric +branch points after constant-field extension still requires an explicit +closed-place/geometric-point comparison. +-/ + +@[expose] public section + +open scoped BigOperators +open IsDedekindDomain + +namespace BGS.HasseWeil + +noncomputable section + +attribute [local instance] FractionRing.liftAlgebra + FractionRing.isScalarTower_liftAlgebra + +section Dedekind + +variable (A B : Type*) [CommRing A] [CommRing B] + [IsDedekindDomain A] [IsDedekindDomain B] + [Algebra A B] + [Module.Finite A B] [Module.IsTorsionFree A B] + [Algebra.IsSeparable (FractionRing A) (FractionRing B)] + +/-- The height-one primes upstairs at which a finite separable Dedekind +extension is ramified. -/ +def dedekindRamificationLocus : Set (HeightOneSpectrum B) := + {Q | ¬ Algebra.IsUnramifiedAt A Q.asIdeal} + +/-- The ramification locus is contained in the finite support of the +different, and is therefore finite. -/ +theorem dedekindRamificationLocus_finite : + (dedekindRamificationLocus A B).Finite := by + let hDifferent : differentIdeal A B ≠ ⊥ := differentIdeal_ne_bot + let D := BGS.CorvajaZannier.differentMultiplicityDivisor A B hDifferent + refine D.support.finite_toSet.subset ?_ + intro Q hQ + rw [Finset.mem_coe, Finsupp.mem_support_iff] + have hdiv : Q.asIdeal ∣ differentIdeal A B := + dvd_differentIdeal_iff.mpr hQ + simpa [D, BGS.CorvajaZannier.differentMultiplicityDivisor_apply] using + (multiplicity_pos_of_dvd hdiv (FiniteMultiplicity.of_prime_left Q.prime hDifferent)).ne' + +/-- The branch locus downstairs is the image of the ramification locus under +contraction of height-one primes. -/ +def dedekindBranchLocus : Set (HeightOneSpectrum A) := + HeightOneSpectrum.under A '' dedekindRamificationLocus A B + +/-- The branch locus of a finite separable Dedekind extension is finite. -/ +theorem dedekindBranchLocus_finite : + (dedekindBranchLocus A B).Finite := by + exact (dedekindRamificationLocus_finite A B).image + (HeightOneSpectrum.under A) + +/-- Any distinguished subset of the closed-place branch locus has cardinality +at most the full closed-place branch locus. -/ +theorem dedekindBranchLocus_selected_ncard_le + (isSelected : HeightOneSpectrum A → Prop) : + (dedekindBranchLocus A B ∩ {P | isSelected P}).ncard ≤ + (dedekindBranchLocus A B).ncard := by + exact Set.ncard_le_ncard Set.inter_subset_left + (dedekindBranchLocus_finite A B) + +end Dedekind + +section FunctionField + +open BGS.CorvajaZannier Polynomial + +variable (K : Type*) [Field K] [DecidableEq (RatFunc K)] +variable (M : Type*) [Field M] [Algebra (RatFunc K) M] + [FiniteDimensional (RatFunc K) M] + [Algebra.IsSeparable (RatFunc K) M] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + [Algebra M L] [IsScalarTower (RatFunc K) M L] + +local instance (priority := 10) branchPolynomialAlgebraM : Algebra K[X] M := + RingHom.toAlgebra ((algebraMap (RatFunc K) M).comp + (algebraMap K[X] (RatFunc K))) + +local instance (priority := 10) branchPolynomialAlgebraL : Algebra K[X] L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K[X] (RatFunc K))) + +local instance branchPolynomialTowerM : IsScalarTower K[X] (RatFunc K) M := + IsScalarTower.of_algebraMap_eq' rfl + +local instance branchPolynomialTowerL : IsScalarTower K[X] (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + +local instance branchPolynomialFieldTower : IsScalarTower K[X] M L := + IsScalarTower.of_algebraMap_eq fun x => by + change algebraMap (RatFunc K) L (algebraMap K[X] (RatFunc K) x) = + algebraMap M L + (algebraMap (RatFunc K) M (algebraMap K[X] (RatFunc K) x)) + exact IsScalarTower.algebraMap_apply (RatFunc K) M L _ + +local instance branchFiniteClosureAlgebra : + Algebra (RatFuncFiniteIntegralClosure K M) + (RatFuncFiniteIntegralClosure K L) := + (finiteIntegralClosureMap K M L).toAlgebra + +local instance branchFiniteIntermediateIntegral : + Algebra.IsIntegral K[X] (RatFuncFiniteIntegralClosure K M) := + IsIntegralClosure.isIntegral_algebra K[X] M + +local instance branchFiniteTopIntegral : + Algebra.IsIntegral K[X] (RatFuncFiniteIntegralClosure K L) := + IsIntegralClosure.isIntegral_algebra K[X] L + +local instance branchFiniteIntermediateModuleFinite : + Module.Finite K[X] (RatFuncFiniteIntegralClosure K M) := + Module.IsNoetherian.finite K[X] (RatFuncFiniteIntegralClosure K M) + +local instance branchFiniteTopModuleFinite : + Module.Finite K[X] (RatFuncFiniteIntegralClosure K L) := + Module.IsNoetherian.finite K[X] (RatFuncFiniteIntegralClosure K L) + +local instance branchFiniteIntermediateTorsionFree : + Module.IsTorsionFree K[X] M := + Module.IsTorsionFree.trans_faithfulSMul K[X] (RatFunc K) M + +local instance branchFiniteTopTorsionFree : + Module.IsTorsionFree K[X] L := + Module.IsTorsionFree.trans_faithfulSMul K[X] (RatFunc K) L + +local instance branchFiniteIntermediateClosureTorsionFree : + Module.IsTorsionFree K[X] (RatFuncFiniteIntegralClosure K M) := + IsIntegralClosure.isTorsionFree K[X] M + +local instance branchFiniteTopClosureTorsionFree : + Module.IsTorsionFree K[X] (RatFuncFiniteIntegralClosure K L) := + IsIntegralClosure.isTorsionFree K[X] L + +local instance branchFiniteIntermediateDedekind : + IsDedekindDomain (RatFuncFiniteIntegralClosure K M) := + IsIntegralClosure.isDedekindDomain K[X] (RatFunc K) M + (RatFuncFiniteIntegralClosure K M) + +local instance branchFiniteTopDedekind : + IsDedekindDomain (RatFuncFiniteIntegralClosure K L) := + IsIntegralClosure.isDedekindDomain K[X] (RatFunc K) L + (RatFuncFiniteIntegralClosure K L) + +local instance branchFiniteClosuresTower : + IsScalarTower K[X] (RatFuncFiniteIntegralClosure K M) + (RatFuncFiniteIntegralClosure K L) := + IsScalarTower.of_algebraMap_eq fun _ => by + apply Subtype.ext + change algebraMap K[X] L _ = algebraMap M L (algebraMap K[X] M _) + exact IsScalarTower.algebraMap_apply K[X] M L _ + +local instance branchFiniteRelativeIntegral : + Algebra.IsIntegral (RatFuncFiniteIntegralClosure K M) + (RatFuncFiniteIntegralClosure K L) := + Algebra.IsIntegral.tower_top K[X] + +local instance branchFiniteRelativeFaithful : + FaithfulSMul (RatFuncFiniteIntegralClosure K M) + (RatFuncFiniteIntegralClosure K L) := by + rw [faithfulSMul_iff_algebraMap_injective] + intro x y hxy + apply Subtype.ext + apply (algebraMap M L).injective + exact congrArg Subtype.val hxy + +local instance branchFiniteRelativeModuleFinite : + Module.Finite (RatFuncFiniteIntegralClosure K M) + (RatFuncFiniteIntegralClosure K L) := + Module.Finite.of_restrictScalars_finite K[X] + (RatFuncFiniteIntegralClosure K M) + (RatFuncFiniteIntegralClosure K L) + +local instance branchFiniteIntermediateClosureFieldTower : + IsScalarTower (RatFuncFiniteIntegralClosure K M) M L := + inferInstance + +local instance branchFiniteTopClosureFieldTower : + IsScalarTower (RatFuncFiniteIntegralClosure K M) + (RatFuncFiniteIntegralClosure K L) L := + ⟨fun r s x => by + simp only [Algebra.smul_def, map_mul] + rw [show algebraMap (RatFuncFiniteIntegralClosure K L) L + (algebraMap (RatFuncFiniteIntegralClosure K M) + (RatFuncFiniteIntegralClosure K L) r) = + algebraMap (RatFuncFiniteIntegralClosure K M) L r by rfl] + ring⟩ + +local instance branchFiniteIntermediateFractionRing : + IsFractionRing (RatFuncFiniteIntegralClosure K M) M := + IsIntegralClosure.isFractionRing_of_finite_extension + K[X] (RatFunc K) M (RatFuncFiniteIntegralClosure K M) + +local instance branchFiniteTopFractionRing : + IsFractionRing (RatFuncFiniteIntegralClosure K L) L := + IsIntegralClosure.isFractionRing_of_finite_extension + K[X] (RatFunc K) L (RatFuncFiniteIntegralClosure K L) + +local instance branchFiniteFractionRingSeparable : + Algebra.IsSeparable + (FractionRing (RatFuncFiniteIntegralClosure K M)) + (FractionRing (RatFuncFiniteIntegralClosure K L)) := by + let : Algebra.IsSeparable M L := + Algebra.isSeparable_tower_top_of_isSeparable (RatFunc K) M L + refine Algebra.IsSeparable.of_equiv_equiv + (FractionRing.algEquiv (RatFuncFiniteIntegralClosure K M) M).symm.toRingEquiv + (FractionRing.algEquiv (RatFuncFiniteIntegralClosure K L) L).symm.toRingEquiv ?_ + ext z + exact IsFractionRing.algEquiv_commutes + (FractionRing.algEquiv (RatFuncFiniteIntegralClosure K M) M).symm + (FractionRing.algEquiv (RatFuncFiniteIntegralClosure K L) L).symm z + +local instance branchInfinityClosureAlgebra : + Algebra (RatFuncInfinityIntegralClosure K M) + (RatFuncInfinityIntegralClosure K L) := + (infinityIntegralClosureMap K M L).toAlgebra + +local instance branchInfinityIntermediateIntegral : + Algebra.IsIntegral (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K M) := + IsIntegralClosure.isIntegral_algebra (RatFuncInfinityIntegers K) M + +local instance branchInfinityIntermediateModuleFinite : + Module.Finite (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K M) := + IsIntegralClosure.finite (RatFuncInfinityIntegers K) (RatFunc K) M + (RatFuncInfinityIntegralClosure K M) + +local instance branchInfinityIntermediateDedekind : + IsDedekindDomain (RatFuncInfinityIntegralClosure K M) := + IsIntegralClosure.isDedekindDomain (RatFuncInfinityIntegers K) + (RatFunc K) M (RatFuncInfinityIntegralClosure K M) + +local instance branchInfinityPlaceFintype : + Fintype (FiniteExtensionInfinityPlace K M) := + Set.Finite.fintype + (IsDedekindDomain.primesOver_finite + (ratFuncInfinityPlace K).asIdeal + (RatFuncInfinityIntegralClosure K M)) + +/-- The exhaustive branch locus of the finite separable function-field tower +`L / M / K(t)`. The finite chart is the contraction of the different support; +the infinity chart records the base infinity places admitting a ramified lift. +-/ +def finiteExtensionBranchLocus : Set (FiniteExtensionPlace K M) := + Sum.inl '' dedekindBranchLocus + (RatFuncFiniteIntegralClosure K M) + (RatFuncFiniteIntegralClosure K L) ∪ + Sum.inr '' {P : FiniteExtensionInfinityPlace K M | + ∃ Q : FiniteExtensionInfinityPlace K L, + infinityPlaceUnder K M L Q = P ∧ + ¬ Algebra.IsUnramifiedAt + (RatFuncInfinityIntegralClosure K M) Q.1} + +/-- The exhaustive branch locus of a finite separable function-field +extension is finite. -/ +theorem finiteExtensionBranchLocus_finite : + (finiteExtensionBranchLocus K M L).Finite := by + apply Set.Finite.union + · exact (dedekindBranchLocus_finite + (RatFuncFiniteIntegralClosure K M) + (RatFuncFiniteIntegralClosure K L)).image Sum.inl + · exact (Set.toFinite _).image Sum.inr + +section DegreeWeight + +variable [DecidableEq K] + +/-- The nonnegative weight of an exhaustive closed place is its degree over +the constant field `K`. On the finite chart this is the relative residue +degree times the degree of the contracted polynomial place; above infinity it +is the relative residue degree, since the base infinity place has degree one. +-/ +def finiteExtensionClosedPlaceWeight + (P : FiniteExtensionPlace K M) : ℕ := + finiteExtensionPlaceDegree K M P + +omit [FiniteDimensional (RatFunc K) M] + [Algebra.IsSeparable (RatFunc K) M] in +@[simp] +theorem finiteExtensionClosedPlaceWeight_inl + (P : FiniteExtensionFinitePlace K M) : + finiteExtensionClosedPlaceWeight K M (.inl P) = + P.asIdeal.inertiaDeg K[X] * + ratFuncFinitePlaceDegree (HeightOneSpectrum.under K[X] P) := by + rfl + +omit [FiniteDimensional (RatFunc K) M] + [Algebra.IsSeparable (RatFunc K) M] in +@[simp] +theorem finiteExtensionClosedPlaceWeight_inr + (P : FiniteExtensionInfinityPlace K M) : + finiteExtensionClosedPlaceWeight K M (.inr P) = + P.1.inertiaDeg (RatFuncInfinityIntegers K) := by + rfl + +/-- The finite support on which the branch-locus degree sum is taken. -/ +def finiteExtensionBranchLocusSupport : + Finset (FiniteExtensionPlace K M) := + (finiteExtensionBranchLocus_finite K M L).toFinset + +omit [DecidableEq K] in +@[simp] +theorem mem_finiteExtensionBranchLocusSupport_iff + (P : FiniteExtensionPlace K M) : + P ∈ finiteExtensionBranchLocusSupport K M L ↔ + P ∈ finiteExtensionBranchLocus K M L := by + simp [finiteExtensionBranchLocusSupport] + +omit [DecidableEq K] in +/-- The support finset represents exactly the finite branch locus. -/ +theorem finiteExtensionBranchLocusSupport_coe : + (finiteExtensionBranchLocusSupport K M L : + Set (FiniteExtensionPlace K M)) = + finiteExtensionBranchLocus K M L := by + ext P + simp + +omit [DecidableEq K] in +/-- In set form, the exact branch support is finite. -/ +theorem finiteExtensionBranchLocusSupport_finite : + ((finiteExtensionBranchLocusSupport K M L : + Finset (FiniteExtensionPlace K M)) : + Set (FiniteExtensionPlace K M)).Finite := + Finset.finite_toSet _ + +/-- The total residue-degree weight of the exhaustive branch locus. -/ +def finiteExtensionBranchLocusDegreeSum : ℕ := + ∑ P ∈ finiteExtensionBranchLocusSupport K M L, + finiteExtensionClosedPlaceWeight K M P + +/-- The finite branch support restricted by an arbitrary predicate. -/ +def finiteExtensionBranchLocusSelectedSupport + (isSelected : FiniteExtensionPlace K M → Prop) : + Finset (FiniteExtensionPlace K M) := by + classical + exact (finiteExtensionBranchLocusSupport K M L).filter isSelected + +omit [DecidableEq K] in +@[simp] +theorem mem_finiteExtensionBranchLocusSelectedSupport_iff + (isSelected : FiniteExtensionPlace K M → Prop) + (P : FiniteExtensionPlace K M) : + P ∈ finiteExtensionBranchLocusSelectedSupport K M L isSelected ↔ + P ∈ finiteExtensionBranchLocus K M L ∧ isSelected P := by + classical + simp [finiteExtensionBranchLocusSelectedSupport] + +/-- The residue-degree weight of a selected part of the finite branch +support. -/ +def finiteExtensionBranchLocusSelectedDegreeSum + (isSelected : FiniteExtensionPlace K M → Prop) : ℕ := + ∑ P ∈ finiteExtensionBranchLocusSelectedSupport K M L isSelected, + finiteExtensionClosedPlaceWeight K M P + +/-- Every selected part of the branch locus has residue-degree weight at most +the total residue-degree weight of the full finite branch support. -/ +theorem finiteExtensionBranchLocus_selected_degreeSum_le + (isSelected : FiniteExtensionPlace K M → Prop) : + finiteExtensionBranchLocusSelectedDegreeSum K M L isSelected ≤ + finiteExtensionBranchLocusDegreeSum K M L := by + classical + rw [finiteExtensionBranchLocusSelectedDegreeSum, + finiteExtensionBranchLocusDegreeSum, + finiteExtensionBranchLocusSelectedSupport] + exact Finset.sum_le_sum_of_subset (Finset.filter_subset _ _) + +end DegreeWeight + +/-- Any distinguished subset of the exhaustive closed-place branch locus has +cardinality at most the full closed-place branch locus. -/ +theorem finiteExtensionBranchLocus_selected_ncard_le + (isSelected : FiniteExtensionPlace K M → Prop) : + (finiteExtensionBranchLocus K M L ∩ {P | isSelected P}).ncard ≤ + (finiteExtensionBranchLocus K M L).ncard := by + exact Set.ncard_le_ncard Set.inter_subset_left + (finiteExtensionBranchLocus_finite K M L) + +end FunctionField + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionAffineIdealDegree.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionAffineIdealDegree.lean new file mode 100644 index 0000000000..38bbf5708b --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionAffineIdealDegree.lean @@ -0,0 +1,217 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionExhaustiveProductFormula +public import Mathlib.NumberTheory.ClassNumber.FunctionField +public import Mathlib.RingTheory.Ideal.Quotient.HasFiniteQuotients.Basic +public import Mathlib.RingTheory.Ideal.Quotient.HasFiniteQuotients.Norm + +/-! +# Affine ideal degrees in a finite function field + +The finite class group of the normalization of `K[X]` controls ideal classes, +but an affine ideal zeta series also needs finite coefficient sets. This file +provides that missing finiteness layer for a finite separable extension of +`K(X)` over a finite field `K`. + +First, every nonzero quotient of `K[X]` is finite: a nonzero ideal contains a +monic polynomial up to multiplication by a unit, and its quotient maps onto +the original quotient. Module finiteness transfers this property to the +normalization of `K[X]` in the function field. For a nonzero ideal `I`, its +affine degree is then the `K`-dimension of the quotient by `I`. Consequently + +`cardQuot I = |K| ^ degree(I)`, + +and Mathlib's bounded-quotient-cardinality theorem makes the ideals of each +fixed degree into a finite type. No Riemann--Roch or Hasse--Weil input is used. +-/ + +@[expose] public section + +open scoped Polynomial nonZeroDivisors + +namespace BGS.HasseWeil + +noncomputable section + +open BGS.CorvajaZannier + +variable (K : Type*) [Field K] [Fintype K] + +omit [Fintype K] in +/-- The polynomial ring over a finite field has finite quotients. -/ +theorem ratFuncPolynomial_hasFiniteQuotients [Finite K] : + Ring.HasFiniteQuotients K[X] := by + constructor + intro I hI + obtain ⟨f, hfI, hf0⟩ := Submodule.exists_mem_ne_zero_of_ne_bot hI + let g : K[X] := f * Polynomial.C f.leadingCoeff⁻¹ + have hgmonic : g.Monic := Polynomial.monic_mul_leadingCoeff_inv hf0 + have hgI : g ∈ I := by + exact I.mul_mem_right (Polynomial.C f.leadingCoeff⁻¹) hfI + have hspan : Ideal.span ({g} : Set K[X]) ≤ I := by + rw [Ideal.span_le, Set.singleton_subset_iff] + exact hgI + let : Module.Finite K (K[X] ⧸ Ideal.span ({g} : Set K[X])) := + hgmonic.finite_quotient + let : Finite (K[X] ⧸ Ideal.span ({g} : Set K[X])) := + Module.finite_of_finite K + exact Finite.of_surjective (Ideal.Quotient.factor hspan) + (Ideal.Quotient.factor_surjective hspan) + +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +local instance (priority := 10) affineIdealPolynomialAlgebra : + Algebra K[X] L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K[X] (RatFunc K))) + +local instance affineIdealPolynomialTower : + IsScalarTower K[X] (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + +local instance affineIdealClosureModuleFinite : + Module.Finite K[X] (RatFuncFiniteIntegralClosure K L) := + Module.IsNoetherian.finite K[X] (RatFuncFiniteIntegralClosure K L) + +local instance affineIdealClosureConstantAlgebra : + Algebra K (RatFuncFiniteIntegralClosure K L) := + RingHom.toAlgebra ((algebraMap K[X] + (RatFuncFiniteIntegralClosure K L)).comp (algebraMap K K[X])) + +local instance affineIdealClosureConstantTower : + IsScalarTower K K[X] (RatFuncFiniteIntegralClosure K L) := + IsScalarTower.of_algebraMap_eq' rfl + +omit [Fintype K] in +/-- The normalization of `K[X]` in a finite separable extension of `K(X)` has +finite quotients. -/ +theorem ratFuncFiniteIntegralClosure_hasFiniteQuotients [Finite K] : + Ring.HasFiniteQuotients (RatFuncFiniteIntegralClosure K L) := by + let : Ring.HasFiniteQuotients K[X] := + ratFuncPolynomial_hasFiniteQuotients K + exact Ring.HasFiniteQuotients.of_module_finite K[X] + (RatFuncFiniteIntegralClosure K L) + +omit [Fintype K] in +/-- The affine ideal class group is finite. This is the function-field class +number theorem from Mathlib, stated at the normalization used by BGS. -/ +theorem finiteExtensionAffineClassGroup_finite [Finite K] : + Finite (ClassGroup (RatFuncFiniteIntegralClosure K L)) := by + let : Fintype K := Fintype.ofFinite K + let : Fintype (ClassGroup (RatFuncFiniteIntegralClosure K L)) := + inferInstance + exact Fintype.finite inferInstance + +/-- Nonzero affine ideals in the normalization of `K[X]` in `L`. -/ +abbrev FiniteExtensionAffineIdeal := + (Ideal (RatFuncFiniteIntegralClosure K L))⁰ + +/-- The degree of a nonzero affine ideal is the `K`-dimension of its quotient. -/ +def finiteExtensionAffineIdealDegree + (I : FiniteExtensionAffineIdeal K L) : ℕ := by + letI : Ring.HasFiniteQuotients (RatFuncFiniteIntegralClosure K L) := + ratFuncFiniteIntegralClosure_hasFiniteQuotients K L + have hI : (I : Ideal (RatFuncFiniteIntegralClosure K L)) ≠ ⊥ := by + rw [← Ideal.zero_eq_bot] + exact mem_nonZeroDivisors_iff_ne_zero.mp I.property + letI : Finite (RatFuncFiniteIntegralClosure K L ⧸ + (I : Ideal (RatFuncFiniteIntegralClosure K L))) := + Ring.HasFiniteQuotients.finiteQuotient hI + letI : Module.Finite K (RatFuncFiniteIntegralClosure K L ⧸ + (I : Ideal (RatFuncFiniteIntegralClosure K L))) := + Module.Finite.of_finite + exact Module.finrank K (RatFuncFiniteIntegralClosure K L ⧸ + (I : Ideal (RatFuncFiniteIntegralClosure K L))) + +/-- Quotient cardinality is the cardinality of the constant field raised to +the affine ideal degree. -/ +theorem finiteExtensionAffineIdeal_cardQuot_eq_card_pow_degree + (I : FiniteExtensionAffineIdeal K L) : + (I : Ideal (RatFuncFiniteIntegralClosure K L)).cardQuot = + Fintype.card K ^ finiteExtensionAffineIdealDegree K L I := by + let : Ring.HasFiniteQuotients (RatFuncFiniteIntegralClosure K L) := + ratFuncFiniteIntegralClosure_hasFiniteQuotients K L + have hI : (I : Ideal (RatFuncFiniteIntegralClosure K L)) ≠ ⊥ := by + rw [← Ideal.zero_eq_bot] + exact mem_nonZeroDivisors_iff_ne_zero.mp I.property + let : Finite (RatFuncFiniteIntegralClosure K L ⧸ + (I : Ideal (RatFuncFiniteIntegralClosure K L))) := + Ring.HasFiniteQuotients.finiteQuotient hI + let : Module.Finite K (RatFuncFiniteIntegralClosure K L ⧸ + (I : Ideal (RatFuncFiniteIntegralClosure K L))) := + Module.Finite.of_finite + rw [Submodule.cardQuot_apply, finiteExtensionAffineIdealDegree, + ← Nat.card_eq_fintype_card] + exact Module.natCard_eq_pow_finrank + +omit [Fintype K] in +/-- An affine ideal has degree zero exactly when it is the unit ideal. -/ +theorem finiteExtensionAffineIdealDegree_eq_zero_iff [Finite K] + (I : FiniteExtensionAffineIdeal K L) : + finiteExtensionAffineIdealDegree K L I = 0 ↔ + (I : Ideal (RatFuncFiniteIntegralClosure K L)) = ⊤ := by + let : Fintype K := Fintype.ofFinite K + constructor + · intro hdegree + apply Submodule.cardQuot_eq_one_iff.mp + rw [finiteExtensionAffineIdeal_cardQuot_eq_card_pow_degree K L I, + hdegree, pow_zero] + · intro hI + let : Ring.HasFiniteQuotients (RatFuncFiniteIntegralClosure K L) := + ratFuncFiniteIntegralClosure_hasFiniteQuotients K L + have hne : (I : Ideal (RatFuncFiniteIntegralClosure K L)) ≠ ⊥ := by + rw [← Ideal.zero_eq_bot] + exact mem_nonZeroDivisors_iff_ne_zero.mp I.property + let : Finite (RatFuncFiniteIntegralClosure K L ⧸ + (I : Ideal (RatFuncFiniteIntegralClosure K L))) := + Ring.HasFiniteQuotients.finiteQuotient hne + let : Module.Finite K (RatFuncFiniteIntegralClosure K L ⧸ + (I : Ideal (RatFuncFiniteIntegralClosure K L))) := + Module.Finite.of_finite + rw [finiteExtensionAffineIdealDegree, hI] + exact Module.finrank_zero_of_subsingleton + +omit [Fintype K] in +/-- There are only finitely many nonzero affine ideals of any prescribed +degree. -/ +theorem finite_setOf_finiteExtensionAffineIdealDegree_eq [Finite K] (n : ℕ) : + {I : FiniteExtensionAffineIdeal K L | + finiteExtensionAffineIdealDegree K L I = n}.Finite := by + let : Fintype K := Fintype.ofFinite K + let : Ring.HasFiniteQuotients (RatFuncFiniteIntegralClosure K L) := + ratFuncFiniteIntegralClosure_hasFiniteQuotients K L + apply Set.Finite.of_injOn + (f := fun I : FiniteExtensionAffineIdeal K L => + (I : Ideal (RatFuncFiniteIntegralClosure K L))) + (t := {J : Ideal (RatFuncFiniteIntegralClosure K L) | + J.cardQuot ≤ Fintype.card K ^ n}) + · intro I hI + simp only [Set.mem_ofPred_eq] at hI ⊢ + rw [finiteExtensionAffineIdeal_cardQuot_eq_card_pow_degree K L I, hI] + · intro I _ J _ hIJ + exact Subtype.ext hIJ + · exact Ring.HasFiniteQuotients.finite_cardQuot_le _ + +/-- A finite indexing type for nonzero affine ideals of degree `n`. -/ +noncomputable instance finiteExtensionAffineIdealsOfDegree_fintype (n : ℕ) : + Fintype {I : FiniteExtensionAffineIdeal K L // + finiteExtensionAffineIdealDegree K L I = n} := + (finite_setOf_finiteExtensionAffineIdealDegree_eq K L n).fintype + +/-- The number of nonzero affine ideals of degree `n`; this is the natural +coefficient sequence for the affine ideal zeta series. -/ +noncomputable def finiteExtensionAffineIdealCount (n : ℕ) : ℕ := + Fintype.card {I : FiniteExtensionAffineIdeal K L // + finiteExtensionAffineIdealDegree K L I = n} + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionAffineIdealDivisor.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionAffineIdealDivisor.lean new file mode 100644 index 0000000000..b905e27188 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionAffineIdealDivisor.lean @@ -0,0 +1,492 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionAffineIdealDegree +public import LeanPool.MarkoffModP.BGS.HasseWeil.FunctionFieldConstantField +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.DedekindDifferentDivisor +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionPrincipalDivisor + +/-! +# Nonzero affine ideals as effective finite divisors + +In a Dedekind domain, a nonzero ideal is uniquely determined by the +multiplicity of every height-one prime in its factorization. This file +packages that factorization as an equivalence between nonzero ideals and +effective, finitely supported divisors. + +Specializing to the normalization of `K[X]` in a finite separable extension +of `K(X)` identifies nonzero affine ideals with effective divisors on the +finite places of the function field. The equivalence is purely Dedekind +factorization: it does not use Riemann--Roch or a zeta-function argument. +-/ + +@[expose] public section + +open scoped nonZeroDivisors Polynomial +open IsDedekindDomain + +namespace BGS.HasseWeil + +noncomputable section + +open BGS.CorvajaZannier + +section DedekindDomain + +variable {R : Type*} [CommRing R] [IsDedekindDomain R] + +/-- The ideal represented by an effective divisor on the height-one primes of +a Dedekind domain. -/ +def effectiveDivisorIdeal (D : HeightOneSpectrum R →₀ ℕ) : Ideal R := + D.prod fun v e => v.asIdeal ^ e + +omit [IsDedekindDomain R] in +@[simp] +theorem effectiveDivisorIdeal_zero : + effectiveDivisorIdeal (0 : HeightOneSpectrum R →₀ ℕ) = ⊤ := by + simp [effectiveDivisorIdeal] + +omit [IsDedekindDomain R] in +@[simp] +theorem effectiveDivisorIdeal_single + (v : HeightOneSpectrum R) (e : ℕ) : + effectiveDivisorIdeal (Finsupp.single v e) = v.asIdeal ^ e := by + classical + simp [effectiveDivisorIdeal, Finsupp.prod_single_index] + +omit [IsDedekindDomain R] in +theorem effectiveDivisorIdeal_add + (D E : HeightOneSpectrum R →₀ ℕ) : + effectiveDivisorIdeal (D + E) = + effectiveDivisorIdeal D * effectiveDivisorIdeal E := by + classical + unfold effectiveDivisorIdeal + apply Finsupp.prod_add_index + · intro v _ + exact pow_zero v.asIdeal + · intro v _ a b + exact pow_add v.asIdeal a b + +/-- A height-one prime outside the support of an effective divisor is +coprime to the ideal represented by that divisor. -/ +theorem isCoprime_effectiveDivisorIdeal_of_not_mem_support + (v : HeightOneSpectrum R) (D : HeightOneSpectrum R →₀ ℕ) + (hv : v ∉ D.support) : IsCoprime v.asIdeal (effectiveDivisorIdeal D) := by + classical + induction D using Finsupp.induction with + | zero => + rw [effectiveDivisorIdeal_zero, ← Ideal.one_eq_top] + exact isCoprime_one_right + | single_add a b E ha hb ih => + rw [effectiveDivisorIdeal_add, effectiveDivisorIdeal_single] + apply IsCoprime.mul_right + · have hva : v ≠ a := by + intro hva + apply hv + rw [Finsupp.support_single_add ha hb] + simp [hva] + exact (HeightOneSpectrum.isCoprime_of_ne v a hva).pow_right + · apply ih + intro hvE + apply hv + rw [Finsupp.support_single_add ha hb] + simp [hvE] + +/-- The quotient cardinality of the ideal represented by an effective divisor +is the product of the quotient cardinalities of its prime powers. -/ +theorem cardQuot_effectiveDivisorIdeal_eq_prod + (D : HeightOneSpectrum R →₀ ℕ) : + (effectiveDivisorIdeal D).cardQuot = + D.prod fun v e => v.asIdeal.cardQuot ^ e := by + classical + induction D using Finsupp.induction with + | zero => simp + | single_add a b E ha hb ih => + calc + (effectiveDivisorIdeal (Finsupp.single a b + E)).cardQuot = + (a.asIdeal ^ b).cardQuot * + (effectiveDivisorIdeal E).cardQuot := by + rw [effectiveDivisorIdeal_add, effectiveDivisorIdeal_single, + cardQuot_mul_of_coprime + ((isCoprime_effectiveDivisorIdeal_of_not_mem_support + a E ha).pow_left)] + _ = (a.asIdeal ^ b).cardQuot * + E.prod (fun v e => v.asIdeal.cardQuot ^ e) := by rw [ih] + _ = a.asIdeal.cardQuot ^ b * + E.prod (fun v e => v.asIdeal.cardQuot ^ e) := by + rw [cardQuot_pow_of_prime a.ne_bot] + _ = (Finsupp.single a b).prod + (fun v e => v.asIdeal.cardQuot ^ e) * + E.prod (fun v e => v.asIdeal.cardQuot ^ e) := by + rw [Finsupp.prod_single_index] + simp + _ = (Finsupp.single a b + E).prod + (fun v e => v.asIdeal.cardQuot ^ e) := by + symm + apply Finsupp.prod_add_index + · intro v _ + simp + · intro v _ m n + exact pow_add v.asIdeal.cardQuot m n + +/-- A product of powers of height-one primes is a nonzero ideal. -/ +theorem effectiveDivisorIdeal_ne_bot (D : HeightOneSpectrum R →₀ ℕ) : + effectiveDivisorIdeal D ≠ ⊥ := by + rw [effectiveDivisorIdeal, ← Ideal.zero_eq_bot, + Finsupp.prod_ne_zero_iff] + intro v _ + exact pow_ne_zero _ v.ne_bot + +/-- Reconstructing a nonzero ideal from its prime multiplicities returns the +original ideal. -/ +theorem effectiveDivisorIdeal_idealMultiplicityDivisor + (I : Ideal R) (hI : I ≠ ⊥) : + effectiveDivisorIdeal + (BGS.CorvajaZannier.idealMultiplicityDivisor I hI) = I := by + change + (BGS.CorvajaZannier.idealMultiplicityDivisor I hI).prod + (fun v e => v.asIdeal ^ e) = I + calc + _ = ∏ᶠ v : HeightOneSpectrum R, + v.asIdeal ^ multiplicity v.asIdeal I := by + apply (finprod_eq_prod_of_mulSupport_subset + (fun v : HeightOneSpectrum R => + v.asIdeal ^ multiplicity v.asIdeal I) + (s := (BGS.CorvajaZannier.idealMultiplicityDivisor I hI).support) + ?_).symm + intro v hv + simp only [Function.mem_mulSupport, ne_eq] at hv + apply Finsupp.mem_support_iff.mpr + rw [BGS.CorvajaZannier.idealMultiplicityDivisor_apply] + exact fun hzero => hv (by simp [hzero]) + _ = I := Ideal.finprod_heightOneSpectrum_pow_multiplicity hI + +/-- The multiplicity of a prime in the ideal represented by an effective +divisor is its coefficient in that divisor. -/ +theorem multiplicity_effectiveDivisorIdeal + (D : HeightOneSpectrum R →₀ ℕ) (v : HeightOneSpectrum R) : + multiplicity v.asIdeal (effectiveDivisorIdeal D) = D v := by + let DInt : HeightOneSpectrum R →₀ ℤ := + D.mapRange (fun n : ℕ => (n : ℤ)) (by simp) + let F := FractionalIdeal R⁰ (FractionRing R) + have hcoe : + ((effectiveDivisorIdeal D : Ideal R) : F) = + D.prod (fun w e => (w.asIdeal : F) ^ e) := by + change + (FractionalIdeal.coeIdealHom R⁰ (FractionRing R)) + (D.prod fun w e => w.asIdeal ^ e) = _ + rw [map_finsuppProd] + apply Finsupp.prod_congr + intro w _ + exact FractionalIdeal.coeIdeal_pow R⁰ (FractionRing R) w.asIdeal (D w) + have hcast : + DInt.prod (fun w e => (w.asIdeal : F) ^ e) = + D.prod (fun w e => (w.asIdeal : F) ^ e) := by + dsimp [DInt] + rw [Finsupp.prod_mapRange_index] + · apply Finsupp.prod_congr + intro w _ + exact zpow_natCast (w.asIdeal : F) (D w) + · intro w + exact zpow_zero (w.asIdeal : F) + have hcount := FractionalIdeal.count_finsuppProd + (FractionRing R) v DInt + rw [hcast, ← hcoe, + FractionalIdeal.count_coe (FractionRing R) v + (effectiveDivisorIdeal_ne_bot D)] at hcount + rw [Ideal.count_associates_factors_eq + (effectiveDivisorIdeal_ne_bot D) v.isPrime v.ne_bot, + IsDedekindDomain.HeightOneSpectrum.count_normalizedFactors_eq_multiplicity + (effectiveDivisorIdeal_ne_bot D), Finsupp.mapRange_apply] at hcount + exact Int.ofNat_injective hcount + +/-- Taking prime multiplicities after constructing the ideal represented by +an effective divisor recovers the divisor. -/ +theorem idealMultiplicityDivisor_effectiveDivisorIdeal + (D : HeightOneSpectrum R →₀ ℕ) : + BGS.CorvajaZannier.idealMultiplicityDivisor + (effectiveDivisorIdeal D) (effectiveDivisorIdeal_ne_bot D) = D := by + ext v + rw [BGS.CorvajaZannier.idealMultiplicityDivisor_apply, + multiplicity_effectiveDivisorIdeal] + +/-- A nonzero ideal, regarded as an element of the non-zero-divisors +submonoid, is not the bottom ideal. -/ +theorem nonzeroIdeal_ne_bot (I : (Ideal R)⁰) : (I : Ideal R) ≠ ⊥ := by + rw [← Ideal.zero_eq_bot] + exact mem_nonZeroDivisors_iff_ne_zero.mp I.property + +/-- Dedekind factorization as an equivalence between nonzero ideals and +effective finitely supported divisors on height-one primes. -/ +def nonzeroIdealEffectiveDivisorEquiv : + (Ideal R)⁰ ≃ (HeightOneSpectrum R →₀ ℕ) where + toFun I := BGS.CorvajaZannier.idealMultiplicityDivisor + (I : Ideal R) (nonzeroIdeal_ne_bot I) + invFun D := ⟨effectiveDivisorIdeal D, by + apply mem_nonZeroDivisors_iff_ne_zero.mpr + simpa only [Ideal.zero_eq_bot] using effectiveDivisorIdeal_ne_bot D⟩ + left_inv I := by + apply Subtype.ext + exact effectiveDivisorIdeal_idealMultiplicityDivisor + (I : Ideal R) (nonzeroIdeal_ne_bot I) + right_inv D := idealMultiplicityDivisor_effectiveDivisorIdeal D + +@[simp] +theorem nonzeroIdealEffectiveDivisorEquiv_apply + (I : (Ideal R)⁰) (v : HeightOneSpectrum R) : + nonzeroIdealEffectiveDivisorEquiv I v = + multiplicity v.asIdeal (I : Ideal R) := by + simp [nonzeroIdealEffectiveDivisorEquiv, + BGS.CorvajaZannier.idealMultiplicityDivisor_apply] + +@[simp] +theorem nonzeroIdealEffectiveDivisorEquiv_symm_coe + (D : HeightOneSpectrum R →₀ ℕ) : + ((nonzeroIdealEffectiveDivisorEquiv.symm D : (Ideal R)⁰) : Ideal R) = + effectiveDivisorIdeal D := rfl + +end DedekindDomain + +section FunctionField + +variable (K : Type*) [Field K] [Fintype K] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +local instance (priority := 10) affineDivisorPolynomialAlgebra : + Algebra K[X] L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K[X] (RatFunc K))) + +local instance affineDivisorPolynomialTower : + IsScalarTower K[X] (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + +local instance affineDivisorFiniteClosureModuleFinite : + Module.Finite K[X] (RatFuncFiniteIntegralClosure K L) := + Module.IsNoetherian.finite K[X] (RatFuncFiniteIntegralClosure K L) + +local instance affineDivisorFiniteClosureConstantAlgebra : + Algebra K (RatFuncFiniteIntegralClosure K L) := + RingHom.toAlgebra + ((algebraMap K[X] (RatFuncFiniteIntegralClosure K L)).comp + (algebraMap K K[X])) + +local instance affineDivisorFiniteClosureConstantTower : + IsScalarTower K K[X] (RatFuncFiniteIntegralClosure K L) := + IsScalarTower.of_algebraMap_eq' rfl + +local instance affineDivisorFiniteClosureIntegral : + Algebra.IsIntegral K[X] (RatFuncFiniteIntegralClosure K L) := + IsIntegralClosure.isIntegral_algebra K[X] L + +local instance affineDivisorPolynomialTorsionFreeTop : + Module.IsTorsionFree K[X] L := + Module.IsTorsionFree.trans_faithfulSMul K[X] (RatFunc K) L + +local instance affineDivisorFiniteClosureTorsionFree : + Module.IsTorsionFree K[X] (RatFuncFiniteIntegralClosure K L) := + IsIntegralClosure.isTorsionFree K[X] L + +local instance affineDivisorFiniteClosureDedekind : + IsDedekindDomain (RatFuncFiniteIntegralClosure K L) := + IsIntegralClosure.isDedekindDomain K[X] (RatFunc K) L + (RatFuncFiniteIntegralClosure K L) + +/-- The degree of an effective finite divisor is the sum of its +multiplicities weighted by the dimensions of the residue fields over the +constant field. -/ +def finiteExtensionEffectiveFiniteDivisorDegree + (D : FiniteExtensionFinitePlace K L →₀ ℕ) : ℕ := + D.sum fun v e => e * Module.finrank K v.asIdeal.ResidueField + +/-- The quotient cardinality of a finite-place prime is the cardinality of +the constant field raised to the residue-field degree. -/ +theorem finiteExtensionFinitePlace_cardQuot_eq_card_pow_degree + (v : FiniteExtensionFinitePlace K L) : + v.asIdeal.cardQuot = Fintype.card K ^ + Module.finrank K v.asIdeal.ResidueField := by + let : DecidableEq K := Classical.decEq K + let : Finite v.asIdeal.ResidueField := + finiteExtensionFinitePlaceResidueField_finite K L v + let : Module.Finite K v.asIdeal.ResidueField := + Module.Finite.of_finite + calc + v.asIdeal.cardQuot = + Nat.card (RatFuncFiniteIntegralClosure K L ⧸ v.asIdeal) := + Submodule.cardQuot_apply v.asIdeal + _ = Nat.card v.asIdeal.ResidueField := + Nat.card_congr + (RingEquiv.ofBijective + (algebraMap + (RatFuncFiniteIntegralClosure K L ⧸ v.asIdeal) + v.asIdeal.ResidueField) + v.asIdeal.bijective_algebraMap_quotient_residueField).toEquiv + _ = Nat.card K ^ Module.finrank K v.asIdeal.ResidueField := + Module.natCard_eq_pow_finrank + _ = Fintype.card K ^ Module.finrank K v.asIdeal.ResidueField := by + rw [Nat.card_eq_fintype_card] + +/-- Quotient cardinality is the constant-field cardinality raised to the +degree of the represented effective finite divisor. -/ +theorem effectiveDivisorIdeal_cardQuot_eq_card_pow_degree + (D : FiniteExtensionFinitePlace K L →₀ ℕ) : + (effectiveDivisorIdeal D).cardQuot = Fintype.card K ^ + finiteExtensionEffectiveFiniteDivisorDegree K L D := by + rw [cardQuot_effectiveDivisorIdeal_eq_prod] + unfold finiteExtensionEffectiveFiniteDivisorDegree Finsupp.prod Finsupp.sum + calc + D.support.prod (fun v => v.asIdeal.cardQuot ^ D v) = + D.support.prod (fun v => + Fintype.card K ^ + (D v * Module.finrank K v.asIdeal.ResidueField)) := by + apply Finset.prod_congr rfl + intro v _ + rw [finiteExtensionFinitePlace_cardQuot_eq_card_pow_degree] + calc + (Fintype.card K ^ Module.finrank K v.asIdeal.ResidueField) ^ D v = + Fintype.card K ^ + (Module.finrank K v.asIdeal.ResidueField * D v) := + (pow_mul (Fintype.card K) + (Module.finrank K v.asIdeal.ResidueField) (D v)).symm + _ = Fintype.card K ^ + (D v * Module.finrank K v.asIdeal.ResidueField) := by + rw [Nat.mul_comm] + _ = Fintype.card K ^ + D.support.sum (fun v => + D v * Module.finrank K v.asIdeal.ResidueField) := + Finset.prod_pow_eq_pow_sum D.support + (fun v => D v * Module.finrank K v.asIdeal.ResidueField) + (Fintype.card K) + +/-- Nonzero affine ideals in the normalization of `K[X]` are exactly +effective divisors on the finite places of the function field. -/ +def finiteExtensionAffineIdealEffectiveDivisorEquiv : + FiniteExtensionAffineIdeal K L ≃ + (FiniteExtensionFinitePlace K L →₀ ℕ) := + nonzeroIdealEffectiveDivisorEquiv + +omit [Fintype K] in +@[simp] +theorem finiteExtensionAffineIdealEffectiveDivisorEquiv_apply + (I : FiniteExtensionAffineIdeal K L) + (v : FiniteExtensionFinitePlace K L) : + finiteExtensionAffineIdealEffectiveDivisorEquiv K L I v = + multiplicity v.asIdeal + (I : Ideal (RatFuncFiniteIntegralClosure K L)) := by + simp [finiteExtensionAffineIdealEffectiveDivisorEquiv] + +omit [Fintype K] in +@[simp] +theorem finiteExtensionAffineIdealEffectiveDivisorEquiv_symm_coe + (D : FiniteExtensionFinitePlace K L →₀ ℕ) : + (((finiteExtensionAffineIdealEffectiveDivisorEquiv K L).symm D : + FiniteExtensionAffineIdeal K L) : + Ideal (RatFuncFiniteIntegralClosure K L)) = + effectiveDivisorIdeal D := by + simp [finiteExtensionAffineIdealEffectiveDivisorEquiv] + +omit [Fintype K] in +/-- The affine ideal degree of the ideal represented by an effective finite +divisor is its residue-degree-weighted divisor degree. -/ +theorem finiteExtensionAffineIdealDegree_equiv_symm [Finite K] + (D : FiniteExtensionFinitePlace K L →₀ ℕ) : + finiteExtensionAffineIdealDegree K L + ((finiteExtensionAffineIdealEffectiveDivisorEquiv K L).symm D) = + finiteExtensionEffectiveFiniteDivisorDegree K L D := by + classical + let : Fintype K := Fintype.ofFinite K + apply Nat.pow_right_injective (by + simpa [Nat.succ_le_iff] using Fintype.one_lt_card (α := K)) + calc + Fintype.card K ^ finiteExtensionAffineIdealDegree K L + ((finiteExtensionAffineIdealEffectiveDivisorEquiv K L).symm D) = + (((finiteExtensionAffineIdealEffectiveDivisorEquiv K L).symm D : + FiniteExtensionAffineIdeal K L) : + Ideal (RatFuncFiniteIntegralClosure K L)).cardQuot := + (finiteExtensionAffineIdeal_cardQuot_eq_card_pow_degree K L + ((finiteExtensionAffineIdealEffectiveDivisorEquiv K L).symm D)).symm + _ = (effectiveDivisorIdeal D).cardQuot := by + rw [finiteExtensionAffineIdealEffectiveDivisorEquiv_symm_coe] + _ = Fintype.card K ^ + finiteExtensionEffectiveFiniteDivisorDegree K L D := + effectiveDivisorIdeal_cardQuot_eq_card_pow_degree K L D + +omit [Fintype K] in +/-- The degree of a nonzero affine ideal is the residue-degree-weighted sum of +its finite-place prime multiplicities. -/ +theorem finiteExtensionAffineIdealDegree_eq_divisorDegree [Finite K] + (I : FiniteExtensionAffineIdeal K L) : + finiteExtensionAffineIdealDegree K L I = + finiteExtensionEffectiveFiniteDivisorDegree K L + (finiteExtensionAffineIdealEffectiveDivisorEquiv K L I) := by + simpa using finiteExtensionAffineIdealDegree_equiv_symm K L + (finiteExtensionAffineIdealEffectiveDivisorEquiv K L I) + +omit [Fintype K] in +/-- Expanded pointwise form of the affine ideal degree formula. -/ +theorem finiteExtensionAffineIdealDegree_eq_sum_multiplicity_mul_residueDegree [Finite K] + (I : FiniteExtensionAffineIdeal K L) : + finiteExtensionAffineIdealDegree K L I = + (finiteExtensionAffineIdealEffectiveDivisorEquiv K L I).sum + (fun v e => e * Module.finrank K v.asIdeal.ResidueField) := by + exact finiteExtensionAffineIdealDegree_eq_divisorDegree K L I + +/-- The ideal/divisor equivalence restricts to each degree. -/ +def finiteExtensionAffineIdealsOfDegreeEquivEffectiveFiniteDivisorsOfDegree + (n : ℕ) : + {I : FiniteExtensionAffineIdeal K L // + finiteExtensionAffineIdealDegree K L I = n} ≃ + {D : FiniteExtensionFinitePlace K L →₀ ℕ // + finiteExtensionEffectiveFiniteDivisorDegree K L D = n} where + toFun I := ⟨finiteExtensionAffineIdealEffectiveDivisorEquiv K L I.1, by + rw [← finiteExtensionAffineIdealDegree_eq_divisorDegree K L I.1] + exact I.2⟩ + invFun D := ⟨(finiteExtensionAffineIdealEffectiveDivisorEquiv K L).symm D.1, by + rw [finiteExtensionAffineIdealDegree_equiv_symm K L D.1] + exact D.2⟩ + left_inv I := by + apply Subtype.ext + exact (finiteExtensionAffineIdealEffectiveDivisorEquiv K L).symm_apply_apply I.1 + right_inv D := by + apply Subtype.ext + exact (finiteExtensionAffineIdealEffectiveDivisorEquiv K L).apply_symm_apply D.1 + +/-- Effective finite divisors of a fixed degree form a finite type, transported +from the already-finite type of affine ideals of that degree. -/ +noncomputable instance finiteExtensionEffectiveFiniteDivisorsOfDegree_fintype + (n : ℕ) : + Fintype {D : FiniteExtensionFinitePlace K L →₀ ℕ // + finiteExtensionEffectiveFiniteDivisorDegree K L D = n} := + Fintype.ofEquiv + {I : FiniteExtensionAffineIdeal K L // + finiteExtensionAffineIdealDegree K L I = n} + (finiteExtensionAffineIdealsOfDegreeEquivEffectiveFiniteDivisorsOfDegree + K L n) + +/-- The effective-finite-divisor coefficient of degree `n`. -/ +noncomputable def finiteExtensionEffectiveFiniteDivisorCount (n : ℕ) : ℕ := + Fintype.card {D : FiniteExtensionFinitePlace K L →₀ ℕ // + finiteExtensionEffectiveFiniteDivisorDegree K L D = n} + +/-- The affine ideal coefficient sequence is exactly the effective +finite-divisor coefficient sequence. -/ +theorem finiteExtensionAffineIdealCount_eq_effectiveFiniteDivisorCount + (n : ℕ) : + finiteExtensionAffineIdealCount K L n = + finiteExtensionEffectiveFiniteDivisorCount K L n := by + exact Fintype.card_congr + (finiteExtensionAffineIdealsOfDegreeEquivEffectiveFiniteDivisorsOfDegree + K L n) + +end FunctionField + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionCanonicalDifferentCanonicalityCriterion.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionCanonicalDifferentCanonicalityCriterion.lean new file mode 100644 index 0000000000..71b060fa1c --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionCanonicalDifferentCanonicalityCriterion.lean @@ -0,0 +1,262 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionCanonicalDifferentGenusBound + +/-! +# Canonicality criterion for the finite-extension different divisor + +The Corvaja--Zannier development constructs the divisor of the separating +differential `dX` place by place: its finite coefficients are trace-different +multiplicities, and its coefficients above infinity are the different +multiplicity minus twice the ramification index. The Riemann--Roch library, +on the other hand, defines canonical divisors as maximal vanishing divisors +of nonzero adelic Weil functionals. + +This module gives the exact theorem-level reduction between those two +presentations. It does not assume or package canonicality. The target is +equivalent to: + +* the Riemann--Hurwitz identity for the total trace different; and +* the dimension statement + + `genus K L ≤ finrank K (finiteExtensionRiemannSpace K L Ddiff)`. + +Once the degree identity is known, Riemann--Roch proves that this finrank is +already between `g - 1` and `g`. Thus the exact remaining +trace-residue/Kähler-to-Weil theorem is the displayed lower bound: construct +the Weil functional attached to `dX`, identify its local annihilator with the +trace-different/Kähler module, and thereby close the last one-dimensional +gap. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +noncomputable section + +open BGS.CorvajaZannier +open scoped Polynomial + +variable (K : Type*) [Field K] [Fintype K] [DecidableEq K] + [DecidableEq (RatFunc K)] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +local instance canonicalCriterionConstantAlgebra : Algebra K L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K (RatFunc K))) + +local instance canonicalCriterionConstantTower : + IsScalarTower K (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + +local instance (priority := 10) canonicalCriterionPolynomialAlgebra : + Algebra K[X] L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K[X] (RatFunc K))) + +local instance canonicalCriterionPolynomialTower : + IsScalarTower K[X] (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + +local instance canonicalCriterionConstantPolynomialTower : + IsScalarTower K K[X] L := + IsScalarTower.of_algebraMap_eq' rfl + +omit [Fintype K] [DecidableEq K] [DecidableEq (RatFunc K)] in +/-- A degree-zero chart divisor has a Riemann--Roch space of dimension at +most one. -/ +theorem chart_ell_le_one_of_degree_eq_zero + [FunctionField.IsFullConstantField K L] + (D : FunctionField.Chart.DivisorA K L) + (hdegree : FunctionField.Chart.deg K L D = 0) : + FunctionField.Chart.ell K L D ≤ 1 := by + by_cases hell : FunctionField.Chart.ell K L D = 0 + · omega + · have hpositive : 0 < FunctionField.Chart.ell K L D := + Nat.pos_of_ne_zero hell + obtain ⟨x, heffective⟩ := + FunctionField.Chart.exists_effective_add_principal_of_ell_pos + K L D hpositive + let P := FunctionField.Chart.principalDivisorA K L (Additive.ofMul x) + have hdegreeZero : FunctionField.Chart.deg K L (D + P) = 0 := by + rw [FunctionField.Chart.deg_add, + FunctionField.Chart.deg_principalDivisorA_eq_zero, hdegree] + omega + have hzero : D + P = 0 := + FunctionField.Chart.eq_zero_of_effective_deg_zero K L + heffective hdegreeZero + have hellAdd := FunctionField.Chart.ell_add_principal K L D x + change FunctionField.Chart.ell K L (D + P) = + FunctionField.Chart.ell K L D at hellAdd + rw [hzero, FunctionField.Chart.ell_zero] at hellAdd + omega + +omit [Fintype K] [DecidableEq K] [DecidableEq (RatFunc K)] in +/-- At canonical degree, Riemann--Roch leaves at most a one-dimensional +defect from canonicality. -/ +theorem chart_ell_le_genus_of_degree_eq_two_genus_sub_two + [FunctionField.IsFullConstantField K L] + (D : FunctionField.Chart.DivisorA K L) + (hdegree : FunctionField.Chart.deg K L D = + 2 * (FunctionField.Chart.genus K L : ℤ) - 2) : + FunctionField.Chart.ell K L D ≤ FunctionField.Chart.genus K L := by + obtain ⟨W, hW⟩ := FunctionField.Chart.exists_isCanonical K L + have hdegreeDiff : FunctionField.Chart.deg K L (W - D) = 0 := by + rw [FunctionField.Chart.deg_sub, + FunctionField.Chart.deg_canonical K L hW, hdegree] + omega + have hellDiff : FunctionField.Chart.ell K L (W - D) ≤ 1 := + chart_ell_le_one_of_degree_eq_zero K L (W - D) hdegreeDiff + have hRR := FunctionField.Chart.riemann_roch K L hW D + rw [hdegree] at hRR + omega + +/-- Canonicality of the explicit different divisor is equivalent to its +canonical degree and canonical Riemann--Roch dimension. Both conditions are +stated entirely in the exhaustive BGS divisor model. -/ +theorem finiteExtensionCanonicalDifferent_isCanonical_iff_degree_finrank + [FunctionField.IsFullConstantField K L] : + FunctionField.Chart.IsCanonical K L + (finiteExtensionDivisorEquivChart K L + (finiteExtensionCanonicalDifferentDivisor K L + (finiteExtensionFiniteDifferentIdeal_ne_bot K L))) ↔ + finiteExtensionDivisorDegree K L + (finiteExtensionCanonicalDifferentDivisor K L + (finiteExtensionFiniteDifferentIdeal_ne_bot K L)) = + 2 * (FunctionField.Chart.genus K L : ℤ) - 2 ∧ + Module.finrank K + (finiteExtensionRiemannSpace K L + (finiteExtensionCanonicalDifferentDivisor K L + (finiteExtensionFiniteDifferentIdeal_ne_bot K L))) = + FunctionField.Chart.genus K L := by + let D := finiteExtensionCanonicalDifferentDivisor K L + (finiteExtensionFiniteDifferentIdeal_ne_bot K L) + rw [FunctionField.chart_isCanonical_iff_degree_ell] + rw [← finiteExtensionDivisorDegree_eq_chart K L D] + change finiteExtensionDivisorDegree K L D = _ ∧ + Module.finrank K (FunctionField.Chart.RRspace K L + (finiteExtensionDivisorEquivChart K L D)) = _ ↔ _ + rw [← finiteExtensionRiemannSpace_eq_chart K L D] + +/-- Once Riemann--Hurwitz supplies the degree identity, canonicality is +equivalent to closing the single remaining Riemann--Roch dimension gap. -/ +theorem finiteExtensionCanonicalDifferent_isCanonical_iff_genus_le_finrank_of_degree_eq + [FunctionField.IsFullConstantField K L] + (hdegree : finiteExtensionDivisorDegree K L + (finiteExtensionCanonicalDifferentDivisor K L + (finiteExtensionFiniteDifferentIdeal_ne_bot K L)) = + 2 * (FunctionField.Chart.genus K L : ℤ) - 2) : + FunctionField.Chart.IsCanonical K L + (finiteExtensionDivisorEquivChart K L + (finiteExtensionCanonicalDifferentDivisor K L + (finiteExtensionFiniteDifferentIdeal_ne_bot K L))) ↔ + FunctionField.Chart.genus K L ≤ + Module.finrank K + (finiteExtensionRiemannSpace K L + (finiteExtensionCanonicalDifferentDivisor K L + (finiteExtensionFiniteDifferentIdeal_ne_bot K L))) := by + let D := finiteExtensionCanonicalDifferentDivisor K L + (finiteExtensionFiniteDifferentIdeal_ne_bot K L) + have hdegreeChart : FunctionField.Chart.deg K L + (finiteExtensionDivisorEquivChart K L D) = + 2 * (FunctionField.Chart.genus K L : ℤ) - 2 := by + rw [← finiteExtensionDivisorDegree_eq_chart K L D] + exact hdegree + have hupperChart : FunctionField.Chart.ell K L + (finiteExtensionDivisorEquivChart K L D) ≤ + FunctionField.Chart.genus K L := + chart_ell_le_genus_of_degree_eq_two_genus_sub_two K L + (finiteExtensionDivisorEquivChart K L D) hdegreeChart + have hupper : Module.finrank K (finiteExtensionRiemannSpace K L D) ≤ + FunctionField.Chart.genus K L := by + rw [finiteExtensionRiemannSpace_eq_chart] + exact hupperChart + rw [finiteExtensionCanonicalDifferent_isCanonical_iff_degree_finrank K L] + constructor + · rintro ⟨_hdegree, hfinrank⟩ + simpa only [D] using hfinrank.ge + · intro hlower + refine ⟨hdegree, ?_⟩ + apply Nat.le_antisymm + · simpa only [D] using hupper + · exact hlower + +/-- The degree identity leaves at most one unit of uncertainty in the +Riemann--Roch dimension of the explicit different divisor. -/ +theorem finiteExtensionCanonicalDifferent_finrank_bounds_of_degree_eq + [FunctionField.IsFullConstantField K L] + (hdegree : finiteExtensionDivisorDegree K L + (finiteExtensionCanonicalDifferentDivisor K L + (finiteExtensionFiniteDifferentIdeal_ne_bot K L)) = + 2 * (FunctionField.Chart.genus K L : ℤ) - 2) : + (FunctionField.Chart.genus K L : ℤ) - 1 ≤ + (Module.finrank K + (finiteExtensionRiemannSpace K L + (finiteExtensionCanonicalDifferentDivisor K L + (finiteExtensionFiniteDifferentIdeal_ne_bot K L))) : ℤ) ∧ + Module.finrank K + (finiteExtensionRiemannSpace K L + (finiteExtensionCanonicalDifferentDivisor K L + (finiteExtensionFiniteDifferentIdeal_ne_bot K L))) ≤ + FunctionField.Chart.genus K L := by + let D := finiteExtensionCanonicalDifferentDivisor K L + (finiteExtensionFiniteDifferentIdeal_ne_bot K L) + have hdegreeChart : FunctionField.Chart.deg K L + (finiteExtensionDivisorEquivChart K L D) = + 2 * (FunctionField.Chart.genus K L : ℤ) - 2 := by + rw [← finiteExtensionDivisorDegree_eq_chart K L D] + exact hdegree + have hlowerChart := FunctionField.Chart.riemann_ineq K L + (finiteExtensionDivisorEquivChart K L D) + rw [hdegreeChart] at hlowerChart + have hlowerInt : (FunctionField.Chart.genus K L : ℤ) - 1 ≤ + (FunctionField.Chart.ell K L + (finiteExtensionDivisorEquivChart K L D) : ℤ) := by + omega + have hupperChart := + chart_ell_le_genus_of_degree_eq_two_genus_sub_two K L + (finiteExtensionDivisorEquivChart K L D) hdegreeChart + change (FunctionField.Chart.genus K L : ℤ) - 1 ≤ + (Module.finrank K (finiteExtensionRiemannSpace K L D) : ℤ) ∧ + Module.finrank K (finiteExtensionRiemannSpace K L D) ≤ + FunctionField.Chart.genus K L + have hfinrank : Module.finrank K (finiteExtensionRiemannSpace K L D) = + FunctionField.Chart.ell K L + (finiteExtensionDivisorEquivChart K L D) := by + rw [finiteExtensionRiemannSpace_eq_chart] + rfl + constructor + · rw [hfinrank] + exact hlowerInt + · rw [hfinrank] + exact hupperChart + +omit [Fintype K] in +/-- The degree half of canonicality is exactly the Riemann--Hurwitz identity +for the finite and infinite trace different. -/ +theorem finiteExtensionCanonicalDifferent_degree_eq_two_genus_sub_two_iff + [FunctionField.IsFullConstantField K L] : + finiteExtensionDivisorDegree K L + (finiteExtensionCanonicalDifferentDivisor K L + (finiteExtensionFiniteDifferentIdeal_ne_bot K L)) = + 2 * (FunctionField.Chart.genus K L : ℤ) - 2 ↔ + (finiteExtensionFiniteDifferentDegree K L + (finiteExtensionFiniteDifferentIdeal_ne_bot K L) : ℤ) + + (infinityDifferentDegree K L : ℤ) = + 2 * (Module.finrank (RatFunc K) L : ℤ) + + 2 * (FunctionField.Chart.genus K L : ℤ) - 2 := by + rw [finiteExtensionCanonicalDifferentDivisor_degree] + constructor <;> intro h <;> omega + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionCanonicalDifferentCotrace.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionCanonicalDifferentCotrace.lean new file mode 100644 index 0000000000..a7adfeff1f --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionCanonicalDifferentCotrace.lean @@ -0,0 +1,1367 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionCanonicalDifferentCanonicalityCriterion +public import LeanPool.MarkoffModP.BGS.HasseWeil.DedekindDifferentLocalTrace +public import LeanPool.MarkoffModP.BGS.HasseWeil.RatFuncCanonicalInfinityDivisor +public import LeanPool.MarkoffModP.BGS.HasseWeil.LinearFunctionalGluing + +/-! +# Cotrace construction for the finite-extension canonical different + +This file constructs a surjective cotrace on fiber-constant adeles and uses +the trace codifferent bounds to build a nonzero Weil differential whose +maximal vanishing divisor contains the explicit finite-extension different. +Nothing in this file is an assumption. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +open BGS.CorvajaZannier +open IsDedekindDomain Multiplicative WithZero +open scoped Polynomial nonZeroDivisors + +noncomputable section + +variable (K : Type*) [Field K] [Fintype K] [DecidableEq K] + [DecidableEq (RatFunc K)] + +/-- The exhaustive rational-function places used as the base of the finite +extension place map. -/ +abbrev RatFuncExhaustivePlace := + HeightOneSpectrum K[X] ⊕ HeightOneSpectrum (RatFuncInfinityIntegers K) + +/-- The polynomial ring is the integral closure of itself in its fraction +field, so its height-one primes are exactly the finite chart places of +`K(X)`. -/ +def ratFuncFiniteBaseRingEquivChart : + K[X] ≃+* FunctionField.ringOfIntegers K (RatFunc K) := + (IsIntegralClosure.equiv K[X] K[X] (RatFunc K) + (FunctionField.ringOfIntegers K (RatFunc K))).toRingEquiv + +omit [Fintype K] [DecidableEq K] [DecidableEq (RatFunc K)] in +@[simp] +theorem ratFuncFiniteBaseRingEquivChart_algebraMap + (r : K[X]) : + algebraMap (FunctionField.ringOfIntegers K (RatFunc K)) + (RatFunc K) (ratFuncFiniteBaseRingEquivChart K r) = + algebraMap K[X] (RatFunc K) r := + IsIntegralClosure.algebraMap_equiv K[X] K[X] + (RatFunc K) (FunctionField.ringOfIntegers K (RatFunc K)) r + +/-- The BGS infinity valuation ring and the chart infinity integral closure +inside `K(X)` are canonically equivalent. -/ +def ratFuncInfinityBaseRingEquivChart : + RatFuncInfinityIntegers K ≃+* + FunctionField.Chart.infiniteIntegers K (RatFunc K) := + (finiteExtensionInfinityBaseRingEquiv K).trans + (IsIntegralClosure.equiv + (FunctionField.Chart.inftyValuationSubring K) + (FunctionField.Chart.inftyValuationSubring K) (RatFunc K) + (FunctionField.Chart.infiniteIntegers K (RatFunc K))).toRingEquiv + +omit [Fintype K] [DecidableEq K] in +@[simp] +theorem ratFuncInfinityBaseRingEquivChart_algebraMap + (r : RatFuncInfinityIntegers K) : + algebraMap (FunctionField.Chart.infiniteIntegers K (RatFunc K)) + (RatFunc K) (ratFuncInfinityBaseRingEquivChart K r) = + algebraMap (RatFuncInfinityIntegers K) (RatFunc K) r := by + calc + _ = algebraMap (FunctionField.Chart.inftyValuationSubring K) + (RatFunc K) (finiteExtensionInfinityBaseRingEquiv K r) := + IsIntegralClosure.algebraMap_equiv + (FunctionField.Chart.inftyValuationSubring K) + (FunctionField.Chart.inftyValuationSubring K) (RatFunc K) + (FunctionField.Chart.infiniteIntegers K (RatFunc K)) + (finiteExtensionInfinityBaseRingEquiv K r) + _ = (r : RatFunc K) := rfl + _ = algebraMap (RatFuncInfinityIntegers K) (RatFunc K) r := rfl + +/-- Reindex the exhaustive BGS rational-function places as chart places. -/ +def ratFuncExhaustivePlaceEquivChart : + RatFuncExhaustivePlace K ≃ FunctionField.Chart.PlaceA K (RatFunc K) := + Equiv.sumCongr + (HeightOneSpectrum.equivOfRingEquiv + (ratFuncFiniteBaseRingEquivChart K)) + (HeightOneSpectrum.equivOfRingEquiv + (ratFuncInfinityBaseRingEquivChart K)) + +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +local instance cotraceConstantAlgebra : Algebra K L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K (RatFunc K))) + +local instance cotraceConstantTower : IsScalarTower K (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + +local instance (priority := 10) cotracePolynomialAlgebra : Algebra K[X] L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K[X] (RatFunc K))) + +local instance cotracePolynomialTower : IsScalarTower K[X] (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + +local instance cotraceConstantPolynomialTower : IsScalarTower K K[X] L := + IsScalarTower.of_algebraMap_eq' rfl + +local instance cotraceFiniteClosureModuleFinite : + Module.Finite K[X] (RatFuncFiniteIntegralClosure K L) := + IsIntegralClosure.finite K[X] (RatFunc K) L + (RatFuncFiniteIntegralClosure K L) + +local instance cotraceFiniteClosureIsIntegral : + Algebra.IsIntegral K[X] (RatFuncFiniteIntegralClosure K L) := + IsIntegralClosure.isIntegral_algebra K[X] L + +local instance cotraceFiniteBaseTorsionFreeTop : + Module.IsTorsionFree K[X] L := + Module.IsTorsionFree.trans_faithfulSMul K[X] (RatFunc K) L + +local instance cotraceFiniteClosureTorsionFree : + Module.IsTorsionFree K[X] (RatFuncFiniteIntegralClosure K L) := + IsIntegralClosure.isTorsionFree K[X] L + +local instance cotraceInfinityClosureModuleFinite : + Module.Finite (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.finite (RatFuncInfinityIntegers K) (RatFunc K) L + (RatFuncInfinityIntegralClosure K L) + +local instance cotraceInfinityClosureIsIntegral : + Algebra.IsIntegral (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.isIntegral_algebra (RatFuncInfinityIntegers K) L + +local instance cotraceInfinityBaseTorsionFreeTop : + Module.IsTorsionFree (RatFuncInfinityIntegers K) L := + Module.IsTorsionFree.trans_faithfulSMul + (RatFuncInfinityIntegers K) (RatFunc K) L + +local instance cotraceInfinityClosureTorsionFree : + Module.IsTorsionFree (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.isTorsionFree (RatFuncInfinityIntegers K) L + +local instance cotraceInfinityClosureIsDedekind : + IsDedekindDomain (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.isDedekindDomain + (RatFuncInfinityIntegers K) (RatFunc K) L + (RatFuncInfinityIntegralClosure K L) + +local instance cotraceInfinityClosureIsFractionRing : + IsFractionRing (RatFuncInfinityIntegralClosure K L) L := + IsIntegralClosure.isFractionRing_of_finite_extension + (RatFuncInfinityIntegers K) (RatFunc K) L + (RatFuncInfinityIntegralClosure K L) + +/-- Transport the condition of belonging to a height-one valuation ring +across an identity-on-fraction-field ring equivalence. -/ +theorem heightOneValuation_le_one_of_ringEquiv + {R S F : Type*} [CommRing R] [CommRing S] [Field F] + [Algebra R F] [Algebra S F] [IsFractionRing R F] + [IsFractionRing S F] [IsDedekindDomain R] [IsDedekindDomain S] + (e : R ≃+* S) + (halg : ∀ r : R, algebraMap S F (e r) = algebraMap R F r) + (q : HeightOneSpectrum R) (q' : HeightOneSpectrum S) + (hideal : q'.asIdeal = q.asIdeal.comap e.symm) + {x : F} (hx : q.valuation F x ≤ 1) : q'.valuation F x ≤ 1 := by + obtain ⟨n, d, hnd⟩ := q.exists_primeCompl_mul_eq_of_integer x hx + have hd' : e d.1 ∉ q'.asIdeal := by + intro hmem + have hd : (d.1 : R) ∉ q.asIdeal := d.2 + apply hd + rw [hideal] at hmem + change e.symm (e d.1) ∈ q.asIdeal at hmem + simpa using hmem + have hnd' : + x * algebraMap S F (e d.1) = algebraMap S F (e n) := by + simpa only [halg] using hnd + have hval := congrArg (q'.valuation F) hnd' + rw [map_mul, q'.valuation_eq_one_iff_notMem (K := F).2 hd'] at hval + simp only [mul_one] at hval + rw [hval] + exact q'.valuation_le_one (K := F) (e n) + +/-- Identity-on-fraction-field equivalences identify the valuation rings of +corresponding height-one primes. -/ +theorem heightOneValuation_isEquiv_of_ringEquiv + {R S F : Type*} [CommRing R] [CommRing S] [Field F] + [Algebra R F] [Algebra S F] [IsFractionRing R F] + [IsFractionRing S F] [IsDedekindDomain R] [IsDedekindDomain S] + (e : R ≃+* S) + (halg : ∀ r : R, algebraMap S F (e r) = algebraMap R F r) + (q : HeightOneSpectrum R) (q' : HeightOneSpectrum S) + (hideal : q'.asIdeal = q.asIdeal.comap e.symm) : + (q.valuation F).IsEquiv (q'.valuation F) := by + apply Valuation.isEquiv_of_val_le_one + intro x + constructor + · exact heightOneValuation_le_one_of_ringEquiv + e halg q q' hideal + · intro hx + have halg' : ∀ s : S, + algebraMap R F (e.symm s) = algebraMap S F s := by + intro s + rw [← halg (e.symm s), e.apply_symm_apply] + have hideal' : q.asIdeal = q'.asIdeal.comap e := by + ext r + rw [Ideal.mem_comap, hideal, Ideal.mem_comap] + simp + exact heightOneValuation_le_one_of_ringEquiv + e.symm halg' q' q hideal' hx + +/-- Equivalent surjective valuations with value group `ℤᵐ⁰` have the same +normalization. -/ +theorem normalizedIntValuation_eq_of_isEquiv_of_surjective + {F : Type*} [Field F] (v w : Valuation F ℤᵐ⁰) + (hvw : v.IsEquiv w) (hv : Function.Surjective v) + (hw : Function.Surjective w) : v = w := by + obtain ⟨π, hvπ⟩ := hv (WithZero.exp (-1 : ℤ)) + have hπ : π ≠ 0 := by + apply (Valuation.ne_zero_iff v).mp + rw [hvπ] + exact WithZero.exp_ne_zero + have hwπ0 : w π ≠ 0 := + (hvw.eq_zero.ne).mp ((Valuation.ne_zero_iff v).2 hπ) + let m : ℤ := -WithZero.log (w π) + have hmpos : 0 < m := by + have hvπlt : v π < 1 := by + rw [hvπ, ← WithZero.exp_zero, WithZero.exp_lt_exp] + omega + have hwπlt : w π < 1 := hvw.lt_one_iff_lt_one.mp hvπlt + have hlog : WithZero.log (w π) < 0 := by + rw [← WithZero.log_one] + exact (WithZero.log_lt_log hwπ0 one_ne_zero).2 hwπlt + dsimp only [m] + omega + have hformula (x : F) (hx : x ≠ 0) : + w x = WithZero.exp (m * WithZero.log (v x)) := by + have hvx0 : v x ≠ 0 := (Valuation.ne_zero_iff v).2 hx + let n : ℤ := WithZero.log (v x) + have hvpow : v (π ^ (-n)) = v x := by + rw [map_zpow₀, hvπ, ← WithZero.exp_zsmul] + rw [← WithZero.exp_log hvx0] + congr 1 + dsimp only [n] + simp + have hwpow : w (π ^ (-n)) = w x := hvw.eq_iff.mp hvpow + calc + w x = w (π ^ (-n)) := hwpow.symm + _ = (w π) ^ (-n) := by rw [map_zpow₀] + _ = WithZero.exp ((-n) • WithZero.log (w π)) := by + rw [WithZero.exp_zsmul, WithZero.exp_log hwπ0] + _ = WithZero.exp (m * WithZero.log (v x)) := by + congr 1 + dsimp only [m, n] + ring + obtain ⟨y, hwy⟩ := hw (WithZero.exp (1 : ℤ)) + have hy : y ≠ 0 := by + apply (Valuation.ne_zero_iff w).mp + rw [hwy] + exact WithZero.exp_ne_zero + have hm : m * WithZero.log (v y) = 1 := by + apply WithZero.exp_injective + rw [← hformula y hy, hwy] + have hm1 : m = 1 := by + rcases Int.mul_eq_one_iff_eq_one_or_neg_one.mp hm with h | h + · exact h.1 + · omega + ext x + by_cases hx : x = 0 + · subst x + simp + · rw [hformula x hx, hm1, one_mul, + WithZero.exp_log ((Valuation.ne_zero_iff v).2 hx)] + +/-- Corresponding height-one primes have exactly the same normalized +`ℤᵐ⁰`-valued valuation under an identity-on-fraction-field equivalence. -/ +theorem heightOneValuation_eq_of_ringEquiv + {R S F : Type*} [CommRing R] [CommRing S] [Field F] + [Algebra R F] [Algebra S F] [IsFractionRing R F] + [IsFractionRing S F] [IsDedekindDomain R] [IsDedekindDomain S] + (e : R ≃+* S) + (halg : ∀ r : R, algebraMap S F (e r) = algebraMap R F r) + (q : HeightOneSpectrum R) (q' : HeightOneSpectrum S) + (hideal : q'.asIdeal = q.asIdeal.comap e.symm) : + q.valuation F = q'.valuation F := by + apply normalizedIntValuation_eq_of_isEquiv_of_surjective + · exact heightOneValuation_isEquiv_of_ringEquiv e halg q q' hideal + · exact HeightOneSpectrum.valuation_surjective (K := F) q + · exact HeightOneSpectrum.valuation_surjective (K := F) q' + +/-- Integrality at a height-one prime pulls up along a finite extension to +every prime above it. -/ +theorem heightOneValuation_algebraMap_le_one_of_under + {R S F E : Type*} [CommRing R] [CommRing S] [Field F] [Field E] + [Algebra R S] [Algebra R F] [Algebra R E] [Algebra S E] + [Algebra F E] [IsScalarTower R S E] [IsScalarTower R F E] + [Algebra.IsIntegral R S] + [IsFractionRing R F] [IsFractionRing S E] + [IsDedekindDomain R] [IsDedekindDomain S] + (q : HeightOneSpectrum S) (p : HeightOneSpectrum R) + (hunder : q.under R = p) {x : F} + (hx : p.valuation F x ≤ 1) : + q.valuation E (algebraMap F E x) ≤ 1 := by + obtain ⟨n, d, hnd⟩ := p.exists_primeCompl_mul_eq_of_integer x hx + have hunderIdeal : q.asIdeal.under R = p.asIdeal := + congrArg HeightOneSpectrum.asIdeal hunder + have hdq : algebraMap R S d.1 ∉ q.asIdeal := by + intro hdq + have hdUnder : (d.1 : R) ∈ q.asIdeal.under R := hdq + have hdP : (d.1 : R) ∈ p.asIdeal := by + simpa only [hunderIdeal] using hdUnder + exact d.2 hdP + have hndE := congrArg (algebraMap F E) hnd + have hndE' : algebraMap F E x * algebraMap S E (algebraMap R S d.1) = + algebraMap S E (algebraMap R S n) := by + simpa only [map_mul, ← IsScalarTower.algebraMap_apply R F E, + ← IsScalarTower.algebraMap_apply R S E] using hndE + have hval := congrArg (q.valuation E) hndE' + have hdval : q.valuation E (algebraMap S E (algebraMap R S d.1)) = 1 := + q.valuation_eq_one_iff_notMem (K := E).2 hdq + rw [map_mul, hdval, mul_one] at hval + rw [hval] + exact q.valuation_le_one (K := E) (algebraMap R S n) + +/-- Integrality at a height-one place is the nonnegativity of its principal +fractional-ideal count. -/ +theorem zero_le_count_spanSingleton_of_valuation_le_one + {R F : Type*} [CommRing R] [Field F] [Algebra R F] + [IsFractionRing R F] [IsDedekindDomain R] + (q : HeightOneSpectrum R) {x : F} (hx : x ≠ 0) + (hval : q.valuation F x ≤ 1) : + 0 ≤ FractionalIdeal.count F q + (FractionalIdeal.spanSingleton R⁰ x) := by + have hvaluation := FractionalIdeal.valuation_eq_exp_neg_count + q (Units.mk0 x hx) + have hval' : q.valuation F (↑(Units.mk0 x hx) : F) ≤ 1 := by + simpa using hval + rw [hvaluation, ← WithZero.exp_zero] at hval' + exact neg_nonpos.mp (WithZero.exp_le_exp.mp hval') + +/-- Forget an extension place down to its rational-function place. -/ +def finiteExtensionUnderPlace : + FiniteExtensionPlace K L → RatFuncExhaustivePlace K + | .inl q => .inl (q.under K[X]) + | .inr _ => .inr (ratFuncInfinityPlace K) + +omit [Fintype K] [DecidableEq K] in +/-- Every rational-function place has an extension place above it. -/ +theorem finiteExtensionUnderPlace_surjective : + Function.Surjective (finiteExtensionUnderPlace K L) := by + intro p + rcases p with p | p + · obtain ⟨P, hP, hunder⟩ := + p.asIdeal.exists_ideal_over_prime_of_isIntegral_of_isDomain + (S := RatFuncFiniteIntegralClosure K L) (by simp) + have hPbot : P ≠ ⊥ := by + intro hbot + have hpbot : p.asIdeal = ⊥ := by + calc + p.asIdeal = Ideal.comap + (algebraMap K[X] (RatFuncFiniteIntegralClosure K L)) P := + hunder.symm + _ = Ideal.comap + (algebraMap K[X] (RatFuncFiniteIntegralClosure K L)) ⊥ := by + rw [hbot] + _ = ⊥ := Ideal.comap_bot_of_injective _ + (FaithfulSMul.algebraMap_injective K[X] + (RatFuncFiniteIntegralClosure K L)) + exact p.ne_bot hpbot + let q : HeightOneSpectrum (RatFuncFiniteIntegralClosure K L) := + ⟨P, hP, hPbot⟩ + refine ⟨.inl q, ?_⟩ + apply congrArg Sum.inl + apply HeightOneSpectrum.ext + exact hunder + · have hpEq : p = ratFuncInfinityPlace K := by + apply HeightOneSpectrum.ext + exact (IsLocalRing.eq_maximalIdeal + (p.isPrime.isMaximal p.ne_bot)).trans + (IsLocalRing.eq_maximalIdeal + ((ratFuncInfinityPlace K).isPrime.isMaximal + (ratFuncInfinityPlace K).ne_bot)).symm + obtain ⟨P, hPmax, hPover⟩ := + (ratFuncInfinityPlace K).asIdeal.exists_maximal_ideal_liesOver_of_isIntegral + (S := RatFuncInfinityIntegralClosure K L) + let P' : FiniteExtensionInfinityPlace K L := + ⟨P, hPmax.isPrime, hPover⟩ + refine ⟨.inr P', ?_⟩ + simp only [finiteExtensionUnderPlace] + exact congrArg Sum.inr hpEq.symm + +omit [Fintype K] [DecidableEq K] in +/-- Every fiber of the exhaustive place map is finite. -/ +theorem finiteExtensionUnderPlace_finite_preimage_singleton + (p : RatFuncExhaustivePlace K) : + Set.Finite ((finiteExtensionUnderPlace K L) ⁻¹' {p}) := by + rcases p with p | p + · have hfiber : Set.Finite {q : FiniteExtensionFinitePlace K L | + q.under K[X] = p} := by + rw [← Set.finite_coe_iff] + let : Finite + (p.asIdeal.primesOver (RatFuncFiniteIntegralClosure K L)) := + Set.finite_coe_iff.mpr + (IsDedekindDomain.primesOver_finite p.asIdeal + (RatFuncFiniteIntegralClosure K L)) + exact Finite.of_equiv + (p.asIdeal.primesOver (RatFuncFiniteIntegralClosure K L)) + (finitePlaceFiberEquivPrimesOver K L p).symm + refine (hfiber.image (fun q => + (Sum.inl q : FiniteExtensionPlace K L))).subset ?_ + intro q hq + rcases q with q | q + · refine ⟨q, ?_, rfl⟩ + change q.under K[X] = p + simpa only [Set.mem_preimage, Set.mem_singleton_iff, + finiteExtensionUnderPlace, Sum.inl.injEq] using hq + · simp only [Set.mem_preimage, Set.mem_singleton_iff, + finiteExtensionUnderPlace, reduceCtorEq] at hq + · let : Finite (FiniteExtensionInfinityPlace K L) := + Set.finite_coe_iff.mpr + (IsDedekindDomain.primesOver_finite + (ratFuncInfinityPlace K).asIdeal + (RatFuncInfinityIntegralClosure K L)) + refine (Set.finite_range (fun q : FiniteExtensionInfinityPlace K L => + (Sum.inr q : FiniteExtensionPlace K L))).subset ?_ + intro q hq + rcases q with q | q + · simp only [Set.mem_preimage, Set.mem_singleton_iff, + finiteExtensionUnderPlace, reduceCtorEq] at hq + · exact Set.mem_range_self q + +omit [Fintype K] [DecidableEq K] in +/-- Pullback along the exhaustive place map preserves cofinite eventual +properties. -/ +theorem finiteExtensionUnderPlace_tendstoCofinite : + Filter.TendstoCofinite (finiteExtensionUnderPlace K L) := + (Filter.tendstoCofinite_iff_finite_preimage_singleton + (finiteExtensionUnderPlace K L)).mpr + (finiteExtensionUnderPlace_finite_preimage_singleton K L) + +/-- The place below a top chart place, expressed in the base chart. -/ +def finiteExtensionUnderPlaceChart + (q : FunctionField.Chart.PlaceA K L) : + FunctionField.Chart.PlaceA K (RatFunc K) := + ratFuncExhaustivePlaceEquivChart K + (finiteExtensionUnderPlace K L + ((finiteExtensionPlaceEquivChart K L).symm q)) + +omit [Fintype K] [DecidableEq K] in +/-- Every rational-function chart place has an upstairs chart place. -/ +theorem finiteExtensionUnderPlaceChart_surjective : + Function.Surjective (finiteExtensionUnderPlaceChart K L) := by + intro p + let p' := (ratFuncExhaustivePlaceEquivChart K).symm p + obtain ⟨q, hq⟩ := finiteExtensionUnderPlace_surjective K L p' + refine ⟨finiteExtensionPlaceEquivChart K L q, ?_⟩ + simp only [finiteExtensionUnderPlaceChart, Equiv.symm_apply_apply, hq, p'] + exact (ratFuncExhaustivePlaceEquivChart K).apply_symm_apply p + +omit [Fintype K] [DecidableEq K] in +/-- Pullback along the chart place map preserves cofinite eventual +properties. -/ +theorem finiteExtensionUnderPlaceChart_tendstoCofinite : + Filter.TendstoCofinite (finiteExtensionUnderPlaceChart K L) := by + let : Filter.TendstoCofinite (finiteExtensionUnderPlace K L) := + finiteExtensionUnderPlace_tendstoCofinite K L + change Filter.TendstoCofinite + ((ratFuncExhaustivePlaceEquivChart K) ∘ + (finiteExtensionUnderPlace K L) ∘ + (finiteExtensionPlaceEquivChart K L).symm) + infer_instance + +omit [Fintype K] [DecidableEq K] in +/-- A base element integral at a chart place remains integral at every +upstairs chart place above it. -/ +theorem finiteExtension_placeValuation_algebraMap_le_one + (q : FunctionField.Chart.PlaceA K L) {x : RatFunc K} + (hx : FunctionField.Chart.placeValuation K (RatFunc K) + (finiteExtensionUnderPlaceChart K L q) x ≤ 1) : + FunctionField.Chart.placeValuation K L q + (algebraMap (RatFunc K) L x) ≤ 1 := by + let P := (finiteExtensionPlaceEquivChart K L).symm q + have hP : finiteExtensionPlaceEquivChart K L P = q := + (finiteExtensionPlaceEquivChart K L).apply_symm_apply q + rw [← hP] at hx ⊢ + rcases P with q | P + · let p₀ := q.under K[X] + let pChart := HeightOneSpectrum.equivOfRingEquiv + (ratFuncFiniteBaseRingEquivChart K) p₀ + have hbaseEq : p₀.valuation (RatFunc K) = + pChart.valuation (RatFunc K) := + heightOneValuation_eq_of_ringEquiv + (ratFuncFiniteBaseRingEquivChart K) + (ratFuncFiniteBaseRingEquivChart_algebraMap K) + p₀ pChart rfl + have hunderChart : finiteExtensionUnderPlaceChart K L + (finiteExtensionPlaceEquivChart K L (.inl q)) = + Sum.inl pChart := by + simp only [finiteExtensionUnderPlaceChart, Equiv.symm_apply_apply, + finiteExtensionUnderPlace] + rfl + have hx₀ : p₀.valuation (RatFunc K) x ≤ 1 := by + rw [hbaseEq] + rw [hunderChart] at hx + exact hx + exact heightOneValuation_algebraMap_le_one_of_under + q p₀ rfl hx₀ + · let p₀ := ratFuncInfinityPlace K + let pChart := HeightOneSpectrum.equivOfRingEquiv + (ratFuncInfinityBaseRingEquivChart K) p₀ + let q₀ := primeOverHeightOne (ratFuncInfinityPlace K) P + have hbaseEq : p₀.valuation (RatFunc K) = + pChart.valuation (RatFunc K) := + heightOneValuation_eq_of_ringEquiv + (ratFuncInfinityBaseRingEquivChart K) + (ratFuncInfinityBaseRingEquivChart_algebraMap K) + p₀ pChart rfl + have hunderChart : finiteExtensionUnderPlaceChart K L + (finiteExtensionPlaceEquivChart K L (.inr P)) = + Sum.inr pChart := by + simp only [finiteExtensionUnderPlaceChart, Equiv.symm_apply_apply, + finiteExtensionUnderPlace] + rfl + have hx₀ : p₀.valuation (RatFunc K) x ≤ 1 := by + rw [hbaseEq] + rw [hunderChart] at hx + exact hx + have hqUnder : q₀.under (RatFuncInfinityIntegers K) = p₀ := by + apply HeightOneSpectrum.ext + exact (Ideal.over_def P.1 (ratFuncInfinityPlace K).asIdeal).symm + have htop : q₀.valuation L (algebraMap (RatFunc K) L x) ≤ 1 := + heightOneValuation_algebraMap_le_one_of_under q₀ p₀ hqUnder hx₀ + have htopEq := congrArg + (fun v : Valuation L ℤᵐ⁰ => v (algebraMap (RatFunc K) L x)) + (finiteExtensionPlaceValuation_eq_chart K L (.inr P)) + rw [← htopEq] + exact htop + +/-- A chosen place of `L` above each rational-function chart place. -/ +def finiteExtensionPlaceSectionChart + (p : FunctionField.Chart.PlaceA K (RatFunc K)) : + FunctionField.Chart.PlaceA K L := + Classical.choose (finiteExtensionUnderPlaceChart_surjective K L p) + +omit [Fintype K] [DecidableEq K] in +@[simp] +theorem finiteExtensionUnderPlaceChart_section + (p : FunctionField.Chart.PlaceA K (RatFunc K)) : + finiteExtensionUnderPlaceChart K L + (finiteExtensionPlaceSectionChart K L p) = p := + Classical.choose_spec (finiteExtensionUnderPlaceChart_surjective K L p) + +/-- Adeles whose components are constant on every fiber over a base place. -/ +def finiteExtensionFiberConstantAdeleSubmodule : + Submodule K (FunctionField.Chart.AdeleSpace K L) where + carrier := {a | ∀ q r, + finiteExtensionUnderPlaceChart K L q = + finiteExtensionUnderPlaceChart K L r → a.1 q = a.1 r} + zero_mem' := by simp + add_mem' {a b} ha hb q r hqr := by + change a.1 q + b.1 q = a.1 r + b.1 r + rw [ha q r hqr, hb q r hqr] + smul_mem' c a ha q r hqr := by + change c • a.1 q = c • a.1 r + rw [ha q r hqr] + +/-- A fiber-constant adele has the chosen component at the base place of +every upstairs place. -/ +theorem fiberConstant_component_eq_section + (a : finiteExtensionFiberConstantAdeleSubmodule K L) + (q : FunctionField.Chart.PlaceA K L) : + a.1.1 q = a.1.1 (finiteExtensionPlaceSectionChart K L + (finiteExtensionUnderPlaceChart K L q)) := by + apply a.2 + rw [finiteExtensionUnderPlaceChart_section] + +/-- Componentwise field trace of a fiber-constant adele, before proving that +the resulting tuple is a rational-function adele. -/ +def finiteExtensionFiberTraceRaw : + finiteExtensionFiberConstantAdeleSubmodule K L →ₗ[K] + (FunctionField.Chart.PlaceA K (RatFunc K) → RatFunc K) where + toFun a p := Algebra.trace (RatFunc K) L + (a.1.1 (finiteExtensionPlaceSectionChart K L p)) + map_add' a b := by + funext p + exact map_add (Algebra.trace (RatFunc K) L) _ _ + map_smul' c a := by + funext p + simp only [Submodule.coe_smul, Pi.smul_apply] + rw [Algebra.smul_def, Algebra.smul_def] + rw [IsScalarTower.algebraMap_apply K (RatFunc K) L] + simp only [RingHom.id_apply] + simpa [Algebra.smul_def] using + (Algebra.trace (RatFunc K) L).map_smul + (algebraMap K (RatFunc K) c) + (a.1.1 (finiteExtensionPlaceSectionChart K L p)) + +/-- Top chart places at which a given adele is not integral. -/ +def finiteExtensionAdeleExceptionalSet + (a : FunctionField.Chart.AdeleSpace K L) : + Set (FunctionField.Chart.PlaceA K L) := + {q | a.1 q ∉ FunctionField.Chart.placeValuationSubring K L q} + +omit [Fintype K] [DecidableEq K] [DecidableEq (RatFunc K)] in +theorem finiteExtensionAdeleExceptionalSet_finite + (a : FunctionField.Chart.AdeleSpace K L) : + (finiteExtensionAdeleExceptionalSet K L a).Finite := by + have ha := a.2 + change ∀ᶠ q : FunctionField.Chart.PlaceA K L in Filter.cofinite, + a.1 q ∈ FunctionField.Chart.placeValuationSubring K L q at ha + simpa only [Filter.eventually_cofinite, + finiteExtensionAdeleExceptionalSet] using ha + +/-- Finite chart places in the support of the finite different. -/ +def finiteExtensionDifferentExceptionalSet : + Set (FunctionField.Chart.PlaceA K L) := + finiteExtensionPlaceEquivChart K L '' + (Sum.inl '' {q : FiniteExtensionFinitePlace K L | + multiplicity q.asIdeal + (differentIdeal K[X] (RatFuncFiniteIntegralClosure K L)) ≠ 0}) + +omit [Fintype K] [DecidableEq K] in +theorem finiteExtensionDifferentExceptionalSet_finite : + (finiteExtensionDifferentExceptionalSet K L).Finite := by + have hdiff : differentIdeal K[X] + (RatFuncFiniteIntegralClosure K L) ≠ ⊥ := + finiteExtensionFiniteDifferentIdeal_ne_bot K L + have hcountFinite : Set.Finite {q : FiniteExtensionFinitePlace K L | + FractionalIdeal.count L q + ((differentIdeal K[X] (RatFuncFiniteIntegralClosure K L) : + Ideal (RatFuncFiniteIntegralClosure K L)) : + FractionalIdeal (RatFuncFiniteIntegralClosure K L)⁰ L) ≠ 0} := by + simpa only [Filter.eventually_cofinite] using + FractionalIdeal.finite_factors (K := L) + ((differentIdeal K[X] (RatFuncFiniteIntegralClosure K L) : + Ideal (RatFuncFiniteIntegralClosure K L)) : + FractionalIdeal (RatFuncFiniteIntegralClosure K L)⁰ L) + have hmultFinite : Set.Finite {q : FiniteExtensionFinitePlace K L | + multiplicity q.asIdeal + (differentIdeal K[X] (RatFuncFiniteIntegralClosure K L)) ≠ 0} := by + refine hcountFinite.subset ?_ + intro q hq + change FractionalIdeal.count L q + ((differentIdeal K[X] (RatFuncFiniteIntegralClosure K L) : + Ideal (RatFuncFiniteIntegralClosure K L)) : + FractionalIdeal (RatFuncFiniteIntegralClosure K L)⁰ L) ≠ 0 + rw [FractionalIdeal.count_coeIdeal_eq_multiplicity + (K := L) (differentIdeal K[X] + (RatFuncFiniteIntegralClosure K L)) hdiff] + exact_mod_cast hq + exact (hmultFinite.image Sum.inl).image + (finiteExtensionPlaceEquivChart K L) + +/-- The unique base infinity chart place, expressed through the exhaustive +place equivalence. -/ +def ratFuncInfinityPlaceChart : + FunctionField.Chart.PlaceA K (RatFunc K) := + ratFuncExhaustivePlaceEquivChart K (.inr (ratFuncInfinityPlace K)) + +/-- The finite exceptional set outside which the componentwise trace is +integral. -/ +def finiteExtensionCotraceBadBaseSet + (a : FunctionField.Chart.AdeleSpace K L) : + Set (FunctionField.Chart.PlaceA K (RatFunc K)) := + finiteExtensionUnderPlaceChart K L '' + (finiteExtensionAdeleExceptionalSet K L a ∪ + finiteExtensionDifferentExceptionalSet K L) ∪ + {ratFuncInfinityPlaceChart K} + +omit [Fintype K] [DecidableEq K] in +theorem finiteExtensionCotraceBadBaseSet_finite + (a : FunctionField.Chart.AdeleSpace K L) : + (finiteExtensionCotraceBadBaseSet K L a).Finite := by + apply Set.Finite.union + · exact ((finiteExtensionAdeleExceptionalSet_finite K L a).union + (finiteExtensionDifferentExceptionalSet_finite K L)).image + (finiteExtensionUnderPlaceChart K L) + · exact Set.finite_singleton _ + +omit [Fintype K] [DecidableEq K] in +/-- The infinity component of the rational-function chart contains only the +place transported from the BGS infinity valuation ring. -/ +theorem ratFunc_infinite_chart_place_eq + (p : HeightOneSpectrum + (FunctionField.Chart.infiniteIntegers K (RatFunc K))) : + (Sum.inr p : FunctionField.Chart.PlaceA K (RatFunc K)) = + ratFuncInfinityPlaceChart K := by + let e := HeightOneSpectrum.equivOfRingEquiv + (ratFuncInfinityBaseRingEquivChart K) + have hsource : e.symm p = ratFuncInfinityPlace K := by + apply HeightOneSpectrum.ext + exact (IsLocalRing.eq_maximalIdeal + ((e.symm p).isPrime.isMaximal (e.symm p).ne_bot)).trans + (IsLocalRing.eq_maximalIdeal + ((ratFuncInfinityPlace K).isPrime.isMaximal + (ratFuncInfinityPlace K).ne_bot)).symm + change Sum.inr p = Sum.inr (e (ratFuncInfinityPlace K)) + apply congrArg Sum.inr + rw [← hsource, e.apply_symm_apply] + +/-- Outside the explicit finite exceptional set, the raw componentwise trace +is integral at the base chart place. -/ +theorem finiteExtensionFiberTraceRaw_mem_placeValuationSubring_of_not_bad + (a : finiteExtensionFiberConstantAdeleSubmodule K L) + (p : FunctionField.Chart.PlaceA K (RatFunc K)) + (hp : p ∉ finiteExtensionCotraceBadBaseSet K L a.1) : + finiteExtensionFiberTraceRaw K L a p ∈ + FunctionField.Chart.placeValuationSubring K (RatFunc K) p := by + rcases p with p | p + · let e := HeightOneSpectrum.equivOfRingEquiv + (ratFuncFiniteBaseRingEquivChart K) + let p₀ : HeightOneSpectrum K[X] := e.symm p + let q₀ := finiteExtensionPlaceSectionChart K L + (Sum.inl p : FunctionField.Chart.PlaceA K (RatFunc K)) + let y : L := a.1.1 q₀ + by_cases hy : y = 0 + · change Algebra.trace (RatFunc K) L y ∈ _ + rw [hy, map_zero] + exact zero_mem _ + have hnotTop (q : FunctionField.Chart.PlaceA K L) + (hq : finiteExtensionUnderPlaceChart K L q = Sum.inl p) : + q ∉ finiteExtensionAdeleExceptionalSet K L a.1 ∪ + finiteExtensionDifferentExceptionalSet K L := by + intro hqbad + apply hp + apply Or.inl + exact ⟨q, hqbad, hq⟩ + have hlocal : ∀ q : HeightOneSpectrum + (RatFuncFiniteIntegralClosure K L), + q.under K[X] = p₀ → + -(multiplicity q.asIdeal + (differentIdeal K[X] + (RatFuncFiniteIntegralClosure K L)) : ℤ) ≤ + FractionalIdeal.count L q + (FractionalIdeal.spanSingleton + (RatFuncFiniteIntegralClosure K L)⁰ y) := by + intro q hqUnder + let qChart : FunctionField.Chart.PlaceA K L := + finiteExtensionPlaceEquivChart K L (.inl q) + have hpImage : e p₀ = p := e.apply_symm_apply p + have hqBelow : finiteExtensionUnderPlaceChart K L qChart = + Sum.inl p := by + change ratFuncExhaustivePlaceEquivChart K + (Sum.inl (q.under K[X])) = Sum.inl p + rw [hqUnder] + change Sum.inl (e p₀) = Sum.inl p + rw [hpImage] + have hqGood := hnotTop qChart hqBelow + have hqAdele : qChart ∉ + finiteExtensionAdeleExceptionalSet K L a.1 := by + exact fun h => hqGood (Or.inl h) + have hqDifferent : qChart ∉ + finiteExtensionDifferentExceptionalSet K L := by + exact fun h => hqGood (Or.inr h) + have hyEq : a.1.1 qChart = y := by + have hcomponent := fiberConstant_component_eq_section K L a qChart + rw [hqBelow] at hcomponent + exact hcomponent + have hqMem : a.1.1 qChart ∈ + FunctionField.Chart.placeValuationSubring K L qChart := by + exact Classical.not_not.mp hqAdele + have hqValChart : FunctionField.Chart.placeValuation K L qChart + (a.1.1 qChart) ≤ 1 := by + rwa [← Valuation.mem_valuationSubring_iff] + have hqVal : q.valuation L y ≤ 1 := by + rw [← hyEq] + simpa [qChart, finiteExtensionPlaceEquivChart, + FunctionField.Chart.placeValuation] using hqValChart + have hqCount : 0 ≤ FractionalIdeal.count L q + (FractionalIdeal.spanSingleton + (RatFuncFiniteIntegralClosure K L)⁰ y) := + zero_le_count_spanSingleton_of_valuation_le_one q hy hqVal + have hqMultiplicity : multiplicity q.asIdeal + (differentIdeal K[X] + (RatFuncFiniteIntegralClosure K L)) = 0 := by + by_contra hne + apply hqDifferent + exact ⟨Sum.inl q, ⟨q, hne, rfl⟩, rfl⟩ + rw [hqMultiplicity] + simpa using hqCount + have htraceBase : p₀.valuation (RatFunc K) + (Algebra.trace (RatFunc K) L y) ≤ 1 := + valuation_trace_le_one_of_different_count_bounds_over + (A := K[X]) (K₀ := RatFunc K) + (B := RatFuncFiniteIntegralClosure K L) (L := L) + p₀ hy hlocal + have htraceChart : (e p₀).valuation (RatFunc K) + (Algebra.trace (RatFunc K) L y) ≤ 1 := by + apply heightOneValuation_le_one_of_ringEquiv + (ratFuncFiniteBaseRingEquivChart K) + (ratFuncFiniteBaseRingEquivChart_algebraMap K) + p₀ (e p₀) rfl htraceBase + change p.valuation (RatFunc K) + (Algebra.trace (RatFunc K) L y) ≤ 1 + have hpImage : e p₀ = p := e.apply_symm_apply p + rw [hpImage] at htraceChart + exact htraceChart + · exfalso + apply hp + apply Or.inr + exact Set.mem_singleton_iff.mpr (ratFunc_infinite_chart_place_eq K p) + +/-- Componentwise field trace as an actual rational-function adele. -/ +def finiteExtensionFiberTrace : + finiteExtensionFiberConstantAdeleSubmodule K L →ₗ[K] + FunctionField.Chart.AdeleSpace K (RatFunc K) where + toFun a := ⟨finiteExtensionFiberTraceRaw K L a, by + change ∀ᶠ p : FunctionField.Chart.PlaceA K (RatFunc K) in + Filter.cofinite, + finiteExtensionFiberTraceRaw K L a p ∈ + FunctionField.Chart.placeValuationSubring K (RatFunc K) p + rw [Filter.eventually_cofinite] + refine (finiteExtensionCotraceBadBaseSet_finite K L a.1).subset ?_ + intro p hp + by_contra hpBad + exact hp (finiteExtensionFiberTraceRaw_mem_placeValuationSubring_of_not_bad + K L a p hpBad)⟩ + map_add' a b := by + apply Subtype.ext + exact congrArg (fun f => f) ((finiteExtensionFiberTraceRaw K L).map_add a b) + map_smul' c a := by + apply Subtype.ext + exact congrArg (fun f => f) ((finiteExtensionFiberTraceRaw K L).map_smul c a) + +/-- Lift a base adele to a fiber-constant upstairs adele after multiplying by +a fixed extension-field element. -/ +def finiteExtensionFiberLift (z : L) + (b : FunctionField.Chart.AdeleSpace K (RatFunc K)) : + finiteExtensionFiberConstantAdeleSubmodule K L := by + letI : Filter.TendstoCofinite (finiteExtensionUnderPlaceChart K L) := + finiteExtensionUnderPlaceChart_tendstoCofinite K L + let a : FunctionField.Chart.AdeleSpace K L := + ⟨fun q => z * algebraMap (RatFunc K) L + (b.1 (finiteExtensionUnderPlaceChart K L q)), by + have hz := FunctionField.Chart.eventually_mem_placeValuationSubring K L z + have hb : ∀ᶠ q : FunctionField.Chart.PlaceA K L in Filter.cofinite, + b.1 (finiteExtensionUnderPlaceChart K L q) ∈ + FunctionField.Chart.placeValuationSubring K (RatFunc K) + (finiteExtensionUnderPlaceChart K L q) := + Filter.TendstoCofinite.tendsto_cofinite + (finiteExtensionUnderPlaceChart K L) b.2 + filter_upwards [hz, hb] with q hzq hbq + apply mul_mem hzq + exact finiteExtension_placeValuation_algebraMap_le_one K L q hbq⟩ + refine ⟨a, ?_⟩ + intro q r hqr + change z * algebraMap (RatFunc K) L + (b.1 (finiteExtensionUnderPlaceChart K L q)) = + z * algebraMap (RatFunc K) L + (b.1 (finiteExtensionUnderPlaceChart K L r)) + rw [hqr] + +/-- Cotrace of the lifted adele is scalar multiplication by `Tr(z)`. -/ +theorem finiteExtensionFiberTrace_lift (z : L) + (b : FunctionField.Chart.AdeleSpace K (RatFunc K)) : + finiteExtensionFiberTrace K L (finiteExtensionFiberLift K L z b) = + (Algebra.trace (RatFunc K) L z) • b := by + apply Subtype.ext + funext p + change Algebra.trace (RatFunc K) L + ((finiteExtensionFiberLift K L z b).1.1 + (finiteExtensionPlaceSectionChart K L p)) = + Algebra.trace (RatFunc K) L z * b.1 p + change Algebra.trace (RatFunc K) L + (z * algebraMap (RatFunc K) L + (b.1 (finiteExtensionUnderPlaceChart K L + (finiteExtensionPlaceSectionChart K L p)))) = _ + rw [finiteExtensionUnderPlaceChart_section] + simpa [Algebra.smul_def, mul_comm] using + (Algebra.trace (RatFunc K) L).map_smul (b.1 p) z + +/-- Componentwise cotrace is onto the base adele space. -/ +theorem finiteExtensionFiberTrace_surjective : + Function.Surjective (finiteExtensionFiberTrace K L) := by + intro b + obtain ⟨z, hz⟩ := Algebra.trace_surjective (RatFunc K) L (1 : RatFunc K) + refine ⟨finiteExtensionFiberLift K L z b, ?_⟩ + rw [finiteExtensionFiberTrace_lift K L z b, hz, one_smul] + +/-- At a finite base place, the componentwise trace of a fiber-constant +adele in the explicit different filtration is integral. -/ +theorem finiteExtensionFiberTrace_finite_valuation_le_one + (a : finiteExtensionFiberConstantAdeleSubmodule K L) + (ha : a.1 ∈ FunctionField.Chart.adeleFilt K L + (finiteExtensionDivisorEquivChart K L + (finiteExtensionCanonicalDifferentDivisor K L + (finiteExtensionFiniteDifferentIdeal_ne_bot K L)))) + (p : HeightOneSpectrum + (FunctionField.ringOfIntegers K (RatFunc K))) : + p.valuation (RatFunc K) + ((finiteExtensionFiberTrace K L a).1 (.inl p)) ≤ 1 := by + let e := HeightOneSpectrum.equivOfRingEquiv + (ratFuncFiniteBaseRingEquivChart K) + let p₀ : HeightOneSpectrum K[X] := e.symm p + let q₀ := finiteExtensionPlaceSectionChart K L + (Sum.inl p : FunctionField.Chart.PlaceA K (RatFunc K)) + let y : L := a.1.1 q₀ + by_cases hy : y = 0 + · change p.valuation (RatFunc K) (Algebra.trace (RatFunc K) L y) ≤ 1 + rw [hy, map_zero, Valuation.map_zero] + exact zero_le + have hlocal : ∀ q : HeightOneSpectrum + (RatFuncFiniteIntegralClosure K L), + q.under K[X] = p₀ → + -(multiplicity q.asIdeal + (differentIdeal K[X] + (RatFuncFiniteIntegralClosure K L)) : ℤ) ≤ + FractionalIdeal.count L q + (FractionalIdeal.spanSingleton + (RatFuncFiniteIntegralClosure K L)⁰ y) := by + intro q hqUnder + let qChart : FunctionField.Chart.PlaceA K L := + finiteExtensionPlaceEquivChart K L (.inl q) + have hpImage : e p₀ = p := e.apply_symm_apply p + have hqBelow : finiteExtensionUnderPlaceChart K L qChart = + Sum.inl p := by + change ratFuncExhaustivePlaceEquivChart K + (Sum.inl (q.under K[X])) = Sum.inl p + rw [hqUnder] + change Sum.inl (e p₀) = Sum.inl p + rw [hpImage] + have hyEq : a.1.1 qChart = y := by + have hcomponent := fiberConstant_component_eq_section K L a qChart + rw [hqBelow] at hcomponent + exact hcomponent + have hqFilter := ha qChart + have hqFilter' : q.valuation L y ≤ + WithZero.exp + (multiplicity q.asIdeal + (differentIdeal K[X] + (RatFuncFiniteIntegralClosure K L)) : ℤ) := by + rw [← hyEq] + simpa [qChart, finiteExtensionPlaceEquivChart, + FunctionField.Chart.placeValuation, + finiteExtensionDivisorEquivChart, Finsupp.domCongr_apply, + finiteExtensionCanonicalDifferentDivisor_inl] using hqFilter + have hqValuation := valuation_eq_exp_neg_finitePlaceOrder q y hy + rw [hqValuation] at hqFilter' + have hqExp := WithZero.exp_le_exp.mp hqFilter' + change -FractionalIdeal.count L q + (FractionalIdeal.spanSingleton + (RatFuncFiniteIntegralClosure K L)⁰ y) ≤ + (multiplicity q.asIdeal + (differentIdeal K[X] + (RatFuncFiniteIntegralClosure K L)) : ℤ) at hqExp + omega + have htraceBase : p₀.valuation (RatFunc K) + (Algebra.trace (RatFunc K) L y) ≤ 1 := + valuation_trace_le_one_of_different_count_bounds_over + (A := K[X]) (K₀ := RatFunc K) + (B := RatFuncFiniteIntegralClosure K L) (L := L) + p₀ hy hlocal + have htraceChart : (e p₀).valuation (RatFunc K) + (Algebra.trace (RatFunc K) L y) ≤ 1 := by + apply heightOneValuation_le_one_of_ringEquiv + (ratFuncFiniteBaseRingEquivChart K) + (ratFuncFiniteBaseRingEquivChart_algebraMap K) + p₀ (e p₀) rfl htraceBase + have hpImage : e p₀ = p := e.apply_symm_apply p + change p.valuation (RatFunc K) + (Algebra.trace (RatFunc K) L y) ≤ 1 + rw [hpImage] at htraceChart + exact htraceChart + +/-- At the infinite base place, the componentwise trace of a fiber-constant +adele in the explicit different filtration has order at least two. -/ +theorem finiteExtensionFiberTrace_infinite_valuation_le_exp_neg_two + (a : finiteExtensionFiberConstantAdeleSubmodule K L) + (ha : a.1 ∈ FunctionField.Chart.adeleFilt K L + (finiteExtensionDivisorEquivChart K L + (finiteExtensionCanonicalDifferentDivisor K L + (finiteExtensionFiniteDifferentIdeal_ne_bot K L)))) + (p : HeightOneSpectrum + (FunctionField.Chart.infiniteIntegers K (RatFunc K))) : + p.valuation (RatFunc K) + ((finiteExtensionFiberTrace K L a).1 (.inr p)) ≤ + WithZero.exp (-2 : ℤ) := by + let pInf := ratFuncInfinityPlace K + let pChart := HeightOneSpectrum.equivOfRingEquiv + (ratFuncInfinityBaseRingEquivChart K) pInf + have hpChart : p = pChart := by + apply Sum.inr_injective + calc + Sum.inr p = ratFuncInfinityPlaceChart K := + ratFunc_infinite_chart_place_eq K p + _ = Sum.inr pChart := rfl + let q₀ := finiteExtensionPlaceSectionChart K L + (Sum.inr p : FunctionField.Chart.PlaceA K (RatFunc K)) + let y : L := a.1.1 q₀ + by_cases hy : y = 0 + · change p.valuation (RatFunc K) (Algebra.trace (RatFunc K) L y) ≤ _ + rw [hy, map_zero, Valuation.map_zero] + exact zero_le + let s := ratFuncInfinityUniformizer K + have hs : s ≠ 0 := by + intro h + have hcoe := congrArg Subtype.val h + exact (one_div_ne_zero RatFunc.X_ne_zero) hcoe + let t : RatFunc K := algebraMap (RatFuncInfinityIntegers K) (RatFunc K) s + let tL : L := algebraMap (RatFuncInfinityIntegers K) L s + have htL : tL ≠ 0 := by + simpa only [tL, map_zero] using + (FaithfulSMul.algebraMap_injective + (RatFuncInfinityIntegers K) L).ne hs + let z : L := (tL ^ 2)⁻¹ * y + have hz : z ≠ 0 := mul_ne_zero (inv_ne_zero (pow_ne_zero 2 htL)) hy + have hlocal : ∀ q : HeightOneSpectrum + (RatFuncInfinityIntegralClosure K L), + q.under (RatFuncInfinityIntegers K) = pInf → + -(multiplicity q.asIdeal + (differentIdeal (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L)) : ℤ) ≤ + FractionalIdeal.count L q + (FractionalIdeal.spanSingleton + (RatFuncInfinityIntegralClosure K L)⁰ z) := by + intro q hqUnder + let : q.asIdeal.LiesOver pInf.asIdeal := ⟨by + have hideal := congrArg HeightOneSpectrum.asIdeal hqUnder + exact hideal.symm⟩ + let P : FiniteExtensionInfinityPlace K L := + (finiteExtensionInfinityPrimesOverEquivHeightOne K L).symm q + have hPq : primeOverHeightOne (ratFuncInfinityPlace K) P = q := + (finiteExtensionInfinityPrimesOverEquivHeightOne K L).apply_symm_apply q + let qChart : FunctionField.Chart.PlaceA K L := + finiteExtensionPlaceEquivChart K L (.inr P) + have hqBelow : finiteExtensionUnderPlaceChart K L qChart = + Sum.inr p := by + calc + finiteExtensionUnderPlaceChart K L qChart = + ratFuncInfinityPlaceChart K := by rfl + _ = Sum.inr p := (ratFunc_infinite_chart_place_eq K p).symm + have hyEq : a.1.1 qChart = y := by + have hcomponent := fiberConstant_component_eq_section K L a qChart + rw [hqBelow] at hcomponent + exact hcomponent + have hqFilter := ha qChart + have hcoeff : + (finiteExtensionDivisorEquivChart K L + (finiteExtensionCanonicalDifferentDivisor K L + (finiteExtensionFiniteDifferentIdeal_ne_bot K L))) qChart = + (multiplicity P.1 + (differentIdeal (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L)) : ℤ) - + 2 * (P.1.ramificationIdx + (RatFuncInfinityIntegers K) : ℤ) := by + simp [qChart, finiteExtensionDivisorEquivChart, + Finsupp.domCongr_apply, + finiteExtensionCanonicalDifferentDivisor_inr] + rw [hcoeff] at hqFilter + have hvaluationEq : + (primeOverHeightOne (ratFuncInfinityPlace K) P).valuation L y = + FunctionField.Chart.placeValuation K L qChart y := by + simpa only [finiteExtensionPlaceValuation, qChart] using + congrArg (fun v : Valuation L ℤᵐ⁰ => v y) + (finiteExtensionPlaceValuation_eq_chart K L (.inr P)) + have hqFilterBGS : + (primeOverHeightOne (ratFuncInfinityPlace K) P).valuation L y ≤ + WithZero.exp + ((multiplicity P.1 + (differentIdeal (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L)) : ℤ) - + 2 * (P.1.ramificationIdx + (RatFuncInfinityIntegers K) : ℤ)) := by + rw [hvaluationEq] + simpa only [hyEq] using hqFilter + rw [hPq] at hqFilterBGS + have hqValuation := valuation_eq_exp_neg_finitePlaceOrder q y hy + rw [hqValuation] at hqFilterBGS + have hqOrderBound := WithZero.exp_le_exp.mp hqFilterBGS + change -finitePlaceOrder q y ≤ + (multiplicity P.1 + (differentIdeal (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L)) : ℤ) - + 2 * (P.1.ramificationIdx + (RatFuncInfinityIntegers K) : ℤ) at hqOrderBound + have htOrder : finitePlaceOrder q tL = + (q.asIdeal.ramificationIdx + (RatFuncInfinityIntegers K) : ℤ) := by + simpa only [tL, IsScalarTower.algebraMap_apply + (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) L] using + finitePlaceOrder_algebraMap_uniformizer_eq_ramificationIdx + (R := RatFuncInfinityIntegers K) + (A := RatFuncInfinityIntegralClosure K L) (F := L) + pInf q s hs (ratFuncInfinityPlace_span_uniformizer K) + have htSquareOrder := finitePlaceOrder_mul_eq_add q tL tL htL htL + rw [← pow_two] at htSquareOrder + have htInvOrder := finitePlaceOrder_inv_eq_neg' q (tL ^ 2) + (pow_ne_zero 2 htL) + have hzOrder := finitePlaceOrder_mul_eq_add q (tL ^ 2)⁻¹ y + (inv_ne_zero (pow_ne_zero 2 htL)) hy + have hram : P.1.ramificationIdx (RatFuncInfinityIntegers K) = + q.asIdeal.ramificationIdx (RatFuncInfinityIntegers K) := by + rw [← hPq] + rfl + have hPideal : P.1 = q.asIdeal := by + rw [← hPq] + rfl + change -(multiplicity q.asIdeal + (differentIdeal (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L)) : ℤ) ≤ + finitePlaceOrder q ((tL ^ 2)⁻¹ * y) + rw [hzOrder, htInvOrder, htSquareOrder, htOrder] + rw [hPideal] at hqOrderBound + omega + have htraceScaled : pInf.valuation (RatFunc K) + (Algebra.trace (RatFunc K) L z) ≤ 1 := + valuation_trace_le_one_of_different_count_bounds_over + (A := RatFuncInfinityIntegers K) (K₀ := RatFunc K) + (B := RatFuncInfinityIntegralClosure K L) (L := L) + pInf hz hlocal + have htTower : tL = algebraMap (RatFunc K) L t := by + exact (IsScalarTower.algebraMap_apply + (RatFuncInfinityIntegers K) (RatFunc K) L s).symm + have htraceZ : Algebra.trace (RatFunc K) L z = + (t ^ 2)⁻¹ * Algebra.trace (RatFunc K) L y := by + have hscalar : (tL ^ 2)⁻¹ * y = ((t ^ 2)⁻¹) • y := by + rw [Algebra.smul_def, htTower, map_inv₀, map_pow] + change Algebra.trace (RatFunc K) L ((tL ^ 2)⁻¹ * y) = + ((t ^ 2)⁻¹) • Algebra.trace (RatFunc K) L y + rw [hscalar] + exact (Algebra.trace (RatFunc K) L).map_smul ((t ^ 2)⁻¹) y + rw [htraceZ, map_mul, map_inv₀, map_pow] at htraceScaled + have htVal : pInf.valuation (RatFunc K) t = WithZero.exp (-1 : ℤ) := by + change pInf.valuation (RatFunc K) + (algebraMap (RatFuncInfinityIntegers K) (RatFunc K) s) = _ + rw [HeightOneSpectrum.valuation_of_algebraMap] + exact pInf.intValuation_singleton hs + (ratFuncInfinityPlace_span_uniformizer K) + rw [htVal] at htraceScaled + have hbase : pInf.valuation (RatFunc K) + (Algebra.trace (RatFunc K) L y) ≤ WithZero.exp (-2 : ℤ) := by + apply le_of_mul_le_mul_left ?_ (WithZero.exp_pos : + 0 < WithZero.exp (2 : ℤ)) + calc + WithZero.exp (2 : ℤ) * pInf.valuation (RatFunc K) + (Algebra.trace (RatFunc K) L y) = + ((WithZero.exp (-1 : ℤ)) ^ 2)⁻¹ * + pInf.valuation (RatFunc K) + (Algebra.trace (RatFunc K) L y) := by norm_num + _ ≤ 1 := htraceScaled + _ = WithZero.exp (2 : ℤ) * WithZero.exp (-2 : ℤ) := by + rw [← WithZero.exp_add] + norm_num + have hchart : pChart.valuation (RatFunc K) + (Algebra.trace (RatFunc K) L y) ≤ WithZero.exp (-2 : ℤ) := by + have hvaluation : pInf.valuation (RatFunc K) = + pChart.valuation (RatFunc K) := + heightOneValuation_eq_of_ringEquiv + (ratFuncInfinityBaseRingEquivChart K) + (ratFuncInfinityBaseRingEquivChart_algebraMap K) + pInf pChart rfl + rw [← hvaluation] + exact hbase + change p.valuation (RatFunc K) + (Algebra.trace (RatFunc K) L y) ≤ WithZero.exp (-2 : ℤ) + rw [hpChart] + exact hchart + +omit [Fintype K] [DecidableEq K] in +/-- The infinity place selected for the identity extension is the unique +infinity place in the base chart. -/ +theorem ratFuncInfinityChartPlace_eq_baseChart : + ratFuncInfinityChartPlace K = ratFuncInfinityPlaceChart K := by + let p : HeightOneSpectrum + (FunctionField.Chart.infiniteIntegers K (RatFunc K)) := + finiteExtensionInfinityPlaceEquivChart K (RatFunc K) + (ratFuncIdentityInfinityPlace K) + change Sum.inr p = ratFuncInfinityPlaceChart K + exact ratFunc_infinite_chart_place_eq K p + +/-- The cotrace sends the explicit different filtration into the canonical +`-2∞` filtration on the rational function field. -/ +theorem finiteExtensionFiberTrace_mem_ratFuncCanonicalInfinityAdeleFilt + (a : finiteExtensionFiberConstantAdeleSubmodule K L) + (ha : a.1 ∈ FunctionField.Chart.adeleFilt K L + (finiteExtensionDivisorEquivChart K L + (finiteExtensionCanonicalDifferentDivisor K L + (finiteExtensionFiniteDifferentIdeal_ne_bot K L)))) : + finiteExtensionFiberTrace K L a ∈ + FunctionField.Chart.adeleFilt K (RatFunc K) + (ratFuncCanonicalInfinityDivisor K) := by + intro v + rcases v with p | p + · have h := finiteExtensionFiberTrace_finite_valuation_le_one K L a ha p + have hcoeff : ratFuncCanonicalInfinityDivisor K (Sum.inl p) = 0 := by + rw [ratFuncCanonicalInfinityDivisor, + Finsupp.single_eq_of_ne] + change Sum.inl p ≠ Sum.inr _ + exact Sum.inl_ne_inr + rw [hcoeff, WithZero.exp_zero] + exact h + · have h := finiteExtensionFiberTrace_infinite_valuation_le_exp_neg_two + K L a ha p + have hp : (Sum.inr p : FunctionField.Chart.PlaceA K (RatFunc K)) = + ratFuncInfinityChartPlace K := by + rw [ratFuncInfinityChartPlace_eq_baseChart K] + exact ratFunc_infinite_chart_place_eq K p + have hcoeff : ratFuncCanonicalInfinityDivisor K (Sum.inr p) = -2 := by + rw [ratFuncCanonicalInfinityDivisor, hp, Finsupp.single_eq_same] + rw [hcoeff] + exact h + +omit [Fintype K] [DecidableEq K] in +/-- Principal adeles are fiber-constant. -/ +theorem finiteExtension_diagonal_mem_fiberConstant (x : L) : + FunctionField.Chart.diagonal K L x ∈ + finiteExtensionFiberConstantAdeleSubmodule K L := by + intro q r _hqr + rfl + +/-- Cotrace carries a principal adele to the principal adele of the field +trace. -/ +theorem finiteExtensionFiberTrace_diagonal (x : L) : + finiteExtensionFiberTrace K L + ⟨FunctionField.Chart.diagonal K L x, + finiteExtension_diagonal_mem_fiberConstant K L x⟩ = + FunctionField.Chart.diagonal K (RatFunc K) + (Algebra.trace (RatFunc K) L x) := by + apply Subtype.ext + funext p + rfl + +/-- The base canonical functional composed with cotrace vanishes on the +intersection of fiber-constant adeles with the explicit different +filtration plus principal adeles. -/ +theorem finiteExtensionFiberCotrace_vanishes_on_intersection + (ω : FunctionField.Chart.WeilDifferential K (RatFunc K)) + (hωvan : ratFuncCanonicalInfinityDivisor K ∈ + FunctionField.Chart.WeilDifferential.vanishingDivisors ω) + (x : ↥(finiteExtensionFiberConstantAdeleSubmodule K L ⊓ + (FunctionField.Chart.adeleFilt K L + (finiteExtensionDivisorEquivChart K L + (finiteExtensionCanonicalDifferentDivisor K L + (finiteExtensionFiniteDifferentIdeal_ne_bot K L))) + + FunctionField.Chart.diagonalSubmodule K L))) : + (ω.toFun.comp (finiteExtensionFiberTrace K L)) + ⟨x.1, x.2.1⟩ = 0 := by + let U := finiteExtensionFiberConstantAdeleSubmodule K L + let D := finiteExtensionDivisorEquivChart K L + (finiteExtensionCanonicalDifferentDivisor K L + (finiteExtensionFiniteDifferentIdeal_ne_bot K L)) + have hxsum : x.1 ∈ FunctionField.Chart.adeleFilt K L D ⊔ + FunctionField.Chart.diagonalSubmodule K L := by + rw [← Submodule.add_eq_sup] + exact x.2.2 + rcases Submodule.mem_sup.mp hxsum with ⟨a, ha, d, hd, had⟩ + obtain ⟨y, rfl⟩ := hd + let dU : U := + ⟨FunctionField.Chart.diagonal K L y, + finiteExtension_diagonal_mem_fiberConstant K L y⟩ + have haUmem : a ∈ U := by + have hsub := U.sub_mem x.2.1 dU.2 + have haEq : x.1 - FunctionField.Chart.diagonal K L y = a := by + rw [← had] + abel + rw [haEq] at hsub + exact hsub + let aU : U := ⟨a, haUmem⟩ + have hxEq : (⟨x.1, x.2.1⟩ : U) = aU + dU := by + apply Subtype.ext + exact had.symm + have htraceA : finiteExtensionFiberTrace K L aU ∈ + FunctionField.Chart.adeleFilt K (RatFunc K) + (ratFuncCanonicalInfinityDivisor K) := + finiteExtensionFiberTrace_mem_ratFuncCanonicalInfinityAdeleFilt + K L aU ha + have htraceD : finiteExtensionFiberTrace K L dU ∈ + FunctionField.Chart.diagonalSubmodule K (RatFunc K) := by + rw [finiteExtensionFiberTrace_diagonal K L y] + exact ⟨Algebra.trace (RatFunc K) L y, rfl⟩ + apply hωvan + rw [hxEq, map_add] + rw [Submodule.add_eq_sup] + exact Submodule.add_mem_sup htraceA htraceD + +/-- A nonzero base Weil functional stays nonzero after composition with the +surjective fiber cotrace. -/ +theorem finiteExtensionFiberCotrace_ne_zero + (ω : FunctionField.Chart.WeilDifferential K (RatFunc K)) + (hω : ω.toFun ≠ 0) : + ω.toFun.comp (finiteExtensionFiberTrace K L) ≠ 0 := by + intro hzero + apply hω + apply LinearMap.ext + intro b + obtain ⟨a, ha⟩ := finiteExtensionFiberTrace_surjective K L b + have hz := LinearMap.congr_fun hzero a + change ω.toFun ((finiteExtensionFiberTrace K L) a) = 0 at hz + rw [ha] at hz + exact hz + +/-- The explicit finite-extension different divisor is a vanishing divisor +of a nonzero Weil differential. Consequently it is bounded above by the +maximal divisor of that differential. -/ +theorem finiteExtensionCanonicalDifferent_le_divOmega + [FunctionField.IsFullConstantField K L] : + ∃ (ωTop : FunctionField.Chart.WeilDifferential K L) + (hωTop : FunctionField.Chart.WeilDifferential.IsNonzero ωTop), + finiteExtensionDivisorEquivChart K L + (finiteExtensionCanonicalDifferentDivisor K L + (finiteExtensionFiniteDifferentIdeal_ne_bot K L)) ≤ + FunctionField.Chart.WeilDifferential.divOmega ωTop hωTop := by + obtain ⟨ωBase, hωBase, hdivBase⟩ := + ratFuncCanonicalInfinityDivisor_isCanonical K + have hmaxBase : + FunctionField.Chart.WeilDifferential.divOmega ωBase hωBase ∈ + FunctionField.Chart.WeilDifferential.vanishingDivisors ωBase ∧ + ∀ D ∈ FunctionField.Chart.WeilDifferential.vanishingDivisors ωBase, + D ≤ FunctionField.Chart.WeilDifferential.divOmega ωBase hωBase := by + simpa only [FunctionField.Chart.WeilDifferential.divOmega] using + (Classical.choose_spec + (FunctionField.Chart.WeilDifferential.exists_max_vanishingDivisor + (k := K) (K := RatFunc K) hωBase)).1 + have hbaseVan : ratFuncCanonicalInfinityDivisor K ∈ + FunctionField.Chart.WeilDifferential.vanishingDivisors ωBase := by + rw [hdivBase] at hmaxBase + exact hmaxBase.1 + let U := finiteExtensionFiberConstantAdeleSubmodule K L + let D := finiteExtensionDivisorEquivChart K L + (finiteExtensionCanonicalDifferentDivisor K L + (finiteExtensionFiniteDifferentIdeal_ne_bot K L)) + let V := FunctionField.Chart.adeleFilt K L D + + FunctionField.Chart.diagonalSubmodule K L + let f := ωBase.toFun.comp (finiteExtensionFiberTrace K L) + have hfVan : ∀ x : ↥(U ⊓ V), f ⟨x, x.property.1⟩ = 0 := by + intro x + exact finiteExtensionFiberCotrace_vanishes_on_intersection + K L ωBase hbaseVan x + have hfNe : f ≠ 0 := + finiteExtensionFiberCotrace_ne_zero K L ωBase hωBase + obtain ⟨g, hgU, hgV, hgNe⟩ := + exists_ne_zero_linearMap_extending_eq_zero_on_inf U V f hfVan hfNe + let ωTop : FunctionField.Chart.WeilDifferential K L := + ⟨g, ⟨D, fun a ha => LinearMap.mem_ker.mp (hgV ha)⟩⟩ + have hωTop : FunctionField.Chart.WeilDifferential.IsNonzero ωTop := by + exact hgNe + have hDvan : D ∈ + FunctionField.Chart.WeilDifferential.vanishingDivisors ωTop := by + intro a ha + exact LinearMap.mem_ker.mp (hgV ha) + have hmaxTop : + FunctionField.Chart.WeilDifferential.divOmega ωTop hωTop ∈ + FunctionField.Chart.WeilDifferential.vanishingDivisors ωTop ∧ + ∀ D' ∈ FunctionField.Chart.WeilDifferential.vanishingDivisors ωTop, + D' ≤ FunctionField.Chart.WeilDifferential.divOmega ωTop hωTop := by + simpa only [FunctionField.Chart.WeilDifferential.divOmega] using + (Classical.choose_spec + (FunctionField.Chart.WeilDifferential.exists_max_vanishingDivisor + (k := K) (K := L) hωTop)).1 + exact ⟨ωTop, hωTop, hmaxTop.2 D hDvan⟩ + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionCanonicalDifferentCotraceCanonicality.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionCanonicalDifferentCotraceCanonicality.lean new file mode 100644 index 0000000000..9725a71e7e --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionCanonicalDifferentCotraceCanonicality.lean @@ -0,0 +1,117 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionCanonicalDifferentCotrace +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionCanonicalDifferentCanonicalityCriterion + +/-! +# Canonicality from cotrace and the different degree + +The cotrace construction proves that the explicit different divisor is a +vanishing divisor of a nonzero Weil differential. This file records the +exact consequence of that inclusion: once the Riemann--Hurwitz degree identity +is known, equality of degrees forces equality with the maximal vanishing +divisor. Thus canonicality no longer needs a separate Riemann--Roch dimension +hypothesis. + +The degree identity remains an explicit premise; it is not derived or hidden +here. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +noncomputable section + +open BGS.CorvajaZannier +open scoped Polynomial + +variable (K : Type*) [Field K] [Fintype K] [DecidableEq K] + [DecidableEq (RatFunc K)] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +local instance cotraceCanonicalityConstantAlgebra : Algebra K L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K (RatFunc K))) + +local instance cotraceCanonicalityConstantTower : + IsScalarTower K (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + +local instance (priority := 10) cotraceCanonicalityPolynomialAlgebra : + Algebra K[X] L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K[X] (RatFunc K))) + +local instance cotraceCanonicalityPolynomialTower : + IsScalarTower K[X] (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + +local instance cotraceCanonicalityConstantPolynomialTower : + IsScalarTower K K[X] L := + IsScalarTower.of_algebraMap_eq' rfl + +/-- The cotrace inclusion and the Riemann--Hurwitz degree identity identify +the explicit different divisor with a canonical divisor. -/ +theorem finiteExtensionCanonicalDifferent_isCanonical_of_degree_eq + [FunctionField.IsFullConstantField K L] + (hdegree : finiteExtensionDivisorDegree K L + (finiteExtensionCanonicalDifferentDivisor K L + (finiteExtensionFiniteDifferentIdeal_ne_bot K L)) = + 2 * (FunctionField.Chart.genus K L : ℤ) - 2) : + FunctionField.Chart.IsCanonical K L + (finiteExtensionDivisorEquivChart K L + (finiteExtensionCanonicalDifferentDivisor K L + (finiteExtensionFiniteDifferentIdeal_ne_bot K L))) := by + let D := finiteExtensionDivisorEquivChart K L + (finiteExtensionCanonicalDifferentDivisor K L + (finiteExtensionFiniteDifferentIdeal_ne_bot K L)) + obtain ⟨ω, hω, hDle⟩ := + finiteExtensionCanonicalDifferent_le_divOmega K L + have hcanonicalOmega : FunctionField.Chart.IsCanonical K L + (FunctionField.Chart.WeilDifferential.divOmega ω hω) := + ⟨ω, hω, rfl⟩ + have hdegOmega : FunctionField.Chart.deg K L + (FunctionField.Chart.WeilDifferential.divOmega ω hω) = + 2 * (FunctionField.Chart.genus K L : ℤ) - 2 := + FunctionField.Chart.deg_canonical K L hcanonicalOmega + have hdegD : FunctionField.Chart.deg K L D = + 2 * (FunctionField.Chart.genus K L : ℤ) - 2 := by + rw [← finiteExtensionDivisorDegree_eq_chart] + exact hdegree + have heq : D = FunctionField.Chart.WeilDifferential.divOmega ω hω := + FunctionField.Chart.eq_of_le_of_deg_le K L hDle (by + rw [hdegOmega, hdegD]) + exact ⟨ω, hω, heq.symm⟩ + +/-- Consequently, a degree upper bound gives a genus upper bound once the +Riemann--Hurwitz degree identity is supplied. -/ +theorem finiteExtension_genus_le_budget_of_cotrace_and_degree_eq + [FunctionField.IsFullConstantField K L] + (budget : ℕ) + (hdegreeEq : finiteExtensionDivisorDegree K L + (finiteExtensionCanonicalDifferentDivisor K L + (finiteExtensionFiniteDifferentIdeal_ne_bot K L)) = + 2 * (FunctionField.Chart.genus K L : ℤ) - 2) + (hdegreeLe : finiteExtensionDivisorDegree K L + (finiteExtensionCanonicalDifferentDivisor K L + (finiteExtensionFiniteDifferentIdeal_ne_bot K L)) ≤ + 2 * (budget : ℤ) - 2) : + FunctionField.genus K L ≤ budget := by + exact finiteExtension_genus_le_budget_of_canonicalDifferent_isCanonical + K L budget + (finiteExtensionCanonicalDifferent_isCanonical_of_degree_eq + K L hdegreeEq) + hdegreeLe + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionCanonicalDifferentGenusBound.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionCanonicalDifferentGenusBound.lean new file mode 100644 index 0000000000..e5b84ff9e3 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionCanonicalDifferentGenusBound.lean @@ -0,0 +1,159 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveCanonicalDegreeBound +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionRiemannRoch +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneOnePointRiemannLower + +/-! +# Canonical-different genus bridge + +The explicit different divisor used by the Corvaja--Zannier development has +the correct degree bound under only one separating coordinate. This module +isolates the exact remaining bridge to the intrinsic Riemann--Roch genus: +after transporting that divisor to the Riemann--Roch chart, it must be shown +to be canonical. + +No canonicality premise is hidden in a definition. The generic theorem +below takes `FunctionField.Chart.IsCanonical` explicitly, while the plane +theorem proves the complete degree estimate available below that boundary. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +noncomputable section + +open BGS.CorvajaZannier +open scoped Polynomial + +variable (K : Type*) [Field K] [Fintype K] [DecidableEq K] + [DecidableEq (RatFunc K)] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +local instance canonicalGenusConstantAlgebra : Algebra K L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K (RatFunc K))) + +local instance canonicalGenusConstantTower : + IsScalarTower K (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + +local instance (priority := 10) canonicalGenusPolynomialAlgebra : + Algebra K[X] L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K[X] (RatFunc K))) + +local instance canonicalGenusPolynomialTower : + IsScalarTower K[X] (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + +local instance canonicalGenusConstantPolynomialTower : + IsScalarTower K K[X] L := + IsScalarTower.of_algebraMap_eq' rfl + +omit [Fintype K] in +/-- Identifying the explicit different divisor with a canonical divisor +turns any upper bound for its degree into a genus bound. -/ +theorem finiteExtension_genus_le_budget_of_canonicalDifferent_isCanonical + [FunctionField.IsFullConstantField K L] + (budget : ℕ) + (hcanonical : FunctionField.Chart.IsCanonical K L + (finiteExtensionDivisorEquivChart K L + (finiteExtensionCanonicalDifferentDivisor K L + (finiteExtensionFiniteDifferentIdeal_ne_bot K L)))) + (hdegree : finiteExtensionDivisorDegree K L + (finiteExtensionCanonicalDifferentDivisor K L + (finiteExtensionFiniteDifferentIdeal_ne_bot K L)) ≤ + 2 * (budget : ℤ) - 2) : + FunctionField.genus K L ≤ budget := by + let D := finiteExtensionCanonicalDifferentDivisor K L + (finiteExtensionFiniteDifferentIdeal_ne_bot K L) + have hcanonicalDegree : finiteExtensionDivisorDegree K L D = + 2 * (FunctionField.Chart.genus K L : ℤ) - 2 := by + rw [finiteExtensionDivisorDegree_eq_chart] + exact FunctionField.Chart.deg_canonical K L hcanonical + have hchart : FunctionField.Chart.genus K L ≤ budget := by + have hdegree' : finiteExtensionDivisorDegree K L D ≤ + 2 * (budget : ℤ) - 2 := by + simpa only [D] using hdegree + have hcast : (FunctionField.Chart.genus K L : ℤ) ≤ budget := by + omega + exact_mod_cast hcast + rw [FunctionField.genus_eq_genusChart K L] + exact hchart + +end + +noncomputable section + +open BGS.CorvajaZannier + +variable {K : Type*} [Field K] [Fintype K] [DecidableEq K] + [DecidableEq (RatFunc K)] + +/-- The one-separating-coordinate canonical-degree estimate already has +exactly the degree shape needed for the bidegree genus budget. -/ +theorem planeCurve_canonicalDifferentDivisor_degree_le_two_genusBudget_sub_two + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (hcardK : MvPolynomial.degreeOf 1 f < Fintype.card K) : + letI := planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + letI := planeCurveFirstCoordinateRatFuncAlgebra f hx + letI := finiteDimensional_planeCurveFunctionField_over_ratFunc + hf hpartialSecond + letI := separable_planeCurveFunctionField_over_ratFunc + hf hpartialSecond + finiteExtensionDivisorDegree K (PlaneCurveFunctionField f) + (finiteExtensionCanonicalDifferentDivisor K + (PlaneCurveFunctionField f) + (finiteExtensionFiniteDifferentIdeal_ne_bot K + (PlaneCurveFunctionField f))) ≤ + 2 * (planeCurveBidegreeGenusBudget f : ℤ) - 2 := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let : Algebra (RatFunc K) (PlaneCurveFunctionField f) := + planeCurveFirstCoordinateRatFuncAlgebra f hx + let : FiniteDimensional (RatFunc K) (PlaneCurveFunctionField f) := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : Algebra.IsSeparable (RatFunc K) (PlaneCurveFunctionField f) := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + have hcanonical := + planeCurve_canonicalDifferentDivisor_degree_le + hf hpartialSecond hcardK + have hb : 0 < MvPolynomial.degreeOf 1 f := + degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond + change finiteExtensionDivisorDegree K (PlaneCurveFunctionField f) + (finiteExtensionCanonicalDifferentDivisor K + (PlaneCurveFunctionField f) + (finiteExtensionFiniteDifferentIdeal_ne_bot K + (PlaneCurveFunctionField f))) ≤ + 2 * (((MvPolynomial.degreeOf 0 f - 1) * + (MvPolynomial.degreeOf 1 f - 1) : ℕ) : ℤ) - 2 + by_cases ha : MvPolynomial.degreeOf 0 f = 0 + · rw [ha] at hcanonical ⊢ + simp only [Nat.zero_sub, zero_mul, Nat.cast_zero, zero_mul] + omega + · have ha' : 1 ≤ MvPolynomial.degreeOf 0 f := + Nat.one_le_iff_ne_zero.mpr ha + have hb' : 1 ≤ MvPolynomial.degreeOf 1 f := by omega + rw [Nat.cast_mul, Nat.cast_sub ha', Nat.cast_sub hb'] + push_cast + nlinarith [hcanonical] + +end + + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionCanonicalDifferentLocalMaximality.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionCanonicalDifferentLocalMaximality.lean new file mode 100644 index 0000000000..2486b12fe8 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionCanonicalDifferentLocalMaximality.lean @@ -0,0 +1,787 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionCotraceLocalTraceImage +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionCanonicalDifferentCanonicalityCriterion + +/-! +# Local maximality of the canonical different by cotrace + +This file connects the generic trace-image theorem formalizing Stichtenoth, +Theorem 3.4.6, Step (b1), to the explicit `-2∞` base differential and the +extension-place filtration. A one-place witness detects every divisor not +bounded by the trace-different divisor. Applied to the glued cotrace Weil +functional, this proves that the trace-different divisor is its exact maximal +vanishing divisor, without assuming a Riemann--Hurwitz degree identity. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +open BGS.CorvajaZannier +open IsDedekindDomain Multiplicative WithZero +open scoped Polynomial nonZeroDivisors + +noncomputable section + +variable (K : Type*) [Field K] [Fintype K] [DecidableEq K] + [DecidableEq (RatFunc K)] + +omit [Fintype K] [DecidableEq K] in +/-- At every base chart place, maximality of the canonical `-2∞` +differential supplies a one-component adele at the first filtration step on +which the differential is nonzero. -/ +theorem ratFuncCanonicalWeil_exists_singlePlace_witness + (ω : FunctionField.Chart.WeilDifferential K (RatFunc K)) + (hω : FunctionField.Chart.WeilDifferential.IsNonzero ω) + (hdiv : FunctionField.Chart.WeilDifferential.divOmega ω hω = + ratFuncCanonicalInfinityDivisor K) + (p : FunctionField.Chart.PlaceA K (RatFunc K)) : + ∃ a : FunctionField.Chart.AdeleSpace K (RatFunc K), + a ∈ FunctionField.Chart.adeleFilt K (RatFunc K) + (ratFuncCanonicalInfinityDivisor K + Finsupp.single p 1) ∧ + ω.toFun a ≠ 0 ∧ + (∀ v ≠ p, a.1 v = 0) ∧ + FunctionField.Chart.placeValuation K (RatFunc K) p (a.1 p) = + WithZero.exp (ratFuncCanonicalInfinityDivisor K p + 1) := by + classical + let D := ratFuncCanonicalInfinityDivisor K + let E := D + Finsupp.single p 1 + have hmax : + FunctionField.Chart.WeilDifferential.divOmega ω hω ∈ + FunctionField.Chart.WeilDifferential.vanishingDivisors ω ∧ + ∀ D' ∈ FunctionField.Chart.WeilDifferential.vanishingDivisors ω, + D' ≤ FunctionField.Chart.WeilDifferential.divOmega ω hω := by + simpa only [FunctionField.Chart.WeilDifferential.divOmega] using + (Classical.choose_spec + (FunctionField.Chart.WeilDifferential.exists_max_vanishingDivisor + (k := K) (K := RatFunc K) hω)).1 + rw [hdiv] at hmax + have hEnot : E ∉ + FunctionField.Chart.WeilDifferential.vanishingDivisors ω := by + intro hE + have hle := hmax.2 E hE p + simp only [E, D, Finsupp.add_apply, Finsupp.single_eq_same] at hle + omega + change ¬ ∀ a, a ∈ + FunctionField.Chart.adeleFilt K (RatFunc K) E + + FunctionField.Chart.diagonalSubmodule K (RatFunc K) → + ω.toFun a = 0 at hEnot + push Not at hEnot + obtain ⟨x, hx, hωx⟩ := hEnot + rw [Submodule.add_eq_sup] at hx + rcases Submodule.mem_sup.mp hx with ⟨b, hb, d, hd, hbd⟩ + have hωd : ω.toFun d = 0 := by + apply hmax.1 + rw [Submodule.add_eq_sup] + exact Submodule.mem_sup_right hd + have hωb : ω.toFun b ≠ 0 := by + intro hzero + apply hωx + rw [← hbd, map_add, hzero, hωd, add_zero] + let a := FunctionField.Chart.adeleUpdate K (RatFunc K) + (FunctionField.Chart.zeroAdele K (RatFunc K)) p (b.1 p) + have haE : a ∈ FunctionField.Chart.adeleFilt K (RatFunc K) E := by + intro v + by_cases hv : v = p + · subst v + simpa [a, FunctionField.Chart.adeleUpdate] using hb p + · simp [a, FunctionField.Chart.adeleUpdate, + FunctionField.Chart.zeroAdele, hv] + have hsubD : b - a ∈ + FunctionField.Chart.adeleFilt K (RatFunc K) D := by + intro v + by_cases hv : v = p + · subst v + simp [a, FunctionField.Chart.adeleUpdate, + FunctionField.Chart.zeroAdele] + · have hbv := hb v + simpa [E, D, a, FunctionField.Chart.adeleUpdate, + FunctionField.Chart.zeroAdele, hv] using hbv + have hωsub : ω.toFun (b - a) = 0 := by + apply hmax.1 + rw [Submodule.add_eq_sup] + exact Submodule.mem_sup_left hsubD + have hωa : ω.toFun a ≠ 0 := by + intro hzero + apply hωb + have hmap := ω.toFun.map_sub b a + rw [hωsub, hzero, sub_zero] at hmap + exact hmap.symm + have haSupport : ∀ v ≠ p, a.1 v = 0 := by + intro v hv + simp [a, FunctionField.Chart.adeleUpdate, + FunctionField.Chart.zeroAdele, hv] + have hap0 : a.1 p ≠ 0 := by + intro hzero + apply hωa + have haZero : a = 0 := by + apply Subtype.ext + funext v + by_cases hv : v = p + · subst v + exact hzero + · exact haSupport v hv + rw [haZero, map_zero] + have haUpper : FunctionField.Chart.placeValuation K (RatFunc K) p (a.1 p) ≤ + WithZero.exp (D p + 1) := by + have := haE p + simpa [E, Finsupp.add_apply, Finsupp.single_eq_same] using this + have haNotLower : ¬ FunctionField.Chart.placeValuation K (RatFunc K) p (a.1 p) ≤ + WithZero.exp (D p) := by + intro hlower + apply hωa + apply hmax.1 + rw [Submodule.add_eq_sup] + apply Submodule.mem_sup_left + intro v + by_cases hv : v = p + · subst v + exact hlower + · simp [haSupport v hv] + have haLower : WithZero.exp (D p) < + FunctionField.Chart.placeValuation K (RatFunc K) p (a.1 p) := + lt_of_not_ge haNotLower + let m : ℤ := WithZero.log + (FunctionField.Chart.placeValuation K (RatFunc K) p (a.1 p)) + have hval0 : FunctionField.Chart.placeValuation K (RatFunc K) p (a.1 p) ≠ 0 := + (Valuation.ne_zero_iff _).mpr hap0 + have hvalExp : WithZero.exp m = + FunctionField.Chart.placeValuation K (RatFunc K) p (a.1 p) := by + exact WithZero.exp_log hval0 + have hmLower : D p < m := by + rw [← hvalExp, WithZero.exp_lt_exp] at haLower + exact haLower + have hmUpper : m ≤ D p + 1 := by + rw [← hvalExp, WithZero.exp_le_exp] at haUpper + exact haUpper + have hm : m = D p + 1 := by omega + refine ⟨a, ?_, hωa, haSupport, ?_⟩ + · simpa only [E, D] using haE + · rw [← hvalExp, hm] + +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +local instance detectionConstantAlgebra : Algebra K L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K (RatFunc K))) + +local instance detectionConstantTower : IsScalarTower K (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + +local instance (priority := 10) detectionPolynomialAlgebra : Algebra K[X] L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K[X] (RatFunc K))) + +local instance detectionPolynomialTower : IsScalarTower K[X] (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + +local instance detectionConstantPolynomialTower : IsScalarTower K K[X] L := + IsScalarTower.of_algebraMap_eq' rfl + +local instance detectionFiniteClosureModuleFinite : + Module.Finite K[X] (RatFuncFiniteIntegralClosure K L) := + IsIntegralClosure.finite K[X] (RatFunc K) L + (RatFuncFiniteIntegralClosure K L) + +local instance detectionFiniteClosureIsIntegral : + Algebra.IsIntegral K[X] (RatFuncFiniteIntegralClosure K L) := + IsIntegralClosure.isIntegral_algebra K[X] L + +local instance detectionFiniteBaseTorsionFreeTop : + Module.IsTorsionFree K[X] L := + Module.IsTorsionFree.trans_faithfulSMul K[X] (RatFunc K) L + +local instance detectionFiniteClosureTorsionFree : + Module.IsTorsionFree K[X] (RatFuncFiniteIntegralClosure K L) := + IsIntegralClosure.isTorsionFree K[X] L + +local instance detectionInfinityClosureModuleFinite : + Module.Finite (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.finite (RatFuncInfinityIntegers K) (RatFunc K) L + (RatFuncInfinityIntegralClosure K L) + +local instance detectionInfinityClosureIsIntegral : + Algebra.IsIntegral (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.isIntegral_algebra (RatFuncInfinityIntegers K) L + +local instance detectionInfinityBaseTorsionFreeTop : + Module.IsTorsionFree (RatFuncInfinityIntegers K) L := + Module.IsTorsionFree.trans_faithfulSMul + (RatFuncInfinityIntegers K) (RatFunc K) L + +local instance detectionInfinityClosureTorsionFree : + Module.IsTorsionFree (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.isTorsionFree (RatFuncInfinityIntegers K) L + +local instance detectionInfinityClosureIsDedekind : + IsDedekindDomain (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.isDedekindDomain + (RatFuncInfinityIntegers K) (RatFunc K) L + (RatFuncInfinityIntegralClosure K L) + +local instance detectionInfinityClosureIsFractionRing : + IsFractionRing (RatFuncInfinityIntegralClosure K L) L := + IsIntegralClosure.isFractionRing_of_finite_extension + (RatFuncInfinityIntegers K) (RatFunc K) L + (RatFuncInfinityIntegralClosure K L) + +/-- A fiber lift supported over one base place lies in an arbitrary divisor +filtration once its common nonzero fiber value satisfies the local bounds. -/ +theorem finiteExtensionFiberLift_mem_adeleFilt_of_supported + (Btop : FunctionField.Chart.DivisorA K L) + (p : FunctionField.Chart.PlaceA K (RatFunc K)) + (b : FunctionField.Chart.AdeleSpace K (RatFunc K)) + (z : L) + (hbp : b.1 p = 1) + (hbAway : ∀ v ≠ p, b.1 v = 0) + (hz : ∀ q, finiteExtensionUnderPlaceChart K L q = p → + FunctionField.Chart.placeValuation K L q z ≤ + WithZero.exp (Btop q)) : + (finiteExtensionFiberLift K L z b).1 ∈ + FunctionField.Chart.adeleFilt K L Btop := by + intro q + by_cases hq : finiteExtensionUnderPlaceChart K L q = p + · change FunctionField.Chart.placeValuation K L q + (z * algebraMap (RatFunc K) L + (b.1 (finiteExtensionUnderPlaceChart K L q))) ≤ _ + rw [hq, hbp, map_one, mul_one] + exact hz q hq + · change FunctionField.Chart.placeValuation K L q + (z * algebraMap (RatFunc K) L + (b.1 (finiteExtensionUnderPlaceChart K L q))) ≤ _ + rw [hbAway _ hq, map_zero, mul_zero, Valuation.map_zero] + exact zero_le + +/-- Normalize a one-component base adele and lift a trace preimage without +changing its cotrace. -/ +theorem finiteExtensionFiberLift_normalized_trace + (ω : FunctionField.Chart.WeilDifferential K (RatFunc K)) + (p : FunctionField.Chart.PlaceA K (RatFunc K)) + (a : FunctionField.Chart.AdeleSpace K (RatFunc K)) + (haNonzero : ω.toFun a ≠ 0) + (haAway : ∀ v ≠ p, a.1 v = 0) + (x : RatFunc K) (hx : x = a.1 p) (hx0 : x ≠ 0) + (z : L) (hzTrace : Algebra.trace (RatFunc K) L z = x) : + let b := x⁻¹ • a + (b.1 p = 1) ∧ + (∀ v ≠ p, b.1 v = 0) ∧ + ω.toFun (finiteExtensionFiberTrace K L + (finiteExtensionFiberLift K L z b)) ≠ 0 := by + dsimp only + have hbp : (x⁻¹ • a).1 p = 1 := by + change x⁻¹ * a.1 p = 1 + rw [← hx, inv_mul_cancel₀ hx0] + have hbAway : ∀ v ≠ p, (x⁻¹ • a).1 v = 0 := by + intro v hv + change x⁻¹ * a.1 v = 0 + rw [haAway v hv, mul_zero] + refine ⟨hbp, hbAway, ?_⟩ + rw [finiteExtensionFiberTrace_lift K L z (x⁻¹ • a), hzTrace, + smul_smul, mul_inv_cancel₀ hx0, one_smul] + exact haNonzero + +/-- Step (b1), finite-place branch: any coefficient strictly above the finite +different is detected by the cotrace functional on a fiber-constant adele in +that divisor filtration. -/ +theorem finiteExtensionFiberCotrace_detects_finite_excess + (ω : FunctionField.Chart.WeilDifferential K (RatFunc K)) + (hω : FunctionField.Chart.WeilDifferential.IsNonzero ω) + (hdiv : FunctionField.Chart.WeilDifferential.divOmega ω hω = + ratFuncCanonicalInfinityDivisor K) + (Btop : FunctionField.Chart.DivisorA K L) + (q₀ : HeightOneSpectrum (RatFuncFiniteIntegralClosure K L)) + (hbad : + (finiteExtensionDivisorEquivChart K L + (finiteExtensionCanonicalDifferentDivisor K L + (finiteExtensionFiniteDifferentIdeal_ne_bot K L))) + (finiteExtensionPlaceEquivChart K L (.inl q₀)) < + Btop (finiteExtensionPlaceEquivChart K L (.inl q₀))) : + ∃ β : finiteExtensionFiberConstantAdeleSubmodule K L, + β.1 ∈ FunctionField.Chart.adeleFilt K L Btop ∧ + ω.toFun (finiteExtensionFiberTrace K L β) ≠ 0 := by + classical + let e := HeightOneSpectrum.equivOfRingEquiv + (ratFuncFiniteBaseRingEquivChart K) + let p₀ : HeightOneSpectrum K[X] := q₀.under K[X] + let pChart : HeightOneSpectrum + (FunctionField.ringOfIntegers K (RatFunc K)) := e p₀ + let p : FunctionField.Chart.PlaceA K (RatFunc K) := .inl pChart + obtain ⟨a, haFilt, hωa, haAway, haVal⟩ := + ratFuncCanonicalWeil_exists_singlePlace_witness K ω hω hdiv p + let x : RatFunc K := a.1 p + have hpCoeff : ratFuncCanonicalInfinityDivisor K p = 0 := by + rw [ratFuncCanonicalInfinityDivisor, Finsupp.single_eq_of_ne] + change Sum.inl pChart ≠ Sum.inr _ + exact Sum.inl_ne_inr + have hx0 : x ≠ 0 := by + apply (Valuation.ne_zero_iff + (FunctionField.Chart.placeValuation K (RatFunc K) p)).mp + rw [show FunctionField.Chart.placeValuation K (RatFunc K) p x = + WithZero.exp (1 : ℤ) by + simpa [x, hpCoeff] using haVal] + exact WithZero.exp_ne_zero + have hxValChart : pChart.valuation (RatFunc K) x = + WithZero.exp (1 : ℤ) := by + simpa [x, p, FunctionField.Chart.placeValuation, + hpCoeff] using haVal + have hbaseEq : p₀.valuation (RatFunc K) = + pChart.valuation (RatFunc K) := + heightOneValuation_eq_of_ringEquiv + (ratFuncFiniteBaseRingEquivChart K) + (ratFuncFiniteBaseRingEquivChart_algebraMap K) + p₀ pChart rfl + have hxVal : p₀.valuation (RatFunc K) x = + WithZero.exp (1 : ℤ) := by + rw [hbaseEq] + exact hxValChart + let n : HeightOneSpectrum (RatFuncFiniteIntegralClosure K L) → ℤ := + fun q => -Btop (finiteExtensionPlaceEquivChart K L (.inl q)) + have hbad' : n q₀ < + -(multiplicity q₀.asIdeal + (differentIdeal K[X] (RatFuncFiniteIntegralClosure K L)) : ℤ) := by + have hcoeff : + (finiteExtensionDivisorEquivChart K L + (finiteExtensionCanonicalDifferentDivisor K L + (finiteExtensionFiniteDifferentIdeal_ne_bot K L))) + (finiteExtensionPlaceEquivChart K L (.inl q₀)) = + (multiplicity q₀.asIdeal + (differentIdeal K[X] + (RatFuncFiniteIntegralClosure K L)) : ℤ) := by + simp [finiteExtensionDivisorEquivChart, Finsupp.domCongr_apply, + finiteExtensionCanonicalDifferentDivisor_inl] + rw [hcoeff] at hbad + dsimp only [n] + omega + obtain ⟨z, hz0, hzTrace, hzCount⟩ := + exists_trace_eq_of_count_threshold_lt_neg_different + (A := K[X]) (K₀ := RatFunc K) + (B := RatFuncFiniteIntegralClosure K L) (L := L) + p₀ n q₀ rfl hbad' x hx0 hxVal + let b : FunctionField.Chart.AdeleSpace K (RatFunc K) := x⁻¹ • a + have hnorm := finiteExtensionFiberLift_normalized_trace + K L ω p a hωa haAway x rfl hx0 z hzTrace + have hbp : b.1 p = 1 := by simpa only [b] using hnorm.1 + have hbAway : ∀ v ≠ p, b.1 v = 0 := by + simpa only [b] using hnorm.2.1 + let β := finiteExtensionFiberLift K L z b + have hβFilt : β.1 ∈ FunctionField.Chart.adeleFilt K L Btop := by + apply finiteExtensionFiberLift_mem_adeleFilt_of_supported + K L Btop p b z hbp hbAway + intro q hq + let Q := (finiteExtensionPlaceEquivChart K L).symm q + have hQq : finiteExtensionPlaceEquivChart K L Q = q := + (finiteExtensionPlaceEquivChart K L).apply_symm_apply q + rcases Q with r | P + · have hrUnder : r.under K[X] = p₀ := by + rw [← hQq] at hq + change ratFuncExhaustivePlaceEquivChart K + (.inl (r.under K[X])) = .inl pChart at hq + change Sum.inl (e (r.under K[X])) = Sum.inl (e p₀) at hq + exact e.injective (Sum.inl.inj hq) + have hrCount := hzCount r hrUnder + have hrVal : r.valuation L z ≤ + WithZero.exp + (Btop (finiteExtensionPlaceEquivChart K L (.inl r))) := by + rw [valuation_eq_exp_neg_finitePlaceOrder r z hz0, + WithZero.exp_le_exp] + change -FractionalIdeal.count L r + (FractionalIdeal.spanSingleton + (RatFuncFiniteIntegralClosure K L)⁰ z) ≤ _ + dsimp only [n] at hrCount + omega + rw [← hQq] + simpa [FunctionField.Chart.placeValuation, + finiteExtensionPlaceEquivChart] using hrVal + · rw [← hQq] at hq + change ratFuncExhaustivePlaceEquivChart K + (.inr (ratFuncInfinityPlace K)) = .inl pChart at hq + change Sum.inr _ = Sum.inl pChart at hq + cases hq + refine ⟨β, hβFilt, ?_⟩ + simpa only [β, b] using hnorm.2.2 + +/-- Step (b1), infinity-place branch: after compensating the `-2e` term by +the square of the base infinity uniformizer, any coefficient strictly above +the infinity different is detected by cotrace. -/ +theorem finiteExtensionFiberCotrace_detects_infinity_excess + (ω : FunctionField.Chart.WeilDifferential K (RatFunc K)) + (hω : FunctionField.Chart.WeilDifferential.IsNonzero ω) + (hdiv : FunctionField.Chart.WeilDifferential.divOmega ω hω = + ratFuncCanonicalInfinityDivisor K) + (Btop : FunctionField.Chart.DivisorA K L) + (P₀ : FiniteExtensionInfinityPlace K L) + (hbad : + (finiteExtensionDivisorEquivChart K L + (finiteExtensionCanonicalDifferentDivisor K L + (finiteExtensionFiniteDifferentIdeal_ne_bot K L))) + (finiteExtensionPlaceEquivChart K L (.inr P₀)) < + Btop (finiteExtensionPlaceEquivChart K L (.inr P₀))) : + ∃ β : finiteExtensionFiberConstantAdeleSubmodule K L, + β.1 ∈ FunctionField.Chart.adeleFilt K L Btop ∧ + ω.toFun (finiteExtensionFiberTrace K L β) ≠ 0 := by + classical + let pInf := ratFuncInfinityPlace K + let e := HeightOneSpectrum.equivOfRingEquiv + (ratFuncInfinityBaseRingEquivChart K) + let pChart : HeightOneSpectrum + (FunctionField.Chart.infiniteIntegers K (RatFunc K)) := e pInf + let p : FunctionField.Chart.PlaceA K (RatFunc K) := .inr pChart + have hpBase : p = ratFuncInfinityPlaceChart K := by rfl + have hpCanonical : p = ratFuncInfinityChartPlace K := + hpBase.trans (ratFuncInfinityChartPlace_eq_baseChart K).symm + obtain ⟨a, haFilt, hωa, haAway, haVal⟩ := + ratFuncCanonicalWeil_exists_singlePlace_witness K ω hω hdiv p + have hpCoeff : ratFuncCanonicalInfinityDivisor K p = -2 := by + rw [hpCanonical, ratFuncCanonicalInfinityDivisor, + Finsupp.single_eq_same] + let x : RatFunc K := a.1 p + have hx0 : x ≠ 0 := by + apply (Valuation.ne_zero_iff + (FunctionField.Chart.placeValuation K (RatFunc K) p)).mp + rw [show FunctionField.Chart.placeValuation K (RatFunc K) p x = + WithZero.exp (-1 : ℤ) by + simpa [x, hpCoeff] using haVal] + exact WithZero.exp_ne_zero + have hxValChart : pChart.valuation (RatFunc K) x = + WithZero.exp (-1 : ℤ) := by + simpa [x, p, FunctionField.Chart.placeValuation, + hpCoeff] using haVal + have hbaseEq : pInf.valuation (RatFunc K) = + pChart.valuation (RatFunc K) := + heightOneValuation_eq_of_ringEquiv + (ratFuncInfinityBaseRingEquivChart K) + (ratFuncInfinityBaseRingEquivChart_algebraMap K) + pInf pChart rfl + have hxValInf : pInf.valuation (RatFunc K) x = + WithZero.exp (-1 : ℤ) := by + rw [hbaseEq] + exact hxValChart + let s := ratFuncInfinityUniformizer K + have hs : s ≠ 0 := by + intro h + have hcoe := congrArg Subtype.val h + exact (one_div_ne_zero RatFunc.X_ne_zero) hcoe + let t : RatFunc K := algebraMap (RatFuncInfinityIntegers K) (RatFunc K) s + have ht0 : t ≠ 0 := by + simpa only [t, map_zero] using + (FaithfulSMul.algebraMap_injective + (RatFuncInfinityIntegers K) (RatFunc K)).ne hs + have htVal : pInf.valuation (RatFunc K) t = + WithZero.exp (-1 : ℤ) := by + change pInf.valuation (RatFunc K) + (algebraMap (RatFuncInfinityIntegers K) (RatFunc K) s) = _ + rw [HeightOneSpectrum.valuation_of_algebraMap] + exact pInf.intValuation_singleton hs + (ratFuncInfinityPlace_span_uniformizer K) + let w : RatFunc K := (t ^ 2)⁻¹ * x + have hw0 : w ≠ 0 := + mul_ne_zero (inv_ne_zero (pow_ne_zero 2 ht0)) hx0 + have hwVal : pInf.valuation (RatFunc K) w = + WithZero.exp (1 : ℤ) := by + change pInf.valuation (RatFunc K) ((t ^ 2)⁻¹ * x) = _ + rw [map_mul, map_inv₀, map_pow, htVal, hxValInf] + norm_num [← WithZero.exp_neg, ← WithZero.exp_add] + let q₀ : HeightOneSpectrum (RatFuncInfinityIntegralClosure K L) := + primeOverHeightOne pInf P₀ + have hq₀Under : q₀.under (RatFuncInfinityIntegers K) = pInf := by + apply HeightOneSpectrum.ext + exact (Ideal.over_def P₀.1 pInf.asIdeal).symm + let n : HeightOneSpectrum (RatFuncInfinityIntegralClosure K L) → ℤ := + fun q => + -2 * ((((finiteExtensionInfinityPrimesOverEquivHeightOne K L).symm q).1.ramificationIdx + (RatFuncInfinityIntegers K)) : ℤ) - + Btop (finiteExtensionPlaceEquivChart K L + (.inr ((finiteExtensionInfinityPrimesOverEquivHeightOne K L).symm q))) + have hbad' : n q₀ < + -(multiplicity q₀.asIdeal + (differentIdeal (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L)) : ℤ) := by + have hcoeff : + (finiteExtensionDivisorEquivChart K L + (finiteExtensionCanonicalDifferentDivisor K L + (finiteExtensionFiniteDifferentIdeal_ne_bot K L))) + (finiteExtensionPlaceEquivChart K L (.inr P₀)) = + (multiplicity P₀.1 + (differentIdeal (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L)) : ℤ) - + 2 * (P₀.1.ramificationIdx + (RatFuncInfinityIntegers K) : ℤ) := by + simp [finiteExtensionDivisorEquivChart, Finsupp.domCongr_apply, + finiteExtensionCanonicalDifferentDivisor_inr] + rw [hcoeff] at hbad + have hsymm : + (finiteExtensionInfinityPrimesOverEquivHeightOne K L).symm q₀ = P₀ := by + exact (finiteExtensionInfinityPrimesOverEquivHeightOne K L).symm_apply_apply P₀ + have hqIdeal : q₀.asIdeal = P₀.1 := rfl + dsimp only [n] + rw [hsymm, hqIdeal] + omega + obtain ⟨z₀, hz₀0, hz₀Trace, hz₀Count⟩ := + exists_trace_eq_of_count_threshold_lt_neg_different + (A := RatFuncInfinityIntegers K) (K₀ := RatFunc K) + (B := RatFuncInfinityIntegralClosure K L) (L := L) + pInf n q₀ hq₀Under hbad' w hw0 hwVal + let tL : L := algebraMap (RatFuncInfinityIntegers K) L s + have htL0 : tL ≠ 0 := by + simpa only [tL, map_zero] using + (FaithfulSMul.algebraMap_injective + (RatFuncInfinityIntegers K) L).ne hs + have htTower : tL = algebraMap (RatFunc K) L t := by + exact (IsScalarTower.algebraMap_apply + (RatFuncInfinityIntegers K) (RatFunc K) L s).symm + let z : L := tL ^ 2 * z₀ + have hz0 : z ≠ 0 := mul_ne_zero (pow_ne_zero 2 htL0) hz₀0 + have hzTrace : Algebra.trace (RatFunc K) L z = x := by + have hscalar : tL ^ 2 * z₀ = (t ^ 2) • z₀ := by + rw [Algebra.smul_def, htTower, map_pow] + change Algebra.trace (RatFunc K) L (tL ^ 2 * z₀) = x + rw [hscalar, map_smul, hz₀Trace] + change t ^ 2 * ((t ^ 2)⁻¹ * x) = x + rw [← mul_assoc, mul_inv_cancel₀ (pow_ne_zero 2 ht0), one_mul] + let b : FunctionField.Chart.AdeleSpace K (RatFunc K) := x⁻¹ • a + have hnorm := finiteExtensionFiberLift_normalized_trace + K L ω p a hωa haAway x rfl hx0 z hzTrace + have hbp : b.1 p = 1 := by simpa only [b] using hnorm.1 + have hbAway : ∀ v ≠ p, b.1 v = 0 := by + simpa only [b] using hnorm.2.1 + let β := finiteExtensionFiberLift K L z b + have hβFilt : β.1 ∈ FunctionField.Chart.adeleFilt K L Btop := by + apply finiteExtensionFiberLift_mem_adeleFilt_of_supported + K L Btop p b z hbp hbAway + intro q hq + let Q := (finiteExtensionPlaceEquivChart K L).symm q + have hQq : finiteExtensionPlaceEquivChart K L Q = q := + (finiteExtensionPlaceEquivChart K L).apply_symm_apply q + rcases Q with r | P + · rw [← hQq] at hq + change ratFuncExhaustivePlaceEquivChart K + (.inl (r.under K[X])) = p at hq + rw [hpBase] at hq + change Sum.inl _ = Sum.inr _ at hq + cases hq + · let qH : HeightOneSpectrum + (RatFuncInfinityIntegralClosure K L) := + primeOverHeightOne pInf P + have hqHUnder : qH.under (RatFuncInfinityIntegers K) = pInf := by + apply HeightOneSpectrum.ext + exact (Ideal.over_def P.1 pInf.asIdeal).symm + let : qH.asIdeal.LiesOver pInf.asIdeal := ⟨by + have hideal := congrArg HeightOneSpectrum.asIdeal hqHUnder + exact hideal.symm⟩ + have hqCount := hz₀Count qH hqHUnder + have hsymm : + (finiteExtensionInfinityPrimesOverEquivHeightOne K L).symm qH = P := by + exact (finiteExtensionInfinityPrimesOverEquivHeightOne K L).symm_apply_apply P + have hqCount' : + -2 * (P.1.ramificationIdx + (RatFuncInfinityIntegers K) : ℤ) - + Btop (finiteExtensionPlaceEquivChart K L (.inr P)) ≤ + finitePlaceOrder qH z₀ := by + simpa only [n, hsymm, finitePlaceOrder] using hqCount + have htOrder : finitePlaceOrder qH tL = + (qH.asIdeal.ramificationIdx + (RatFuncInfinityIntegers K) : ℤ) := by + simpa only [tL, IsScalarTower.algebraMap_apply + (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) L] using + finitePlaceOrder_algebraMap_uniformizer_eq_ramificationIdx + (R := RatFuncInfinityIntegers K) + (A := RatFuncInfinityIntegralClosure K L) (F := L) + pInf qH s hs (ratFuncInfinityPlace_span_uniformizer K) + have htSquareOrder := + finitePlaceOrder_mul_eq_add qH tL tL htL0 htL0 + rw [← pow_two] at htSquareOrder + have hzOrder := finitePlaceOrder_mul_eq_add qH (tL ^ 2) z₀ + (pow_ne_zero 2 htL0) hz₀0 + have hideal : qH.asIdeal = P.1 := rfl + have horderBound : -finitePlaceOrder qH z ≤ + Btop (finiteExtensionPlaceEquivChart K L (.inr P)) := by + dsimp only [z] + rw [hzOrder, htSquareOrder, htOrder, hideal] + omega + have hval : qH.valuation L z ≤ + WithZero.exp + (Btop (finiteExtensionPlaceEquivChart K L (.inr P))) := by + rw [valuation_eq_exp_neg_finitePlaceOrder qH z hz0, + WithZero.exp_le_exp] + exact horderBound + rw [← hQq] + have hvaluationEq : + qH.valuation L z = + FunctionField.Chart.placeValuation K L + (finiteExtensionPlaceEquivChart K L (.inr P)) z := by + simpa only [finiteExtensionPlaceValuation] using + congrArg (fun v : Valuation L ℤᵐ⁰ => v z) + (finiteExtensionPlaceValuation_eq_chart K L (.inr P)) + rw [← hvaluationEq] + exact hval + refine ⟨β, hβFilt, ?_⟩ + simpa only [β, b] using hnorm.2.2 + +/-- Stichtenoth, Theorem 3.4.6, Step (b1), in the project chart model: every +divisor not bounded by the explicit canonical different is detected by the +base canonical functional after cotrace. -/ +theorem finiteExtensionFiberCotrace_detects_not_le + (ω : FunctionField.Chart.WeilDifferential K (RatFunc K)) + (hω : FunctionField.Chart.WeilDifferential.IsNonzero ω) + (hdiv : FunctionField.Chart.WeilDifferential.divOmega ω hω = + ratFuncCanonicalInfinityDivisor K) + (Btop : FunctionField.Chart.DivisorA K L) + (hB : ¬ Btop ≤ + finiteExtensionDivisorEquivChart K L + (finiteExtensionCanonicalDifferentDivisor K L + (finiteExtensionFiniteDifferentIdeal_ne_bot K L))) : + ∃ β : finiteExtensionFiberConstantAdeleSubmodule K L, + β.1 ∈ FunctionField.Chart.adeleFilt K L Btop ∧ + ω.toFun (finiteExtensionFiberTrace K L β) ≠ 0 := by + classical + have hB' : ∃ q : FunctionField.Chart.PlaceA K L, + (finiteExtensionDivisorEquivChart K L + (finiteExtensionCanonicalDifferentDivisor K L + (finiteExtensionFiniteDifferentIdeal_ne_bot K L))) q < Btop q := by + by_contra hnone + apply hB + intro q + have hnot : ¬ + (finiteExtensionDivisorEquivChart K L + (finiteExtensionCanonicalDifferentDivisor K L + (finiteExtensionFiniteDifferentIdeal_ne_bot K L))) q < Btop q := by + intro hlt + exact hnone ⟨q, hlt⟩ + exact le_of_not_gt hnot + obtain ⟨q, hq⟩ := hB' + let Q := (finiteExtensionPlaceEquivChart K L).symm q + have hQq : finiteExtensionPlaceEquivChart K L Q = q := + (finiteExtensionPlaceEquivChart K L).apply_symm_apply q + rcases Q with r | P + · apply finiteExtensionFiberCotrace_detects_finite_excess + K L ω hω hdiv Btop r + simpa only [hQq] using hq + · apply finiteExtensionFiberCotrace_detects_infinity_excess + K L ω hω hdiv Btop P + simpa only [hQq] using hq + +/-- The trace-different divisor is exactly the maximal vanishing divisor of +the Weil functional obtained by gluing cotrace to zero. This is the direct +local-maximality conclusion of Stichtenoth, Theorem 3.4.6, Step (b1), and does +not assume a Riemann--Hurwitz degree identity. -/ +theorem finiteExtensionCanonicalDifferent_isCanonical_of_cotrace + [FunctionField.IsFullConstantField K L] : + FunctionField.Chart.IsCanonical K L + (finiteExtensionDivisorEquivChart K L + (finiteExtensionCanonicalDifferentDivisor K L + (finiteExtensionFiniteDifferentIdeal_ne_bot K L))) := by + obtain ⟨ωBase, hωBase, hdivBase⟩ := + ratFuncCanonicalInfinityDivisor_isCanonical K + have hmaxBase : + FunctionField.Chart.WeilDifferential.divOmega ωBase hωBase ∈ + FunctionField.Chart.WeilDifferential.vanishingDivisors ωBase ∧ + ∀ D ∈ FunctionField.Chart.WeilDifferential.vanishingDivisors ωBase, + D ≤ FunctionField.Chart.WeilDifferential.divOmega ωBase hωBase := by + simpa only [FunctionField.Chart.WeilDifferential.divOmega] using + (Classical.choose_spec + (FunctionField.Chart.WeilDifferential.exists_max_vanishingDivisor + (k := K) (K := RatFunc K) hωBase)).1 + have hbaseVan : ratFuncCanonicalInfinityDivisor K ∈ + FunctionField.Chart.WeilDifferential.vanishingDivisors ωBase := by + rw [hdivBase] at hmaxBase + exact hmaxBase.1 + let U := finiteExtensionFiberConstantAdeleSubmodule K L + let D := finiteExtensionDivisorEquivChart K L + (finiteExtensionCanonicalDifferentDivisor K L + (finiteExtensionFiniteDifferentIdeal_ne_bot K L)) + let V := FunctionField.Chart.adeleFilt K L D + + FunctionField.Chart.diagonalSubmodule K L + let f := ωBase.toFun.comp (finiteExtensionFiberTrace K L) + have hfVan : ∀ x : ↥(U ⊓ V), f ⟨x, x.property.1⟩ = 0 := by + intro x + exact finiteExtensionFiberCotrace_vanishes_on_intersection + K L ωBase hbaseVan x + have hfNe : f ≠ 0 := + finiteExtensionFiberCotrace_ne_zero K L ωBase hωBase + obtain ⟨g, hgU, hgV, hgNe⟩ := + exists_ne_zero_linearMap_extending_eq_zero_on_inf U V f hfVan hfNe + let ωTop : FunctionField.Chart.WeilDifferential K L := + ⟨g, ⟨D, fun a ha => LinearMap.mem_ker.mp (hgV ha)⟩⟩ + have hωTop : FunctionField.Chart.WeilDifferential.IsNonzero ωTop := hgNe + have hDvan : D ∈ + FunctionField.Chart.WeilDifferential.vanishingDivisors ωTop := by + intro a ha + exact LinearMap.mem_ker.mp (hgV ha) + have hDmax : ∀ B ∈ + FunctionField.Chart.WeilDifferential.vanishingDivisors ωTop, + B ≤ D := by + intro B hBvan + by_contra hBle + obtain ⟨β, hβFilt, hdetect⟩ := + finiteExtensionFiberCotrace_detects_not_le + K L ωBase hωBase hdivBase B hBle + have hβsum : β.1 ∈ FunctionField.Chart.adeleFilt K L B + + FunctionField.Chart.diagonalSubmodule K L := by + rw [Submodule.add_eq_sup] + exact Submodule.mem_sup_left hβFilt + have hgβ0 : g β.1 = 0 := hBvan β.1 hβsum + have hgfβ : g β.1 = f β := by + change (g.comp U.subtype) β = f β + exact LinearMap.congr_fun hgU β + have hfβ : f β ≠ 0 := by + simpa only [f, LinearMap.coe_comp, Function.comp_apply] using hdetect + exact hfβ (hgfβ.symm.trans hgβ0) + have hmaxTop : + FunctionField.Chart.WeilDifferential.divOmega ωTop hωTop ∈ + FunctionField.Chart.WeilDifferential.vanishingDivisors ωTop ∧ + ∀ B ∈ FunctionField.Chart.WeilDifferential.vanishingDivisors ωTop, + B ≤ FunctionField.Chart.WeilDifferential.divOmega ωTop hωTop := by + simpa only [FunctionField.Chart.WeilDifferential.divOmega] using + (Classical.choose_spec + (FunctionField.Chart.WeilDifferential.exists_max_vanishingDivisor + (k := K) (K := L) hωTop)).1 + have heq : FunctionField.Chart.WeilDifferential.divOmega ωTop hωTop = D := + le_antisymm (hDmax _ hmaxTop.1) (hmaxTop.2 D hDvan) + exact ⟨ωTop, hωTop, heq⟩ + +/-- The remaining trace-residue lower bound follows from the direct cotrace +canonicality theorem, with no degree premise. -/ +theorem finiteExtension_genus_le_canonicalDifferent_finrank_of_cotrace + [FunctionField.IsFullConstantField K L] : + FunctionField.Chart.genus K L ≤ + Module.finrank K + (finiteExtensionRiemannSpace K L + (finiteExtensionCanonicalDifferentDivisor K L + (finiteExtensionFiniteDifferentIdeal_ne_bot K L))) := by + have hcanonical := finiteExtensionCanonicalDifferent_isCanonical_of_cotrace K L + have hcharacterization := + (finiteExtensionCanonicalDifferent_isCanonical_iff_degree_finrank K L).mp + hcanonical + exact hcharacterization.2.ge + +/-- Any upper bound for the explicit different degree gives the corresponding +genus bound directly from cotrace canonicality. -/ +theorem finiteExtension_genus_le_budget_of_cotrace + [FunctionField.IsFullConstantField K L] + (budget : ℕ) + (hdegree : finiteExtensionDivisorDegree K L + (finiteExtensionCanonicalDifferentDivisor K L + (finiteExtensionFiniteDifferentIdeal_ne_bot K L)) ≤ + 2 * (budget : ℤ) - 2) : + FunctionField.genus K L ≤ budget := by + exact finiteExtension_genus_le_budget_of_canonicalDifferent_isCanonical + K L budget + (finiteExtensionCanonicalDifferent_isCanonical_of_cotrace K L) + hdegree + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionClosedPlaceAlgEquiv.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionClosedPlaceAlgEquiv.lean new file mode 100644 index 0000000000..bcbf2348c1 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionClosedPlaceAlgEquiv.lean @@ -0,0 +1,87 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.ClosedPlaceEulerRecurrence +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionPlaceAlgEquiv + +/-! +# Closed-place counts across function-field equivalences + +The closed-place extension-count sequence is a weighted sum depending only +on absolute place degrees. Hence the degree-preserving place equivalence +induced by a `K(X)`-algebra equivalence preserves the entire sequence. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +noncomputable section + +open BGS.CorvajaZannier + +variable (K L M : Type*) [Field K] [Fintype K] [DecidableEq K] + [DecidableEq (RatFunc K)] + [Field L] [Field M] + [Algebra (RatFunc K) L] [Algebra (RatFunc K) M] + [FiniteDimensional (RatFunc K) L] + [FiniteDimensional (RatFunc K) M] + [Algebra.IsSeparable (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) M] + +/-- Places of degree at most `r` are preserved by a function-field +equivalence. -/ +noncomputable def finiteExtensionPlaceDegreeLEEquivOfAlgEquiv + (e : L ≃ₐ[RatFunc K] M) (r : ℕ) : + {P : FiniteExtensionPlace K L // + finiteExtensionPlaceDegree K L P ≤ r} ≃ + {P : FiniteExtensionPlace K M // + finiteExtensionPlaceDegree K M P ≤ r} := + Equiv.subtypeEquiv (finiteExtensionPlaceEquivOfAlgEquiv K L M e) (by + intro P + rw [finiteExtensionPlaceEquivOfAlgEquiv_degree K L M e P]) + +/-- Within a bounded family, the places whose degrees divide `r` are also +preserved. -/ +noncomputable def finiteExtensionPlaceDegreeDvdEquivOfAlgEquiv + (e : L ≃ₐ[RatFunc K] M) (r : ℕ) : + {P : {P : FiniteExtensionPlace K L // + finiteExtensionPlaceDegree K L P ≤ r} // + finiteExtensionPlaceDegree K L P.1 ∣ r} ≃ + {P : {P : FiniteExtensionPlace K M // + finiteExtensionPlaceDegree K M P ≤ r} // + finiteExtensionPlaceDegree K M P.1 ∣ r} := + Equiv.subtypeEquiv + (finiteExtensionPlaceDegreeLEEquivOfAlgEquiv K L M e r) (by + intro P + change finiteExtensionPlaceDegree K L P.1 ∣ r ↔ + finiteExtensionPlaceDegree K M + (finiteExtensionPlaceEquivOfAlgEquiv K L M e P.1) ∣ r + rw [finiteExtensionPlaceEquivOfAlgEquiv_degree K L M e P.1]) + +/-- Every closed-place extension count is invariant under an equivalence of +finite `K(X)`-algebras. -/ +theorem finiteExtensionClosedPlaceExtensionCount_eq_of_algEquiv + (e : L ≃ₐ[RatFunc K] M) (r : ℕ) : + finiteExtensionClosedPlaceExtensionCount K L r = + finiteExtensionClosedPlaceExtensionCount K M r := by + let := finiteExtensionPlaceDegreeLEFintype K L r + let := finiteExtensionPlaceDegreeLEFintype K M r + rw [finiteExtensionClosedPlaceExtensionCount_eq_sum_degree_dvd, + finiteExtensionClosedPlaceExtensionCount_eq_sum_degree_dvd] + apply Fintype.sum_equiv + (finiteExtensionPlaceDegreeDvdEquivOfAlgEquiv K L M e r) + intro P + change finiteExtensionPlaceDegree K L P.1.1 = + finiteExtensionPlaceDegree K M + (finiteExtensionPlaceEquivOfAlgEquiv K L M e P.1.1) + exact (finiteExtensionPlaceEquivOfAlgEquiv_degree K L M e P.1.1).symm + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionCotraceLocalTraceImage.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionCotraceLocalTraceImage.lean new file mode 100644 index 0000000000..4797a559b6 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionCotraceLocalTraceImage.lean @@ -0,0 +1,374 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionCanonicalDifferentCotrace +public import LeanPool.MarkoffModP.BGS.HasseWeil.FinitePlaceApproximation + +/-! +# Local trace image for cotrace maximality + +This file formalizes the exact local trace-image argument in Stichtenoth, +Theorem 3.4.6, Step (b1). Weak approximation creates an element just outside +the complementary module at an offending extension place; trace duality then +shows that any prescribed base element of order `-1` is a trace without losing +the required lower bounds at the places over the chosen base place. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +open Set Function UniqueFactorizationMonoid IsDedekindDomain + IsDedekindDomain.HeightOneSpectrum +open scoped nonZeroDivisors + +noncomputable section + +universe u + +variable (A K₀ : Type*) {L : Type u} {B : Type*} +variable [CommRing A] [Field K₀] [CommRing B] [Field L] +variable [Algebra A K₀] [Algebra B L] [Algebra A B] [Algebra K₀ L] [Algebra A L] +variable [IsScalarTower A K₀ L] [IsScalarTower A B L] +variable [IsDedekindDomain A] [IsFractionRing A K₀] +variable [FiniteDimensional K₀ L] [Algebra.IsSeparable K₀ L] +variable [IsIntegralClosure B A L] [IsFractionRing B L] +variable [IsDedekindDomain B] +variable [Module.IsTorsionFree A B] +variable [Algebra.IsIntegral A B] + +/-- Rebuild a height-one prime from an ideal in the finite primes-over set. -/ +def heightOneOfPrimesOverFinset (p : HeightOneSpectrum A) + (Q : Ideal B) (hQ : Q ∈ IsDedekindDomain.primesOverFinset p.asIdeal B) : + HeightOneSpectrum B := by + have hQover : Q ∈ p.asIdeal.primesOver B := + (IsDedekindDomain.mem_primesOverFinset_iff p.ne_bot B).mp hQ + exact ⟨Q, hQover.1, + Ideal.ne_bot_of_mem_primesOver p.ne_bot hQover⟩ + +omit [Algebra.IsIntegral A B] in +@[simp] +theorem heightOneOfPrimesOverFinset_asIdeal (p : HeightOneSpectrum A) + (Q : Ideal B) (hQ : Q ∈ IsDedekindDomain.primesOverFinset p.asIdeal B) : + (heightOneOfPrimesOverFinset (B := B) A p Q hQ).asIdeal = Q := rfl + +/-- Membership in the finite primes-over set is equivalent to contraction to +the selected height-one prime. -/ +theorem mem_primesOverFinset_iff_under_eq (p : HeightOneSpectrum A) + (q : HeightOneSpectrum B) : + q.asIdeal ∈ IsDedekindDomain.primesOverFinset p.asIdeal B ↔ + q.under A = p := by + rw [IsDedekindDomain.mem_primesOverFinset_iff p.ne_bot B] + constructor + · rintro ⟨_, h⟩ + apply HeightOneSpectrum.ext + rw [Ideal.liesOver_iff] at h + exact h.symm + · intro h + refine ⟨q.isPrime, ?_⟩ + rw [Ideal.liesOver_iff] + exact (congrArg HeightOneSpectrum.asIdeal h).symm + +omit [Algebra.IsIntegral A B] in +/-- Every ideal selected by `primesOverFinset` is prime in the factorization +monoid sense required by the weak-approximation theorem. -/ +theorem prime_of_mem_primesOverFinset (p : HeightOneSpectrum A) + (Q : Ideal B) + (hQ : Q ∈ IsDedekindDomain.primesOverFinset p.asIdeal B) : + Prime Q := by + exact Ideal.prime_of_mem_primesOver p.ne_bot + ((IsDedekindDomain.mem_primesOverFinset_iff p.ne_bot B).mp hQ) + +/-- A valuation bound on a nonzero element gives the corresponding lower +bound for its principal fractional-ideal coefficient. -/ +theorem le_count_spanSingleton_of_valuation_le_exp_neg + (q : HeightOneSpectrum B) {x : L} (hx : x ≠ 0) (n : ℤ) + (hval : q.valuation L x ≤ WithZero.exp (-n)) : + n ≤ FractionalIdeal.count L q + (FractionalIdeal.spanSingleton B⁰ x) := by + have hvaluation : q.valuation L x = + WithZero.exp (-FractionalIdeal.count L q + (FractionalIdeal.spanSingleton B⁰ x)) := by + simpa using (FractionalIdeal.valuation_eq_exp_neg_count + (R := B) (K := L) q (Units.mk0 x hx)) + rw [hvaluation] at hval + have := WithZero.exp_le_exp.mp hval + omega + +omit [Algebra A L] [IsScalarTower A B L] [IsIntegralClosure B A L] in +/-- Weak approximation realizes simultaneous lower order bounds over one +base prime and realizes a prescribed negative order exactly at one chosen +prime. -/ +theorem exists_element_with_counts_over_and_exact_at + (p : HeightOneSpectrum A) (n : HeightOneSpectrum B → ℤ) + (q₀ : HeightOneSpectrum B) (hq₀ : q₀.under A = p) + (hn₀ : n q₀ < 0) : + ∃ u : L, u ≠ 0 ∧ + (∀ q : HeightOneSpectrum B, q.under A = p → + n q ≤ FractionalIdeal.count L q + (FractionalIdeal.spanSingleton B⁰ u)) ∧ + FractionalIdeal.count L q₀ + (FractionalIdeal.spanSingleton B⁰ u) = n q₀ ∧ + ∀ q : HeightOneSpectrum B, q.under A ≠ p → + 0 ≤ FractionalIdeal.count L q + (FractionalIdeal.spanSingleton B⁰ u) := by + classical + let selected := IsDedekindDomain.primesOverFinset p.asIdeal B + let qOf : ∀ Q : Ideal B, Q ∈ selected → HeightOneSpectrum B := + fun Q hQ ↦ heightOneOfPrimesOverFinset (B := B) A p Q hQ + let target : Ideal B → L := fun Q ↦ + if Q = q₀.asIdeal then + (Classical.choose (q₀.valuation_exists_uniformizer L)) ^ (n q₀) + else 0 + let precision : Ideal B → ℕ := fun Q ↦ + if hQ : Q ∈ selected then Int.toNat (n (qOf Q hQ)) else 0 + obtain ⟨u, huSelected, huElse⟩ := + exists_fraction_approximating_at_finitePlaces_regular_elsewhere + (R := B) (L := L) selected + (fun Q hQ ↦ prime_of_mem_primesOverFinset (B := B) A p Q hQ) + target precision + have hq₀Selected : q₀.asIdeal ∈ selected := + (mem_primesOverFinset_iff_under_eq (B := B) A p q₀).mpr hq₀ + have hq₀Of : qOf q₀.asIdeal hq₀Selected = q₀ := by + apply HeightOneSpectrum.ext + rfl + have hprecisionq₀ : precision q₀.asIdeal = 0 := by + simp only [precision, hq₀Selected, dite_true, qOf, hq₀Of] + exact Int.toNat_of_nonpos hn₀.le + let π : L := Classical.choose (q₀.valuation_exists_uniformizer L) + have hπ : q₀.valuation L π = WithZero.exp (-1) := + Classical.choose_spec (q₀.valuation_exists_uniformizer L) + have hπne : π ≠ 0 := by + intro hzero + rw [hzero, Valuation.map_zero] at hπ + exact WithZero.exp_ne_zero hπ.symm + have htargetq₀ : target q₀.asIdeal = π ^ (n q₀) := by + simp [target, π] + have huApprox : q₀.valuation L (u - π ^ (n q₀)) ≤ 1 := by + simpa [hprecisionq₀, htargetq₀, WithZero.exp_zero] using + huSelected q₀ hq₀Selected + have htargetVal : q₀.valuation L (π ^ (n q₀)) = + WithZero.exp (-(n q₀)) := by + rw [map_zpow₀, hπ, ← WithZero.exp_zsmul] + congr 1 + simp + have herrorLt : q₀.valuation L (u - π ^ (n q₀)) < + q₀.valuation L (π ^ (n q₀)) := by + rw [htargetVal] + apply lt_of_le_of_lt huApprox + rw [← WithZero.exp_zero, WithZero.exp_lt_exp] + omega + have huVal : q₀.valuation L u = WithZero.exp (-(n q₀)) := by + rw [← htargetVal] + exact Valuation.map_eq_of_sub_lt (q₀.valuation L) herrorLt + have hu0 : u ≠ 0 := by + intro hzero + rw [hzero, Valuation.map_zero] at huVal + exact WithZero.exp_ne_zero huVal.symm + have huCountExact : FractionalIdeal.count L q₀ + (FractionalIdeal.spanSingleton B⁰ u) = n q₀ := by + have hvaluation : q₀.valuation L u = + WithZero.exp (-FractionalIdeal.count L q₀ + (FractionalIdeal.spanSingleton B⁰ u)) := by + simpa using (FractionalIdeal.valuation_eq_exp_neg_count + (R := B) (K := L) q₀ (Units.mk0 u hu0)) + rw [huVal] at hvaluation + exact neg_injective (WithZero.exp_injective hvaluation.symm) + refine ⟨u, hu0, ?_, huCountExact, ?_⟩ + · intro q hq + have hqSelected : q.asIdeal ∈ selected := + (mem_primesOverFinset_iff_under_eq (B := B) A p q).mpr hq + have hqOf : qOf q.asIdeal hqSelected = q := by + apply HeightOneSpectrum.ext + rfl + have hprecision : precision q.asIdeal = Int.toNat (n q) := by + simp only [precision, hqSelected, dite_true, qOf, hqOf] + have htarget : target q.asIdeal = + if q.asIdeal = q₀.asIdeal then π ^ (n q₀) else 0 := by + rfl + by_cases hqq₀ : q = q₀ + · subst q + exact huCountExact.ge + · have hideal : q.asIdeal ≠ q₀.asIdeal := by + intro h + exact hqq₀ (HeightOneSpectrum.ext h) + have hval : q.valuation L u ≤ + WithZero.exp (-(Int.toNat (n q) : ℤ)) := by + have h := huSelected q hqSelected + simpa [hprecision, target, hideal] using h + have hnle : n q ≤ (Int.toNat (n q) : ℤ) := by + by_cases hn : 0 ≤ n q + · simp [Int.toNat_of_nonneg hn] + · rw [Int.toNat_of_nonpos (le_of_not_ge hn)] + exact le_of_not_ge hn + exact hnle.trans + (le_count_spanSingleton_of_valuation_le_exp_neg + (B := B) q hu0 (Int.toNat (n q)) hval) + · intro q hq + have hqNotSelected : q.asIdeal ∉ selected := by + intro hmem + exact hq ((mem_primesOverFinset_iff_under_eq (B := B) A p q).mp hmem) + exact zero_le_count_spanSingleton_of_valuation_le_one q hu0 + (huElse q hqNotSelected) + +/-- If one local order bound is strictly below the complementary-module +threshold, then every element of base order `-1` occurs as a trace while all +the prescribed order bounds over the chosen base prime are retained. + +This is the algebraic core of Stichtenoth, Theorem 3.4.6, Step 1(b). -/ +theorem exists_trace_eq_of_count_threshold_lt_neg_different + (p : HeightOneSpectrum A) (n : HeightOneSpectrum B → ℤ) + (q₀ : HeightOneSpectrum B) (hq₀ : q₀.under A = p) + (hbad : n q₀ < + -(multiplicity q₀.asIdeal (differentIdeal A B) : ℤ)) + (w : K₀) (hw : w ≠ 0) + (hwVal : p.valuation K₀ w = WithZero.exp (1 : ℤ)) : + ∃ z : L, z ≠ 0 ∧ Algebra.trace K₀ L z = w ∧ + ∀ q : HeightOneSpectrum B, q.under A = p → + n q ≤ FractionalIdeal.count L q + (FractionalIdeal.spanSingleton B⁰ z) := by + classical + have hn₀ : n q₀ < 0 := by + have hmult : 0 ≤ + (multiplicity q₀.asIdeal (differentIdeal A B) : ℤ) := by + exact_mod_cast (Nat.zero_le + (multiplicity q₀.asIdeal (differentIdeal A B))) + omega + obtain ⟨u, hu0, huOver, huExact, huAway⟩ := + exists_element_with_counts_over_and_exact_at + (A := A) (B := B) (L := L) p n q₀ hq₀ hn₀ + have huNotDual : u ∉ + FractionalIdeal.dual A K₀ (1 : FractionalIdeal B⁰ L) := by + intro hu + have hcounts := + (mem_dual_one_iff_different_multiplicity_le_count + (A := A) (K₀ := K₀) hu0).mp hu + have hq₀Count := hcounts q₀ + rw [huExact] at hq₀Count + exact (not_lt_of_ge hq₀Count) hbad + rw [FractionalIdeal.mem_dual (A := A) (K := K₀) + (I := (1 : FractionalIdeal B⁰ L)) one_ne_zero] at huNotDual + push Not at huNotDual + obtain ⟨s, hs, husNot⟩ := huNotDual + have hs0 : s ≠ 0 := by + intro hsZero + subst s + simp [Algebra.traceForm_apply] at husNot + let z₀ : L := u * s + have hz₀0 : z₀ ≠ 0 := mul_ne_zero hu0 hs0 + have htraceNot : Algebra.trace K₀ L z₀ ∉ (algebraMap A K₀).range := by + simpa only [Algebra.traceForm_apply, z₀] using husNot + have hsCount : ∀ q : HeightOneSpectrum B, + 0 ≤ FractionalIdeal.count L q + (FractionalIdeal.spanSingleton B⁰ s) := by + have hsCounts := (FractionalIdeal.mem_iff_count_ge + (I := (1 : FractionalIdeal B⁰ L)) one_ne_zero hs0).mp hs + intro q + simpa only [FractionalIdeal.count_one] using hsCounts q + have hz₀Count : ∀ q : HeightOneSpectrum B, + FractionalIdeal.count L q (FractionalIdeal.spanSingleton B⁰ z₀) = + FractionalIdeal.count L q (FractionalIdeal.spanSingleton B⁰ u) + + FractionalIdeal.count L q (FractionalIdeal.spanSingleton B⁰ s) := by + intro q + change FractionalIdeal.count L q + (FractionalIdeal.spanSingleton B⁰ (u * s)) = _ + rw [← FractionalIdeal.spanSingleton_mul_spanSingleton, + FractionalIdeal.count_mul] + · exact FractionalIdeal.spanSingleton_ne_zero_iff.mpr hu0 + · exact FractionalIdeal.spanSingleton_ne_zero_iff.mpr hs0 + have hz₀Away : ∀ q : HeightOneSpectrum B, q.under A ≠ p → + 0 ≤ FractionalIdeal.count L q + (FractionalIdeal.spanSingleton B⁰ z₀) := by + intro q hq + rw [hz₀Count q] + exact add_nonneg (huAway q hq) (hsCount q) + let t : K₀ := Algebra.trace K₀ L z₀ + have ht0 : t ≠ 0 := by + intro ht + apply htraceNot + rw [show Algebra.trace K₀ L z₀ = t from rfl, ht] + exact ⟨0, map_zero (algebraMap A K₀)⟩ + have hpNotIntegral : ¬ p.valuation K₀ t ≤ 1 := by + intro hp + apply htraceNot + apply HeightOneSpectrum.mem_integers_of_valuation_le_one + intro v + by_cases hv : v = p + · simpa [t, hv] using hp + · have hlocal : ∀ q : HeightOneSpectrum B, + q.under A = v → + -(multiplicity q.asIdeal (differentIdeal A B) : ℤ) ≤ + FractionalIdeal.count L q + (FractionalIdeal.spanSingleton B⁰ z₀) := by + intro q hq + have hqAway : q.under A ≠ p := by + rw [hq] + exact hv + have hnonneg := hz₀Away q hqAway + have hmult : 0 ≤ + (multiplicity q.asIdeal (differentIdeal A B) : ℤ) := by + exact_mod_cast (Nat.zero_le + (multiplicity q.asIdeal (differentIdeal A B))) + omega + simpa [t] using + valuation_trace_le_one_of_different_count_bounds_over + (A := A) (K₀ := K₀) (B := B) (L := L) v hz₀0 hlocal + have hpGt : 1 < p.valuation K₀ t := lt_of_not_ge hpNotIntegral + have htVal : p.valuation K₀ t = + WithZero.exp (-FractionalIdeal.count K₀ p + (FractionalIdeal.spanSingleton A⁰ t)) := by + simpa using (FractionalIdeal.valuation_eq_exp_neg_count + (R := A) (K := K₀) p (Units.mk0 t ht0)) + have hwLeTrace : p.valuation K₀ w ≤ p.valuation K₀ t := by + rw [hwVal, htVal, WithZero.exp_le_exp] + rw [htVal, ← WithZero.exp_zero, WithZero.exp_lt_exp] at hpGt + omega + let r : K₀ := w / t + have hr0 : r ≠ 0 := div_ne_zero hw ht0 + have hrIntegral : p.valuation K₀ r ≤ 1 := by + change p.valuation K₀ (w / t) ≤ 1 + rw [(p.valuation K₀).map_div] + exact (div_le_one₀ (show 0 < p.valuation K₀ t by + rw [htVal] + exact WithZero.exp_pos)).mpr hwLeTrace + let z : L := r • z₀ + have hz0 : z ≠ 0 := smul_ne_zero hr0 hz₀0 + have htraceZ : Algebra.trace K₀ L z = w := by + change Algebra.trace K₀ L (r • z₀) = w + rw [map_smul] + change (w / t) * t = w + exact div_mul_cancel₀ w ht0 + refine ⟨z, hz0, htraceZ, ?_⟩ + intro q hq + have hrTopVal : q.valuation L (algebraMap K₀ L r) ≤ 1 := + heightOneValuation_algebraMap_le_one_of_under + q p hq hrIntegral + have hrTop0 : algebraMap K₀ L r ≠ 0 := + by simpa using (algebraMap K₀ L).injective.ne hr0 + have hrCount : 0 ≤ FractionalIdeal.count L q + (FractionalIdeal.spanSingleton B⁰ (algebraMap K₀ L r)) := + zero_le_count_spanSingleton_of_valuation_le_one q hrTop0 hrTopVal + have hzCount : FractionalIdeal.count L q + (FractionalIdeal.spanSingleton B⁰ z) = + FractionalIdeal.count L q + (FractionalIdeal.spanSingleton B⁰ (algebraMap K₀ L r)) + + FractionalIdeal.count L q + (FractionalIdeal.spanSingleton B⁰ z₀) := by + rw [show z = r • z₀ from rfl, Algebra.smul_def, + ← FractionalIdeal.spanSingleton_mul_spanSingleton, + FractionalIdeal.count_mul] + · exact FractionalIdeal.spanSingleton_ne_zero_iff.mpr hrTop0 + · exact FractionalIdeal.spanSingleton_ne_zero_iff.mpr hz₀0 + rw [hzCount, hz₀Count q] + have huq := huOver q hq + have hsq := hsCount q + omega + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionDivisibleErrorFromConstantBase.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionDivisibleErrorFromConstantBase.lean new file mode 100644 index 0000000000..084239ccd4 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionDivisibleErrorFromConstantBase.lean @@ -0,0 +1,167 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.ConstantExtensionClosedPlaceSplittingFormula +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionHasseBoundFromEvenConstantExtensions + +/-! +# Divisible-even errors from one enlarged constant field + +Let `F / K(X)` have exact constant field `K`, and let `C / K` be finite +Galois of degree `r`. Exact constant-extension splitting identifies the +closed-place count of `C F` at level `m` with the count of `F` at level +`r m`. Since `#C = (#K)^r`, a square-root-scale estimate for `C F` along +the levels `2 H n` is therefore exactly such an estimate for `F` along the +fixed divisible-even subsequence `2 (r H) n`. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +noncomputable section + +open Filter Asymptotics + + +variable (K C F : Type*) + [Field K] [Fintype K] [DecidableEq K] [DecidableEq (RatFunc K)] + [Field C] [Fintype C] [Algebra K C] + [FiniteDimensional K C] [IsGalois K C] + [Field F] [Algebra (RatFunc K) F] + [FiniteDimensional (RatFunc K) F] + [Algebra.IsSeparable (RatFunc K) F] + +local instance divisibleErrorBaseConstantAlgebra : Algebra K F := + bridgeBaseConstantAlgebra K F + +local instance divisibleErrorBaseConstantTower : + IsScalarTower K (RatFunc K) F := + IsScalarTower.of_algebraMap_eq' rfl + +/-- Pointwise error transport from the scalar extension `C F` to `F`. +The multiplier `r H`, where `r = [C : K]`, is independent of `n`. -/ +theorem finiteExtensionClosedPlace_divisibleEvenError_bound_of_constantBase + (hExact : algebraicClosure K F = + (⊥ : IntermediateField K F)) + (H : ℕ) (A B : ℝ) + (hbound : ∀ n, 0 < n → + |(exactConstantExtensionClosedPlaceExtensionCount + K C F hExact (2 * H * n) : ℝ) - + (Nat.card C : ℝ) ^ (2 * H * n) - 1| ≤ + A + B * (Nat.card C : ℝ) ^ (H * n)) : + ∀ n, 0 < n → + |(finiteExtensionClosedPlaceExtensionCount K F + (2 * (Module.finrank K C * H) * n) : ℝ) - + (Nat.card K : ℝ) ^ + (2 * (Module.finrank K C * H) * n) - 1| ≤ + A + B * (((Nat.card K : ℝ) ^ + (Module.finrank K C * H)) ^ n) := by + intro n hn + have hcount : + exactConstantExtensionClosedPlaceExtensionCount + K C F hExact (2 * H * n) = + finiteExtensionClosedPlaceExtensionCount K F + (2 * (Module.finrank K C * H) * n) := by + rw [exactConstantExtensionClosedPlaceExtensionCount_eq_classical_decidableEq] + have h := exactConstantExtensionClosedPlaceExtensionCount_eq + K C F hExact (2 * H * n) + convert h using 1 + all_goals congr 1 <;> ring + have hcard : Nat.card C = Nat.card K ^ Module.finrank K C := + Module.natCard_eq_pow_finrank + have hcenter : + (Nat.card C : ℝ) ^ (2 * H * n) = + (Nat.card K : ℝ) ^ + (2 * (Module.finrank K C * H) * n) := by + rw [hcard, Nat.cast_pow] + calc + ((Nat.card K : ℝ) ^ Module.finrank K C) ^ (2 * H * n) = + (Nat.card K : ℝ) ^ + (Module.finrank K C * (2 * H * n)) := by + exact (pow_mul (Nat.card K : ℝ) + (Module.finrank K C) (2 * H * n)).symm + _ = (Nat.card K : ℝ) ^ + (2 * (Module.finrank K C * H) * n) := by + congr 1 + ring + have hscale : + (Nat.card C : ℝ) ^ (H * n) = + ((Nat.card K : ℝ) ^ (Module.finrank K C * H)) ^ n := by + rw [hcard, Nat.cast_pow] + calc + ((Nat.card K : ℝ) ^ Module.finrank K C) ^ (H * n) = + (Nat.card K : ℝ) ^ + (Module.finrank K C * (H * n)) := by + exact (pow_mul (Nat.card K : ℝ) + (Module.finrank K C) (H * n)).symm + _ = (Nat.card K : ℝ) ^ + ((Module.finrank K C * H) * n) := by + congr 1 + ring + _ = ((Nat.card K : ℝ) ^ + (Module.finrank K C * H)) ^ n := by + exact pow_mul (Nat.card K : ℝ) + (Module.finrank K C * H) n + have h := hbound n hn + rw [hcount, hcenter, hscale] at h + exact h + +/-- The preceding pointwise transport immediately supplies the +divisible-even `IsBigO` premise used by the spectral Hasse argument. -/ +theorem finiteExtensionClosedPlace_divisibleEvenError_isBigO_of_constantBase + (hExact : algebraicClosure K F = + (⊥ : IntermediateField K F)) + (H : ℕ) (A B : ℝ) (hA : 0 ≤ A) + (hbound : ∀ n, 0 < n → + |(exactConstantExtensionClosedPlaceExtensionCount + K C F hExact (2 * H * n) : ℝ) - + (Nat.card C : ℝ) ^ (2 * H * n) - 1| ≤ + A + B * (Nat.card C : ℝ) ^ (H * n)) : + (fun n : ℕ ↦ + (finiteExtensionClosedPlaceExtensionCount K F + (2 * (Module.finrank K C * H) * n) : ℂ) - + (Nat.card K : ℂ) ^ + (2 * (Module.finrank K C * H) * n) - 1) =O[atTop] + fun n : ℕ ↦ + ((Nat.card K : ℝ) ^ (Module.finrank K C * H)) ^ n := by + apply divisibleEvenExtensionError_isBigO_of_pointwise_bound + (Nat.card K) (Module.finrank K C * H) + (finiteExtensionClosedPlaceExtensionCount K F) A B + Nat.card_pos hA + exact finiteExtensionClosedPlace_divisibleEvenError_bound_of_constantBase + K C F hExact H A B hbound + +/-- Closed Hasse--Weil over `K` from one fixed enlarged constant field. +The geometric work is isolated in `hbound`; exact splitting and the spectral +argument discharge every remaining count and zeta-function step. -/ +theorem finiteExtensionClosedPlaceHasseBound_of_constantBase_bound + (budget : ℕ) + (hExact : algebraicClosure K F = + (⊥ : IntermediateField K F)) + (hgenus : FunctionField.genus K F ≤ budget) + (H : ℕ) (hH : 0 < H) (A B : ℝ) (hA : 0 ≤ A) + (hbound : ∀ n, 0 < n → + |(exactConstantExtensionClosedPlaceExtensionCount + K C F hExact (2 * H * n) : ℝ) - + (Nat.card C : ℝ) ^ (2 * H * n) - 1| ≤ + A + B * (Nat.card C : ℝ) ^ (H * n)) : + |(finiteExtensionClosedPlaceExtensionCount K F 1 : ℝ) - + Nat.card K - 1| ≤ + (2 * budget + 1 : ℝ) * Real.sqrt (Nat.card K) := by + apply + finiteExtensionClosedPlaceHasseBound_of_exactConstants_and_divisibleEvenError + K F budget (Module.finrank K C * H) hExact hgenus + (Nat.mul_pos Module.finrank_pos hH) + exact + finiteExtensionClosedPlace_divisibleEvenError_isBigO_of_constantBase + K C F hExact H A B hA hbound + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionDivisorClassRecurrence.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionDivisorClassRecurrence.lean new file mode 100644 index 0000000000..4f902c3735 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionDivisorClassRecurrence.lean @@ -0,0 +1,561 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionDivisorDegreeIndex +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionEffectiveDivisorSplit +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionRiemannSpaceProjectivization + +/-! +# Divisor classes and the indexed eventual recurrence + +This file builds the exhaustive divisor-class quotient and partitions the +effective divisors of a fixed degree into its class fibers. Under exact +constants, each fiber is the projectivization of the corresponding Riemann +space. + +The final recurrence is conditional on one explicit geometric input: +the uniform eventual Riemann formula for *arbitrary* exhaustive divisors, +not merely divisors on one effective ray. This is the remaining theorem +needed to turn the existing one-ray stabilization results into the global +divisor-count recurrence. In particular, no finiteness of a projective +divisor class group is assumed: it follows, in every sufficiently large +degree, from the uniform formula and the already proved finiteness of the +effective divisors of that degree. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +open BGS.CorvajaZannier +open scoped Polynomial + +noncomputable section + +variable (K : Type*) [Field K] [Fintype K] [DecidableEq K] + [DecidableEq (RatFunc K)] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +local instance divisorClassConstantAlgebra : Algebra K L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K (RatFunc K))) + +local instance divisorClassConstantTower : + IsScalarTower K (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + +/-- The additive subgroup of exhaustive principal divisors. -/ +def finiteExtensionPrincipalDivisorSubgroup : + AddSubgroup (FiniteExtensionDivisor K L) where + carrier := {D | ∃ x : L, x ≠ 0 ∧ finiteExtensionPrincipalDivisor K L x = D} + zero_mem' := ⟨1, one_ne_zero, finiteExtensionPrincipalDivisor_one K L⟩ + add_mem' := by + rintro D E ⟨x, hx, rfl⟩ ⟨y, hy, rfl⟩ + exact ⟨x * y, mul_ne_zero hx hy, + finiteExtensionPrincipalDivisor_mul K L x y hx hy⟩ + neg_mem' := by + rintro D ⟨x, hx, rfl⟩ + exact ⟨x⁻¹, inv_ne_zero hx, + finiteExtensionPrincipalDivisor_inv K L x hx⟩ + +/-- The exhaustive divisor class group. -/ +abbrev FiniteExtensionDivisorClass := + FiniteExtensionDivisor K L ⧸ finiteExtensionPrincipalDivisorSubgroup K L + +/-- The quotient map from exhaustive divisors to divisor classes. -/ +def finiteExtensionDivisorClassMap : + FiniteExtensionDivisor K L →+ FiniteExtensionDivisorClass K L := + QuotientAddGroup.mk' (finiteExtensionPrincipalDivisorSubgroup K L) + +omit [Fintype K] in +omit [DecidableEq K] in +@[simp] +theorem finiteExtensionDivisorClassMap_principal + (x : L) (hx : x ≠ 0) : + finiteExtensionDivisorClassMap K L + (finiteExtensionPrincipalDivisor K L x) = 0 := by + change + ((finiteExtensionPrincipalDivisor K L x : FiniteExtensionDivisor K L) : + FiniteExtensionDivisor K L ⧸ finiteExtensionPrincipalDivisorSubgroup K L) = 0 + exact QuotientAddGroup.eq_zero_iff _ |>.2 ⟨x, hx, rfl⟩ + +omit [Fintype K] in +private theorem finiteExtensionPrincipalDivisorSubgroup_le_degreeKernel : + finiteExtensionPrincipalDivisorSubgroup K L ≤ + (finiteExtensionDivisorDegreeHom K L).ker := by + rintro D ⟨x, hx, rfl⟩ + exact finiteExtensionDivisorDegree_principal K L x hx + +/-- Divisor degree descends to divisor classes because principal divisors +have degree zero. -/ +def finiteExtensionDivisorClassDegree : + FiniteExtensionDivisorClass K L →+ ℤ := + QuotientAddGroup.lift (finiteExtensionPrincipalDivisorSubgroup K L) + (finiteExtensionDivisorDegreeHom K L) + (by exact finiteExtensionPrincipalDivisorSubgroup_le_degreeKernel K L) + +omit [Fintype K] in +@[simp] +theorem finiteExtensionDivisorClassDegree_mk + (D : FiniteExtensionDivisor K L) : + finiteExtensionDivisorClassDegree K L + (finiteExtensionDivisorClassMap K L D) = + finiteExtensionDivisorDegree K L D := + by + classical + rfl + +/-- Divisor classes of a prescribed integer degree. -/ +abbrev FiniteExtensionDivisorClassOfDegree (n : ℤ) := + {c : FiniteExtensionDivisorClass K L // + finiteExtensionDivisorClassDegree K L c = n} + +/-- A chosen divisor representative of a class. -/ +def finiteExtensionDivisorClassRepresentative + (c : FiniteExtensionDivisorClass K L) : FiniteExtensionDivisor K L := + Quotient.out c + +omit [Fintype K] in +omit [DecidableEq K] in +@[simp] +theorem finiteExtensionDivisorClassMap_representative + (c : FiniteExtensionDivisorClass K L) : + finiteExtensionDivisorClassMap K L + (finiteExtensionDivisorClassRepresentative K L c) = c := + Quotient.out_eq c + +omit [Fintype K] in +theorem finiteExtensionDivisorClassRepresentative_degree + {n : ℤ} (c : FiniteExtensionDivisorClassOfDegree K L n) : + finiteExtensionDivisorDegree K L + (finiteExtensionDivisorClassRepresentative K L c.1) = n := by + classical + calc + finiteExtensionDivisorDegree K L + (finiteExtensionDivisorClassRepresentative K L c.1) = + finiteExtensionDivisorClassDegree K L + (finiteExtensionDivisorClassMap K L + (finiteExtensionDivisorClassRepresentative K L c.1)) := by + rw [finiteExtensionDivisorClassDegree_mk] + _ = finiteExtensionDivisorClassDegree K L c.1 := by + rw [finiteExtensionDivisorClassMap_representative] + _ = n := c.2 + +/-- Translation by a divisor of degree `d` identifies the degree-`n` and +degree-`n+d` class fibers. -/ +def finiteExtensionDivisorClassOfDegreeTranslateEquiv + (H : FiniteExtensionDivisor K L) (n d : ℤ) + (hH : finiteExtensionDivisorDegree K L H = d) : + FiniteExtensionDivisorClassOfDegree K L n ≃ + FiniteExtensionDivisorClassOfDegree K L (n + d) where + toFun c := ⟨c.1 + finiteExtensionDivisorClassMap K L H, by + rw [map_add, c.2, finiteExtensionDivisorClassDegree_mk, hH]⟩ + invFun c := ⟨c.1 - finiteExtensionDivisorClassMap K L H, by + rw [map_sub, c.2, finiteExtensionDivisorClassDegree_mk, hH] + omega⟩ + left_inv c := by + apply Subtype.ext + simp + right_inv c := by + apply Subtype.ext + simp + +/-- The divisor class of an effective divisor of natural degree `n`. -/ +def finiteExtensionEffectiveDivisorClassOfDegree (n : ℕ) + (D : {D : FiniteExtensionEffectiveDivisor K L // + finiteExtensionEffectiveDivisorDegree K L D = n}) : + FiniteExtensionDivisorClassOfDegree K L (n : ℤ) := by + refine ⟨finiteExtensionDivisorClassMap K L + (finiteExtensionEffectiveDivisorToDivisor K L D.1), ?_⟩ + rw [finiteExtensionDivisorClassDegree_mk] + rw [← finiteExtensionEffectiveDivisorDegree_cast K L D.1, D.2] + +/-- The fixed-degree effective divisors lying in one divisor class. -/ +abbrev FiniteExtensionEffectiveDivisorClassFiber (n : ℕ) + (c : FiniteExtensionDivisorClassOfDegree K L (n : ℤ)) := + {D : {D : FiniteExtensionEffectiveDivisor K L // + finiteExtensionEffectiveDivisorDegree K L D = n} // + finiteExtensionEffectiveDivisorClassOfDegree K L n D = c} + +omit [Fintype K] [DecidableEq K] in +private theorem finiteExtensionEffectiveDivisorToDivisor_of_symm + (D : {D : FiniteExtensionDivisor K L // ∀ P, 0 ≤ D P}) : + finiteExtensionEffectiveDivisorToDivisor K L + ((finiteExtensionEffectiveDivisorEquivEffectiveIntegralDivisor K L).symm D) = + D.1 := by + classical + exact congrArg Subtype.val + ((finiteExtensionEffectiveDivisorEquivEffectiveIntegralDivisor K L).apply_symm_apply D) + +/-- A fixed-degree class fiber is exactly the effective divisors in the +principal class of its chosen representative. -/ +def finiteExtensionEffectiveDivisorClassFiberEquiv + (n : ℕ) (c : FiniteExtensionDivisorClassOfDegree K L (n : ℤ)) : + FiniteExtensionEffectiveDivisorClassFiber K L n c ≃ + EffectiveDivisorInPrincipalClass K L + (finiteExtensionDivisorClassRepresentative K L c.1) where + toFun E := by + let D := finiteExtensionEffectiveDivisorToDivisor K L E.1.1 + let R := finiteExtensionDivisorClassRepresentative K L c.1 + have hclass : finiteExtensionDivisorClassMap K L D = + finiteExtensionDivisorClassMap K L R := by + calc + finiteExtensionDivisorClassMap K L D = c.1 := by + exact congrArg Subtype.val E.2 + _ = finiteExtensionDivisorClassMap K L R := + (finiteExtensionDivisorClassMap_representative K L c.1).symm + refine ⟨D, finiteExtensionEffectiveDivisorToDivisor_effective K L E.1.1, ?_⟩ + obtain ⟨x, hx, hdiv⟩ := + (QuotientAddGroup.eq_iff_sub_mem.mp hclass : + D - R ∈ finiteExtensionPrincipalDivisorSubgroup K L) + refine ⟨x, hx, ?_⟩ + rw [hdiv] + exact (sub_add_cancel D R).symm + invFun E := by + let D : FiniteExtensionEffectiveDivisor K L := + (finiteExtensionEffectiveDivisorEquivEffectiveIntegralDivisor K L).symm + ⟨E.1, E.2.1⟩ + have hDcast : finiteExtensionEffectiveDivisorToDivisor K L D = E.1 := + congrArg Subtype.val + ((finiteExtensionEffectiveDivisorEquivEffectiveIntegralDivisor K L).apply_symm_apply + ⟨E.1, E.2.1⟩) + have hdegreeInt : finiteExtensionDivisorDegree K L E.1 = (n : ℤ) := by + obtain ⟨x, hx, hE⟩ := E.2.2 + rw [hE, finiteExtensionDivisorDegree_add, + finiteExtensionDivisorDegree_principal K L x hx, + finiteExtensionDivisorClassRepresentative_degree K L c] + simp + have hdegreeNat : finiteExtensionEffectiveDivisorDegree K L D = n := by + have hcast := finiteExtensionEffectiveDivisorDegree_cast K L D + rw [hDcast, hdegreeInt] at hcast + exact_mod_cast hcast + refine ⟨⟨D, hdegreeNat⟩, ?_⟩ + apply Subtype.ext + change finiteExtensionDivisorClassMap K L + (finiteExtensionEffectiveDivisorToDivisor K L D) = c.1 + rw [hDcast] + obtain ⟨x, hx, hE⟩ := E.2.2 + rw [hE, map_add, finiteExtensionDivisorClassMap_principal K L x hx, + zero_add, finiteExtensionDivisorClassMap_representative] + left_inv E := by + apply Subtype.ext + apply Subtype.ext + change + (finiteExtensionEffectiveDivisorEquivEffectiveIntegralDivisor K L).symm + ((finiteExtensionEffectiveDivisorEquivEffectiveIntegralDivisor K L) E.1.1) = E.1.1 + exact (finiteExtensionEffectiveDivisorEquivEffectiveIntegralDivisor K L).symm_apply_apply E.1.1 + right_inv E := by + apply Subtype.ext + exact finiteExtensionEffectiveDivisorToDivisor_of_symm K L ⟨E.1, E.2.1⟩ + +/-- Uniform eventual Riemann formula for arbitrary exhaustive divisors. +This is the single geometric input not supplied by the current one-ray +stabilization files. -/ +def HasFiniteExtensionUniformEventualRiemannFormula + (genus threshold : ℕ) : Prop := + genus ≤ threshold ∧ + ∀ (D : FiniteExtensionDivisor K L) (n : ℕ), threshold ≤ n → + finiteExtensionDivisorDegree K L D = (n : ℤ) → + Module.Finite K (finiteExtensionRiemannSpace K L D) ∧ + Module.finrank K (finiteExtensionRiemannSpace K L D) = + n + 1 - genus + +/-- The uniform eventual formula makes every sufficiently large divisor +class effective. -/ +theorem finiteExtensionEffectiveDivisorClassOfDegree_surjective_of_uniformRiemann + (genus threshold n : ℕ) + (hRiemann : HasFiniteExtensionUniformEventualRiemannFormula + K L genus threshold) + (hn : threshold ≤ n) : + Function.Surjective + (finiteExtensionEffectiveDivisorClassOfDegree K L n) := by + intro c + let R := finiteExtensionDivisorClassRepresentative K L c.1 + have hRdegree : finiteExtensionDivisorDegree K L R = (n : ℤ) := + finiteExtensionDivisorClassRepresentative_degree K L c + have hdata := hRiemann.2 R n hn hRdegree + let : Module.Finite K (finiteExtensionRiemannSpace K L R) := hdata.1 + have hpositive : + 0 < Module.finrank K (finiteExtensionRiemannSpace K L R) := by + rw [hdata.2] + have hg := hRiemann.1 + omega + let : Nontrivial (finiteExtensionRiemannSpace K L R) := + Module.finrank_pos_iff.mp hpositive + obtain ⟨x, hx⟩ := exists_ne (0 : finiteExtensionRiemannSpace K L R) + let E : EffectiveDivisorInPrincipalClass K L R := + effectiveDivisorInPrincipalClassOfNonzeroSection K L R ⟨x, hx⟩ + let F := (finiteExtensionEffectiveDivisorClassFiberEquiv K L n c).symm E + exact ⟨F.1, F.2⟩ + +/-- Hence the set of divisor classes of every sufficiently large admissible +degree is finite. -/ +theorem finiteExtensionDivisorClassOfDegree_finite_of_uniformRiemann + (genus threshold n : ℕ) + (hRiemann : HasFiniteExtensionUniformEventualRiemannFormula + K L genus threshold) + (hn : threshold ≤ n) : + Finite (FiniteExtensionDivisorClassOfDegree K L (n : ℤ)) := by + exact Finite.of_surjective + (finiteExtensionEffectiveDivisorClassOfDegree K L n) + (finiteExtensionEffectiveDivisorClassOfDegree_surjective_of_uniformRiemann + K L genus threshold n hRiemann hn) + +/-- Under exact constants, every sufficiently large fixed-degree class fiber +is finite. -/ +theorem finiteExtensionEffectiveDivisorClassFiber_finite_of_uniformRiemann + (genus threshold n : ℕ) + (hconstants : algebraicClosure K L = ⊥) + (hRiemann : HasFiniteExtensionUniformEventualRiemannFormula + K L genus threshold) + (hn : threshold ≤ n) + (c : FiniteExtensionDivisorClassOfDegree K L (n : ℤ)) : + Finite (FiniteExtensionEffectiveDivisorClassFiber K L n c) := by + let R := finiteExtensionDivisorClassRepresentative K L c.1 + have hRdegree : finiteExtensionDivisorDegree K L R = (n : ℤ) := + finiteExtensionDivisorClassRepresentative_degree K L c + have hdata := hRiemann.2 R n hn hRdegree + let : Module.Finite K (finiteExtensionRiemannSpace K L R) := hdata.1 + let : Finite (finiteExtensionRiemannSpace K L R) := + Module.finite_of_finite K + exact Finite.of_equiv + (Projectivization K (finiteExtensionRiemannSpace K L R)) + ((projectiveRiemannSectionEquivEffectiveDivisorInPrincipalClass + K L R hconstants).trans + (finiteExtensionEffectiveDivisorClassFiberEquiv K L n c).symm) + +/-- Every large degree-`n` class fiber has the same geometric-sum +cardinality. -/ +theorem finiteExtensionEffectiveDivisorClassFiber_card_eq_geomSum_of_uniformRiemann + (genus threshold n : ℕ) + (hconstants : algebraicClosure K L = ⊥) + (hRiemann : HasFiniteExtensionUniformEventualRiemannFormula + K L genus threshold) + (hn : threshold ≤ n) + (c : FiniteExtensionDivisorClassOfDegree K L (n : ℤ)) : + Nat.card (FiniteExtensionEffectiveDivisorClassFiber K L n c) = + ∑ i ∈ Finset.range (n + 1 - genus), Nat.card K ^ i := by + let R := finiteExtensionDivisorClassRepresentative K L c.1 + have hRdegree : finiteExtensionDivisorDegree K L R = (n : ℤ) := + finiteExtensionDivisorClassRepresentative_degree K L c + have hdata := hRiemann.2 R n hn hRdegree + rw [Nat.card_congr (finiteExtensionEffectiveDivisorClassFiberEquiv K L n c)] + rw [effectiveDivisorInPrincipalClass_card_eq_geomSum K L R hconstants] + rw [hdata.2] + +/-- The global effective-divisor coefficient is the number of degree-`n` +classes times the common projective Riemann-space count. -/ +theorem finiteExtensionEffectiveDivisorCount_eq_classCount_mul_geomSum_of_uniformRiemann + (genus threshold n : ℕ) + (hconstants : algebraicClosure K L = ⊥) + (hRiemann : HasFiniteExtensionUniformEventualRiemannFormula + K L genus threshold) + (hn : threshold ≤ n) : + finiteExtensionEffectiveDivisorCount K L n = + Nat.card (FiniteExtensionDivisorClassOfDegree K L (n : ℤ)) * + ∑ i ∈ Finset.range (n + 1 - genus), Nat.card K ^ i := by + let : Finite (FiniteExtensionDivisorClassOfDegree K L (n : ℤ)) := + finiteExtensionDivisorClassOfDegree_finite_of_uniformRiemann + K L genus threshold n hRiemann hn + let : Fintype (FiniteExtensionDivisorClassOfDegree K L (n : ℤ)) := + Fintype.ofFinite _ + let (c : FiniteExtensionDivisorClassOfDegree K L (n : ℤ)) : + Finite (FiniteExtensionEffectiveDivisorClassFiber K L n c) := + finiteExtensionEffectiveDivisorClassFiber_finite_of_uniformRiemann + K L genus threshold n hconstants hRiemann hn c + let f := finiteExtensionEffectiveDivisorClassOfDegree K L n + calc + finiteExtensionEffectiveDivisorCount K L n = + Nat.card {D : FiniteExtensionEffectiveDivisor K L // + finiteExtensionEffectiveDivisorDegree K L D = n} := by + rw [finiteExtensionEffectiveDivisorCount, Nat.card_eq_fintype_card] + _ = Nat.card (Σ c : FiniteExtensionDivisorClassOfDegree K L (n : ℤ), + FiniteExtensionEffectiveDivisorClassFiber K L n c) := by + exact (Nat.card_congr (Equiv.sigmaFiberEquiv f)).symm + _ = ∑ c : FiniteExtensionDivisorClassOfDegree K L (n : ℤ), + Nat.card (FiniteExtensionEffectiveDivisorClassFiber K L n c) := + Nat.card_sigma + _ = ∑ _c : FiniteExtensionDivisorClassOfDegree K L (n : ℤ), + (∑ i ∈ Finset.range (n + 1 - genus), Nat.card K ^ i) := by + apply Finset.sum_congr rfl + intro c _ + exact finiteExtensionEffectiveDivisorClassFiber_card_eq_geomSum_of_uniformRiemann + K L genus threshold n hconstants hRiemann hn c + _ = Nat.card (FiniteExtensionDivisorClassOfDegree K L (n : ℤ)) * + ∑ i ∈ Finset.range (n + 1 - genus), Nat.card K ^ i := by + rw [Finset.sum_const, nsmul_eq_mul] + simp [Nat.card_eq_fintype_card] + +/-- A canonical signed divisor whose degree is the divisor-degree index. It +need not be effective; this is why translation is carried out in the class +group rather than by adding an effective divisor. -/ +def finiteExtensionDivisorIndexRepresentative : + FiniteExtensionDivisor K L := + Classical.choose (exists_finiteExtensionDivisor_degree_eq_index K L) + +omit [Fintype K] [FiniteDimensional (RatFunc K) L] [Algebra.IsSeparable (RatFunc K) L] in +@[simp] +theorem finiteExtensionDivisorIndexRepresentative_degree : + finiteExtensionDivisorDegree K L + (finiteExtensionDivisorIndexRepresentative K L) = + (finiteExtensionDivisorDegreeIndex K L : ℤ) := + Classical.choose_spec (exists_finiteExtensionDivisor_degree_eq_index K L) + +omit [Fintype K] in +/-- Translation by the signed index representative preserves the number of +classes when the degree is advanced by the index. -/ +theorem finiteExtensionDivisorClassOfDegree_natCard_add_index (n : ℕ) : + Nat.card (FiniteExtensionDivisorClassOfDegree K L (n : ℤ)) = + Nat.card (FiniteExtensionDivisorClassOfDegree K L + ((n + finiteExtensionDivisorDegreeIndex K L : ℕ) : ℤ)) := by + classical + let e := finiteExtensionDivisorClassOfDegreeTranslateEquiv K L + (finiteExtensionDivisorIndexRepresentative K L) + (n : ℤ) (finiteExtensionDivisorDegreeIndex K L : ℤ) + (finiteExtensionDivisorIndexRepresentative_degree K L) + have h := Nat.card_congr e + convert h using 1 + norm_num + +private theorem geomSum_add (q a b : ℕ) : + (∑ i ∈ Finset.range (a + b), q ^ i) = + (∑ i ∈ Finset.range a, q ^ i) + + q ^ a * ∑ i ∈ Finset.range b, q ^ i := by + rw [Finset.sum_range_add, Finset.mul_sum] + apply congrArg₂ (· + ·) rfl + apply Finset.sum_congr rfl + intro i _ + rw [pow_add] + +/-- The finite geometric sums satisfy the indexed curve-zeta recurrence. -/ +theorem geomSum_indexed_recurrence (q ell d : ℕ) : + (∑ i ∈ Finset.range (ell + 2 * d), q ^ i) + + q ^ d * (∑ i ∈ Finset.range ell, q ^ i) = + (q ^ d + 1) * ∑ i ∈ Finset.range (ell + d), q ^ i := by + rw [show ell + 2 * d = (ell + d) + d by omega] + rw [geomSum_add q (ell + d) d, geomSum_add q ell d, pow_add] + ring + +private theorem mul_geomSum_indexed_recurrence (h q ell d : ℕ) : + h * (∑ i ∈ Finset.range (ell + 2 * d), q ^ i) + + q ^ d * (h * (∑ i ∈ Finset.range ell, q ^ i)) = + (q ^ d + 1) * + (h * ∑ i ∈ Finset.range (ell + d), q ^ i) := by + calc + h * (∑ i ∈ Finset.range (ell + 2 * d), q ^ i) + + q ^ d * (h * (∑ i ∈ Finset.range ell, q ^ i)) = + h * ((∑ i ∈ Finset.range (ell + 2 * d), q ^ i) + + q ^ d * (∑ i ∈ Finset.range ell, q ^ i)) := by ring + _ = h * ((q ^ d + 1) * + ∑ i ∈ Finset.range (ell + d), q ^ i) := by + rw [geomSum_indexed_recurrence] + _ = (q ^ d + 1) * + (h * ∑ i ∈ Finset.range (ell + d), q ^ i) := by ring + +/-- The actual eventual indexed recurrence for exhaustive effective-divisor +counts. The only unproved input is the explicitly stated uniform eventual +Riemann formula. -/ +theorem finiteExtensionEffectiveDivisorCount_indexed_eventual_recurrence + (genus threshold n : ℕ) + (hconstants : algebraicClosure K L = ⊥) + (hRiemann : HasFiniteExtensionUniformEventualRiemannFormula + K L genus threshold) + (hn : threshold ≤ n) : + finiteExtensionEffectiveDivisorCount K L + (n + 2 * finiteExtensionDivisorDegreeIndex K L) + + Nat.card K ^ finiteExtensionDivisorDegreeIndex K L * + finiteExtensionEffectiveDivisorCount K L n = + (Nat.card K ^ finiteExtensionDivisorDegreeIndex K L + 1) * + finiteExtensionEffectiveDivisorCount K L + (n + finiteExtensionDivisorDegreeIndex K L) := by + let d := finiteExtensionDivisorDegreeIndex K L + let q := Nat.card K + have hn1 : threshold ≤ n + d := by omega + have hn2 : threshold ≤ n + 2 * d := by omega + have hcount0 := + finiteExtensionEffectiveDivisorCount_eq_classCount_mul_geomSum_of_uniformRiemann + K L genus threshold n hconstants hRiemann hn + have hcount1 := + finiteExtensionEffectiveDivisorCount_eq_classCount_mul_geomSum_of_uniformRiemann + K L genus threshold (n + d) hconstants hRiemann hn1 + have hcount2 := + finiteExtensionEffectiveDivisorCount_eq_classCount_mul_geomSum_of_uniformRiemann + K L genus threshold (n + 2 * d) hconstants hRiemann hn2 + have hclass01 : + Nat.card (FiniteExtensionDivisorClassOfDegree K L (n : ℤ)) = + Nat.card (FiniteExtensionDivisorClassOfDegree K L ((n + d : ℕ) : ℤ)) := by + simpa [d] using + (finiteExtensionDivisorClassOfDegree_natCard_add_index K L n) + have hclass12 : + Nat.card (FiniteExtensionDivisorClassOfDegree K L ((n + d : ℕ) : ℤ)) = + Nat.card (FiniteExtensionDivisorClassOfDegree K L + ((n + 2 * d : ℕ) : ℤ)) := by + simpa [d, Nat.add_assoc, two_mul] using + (finiteExtensionDivisorClassOfDegree_natCard_add_index K L (n + d)) + have hgenus : genus ≤ n := hRiemann.1.trans hn + have hlength1 : n + d + 1 - genus = (n + 1 - genus) + d := by omega + have hlength2 : n + 2 * d + 1 - genus = (n + 1 - genus) + 2 * d := by omega + change + finiteExtensionEffectiveDivisorCount K L (n + 2 * d) + + q ^ d * finiteExtensionEffectiveDivisorCount K L n = + (q ^ d + 1) * finiteExtensionEffectiveDivisorCount K L (n + d) + rw [hcount0, hcount1, hcount2] + rw [← hclass12, ← hclass01] + rw [hlength1, hlength2] + exact mul_geomSum_indexed_recurrence + (Nat.card (FiniteExtensionDivisorClassOfDegree K L (n : ℤ))) + q (n + 1 - genus) d + +/-- Subtractive integer form of the indexed recurrence, matching the +coefficient hypothesis used by formal zeta rationality. -/ +theorem finiteExtensionEffectiveDivisorCount_indexed_eventual_recurrence_int + (genus threshold n : ℕ) + (hconstants : algebraicClosure K L = ⊥) + (hRiemann : HasFiniteExtensionUniformEventualRiemannFormula + K L genus threshold) + (hn : threshold ≤ n) : + (finiteExtensionEffectiveDivisorCount K L + (n + 2 * finiteExtensionDivisorDegreeIndex K L) : ℤ) = + ((Nat.card K ^ finiteExtensionDivisorDegreeIndex K L + 1 : ℕ) : ℤ) * + finiteExtensionEffectiveDivisorCount K L + (n + finiteExtensionDivisorDegreeIndex K L) - + (Nat.card K ^ finiteExtensionDivisorDegreeIndex K L : ℕ) * + finiteExtensionEffectiveDivisorCount K L n := by + have h := congrArg (fun m : ℕ ↦ (m : ℤ)) + (finiteExtensionEffectiveDivisorCount_indexed_eventual_recurrence + K L genus threshold n hconstants hRiemann hn) + push_cast at h ⊢ + apply eq_sub_iff_add_eq.mpr + simpa [add_comm, add_left_comm, add_assoc] using h + +/-- Complex form used directly by `FormalZetaRationality`. -/ +theorem finiteExtensionEffectiveDivisorCount_indexed_eventual_recurrence_complex + (genus threshold n : ℕ) + (hconstants : algebraicClosure K L = ⊥) + (hRiemann : HasFiniteExtensionUniformEventualRiemannFormula + K L genus threshold) + (hn : threshold ≤ n) : + (finiteExtensionEffectiveDivisorCount K L + (n + 2 * finiteExtensionDivisorDegreeIndex K L) : ℂ) = + ((Nat.card K : ℂ) ^ finiteExtensionDivisorDegreeIndex K L + 1) * + finiteExtensionEffectiveDivisorCount K L + (n + finiteExtensionDivisorDegreeIndex K L) - + (Nat.card K : ℂ) ^ finiteExtensionDivisorDegreeIndex K L * + finiteExtensionEffectiveDivisorCount K L n := by + have h := congrArg (fun m : ℕ ↦ (m : ℂ)) + (finiteExtensionEffectiveDivisorCount_indexed_eventual_recurrence + K L genus threshold n hconstants hRiemann hn) + push_cast at h ⊢ + apply eq_sub_iff_add_eq.mpr + simpa [add_comm, add_left_comm, add_assoc] using h + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionDivisorDegreeIndex.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionDivisorDegreeIndex.lean new file mode 100644 index 0000000000..829dca1e52 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionDivisorDegreeIndex.lean @@ -0,0 +1,327 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionCanonicalWronskian +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionZeroCounting +public import Mathlib.GroupTheory.Archimedean + +/-! +# The divisor-degree index + +For a finite separable extension of `K(X)`, divisor degree is an additive map +from the exhaustive divisor group to `ℤ`. Its image is a nonzero subgroup of +`ℤ`, hence is generated by one positive natural number. This file defines +that generator and proves its two equivalent universal properties: + +* it generates every divisor degree; and +* it is the greatest common divisor of the degrees of all exhaustive places. + +This is the integer `δ` introduced in Stichtenoth, Lemma 5.1.4 (printed +p. 187). The zeta-function rationality argument initially works with `δ` +arbitrary. The later theorem `δ = 1` is F. K. Schmidt's theorem (Corollary +5.1.11, printed p. 191); Stichtenoth proves it only after rationality and the +constant-extension identity for zeta functions. Consequently no implication +from exact constants to `δ = 1` is asserted here: doing so at this stage would +make the intended zeta proof circular. The exact missing conclusion is +isolated by the degree-one criterion at the end of the file. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +open BGS.CorvajaZannier +open scoped nonZeroDivisors Polynomial + +noncomputable section + +variable (K : Type*) [Field K] [Fintype K] [DecidableEq K] + [DecidableEq (RatFunc K)] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +local instance divisorDegreeIndexInfinityIntegralClosureModuleFinite : + Module.Finite (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.finite (RatFuncInfinityIntegers K) (RatFunc K) L + (RatFuncInfinityIntegralClosure K L) + +local instance divisorDegreeIndexInfinityIntegralClosureIsIntegral : + Algebra.IsIntegral (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.isIntegral_algebra (RatFuncInfinityIntegers K) L + +local instance divisorDegreeIndexInfinityBaseTorsionFreeTop : + Module.IsTorsionFree (RatFuncInfinityIntegers K) L := + Module.IsTorsionFree.trans_faithfulSMul + (RatFuncInfinityIntegers K) (RatFunc K) L + +local instance divisorDegreeIndexInfinityIntegralClosureIsTorsionFree : + Module.IsTorsionFree (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.isTorsionFree (RatFuncInfinityIntegers K) L + +omit [Fintype K] [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] in +private theorem finiteExtensionDivisorDegree_add_index + (D E : FiniteExtensionPlace K L →₀ ℤ) : + finiteExtensionDivisorDegree K L (D + E) = + finiteExtensionDivisorDegree K L D + + finiteExtensionDivisorDegree K L E := by + classical + simpa only [finiteExtensionDivisorDegree] using + (Finsupp.sum_add_index (f := D) (g := E) + (h := fun v e ↦ e * (finiteExtensionPlaceDegree K L v : ℤ)) + (by simp) (by intros; ring)) + +omit [Fintype K] [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] in +private theorem finiteExtensionDivisorDegree_single_index + (P : FiniteExtensionPlace K L) (z : ℤ) : + finiteExtensionDivisorDegree K L (Finsupp.single P z) = + z * (finiteExtensionPlaceDegree K L P : ℤ) := by + classical + simp [finiteExtensionDivisorDegree] + +/-- Divisor degree as an additive homomorphism to `ℤ`. -/ +def finiteExtensionDivisorDegreeHom : + (FiniteExtensionPlace K L →₀ ℤ) →+ ℤ where + toFun := finiteExtensionDivisorDegree K L + map_zero' := by simp [finiteExtensionDivisorDegree] + map_add' := by exact finiteExtensionDivisorDegree_add_index K L + +/-- A cyclic generator of the image of divisor degree in the integers. -/ +noncomputable def finiteExtensionDivisorDegreeGenerator : ℤ := + Classical.choose + (Int.subgroup_cyclic (finiteExtensionDivisorDegreeHom K L).range) + +/-- The positive generator of the image of divisor degree. Equivalently, +this is the gcd of the degrees of all exhaustive places. -/ +def finiteExtensionDivisorDegreeIndex : ℕ := + (finiteExtensionDivisorDegreeGenerator K L).natAbs + +omit [Fintype K] [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] in +private theorem finiteExtensionDivisorDegreeHom_range_eq_zmultiples : + (finiteExtensionDivisorDegreeHom K L).range = + AddSubgroup.zmultiples + (finiteExtensionDivisorDegreeIndex K L : ℤ) := by + let a := finiteExtensionDivisorDegreeGenerator K L + have ha : (finiteExtensionDivisorDegreeHom K L).range = + AddSubgroup.closure {a} := + Classical.choose_spec + (Int.subgroup_cyclic (finiteExtensionDivisorDegreeHom K L).range) + calc + (finiteExtensionDivisorDegreeHom K L).range = + AddSubgroup.closure {a} := ha + _ = AddSubgroup.zmultiples a := + (AddSubgroup.zmultiples_eq_closure a).symm + _ = AddSubgroup.zmultiples + (finiteExtensionDivisorDegreeIndex K L : ℤ) := by + rw [finiteExtensionDivisorDegreeIndex] + exact (Int.zmultiples_natAbs a).symm + +omit [Fintype K] in +private theorem finiteExtensionDivisorDegreeHom_range_ne_bot : + (finiteExtensionDivisorDegreeHom K L).range ≠ ⊥ := by + let P : FiniteExtensionInfinityPlace K L := + Classical.choice (inferInstance : Nonempty (FiniteExtensionInfinityPlace K L)) + let D : FiniteExtensionPlace K L →₀ ℤ := Finsupp.single (.inr P) 1 + have hmem : finiteExtensionDivisorDegree K L D ∈ + (finiteExtensionDivisorDegreeHom K L).range := ⟨D, rfl⟩ + have hdegree : finiteExtensionDivisorDegree K L D = + (finiteExtensionPlaceDegree K L (.inr P) : ℤ) := by + rw [finiteExtensionDivisorDegree_single_index] + simp + intro hrange + rw [hrange, AddSubgroup.mem_bot, hdegree] at hmem + have hzero : finiteExtensionPlaceDegree K L (.inr P) = 0 := by + exact_mod_cast hmem + exact (finiteExtensionPlaceDegree_pos K L (.inr P)).ne' hzero + +omit [Fintype K] in +/-- The divisor-degree index is strictly positive. -/ +theorem finiteExtensionDivisorDegreeIndex_pos : + 0 < finiteExtensionDivisorDegreeIndex K L := by + apply Nat.pos_of_ne_zero + intro hzero + apply finiteExtensionDivisorDegreeHom_range_ne_bot K L + rw [finiteExtensionDivisorDegreeHom_range_eq_zmultiples K L, hzero] + simp + +omit [Fintype K] [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] in +/-- Every divisor degree is an integer multiple of the index. -/ +theorem finiteExtensionDivisorDegreeIndex_dvd_divisorDegree + (D : FiniteExtensionPlace K L →₀ ℤ) : + (finiteExtensionDivisorDegreeIndex K L : ℤ) ∣ + finiteExtensionDivisorDegree K L D := by + rw [← Int.mem_zmultiples_iff, + ← finiteExtensionDivisorDegreeHom_range_eq_zmultiples K L] + exact ⟨D, rfl⟩ + +omit [Fintype K] [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] in +/-- The index itself occurs as the degree of an exhaustive divisor. -/ +theorem exists_finiteExtensionDivisor_degree_eq_index : + ∃ D : FiniteExtensionPlace K L →₀ ℤ, + finiteExtensionDivisorDegree K L D = + (finiteExtensionDivisorDegreeIndex K L : ℤ) := by + have hmem : (finiteExtensionDivisorDegreeIndex K L : ℤ) ∈ + AddSubgroup.zmultiples + (finiteExtensionDivisorDegreeIndex K L : ℤ) := + AddSubgroup.mem_zmultiples _ + rw [← finiteExtensionDivisorDegreeHom_range_eq_zmultiples K L] at hmem + rcases hmem with ⟨D, hD⟩ + exact ⟨D, hD⟩ + +omit [Fintype K] [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] in +/-- The image of divisor degree is exactly the subgroup of multiples of the +index. -/ +theorem finiteExtensionDivisorDegree_mem_range_iff + (n : ℤ) : + n ∈ (finiteExtensionDivisorDegreeHom K L).range ↔ + (finiteExtensionDivisorDegreeIndex K L : ℤ) ∣ n := by + rw [finiteExtensionDivisorDegreeHom_range_eq_zmultiples K L, + Int.mem_zmultiples_iff] + +omit [Fintype K] [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] in +/-- An integer occurs as a divisor degree exactly when it is a multiple of +the index. -/ +theorem exists_finiteExtensionDivisor_degree_eq_iff + (n : ℤ) : + (∃ D : FiniteExtensionPlace K L →₀ ℤ, + finiteExtensionDivisorDegree K L D = n) ↔ + (finiteExtensionDivisorDegreeIndex K L : ℤ) ∣ n := by + rw [← finiteExtensionDivisorDegree_mem_range_iff K L n] + rfl + +omit [Fintype K] [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] in +/-- Natural-valued form of index divisibility, used for zeta coefficients. -/ +theorem finiteExtensionDivisorDegreeIndex_dvd_nat_of_degree_eq + (D : FiniteExtensionPlace K L →₀ ℤ) (n : ℕ) + (hD : finiteExtensionDivisorDegree K L D = (n : ℤ)) : + finiteExtensionDivisorDegreeIndex K L ∣ n := by + have hdiv : (finiteExtensionDivisorDegreeIndex K L : ℤ) ∣ (n : ℤ) := by + rw [← hD] + exact finiteExtensionDivisorDegreeIndex_dvd_divisorDegree K L D + exact_mod_cast hdiv + +omit [Fintype K] [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] in +/-- If the index does not divide `n`, there is no divisor (and hence no +effective divisor) of degree `n`. -/ +theorem not_exists_finiteExtensionDivisor_degree_eq_of_not_dvd + (n : ℕ) (hn : ¬ finiteExtensionDivisorDegreeIndex K L ∣ n) : + ¬ ∃ D : FiniteExtensionPlace K L →₀ ℤ, + finiteExtensionDivisorDegree K L D = (n : ℤ) := by + rintro ⟨D, hD⟩ + exact hn + (finiteExtensionDivisorDegreeIndex_dvd_nat_of_degree_eq K L D n hD) + +omit [Fintype K] [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] in +/-- The index divides the degree of each exhaustive place. -/ +theorem finiteExtensionDivisorDegreeIndex_dvd_placeDegree + (P : FiniteExtensionPlace K L) : + finiteExtensionDivisorDegreeIndex K L ∣ + finiteExtensionPlaceDegree K L P := by + have hdiv := finiteExtensionDivisorDegreeIndex_dvd_divisorDegree K L + (Finsupp.single P 1) + rw [finiteExtensionDivisorDegree_single_index] at hdiv + simp only [one_mul] at hdiv + exact_mod_cast hdiv + +omit [Fintype K] [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] in +private theorem integer_dvd_finiteExtensionDivisorDegree_of_dvd_placeDegree + (d : ℕ) (hd : ∀ P : FiniteExtensionPlace K L, + d ∣ finiteExtensionPlaceDegree K L P) + (D : FiniteExtensionPlace K L →₀ ℤ) : + (d : ℤ) ∣ finiteExtensionDivisorDegree K L D := by + classical + induction D using Finsupp.induction with + | zero => simp [finiteExtensionDivisorDegree] + | single_add P z D hPD hz ih => + rw [finiteExtensionDivisorDegree_add_index, + finiteExtensionDivisorDegree_single_index] + apply dvd_add + · obtain ⟨c, hc⟩ := hd P + refine ⟨z * (c : ℤ), ?_⟩ + rw [hc] + push_cast + ring + · exact ih + +omit [Fintype K] [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] in +/-- Any natural number dividing every place degree also divides the divisor +degree index. Together with `finiteExtensionDivisorDegreeIndex_dvd_placeDegree`, +this is the gcd universal property. -/ +theorem dvd_finiteExtensionDivisorDegreeIndex_of_dvd_placeDegree + (d : ℕ) (hd : ∀ P : FiniteExtensionPlace K L, + d ∣ finiteExtensionPlaceDegree K L P) : + d ∣ finiteExtensionDivisorDegreeIndex K L := by + obtain ⟨D, hD⟩ := exists_finiteExtensionDivisor_degree_eq_index K L + have hdiv : (d : ℤ) ∣ finiteExtensionDivisorDegree K L D := + integer_dvd_finiteExtensionDivisorDegree_of_dvd_placeDegree K L d hd D + rw [hD] at hdiv + exact_mod_cast hdiv + +omit [Fintype K] [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] in +/-- Universal characterization of the divisor-degree index as the gcd of all +exhaustive place degrees. -/ +theorem finiteExtensionDivisorDegreeIndex_isGCD : + (∀ P : FiniteExtensionPlace K L, + finiteExtensionDivisorDegreeIndex K L ∣ + finiteExtensionPlaceDegree K L P) ∧ + ∀ d : ℕ, (∀ P : FiniteExtensionPlace K L, + d ∣ finiteExtensionPlaceDegree K L P) → + d ∣ finiteExtensionDivisorDegreeIndex K L := by + exact ⟨finiteExtensionDivisorDegreeIndex_dvd_placeDegree K L, + dvd_finiteExtensionDivisorDegreeIndex_of_dvd_placeDegree K L⟩ + +omit [Fintype K] [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] in +/-- A positive divisor degree is at least the index. -/ +theorem finiteExtensionDivisorDegreeIndex_le_of_degree_eq_nat + (D : FiniteExtensionPlace K L →₀ ℤ) (n : ℕ) (hn : 0 < n) + (hD : finiteExtensionDivisorDegree K L D = (n : ℤ)) : + finiteExtensionDivisorDegreeIndex K L ≤ n := by + have hdivNat : finiteExtensionDivisorDegreeIndex K L ∣ n := + finiteExtensionDivisorDegreeIndex_dvd_nat_of_degree_eq K L D n hD + exact Nat.le_of_dvd hn hdivNat + +omit [Fintype K] in +/-- The index is one exactly when there exists an exhaustive divisor of +degree one. Thus an exact-constants-to-index-one proof must genuinely +construct (or otherwise imply) such a degree-one divisor; exact constants by +themselves only control the kernel of principal divisor, not this image. -/ +theorem finiteExtensionDivisorDegreeIndex_eq_one_iff : + finiteExtensionDivisorDegreeIndex K L = 1 ↔ + ∃ D : FiniteExtensionPlace K L →₀ ℤ, + finiteExtensionDivisorDegree K L D = 1 := by + constructor + · intro hindex + obtain ⟨D, hD⟩ := exists_finiteExtensionDivisor_degree_eq_index K L + exact ⟨D, by simpa [hindex] using hD⟩ + · rintro ⟨D, hD⟩ + have hle : finiteExtensionDivisorDegreeIndex K L ≤ 1 := + finiteExtensionDivisorDegreeIndex_le_of_degree_eq_nat K L D 1 + Nat.zero_lt_one (by simpa using hD) + have hpos := finiteExtensionDivisorDegreeIndex_pos K L + omega + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionEffectiveDivisorSplit.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionEffectiveDivisorSplit.lean new file mode 100644 index 0000000000..c7db6b0682 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionEffectiveDivisorSplit.lean @@ -0,0 +1,421 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionAffineIdealDivisor +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionZeroCounting +public import LeanPool.MarkoffModP.BGS.HasseWeil.OnePointLeadingCoefficient +public import Mathlib.Data.Finsupp.Fintype + +/-! +# Splitting effective exhaustive divisors at infinity + +An effective divisor on the exhaustive place type of a finite extension of +`K(X)` is a finitely supported natural-number-valued function. Since that +place type is a sum of finite and above-infinity places, such a divisor +splits canonically into its finite and infinity parts. + +This file records the inverse equivalence, degree additivity, the conversion +to the repository's integer-valued effective divisors, and the resulting +fixed-degree convolution. The finite component is also identified with a +nonzero ideal in the normalization of `K[X]`. +-/ + +@[expose] public section + +open scoped nonZeroDivisors Polynomial BigOperators + +namespace BGS.HasseWeil + +noncomputable section + +open BGS.CorvajaZannier + +variable (K : Type*) [Field K] [Fintype K] [DecidableEq K] + [DecidableEq (RatFunc K)] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +/-- Effective divisors on all exhaustive places. -/ +abbrev FiniteExtensionEffectiveDivisor := + FiniteExtensionPlace K L →₀ ℕ + +/-- Effective divisors supported above the place at infinity. -/ +abbrev FiniteExtensionEffectiveInfinityDivisor := + FiniteExtensionInfinityPlace K L →₀ ℕ + +/-- Natural-number degree of an effective exhaustive divisor. -/ +def finiteExtensionEffectiveDivisorDegree + (D : FiniteExtensionEffectiveDivisor K L) : ℕ := + D.sum fun P e => e * finiteExtensionPlaceDegree K L P + +/-- Natural-number degree of an effective divisor supported at infinity. -/ +def finiteExtensionEffectiveInfinityDivisorDegree + (D : FiniteExtensionEffectiveInfinityDivisor K L) : ℕ := + D.sum fun P e => e * finiteExtensionPlaceDegree K L (.inr P) + +/-- An effective exhaustive divisor is exactly a pair consisting of its +finite-place and infinity-place components. -/ +def finiteExtensionEffectiveDivisorSplitEquiv : + FiniteExtensionEffectiveDivisor K L ≃ + (FiniteExtensionFinitePlace K L →₀ ℕ) × + FiniteExtensionEffectiveInfinityDivisor K L := + Finsupp.sumFinsuppEquivProdFinsupp + +omit [Fintype K] [DecidableEq K] [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] in +@[simp] +theorem finiteExtensionEffectiveDivisorSplitEquiv_finite_apply + (D : FiniteExtensionEffectiveDivisor K L) + (P : FiniteExtensionFinitePlace K L) : + (finiteExtensionEffectiveDivisorSplitEquiv K L D).1 P = D (.inl P) := + rfl + +omit [Fintype K] [DecidableEq K] [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] in +@[simp] +theorem finiteExtensionEffectiveDivisorSplitEquiv_infinity_apply + (D : FiniteExtensionEffectiveDivisor K L) + (P : FiniteExtensionInfinityPlace K L) : + (finiteExtensionEffectiveDivisorSplitEquiv K L D).2 P = D (.inr P) := + rfl + +omit [Fintype K] [DecidableEq K] [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] in +@[simp] +theorem finiteExtensionEffectiveDivisorSplitEquiv_symm_inl + (D : (FiniteExtensionFinitePlace K L →₀ ℕ) × + FiniteExtensionEffectiveInfinityDivisor K L) + (P : FiniteExtensionFinitePlace K L) : + (finiteExtensionEffectiveDivisorSplitEquiv K L).symm D (.inl P) = D.1 P := + rfl + +omit [Fintype K] [DecidableEq K] [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] in +@[simp] +theorem finiteExtensionEffectiveDivisorSplitEquiv_symm_inr + (D : (FiniteExtensionFinitePlace K L →₀ ℕ) × + FiniteExtensionEffectiveInfinityDivisor K L) + (P : FiniteExtensionInfinityPlace K L) : + (finiteExtensionEffectiveDivisorSplitEquiv K L).symm D (.inr P) = D.2 P := + rfl + +omit [Fintype K] in +/-- The existing finite-divisor degree is the restriction of exhaustive +place degree to the finite branch. -/ +theorem finiteExtensionEffectiveFiniteDivisorDegree_eq_placeDegree + (D : FiniteExtensionFinitePlace K L →₀ ℕ) : + finiteExtensionEffectiveFiniteDivisorDegree K L D = + D.sum (fun P e => e * finiteExtensionPlaceDegree K L (.inl P)) := by + apply Finsupp.sum_congr + intro P _ + rw [finiteExtensionFinitePlace_degree_eq_finrank_residueField K L P] + +omit [Fintype K] in +/-- Degree is additive across the finite/infinity split. -/ +theorem finiteExtensionEffectiveDivisorDegree_split + (D : FiniteExtensionEffectiveDivisor K L) : + finiteExtensionEffectiveDivisorDegree K L D = + finiteExtensionEffectiveFiniteDivisorDegree K L + (finiteExtensionEffectiveDivisorSplitEquiv K L D).1 + + finiteExtensionEffectiveInfinityDivisorDegree K L + (finiteExtensionEffectiveDivisorSplitEquiv K L D).2 := by + rw [finiteExtensionEffectiveDivisorDegree, + finiteExtensionEffectiveFiniteDivisorDegree_eq_placeDegree, + finiteExtensionEffectiveInfinityDivisorDegree] + let e := finiteExtensionEffectiveDivisorSplitEquiv K L + let g := fun P : FiniteExtensionPlace K L => fun n : ℕ => + n * finiteExtensionPlaceDegree K L P + change D.sum g = + (e D).1.sum (g ∘ Sum.inl) + (e D).2.sum (g ∘ Sum.inr) + calc + D.sum g = (e.symm (e D)).sum g := by + rw [e.symm_apply_apply] + _ = (e D).1.sum (g ∘ Sum.inl) + (e D).2.sum (g ∘ Sum.inr) := by + change (Finsupp.sumElim (e D).1 (e D).2).sum g = _ + exact Finsupp.sum_sumElim _ _ _ + +/-- Cast an effective natural-number divisor to the integer-valued divisor +type used by Riemann spaces and divisor classes. -/ +def finiteExtensionEffectiveDivisorToDivisor + (D : FiniteExtensionEffectiveDivisor K L) : FiniteExtensionDivisor K L := + D.mapRange (fun n : ℕ => (n : ℤ)) (by simp) + +omit [Fintype K] [DecidableEq K] [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] in +@[simp] +theorem finiteExtensionEffectiveDivisorToDivisor_apply + (D : FiniteExtensionEffectiveDivisor K L) + (P : FiniteExtensionPlace K L) : + finiteExtensionEffectiveDivisorToDivisor K L D P = D P := by + simp [finiteExtensionEffectiveDivisorToDivisor] + +omit [Fintype K] [DecidableEq K] in +/-- The cast divisor is effective. -/ +theorem finiteExtensionEffectiveDivisorToDivisor_effective + (D : FiniteExtensionEffectiveDivisor K L) (P : FiniteExtensionPlace K L) : + 0 ≤ finiteExtensionEffectiveDivisorToDivisor K L D P := by + simp + +omit [Fintype K] [FiniteDimensional (RatFunc K) L] [Algebra.IsSeparable (RatFunc K) L] in +/-- Natural degree casts to the integer degree of the associated exhaustive +divisor. -/ +theorem finiteExtensionEffectiveDivisorDegree_cast + (D : FiniteExtensionEffectiveDivisor K L) : + (finiteExtensionEffectiveDivisorDegree K L D : ℤ) = + finiteExtensionDivisorDegree K L + (finiteExtensionEffectiveDivisorToDivisor K L D) := by + rw [finiteExtensionEffectiveDivisorDegree, finiteExtensionDivisorDegree, + finiteExtensionEffectiveDivisorToDivisor] + rw [Finsupp.sum_mapRange_index (fun _ => by simp)] + push_cast + rfl + +/-- Natural effective exhaustive divisors are equivalent to the subtype of +pointwise-effective integer-valued exhaustive divisors. -/ +def finiteExtensionEffectiveDivisorEquivEffectiveIntegralDivisor : + FiniteExtensionEffectiveDivisor K L ≃ + {D : FiniteExtensionDivisor K L // ∀ P, 0 ≤ D P} where + toFun D := ⟨finiteExtensionEffectiveDivisorToDivisor K L D, + finiteExtensionEffectiveDivisorToDivisor_effective K L D⟩ + invFun D := D.1.mapRange Int.toNat (by simp) + left_inv D := by + ext P + simp [finiteExtensionEffectiveDivisorToDivisor] + right_inv D := by + apply Subtype.ext + ext P + simp [finiteExtensionEffectiveDivisorToDivisor, + Int.toNat_of_nonneg (D.2 P)] + +/-- Splitting an effective exhaustive divisor and replacing its finite part +by the corresponding nonzero affine ideal. -/ +def finiteExtensionEffectiveDivisorAffineInfinityEquiv : + FiniteExtensionEffectiveDivisor K L ≃ + FiniteExtensionAffineIdeal K L × + FiniteExtensionEffectiveInfinityDivisor K L := + (finiteExtensionEffectiveDivisorSplitEquiv K L).trans + ((finiteExtensionAffineIdealEffectiveDivisorEquiv K L).symm.prodCongr + (Equiv.refl _)) + +omit [Fintype K] in +/-- Under the ideal/infinity equivalence, exhaustive degree is affine ideal +degree plus infinity degree. -/ +theorem finiteExtensionEffectiveDivisorDegree_eq_affine_add_infinity [Finite K] + (D : FiniteExtensionEffectiveDivisor K L) : + finiteExtensionEffectiveDivisorDegree K L D = + finiteExtensionAffineIdealDegree K L + (finiteExtensionEffectiveDivisorAffineInfinityEquiv K L D).1 + + finiteExtensionEffectiveInfinityDivisorDegree K L + (finiteExtensionEffectiveDivisorAffineInfinityEquiv K L D).2 := by + let : Fintype K := Fintype.ofFinite K + rw [finiteExtensionEffectiveDivisorDegree_split] + rw [finiteExtensionAffineIdealDegree_eq_divisorDegree] + simp [finiteExtensionEffectiveDivisorAffineInfinityEquiv] + +private local instance effectiveDivisorInfinityClosureModuleFinite : + Module.Finite (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.finite (RatFuncInfinityIntegers K) (RatFunc K) L + (RatFuncInfinityIntegralClosure K L) + +private local instance effectiveDivisorInfinityClosureIntegral : + Algebra.IsIntegral (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.isIntegral_algebra (RatFuncInfinityIntegers K) L + +private local instance effectiveDivisorInfinityTorsionFreeTop : + Module.IsTorsionFree (RatFuncInfinityIntegers K) L := + Module.IsTorsionFree.trans_faithfulSMul + (RatFuncInfinityIntegers K) (RatFunc K) L + +private local instance effectiveDivisorInfinityClosureTorsionFree : + Module.IsTorsionFree (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.isTorsionFree (RatFuncInfinityIntegers K) L + +private local instance effectiveDivisorInfinityClosureDedekind : + IsDedekindDomain (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.isDedekindDomain (RatFuncInfinityIntegers K) + (RatFunc K) L (RatFuncInfinityIntegralClosure K L) + +local instance effectiveDivisorInfinityPlaceFinite : + Finite (FiniteExtensionInfinityPlace K L) := by + let := Set.Finite.fintype + (IsDedekindDomain.primesOver_finite + (ratFuncInfinityPlace K).asIdeal + (RatFuncInfinityIntegralClosure K L)) + infer_instance + +omit [Fintype K] in +/-- Every infinity coefficient is bounded by the weighted degree. -/ +theorem finiteExtensionEffectiveInfinityDivisor_apply_le_degree + (D : FiniteExtensionEffectiveInfinityDivisor K L) + (P : FiniteExtensionInfinityPlace K L) : + D P ≤ finiteExtensionEffectiveInfinityDivisorDegree K L D := by + apply le_trans (Nat.le_mul_of_pos_right (D P) + (finiteExtensionPlaceDegree_pos K L (.inr P))) + simpa [finiteExtensionEffectiveInfinityDivisorDegree] using + (Finsupp.single_le_sum D + (g := fun Q e => e * finiteExtensionPlaceDegree K L (.inr Q)) + (fun _ _ => Nat.zero_le _) P) + +/-- Effective infinity divisors of a fixed degree form a finite type. -/ +noncomputable instance finiteExtensionEffectiveInfinityDivisorsOfDegree_fintype + (n : ℕ) : + Fintype {D : FiniteExtensionEffectiveInfinityDivisor K L // + finiteExtensionEffectiveInfinityDivisorDegree K L D = n} := by + let encode : + {D : FiniteExtensionEffectiveInfinityDivisor K L // + finiteExtensionEffectiveInfinityDivisorDegree K L D = n} → + (FiniteExtensionInfinityPlace K L → Fin (n + 1)) := + fun D P => ⟨D.1 P, by + rw [Nat.lt_succ_iff] + exact (finiteExtensionEffectiveInfinityDivisor_apply_le_degree + K L D.1 P).trans_eq D.2⟩ + letI : Finite + (FiniteExtensionInfinityPlace K L → Fin (n + 1)) := inferInstance + letI : Finite + {D : FiniteExtensionEffectiveInfinityDivisor K L // + finiteExtensionEffectiveInfinityDivisorDegree K L D = n} := + Finite.of_injective encode (by + intro D E h + apply Subtype.ext + ext P + exact congrArg Fin.val (congrFun h P)) + exact Fintype.ofFinite _ + +/-- The effective-infinity-divisor coefficient of degree `n`. -/ +noncomputable def finiteExtensionEffectiveInfinityDivisorCount (n : ℕ) : ℕ := + Fintype.card {D : FiniteExtensionEffectiveInfinityDivisor K L // + finiteExtensionEffectiveInfinityDivisorDegree K L D = n} + +/-- Fixed-degree effective exhaustive divisors split according to the degree +of their finite component. -/ +def finiteExtensionEffectiveDivisorsOfDegreeSplitEquiv (n : ℕ) : + {D : FiniteExtensionEffectiveDivisor K L // + finiteExtensionEffectiveDivisorDegree K L D = n} ≃ + Σ m : Fin (n + 1), + {D : (FiniteExtensionFinitePlace K L →₀ ℕ) × + FiniteExtensionEffectiveInfinityDivisor K L // + finiteExtensionEffectiveFiniteDivisorDegree K L D.1 = m.1 ∧ + finiteExtensionEffectiveInfinityDivisorDegree K L D.2 = + n - m.1} where + toFun D := by + let parts := finiteExtensionEffectiveDivisorSplitEquiv K L D.1 + have hsum : + finiteExtensionEffectiveFiniteDivisorDegree K L parts.1 + + finiteExtensionEffectiveInfinityDivisorDegree K L parts.2 = n := by + rw [← finiteExtensionEffectiveDivisorDegree_split K L D.1, D.2] + have hle : finiteExtensionEffectiveFiniteDivisorDegree K L parts.1 ≤ n := by + omega + exact ⟨⟨finiteExtensionEffectiveFiniteDivisorDegree K L parts.1, + Nat.lt_succ_iff.mpr hle⟩, + ⟨parts, rfl, by + change finiteExtensionEffectiveInfinityDivisorDegree K L parts.2 = + n - finiteExtensionEffectiveFiniteDivisorDegree K L parts.1 + omega⟩⟩ + invFun D := by + let E := (finiteExtensionEffectiveDivisorSplitEquiv K L).symm + D.2.1 + refine ⟨E, ?_⟩ + rw [finiteExtensionEffectiveDivisorDegree_split] + dsimp [E] + rw [(finiteExtensionEffectiveDivisorSplitEquiv K L).apply_symm_apply] + rw [D.2.2.1, D.2.2.2] + exact Nat.add_sub_of_le (Nat.le_of_lt_succ D.1.2) + left_inv D := by + apply Subtype.ext + exact (finiteExtensionEffectiveDivisorSplitEquiv K L).symm_apply_apply D.1 + right_inv D := by + apply Sigma.subtype_ext + · apply Fin.ext + change finiteExtensionEffectiveFiniteDivisorDegree K L + ((finiteExtensionEffectiveDivisorSplitEquiv K L) + ((finiteExtensionEffectiveDivisorSplitEquiv K L).symm D.2.1)).1 = + D.1.1 + rw [(finiteExtensionEffectiveDivisorSplitEquiv K L).apply_symm_apply] + exact D.2.2.1 + · exact (finiteExtensionEffectiveDivisorSplitEquiv K L).apply_symm_apply D.2.1 + +/-- Each fixed split-degree fiber is the product of its finite and infinity +fixed-degree components. -/ +def finiteExtensionEffectiveDivisorSplitFiberEquiv (n : ℕ) (m : Fin (n + 1)) : + {D : (FiniteExtensionFinitePlace K L →₀ ℕ) × + FiniteExtensionEffectiveInfinityDivisor K L // + finiteExtensionEffectiveFiniteDivisorDegree K L D.1 = m.1 ∧ + finiteExtensionEffectiveInfinityDivisorDegree K L D.2 = n - m.1} ≃ + {D : FiniteExtensionFinitePlace K L →₀ ℕ // + finiteExtensionEffectiveFiniteDivisorDegree K L D = m.1} × + {D : FiniteExtensionEffectiveInfinityDivisor K L // + finiteExtensionEffectiveInfinityDivisorDegree K L D = n - m.1} where + toFun D := ⟨⟨D.1.1, D.2.1⟩, ⟨D.1.2, D.2.2⟩⟩ + invFun D := ⟨(D.1.1, D.2.1), D.1.2, D.2.2⟩ + left_inv D := by + apply Subtype.ext + rfl + right_inv D := by + apply Prod.ext <;> apply Subtype.ext <;> rfl + +noncomputable instance finiteExtensionEffectiveDivisorSplitFiber_fintype + (n : ℕ) (m : Fin (n + 1)) : + Fintype {D : (FiniteExtensionFinitePlace K L →₀ ℕ) × + FiniteExtensionEffectiveInfinityDivisor K L // + finiteExtensionEffectiveFiniteDivisorDegree K L D.1 = m.1 ∧ + finiteExtensionEffectiveInfinityDivisorDegree K L D.2 = n - m.1} := + Fintype.ofEquiv _ + (finiteExtensionEffectiveDivisorSplitFiberEquiv K L n m).symm + +/-- Effective exhaustive divisors of fixed degree form a finite type. -/ +noncomputable instance finiteExtensionEffectiveDivisorsOfDegree_fintype + (n : ℕ) : + Fintype {D : FiniteExtensionEffectiveDivisor K L // + finiteExtensionEffectiveDivisorDegree K L D = n} := + Fintype.ofEquiv _ + (finiteExtensionEffectiveDivisorsOfDegreeSplitEquiv K L n).symm + +/-- The effective-exhaustive-divisor coefficient of degree `n`. -/ +noncomputable def finiteExtensionEffectiveDivisorCount (n : ℕ) : ℕ := + Fintype.card {D : FiniteExtensionEffectiveDivisor K L // + finiteExtensionEffectiveDivisorDegree K L D = n} + +/-- Fixed-degree exhaustive divisor counts are the convolution of the affine +ideal coefficients with the infinity-divisor coefficients. -/ +theorem finiteExtensionEffectiveDivisorCount_eq_sum_mul_infinityCount + (n : ℕ) : + finiteExtensionEffectiveDivisorCount K L n = + ∑ m : Fin (n + 1), + finiteExtensionEffectiveFiniteDivisorCount K L m.1 * + finiteExtensionEffectiveInfinityDivisorCount K L (n - m.1) := by + rw [finiteExtensionEffectiveDivisorCount] + rw [Fintype.card_congr + (finiteExtensionEffectiveDivisorsOfDegreeSplitEquiv K L n)] + rw [Fintype.card_sigma] + apply Finset.sum_congr rfl + intro m _ + rw [Fintype.card_congr + (finiteExtensionEffectiveDivisorSplitFiberEquiv K L n m)] + rw [Fintype.card_prod] + rfl + +/-- The same convolution with the finite coefficient written as the affine +ideal count in the normalization of `K[X]`. -/ +theorem finiteExtensionEffectiveDivisorCount_eq_sum_affineIdealCount_mul_infinityCount + (n : ℕ) : + finiteExtensionEffectiveDivisorCount K L n = + ∑ m : Fin (n + 1), + finiteExtensionAffineIdealCount K L m.1 * + finiteExtensionEffectiveInfinityDivisorCount K L (n - m.1) := by + rw [finiteExtensionEffectiveDivisorCount_eq_sum_mul_infinityCount] + apply Finset.sum_congr rfl + intro m _ + rw [← finiteExtensionAffineIdealCount_eq_effectiveFiniteDivisorCount] + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionGenusBound.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionGenusBound.lean new file mode 100644 index 0000000000..7e44ba6136 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionGenusBound.lean @@ -0,0 +1,96 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionDivisorClassRecurrence + +/-! +# Bounding the Riemann--Roch genus from a one-point inequality + +Once the uniform Riemann--Roch formula is known, any coarse one-point +Riemann inequality bounds its genus parameter. This is the bridge that will +turn the existing bidegree monomial budget into a numerator-degree bound. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +noncomputable section + +open BGS.CorvajaZannier + +variable (K : Type*) [Field K] [Fintype K] [DecidableEq K] + [DecidableEq (RatFunc K)] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +local instance genusBoundConstantAlgebra : Algebra K L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K (RatFunc K))) + +local instance genusBoundConstantTower : + IsScalarTower K (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + +/-- A one-point lower Riemann inequality with budget `budget`, together with +the uniform eventual Riemann--Roch formula, forces `genus ≤ budget`. -/ +theorem genus_le_budget_of_uniformRiemann_onePoint + (genus threshold budget : ℕ) + (P : FiniteExtensionPlace K L) + (hRiemann : HasFiniteExtensionUniformEventualRiemannFormula + K L genus threshold) + (hLower : ∀ N : ℕ, + N * finiteExtensionPlaceDegree K L P + 1 ≤ + Module.finrank K + (finiteExtensionOnePointRiemannSpace K L P N) + budget) : + genus ≤ budget := by + let d := finiteExtensionPlaceDegree K L P + let D : FiniteExtensionDivisor K L := + Finsupp.single P (threshold : ℤ) + have hd : 0 < d := finiteExtensionPlaceDegree_pos K L P + have hthreshold : threshold ≤ threshold * d := by + by_cases ht : threshold = 0 + · simp [ht] + · exact Nat.le_mul_of_pos_right _ hd + have hdegree : finiteExtensionDivisorDegree K L D = + (threshold * d : ℕ) := by + dsimp only [D, d] + rw [finiteExtensionDivisorDegree_single] + norm_num + have hdata := hRiemann.2 D (threshold * d) hthreshold hdegree + let : Module.Finite K (finiteExtensionRiemannSpace K L D) := hdata.1 + have hspace : finiteExtensionRiemannSpace K L D = + finiteExtensionOnePointRiemannSpace K L P threshold := by + rfl + have hrank : Module.finrank K + (finiteExtensionOnePointRiemannSpace K L P threshold) = + threshold * d + 1 - genus := by + rw [← hspace] + exact hdata.2 + have hlower := hLower threshold + have hgenusThreshold := hRiemann.1 + have hgenusDegree : genus ≤ threshold * d + 1 := by + exact hgenusThreshold.trans (by omega) + have hrankAdd : + Module.finrank K + (finiteExtensionOnePointRiemannSpace K L P threshold) + genus = + threshold * d + 1 := by + rw [hrank, Nat.sub_add_cancel hgenusDegree] + have hcancel : + Module.finrank K + (finiteExtensionOnePointRiemannSpace K L P threshold) + genus ≤ + Module.finrank K + (finiteExtensionOnePointRiemannSpace K L P threshold) + budget := by + rw [hrankAdd] + exact hlower + exact Nat.le_of_add_le_add_left hcancel + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionHasseBoundFromEvenConstantExtensions.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionHasseBoundFromEvenConstantExtensions.lean new file mode 100644 index 0000000000..3972188ca9 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionHasseBoundFromEvenConstantExtensions.lean @@ -0,0 +1,269 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionZetaDegreeIndexOneAutomatic +public import LeanPool.MarkoffModP.BGS.HasseWeil.FormalZetaHasseBound + +/-! +# Hasse bounds from even exact constant-extension estimates + +This file connects the exact constant-extension closed-place identity to the +completed zeta-function and spectral arguments. A uniform two-sided estimate +for degree-one places on the exact degree-`2n` constant extensions becomes the +even-extension `IsBigO` premise used by the power-sum argument. Exact +constants then provide the zeta numerator and its degree bound automatically. + +The geometric two-sided estimate itself is deliberately left as an explicit +hypothesis. Proving it is the remaining Galois-twist boundary; no one-sided +Stepanov estimate can replace it. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +open Filter Asymptotics + +noncomputable section + +/-- Pointwise two-sided square-root estimates at every positive even-extension +index imply the asymptotic estimate used by the zeta spectral argument. -/ +theorem evenExtensionError_isBigO_of_pointwise_bound + (q : ℕ) (pointCount : ℕ → ℕ) (A : ℝ) + (hbound : ∀ n, 0 < n → + |(pointCount (2 * n) : ℝ) - (q : ℝ) ^ (2 * n) - 1| ≤ + A * (q : ℝ) ^ n) : + (fun n : ℕ ↦ + (pointCount (2 * n) : ℂ) - (q : ℂ) ^ (2 * n) - 1) =O[atTop] + fun n : ℕ ↦ (q : ℝ) ^ n := by + apply IsBigO.of_bound A + filter_upwards [eventually_ge_atTop 1] with n hn + have hqn : 0 ≤ (q : ℝ) ^ n := by positivity + rw [Real.norm_eq_abs, abs_of_nonneg hqn] + have heq : + (pointCount (2 * n) : ℂ) - (q : ℂ) ^ (2 * n) - 1 = + (((pointCount (2 * n) : ℝ) - (q : ℝ) ^ (2 * n) - 1 : ℝ) : ℂ) := by + norm_num + rw [heq, Complex.norm_real, Real.norm_eq_abs] + exact hbound n hn + +/-- A pointwise two-sided square-root estimate along one fixed divisible-even +subsequence, with a bounded additive error, gives the asymptotic estimate +used by the rank-general spectral argument. -/ +theorem divisibleEvenExtensionError_isBigO_of_pointwise_bound + (q δ : ℕ) (pointCount : ℕ → ℕ) (A B : ℝ) + (hq : 0 < q) (hA : 0 ≤ A) + (hbound : ∀ n, 0 < n → + |(pointCount (2 * δ * n) : ℝ) - + (q : ℝ) ^ (2 * δ * n) - 1| ≤ + A + B * (((q : ℝ) ^ δ) ^ n)) : + (fun n : ℕ ↦ + (pointCount (2 * δ * n) : ℂ) - + (q : ℂ) ^ (2 * δ * n) - 1) =O[atTop] + fun n : ℕ ↦ ((q : ℝ) ^ δ) ^ n := by + apply IsBigO.of_bound (A + B) + filter_upwards [eventually_ge_atTop 1] with n hn + have hnpos : 0 < n := by omega + have hqOneNat : 1 ≤ q := Nat.one_le_iff_ne_zero.mpr hq.ne' + have hqOne : (1 : ℝ) ≤ q := by exact_mod_cast hqOneNat + have hrhoOne : (1 : ℝ) ≤ ((q : ℝ) ^ δ) ^ n := + one_le_pow₀ (one_le_pow₀ hqOne) + have hpoint := hbound n hnpos + have heq : + (pointCount (2 * δ * n) : ℂ) - + (q : ℂ) ^ (2 * δ * n) - 1 = + (((pointCount (2 * δ * n) : ℝ) - + (q : ℝ) ^ (2 * δ * n) - 1 : ℝ) : ℂ) := by + norm_num + have hrhoNonneg : 0 ≤ (((q : ℝ) ^ δ) ^ n) := by positivity + rw [heq, Complex.norm_real, Real.norm_eq_abs, + Real.norm_eq_abs, abs_of_nonneg hrhoNonneg] + calc + |(pointCount (2 * δ * n) : ℝ) - + (q : ℝ) ^ (2 * δ * n) - 1| ≤ + A + B * (((q : ℝ) ^ δ) ^ n) := hpoint + _ ≤ (A + B) * (((q : ℝ) ^ δ) ^ n) := by nlinarith + +variable (C N : Type*) [Field C] [Fintype C] + [DecidableEq C] [DecidableEq (RatFunc C)] + [Field N] [Algebra (RatFunc C) N] + [FiniteDimensional (RatFunc C) N] + [Algebra.IsSeparable (RatFunc C) N] + +local instance evenConstantExtensionBaseConstantAlgebra : Algebra C N := + bridgeBaseConstantAlgebra C N + +local instance evenConstantExtensionBaseConstantTower : + IsScalarTower C (RatFunc C) N := + IsScalarTower.of_algebraMap_eq' rfl + +/-- The exact constant-extension count identity transports a pointwise +two-sided estimate for rational places on every canonical degree-`2n` +constant extension to the even-extension `IsBigO` estimate for the original +closed-place count sequence. -/ +theorem finiteExtensionClosedPlaceEvenError_isBigO_of_exactConstantExtension_bound + (p : ℕ) [Fact p.Prime] [CharP C p] + (hExact : algebraicClosure C N = + (⊥ : IntermediateField C N)) + (A : ℝ) + (hbound : ∀ n (hn : 0 < n), + letI : NeZero (2 * n) := ⟨by omega⟩ + let S := FiniteField.Extension C p (2 * n) + letI : Fintype S := Fintype.ofFinite S + |(exactConstantExtensionClosedPlaceExtensionCount + C S N hExact 1 : ℝ) - (Nat.card S : ℝ) - 1| ≤ + A * (Nat.card C : ℝ) ^ n) : + (fun n : ℕ ↦ + (finiteExtensionClosedPlaceExtensionCount C N (2 * n) : ℂ) - + (Nat.card C : ℂ) ^ (2 * n) - 1) =O[atTop] + fun n : ℕ ↦ (Nat.card C : ℝ) ^ n := by + apply evenExtensionError_isBigO_of_pointwise_bound (A := A) + intro n hn + let : NeZero (2 * n) := ⟨by omega⟩ + let S := FiniteField.Extension C p (2 * n) + let : Fintype S := Fintype.ofFinite S + have hcount : + exactConstantExtensionClosedPlaceExtensionCount C S N hExact 1 = + finiteExtensionClosedPlaceExtensionCount C N (2 * n) := by + rw [exactConstantExtensionClosedPlaceExtensionCount_eq_classical_decidableEq] + have h := exactConstantExtensionClosedPlaceExtensionCount_eq + C S N hExact 1 + have hfinrank : Module.finrank C S = 2 * n := by + simpa [S] using FiniteField.finrank_extension C p (2 * n) + rw [hfinrank, Nat.mul_one] at h + convert h using 1 + all_goals congr 1 + have hcard : Nat.card S = Nat.card C ^ (2 * n) := by + simpa [S] using FiniteField.natCard_extension C p (2 * n) + have hreal := hbound n hn + dsimp only [S] at hreal + rw [hcount, hcard] at hreal + simpa only [Nat.cast_pow] using hreal + +/-- Exact constants make the standard zeta numerator automatic. Hence the +even-extension error estimate is the only analytic premise left for the +closed-place Hasse bound, apart from the stated genus budget. -/ +theorem finiteExtensionClosedPlaceHasseBound_of_exactConstants_and_evenError + (budget : ℕ) + (hExact : algebraicClosure C N = + (⊥ : IntermediateField C N)) + (hgenus : FunctionField.genus C N ≤ budget) + (herror : + (fun n : ℕ ↦ + (finiteExtensionClosedPlaceExtensionCount C N (2 * n) : ℂ) - + (Nat.card C : ℂ) ^ (2 * n) - 1) =O[atTop] + fun n : ℕ ↦ (Nat.card C : ℝ) ^ n) : + |(finiteExtensionClosedPlaceExtensionCount C N 1 : ℝ) - + Nat.card C - 1| ≤ + (2 * budget + 1 : ℝ) * Real.sqrt (Nat.card C) := by + obtain ⟨P, hPzero, _hPone, hPdegree, hPrational, _hPtrace⟩ := + exists_finiteExtensionClosedPlaceZeta_trace_with_degree_budget_of_exactConstants + C N budget hExact hgenus + have hbound := + abs_pointCount_sub_card_sub_one_le_of_formalPointCountZeta_rational_and_evenError_isBigO + (Nat.card C) (finiteExtensionClosedPlaceExtensionCount C N) P + hPzero hPrational herror + calc + |(finiteExtensionClosedPlaceExtensionCount C N 1 : ℝ) - + Nat.card C - 1| ≤ + (P.natDegree : ℝ) * Real.sqrt (Nat.card C) := hbound + _ ≤ (2 * budget + 1 : ℝ) * Real.sqrt (Nat.card C) := by + gcongr + exact_mod_cast hPdegree + +/-- Exact constants make the zeta package automatic also when the geometric +error estimate is available only along one fixed positive divisible-even +subsequence. -/ +theorem + finiteExtensionClosedPlaceHasseBound_of_exactConstants_and_divisibleEvenError + (budget δ : ℕ) + (hExact : algebraicClosure C N = + (⊥ : IntermediateField C N)) + (hgenus : FunctionField.genus C N ≤ budget) + (hδ : 0 < δ) + (herror : + (fun n : ℕ ↦ + (finiteExtensionClosedPlaceExtensionCount C N (2 * δ * n) : ℂ) - + (Nat.card C : ℂ) ^ (2 * δ * n) - 1) =O[atTop] + fun n : ℕ ↦ ((Nat.card C : ℝ) ^ δ) ^ n) : + |(finiteExtensionClosedPlaceExtensionCount C N 1 : ℝ) - + Nat.card C - 1| ≤ + (2 * budget + 1 : ℝ) * Real.sqrt (Nat.card C) := by + obtain ⟨P, hPzero, _hPone, hPdegree, hPrational, _hPtrace⟩ := + exists_finiteExtensionClosedPlaceZeta_trace_with_degree_budget_of_exactConstants + C N budget hExact hgenus + have hbound := + abs_pointCount_sub_card_sub_one_le_of_formalPointCountZeta_rational_and_divisibleEvenError_isBigO + (Nat.card C) δ (finiteExtensionClosedPlaceExtensionCount C N) P + Nat.card_pos hδ hPzero hPrational herror + calc + |(finiteExtensionClosedPlaceExtensionCount C N 1 : ℝ) - + Nat.card C - 1| ≤ + (P.natDegree : ℝ) * Real.sqrt (Nat.card C) := hbound + _ ≤ (2 * budget + 1 : ℝ) * Real.sqrt (Nat.card C) := by + gcongr + exact_mod_cast hPdegree + +/-- The selected Lorenzini endpoint at the spectral boundary. A uniform +pointwise two-sided estimate along one positive divisible-even subsequence, +allowing a fixed additive error, implies the degree-one closed-place Hasse +bound. Exact constants supply the zeta numerator, index one, and the trace +formula internally. -/ +theorem + finiteExtensionClosedPlaceHasseBound_of_exactConstants_and_divisibleEvenError_bound + (budget δ : ℕ) + (hExact : algebraicClosure C N = + (⊥ : IntermediateField C N)) + (hgenus : FunctionField.genus C N ≤ budget) + (hδ : 0 < δ) + (A B : ℝ) + (hA : 0 ≤ A) + (hbound : ∀ n, 0 < n → + |(finiteExtensionClosedPlaceExtensionCount C N (2 * δ * n) : ℝ) - + (Nat.card C : ℝ) ^ (2 * δ * n) - 1| ≤ + A + B * (((Nat.card C : ℝ) ^ δ) ^ n)) : + |(finiteExtensionClosedPlaceExtensionCount C N 1 : ℝ) - + Nat.card C - 1| ≤ + (2 * budget + 1 : ℝ) * Real.sqrt (Nat.card C) := by + apply + finiteExtensionClosedPlaceHasseBound_of_exactConstants_and_divisibleEvenError + C N budget δ hExact hgenus hδ + exact divisibleEvenExtensionError_isBigO_of_pointwise_bound + (Nat.card C) δ (finiteExtensionClosedPlaceExtensionCount C N) + A B Nat.card_pos hA hbound + +/-- The fully connected conditional endpoint: a uniform two-sided estimate +for rational places on the canonical even exact constant extensions implies +the base closed-place Hasse bound. Zeta rationality, the trace formula, and +degree index one are all discharged internally. -/ +theorem finiteExtensionClosedPlaceHasseBound_of_evenExactConstantExtension_bound + (p : ℕ) [Fact p.Prime] [CharP C p] + (budget : ℕ) + (hExact : algebraicClosure C N = + (⊥ : IntermediateField C N)) + (hgenus : FunctionField.genus C N ≤ budget) + (A : ℝ) + (hbound : ∀ n (hn : 0 < n), + letI : NeZero (2 * n) := ⟨by omega⟩ + let S := FiniteField.Extension C p (2 * n) + letI : Fintype S := Fintype.ofFinite S + |(exactConstantExtensionClosedPlaceExtensionCount + C S N hExact 1 : ℝ) - (Nat.card S : ℝ) - 1| ≤ + A * (Nat.card C : ℝ) ^ n) : + |(finiteExtensionClosedPlaceExtensionCount C N 1 : ℝ) - + Nat.card C - 1| ≤ + (2 * budget + 1 : ℝ) * Real.sqrt (Nat.card C) := by + apply finiteExtensionClosedPlaceHasseBound_of_exactConstants_and_evenError + C N budget hExact hgenus + exact + finiteExtensionClosedPlaceEvenError_isBigO_of_exactConstantExtension_bound + C N p hExact A hbound + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionHasseWeil.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionHasseWeil.lean new file mode 100644 index 0000000000..dbda7853e1 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionHasseWeil.lean @@ -0,0 +1,491 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionIntermediateFrobeniusTwistHasseBound +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionGenusDegree +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionNormalClosureTower +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionDivisibleErrorFromConstantBase +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteFieldDivisibleExtension + +/-! +# Hasse--Weil for finite separable function-field extensions + +The normal closure supplies one finite enlargement of the constant field over +which the extension is geometric. At every sufficiently divisible even +constant-field degree, a quadratic subfield and an auxiliary extension of +factorial degree put the fixed-tower Frobenius-twist estimate into a uniform +form. Exact constant-extension splitting and the spectral argument then +transport that estimate back to the original function field. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +noncomputable section + + +section GenusBridge + +variable (C S N : Type*) [Field C] [Field S] [Field N] + [Fintype C] [Finite S] + [Algebra (RatFunc C) N] [FiniteDimensional (RatFunc C) N] + [Algebra.IsSeparable (RatFunc C) N] + [Algebra C S] [FiniteDimensional C S] [IsGalois C S] +local instance : Algebra C N := bridgeBaseConstantAlgebra C N +local instance : IsScalarTower C (RatFunc C) N := IsScalarTower.of_algebraMap_eq' rfl + +/-- Constant extension preserves genus for the induced rational-function-field algebra. -/ +private theorem exactConstantExtension_genus_eq_for_ratFunc + (hExact : algebraicClosure C N = (⊥ : IntermediateField C N)) : + let E := ExactConstantExtension C N S + let : Field E := exactConstantExtensionField C N S hExact + let : Algebra (RatFunc S) E := ratFuncExactConstantExtensionAlgebra C S N hExact + @FunctionField.genus S E _ _ (bridgeBaseConstantAlgebra S E) = FunctionField.genus C N := by + intro E fieldStructure rationalAlgebra + have hConstantAlgebra : (Algebra.TensorProduct.leftAlgebra : Algebra S E) = + bridgeBaseConstantAlgebra S E := by + apply Algebra.algebra_ext + intro s + exact (ratFuncToExactConstantExtension C S N hExact).commutes s |>.symm + rw [← hConstantAlgebra] + exact exactConstantExtension_genus_eq C S N hExact + + +end GenusBridge + +variable (K F : Type*) [Field K] [Fintype K] [DecidableEq K] + [DecidableEq (RatFunc K)] [Field F] [Algebra (RatFunc K) F] + [FiniteDimensional (RatFunc K) F] + [Algebra.IsSeparable (RatFunc K) F] + +local instance finiteExtensionHasseBaseConstantAlgebra : Algebra K F := + bridgeBaseConstantAlgebra K F + +local instance finiteExtensionHasseBaseConstantTower : + IsScalarTower K (RatFunc K) F := + IsScalarTower.of_algebraMap_eq' rfl + +local instance finiteExtensionHasseNormalClosureConstantFintype : + Fintype (FunctionFieldNormalClosureConstantField K F) := + Fintype.ofFinite _ + +local instance finiteExtensionHasseNormalClosureConstantAlgebra : + Algebra K (FunctionFieldNormalClosureConstantField K F) := + SubalgebraClass.toAlgebra + (algebraicClosure K (FunctionFieldNormalClosure K F)) + +local instance finiteExtensionHasseNormalClosureConstantSmul : + SMul K (FunctionFieldNormalClosureConstantField K F) := + Algebra.toSMul + +local instance finiteExtensionHasseNormalClosureConstantModule : + Module K (FunctionFieldNormalClosureConstantField K F) := + Algebra.toModule + +local instance finiteExtensionHasseNormalClosureConstantFiniteDimensional : + FiniteDimensional K (FunctionFieldNormalClosureConstantField K F) := + functionFieldConstantField_finiteDimensional K + (FunctionFieldNormalClosure K F) + +local instance finiteExtensionHasseNormalClosureConstantIsGalois : + IsGalois K (FunctionFieldNormalClosureConstantField K F) := + functionFieldConstantField_isGalois K (FunctionFieldNormalClosure K F) + +local instance finiteExtensionHasseNormalClosureConstantDecidableEq : + DecidableEq (FunctionFieldNormalClosureConstantField K F) := + Classical.decEq _ + +local instance finiteExtensionHasseNormalClosureRatFuncDecidableEq : + DecidableEq (RatFunc (FunctionFieldNormalClosureConstantField K F)) := + Classical.decEq _ + +local instance finiteExtensionHasseNormalClosureRatFuncSmul : + SMul (RatFunc (FunctionFieldNormalClosureConstantField K F)) + (FunctionFieldNormalClosure K F) := + Algebra.toSMul + +local instance finiteExtensionHasseNormalClosureRatFuncModule : + Module (RatFunc (FunctionFieldNormalClosureConstantField K F)) + (FunctionFieldNormalClosure K F) := + Algebra.toModule + +local instance finiteExtensionHasseNormalClosureRatFuncTorsionFree : + Module.IsTorsionFree + (RatFunc (FunctionFieldNormalClosureConstantField K F)) + (FunctionFieldNormalClosure K F) := by + rw [Module.isTorsionFree_iff_algebraMap_injective] + exact (algebraMap + (RatFunc (FunctionFieldNormalClosureConstantField K F)) + (FunctionFieldNormalClosure K F)).injective + +local instance finiteExtensionHasseNormalClosureFiniteDimensional : + FiniteDimensional + (RatFunc (FunctionFieldNormalClosureConstantField K F)) + (FunctionFieldNormalClosure K F) := + functionFieldNormalClosure_finiteDimensional_over_constantRatFunc K F + +local instance finiteExtensionHasseNormalClosureCanonicalConstantAlgebra : + Algebra (FunctionFieldNormalClosureConstantField K F) + (FunctionFieldNormalClosure K F) := + exactConstantExtensionTowerCanonicalConstantAlgebra _ _ + +/-- The genus of the chosen normal closure over its full constant field. -/ +noncomputable def functionFieldNormalClosureGenus : ℕ := + FunctionField.genus (FunctionFieldNormalClosureConstantField K F) + (FunctionFieldNormalClosure K F) + +/-- The degree of the chosen normal closure over the canonical rational +function field of its full constant field. -/ +noncomputable def functionFieldNormalClosureRatFuncDegree : ℕ := + Module.finrank (RatFunc (FunctionFieldNormalClosureConstantField K F)) + (FunctionFieldNormalClosure K F) + +/-- The Stepanov threshold attached to the chosen normal closure. -/ +def functionFieldNormalClosureStepanovThreshold : ℕ := + (functionFieldNormalClosureGenus K F + 1) * + (functionFieldNormalClosureGenus K F + 2) + +omit [Fintype K] [DecidableEq K] [DecidableEq (RatFunc K)] in +theorem functionFieldNormalClosureRatFuncDegree_pos : + 0 < functionFieldNormalClosureRatFuncDegree K F := by + unfold functionFieldNormalClosureRatFuncDegree + exact Module.finrank_pos + +omit [Fintype K] [DecidableEq K] [DecidableEq (RatFunc K)] in +theorem functionFieldNormalClosureStepanovThreshold_pos : + 0 < functionFieldNormalClosureStepanovThreshold K F := by + unfold functionFieldNormalClosureStepanovThreshold + positivity + +section GenericGaloisTowerBound + +variable (C M N : Type*) [Field C] [Fintype C] [DecidableEq C] + [DecidableEq (RatFunc C)] [Field M] [Field N] + [Algebra (RatFunc C) M] [Algebra (RatFunc C) N] + [Algebra M N] [IsScalarTower (RatFunc C) M N] + [FiniteDimensional (RatFunc C) M] [FiniteDimensional (RatFunc C) N] + [FiniteDimensional M N] + [IsGalois (RatFunc C) N] [IsGalois M N] + [Algebra.IsSeparable (RatFunc C) M] + +/-- Restrict the intermediate rational-function-field algebra to the constants. -/ +local instance genericGaloisTowerConstantAlgebraM : Algebra C M := + exactConstantExtensionTowerCanonicalConstantAlgebra C M + +/-- Restrict the top rational-function-field algebra to the constants. -/ +local instance genericGaloisTowerConstantAlgebraN : Algebra C N := + exactConstantExtensionTowerCanonicalConstantAlgebra C N + +private local instance genericGaloisTowerConstantTower : IsScalarTower C M N := + exactConstantExtensionTowerCanonicalConstantScalarTower C M N + +private local instance genericGaloisTowerRationalConstantTowerM : + IsScalarTower C (RatFunc C) M := IsScalarTower.of_algebraMap_eq' rfl + +private local instance genericGaloisTowerRationalConstantTowerN : + IsScalarTower C (RatFunc C) N := IsScalarTower.of_algebraMap_eq' rfl + +private local instance genericGaloisTowerTopSeparable : Algebra.IsSeparable (RatFunc C) N := + (isGalois_iff.mp (inferInstance : IsGalois (RatFunc C) N)).1 + +omit [DecidableEq C] [DecidableEq (RatFunc C)] in +/-- A finite Galois function-field tower over exact finite constants satisfies the +square-field error bound after a sufficiently divisible even constant extension. -/ +private theorem exactConstantExtensionClosedPlaceError_le_galoisTowerConstants + (hExactM : algebraicClosure C M = (⊥ : IntermediateField C M)) + (hExactN : algebraicClosure C N = (⊥ : IntermediateField C N)) + (n : ℕ) (hn : 0 < n) : + let g := FunctionField.genus C N + let H := (g + 1) * (g + 2) + let D := Module.finrank (RatFunc C) N + let p := ringChar C + let : CharP C p := ringChar.charP C + let : Fact p.Prime := ⟨CharP.char_is_prime C p⟩ + let : NeZero (2 * (H * n)) := ⟨by positivity⟩ + let Cbig := FiniteField.Extension C p (2 * (H * n)) + let : Fintype Cbig := Fintype.ofFinite Cbig + |(exactConstantExtensionClosedPlaceExtensionCount C Cbig M hExactM 1 : ℝ) - + (Nat.card C : ℝ) ^ (2 * H * n) - 1| ≤ + 2 * (D : ℝ) ^ 2 + 2 * (D : ℝ) ^ 3 + + (D : ℝ) ^ 2 * (2 * g + 1) * (Nat.card C : ℝ) ^ (H * n) := by + classical + intro g H D p charP primeP neBig Cbig fintypeBig + have hH : 0 < H := by positivity + have hD : 0 < D := Module.finrank_pos + let : NeZero (H * n) := ⟨Nat.mul_pos hH hn |>.ne'⟩ + let Ksmall := FiniteField.Extension C p (H * n) + let : Fintype Ksmall := Fintype.ofFinite Ksmall + let : DecidableEq Cbig := Classical.decEq Cbig + let : DecidableEq (RatFunc Cbig) := Classical.decEq (RatFunc Cbig) + let : Algebra C Ksmall := + FiniteField.instAlgebraExtension C p (H * n) + let : Algebra C Cbig := + FiniteField.instAlgebraExtension C p (2 * (H * n)) + let : SMul C Ksmall := Algebra.toSMul + let : Module C Ksmall := Algebra.toModule + let : SMul C Cbig := Algebra.toSMul + let : Module C Cbig := Algebra.toModule + let : CharP Cbig p := + charP_of_injective_algebraMap (algebraMap C Cbig).injective p + let : Algebra Ksmall Cbig := + finiteFieldExtensionAlgebraOfDvd C p (H * n) (2 * (H * n)) + ⟨2, by omega⟩ + let : SMul Ksmall Cbig := Algebra.toSMul + let : Module Ksmall Cbig := Algebra.toModule + let : IsScalarTower C Ksmall Cbig := + finiteFieldExtension_isScalarTower_of_dvd C p + (H * n) (2 * (H * n)) ⟨2, by omega⟩ + have hcard : Fintype.card Cbig = Fintype.card Ksmall ^ 2 := by + simpa only [Fintype.card_eq_nat_card] using + natCard_double_finiteFieldExtension_eq_sq C p (H * n) + have hlargeBase : H ≤ Fintype.card Ksmall := by + simpa only [Fintype.card_eq_nat_card] using + degree_le_natCard_finiteFieldExtension_mul C p H n hn + let E_N := ExactConstantExtension C N Cbig + let E_M := ExactConstantExtension C M Cbig + let : Field E_N := + exactConstantExtensionField C N Cbig hExactN + let : Field E_M := + exactConstantExtensionField C M Cbig hExactM + let : Algebra (RatFunc Cbig) E_N := + ratFuncExactConstantExtensionAlgebra C Cbig N hExactN + let : Algebra (RatFunc Cbig) E_M := + ratFuncExactConstantExtensionAlgebra C Cbig M hExactM + let : Module (RatFunc Cbig) E_N := Algebra.toModule + let : Module (RatFunc Cbig) E_M := Algebra.toModule + let : FiniteDimensional (RatFunc Cbig) E_N := + finiteDimensional_over_extendedRatFunc C Cbig N hExactN + let : FiniteDimensional (RatFunc Cbig) E_M := + finiteDimensional_over_extendedRatFunc C Cbig M hExactM + let : Algebra.IsSeparable (RatFunc Cbig) E_N := + isSeparable_over_extendedRatFunc C Cbig N hExactN + let : Algebra.IsSeparable (RatFunc Cbig) E_M := + isSeparable_over_extendedRatFunc C Cbig M hExactM + let : Algebra E_M E_N := + exactConstantExtensionTowerRatFuncAlgebra C M N Cbig + let : SMul (RatFunc Cbig) E_M := Algebra.toSMul + let : SMul (RatFunc Cbig) E_N := Algebra.toSMul + let : SMul E_M E_N := Algebra.toSMul + let : Module E_M E_N := Algebra.toModule + let : IsScalarTower (RatFunc Cbig) E_M E_N := + exactConstantExtensionTower_ratFuncScalarTower C M N Cbig hExactN + let : Module.Finite E_M E_N := + exactConstantExtensionTower_finiteDimensional C M N Cbig hExactN + let : IsGalois E_M E_N := + exactConstantExtensionTower_isGalois C M N Cbig hExactN + let : Algebra (RatFunc C) (RatFunc Cbig) := + ratFuncCoefficientAlgebra C Cbig + let : Algebra (RatFunc C) E_N := + exactConstantExtensionBaseAlgebra C (RatFunc C) N Cbig + let : SMul (RatFunc C) (RatFunc Cbig) := Algebra.toSMul + let : SMul (RatFunc C) E_N := Algebra.toSMul + let : Module (RatFunc C) E_N := Algebra.toModule + let : IsScalarTower (RatFunc C) (RatFunc Cbig) E_N := + rationalBase_scalarTower C Cbig N hExactN + let : IsGalois (RatFunc C) E_N := + exactConstantExtension_isGalois C (RatFunc C) N Cbig hExactN + let : IsGalois (RatFunc Cbig) E_N := + IsGalois.tower_top_of_isGalois (RatFunc C) (RatFunc Cbig) E_N + have hExactEN : + @algebraicClosure Cbig E_N _ _ (bridgeBaseConstantAlgebra Cbig E_N) = + (⊥ : @IntermediateField Cbig E_N _ _ + (bridgeBaseConstantAlgebra Cbig E_N)) := + exactConstantExtension_extended_algebraicClosure_eq_bot + C Cbig N hExactN + have hgenusEN : + @FunctionField.genus Cbig E_N _ _ + (bridgeBaseConstantAlgebra Cbig E_N) = g := by + simpa only [E_N, g] using + exactConstantExtension_genus_eq_for_ratFunc C Cbig N hExactN + have hdegreeEN : Module.finrank (RatFunc Cbig) E_N = D := + exactConstantExtension_finrank_over_extendedRatFunc_eq + C Cbig N hExactN + have hHg : H = (g + 1) * (g + 2) := rfl + have hlarge : + (@FunctionField.genus Cbig E_N _ _ + (bridgeBaseConstantAlgebra Cbig E_N) + 1) * + (@FunctionField.genus Cbig E_N _ _ + (bridgeBaseConstantAlgebra Cbig E_N) + 2) ≤ + Fintype.card Ksmall := by + simpa only [hgenusEN, hHg] using hlargeBase + let : NeZero D.factorial := ⟨Nat.factorial_ne_zero D⟩ + let U := FiniteField.Extension Cbig p D.factorial + let : DecidableEq U := Classical.decEq U + let : DecidableEq (RatFunc U) := Classical.decEq (RatFunc U) + let : Algebra Cbig U := + FiniteField.instAlgebraExtension Cbig p D.factorial + let : SMul Cbig U := Algebra.toSMul + let : Module Cbig U := Algebra.toModule + have hauxDegree : Module.finrank Cbig U = D.factorial := by + simpa only [U] using FiniteField.finrank_extension Cbig p D.factorial + have hdivBase : Nat.card (E_N ≃ₐ[RatFunc Cbig] E_N) ∣ + Module.finrank Cbig U := by + rw [hauxDegree, IsGalois.card_aut_eq_finrank, hdegreeEN] + exact Nat.dvd_factorial hD le_rfl + have hdivMOriginal : Nat.card (N ≃ₐ[M] N) ∣ D.factorial := + natCard_aut_dvd_finrank_factorial_of_tower (RatFunc C) M N + have hcardTower : Nat.card (E_N ≃ₐ[E_M] E_N) = + Nat.card (N ≃ₐ[M] N) := + exactConstantExtensionTower_card_aut_eq C M N Cbig hExactN + have hdivL : Nat.card (E_N ≃ₐ[E_M] E_N) ∣ + Module.finrank Cbig U := by + rw [hauxDegree, hcardTower] + exact hdivMOriginal + have hfixed := + abs_intermediateBaseRationalPlaceError_le_squareField_of_genus + Ksmall Cbig U E_N E_M hcard hExactEN hdivL hdivBase hlarge + have hcount : exactConstantExtensionClosedPlaceExtensionCount C Cbig M hExactM 1 = + finiteExtensionRationalPlaceCount Cbig E_M := + exactConstantExtensionClosedPlaceExtensionCount_one_eq_rationalPlaceCount + C Cbig M hExactM + have hcardBig : Nat.card Cbig = Nat.card C ^ (2 * H * n) := by + simpa only [Cbig, Nat.mul_assoc] using + FiniteField.natCard_extension C p (2 * (H * n)) + have hcardSmall : Fintype.card Ksmall = Nat.card C ^ (H * n) := by + rw [Fintype.card_eq_nat_card, + FiniteField.natCard_extension C p (H * n)] + rw [← hcount, hcardBig, hdegreeEN, hgenusEN, hcardSmall] at hfixed + push_cast at hfixed + simpa only [mul_assoc] using hfixed + +end GenericGaloisTowerBound + +/-- The normal-closure constant field gives a uniform square-root-scale bound +for the packaged exact constant extensions of the original function field. + +Here `H = (g + 1)(g + 2)` is the Stepanov threshold for the genus `g` of the +geometric normal closure, while `D` is its degree over the rational function +field of its full constant field. -/ +theorem exactConstantExtensionClosedPlaceError_le_normalClosureConstants + (hExact : algebraicClosure K F = + (⊥ : IntermediateField K F)) : + ∀ n, 0 < n → + |(exactConstantExtensionClosedPlaceExtensionCount + K (FunctionFieldNormalClosureConstantField K F) F hExact + (2 * functionFieldNormalClosureStepanovThreshold K F * n) : ℝ) - + (Nat.card (FunctionFieldNormalClosureConstantField K F) : ℝ) ^ + (2 * functionFieldNormalClosureStepanovThreshold K F * n) - 1| ≤ + 2 * (functionFieldNormalClosureRatFuncDegree K F : ℝ) ^ 2 + + 2 * (functionFieldNormalClosureRatFuncDegree K F : ℝ) ^ 3 + + (functionFieldNormalClosureRatFuncDegree K F : ℝ) ^ 2 * + (2 * functionFieldNormalClosureGenus K F + 1) * + (Nat.card (FunctionFieldNormalClosureConstantField K F) : ℝ) ^ + (functionFieldNormalClosureStepanovThreshold K F * n) := by + classical + intro n hn + let C := FunctionFieldNormalClosureConstantField K F + let : Fintype C := + finiteExtensionHasseNormalClosureConstantFintype K F + let : DecidableEq C := + finiteExtensionHasseNormalClosureConstantDecidableEq K F + let : DecidableEq (RatFunc C) := + finiteExtensionHasseNormalClosureRatFuncDecidableEq K F + let N := FunctionFieldNormalClosure K F + let M := FunctionFieldNormalClosureOriginalCompositum K F hExact + let : Algebra (RatFunc C) M := + functionFieldNormalClosureOriginalCompositumConstantRatFuncAlgebra + K F hExact + let : SMul (RatFunc C) M := Algebra.toSMul + let : Module (RatFunc C) M := Algebra.toModule + let : Algebra C M := + exactConstantExtensionTowerCanonicalConstantAlgebra C M + let : IsScalarTower (RatFunc C) M N := + functionFieldNormalClosureOriginalCompositumConstantRatFuncTower + K F hExact + let : FiniteDimensional (RatFunc C) M := + functionFieldNormalClosureOriginalCompositum_finiteDimensional_over_constantRatFunc + K F hExact + let : FiniteDimensional M N := + functionFieldNormalClosure_finiteDimensional_over_originalCompositum + K F hExact + let : IsGalois M N := + functionFieldNormalClosure_isGalois_over_originalCompositum K F hExact + let : Algebra.IsSeparable (RatFunc C) M := + functionFieldNormalClosureOriginalCompositum_isSeparable_over_constantRatFunc + K F hExact + let normalClosureGalois : IsGalois (RatFunc C) N := + functionFieldNormalClosure_isGalois_over_constantRatFunc K F + let : Algebra.IsSeparable (RatFunc C) N := + (isGalois_iff.mp normalClosureGalois).1 + let g := functionFieldNormalClosureGenus K F + let H := functionFieldNormalClosureStepanovThreshold K F + let D := functionFieldNormalClosureRatFuncDegree K F + have hH : 0 < H := functionFieldNormalClosureStepanovThreshold_pos K F + have hExactN : algebraicClosure C N = (⊥ : IntermediateField C N) := + functionFieldNormalClosureConstantField_isExact_for_constantRatFunc K F + have hExactM : algebraicClosure C M = (⊥ : IntermediateField C M) := + functionFieldNormalClosureOriginalCompositumConstantField_isExact_for_constantRatFunc + K F hExact + let p := ringChar C + let : CharP C p := ringChar.charP C + let : Fact p.Prime := ⟨CharP.char_is_prime C p⟩ + let : NeZero (2 * (H * n)) := ⟨by positivity⟩ + let Cbig := FiniteField.Extension C p (2 * (H * n)) + let : Fintype Cbig := Fintype.ofFinite Cbig + let : Algebra C Cbig := FiniteField.instAlgebraExtension C p (2 * (H * n)) + have hfixed := exactConstantExtensionClosedPlaceError_le_galoisTowerConstants + C M N hExactM hExactN n hn + have hcount : exactConstantExtensionClosedPlaceExtensionCount C Cbig M hExactM 1 = + exactConstantExtensionClosedPlaceExtensionCount K C F hExact (2 * H * n) := by + have htransport := + (normalClosureOriginalCompositum_rationalPlaceCount_eq_exactExtensionCount + K F Cbig hExact).symm.trans + (normalClosureOriginalCompositum_rationalPlaceCount_eq_originalExactExtensionCount + K F Cbig hExact) + convert htransport using 2 + simpa only [Cbig, Nat.mul_assoc] using + (FiniteField.finrank_extension C p (2 * (H * n))).symm + change |(exactConstantExtensionClosedPlaceExtensionCount C Cbig M hExactM 1 : ℝ) - + (Nat.card C : ℝ) ^ (2 * H * n) - 1| ≤ + 2 * (D : ℝ) ^ 2 + 2 * (D : ℝ) ^ 3 + + (D : ℝ) ^ 2 * (2 * g + 1) * (Nat.card C : ℝ) ^ (H * n) at hfixed + rw [hcount] at hfixed + exact hfixed + +/-- The closed Hasse--Weil bound for a finite separable extension of `K(X)` +with exact constant field `K`. -/ +theorem finiteExtensionClosedPlaceHasseWeil + (hExact : algebraicClosure K F = + (⊥ : IntermediateField K F)) : + |(finiteExtensionClosedPlaceExtensionCount K F 1 : ℝ) - + Nat.card K - 1| ≤ + (2 * FunctionField.genus K F + 1 : ℝ) * + Real.sqrt (Nat.card K) := by + classical + let C := FunctionFieldNormalClosureConstantField K F + let : Fintype C := + finiteExtensionHasseNormalClosureConstantFintype K F + let : DecidableEq C := + finiteExtensionHasseNormalClosureConstantDecidableEq K F + let : DecidableEq (RatFunc C) := + finiteExtensionHasseNormalClosureRatFuncDecidableEq K F + let g := functionFieldNormalClosureGenus K F + let H := functionFieldNormalClosureStepanovThreshold K F + let D := functionFieldNormalClosureRatFuncDegree K F + let A : ℝ := 2 * (D : ℝ) ^ 2 + 2 * (D : ℝ) ^ 3 + let B : ℝ := (D : ℝ) ^ 2 * (2 * g + 1) + have hH : 0 < H := functionFieldNormalClosureStepanovThreshold_pos K F + have hA : 0 ≤ A := by + dsimp only [A] + positivity + have hbound : ∀ n, 0 < n → + |(exactConstantExtensionClosedPlaceExtensionCount + K C F hExact (2 * H * n) : ℝ) - + (Nat.card C : ℝ) ^ (2 * H * n) - 1| ≤ + A + B * (Nat.card C : ℝ) ^ (H * n) := by + intro n hn + have h := exactConstantExtensionClosedPlaceError_le_normalClosureConstants + K F hExact n hn + simpa only [C, g, H, D, A, B] using h + exact finiteExtensionClosedPlaceHasseBound_of_constantBase_bound + K C F (FunctionField.genus K F) hExact le_rfl H hH A B hA hbound + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionIndexedZetaRationality.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionIndexedZetaRationality.lean new file mode 100644 index 0000000000..134d5ed140 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionIndexedZetaRationality.lean @@ -0,0 +1,95 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.ClosedPlaceEulerRecurrence +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionDivisorClassRecurrence +public import LeanPool.MarkoffModP.BGS.HasseWeil.FormalZetaEuler + +/-! +# Indexed zeta rationality for an exact-constant function field + +This file composes the exhaustive divisor-class recurrence with the proved +closed-place Euler recurrence. The only input at this boundary is the +uniform Riemann--Roch formula for arbitrary divisors. The denominator still +uses the divisor-degree index; replacing it by the standard degree-one +denominator is a separate constant-field theorem. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +noncomputable section + +open BGS.CorvajaZannier +open scoped Polynomial + +variable (K : Type*) [Field K] [Fintype K] [DecidableEq K] + [DecidableEq (RatFunc K)] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +local instance indexedZetaConstantAlgebra : Algebra K L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K (RatFunc K))) + +local instance indexedZetaConstantTower : + IsScalarTower K (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + +/-- There is exactly one effective exhaustive divisor of degree zero. -/ +theorem finiteExtensionEffectiveDivisorCount_zero : + finiteExtensionEffectiveDivisorCount K L 0 = 1 := by + rw [finiteExtensionEffectiveDivisorCount] + apply Fintype.card_eq_one_iff.mpr + refine ⟨⟨0, by simp [finiteExtensionEffectiveDivisorDegree]⟩, ?_⟩ + intro D + apply Subtype.ext + let : Finsupp.NonTorsionWeight ℕ + (fun P : FiniteExtensionPlace K L => + finiteExtensionPlaceDegree K L P) := + Finsupp.nonTorsionWeight_of ℕ + (w := fun P : FiniteExtensionPlace K L => + finiteExtensionPlaceDegree K L P) + (fun P => (finiteExtensionPlaceDegree_pos K L P).ne') + apply (Finsupp.weight_eq_zero_iff_eq_zero + (fun P : FiniteExtensionPlace K L => + finiteExtensionPlaceDegree K L P)).mp + simpa [finiteExtensionEffectiveDivisorDegree, Finsupp.weight_apply, + nsmul_eq_mul] using D.2 + +/-- Uniform Riemann--Roch, exact constants, and the exhaustive Euler product +give the indexed rational form of the closed-place zeta series. -/ +theorem exists_finiteExtensionClosedPlaceZeta_indexed_rational + (genus threshold : ℕ) + (hconstants : algebraicClosure K L = + (⊥ : IntermediateField K L)) + (hRiemann : HasFiniteExtensionUniformEventualRiemannFormula + K L genus threshold) : + ∃ P : Polynomial ℂ, + P.coeff 0 = 1 ∧ + HasIndexedCurveZetaRationalForm + (formalPointCountZeta + (finiteExtensionClosedPlaceExtensionCount K L)) + (Nat.card K) (finiteExtensionDivisorDegreeIndex K L) P := by + apply + exists_formalPointCountZeta_indexed_rational_of_effectiveDivisor_recurrences + (finiteExtensionEffectiveDivisorCount K L) + (finiteExtensionClosedPlaceExtensionCount K L) + (Nat.card K) (finiteExtensionDivisorDegreeIndex K L) threshold + (finiteExtensionDivisorDegreeIndex_pos K L) + (finiteExtensionEffectiveDivisorCount_zero K L) + (finiteExtensionEffectiveDivisorPointCountRecurrence K L) + intro n hn + exact finiteExtensionEffectiveDivisorCount_indexed_eventual_recurrence_complex + K L genus threshold n hconstants hRiemann hn + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionIndexedZetaRationalityAutomatic.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionIndexedZetaRationalityAutomatic.lean new file mode 100644 index 0000000000..b4773fe7e2 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionIndexedZetaRationalityAutomatic.lean @@ -0,0 +1,110 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionIndexedZetaRationality +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionRiemannRoch +public import LeanPool.MarkoffModP.BGS.HasseWeil.FormalZetaEulerDegree + +/-! +# Unconditional indexed zeta rationality from exact constants + +This file discharges the uniform Riemann--Roch premise of the indexed zeta +composition by transporting the vendored Riemann--Roch theorem to the +exhaustive BGS divisor model. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +noncomputable section + +open BGS.CorvajaZannier +open scoped Polynomial + +variable (K : Type*) [Field K] [Fintype K] [DecidableEq K] + [DecidableEq (RatFunc K)] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +local instance automaticIndexedZetaConstantAlgebra : Algebra K L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K (RatFunc K))) + +local instance automaticIndexedZetaConstantTower : + IsScalarTower K (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + +local instance (priority := 10) automaticIndexedZetaPolynomialAlgebra : + Algebra K[X] L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K[X] (RatFunc K))) + +local instance automaticIndexedZetaPolynomialTower : + IsScalarTower K[X] (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + +local instance automaticIndexedZetaConstantPolynomialTower : + IsScalarTower K K[X] L := + IsScalarTower.of_algebraMap_eq' rfl + +/-- Exact constants alone supply the indexed rational form of the exhaustive +closed-place zeta series. -/ +theorem exists_finiteExtensionClosedPlaceZeta_indexed_rational_of_constants + (hconstants : algebraicClosure K L = + (⊥ : IntermediateField K L)) : + ∃ P : Polynomial ℂ, + P.coeff 0 = 1 ∧ + HasIndexedCurveZetaRationalForm + (formalPointCountZeta + (finiteExtensionClosedPlaceExtensionCount K L)) + (Nat.card K) (finiteExtensionDivisorDegreeIndex K L) P := by + let : FunctionField.IsFullConstantField K L := + (FunctionField.isFullConstantField_iff_algebraicClosure_eq_bot K L).2 + hconstants + exact exists_finiteExtensionClosedPlaceZeta_indexed_rational + K L (FunctionField.Chart.genus K L) + (2 * FunctionField.Chart.genus K L) hconstants + (hasFiniteExtensionUniformEventualRiemannFormula_of_fullConstantField K L) + +/-- The same automatic composition retains the truncation bound on the +indexed numerator. -/ +theorem exists_finiteExtensionClosedPlaceZeta_indexed_rational_with_natDegree_lt_of_constants + (hconstants : algebraicClosure K L = + (⊥ : IntermediateField K L)) : + ∃ (genus threshold : ℕ) (P : Polynomial ℂ), + HasFiniteExtensionUniformEventualRiemannFormula + K L genus threshold ∧ + P.coeff 0 = 1 ∧ + P.natDegree < + threshold + 2 * finiteExtensionDivisorDegreeIndex K L ∧ + HasIndexedCurveZetaRationalForm + (formalPointCountZeta + (finiteExtensionClosedPlaceExtensionCount K L)) + (Nat.card K) (finiteExtensionDivisorDegreeIndex K L) P := by + obtain ⟨genus, threshold, hRiemann⟩ := + exists_hasFiniteExtensionUniformEventualRiemannFormula_of_constants + K L hconstants + obtain ⟨P, hP0, hPdegree, hP⟩ := + exists_formalPointCountZeta_indexed_rational_with_natDegree_lt_of_effectiveDivisor_recurrences + (finiteExtensionEffectiveDivisorCount K L) + (finiteExtensionClosedPlaceExtensionCount K L) + (Nat.card K) (finiteExtensionDivisorDegreeIndex K L) + threshold + (finiteExtensionDivisorDegreeIndex_pos K L) + (finiteExtensionEffectiveDivisorCount_zero K L) + (finiteExtensionEffectiveDivisorPointCountRecurrence K L) + (fun n hn => + finiteExtensionEffectiveDivisorCount_indexed_eventual_recurrence_complex + K L genus threshold n hconstants hRiemann hn) + exact ⟨genus, threshold, P, hRiemann, hP0, hPdegree, hP⟩ + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionLocalPoleQuotient.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionLocalPoleQuotient.lean new file mode 100644 index 0000000000..0aa4fad566 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionLocalPoleQuotient.lean @@ -0,0 +1,505 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.DVRLocalPoleOrder +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionLocalPoleSpace +public import LeanPool.MarkoffModP.BGS.HasseWeil.LocalPoleCumulativeQuotient +public import LeanPool.MarkoffModP.BGS.HasseWeil.RiemannSpaceInfinityPlaceIncrement + +/-! +# Exact local principal-part dimensions at exhaustive places + +The abstract DVR calculation in `LocalPoleFiltration` is instantiated at +both the finite and infinity places of a finite separable extension of +`K(X)`. Thus every successive local pole layer has dimension exactly the +degree of the corresponding exhaustive place. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +open BGS.CorvajaZannier +open IsDedekindDomain +open scoped nonZeroDivisors Polynomial + +noncomputable section + + +variable (K : Type*) [Field K] [Fintype K] [DecidableEq K] + [DecidableEq (RatFunc K)] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +local instance localQuotientConstantAlgebra : Algebra K L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K (RatFunc K))) + +local instance localQuotientConstantTower : IsScalarTower K (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + +section FinitePlace + +local instance (priority := 10) localQuotientPolynomialAlgebra : Algebra K[X] L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K[X] (RatFunc K))) + +local instance localQuotientPolynomialTower : IsScalarTower K[X] (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + +local instance localQuotientFiniteClosureConstantAlgebra : + Algebra K (RatFuncFiniteIntegralClosure K L) := + RingHom.toAlgebra + ((algebraMap K[X] (RatFuncFiniteIntegralClosure K L)).comp + (algebraMap K K[X])) + +local instance localQuotientFiniteClosureConstantTower : + IsScalarTower K K[X] (RatFuncFiniteIntegralClosure K L) := + IsScalarTower.of_algebraMap_eq' rfl + +local instance localQuotientFiniteClosureIsIntegral : + Algebra.IsIntegral K[X] (RatFuncFiniteIntegralClosure K L) := + IsIntegralClosure.isIntegral_algebra K[X] L + +local instance localQuotientFiniteClosureModuleFinite : + Module.Finite K[X] (RatFuncFiniteIntegralClosure K L) := + Module.IsNoetherian.finite K[X] (RatFuncFiniteIntegralClosure K L) + +local instance localQuotientPolynomialTorsionFreeTop : + Module.IsTorsionFree K[X] L := + Module.IsTorsionFree.trans_faithfulSMul K[X] (RatFunc K) L + +local instance localQuotientFiniteClosureTorsionFree : + Module.IsTorsionFree K[X] (RatFuncFiniteIntegralClosure K L) := + IsIntegralClosure.isTorsionFree K[X] L + +local instance localQuotientFiniteClosureDedekind : + IsDedekindDomain (RatFuncFiniteIntegralClosure K L) := + IsIntegralClosure.isDedekindDomain K[X] (RatFunc K) L + (RatFuncFiniteIntegralClosure K L) + +local instance localQuotientFiniteClosureFractionRing : + IsFractionRing (RatFuncFiniteIntegralClosure K L) L := + IsIntegralClosure.isFractionRing_of_finite_extension + K[X] (RatFunc K) L (RatFuncFiniteIntegralClosure K L) + +/-- Every finite-place local principal-part layer has dimension exactly the +degree of that place. -/ +theorem finiteExtensionLocalPoleSpace_inl_step_finrank + (q : FiniteExtensionFinitePlace K L) (n : ℕ) : + Module.finrank K + (finiteExtensionLocalPoleSpace K L (.inl q) (n + 1) ⧸ + Submodule.comap + (finiteExtensionLocalPoleSpace K L (.inl q) (n + 1)).subtype + (finiteExtensionLocalPoleSpace K L (.inl q) n)) = + finiteExtensionPlaceDegree K L (.inl q) := by + let A := RatFuncFiniteIntegralClosure K L + let R := FiniteExtensionFinitePlaceLocalRing K L q + let : Algebra A A := Algebra.id A + let localA : Algebra A R := OreLocalization.instAlgebra + let := localA + let : SMul A R := localA.toSMul + let : Algebra K R := OreLocalization.instAlgebra + let := finiteExtensionFinitePlaceLocalAlgebra (K := K) (L := L) q + let := finiteExtensionFinitePlaceLocalIsFractionRing (K := K) (L := L) q + let : IsScalarTower K R L := by + apply IsScalarTower.of_algebraMap_eq' + ext c + symm + change finiteExtensionFinitePlaceLocalizationToField + (K := K) (L := L) q (algebraMap K R c) = algebraMap K L c + rw [show algebraMap K R c = algebraMap A R (algebraMap K A c) by rfl] + rw [show finiteExtensionFinitePlaceLocalizationToField + (K := K) (L := L) q (algebraMap A R (algebraMap K A c)) = + algebraMap A L (algebraMap K A c) by + exact DFunLike.congr_fun + (finiteExtensionFinitePlaceLocalizationToField_comp_algebraMap + (K := K) (L := L) q) (algebraMap K A c)] + rfl + let : IsDiscreteValuationRing R := + IsLocalization.AtPrime.isDiscreteValuationRing_of_dedekind_domain + A q.ne_bot R + obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible R + have hπIdeal : + (IsDiscreteValuationRing.maximalIdeal R).asIdeal = Ideal.span {π} := + (IsDiscreteValuationRing.irreducible_iff_uniformizer π).mp hπ + have hspace (m : ℕ) : + finiteExtensionLocalPoleSpace K L (.inl q) m = + localPoleSpace (K := K) (L := L) π m := by + ext x + rw [mem_finiteExtensionLocalPoleSpace_iff, + mem_localPoleSpace_iff_finitePlaceOrder π hπ hπIdeal] + change (x = 0 ∨ (x ≠ 0 ∧ + -(m : ℤ) ≤ finiteExtensionPrincipalDivisor K L x (.inl q))) ↔ + (x = 0 ∨ (x ≠ 0 ∧ + -(m : ℤ) ≤ finiteExtensionFinitePlaceLocalOrder + (K := K) (L := L) q x)) + rw [finiteExtensionFinitePlaceLocalOrder_eq_globalOrder, + ← finiteExtensionPrincipalDivisor_inl_eq_finitePlaceOrder] + let : Finite (IsLocalRing.ResidueField R) := by + simpa [R] using + finiteExtensionFinitePlace_residueField_finite (K := K) (L := L) q + let : Module.Finite K (IsLocalRing.ResidueField R) := Module.Finite.of_finite + rw [hspace (n + 1), hspace n] + calc + Module.finrank K + (localPoleSpace (K := K) (L := L) π (n + 1) ⧸ + Submodule.comap + (localPoleSpace (K := K) (L := L) π (n + 1)).subtype + (localPoleSpace (K := K) (L := L) π n)) = + Module.finrank K (IsLocalRing.ResidueField R) := + localPoleQuotient_finrank π hπ.ne_zero hπIdeal n + _ = finiteExtensionPlaceDegree K L (.inl q) := by + simpa [R] using + (finiteExtensionFinitePlace_degree_eq_finrank_residueField K L q).symm + +/-- The finite-place principal parts through order `n` have dimension +`n` times the degree of the place. -/ +theorem finiteExtensionLocalPoleSpace_inl_cumulative_finrank + (q : FiniteExtensionFinitePlace K L) (n : ℕ) : + Module.finrank K + (finiteExtensionLocalPoleSpace K L (.inl q) n ⧸ + Submodule.comap + (finiteExtensionLocalPoleSpace K L (.inl q) n).subtype + (finiteExtensionLocalPoleSpace K L (.inl q) 0)) = + n * finiteExtensionPlaceDegree K L (.inl q) := by + let A := RatFuncFiniteIntegralClosure K L + let R := FiniteExtensionFinitePlaceLocalRing K L q + let : Algebra A A := Algebra.id A + let localA : Algebra A R := OreLocalization.instAlgebra + let := localA + let : SMul A R := localA.toSMul + let : Algebra K R := OreLocalization.instAlgebra + let := finiteExtensionFinitePlaceLocalAlgebra (K := K) (L := L) q + let := finiteExtensionFinitePlaceLocalIsFractionRing (K := K) (L := L) q + let : IsScalarTower K R L := by + apply IsScalarTower.of_algebraMap_eq' + ext c + symm + change finiteExtensionFinitePlaceLocalizationToField + (K := K) (L := L) q (algebraMap K R c) = algebraMap K L c + rw [show algebraMap K R c = algebraMap A R (algebraMap K A c) by rfl] + rw [show finiteExtensionFinitePlaceLocalizationToField + (K := K) (L := L) q (algebraMap A R (algebraMap K A c)) = + algebraMap A L (algebraMap K A c) by + exact DFunLike.congr_fun + (finiteExtensionFinitePlaceLocalizationToField_comp_algebraMap + (K := K) (L := L) q) (algebraMap K A c)] + rfl + let : IsDiscreteValuationRing R := + IsLocalization.AtPrime.isDiscreteValuationRing_of_dedekind_domain + A q.ne_bot R + obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible R + have hπIdeal : + (IsDiscreteValuationRing.maximalIdeal R).asIdeal = Ideal.span {π} := + (IsDiscreteValuationRing.irreducible_iff_uniformizer π).mp hπ + have hspace (m : ℕ) : + finiteExtensionLocalPoleSpace K L (.inl q) m = + localPoleSpace (K := K) (L := L) π m := by + ext x + rw [mem_finiteExtensionLocalPoleSpace_iff, + mem_localPoleSpace_iff_finitePlaceOrder π hπ hπIdeal] + change (x = 0 ∨ (x ≠ 0 ∧ + -(m : ℤ) ≤ finiteExtensionPrincipalDivisor K L x (.inl q))) ↔ + (x = 0 ∨ (x ≠ 0 ∧ + -(m : ℤ) ≤ finiteExtensionFinitePlaceLocalOrder + (K := K) (L := L) q x)) + rw [finiteExtensionFinitePlaceLocalOrder_eq_globalOrder, + ← finiteExtensionPrincipalDivisor_inl_eq_finitePlaceOrder] + let : Finite (IsLocalRing.ResidueField R) := by + simpa [R] using + finiteExtensionFinitePlace_residueField_finite (K := K) (L := L) q + rw [hspace n, hspace 0] + calc + Module.finrank K + (localPoleSpace (K := K) (L := L) π n ⧸ + Submodule.comap + (localPoleSpace (K := K) (L := L) π n).subtype + (localPoleSpace (K := K) (L := L) π 0)) = + n * Module.finrank K (IsLocalRing.ResidueField R) := + localPoleCumulativeQuotient_finrank π hπ.ne_zero hπIdeal n + _ = n * finiteExtensionPlaceDegree K L (.inl q) := by + congr 1 + simpa [R] using + (finiteExtensionFinitePlace_degree_eq_finrank_residueField K L q).symm + +end FinitePlace + +section InfinityPlace + +local instance localQuotientInfinityConstantAlgebra : + Algebra K (RatFuncInfinityIntegers K) := + (ratFuncInfinityConstantRingHom K).toAlgebra + +local instance localQuotientInfinityClosureConstantAlgebra : + Algebra K (RatFuncInfinityIntegralClosure K L) := + RingHom.toAlgebra + ((algebraMap (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L)).comp + (algebraMap K (RatFuncInfinityIntegers K))) + +local instance localQuotientInfinityClosureConstantTower : + IsScalarTower K (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) := + IsScalarTower.of_algebraMap_eq' rfl + +local instance localQuotientInfinityClosureModuleFinite : + Module.Finite (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.finite (RatFuncInfinityIntegers K) (RatFunc K) L + (RatFuncInfinityIntegralClosure K L) + +local instance localQuotientInfinityClosureIsIntegral : + Algebra.IsIntegral (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.isIntegral_algebra (RatFuncInfinityIntegers K) L + +local instance localQuotientInfinityBaseTorsionFreeTop : + Module.IsTorsionFree (RatFuncInfinityIntegers K) L := + Module.IsTorsionFree.trans_faithfulSMul + (RatFuncInfinityIntegers K) (RatFunc K) L + +local instance localQuotientInfinityClosureTorsionFree : + Module.IsTorsionFree (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.isTorsionFree (RatFuncInfinityIntegers K) L + +local instance localQuotientInfinityClosureDedekind : + IsDedekindDomain (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.isDedekindDomain + (RatFuncInfinityIntegers K) (RatFunc K) L + (RatFuncInfinityIntegralClosure K L) + +local instance localQuotientInfinityClosureFractionRing : + IsFractionRing (RatFuncInfinityIntegralClosure K L) L := + IsIntegralClosure.isFractionRing_of_finite_extension + (RatFuncInfinityIntegers K) (RatFunc K) L + (RatFuncInfinityIntegralClosure K L) + +local instance localQuotientInfinityClosureConstantTowerToField : + IsScalarTower K (RatFuncInfinityIntegralClosure K L) L := by + apply IsScalarTower.of_algebraMap_eq' + ext c + simp only [RingHom.comp_apply] + rw [IsScalarTower.algebraMap_apply K (RatFunc K) L] + rfl + +private noncomputable def localQuotientInfinityResidueFieldAlgEquivOfIdealEq + {I J : Ideal (RatFuncInfinityIntegralClosure K L)} + [I.IsPrime] [J.IsPrime] (h : I = J) : + I.ResidueField ≃ₐ[K] J.ResidueField := by + subst J + exact AlgEquiv.refl + +private noncomputable def localQuotientInfinityResidueFieldAlgEquiv + (P : FiniteExtensionInfinityPlace K L) : + (primeOverHeightOne (ratFuncInfinityPlace K) P).asIdeal.ResidueField + ≃ₐ[K] P.1.ResidueField := + localQuotientInfinityResidueFieldAlgEquivOfIdealEq K L + (primeOverHeightOne_asIdeal (ratFuncInfinityPlace K) P) + +/-- Every infinity-place local principal-part layer has dimension exactly +the degree of that place. -/ +theorem finiteExtensionLocalPoleSpace_inr_step_finrank + (P : FiniteExtensionInfinityPlace K L) (n : ℕ) : + Module.finrank K + (finiteExtensionLocalPoleSpace K L (.inr P) (n + 1) ⧸ + Submodule.comap + (finiteExtensionLocalPoleSpace K L (.inr P) (n + 1)).subtype + (finiteExtensionLocalPoleSpace K L (.inr P) n)) = + finiteExtensionPlaceDegree K L (.inr P) := by + let A := RatFuncInfinityIntegralClosure K L + let R := FiniteExtensionInfinityPlaceLocalRing K L P + let : Algebra A A := Algebra.id A + let localA : Algebra A R := OreLocalization.instAlgebra + let := localA + let : SMul A R := localA.toSMul + let : Algebra K R := OreLocalization.instAlgebra + let := finiteExtensionInfinityPlaceLocalAlgebra (K := K) (L := L) P + let := finiteExtensionInfinityPlaceLocalIsFractionRing (K := K) (L := L) P + let : IsScalarTower K R L := by + apply IsScalarTower.of_algebraMap_eq' + ext c + symm + change finiteExtensionInfinityPlaceLocalizationToField + (K := K) (L := L) P (algebraMap K R c) = algebraMap K L c + rw [show algebraMap K R c = algebraMap A R (algebraMap K A c) by rfl] + rw [show finiteExtensionInfinityPlaceLocalizationToField + (K := K) (L := L) P (algebraMap A R (algebraMap K A c)) = + algebraMap A L (algebraMap K A c) by + exact DFunLike.congr_fun + (finiteExtensionInfinityPlaceLocalizationToField_comp_algebraMap + (K := K) (L := L) P) (algebraMap K A c)] + exact (IsScalarTower.algebraMap_apply K A L c).symm + let : IsDiscreteValuationRing R := + IsLocalization.AtPrime.isDiscreteValuationRing_of_dedekind_domain + A (primeOverHeightOne (ratFuncInfinityPlace K) P).ne_bot R + obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible R + have hπIdeal : + (IsDiscreteValuationRing.maximalIdeal R).asIdeal = Ideal.span {π} := + (IsDiscreteValuationRing.irreducible_iff_uniformizer π).mp hπ + have hspace (m : ℕ) : + finiteExtensionLocalPoleSpace K L (.inr P) m = + localPoleSpace (K := K) (L := L) π m := by + ext x + rw [mem_finiteExtensionLocalPoleSpace_iff, + mem_localPoleSpace_iff_finitePlaceOrder π hπ hπIdeal] + change (x = 0 ∨ (x ≠ 0 ∧ + -(m : ℤ) ≤ finiteExtensionPrincipalDivisor K L x (.inr P))) ↔ + (x = 0 ∨ (x ≠ 0 ∧ + -(m : ℤ) ≤ finiteExtensionInfinityPlaceLocalOrder + (K := K) (L := L) P x)) + rw [finiteExtensionInfinityPlaceLocalOrder_eq_globalOrder, + ← finiteExtensionPrincipalDivisor_inr_eq_infinityPlaceOrder] + let : Finite (IsLocalRing.ResidueField R) := by + let : Finite P.1.ResidueField := + finiteExtensionInfinityPlace_residueField_finite (K := K) (L := L) P + change Finite + (primeOverHeightOne (ratFuncInfinityPlace K) P).asIdeal.ResidueField + exact Finite.of_injective + (localQuotientInfinityResidueFieldAlgEquiv K L P) + (localQuotientInfinityResidueFieldAlgEquiv K L P).injective + let : Module.Finite K (IsLocalRing.ResidueField R) := Module.Finite.of_finite + rw [hspace (n + 1), hspace n] + calc + Module.finrank K + (localPoleSpace (K := K) (L := L) π (n + 1) ⧸ + Submodule.comap + (localPoleSpace (K := K) (L := L) π (n + 1)).subtype + (localPoleSpace (K := K) (L := L) π n)) = + Module.finrank K (IsLocalRing.ResidueField R) := + localPoleQuotient_finrank π hπ.ne_zero hπIdeal n + _ = finiteExtensionPlaceDegree K L (.inr P) := by + change Module.finrank K + (primeOverHeightOne (ratFuncInfinityPlace K) P).asIdeal.ResidueField = _ + calc + Module.finrank K + (primeOverHeightOne (ratFuncInfinityPlace K) P).asIdeal.ResidueField = + Module.finrank K P.1.ResidueField := + (localQuotientInfinityResidueFieldAlgEquiv K L P).toLinearEquiv.finrank_eq + _ = finiteExtensionPlaceDegree K L (.inr P) := + (finiteExtensionInfinityPlace_degree_eq_finrank_residueField K L P).symm + +/-- The infinity-place principal parts through order `n` have dimension +`n` times the degree of the place. -/ +theorem finiteExtensionLocalPoleSpace_inr_cumulative_finrank + (P : FiniteExtensionInfinityPlace K L) (n : ℕ) : + Module.finrank K + (finiteExtensionLocalPoleSpace K L (.inr P) n ⧸ + Submodule.comap + (finiteExtensionLocalPoleSpace K L (.inr P) n).subtype + (finiteExtensionLocalPoleSpace K L (.inr P) 0)) = + n * finiteExtensionPlaceDegree K L (.inr P) := by + let A := RatFuncInfinityIntegralClosure K L + let R := FiniteExtensionInfinityPlaceLocalRing K L P + let : Algebra A A := Algebra.id A + let localA : Algebra A R := OreLocalization.instAlgebra + let := localA + let : SMul A R := localA.toSMul + let : Algebra K R := OreLocalization.instAlgebra + let := finiteExtensionInfinityPlaceLocalAlgebra (K := K) (L := L) P + let := finiteExtensionInfinityPlaceLocalIsFractionRing (K := K) (L := L) P + let : IsScalarTower K R L := by + apply IsScalarTower.of_algebraMap_eq' + ext c + symm + change finiteExtensionInfinityPlaceLocalizationToField + (K := K) (L := L) P (algebraMap K R c) = algebraMap K L c + rw [show algebraMap K R c = algebraMap A R (algebraMap K A c) by rfl] + rw [show finiteExtensionInfinityPlaceLocalizationToField + (K := K) (L := L) P (algebraMap A R (algebraMap K A c)) = + algebraMap A L (algebraMap K A c) by + exact DFunLike.congr_fun + (finiteExtensionInfinityPlaceLocalizationToField_comp_algebraMap + (K := K) (L := L) P) (algebraMap K A c)] + exact (IsScalarTower.algebraMap_apply K A L c).symm + let : IsDiscreteValuationRing R := + IsLocalization.AtPrime.isDiscreteValuationRing_of_dedekind_domain + A (primeOverHeightOne (ratFuncInfinityPlace K) P).ne_bot R + obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible R + have hπIdeal : + (IsDiscreteValuationRing.maximalIdeal R).asIdeal = Ideal.span {π} := + (IsDiscreteValuationRing.irreducible_iff_uniformizer π).mp hπ + have hspace (m : ℕ) : + finiteExtensionLocalPoleSpace K L (.inr P) m = + localPoleSpace (K := K) (L := L) π m := by + ext x + rw [mem_finiteExtensionLocalPoleSpace_iff, + mem_localPoleSpace_iff_finitePlaceOrder π hπ hπIdeal] + change (x = 0 ∨ (x ≠ 0 ∧ + -(m : ℤ) ≤ finiteExtensionPrincipalDivisor K L x (.inr P))) ↔ + (x = 0 ∨ (x ≠ 0 ∧ + -(m : ℤ) ≤ finiteExtensionInfinityPlaceLocalOrder + (K := K) (L := L) P x)) + rw [finiteExtensionInfinityPlaceLocalOrder_eq_globalOrder, + ← finiteExtensionPrincipalDivisor_inr_eq_infinityPlaceOrder] + let : Finite (IsLocalRing.ResidueField R) := by + let : Finite P.1.ResidueField := + finiteExtensionInfinityPlace_residueField_finite (K := K) (L := L) P + change Finite + (primeOverHeightOne (ratFuncInfinityPlace K) P).asIdeal.ResidueField + exact Finite.of_injective + (localQuotientInfinityResidueFieldAlgEquiv K L P) + (localQuotientInfinityResidueFieldAlgEquiv K L P).injective + rw [hspace n, hspace 0] + calc + Module.finrank K + (localPoleSpace (K := K) (L := L) π n ⧸ + Submodule.comap + (localPoleSpace (K := K) (L := L) π n).subtype + (localPoleSpace (K := K) (L := L) π 0)) = + n * Module.finrank K (IsLocalRing.ResidueField R) := + localPoleCumulativeQuotient_finrank π hπ.ne_zero hπIdeal n + _ = n * finiteExtensionPlaceDegree K L (.inr P) := by + congr 1 + change Module.finrank K + (primeOverHeightOne (ratFuncInfinityPlace K) P).asIdeal.ResidueField = _ + calc + Module.finrank K + (primeOverHeightOne (ratFuncInfinityPlace K) P).asIdeal.ResidueField = + Module.finrank K P.1.ResidueField := + (localQuotientInfinityResidueFieldAlgEquiv K L P).toLinearEquiv.finrank_eq + _ = finiteExtensionPlaceDegree K L (.inr P) := + (finiteExtensionInfinityPlace_degree_eq_finrank_residueField K L P).symm + +end InfinityPlace + +/-- At every exhaustive place, each successive local pole layer has exact +dimension equal to the place degree. -/ +theorem finiteExtensionLocalPoleSpace_step_finrank + (P : FiniteExtensionPlace K L) (n : ℕ) : + Module.finrank K + (finiteExtensionLocalPoleSpace K L P (n + 1) ⧸ + Submodule.comap + (finiteExtensionLocalPoleSpace K L P (n + 1)).subtype + (finiteExtensionLocalPoleSpace K L P n)) = + finiteExtensionPlaceDegree K L P := by + cases P with + | inl q => exact finiteExtensionLocalPoleSpace_inl_step_finrank K L q n + | inr P => exact finiteExtensionLocalPoleSpace_inr_step_finrank K L P n + +/-- At every exhaustive place, the principal parts through order `n` have +dimension `n` times the place degree. -/ +theorem finiteExtensionLocalPoleSpace_cumulative_finrank + (P : FiniteExtensionPlace K L) (n : ℕ) : + Module.finrank K + (finiteExtensionLocalPoleSpace K L P n ⧸ + Submodule.comap + (finiteExtensionLocalPoleSpace K L P n).subtype + (finiteExtensionLocalPoleSpace K L P 0)) = + n * finiteExtensionPlaceDegree K L P := by + cases P with + | inl q => + exact finiteExtensionLocalPoleSpace_inl_cumulative_finrank K L q n + | inr P => + exact finiteExtensionLocalPoleSpace_inr_cumulative_finrank K L P n + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionLocalPoleSpace.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionLocalPoleSpace.lean new file mode 100644 index 0000000000..e406125ac0 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionLocalPoleSpace.lean @@ -0,0 +1,197 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionRiemannSpace + +/-! +# Local and away-regular subspaces of a function field + +For an exhaustive place `P`, the one-point Riemann space is the intersection +of two elementary subspaces: functions with a bounded pole at `P`, and +functions regular at every place away from `P`. This is the two-open-cover +decomposition used by the Cech form of Riemann's inequality. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +open BGS.CorvajaZannier + +noncomputable section + +variable (K : Type*) [Field K] [Fintype K] [DecidableEq K] + [DecidableEq (RatFunc K)] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +local instance localPoleConstantAlgebra : Algebra K L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K (RatFunc K))) + +local instance localPoleConstantTower : IsScalarTower K (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + +/-- Functions whose pole at `P` has order at most `n`, with no condition at +the other places. -/ +def finiteExtensionLocalPoleSpace + (P : FiniteExtensionPlace K L) (n : ℕ) : Submodule K L where + carrier := {x | x = 0 ∨ + (x ≠ 0 ∧ -(n : ℤ) ≤ finiteExtensionPrincipalDivisor K L x P)} + zero_mem' := Or.inl rfl + add_mem' := by + rintro x y (hx0 | ⟨hx0, hx⟩) (hy0 | ⟨hy0, hy⟩) + · exact Or.inl (by simp [hx0, hy0]) + · subst x + simpa using + (Or.inr ⟨hy0, hy⟩ : y = 0 ∨ + (y ≠ 0 ∧ -(n : ℤ) ≤ finiteExtensionPrincipalDivisor K L y P)) + · subst y + simpa using + (Or.inr ⟨hx0, hx⟩ : x = 0 ∨ + (x ≠ 0 ∧ -(n : ℤ) ≤ finiteExtensionPrincipalDivisor K L x P)) + · by_cases hxy : x + y = 0 + · exact Or.inl hxy + · refine Or.inr ⟨hxy, ?_⟩ + exact le_trans (le_min hx hy) + (finiteExtensionPrincipalDivisor_add_ge_min + K L x y hx0 hy0 hxy P) + smul_mem' := by + intro c x hx + by_cases hc : c = 0 + · subst c + exact Or.inl (zero_smul K x) + rcases hx with hx | ⟨hx, horder⟩ + · subst x + exact Or.inl (smul_zero c) + · have hcL : algebraMap K L c ≠ 0 := by + simpa only [map_zero] using (algebraMap K L).injective.ne hc + have hcx : c • x ≠ 0 := by + rw [Algebra.smul_def] + exact mul_ne_zero hcL hx + refine Or.inr ⟨hcx, ?_⟩ + rw [Algebra.smul_def, + finiteExtensionPrincipalDivisor_mul K L _ _ hcL hx, + finiteExtensionPrincipalDivisor_algebraMap_constant K L c hc] + simpa using horder + +@[simp] +theorem mem_finiteExtensionLocalPoleSpace_iff + (P : FiniteExtensionPlace K L) (n : ℕ) (x : L) : + x ∈ finiteExtensionLocalPoleSpace K L P n ↔ + x = 0 ∨ + (x ≠ 0 ∧ -(n : ℤ) ≤ finiteExtensionPrincipalDivisor K L x P) := + Iff.rfl + +/-- Functions regular at every exhaustive place other than `P`. -/ +def finiteExtensionAwayRegularSpace + (P : FiniteExtensionPlace K L) : Submodule K L where + carrier := {x | x = 0 ∨ + (x ≠ 0 ∧ ∀ v, v ≠ P → 0 ≤ finiteExtensionPrincipalDivisor K L x v)} + zero_mem' := Or.inl rfl + add_mem' := by + rintro x y (hx0 | ⟨hx0, hx⟩) (hy0 | ⟨hy0, hy⟩) + · exact Or.inl (by simp [hx0, hy0]) + · subst x + simpa only [zero_add, Set.mem_ofPred_eq] using + (Or.inr ⟨hy0, hy⟩ : y = 0 ∨ + (y ≠ 0 ∧ ∀ v, v ≠ P → + 0 ≤ finiteExtensionPrincipalDivisor K L y v)) + · subst y + simpa only [add_zero, Set.mem_ofPred_eq] using + (Or.inr ⟨hx0, hx⟩ : x = 0 ∨ + (x ≠ 0 ∧ ∀ v, v ≠ P → + 0 ≤ finiteExtensionPrincipalDivisor K L x v)) + · by_cases hxy : x + y = 0 + · exact Or.inl hxy + · refine Or.inr ⟨hxy, ?_⟩ + intro v hv + exact le_trans (le_min (hx v hv) (hy v hv)) + (finiteExtensionPrincipalDivisor_add_ge_min + K L x y hx0 hy0 hxy v) + smul_mem' := by + intro c x hx + by_cases hc : c = 0 + · subst c + exact Or.inl (zero_smul K x) + rcases hx with hx | ⟨hx, horders⟩ + · subst x + exact Or.inl (smul_zero c) + · have hcL : algebraMap K L c ≠ 0 := by + simpa only [map_zero] using (algebraMap K L).injective.ne hc + have hcx : c • x ≠ 0 := by + rw [Algebra.smul_def] + exact mul_ne_zero hcL hx + refine Or.inr ⟨hcx, ?_⟩ + intro v hv + rw [Algebra.smul_def, + finiteExtensionPrincipalDivisor_mul K L _ _ hcL hx, + finiteExtensionPrincipalDivisor_algebraMap_constant K L c hc] + simpa using horders v hv + +@[simp] +theorem mem_finiteExtensionAwayRegularSpace_iff + (P : FiniteExtensionPlace K L) (x : L) : + x ∈ finiteExtensionAwayRegularSpace K L P ↔ + x = 0 ∨ + (x ≠ 0 ∧ ∀ v, v ≠ P → + 0 ≤ finiteExtensionPrincipalDivisor K L x v) := + Iff.rfl + +/-- The local pole filtration is increasing. -/ +theorem finiteExtensionLocalPoleSpace_mono + (P : FiniteExtensionPlace K L) {m n : ℕ} (hmn : m ≤ n) : + finiteExtensionLocalPoleSpace K L P m ≤ + finiteExtensionLocalPoleSpace K L P n := by + intro x hx + rw [mem_finiteExtensionLocalPoleSpace_iff] at hx ⊢ + rcases hx with rfl | ⟨hx0, hx⟩ + · exact Or.inl rfl + · have hmnZ : (m : ℤ) ≤ (n : ℤ) := by exact_mod_cast hmn + exact Or.inr ⟨hx0, le_trans (Int.neg_le_neg hmnZ) hx⟩ + +/-- The one-point Riemann space is the intersection of its local pole bound +and its away-regular condition. -/ +theorem finiteExtensionOnePointRiemannSpace_eq_inf + (P : FiniteExtensionPlace K L) (n : ℕ) : + finiteExtensionOnePointRiemannSpace K L P n = + finiteExtensionLocalPoleSpace K L P n ⊓ + finiteExtensionAwayRegularSpace K L P := by + ext x + rw [mem_finiteExtensionOnePointRiemannSpace_iff, + Submodule.mem_inf, mem_finiteExtensionLocalPoleSpace_iff, + mem_finiteExtensionAwayRegularSpace_iff] + constructor + · rintro (rfl | ⟨hx0, hP, hAway⟩) + · exact ⟨Or.inl rfl, Or.inl rfl⟩ + · exact ⟨Or.inr ⟨hx0, hP⟩, Or.inr ⟨hx0, hAway⟩⟩ + · rintro ⟨hlocal, hAway⟩ + rcases hlocal with rfl | ⟨hx0, hP⟩ + · exact Or.inl rfl + · rcases hAway with hzero | ⟨_, hAway⟩ + · exact (hx0 hzero).elim + · exact Or.inr ⟨hx0, hP, hAway⟩ + +/-- At level zero the same intersection is the all-place regular space. -/ +theorem finiteExtensionRiemannSpace_zero_eq_local_inf_away + (P : FiniteExtensionPlace K L) : + finiteExtensionRiemannSpace K L 0 = + finiteExtensionLocalPoleSpace K L P 0 ⊓ + finiteExtensionAwayRegularSpace K L P := by + rw [← finiteExtensionOnePointRiemannSpace_eq_inf K L P 0] + apply congrArg (finiteExtensionRiemannSpace K L) + ext v + by_cases hv : v = P + · subst v + simp + · simp + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionPlaceAlgEquiv.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionPlaceAlgEquiv.lean new file mode 100644 index 0000000000..6c4d89f95f --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionPlaceAlgEquiv.lean @@ -0,0 +1,440 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.FinitePlaceNormalizationTransport +public import LeanPool.MarkoffModP.BGS.HasseWeil.RationalPlace + +/-! +# Transporting function-field places across algebra equivalences + +An equivalence of finite extensions over `K(X)` identifies both normalization +charts. This file packages the induced equivalences of finite, infinity, and +exhaustive places and records preservation of absolute place degree. In +particular, rational-place counts depend only on the `K(X)`-algebra up to +equivalence, not on its chosen field presentation. +-/ + +@[expose] public section + +open scoped Polynomial + +namespace BGS.HasseWeil + +noncomputable section + +open BGS.CorvajaZannier +open IsDedekindDomain + + +section Fiber + +variable (R A : Type*) [CommRing R] [IsDomain R] + [CommRing A] [IsDomain A] [Algebra R A] + [Algebra.IsIntegral R A] [Module.IsTorsionFree R A] + +/-- A height-one prime restriction fiber is the usual type of primes above +the base prime. -/ +def heightOneSpectrumFiberEquivPrimesOver (p : HeightOneSpectrum R) : + {q : HeightOneSpectrum A // HeightOneSpectrum.under R q = p} ≃ + p.asIdeal.primesOver A where + toFun q := ⟨q.1.asIdeal, q.1.isPrime, ⟨by + have h := congrArg HeightOneSpectrum.asIdeal q.2 + exact h.symm⟩⟩ + invFun P := ⟨primeOverHeightOne p P, by + apply HeightOneSpectrum.ext + exact (Ideal.over_def P.1 p.asIdeal).symm⟩ + left_inv q := by + apply Subtype.ext + apply HeightOneSpectrum.ext + rfl + right_inv P := by + apply Subtype.ext + rfl + +end Fiber + +variable (K L M : Type*) [Field K] [DecidableEq K] + [DecidableEq (RatFunc K)] + [Field L] [Field M] + [Algebra (RatFunc K) L] [Algebra (RatFunc K) M] + [FiniteDimensional (RatFunc K) L] + [FiniteDimensional (RatFunc K) M] + [Algebra.IsSeparable (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) M] + +local instance (priority := 10) finiteAlgEquivPolynomialAlgebraLeft : + Algebra K[X] L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K[X] (RatFunc K))) + +local instance (priority := 10) finiteAlgEquivPolynomialAlgebraRight : + Algebra K[X] M := + RingHom.toAlgebra ((algebraMap (RatFunc K) M).comp + (algebraMap K[X] (RatFunc K))) + +local instance finiteAlgEquivPolynomialTowerLeft : + IsScalarTower K[X] (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' + (R := K[X]) (S := RatFunc K) (A := L) rfl + +local instance finiteAlgEquivPolynomialTowerRight : + IsScalarTower K[X] (RatFunc K) M := + IsScalarTower.of_algebraMap_eq' + (R := K[X]) (S := RatFunc K) (A := M) rfl + +local instance (priority := 10) finiteAlgEquivInfinityAlgebraLeft : + Algebra (RatFuncInfinityIntegers K) L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap (RatFuncInfinityIntegers K) (RatFunc K))) + +local instance (priority := 10) finiteAlgEquivInfinityAlgebraRight : + Algebra (RatFuncInfinityIntegers K) M := + RingHom.toAlgebra ((algebraMap (RatFunc K) M).comp + (algebraMap (RatFuncInfinityIntegers K) (RatFunc K))) + +local instance finiteAlgEquivInfinityTowerLeft : + IsScalarTower (RatFuncInfinityIntegers K) (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' + (R := RatFuncInfinityIntegers K) (S := RatFunc K) (A := L) rfl + +local instance finiteAlgEquivInfinityTowerRight : + IsScalarTower (RatFuncInfinityIntegers K) (RatFunc K) M := + IsScalarTower.of_algebraMap_eq' + (R := RatFuncInfinityIntegers K) (S := RatFunc K) (A := M) rfl + +local instance finiteAlgEquivInfinityConstantAlgebra : + Algebra K (RatFuncInfinityIntegers K) := + (ratFuncInfinityConstantRingHom K).toAlgebra + +local instance finiteAlgEquivInfinityConstantTower : + IsScalarTower K (RatFuncInfinityIntegers K) (RatFunc K) := + IsScalarTower.of_algebraMap_eq' + (R := K) (S := RatFuncInfinityIntegers K) (A := RatFunc K) rfl + +local instance finiteAlgEquivPolynomialTorsionFreeLeft : + Module.IsTorsionFree K[X] L := + Module.IsTorsionFree.trans_faithfulSMul K[X] (RatFunc K) L + +local instance finiteAlgEquivPolynomialTorsionFreeRight : + Module.IsTorsionFree K[X] M := + Module.IsTorsionFree.trans_faithfulSMul K[X] (RatFunc K) M + +local instance finiteAlgEquivFiniteClosureTorsionFreeLeft : + Module.IsTorsionFree K[X] (RatFuncFiniteIntegralClosure K L) := + IsIntegralClosure.isTorsionFree K[X] L + +local instance finiteAlgEquivFiniteClosureTorsionFreeRight : + Module.IsTorsionFree K[X] (RatFuncFiniteIntegralClosure K M) := + IsIntegralClosure.isTorsionFree K[X] M + +local instance finiteAlgEquivInfinityClosureTorsionFreeLeft : + Module.IsTorsionFree (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.isTorsionFree (RatFuncInfinityIntegers K) L + +local instance finiteAlgEquivInfinityClosureTorsionFreeRight : + Module.IsTorsionFree (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K M) := + IsIntegralClosure.isTorsionFree (RatFuncInfinityIntegers K) M + +local instance finiteAlgEquivFiniteClosureConstantAlgebraLeft : + Algebra K (RatFuncFiniteIntegralClosure K L) := + RingHom.toAlgebra ((algebraMap K[X] + (RatFuncFiniteIntegralClosure K L)).comp (algebraMap K K[X])) + +local instance finiteAlgEquivFiniteClosureConstantAlgebraRight : + Algebra K (RatFuncFiniteIntegralClosure K M) := + RingHom.toAlgebra ((algebraMap K[X] + (RatFuncFiniteIntegralClosure K M)).comp (algebraMap K K[X])) + +local instance finiteAlgEquivFiniteClosureConstantTowerLeft : + IsScalarTower K K[X] (RatFuncFiniteIntegralClosure K L) := + IsScalarTower.of_algebraMap_eq' + (R := K) (S := K[X]) (A := RatFuncFiniteIntegralClosure K L) rfl + +local instance finiteAlgEquivFiniteClosureConstantTowerRight : + IsScalarTower K K[X] (RatFuncFiniteIntegralClosure K M) := + IsScalarTower.of_algebraMap_eq' + (R := K) (S := K[X]) (A := RatFuncFiniteIntegralClosure K M) rfl + +local instance finiteAlgEquivInfinityClosureConstantAlgebraLeft : + Algebra K (RatFuncInfinityIntegralClosure K L) := + RingHom.toAlgebra ((algebraMap (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L)).comp + (algebraMap K (RatFuncInfinityIntegers K))) + +local instance finiteAlgEquivInfinityClosureConstantAlgebraRight : + Algebra K (RatFuncInfinityIntegralClosure K M) := + RingHom.toAlgebra ((algebraMap (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K M)).comp + (algebraMap K (RatFuncInfinityIntegers K))) + +local instance finiteAlgEquivInfinityClosureConstantTowerLeft : + IsScalarTower K (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) := + IsScalarTower.of_algebraMap_eq' + (R := K) (S := RatFuncInfinityIntegers K) + (A := RatFuncInfinityIntegralClosure K L) rfl + +local instance finiteAlgEquivInfinityClosureConstantTowerRight : + IsScalarTower K (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K M) := + IsScalarTower.of_algebraMap_eq' + (R := K) (S := RatFuncInfinityIntegers K) + (A := RatFuncInfinityIntegralClosure K M) rfl + +/-- A `K(X)`-algebra equivalence restricts to the finite normalization +charts. -/ +noncomputable def ratFuncFiniteIntegralClosureAlgEquivOfAlgEquiv + (e : L ≃ₐ[RatFunc K] M) : + RatFuncFiniteIntegralClosure K L ≃ₐ[K[X]] + RatFuncFiniteIntegralClosure K M := + (e.restrictScalars K[X]).mapIntegralClosure + +/-- A `K(X)`-algebra equivalence restricts to the infinity normalization +charts. -/ +noncomputable def ratFuncInfinityIntegralClosureAlgEquivOfAlgEquiv + (e : L ≃ₐ[RatFunc K] M) : + RatFuncInfinityIntegralClosure K L ≃ₐ[RatFuncInfinityIntegers K] + RatFuncInfinityIntegralClosure K M := + by + change integralClosure (RatFuncInfinityIntegers K) L ≃ₐ[ + RatFuncInfinityIntegers K] + integralClosure (RatFuncInfinityIntegers K) M + exact (e.restrictScalars + (RatFuncInfinityIntegers K)).mapIntegralClosure + +/-- Finite places are invariant under an equivalence of the ambient +`K(X)`-algebras. -/ +noncomputable def finiteExtensionFinitePlaceEquivOfAlgEquiv + (e : L ≃ₐ[RatFunc K] M) : + FiniteExtensionFinitePlace K L ≃ FiniteExtensionFinitePlace K M := + heightOneSpectrumEquivOfAlgEquiv + (ratFuncFiniteIntegralClosureAlgEquivOfAlgEquiv K L M e) + +/-- The residue fields of corresponding finite places are equivalent over +the constant field. -/ +noncomputable def finiteExtensionFinitePlaceResidueFieldAlgEquivOfAlgEquiv + (e : L ≃ₐ[RatFunc K] M) (Q : FiniteExtensionFinitePlace K L) : + Q.asIdeal.ResidueField ≃ₐ[K] + (finiteExtensionFinitePlaceEquivOfAlgEquiv K L M e Q).asIdeal.ResidueField := + heightOneSpectrumResidueFieldAlgEquiv + ((ratFuncFiniteIntegralClosureAlgEquivOfAlgEquiv K L M e).restrictScalars K) + Q + +/-- Infinity places are invariant under an equivalence of the ambient +`K(X)`-algebras. -/ +noncomputable def finiteExtensionInfinityPlaceEquivOfAlgEquiv + (e : L ≃ₐ[RatFunc K] M) : + FiniteExtensionInfinityPlace K L ≃ + FiniteExtensionInfinityPlace K M := by + let R := RatFuncInfinityIntegers K + let A := RatFuncInfinityIntegralClosure K L + let B := RatFuncInfinityIntegralClosure K M + let p := ratFuncInfinityPlace K + let eAB : A ≃ₐ[R] B := + ratFuncInfinityIntegralClosureAlgEquivOfAlgEquiv K L M e + let ePlaces : HeightOneSpectrum A ≃ HeightOneSpectrum B := + heightOneSpectrumEquivOfAlgEquiv eAB + let eFibers : + {q : HeightOneSpectrum A // HeightOneSpectrum.under R q = p} ≃ + {q : HeightOneSpectrum B // HeightOneSpectrum.under R q = p} := + { toFun := fun q => ⟨ePlaces q.1, by + calc + HeightOneSpectrum.under R (ePlaces q.1) = + HeightOneSpectrum.under R q.1 := by + exact heightOneSpectrumEquivOfAlgEquiv_under eAB q.1 + _ = p := q.2⟩ + invFun := fun q => ⟨ePlaces.symm q.1, by + calc + HeightOneSpectrum.under R (ePlaces.symm q.1) = + HeightOneSpectrum.under R q.1 := by + exact heightOneSpectrumEquivOfAlgEquiv_under eAB.symm q.1 + _ = p := q.2⟩ + left_inv := fun q => by + apply Subtype.ext + exact ePlaces.left_inv q.1 + right_inv := fun q => by + apply Subtype.ext + exact ePlaces.right_inv q.1 } + exact + (heightOneSpectrumFiberEquivPrimesOver R A p).symm.trans + (eFibers.trans (heightOneSpectrumFiberEquivPrimesOver R B p)) + +/-- Exhaustive places are invariant under an equivalence of the ambient +`K(X)`-algebras. -/ +noncomputable def finiteExtensionPlaceEquivOfAlgEquiv + (e : L ≃ₐ[RatFunc K] M) : + FiniteExtensionPlace K L ≃ FiniteExtensionPlace K M := + Equiv.sumCongr + (finiteExtensionFinitePlaceEquivOfAlgEquiv K L M e) + (finiteExtensionInfinityPlaceEquivOfAlgEquiv K L M e) + +/-- The absolute degree of a finite place is the dimension of its residue +field over the constant field. -/ +theorem finiteExtensionFinitePlace_degree_eq_residue_finrank + (Q : FiniteExtensionFinitePlace K L) : + finiteExtensionPlaceDegree K L (.inl Q) = + Module.finrank K Q.asIdeal.ResidueField := by + let P := HeightOneSpectrum.under K[X] Q + let : Q.asIdeal.LiesOver P.asIdeal := ⟨rfl⟩ + let hLocalAlg := + Localization.AtPrime.algebraOfLiesOver P.asIdeal Q.asIdeal + let _ : IsScalarTower K[X] (Localization.AtPrime P.asIdeal) + (Localization.AtPrime Q.asIdeal) := inferInstance + let _ : Module.Free P.asIdeal.ResidueField Q.asIdeal.ResidueField := + Module.Free.of_divisionRing P.asIdeal.ResidueField Q.asIdeal.ResidueField + rw [finiteExtensionPlaceDegree, Ideal.inertiaDeg_eq P.asIdeal Q.asIdeal] + rw [ratFuncFinitePlaceDegree_eq_finrank_residueField K P] + rw [mul_comm, Module.finrank_mul_finrank] + +omit [FiniteDimensional (RatFunc K) L] [Algebra.IsSeparable (RatFunc K) L] in +/-- The absolute degree of an infinity place is the dimension of its residue +field over the constant field. -/ +theorem finiteExtensionInfinityPlace_degree_eq_residue_finrank + (P : FiniteExtensionInfinityPlace K L) : + finiteExtensionPlaceDegree K L (.inr P) = + Module.finrank K P.1.ResidueField := by + let p := (ratFuncInfinityPlace K).asIdeal + let hLocalAlg := Localization.AtPrime.algebraOfLiesOver p P.1 + let _ : IsScalarTower (RatFuncInfinityIntegers K) (Localization.AtPrime p) + (Localization.AtPrime P.1) := inferInstance + let _ : Module.Free p.ResidueField P.1.ResidueField := + Module.Free.of_divisionRing p.ResidueField P.1.ResidueField + let : Algebra p.ResidueField P.1.ResidueField := + IsLocalRing.ResidueField.instAlgebra + let : IsScalarTower K p.ResidueField P.1.ResidueField := inferInstance + rw [finiteExtensionPlaceDegree, Ideal.inertiaDeg_eq p P.1] + have hbase : Module.finrank K p.ResidueField = 1 := + by simpa [p] using + (ratFuncInfinityPlaceResidueEquiv K).toLinearEquiv.finrank_eq + calc + Module.finrank p.ResidueField P.1.ResidueField = + 1 * Module.finrank p.ResidueField P.1.ResidueField := by simp + _ = Module.finrank K p.ResidueField * + Module.finrank p.ResidueField P.1.ResidueField := by rw [hbase] + _ = Module.finrank K P.1.ResidueField := + Module.finrank_mul_finrank K p.ResidueField P.1.ResidueField + +/-- Corresponding finite places have the same absolute degree. -/ +@[simp] +theorem finiteExtensionFinitePlaceEquivOfAlgEquiv_degree + (e : L ≃ₐ[RatFunc K] M) (Q : FiniteExtensionFinitePlace K L) : + finiteExtensionPlaceDegree K M + (.inl (finiteExtensionFinitePlaceEquivOfAlgEquiv K L M e Q)) = + finiteExtensionPlaceDegree K L (.inl Q) := by + calc + finiteExtensionPlaceDegree K M + (.inl (finiteExtensionFinitePlaceEquivOfAlgEquiv K L M e Q)) = + Module.finrank K + (finiteExtensionFinitePlaceEquivOfAlgEquiv K L M e Q).asIdeal.ResidueField := + finiteExtensionFinitePlace_degree_eq_residue_finrank K M _ + _ = Module.finrank K Q.asIdeal.ResidueField := + (finiteExtensionFinitePlaceResidueFieldAlgEquivOfAlgEquiv + K L M e Q).toLinearEquiv.finrank_eq.symm + _ = finiteExtensionPlaceDegree K L (.inl Q) := + (finiteExtensionFinitePlace_degree_eq_residue_finrank K L Q).symm + +omit [DecidableEq K] [FiniteDimensional (RatFunc K) L] [FiniteDimensional (RatFunc K) M] in +@[simp] +theorem finiteExtensionInfinityPlaceEquivOfAlgEquiv_asIdeal + (e : L ≃ₐ[RatFunc K] M) (P : FiniteExtensionInfinityPlace K L) : + (finiteExtensionInfinityPlaceEquivOfAlgEquiv K L M e P).1 = + P.1.comap + (ratFuncInfinityIntegralClosureAlgEquivOfAlgEquiv K L M e).symm := by + rfl + +/-- The residue fields of corresponding infinity places are equivalent over +the constant field. -/ +noncomputable def finiteExtensionInfinityPlaceResidueFieldAlgEquivOfAlgEquiv + (e : L ≃ₐ[RatFunc K] M) (P : FiniteExtensionInfinityPlace K L) : + P.1.ResidueField ≃ₐ[K] + (finiteExtensionInfinityPlaceEquivOfAlgEquiv K L M e P).1.ResidueField := by + let eInf := ratFuncInfinityIntegralClosureAlgEquivOfAlgEquiv K L M e + change P.1.ResidueField ≃ₐ[K] (P.1.comap eInf.symm).ResidueField + exact Ideal.residueFieldAlgEquiv P.1 (P.1.comap eInf.symm) + (eInf.restrictScalars K) (by + change P.1 = (P.1.comap eInf.symm).comap eInf + exact (Ideal.comap_of_equiv eInf.toRingEquiv).symm) + +omit [FiniteDimensional (RatFunc K) L] [FiniteDimensional (RatFunc K) M] in +/-- Corresponding infinity places have the same absolute degree. -/ +@[simp] +theorem finiteExtensionInfinityPlaceEquivOfAlgEquiv_degree + (e : L ≃ₐ[RatFunc K] M) (P : FiniteExtensionInfinityPlace K L) : + finiteExtensionPlaceDegree K M + (.inr (finiteExtensionInfinityPlaceEquivOfAlgEquiv K L M e P)) = + finiteExtensionPlaceDegree K L (.inr P) := by + calc + finiteExtensionPlaceDegree K M + (.inr (finiteExtensionInfinityPlaceEquivOfAlgEquiv K L M e P)) = + Module.finrank K + (finiteExtensionInfinityPlaceEquivOfAlgEquiv K L M e P).1.ResidueField := + finiteExtensionInfinityPlace_degree_eq_residue_finrank K M _ + _ = Module.finrank K P.1.ResidueField := + (finiteExtensionInfinityPlaceResidueFieldAlgEquivOfAlgEquiv + K L M e P).toLinearEquiv.finrank_eq.symm + _ = finiteExtensionPlaceDegree K L (.inr P) := + (finiteExtensionInfinityPlace_degree_eq_residue_finrank K L P).symm + +/-- The exhaustive place equivalence preserves absolute degree. -/ +@[simp] +theorem finiteExtensionPlaceEquivOfAlgEquiv_degree + (e : L ≃ₐ[RatFunc K] M) (P : FiniteExtensionPlace K L) : + finiteExtensionPlaceDegree K M + (finiteExtensionPlaceEquivOfAlgEquiv K L M e P) = + finiteExtensionPlaceDegree K L P := by + cases P with + | inl Q => + exact finiteExtensionFinitePlaceEquivOfAlgEquiv_degree K L M e Q + | inr Q => + exact finiteExtensionInfinityPlaceEquivOfAlgEquiv_degree K L M e Q + +/-- Degree-one finite places are invariant under a `K(X)`-algebra +equivalence. -/ +noncomputable def finiteExtensionRationalFinitePlaceEquivOfAlgEquiv + (e : L ≃ₐ[RatFunc K] M) : + FiniteExtensionRationalFinitePlace K L ≃ + FiniteExtensionRationalFinitePlace K M := + Equiv.subtypeEquiv + (finiteExtensionFinitePlaceEquivOfAlgEquiv K L M e) (by + intro Q + rw [finiteExtensionFinitePlaceEquivOfAlgEquiv_degree K L M e Q]) + +/-- Degree-one infinity places are invariant under a `K(X)`-algebra +equivalence. -/ +noncomputable def finiteExtensionRationalInfinityPlaceEquivOfAlgEquiv + (e : L ≃ₐ[RatFunc K] M) : + FiniteExtensionRationalInfinityPlace K L ≃ + FiniteExtensionRationalInfinityPlace K M := + Equiv.subtypeEquiv + (finiteExtensionInfinityPlaceEquivOfAlgEquiv K L M e) (by + intro P + rw [finiteExtensionInfinityPlaceEquivOfAlgEquiv_degree K L M e P]) + +/-- Complete degree-one place types are invariant under a `K(X)`-algebra +equivalence. -/ +noncomputable def finiteExtensionRationalPlaceEquivOfAlgEquiv + (e : L ≃ₐ[RatFunc K] M) : + FiniteExtensionRationalPlace K L ≃ + FiniteExtensionRationalPlace K M := + Equiv.sumCongr + (finiteExtensionRationalFinitePlaceEquivOfAlgEquiv K L M e) + (finiteExtensionRationalInfinityPlaceEquivOfAlgEquiv K L M e) + +/-- Complete rational-place counts are invariant under an equivalence of +finite `K(X)`-algebras. -/ +theorem finiteExtensionRationalPlaceCount_eq_of_algEquiv + (e : L ≃ₐ[RatFunc K] M) : + finiteExtensionRationalPlaceCount K L = + finiteExtensionRationalPlaceCount K M := + Nat.card_congr (finiteExtensionRationalPlaceEquivOfAlgEquiv K L M e) + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionPlaceDegreeFiniteness.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionPlaceDegreeFiniteness.lean new file mode 100644 index 0000000000..dbaaa9a046 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionPlaceDegreeFiniteness.lean @@ -0,0 +1,184 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionPlaceTower + +/-! +# Finiteness of bounded-degree places + +For a finite field `K`, there are only finitely many finite places of `K(X)` +of bounded degree: a place is represented by its normalized prime polynomial, +and a polynomial of bounded degree is determined by finitely many +coefficients. A finite place in a finite function-field extension lies over +one of these base places, with only finitely many primes in each fiber. + +This file proves the corresponding finiteness statements for base finite +places, finite places in an extension, and the exhaustive finite-plus-infinity +place type. These are the local-finiteness inputs needed to define effective +divisor counts and Euler products without assuming zeta rationality. +-/ + +@[expose] public section + +open scoped Polynomial + +namespace BGS.HasseWeil + +open BGS.CorvajaZannier + +noncomputable section + + +/-- Finite fields have only finitely many finite rational-function places of +degree at most `n`. -/ +theorem ratFuncFinitePlace_degree_le_finite + (K : Type*) [Field K] [Finite K] [DecidableEq K] (n : ℕ) : + Finite {p : IsDedekindDomain.HeightOneSpectrum K[X] // + ratFuncFinitePlaceDegree p ≤ n} := by + let f : {p : IsDedekindDomain.HeightOneSpectrum K[X] // + ratFuncFinitePlaceDegree p ≤ n} → Fin (n + 1) → K := + fun p i => (finitePlaceNormalizedPrime p.1 : K[X]).coeff i + apply Finite.of_injective f + intro p q hpq + apply Subtype.ext + have hr : finitePlaceNormalizedPrime p.1 = + finitePlaceNormalizedPrime q.1 := by + apply Subtype.ext + apply Polynomial.ext + intro m + by_cases hm : m ≤ n + · exact congrFun hpq ⟨m, Nat.lt_succ_iff.mpr hm⟩ + · have hnm : n < m := Nat.lt_of_not_ge hm + rw [Polynomial.coeff_eq_zero_of_natDegree_lt + (lt_of_le_of_lt p.2 hnm), + Polynomial.coeff_eq_zero_of_natDegree_lt + (lt_of_le_of_lt q.2 hnm)] + calc + p.1 = normalizedPrimeFinitePlace (K := K) + (finitePlaceNormalizedPrime p.1) := + (normalizedPrimeFinitePlace_finitePlaceNormalizedPrime p.1).symm + _ = normalizedPrimeFinitePlace (K := K) + (finitePlaceNormalizedPrime q.1) := + congrArg (normalizedPrimeFinitePlace (K := K)) hr + _ = q.1 := normalizedPrimeFinitePlace_finitePlaceNormalizedPrime q.1 + +/-- A finite extension of `K(X)` has only finitely many finite places of +degree at most `n`. -/ +theorem finiteExtensionFinitePlace_degree_le_finite + (K L : Type*) [Field K] [Finite K] [DecidableEq K] + [DecidableEq (RatFunc K)] [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] [Algebra.IsSeparable (RatFunc K) L] + (n : ℕ) : + Finite {q : FiniteExtensionFinitePlace K L // + finiteExtensionPlaceDegree K L (.inl q) ≤ n} := by + let : Algebra K[X] L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K[X] (RatFunc K))) + let : IsScalarTower K[X] (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + let : Module.Finite K[X] (RatFuncFiniteIntegralClosure K L) := + Module.IsNoetherian.finite K[X] (RatFuncFiniteIntegralClosure K L) + let : Algebra.IsIntegral K[X] (RatFuncFiniteIntegralClosure K L) := + IsIntegralClosure.isIntegral_algebra K[X] L + let : Module.IsTorsionFree K[X] L := + Module.IsTorsionFree.trans_faithfulSMul K[X] (RatFunc K) L + let : Module.IsTorsionFree K[X] (RatFuncFiniteIntegralClosure K L) := + IsIntegralClosure.isTorsionFree K[X] L + let Base := {p : IsDedekindDomain.HeightOneSpectrum K[X] // + ratFuncFinitePlaceDegree p ≤ n} + let Fiber : Base → Type _ := fun p => + p.1.asIdeal.primesOver (RatFuncFiniteIntegralClosure K L) + let : Finite Base := ratFuncFinitePlace_degree_le_finite K n + let : Fintype Base := Fintype.ofFinite Base + let (p : Base) : Fintype (Fiber p) := by + dsimp only [Fiber] + exact Set.Finite.fintype + (IsDedekindDomain.primesOver_finite p.1.asIdeal + (RatFuncFiniteIntegralClosure K L)) + let f : {q : FiniteExtensionFinitePlace K L // + finiteExtensionPlaceDegree K L (.inl q) ≤ n} → + Σ p : Base, Fiber p := fun q => by + let p := IsDedekindDomain.HeightOneSpectrum.under K[X] q.1 + have hp : ratFuncFinitePlaceDegree p ≤ n := by + apply (Nat.le_mul_of_pos_left _ + (Ideal.inertiaDeg_pos q.1.asIdeal K[X])).trans + simpa only [finiteExtensionPlaceDegree, p] using q.2 + exact ⟨⟨p, hp⟩, + (finitePlaceFiberEquivPrimesOver K L p) ⟨q.1, by simp [p]⟩⟩ + refine Finite.of_injective f ?_ + intro q r hqr + apply Subtype.ext + exact IsDedekindDomain.HeightOneSpectrum.ext + (congrArg (fun z : Σ p : Base, Fiber p => z.2.1) hqr) + +/-- A finite extension of `K(X)` has only finitely many exhaustive places of +degree at most `n`. The finite branch is the preceding theorem; the branch +above the unique base infinity place is finite without a degree restriction. -/ +theorem finiteExtensionPlace_degree_le_finite + (K L : Type*) [Field K] [Finite K] [DecidableEq K] + [DecidableEq (RatFunc K)] [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] [Algebra.IsSeparable (RatFunc K) L] + (n : ℕ) : + Finite {P : FiniteExtensionPlace K L // + finiteExtensionPlaceDegree K L P ≤ n} := by + let FinitePart := {q : FiniteExtensionFinitePlace K L // + finiteExtensionPlaceDegree K L (.inl q) ≤ n} + let : Finite FinitePart := + finiteExtensionFinitePlace_degree_le_finite K L n + let : Module.Finite (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.finite (RatFuncInfinityIntegers K) (RatFunc K) L + (RatFuncInfinityIntegralClosure K L) + let : Algebra.IsIntegral (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.isIntegral_algebra (RatFuncInfinityIntegers K) L + let : Module.IsTorsionFree (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.isTorsionFree (RatFuncInfinityIntegers K) L + let : IsDedekindDomain (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.isDedekindDomain (RatFuncInfinityIntegers K) + (RatFunc K) L (RatFuncInfinityIntegralClosure K L) + let : Fintype (FiniteExtensionInfinityPlace K L) := + Set.Finite.fintype + (IsDedekindDomain.primesOver_finite + (ratFuncInfinityPlace K).asIdeal + (RatFuncInfinityIntegralClosure K L)) + let f : {P : FiniteExtensionPlace K L // + finiteExtensionPlaceDegree K L P ≤ n} → + FinitePart ⊕ FiniteExtensionInfinityPlace K L + | ⟨.inl q, hq⟩ => .inl ⟨q, hq⟩ + | ⟨.inr Q, _⟩ => .inr Q + refine Finite.of_injective f ?_ + intro P Q h + apply Subtype.ext + cases P with + | mk P hP => + cases Q with + | mk Q hQ => + cases P <;> cases Q <;> simp only [f, Sum.inl.injEq, + Sum.inr.injEq, reduceCtorEq] at h ⊢ + · exact congrArg Subtype.val h + · exact h + +/-- A concrete finite type of exhaustive places of degree at most `n`. -/ +@[implicit_reducible] +noncomputable def finiteExtensionPlaceDegreeLEFintype + (K L : Type*) [Field K] [Fintype K] [DecidableEq K] + [DecidableEq (RatFunc K)] [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] [Algebra.IsSeparable (RatFunc K) L] + (n : ℕ) : + Fintype {P : FiniteExtensionPlace K L // + finiteExtensionPlaceDegree K L P ≤ n} := by + letI : Finite {P : FiniteExtensionPlace K L // + finiteExtensionPlaceDegree K L P ≤ n} := + finiteExtensionPlace_degree_le_finite K L n + exact Fintype.ofFinite _ + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionPlaceTower.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionPlaceTower.lean new file mode 100644 index 0000000000..2cda0f7df5 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionPlaceTower.lean @@ -0,0 +1,1354 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionPrincipalDivisor +public import LeanPool.MarkoffModP.BGS.HasseWeil.FixedPointAverage +public import Mathlib.NumberTheory.RamificationInertia.Galois +public import Mathlib.RingTheory.Invariant.Galois +public import Mathlib.RingTheory.RamificationInertia.Basic + +/-! +# Restriction of function-field places in a finite tower + +Stichtenoth's fixed-field proof of the Hasse--Weil lower bound compares +rational places in several intermediate fields of one Galois tower. This file +starts that tower API for the repository's exhaustive place type. It restricts +both finite places and places above infinity by contracting the corresponding +height-one prime through the integral closures. + +The construction is intrinsic to the field tower. It assumes no point-count +bound, zeta theorem, or Hasse--Weil statement. +-/ + +@[expose] public section + +open scoped BigOperators nonZeroDivisors Pointwise Polynomial +open IsDedekindDomain + +namespace BGS.HasseWeil + +noncomputable section + +open BGS.CorvajaZannier + +variable (K : Type*) [Field K] [DecidableEq K] [DecidableEq (RatFunc K)] +variable (M : Type*) [Field M] [Algebra (RatFunc K) M] + [FiniteDimensional (RatFunc K) M] + [Algebra.IsSeparable (RatFunc K) M] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + [Algebra M L] [IsScalarTower (RatFunc K) M L] + +local instance (priority := 10) finitePlaceTowerPolynomialAlgebraM : Algebra K[X] M := + RingHom.toAlgebra ((algebraMap (RatFunc K) M).comp + (algebraMap K[X] (RatFunc K))) + +local instance (priority := 10) finitePlaceTowerPolynomialAlgebraL : Algebra K[X] L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K[X] (RatFunc K))) + +local instance finitePlaceTowerPolynomialRatFuncM : + IsScalarTower K[X] (RatFunc K) M := + IsScalarTower.of_algebraMap_eq' rfl + +local instance finitePlaceTowerPolynomialRatFuncL : + IsScalarTower K[X] (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + +local instance finitePlaceTowerPolynomialFields : IsScalarTower K[X] M L := + IsScalarTower.of_algebraMap_eq fun x => by + change algebraMap (RatFunc K) L (algebraMap K[X] (RatFunc K) x) = + algebraMap M L + (algebraMap (RatFunc K) M (algebraMap K[X] (RatFunc K) x)) + exact IsScalarTower.algebraMap_apply (RatFunc K) M L _ + +/-- The field inclusion maps the finite integral closure in an intermediate +field into the finite integral closure in the top field. -/ +def finiteIntegralClosureMap : + RatFuncFiniteIntegralClosure K M →ₐ[K[X]] + RatFuncFiniteIntegralClosure K L := + (IsScalarTower.toAlgHom K[X] M L).mapIntegralClosure + +local instance finitePlaceTowerIntegralClosureAlgebra : + Algebra (RatFuncFiniteIntegralClosure K M) + (RatFuncFiniteIntegralClosure K L) := + (finiteIntegralClosureMap K M L).toAlgebra + +local instance finitePlaceTowerIntermediateIntegral : + Algebra.IsIntegral K[X] (RatFuncFiniteIntegralClosure K M) := + IsIntegralClosure.isIntegral_algebra K[X] M + +local instance finitePlaceTowerIntermediateModuleFinite : + Module.Finite K[X] (RatFuncFiniteIntegralClosure K M) := + Module.IsNoetherian.finite K[X] (RatFuncFiniteIntegralClosure K M) + +local instance finitePlaceTowerIntermediateTorsionFree : + Module.IsTorsionFree K[X] M := + Module.IsTorsionFree.trans_faithfulSMul K[X] (RatFunc K) M + +local instance finitePlaceTowerIntermediateClosureTorsionFree : + Module.IsTorsionFree K[X] (RatFuncFiniteIntegralClosure K M) := + IsIntegralClosure.isTorsionFree K[X] M + +local instance finitePlaceTowerIntermediateDedekind : + IsDedekindDomain (RatFuncFiniteIntegralClosure K M) := + IsIntegralClosure.isDedekindDomain K[X] (RatFunc K) M + (RatFuncFiniteIntegralClosure K M) + +local instance finitePlaceTowerBaseIntegral : + Algebra.IsIntegral K[X] (RatFuncFiniteIntegralClosure K L) := + IsIntegralClosure.isIntegral_algebra K[X] L + +local instance finitePlaceTowerTopModuleFinite : + Module.Finite K[X] (RatFuncFiniteIntegralClosure K L) := + Module.IsNoetherian.finite K[X] (RatFuncFiniteIntegralClosure K L) + +local instance finitePlaceTowerTopTorsionFree : + Module.IsTorsionFree K[X] L := + Module.IsTorsionFree.trans_faithfulSMul K[X] (RatFunc K) L + +local instance finitePlaceTowerTopClosureTorsionFree : + Module.IsTorsionFree K[X] (RatFuncFiniteIntegralClosure K L) := + IsIntegralClosure.isTorsionFree K[X] L + +local instance finitePlaceTowerTopDedekind : + IsDedekindDomain (RatFuncFiniteIntegralClosure K L) := + IsIntegralClosure.isDedekindDomain K[X] (RatFunc K) L + (RatFuncFiniteIntegralClosure K L) + +local instance finitePlaceTowerIntegralClosures : + IsScalarTower K[X] (RatFuncFiniteIntegralClosure K M) + (RatFuncFiniteIntegralClosure K L) := + IsScalarTower.of_algebraMap_eq fun _ => by + apply Subtype.ext + change algebraMap K[X] L _ = algebraMap M L (algebraMap K[X] M _) + exact IsScalarTower.algebraMap_apply K[X] M L _ + +local instance finitePlaceTowerTopIntegral : + Algebra.IsIntegral (RatFuncFiniteIntegralClosure K M) + (RatFuncFiniteIntegralClosure K L) := + Algebra.IsIntegral.tower_top K[X] + +local instance finitePlaceTowerFaithful : + FaithfulSMul (RatFuncFiniteIntegralClosure K M) + (RatFuncFiniteIntegralClosure K L) := by + rw [faithfulSMul_iff_algebraMap_injective] + intro x y hxy + apply Subtype.ext + apply (algebraMap M L).injective + exact congrArg Subtype.val hxy + +local instance finitePlaceTowerRelativeModuleFinite : + Module.Finite (RatFuncFiniteIntegralClosure K M) + (RatFuncFiniteIntegralClosure K L) := + Module.Finite.of_restrictScalars_finite K[X] + (RatFuncFiniteIntegralClosure K M) + (RatFuncFiniteIntegralClosure K L) + +local instance finitePlaceTowerIntermediateFractionRing : + IsFractionRing (RatFuncFiniteIntegralClosure K M) M := + IsIntegralClosure.isFractionRing_of_finite_extension + K[X] (RatFunc K) M (RatFuncFiniteIntegralClosure K M) + +local instance finitePlaceTowerTopFractionRing : + IsFractionRing (RatFuncFiniteIntegralClosure K L) L := + IsIntegralClosure.isFractionRing_of_finite_extension + K[X] (RatFunc K) L (RatFuncFiniteIntegralClosure K L) + +local instance finitePlaceTowerIntermediateClosureFieldTower : + IsScalarTower (RatFuncFiniteIntegralClosure K M) M L := + inferInstance + +local instance finitePlaceTowerTopClosureFieldTower : + IsScalarTower (RatFuncFiniteIntegralClosure K M) + (RatFuncFiniteIntegralClosure K L) L := + ⟨fun r s x => by + simp only [Algebra.smul_def, map_mul] + rw [show algebraMap (RatFuncFiniteIntegralClosure K L) L + (algebraMap (RatFuncFiniteIntegralClosure K M) + (RatFuncFiniteIntegralClosure K L) r) = + algebraMap (RatFuncFiniteIntegralClosure K M) L r by rfl] + ring⟩ + +local instance finitePlaceTowerRelativeIsIntegralClosure : + IsIntegralClosure (RatFuncFiniteIntegralClosure K L) + (RatFuncFiniteIntegralClosure K M) L := + IsIntegralClosure.tower_top (R := K[X]) + +/-- Restriction of a finite place contracts its height-one prime to the +intermediate finite integral closure. -/ +def finitePlaceUnder + (P : FiniteExtensionFinitePlace K L) : + FiniteExtensionFinitePlace K M := + HeightOneSpectrum.under (RatFuncFiniteIntegralClosure K M) P + +omit [DecidableEq K] [DecidableEq (RatFunc K)] [FiniteDimensional (RatFunc K) M] + [Algebra.IsSeparable (RatFunc K) M] [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] in +@[simp] +theorem finitePlaceUnder_asIdeal + (P : FiniteExtensionFinitePlace K L) : + (finitePlaceUnder K M L P).asIdeal = + P.asIdeal.under (RatFuncFiniteIntegralClosure K M) := rfl + +omit [DecidableEq K] [DecidableEq (RatFunc K)] [FiniteDimensional (RatFunc K) M] + [Algebra.IsSeparable (RatFunc K) M] [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] in +/-- Restricting a finite place through the intermediate field preserves the +place below it in the rational function field. -/ +@[simp] +theorem finitePlaceUnder_under + (P : FiniteExtensionFinitePlace K L) : + HeightOneSpectrum.under K[X] (finitePlaceUnder K M L P) = + HeightOneSpectrum.under K[X] P := by + apply HeightOneSpectrum.ext + exact Ideal.under_under P.asIdeal + +/-- The field inclusion maps the integral closure of the infinity valuation +ring in an intermediate field into the corresponding top integral closure. -/ +def infinityIntegralClosureMap : + RatFuncInfinityIntegralClosure K M →ₐ[RatFuncInfinityIntegers K] + RatFuncInfinityIntegralClosure K L := + (IsScalarTower.toAlgHom (RatFuncInfinityIntegers K) M L).mapIntegralClosure + +local instance infinityPlaceTowerIntegralClosureAlgebra : + Algebra (RatFuncInfinityIntegralClosure K M) + (RatFuncInfinityIntegralClosure K L) := + (infinityIntegralClosureMap K M L).toAlgebra + +local instance infinityPlaceTowerIntermediateIntegral : + Algebra.IsIntegral (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K M) := + IsIntegralClosure.isIntegral_algebra (RatFuncInfinityIntegers K) M + +local instance infinityPlaceTowerIntermediateModuleFinite : + Module.Finite (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K M) := + IsIntegralClosure.finite (RatFuncInfinityIntegers K) (RatFunc K) M + (RatFuncInfinityIntegralClosure K M) + +local instance infinityPlaceTowerIntermediateClosureTorsionFree : + Module.IsTorsionFree (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K M) := + IsIntegralClosure.isTorsionFree (RatFuncInfinityIntegers K) M + +local instance infinityPlaceTowerIntermediateDedekind : + IsDedekindDomain (RatFuncInfinityIntegralClosure K M) := + IsIntegralClosure.isDedekindDomain (RatFuncInfinityIntegers K) + (RatFunc K) M (RatFuncInfinityIntegralClosure K M) + +local instance infinityPlaceTowerBaseIntegral : + Algebra.IsIntegral (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.isIntegral_algebra (RatFuncInfinityIntegers K) L + +local instance infinityPlaceTowerTopModuleFinite : + Module.Finite (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.finite (RatFuncInfinityIntegers K) (RatFunc K) L + (RatFuncInfinityIntegralClosure K L) + +local instance infinityPlaceTowerTopClosureTorsionFree : + Module.IsTorsionFree (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.isTorsionFree (RatFuncInfinityIntegers K) L + +local instance infinityPlaceTowerTopDedekind : + IsDedekindDomain (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.isDedekindDomain (RatFuncInfinityIntegers K) + (RatFunc K) L (RatFuncInfinityIntegralClosure K L) + +local instance infinityPlaceTowerIntegralClosures : + IsScalarTower (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K M) + (RatFuncInfinityIntegralClosure K L) := + IsScalarTower.of_algebraMap_eq fun _ => by + apply Subtype.ext + change algebraMap (RatFuncInfinityIntegers K) L _ = + algebraMap M L (algebraMap (RatFuncInfinityIntegers K) M _) + exact IsScalarTower.algebraMap_apply (RatFuncInfinityIntegers K) M L _ + +local instance infinityPlaceTowerTopIntegral : + Algebra.IsIntegral (RatFuncInfinityIntegralClosure K M) + (RatFuncInfinityIntegralClosure K L) := + Algebra.IsIntegral.tower_top (RatFuncInfinityIntegers K) + +local instance infinityPlaceTowerFaithful : + FaithfulSMul (RatFuncInfinityIntegralClosure K M) + (RatFuncInfinityIntegralClosure K L) := by + rw [faithfulSMul_iff_algebraMap_injective] + intro x y hxy + apply Subtype.ext + apply (algebraMap M L).injective + exact congrArg Subtype.val hxy + +local instance infinityPlaceTowerRelativeModuleFinite : + Module.Finite (RatFuncInfinityIntegralClosure K M) + (RatFuncInfinityIntegralClosure K L) := + Module.Finite.of_restrictScalars_finite (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K M) + (RatFuncInfinityIntegralClosure K L) + +local instance infinityPlaceTowerIntermediateFractionRing : + IsFractionRing (RatFuncInfinityIntegralClosure K M) M := + IsIntegralClosure.isFractionRing_of_finite_extension + (RatFuncInfinityIntegers K) (RatFunc K) M + (RatFuncInfinityIntegralClosure K M) + +local instance infinityPlaceTowerTopFractionRing : + IsFractionRing (RatFuncInfinityIntegralClosure K L) L := + IsIntegralClosure.isFractionRing_of_finite_extension + (RatFuncInfinityIntegers K) (RatFunc K) L + (RatFuncInfinityIntegralClosure K L) + +local instance infinityPlaceTowerIntermediateClosureFieldTower : + IsScalarTower (RatFuncInfinityIntegralClosure K M) M L := + inferInstance + +local instance infinityPlaceTowerTopClosureFieldTower : + IsScalarTower (RatFuncInfinityIntegralClosure K M) + (RatFuncInfinityIntegralClosure K L) L := + ⟨fun r s x => by + simp only [Algebra.smul_def, map_mul] + rw [show algebraMap (RatFuncInfinityIntegralClosure K L) L + (algebraMap (RatFuncInfinityIntegralClosure K M) + (RatFuncInfinityIntegralClosure K L) r) = + algebraMap (RatFuncInfinityIntegralClosure K M) L r by rfl] + ring⟩ + +local instance infinityPlaceTowerRelativeIsIntegralClosure : + IsIntegralClosure (RatFuncInfinityIntegralClosure K L) + (RatFuncInfinityIntegralClosure K M) L := + IsIntegralClosure.tower_top (R := RatFuncInfinityIntegers K) + +/-- Restriction of a place above infinity contracts its prime to the +intermediate integral closure. The tower law for ideals proves that the +contracted prime still lies above the distinguished infinity place. -/ +def infinityPlaceUnder + (P : FiniteExtensionInfinityPlace K L) : + FiniteExtensionInfinityPlace K M := by + let wL : HeightOneSpectrum (RatFuncInfinityIntegralClosure K L) := + primeOverHeightOne (ratFuncInfinityPlace K) P + let wM : HeightOneSpectrum (RatFuncInfinityIntegralClosure K M) := + HeightOneSpectrum.under (RatFuncInfinityIntegralClosure K M) wL + refine ⟨wM.asIdeal, wM.isPrime, ?_⟩ + have hwM : wM.asIdeal = + wL.asIdeal.under (RatFuncInfinityIntegralClosure K M) := rfl + let : wL.asIdeal.LiesOver wM.asIdeal := by + rw [hwM] + infer_instance + let : wL.asIdeal.LiesOver (ratFuncInfinityPlace K).asIdeal := by + change P.1.LiesOver (ratFuncInfinityPlace K).asIdeal + infer_instance + exact Ideal.LiesOver.tower_bot wL.asIdeal wM.asIdeal + (ratFuncInfinityPlace K).asIdeal + +omit [DecidableEq K] [FiniteDimensional (RatFunc K) M] [Algebra.IsSeparable (RatFunc K) M] + [FiniteDimensional (RatFunc K) L] [Algebra.IsSeparable (RatFunc K) L] in +@[simp] +theorem infinityPlaceUnder_asIdeal + (P : FiniteExtensionInfinityPlace K L) : + (infinityPlaceUnder K M L P).1 = + P.1.under (RatFuncInfinityIntegralClosure K M) := by + rfl + +/-- Restriction on the exhaustive sum of finite and above-infinity places. -/ +def placeUnder : FiniteExtensionPlace K L → FiniteExtensionPlace K M + | .inl P => .inl (finitePlaceUnder K M L P) + | .inr P => .inr (infinityPlaceUnder K M L P) + +omit [DecidableEq K] [FiniteDimensional (RatFunc K) M] [Algebra.IsSeparable (RatFunc K) M] + [FiniteDimensional (RatFunc K) L] [Algebra.IsSeparable (RatFunc K) L] in +@[simp] +theorem placeUnder_inl + (P : FiniteExtensionFinitePlace K L) : + placeUnder K M L (.inl P) = .inl (finitePlaceUnder K M L P) := rfl + +omit [DecidableEq K] [FiniteDimensional (RatFunc K) M] [Algebra.IsSeparable (RatFunc K) M] + [FiniteDimensional (RatFunc K) L] [Algebra.IsSeparable (RatFunc K) L] in +@[simp] +theorem placeUnder_inr + (P : FiniteExtensionInfinityPlace K L) : + placeUnder K M L (.inr P) = .inr (infinityPlaceUnder K M L P) := rfl + +omit [DecidableEq K] [DecidableEq (RatFunc K)] [FiniteDimensional (RatFunc K) M] + [Algebra.IsSeparable (RatFunc K) M] [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] in +/-- Every finite place of the intermediate field has a finite place above it +in the top field. This is lying-over for the induced integral-closure map. -/ +theorem finitePlaceUnder_surjective : + Function.Surjective (finitePlaceUnder K M L) := by + intro P + let Q : P.asIdeal.primesOver (RatFuncFiniteIntegralClosure K L) := + Classical.choice inferInstance + let : Q.1.LiesOver P.asIdeal := Q.2.2 + have hQ0 : Q.1 ≠ ⊥ := + Ideal.ne_bot_of_mem_primesOver P.ne_bot Q.2 + let q : FiniteExtensionFinitePlace K L := ⟨Q.1, Q.2.1, hQ0⟩ + refine ⟨q, ?_⟩ + apply HeightOneSpectrum.ext + exact (Ideal.over_def Q.1 P.asIdeal).symm + +omit [DecidableEq K] [FiniteDimensional (RatFunc K) M] [Algebra.IsSeparable (RatFunc K) M] + [FiniteDimensional (RatFunc K) L] [Algebra.IsSeparable (RatFunc K) L] in +/-- Every place above infinity in the intermediate field has a place above it +in the top field. -/ +theorem infinityPlaceUnder_surjective : + Function.Surjective (infinityPlaceUnder K M L) := by + intro P + let Q : P.1.primesOver (RatFuncInfinityIntegralClosure K L) := + Classical.choice inferInstance + let : Q.1.LiesOver P.1 := Q.2.2 + let : P.1.LiesOver (ratFuncInfinityPlace K).asIdeal := P.2.2 + let : Q.1.LiesOver (ratFuncInfinityPlace K).asIdeal := + Ideal.LiesOver.trans Q.1 P.1 (ratFuncInfinityPlace K).asIdeal + let q : FiniteExtensionInfinityPlace K L := + ⟨Q.1, Q.2.1, inferInstance⟩ + refine ⟨q, ?_⟩ + apply Subtype.ext + exact (Ideal.over_def Q.1 P.1).symm + +omit [DecidableEq K] [FiniteDimensional (RatFunc K) M] [Algebra.IsSeparable (RatFunc K) M] + [FiniteDimensional (RatFunc K) L] [Algebra.IsSeparable (RatFunc K) L] in +/-- Restriction from the top field is surjective on the exhaustive place +type. -/ +theorem placeUnder_surjective : + Function.Surjective (placeUnder K M L) := by + intro P + rcases P with P | P + · obtain ⟨Q, hQ⟩ := finitePlaceUnder_surjective K M L P + exact ⟨.inl Q, congrArg Sum.inl hQ⟩ + · obtain ⟨Q, hQ⟩ := infinityPlaceUnder_surjective K M L P + exact ⟨.inr Q, congrArg Sum.inr hQ⟩ + +/-- The finite places of the top field above a fixed intermediate finite +place. -/ +abbrev FinitePlaceUnderFiber (P : FiniteExtensionFinitePlace K M) := + {Q : FiniteExtensionFinitePlace K L // finitePlaceUnder K M L Q = P} + +/-- A restriction fiber is the usual finite set of primes lying over the +contracted prime ideal. -/ +def finitePlaceUnderFiberEquivPrimesOver + (P : FiniteExtensionFinitePlace K M) : + FinitePlaceUnderFiber K M L P ≃ + P.asIdeal.primesOver (RatFuncFiniteIntegralClosure K L) where + toFun Q := ⟨Q.1.asIdeal, Q.1.isPrime, ⟨by + have h := congrArg HeightOneSpectrum.asIdeal Q.2 + exact h.symm⟩⟩ + invFun Q := ⟨primeOverHeightOne P Q, by + apply HeightOneSpectrum.ext + exact (Ideal.over_def Q.1 P.asIdeal).symm⟩ + left_inv Q := by + apply Subtype.ext + apply HeightOneSpectrum.ext + rfl + right_inv Q := by + apply Subtype.ext + rfl + +noncomputable instance finitePlaceUnderFiberFintype + (P : FiniteExtensionFinitePlace K M) : + Fintype (FinitePlaceUnderFiber K M L P) := + Fintype.ofEquiv + (P.asIdeal.primesOver (RatFuncFiniteIntegralClosure K L)) + (finitePlaceUnderFiberEquivPrimesOver K M L P).symm + +/-- The places of the top field above a fixed intermediate place at +infinity. -/ +abbrev InfinityPlaceUnderFiber (P : FiniteExtensionInfinityPlace K M) := + {Q : FiniteExtensionInfinityPlace K L // + infinityPlaceUnder K M L Q = P} + +/-- The restriction fiber above infinity is likewise the finite set of primes +over the corresponding intermediate prime. -/ +def infinityPlaceUnderFiberEquivPrimesOver + (P : FiniteExtensionInfinityPlace K M) : + InfinityPlaceUnderFiber K M L P ≃ + P.1.primesOver (RatFuncInfinityIntegralClosure K L) where + toFun Q := ⟨Q.1.1, Q.1.2.1, ⟨by + have h := congrArg Subtype.val Q.2 + exact h.symm⟩⟩ + invFun Q := by + letI : Q.1.LiesOver P.1 := Q.2.2 + letI : P.1.LiesOver (ratFuncInfinityPlace K).asIdeal := P.2.2 + letI : Q.1.LiesOver (ratFuncInfinityPlace K).asIdeal := + Ideal.LiesOver.trans Q.1 P.1 (ratFuncInfinityPlace K).asIdeal + let q : FiniteExtensionInfinityPlace K L := + ⟨Q.1, Q.2.1, inferInstance⟩ + refine ⟨q, ?_⟩ + apply Subtype.ext + exact (Ideal.over_def Q.1 P.1).symm + left_inv Q := by + apply Subtype.ext + apply Subtype.ext + rfl + right_inv Q := by + apply Subtype.ext + rfl + +noncomputable instance infinityPlaceUnderFiberFintype + (P : FiniteExtensionInfinityPlace K M) : + Fintype (InfinityPlaceUnderFiber K M L P) := + Fintype.ofEquiv + (P.1.primesOver (RatFuncInfinityIntegralClosure K L)) + (infinityPlaceUnderFiberEquivPrimesOver K M L P).symm + +omit [DecidableEq K] [DecidableEq (RatFunc K)] [Algebra.IsSeparable (RatFunc K) M] + [Algebra.IsSeparable (RatFunc K) L] in +/-- The rank of the relative finite integral-closure extension is the field +degree of the top function field over the intermediate field. -/ +theorem finiteIntegralClosure_relative_finrank_eq_field_finrank : + Module.finrank (RatFuncFiniteIntegralClosure K M) + (RatFuncFiniteIntegralClosure K L) = + Module.finrank M L := by + exact (IsFractionRing.finrank_eq + (RatFuncFiniteIntegralClosure K M) M + (RatFuncFiniteIntegralClosure K L) L).symm + +omit [DecidableEq K] [Algebra.IsSeparable (RatFunc K) M] [Algebra.IsSeparable (RatFunc K) L] in +/-- The infinity integral-closure model has the same relative rank, namely +the degree of the field extension. -/ +theorem infinityIntegralClosure_relative_finrank_eq_field_finrank : + Module.finrank (RatFuncInfinityIntegralClosure K M) + (RatFuncInfinityIntegralClosure K L) = + Module.finrank M L := by + exact (IsFractionRing.finrank_eq + (RatFuncInfinityIntegralClosure K M) M + (RatFuncInfinityIntegralClosure K L) L).symm + +/-- Ramification index of a top finite place over the intermediate finite +integral closure. -/ +noncomputable def finitePlaceRelativeRamificationIdx + (Q : FiniteExtensionFinitePlace K L) : ℕ := + Q.asIdeal.ramificationIdx (RatFuncFiniteIntegralClosure K M) + +/-- Inertia degree of a top finite place over the intermediate finite +integral closure. -/ +noncomputable def finitePlaceRelativeInertiaDeg + (Q : FiniteExtensionFinitePlace K L) : ℕ := + Q.asIdeal.inertiaDeg (RatFuncFiniteIntegralClosure K M) + +omit [DecidableEq K] [DecidableEq (RatFunc K)] in +/-- The fundamental equality for the finite-place restriction fiber. -/ +theorem sum_finitePlaceUnderFiber_ramification_inertia_eq_finrank + (P : FiniteExtensionFinitePlace K M) : + ∑ Q : FinitePlaceUnderFiber K M L P, + finitePlaceRelativeRamificationIdx K M L Q.1 * + finitePlaceRelativeInertiaDeg K M L Q.1 = + Module.finrank (RatFuncFiniteIntegralClosure K M) + (RatFuncFiniteIntegralClosure K L) := by + classical + let e := finitePlaceUnderFiberEquivPrimesOver K M L P + calc + _ = ∑ Q : P.asIdeal.primesOver (RatFuncFiniteIntegralClosure K L), + Q.1.ramificationIdx (RatFuncFiniteIntegralClosure K M) * + Q.1.inertiaDeg (RatFuncFiniteIntegralClosure K M) := by + apply Fintype.sum_equiv e + intro Q + rfl + _ = _ := Ideal.sum_ramification_inertia_eq_finrank P.asIdeal + (RatFuncFiniteIntegralClosure K L) + +omit [DecidableEq K] [DecidableEq (RatFunc K)] in +/-- Field-degree form of the finite-place fundamental equality. -/ +theorem sum_finitePlaceUnderFiber_ramification_inertia_eq_field_finrank + (P : FiniteExtensionFinitePlace K M) : + ∑ Q : FinitePlaceUnderFiber K M L P, + finitePlaceRelativeRamificationIdx K M L Q.1 * + finitePlaceRelativeInertiaDeg K M L Q.1 = + Module.finrank M L := by + rw [sum_finitePlaceUnderFiber_ramification_inertia_eq_finrank K M L P, + finiteIntegralClosure_relative_finrank_eq_field_finrank K M L] + +/-- Ramification index of a top place above infinity over the intermediate +infinity integral closure. -/ +noncomputable def infinityPlaceRelativeRamificationIdx + (Q : FiniteExtensionInfinityPlace K L) : ℕ := + Q.1.ramificationIdx (RatFuncInfinityIntegralClosure K M) + +/-- Inertia degree of a top place above infinity over the intermediate +infinity integral closure. -/ +noncomputable def infinityPlaceRelativeInertiaDeg + (Q : FiniteExtensionInfinityPlace K L) : ℕ := + Q.1.inertiaDeg (RatFuncInfinityIntegralClosure K M) + +omit [DecidableEq K] in +/-- The fundamental equality for the restriction fiber above infinity. -/ +theorem sum_infinityPlaceUnderFiber_ramification_inertia_eq_finrank + (P : FiniteExtensionInfinityPlace K M) : + ∑ Q : InfinityPlaceUnderFiber K M L P, + infinityPlaceRelativeRamificationIdx K M L Q.1 * + infinityPlaceRelativeInertiaDeg K M L Q.1 = + Module.finrank (RatFuncInfinityIntegralClosure K M) + (RatFuncInfinityIntegralClosure K L) := by + classical + let : P.1.IsPrime := P.2.1 + let e := infinityPlaceUnderFiberEquivPrimesOver K M L P + calc + _ = ∑ Q : P.1.primesOver (RatFuncInfinityIntegralClosure K L), + Q.1.ramificationIdx (RatFuncInfinityIntegralClosure K M) * + Q.1.inertiaDeg (RatFuncInfinityIntegralClosure K M) := by + apply Fintype.sum_equiv e + intro Q + rfl + _ = _ := Ideal.sum_ramification_inertia_eq_finrank P.1 + (RatFuncInfinityIntegralClosure K L) + +omit [DecidableEq K] in +/-- Field-degree form of the fundamental equality above infinity. -/ +theorem sum_infinityPlaceUnderFiber_ramification_inertia_eq_field_finrank + (P : FiniteExtensionInfinityPlace K M) : + ∑ Q : InfinityPlaceUnderFiber K M L P, + infinityPlaceRelativeRamificationIdx K M L Q.1 * + infinityPlaceRelativeInertiaDeg K M L Q.1 = + Module.finrank M L := by + rw [sum_infinityPlaceUnderFiber_ramification_inertia_eq_finrank K M L P, + infinityIntegralClosure_relative_finrank_eq_field_finrank K M L] + +omit [FiniteDimensional (RatFunc K) M] [Algebra.IsSeparable (RatFunc K) M] + [FiniteDimensional (RatFunc K) L] [Algebra.IsSeparable (RatFunc K) L] in +/-- Place degree is multiplicative when a finite place is restricted through +an intermediate function field. The second factor is the residue-field +degree in the relative extension. -/ +theorem finiteExtensionPlaceDegree_inl_eq_mul_relativeInertiaDeg + (Q : FiniteExtensionFinitePlace K L) : + finiteExtensionPlaceDegree K L (.inl Q) = + finiteExtensionPlaceDegree K M + (.inl (finitePlaceUnder K M L Q)) * + finitePlaceRelativeInertiaDeg K M L Q := by + let P := finitePlaceUnder K M L Q + let : Q.asIdeal.LiesOver P.asIdeal := + ⟨finitePlaceUnder_asIdeal K M L Q⟩ + rw [finiteExtensionPlaceDegree, finiteExtensionPlaceDegree, + finitePlaceRelativeInertiaDeg] + rw [Ideal.inertiaDeg_tower (R := K[X]) P.asIdeal Q.asIdeal] + rw [finitePlaceUnder_under] + ring + +omit [FiniteDimensional (RatFunc K) M] [Algebra.IsSeparable (RatFunc K) M] + [FiniteDimensional (RatFunc K) L] [Algebra.IsSeparable (RatFunc K) L] in +/-- The analogous degree-tower formula for places above infinity. -/ +theorem finiteExtensionPlaceDegree_inr_eq_mul_relativeInertiaDeg + (Q : FiniteExtensionInfinityPlace K L) : + finiteExtensionPlaceDegree K L (.inr Q) = + finiteExtensionPlaceDegree K M + (.inr (infinityPlaceUnder K M L Q)) * + infinityPlaceRelativeInertiaDeg K M L Q := by + let P := infinityPlaceUnder K M L Q + let : Q.1.LiesOver P.1 := + ⟨infinityPlaceUnder_asIdeal K M L Q⟩ + rw [finiteExtensionPlaceDegree, finiteExtensionPlaceDegree, + infinityPlaceRelativeInertiaDeg] + exact Ideal.inertiaDeg_tower P.1 Q.1 + +omit [FiniteDimensional (RatFunc K) M] [Algebra.IsSeparable (RatFunc K) M] + [FiniteDimensional (RatFunc K) L] [Algebra.IsSeparable (RatFunc K) L] in +/-- Exhaustive place degree is multiplicative under restriction through an +intermediate function field. -/ +theorem finiteExtensionPlaceDegree_eq_under_mul_relativeInertiaDeg + (Q : FiniteExtensionPlace K L) : + finiteExtensionPlaceDegree K L Q = + finiteExtensionPlaceDegree K M (placeUnder K M L Q) * + match Q with + | .inl q => finitePlaceRelativeInertiaDeg K M L q + | .inr q => infinityPlaceRelativeInertiaDeg K M L q := by + cases Q with + | inl Q => + exact finiteExtensionPlaceDegree_inl_eq_mul_relativeInertiaDeg K M L Q + | inr Q => + exact finiteExtensionPlaceDegree_inr_eq_mul_relativeInertiaDeg K M L Q + +section Galois + +variable [IsGalois M L] + +/-- The field Galois group acts on the finite integral closure in the top +field, relative to the intermediate finite integral closure. -/ +@[implicit_reducible] +noncomputable def finiteIntegralClosureGalAction : + MulSemiringAction Gal(L/M) (RatFuncFiniteIntegralClosure K L) := + IsIntegralClosure.MulSemiringAction + (RatFuncFiniteIntegralClosure K M) M L + (RatFuncFiniteIntegralClosure K L) + +omit [DecidableEq K] [DecidableEq (RatFunc K)] [Algebra.IsSeparable (RatFunc K) M] + [FiniteDimensional (RatFunc K) L] [Algebra.IsSeparable (RatFunc K) L] in +/-- The relative Galois action fixes the intermediate finite integral +closure. -/ +theorem finiteIntegralClosureGalSmulComm : + letI := finiteIntegralClosureGalAction K M L + SMulCommClass Gal(L/M) (RatFuncFiniteIntegralClosure K M) + (RatFuncFiniteIntegralClosure K L) := by + let := finiteIntegralClosureGalAction K M L + constructor + intro g r s + change galRestrict (RatFuncFiniteIntegralClosure K M) M L + (RatFuncFiniteIntegralClosure K L) g + (algebraMap (RatFuncFiniteIntegralClosure K M) + (RatFuncFiniteIntegralClosure K L) r * s) = + algebraMap (RatFuncFiniteIntegralClosure K M) + (RatFuncFiniteIntegralClosure K L) r * + galRestrict (RatFuncFiniteIntegralClosure K M) M L + (RatFuncFiniteIntegralClosure K L) g s + rw [map_mul, AlgEquiv.commutes] + +/-- The relative Galois action on a finite place, obtained by acting on its +height-one prime ideal. -/ +noncomputable def finitePlaceGalSmul + (g : Gal(L/M)) (P : FiniteExtensionFinitePlace K L) : + FiniteExtensionFinitePlace K L := by + letI := finiteIntegralClosureGalAction K M L + refine ⟨g • P.asIdeal, P.isPrime.smul g, ?_⟩ + intro hbot + apply P.ne_bot + have h := congrArg + (fun I : Ideal (RatFuncFiniteIntegralClosure K L) => g⁻¹ • I) hbot + simpa [smul_smul] using h + +/-- The relative Galois group acts on finite places of the top function +field. -/ +@[implicit_reducible] +noncomputable def finitePlaceGalAction : + MulAction Gal(L/M) (FiniteExtensionFinitePlace K L) := by + letI := finiteIntegralClosureGalAction K M L + exact + { smul := finitePlaceGalSmul K M L + one_smul := fun P => by + apply HeightOneSpectrum.ext + change (1 : Gal(L/M)) • P.asIdeal = P.asIdeal + simp + mul_smul := fun g h P => by + apply HeightOneSpectrum.ext + change (g * h) • P.asIdeal = g • h • P.asIdeal + rw [mul_smul] } + +omit [DecidableEq K] [DecidableEq (RatFunc K)] [Algebra.IsSeparable (RatFunc K) M] + [FiniteDimensional (RatFunc K) L] [Algebra.IsSeparable (RatFunc K) L] in +/-- Relative Galois conjugation does not change the restricted finite place. -/ +@[simp] +theorem finitePlaceUnder_finitePlaceGalSmul + (g : Gal(L/M)) (P : FiniteExtensionFinitePlace K L) : + finitePlaceUnder K M L (finitePlaceGalSmul K M L g P) = + finitePlaceUnder K M L P := by + let := finiteIntegralClosureGalAction K M L + let := finiteIntegralClosureGalSmulComm K M L + apply HeightOneSpectrum.ext + change (g • P.asIdeal).under (RatFuncFiniteIntegralClosure K M) = + P.asIdeal.under (RatFuncFiniteIntegralClosure K M) + exact P.asIdeal.under_smul (RatFuncFiniteIntegralClosure K M) g + +/-- The relative Galois action restricts to every finite-place fiber. -/ +@[implicit_reducible] +noncomputable def finitePlaceUnderFiberGalAction + (P : FiniteExtensionFinitePlace K M) : + MulAction Gal(L/M) (FinitePlaceUnderFiber K M L P) := by + letI := finiteIntegralClosureGalAction K M L + exact + { smul := fun g Q => ⟨finitePlaceGalSmul K M L g Q.1, by + rw [finitePlaceUnder_finitePlaceGalSmul, Q.2]⟩ + one_smul := fun Q => by + apply Subtype.ext + apply HeightOneSpectrum.ext + change (1 : Gal(L/M)) • Q.1.asIdeal = Q.1.asIdeal + simp + mul_smul := fun g h Q => by + apply Subtype.ext + apply HeightOneSpectrum.ext + change (g * h) • Q.1.asIdeal = g • h • Q.1.asIdeal + rw [mul_smul] } + +/-- Galois conjugacy of finite places, expressed on their prime ideals. -/ +def FinitePlacesGaloisConjugate + (P Q : FiniteExtensionFinitePlace K L) : Prop := + letI := finiteIntegralClosureGalAction K M L + ∃ g : Gal(L/M), Q.asIdeal = g • P.asIdeal + +omit [DecidableEq K] [DecidableEq (RatFunc K)] [Algebra.IsSeparable (RatFunc K) M] + [Algebra.IsSeparable (RatFunc K) L] in +/-- Two finite places above the same intermediate place are conjugate under +the relative field Galois group. -/ +theorem exists_gal_smul_finitePlace_asIdeal_of_same_under + (P Q : FiniteExtensionFinitePlace K L) + (hPQ : finitePlaceUnder K M L P = finitePlaceUnder K M L Q) : + FinitePlacesGaloisConjugate K M L P Q := by + let : Module.Finite M L := + Module.Finite.of_restrictScalars_finite (RatFunc K) M L + let := finiteIntegralClosureGalAction K M L + change ∃ g : Gal(L/M), Q.asIdeal = g • P.asIdeal + let := finiteIntegralClosureGalSmulComm K M L + let : Algebra.IsInvariant (RatFuncFiniteIntegralClosure K M) + (RatFuncFiniteIntegralClosure K L) Gal(L/M) := + Algebra.isInvariant_of_isGalois + (RatFuncFiniteIntegralClosure K M) M L + (RatFuncFiniteIntegralClosure K L) + let : P.asIdeal.IsPrime := P.isPrime + let : Q.asIdeal.IsPrime := Q.isPrime + apply Algebra.IsInvariant.exists_smul_of_under_eq + (RatFuncFiniteIntegralClosure K M) + (RatFuncFiniteIntegralClosure K L) Gal(L/M) + simpa only [finitePlaceUnder_asIdeal] using + congrArg HeightOneSpectrum.asIdeal hPQ + +omit [DecidableEq K] [DecidableEq (RatFunc K)] [Algebra.IsSeparable (RatFunc K) M] + [Algebra.IsSeparable (RatFunc K) L] in +/-- Each finite-place restriction fiber is a transitive relative Galois +set. -/ +theorem finitePlaceUnderFiberGalAction_isPretransitive + (P : FiniteExtensionFinitePlace K M) : + letI := finitePlaceUnderFiberGalAction K M L P + MulAction.IsPretransitive Gal(L/M) (FinitePlaceUnderFiber K M L P) := by + let := finiteIntegralClosureGalAction K M L + let := finitePlaceUnderFiberGalAction K M L P + constructor + intro Q R + obtain ⟨g, hg⟩ := + exists_gal_smul_finitePlace_asIdeal_of_same_under + K M L Q.1 R.1 (Q.2.trans R.2.symm) + refine ⟨g, ?_⟩ + apply Subtype.ext + apply HeightOneSpectrum.ext + change g • Q.1.asIdeal = R.1.asIdeal + exact hg.symm + +/-- Finite places in a restriction fiber fixed by one relative Galois +automorphism. -/ +noncomputable def finitePlaceUnderFiberFixedBy + (P : FiniteExtensionFinitePlace K M) (g : Gal(L/M)) : Type _ := + letI := finitePlaceUnderFiberGalAction K M L P + MulAction.fixedBy (FinitePlaceUnderFiber K M L P) g + +omit [DecidableEq K] [DecidableEq (RatFunc K)] in +/-- The exact local fixed-point trace identity for a finite-place restriction +fiber. -/ +theorem sum_card_finitePlaceUnderFiberFixedBy_eq_card_galoisGroup + (P : FiniteExtensionFinitePlace K M) : + letI : Module.Finite M L := + Module.Finite.of_restrictScalars_finite (RatFunc K) M L + (∑ g : Gal(L/M), Nat.card (finitePlaceUnderFiberFixedBy K M L P g)) = + Nat.card Gal(L/M) := by + let : Module.Finite M L := + Module.Finite.of_restrictScalars_finite (RatFunc K) M L + let := finitePlaceUnderFiberGalAction K M L P + let : MulAction.IsPretransitive Gal(L/M) + (FinitePlaceUnderFiber K M L P) := + finitePlaceUnderFiberGalAction_isPretransitive K M L P + let : Nonempty (FinitePlaceUnderFiber K M L P) := by + obtain ⟨Q, hQ⟩ := finitePlaceUnder_surjective K M L P + exact ⟨⟨Q, hQ⟩⟩ + change (∑ g : Gal(L/M), + Nat.card (MulAction.fixedBy (FinitePlaceUnderFiber K M L P) g)) = _ + exact sum_card_fixedBy_eq_card_group_of_isPretransitive + Gal(L/M) (FinitePlaceUnderFiber K M L P) + +/-- The same relative Galois group acts on the integral closure of the +infinity valuation ring. -/ +@[implicit_reducible] +noncomputable def infinityIntegralClosureGalAction : + MulSemiringAction Gal(L/M) (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.MulSemiringAction + (RatFuncInfinityIntegralClosure K M) M L + (RatFuncInfinityIntegralClosure K L) + +omit [DecidableEq K] [Algebra.IsSeparable (RatFunc K) M] [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] in +/-- The relative Galois action fixes the intermediate infinity integral +closure. -/ +theorem infinityIntegralClosureGalSmulComm : + letI := infinityIntegralClosureGalAction K M L + SMulCommClass Gal(L/M) (RatFuncInfinityIntegralClosure K M) + (RatFuncInfinityIntegralClosure K L) := by + let := infinityIntegralClosureGalAction K M L + constructor + intro g r s + change galRestrict (RatFuncInfinityIntegralClosure K M) M L + (RatFuncInfinityIntegralClosure K L) g + (algebraMap (RatFuncInfinityIntegralClosure K M) + (RatFuncInfinityIntegralClosure K L) r * s) = + algebraMap (RatFuncInfinityIntegralClosure K M) + (RatFuncInfinityIntegralClosure K L) r * + galRestrict (RatFuncInfinityIntegralClosure K M) M L + (RatFuncInfinityIntegralClosure K L) g s + rw [map_mul, AlgEquiv.commutes] + +omit [DecidableEq K] [Algebra.IsSeparable (RatFunc K) M] [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] in +/-- The relative Galois action also commutes with scalars from the base +infinity valuation ring. -/ +theorem ratFuncInfinityIntegersGalSmulComm : + letI := infinityIntegralClosureGalAction K M L + SMulCommClass Gal(L/M) (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) := by + let := infinityIntegralClosureGalAction K M L + let := infinityIntegralClosureGalSmulComm K M L + constructor + intro g r s + calc + g • (r • s) = g • ((algebraMap (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K M) r) • s) := by + congr 1 + simp only [Algebra.smul_def, + IsScalarTower.algebraMap_apply (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K M) + (RatFuncInfinityIntegralClosure K L)] + _ = (algebraMap (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K M) r) • (g • s) := + smul_comm g + (algebraMap (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K M) r) s + _ = r • (g • s) := by + simp only [Algebra.smul_def, + IsScalarTower.algebraMap_apply (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K M) + (RatFuncInfinityIntegralClosure K L)] + +/-- The relative Galois action on a place above infinity, obtained by acting +on its prime ideal. -/ +noncomputable def infinityPlaceGalSmul + (g : Gal(L/M)) (P : FiniteExtensionInfinityPlace K L) : + FiniteExtensionInfinityPlace K L := by + letI := infinityIntegralClosureGalAction K M L + letI := ratFuncInfinityIntegersGalSmulComm K M L + refine ⟨g • P.1, P.2.1.smul g, ?_⟩ + exact P.2.2.smul g + +/-- The relative Galois group acts on places above infinity of the top +function field. -/ +@[implicit_reducible] +noncomputable def infinityPlaceGalAction : + MulAction Gal(L/M) (FiniteExtensionInfinityPlace K L) := by + letI := infinityIntegralClosureGalAction K M L + exact + { smul := infinityPlaceGalSmul K M L + one_smul := fun P => by + apply Subtype.ext + change (1 : Gal(L/M)) • P.1 = P.1 + simp + mul_smul := fun g h P => by + apply Subtype.ext + change (g * h) • P.1 = g • h • P.1 + rw [mul_smul] } + +omit [DecidableEq K] [Algebra.IsSeparable (RatFunc K) M] [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] in +/-- Relative Galois conjugation does not change the restricted infinity +place. -/ +@[simp] +theorem infinityPlaceUnder_infinityPlaceGalSmul + (g : Gal(L/M)) (P : FiniteExtensionInfinityPlace K L) : + infinityPlaceUnder K M L (infinityPlaceGalSmul K M L g P) = + infinityPlaceUnder K M L P := by + let := infinityIntegralClosureGalAction K M L + let := infinityIntegralClosureGalSmulComm K M L + apply Subtype.ext + change (g • P.1).under (RatFuncInfinityIntegralClosure K M) = + P.1.under (RatFuncInfinityIntegralClosure K M) + exact P.1.under_smul (RatFuncInfinityIntegralClosure K M) g + +/-- The relative Galois action restricts to every infinity-place fiber. -/ +@[implicit_reducible] +noncomputable def infinityPlaceUnderFiberGalAction + (P : FiniteExtensionInfinityPlace K M) : + MulAction Gal(L/M) (InfinityPlaceUnderFiber K M L P) := by + letI := infinityIntegralClosureGalAction K M L + exact + { smul := fun g Q => ⟨infinityPlaceGalSmul K M L g Q.1, by + rw [infinityPlaceUnder_infinityPlaceGalSmul, Q.2]⟩ + one_smul := fun Q => by + apply Subtype.ext + apply Subtype.ext + change (1 : Gal(L/M)) • Q.1.1 = Q.1.1 + simp + mul_smul := fun g h Q => by + apply Subtype.ext + apply Subtype.ext + change (g * h) • Q.1.1 = g • h • Q.1.1 + rw [mul_smul] } + +/-- Galois conjugacy of places above infinity, expressed on their prime +ideals. -/ +def InfinityPlacesGaloisConjugate + (P Q : FiniteExtensionInfinityPlace K L) : Prop := + letI := infinityIntegralClosureGalAction K M L + ∃ g : Gal(L/M), Q.1 = g • P.1 + +omit [DecidableEq K] [Algebra.IsSeparable (RatFunc K) L] in +/-- Two places above infinity with the same intermediate restriction are +conjugate under the relative field Galois group. -/ +theorem exists_gal_smul_infinityPlace_asIdeal_of_same_under + (P Q : FiniteExtensionInfinityPlace K L) + (hPQ : infinityPlaceUnder K M L P = infinityPlaceUnder K M L Q) : + InfinityPlacesGaloisConjugate K M L P Q := by + let : Module.Finite M L := + Module.Finite.of_restrictScalars_finite (RatFunc K) M L + let := infinityIntegralClosureGalAction K M L + change ∃ g : Gal(L/M), Q.1 = g • P.1 + let := infinityIntegralClosureGalSmulComm K M L + let : Algebra.IsInvariant (RatFuncInfinityIntegralClosure K M) + (RatFuncInfinityIntegralClosure K L) Gal(L/M) := + Algebra.isInvariant_of_isGalois + (RatFuncInfinityIntegralClosure K M) M L + (RatFuncInfinityIntegralClosure K L) + let : P.1.IsPrime := P.2.1 + let : Q.1.IsPrime := Q.2.1 + apply Algebra.IsInvariant.exists_smul_of_under_eq + (RatFuncInfinityIntegralClosure K M) + (RatFuncInfinityIntegralClosure K L) Gal(L/M) + simpa only [infinityPlaceUnder_asIdeal] using + congrArg Subtype.val hPQ + +omit [DecidableEq K] [Algebra.IsSeparable (RatFunc K) L] in +/-- Each infinity-place restriction fiber is a transitive relative Galois +set. -/ +theorem infinityPlaceUnderFiberGalAction_isPretransitive + (P : FiniteExtensionInfinityPlace K M) : + letI := infinityPlaceUnderFiberGalAction K M L P + MulAction.IsPretransitive Gal(L/M) (InfinityPlaceUnderFiber K M L P) := by + let := infinityIntegralClosureGalAction K M L + let := infinityPlaceUnderFiberGalAction K M L P + constructor + intro Q R + obtain ⟨g, hg⟩ := + exists_gal_smul_infinityPlace_asIdeal_of_same_under + K M L Q.1 R.1 (Q.2.trans R.2.symm) + refine ⟨g, ?_⟩ + apply Subtype.ext + apply Subtype.ext + change g • Q.1.1 = R.1.1 + exact hg.symm + +/-- Places above infinity in a restriction fiber fixed by one relative Galois +automorphism. -/ +noncomputable def infinityPlaceUnderFiberFixedBy + (P : FiniteExtensionInfinityPlace K M) (g : Gal(L/M)) : Type _ := + letI := infinityPlaceUnderFiberGalAction K M L P + MulAction.fixedBy (InfinityPlaceUnderFiber K M L P) g + +omit [DecidableEq K] in +/-- The exact local fixed-point trace identity for an infinity-place +restriction fiber. -/ +theorem sum_card_infinityPlaceUnderFiberFixedBy_eq_card_galoisGroup + (P : FiniteExtensionInfinityPlace K M) : + letI : Module.Finite M L := + Module.Finite.of_restrictScalars_finite (RatFunc K) M L + (∑ g : Gal(L/M), Nat.card (infinityPlaceUnderFiberFixedBy K M L P g)) = + Nat.card Gal(L/M) := by + let : Module.Finite M L := + Module.Finite.of_restrictScalars_finite (RatFunc K) M L + let := infinityPlaceUnderFiberGalAction K M L P + let : MulAction.IsPretransitive Gal(L/M) + (InfinityPlaceUnderFiber K M L P) := + infinityPlaceUnderFiberGalAction_isPretransitive K M L P + let : Nonempty (InfinityPlaceUnderFiber K M L P) := by + obtain ⟨Q, hQ⟩ := infinityPlaceUnder_surjective K M L P + exact ⟨⟨Q, hQ⟩⟩ + change (∑ g : Gal(L/M), + Nat.card (MulAction.fixedBy (InfinityPlaceUnderFiber K M L P) g)) = _ + exact sum_card_fixedBy_eq_card_group_of_isPretransitive + Gal(L/M) (InfinityPlaceUnderFiber K M L P) + +omit [DecidableEq K] [DecidableEq (RatFunc K)] [Algebra.IsSeparable (RatFunc K) M] + [Algebra.IsSeparable (RatFunc K) L] in +/-- Ramification index and inertia degree are constant on each finite-place +restriction fiber in a Galois tower. -/ +theorem finitePlaceRelative_ramificationIdx_inertiaDeg_eq_of_same_under + (P Q : FiniteExtensionFinitePlace K L) + (hPQ : finitePlaceUnder K M L P = finitePlaceUnder K M L Q) : + finitePlaceRelativeRamificationIdx K M L P = + finitePlaceRelativeRamificationIdx K M L Q ∧ + finitePlaceRelativeInertiaDeg K M L P = + finitePlaceRelativeInertiaDeg K M L Q := by + let : Module.Finite M L := + Module.Finite.of_restrictScalars_finite (RatFunc K) M L + let := finiteIntegralClosureGalAction K M L + let := finiteIntegralClosureGalSmulComm K M L + obtain ⟨g, hg⟩ := + exists_gal_smul_finitePlace_asIdeal_of_same_under K M L P Q hPQ + constructor + · unfold finitePlaceRelativeRamificationIdx + rw [hg, Ideal.ramificationIdx_smul] + · unfold finitePlaceRelativeInertiaDeg + rw [hg, Ideal.inertiaDeg_smul] + +omit [DecidableEq K] [Algebra.IsSeparable (RatFunc K) L] in +/-- Ramification index and inertia degree are constant on each restriction +fiber above infinity in a Galois tower. -/ +theorem infinityPlaceRelative_ramificationIdx_inertiaDeg_eq_of_same_under + (P Q : FiniteExtensionInfinityPlace K L) + (hPQ : infinityPlaceUnder K M L P = infinityPlaceUnder K M L Q) : + infinityPlaceRelativeRamificationIdx K M L P = + infinityPlaceRelativeRamificationIdx K M L Q ∧ + infinityPlaceRelativeInertiaDeg K M L P = + infinityPlaceRelativeInertiaDeg K M L Q := by + let : Module.Finite M L := + Module.Finite.of_restrictScalars_finite (RatFunc K) M L + let := infinityIntegralClosureGalAction K M L + let := infinityIntegralClosureGalSmulComm K M L + obtain ⟨g, hg⟩ := + exists_gal_smul_infinityPlace_asIdeal_of_same_under K M L P Q hPQ + constructor + · unfold infinityPlaceRelativeRamificationIdx + rw [hg, Ideal.ramificationIdx_smul] + · unfold infinityPlaceRelativeInertiaDeg + rw [hg, Ideal.inertiaDeg_smul] + +omit [DecidableEq K] [DecidableEq (RatFunc K)] in +/-- In a Galois tower, the number of finite places in a restriction fiber +times their common ramification index and inertia degree is the relative field +degree. -/ +theorem finitePlaceUnderFiber_card_mul_ramificationIdx_mul_inertiaDeg_eq_field_finrank + (P : FiniteExtensionFinitePlace K M) + (Q₀ : FinitePlaceUnderFiber K M L P) : + Fintype.card (FinitePlaceUnderFiber K M L P) * + finitePlaceRelativeRamificationIdx K M L Q₀.1 * + finitePlaceRelativeInertiaDeg K M L Q₀.1 = + Module.finrank M L := by + rw [← sum_finitePlaceUnderFiber_ramification_inertia_eq_field_finrank K M L P] + calc + _ = Fintype.card (FinitePlaceUnderFiber K M L P) * + (finitePlaceRelativeRamificationIdx K M L Q₀.1 * + finitePlaceRelativeInertiaDeg K M L Q₀.1) := by + rw [Nat.mul_assoc] + _ = ∑ _Q : FinitePlaceUnderFiber K M L P, + (finitePlaceRelativeRamificationIdx K M L Q₀.1 * + finitePlaceRelativeInertiaDeg K M L Q₀.1) := by simp + _ = _ := by + apply Finset.sum_congr rfl + intro Q _ + obtain ⟨he, hf⟩ := + finitePlaceRelative_ramificationIdx_inertiaDeg_eq_of_same_under + K M L Q.1 Q₀.1 (Q.2.trans Q₀.2.symm) + rw [he, hf] + +omit [DecidableEq K] in +/-- The analogous Galois decomposition formula for a restriction fiber above +infinity. -/ +theorem infinityPlaceUnderFiber_card_mul_ramificationIdx_mul_inertiaDeg_eq_field_finrank + (P : FiniteExtensionInfinityPlace K M) + (Q₀ : InfinityPlaceUnderFiber K M L P) : + Fintype.card (InfinityPlaceUnderFiber K M L P) * + infinityPlaceRelativeRamificationIdx K M L Q₀.1 * + infinityPlaceRelativeInertiaDeg K M L Q₀.1 = + Module.finrank M L := by + rw [← sum_infinityPlaceUnderFiber_ramification_inertia_eq_field_finrank K M L P] + calc + _ = Fintype.card (InfinityPlaceUnderFiber K M L P) * + (infinityPlaceRelativeRamificationIdx K M L Q₀.1 * + infinityPlaceRelativeInertiaDeg K M L Q₀.1) := by + rw [Nat.mul_assoc] + _ = ∑ _Q : InfinityPlaceUnderFiber K M L P, + (infinityPlaceRelativeRamificationIdx K M L Q₀.1 * + infinityPlaceRelativeInertiaDeg K M L Q₀.1) := by simp + _ = _ := by + apply Finset.sum_congr rfl + intro Q _ + obtain ⟨he, hf⟩ := + infinityPlaceRelative_ramificationIdx_inertiaDeg_eq_of_same_under + K M L Q.1 Q₀.1 (Q.2.trans Q₀.2.symm) + rw [he, hf] + +/-- The decomposition group of a finite place in the relative Galois group. -/ +noncomputable def finitePlaceDecompositionGroup + (P : FiniteExtensionFinitePlace K L) : Subgroup Gal(L/M) := + letI := finiteIntegralClosureGalAction K M L + MulAction.stabilizer Gal(L/M) P.asIdeal + +/-- The inertia group of a finite place in the relative Galois group. -/ +noncomputable def finitePlaceInertiaGroup + (P : FiniteExtensionFinitePlace K L) : Subgroup Gal(L/M) := + letI := finiteIntegralClosureGalAction K M L + P.asIdeal.inertia Gal(L/M) + +/-- The decomposition group of a place above infinity in the relative Galois +group. -/ +noncomputable def infinityPlaceDecompositionGroup + (P : FiniteExtensionInfinityPlace K L) : Subgroup Gal(L/M) := + letI := infinityIntegralClosureGalAction K M L + MulAction.stabilizer Gal(L/M) P.1 + +/-- The inertia group of a place above infinity in the relative Galois group. -/ +noncomputable def infinityPlaceInertiaGroup + (P : FiniteExtensionInfinityPlace K L) : Subgroup Gal(L/M) := + letI := infinityIntegralClosureGalAction K M L + P.1.inertia Gal(L/M) + +section FiniteConstants + +variable [Fintype K] + +omit [DecidableEq K] [Fintype K] in +omit [DecidableEq (RatFunc K)] in +private theorem ratFuncFinitePlaceResidueField_finite [Finite K] + (p : HeightOneSpectrum K[X]) : Finite p.asIdeal.ResidueField := by + classical + let r := finitePlaceNormalizedPrime p + have hr0 : (r : K[X]) ≠ 0 := r.property.1.ne_zero + have hrmonic : (r : K[X]).Monic := + (Polynomial.normalize_eq_self_iff_monic hr0).mp r.property.2 + have hp : p.asIdeal = Ideal.span ({(r : K[X])} : Set K[X]) := by + calc + p.asIdeal = (normalizedPrimeFinitePlace (K := K) r).asIdeal := by + rw [normalizedPrimeFinitePlace_finitePlaceNormalizedPrime] + _ = Ideal.span ({(r : K[X])} : Set K[X]) := rfl + let : Module.Finite K (K[X] ⧸ p.asIdeal) := by + rw [hp] + exact hrmonic.finite_quotient + let : Finite (K[X] ⧸ p.asIdeal) := Module.finite_of_finite K + infer_instance + +omit [DecidableEq K] [Fintype K] in +omit [DecidableEq (RatFunc K)] in +private theorem finitePlaceResidueField_finite [Finite K] + (P : FiniteExtensionFinitePlace K M) : Finite P.asIdeal.ResidueField := by + classical + let p := HeightOneSpectrum.under K[X] P + let : Finite p.asIdeal.ResidueField := + ratFuncFinitePlaceResidueField_finite K p + let : P.asIdeal.LiesOver p.asIdeal := ⟨rfl⟩ + let := Localization.AtPrime.algebraOfLiesOver p.asIdeal P.asIdeal + have : IsScalarTower K[X] (Localization.AtPrime p.asIdeal) + (Localization.AtPrime P.asIdeal) := inferInstance + let : Algebra.QuasiFiniteAt K[X] P.asIdeal := inferInstance + let : Module.Finite p.asIdeal.ResidueField P.asIdeal.ResidueField := + inferInstance + exact Module.finite_of_finite p.asIdeal.ResidueField + +omit [DecidableEq K] [Fintype K] in +private theorem infinityPlaceResidueField_finite [Finite K] + (P : FiniteExtensionInfinityPlace K M) : Finite P.1.ResidueField := by + classical + let : Algebra K (RatFuncInfinityIntegers K) := + (ratFuncInfinityConstantRingHom K).toAlgebra + let : IsScalarTower K (RatFuncInfinityIntegers K) (RatFunc K) := + .of_algebraMap_eq' rfl + let p := (ratFuncInfinityPlace K).asIdeal + let : Finite p.ResidueField := + Finite.of_injective (ratFuncInfinityPlaceResidueEquiv K) + (ratFuncInfinityPlaceResidueEquiv K).injective + let : P.1.LiesOver p := by + simpa [p] using Ideal.primesOver.liesOver + (ratFuncInfinityPlace K).asIdeal P + let := Localization.AtPrime.algebraOfLiesOver p P.1 + have : IsScalarTower (RatFuncInfinityIntegers K) (Localization.AtPrime p) + (Localization.AtPrime P.1) := inferInstance + let : Algebra.QuasiFiniteAt (RatFuncInfinityIntegers K) P.1 := inferInstance + let : Module.Finite p.ResidueField P.1.ResidueField := inferInstance + exact Module.finite_of_finite p.ResidueField + +omit [DecidableEq K] [DecidableEq (RatFunc K)] [Fintype K] in +/-- The inertia-group cardinality is the ramification index at a finite +place. -/ +theorem finitePlaceInertiaGroup_card_eq_ramificationIdx [Finite K] + (P : FiniteExtensionFinitePlace K L) : + Nat.card (finitePlaceInertiaGroup K M L P) = + finitePlaceRelativeRamificationIdx K M L P := by + classical + let : Module.Finite M L := + Module.Finite.of_restrictScalars_finite (RatFunc K) M L + let := finiteIntegralClosureGalAction K M L + let := finiteIntegralClosureGalSmulComm K M L + let : IsGaloisGroup Gal(L/M) (RatFuncFiniteIntegralClosure K M) + (RatFuncFiniteIntegralClosure K L) := + IsGaloisGroup.of_isFractionRing _ _ _ M L + let p := finitePlaceUnder K M L P + let : P.asIdeal.LiesOver p.asIdeal := ⟨finitePlaceUnder_asIdeal K M L P⟩ + let : Finite p.asIdeal.ResidueField := + finitePlaceResidueField_finite K M p + let : PerfectField p.asIdeal.ResidueField := inferInstance + change Nat.card (P.asIdeal.inertia Gal(L/M)) = + P.asIdeal.ramificationIdx (RatFuncFiniteIntegralClosure K M) + rw [Ideal.card_inertia_eq_ramificationIdxIn p.asIdeal P.asIdeal] + exact Ideal.ramificationIdxIn_eq_ramificationIdx p.asIdeal P.asIdeal Gal(L/M) + +omit [DecidableEq K] [DecidableEq (RatFunc K)] [Fintype K] in +/-- The decomposition-group cardinality is ramification index times inertia +degree at a finite place. -/ +theorem finitePlaceDecompositionGroup_card_eq_ramificationIdx_mul_inertiaDeg [Finite K] + (P : FiniteExtensionFinitePlace K L) : + Nat.card (finitePlaceDecompositionGroup K M L P) = + finitePlaceRelativeRamificationIdx K M L P * + finitePlaceRelativeInertiaDeg K M L P := by + classical + let : Module.Finite M L := + Module.Finite.of_restrictScalars_finite (RatFunc K) M L + let := finiteIntegralClosureGalAction K M L + let := finiteIntegralClosureGalSmulComm K M L + let : IsGaloisGroup Gal(L/M) (RatFuncFiniteIntegralClosure K M) + (RatFuncFiniteIntegralClosure K L) := + IsGaloisGroup.of_isFractionRing _ _ _ M L + let p := finitePlaceUnder K M L P + let : P.asIdeal.LiesOver p.asIdeal := ⟨finitePlaceUnder_asIdeal K M L P⟩ + let : Finite p.asIdeal.ResidueField := + finitePlaceResidueField_finite K M p + let : PerfectField p.asIdeal.ResidueField := inferInstance + change Nat.card (MulAction.stabilizer Gal(L/M) P.asIdeal) = + P.asIdeal.ramificationIdx (RatFuncFiniteIntegralClosure K M) * + P.asIdeal.inertiaDeg (RatFuncFiniteIntegralClosure K M) + rw [Ideal.card_stabilizer_eq p.asIdeal P.asIdeal, + Ideal.ramificationIdxIn_eq_ramificationIdx p.asIdeal P.asIdeal Gal(L/M), + Ideal.inertiaDegIn_eq_inertiaDeg p.asIdeal P.asIdeal Gal(L/M)] + +omit [DecidableEq K] [Fintype K] in +/-- The inertia-group cardinality is the ramification index above infinity. -/ +theorem infinityPlaceInertiaGroup_card_eq_ramificationIdx [Finite K] + (P : FiniteExtensionInfinityPlace K L) : + Nat.card (infinityPlaceInertiaGroup K M L P) = + infinityPlaceRelativeRamificationIdx K M L P := by + classical + let : Module.Finite M L := + Module.Finite.of_restrictScalars_finite (RatFunc K) M L + let := infinityIntegralClosureGalAction K M L + let := infinityIntegralClosureGalSmulComm K M L + let : IsGaloisGroup Gal(L/M) (RatFuncInfinityIntegralClosure K M) + (RatFuncInfinityIntegralClosure K L) := + IsGaloisGroup.of_isFractionRing _ _ _ M L + let p := infinityPlaceUnder K M L P + let : P.1.LiesOver p.1 := ⟨infinityPlaceUnder_asIdeal K M L P⟩ + let : Finite p.1.ResidueField := + infinityPlaceResidueField_finite K M p + let : PerfectField p.1.ResidueField := inferInstance + change Nat.card (P.1.inertia Gal(L/M)) = + P.1.ramificationIdx (RatFuncInfinityIntegralClosure K M) + rw [Ideal.card_inertia_eq_ramificationIdxIn p.1 P.1] + exact Ideal.ramificationIdxIn_eq_ramificationIdx p.1 P.1 Gal(L/M) + +omit [DecidableEq K] [Fintype K] in +/-- The decomposition-group cardinality is ramification index times inertia +degree above infinity. -/ +theorem infinityPlaceDecompositionGroup_card_eq_ramificationIdx_mul_inertiaDeg [Finite K] + (P : FiniteExtensionInfinityPlace K L) : + Nat.card (infinityPlaceDecompositionGroup K M L P) = + infinityPlaceRelativeRamificationIdx K M L P * + infinityPlaceRelativeInertiaDeg K M L P := by + classical + let : Module.Finite M L := + Module.Finite.of_restrictScalars_finite (RatFunc K) M L + let := infinityIntegralClosureGalAction K M L + let := infinityIntegralClosureGalSmulComm K M L + let : IsGaloisGroup Gal(L/M) (RatFuncInfinityIntegralClosure K M) + (RatFuncInfinityIntegralClosure K L) := + IsGaloisGroup.of_isFractionRing _ _ _ M L + let p := infinityPlaceUnder K M L P + let : P.1.LiesOver p.1 := ⟨infinityPlaceUnder_asIdeal K M L P⟩ + let : Finite p.1.ResidueField := + infinityPlaceResidueField_finite K M p + let : PerfectField p.1.ResidueField := inferInstance + change Nat.card (MulAction.stabilizer Gal(L/M) P.1) = + P.1.ramificationIdx (RatFuncInfinityIntegralClosure K M) * + P.1.inertiaDeg (RatFuncInfinityIntegralClosure K M) + rw [Ideal.card_stabilizer_eq p.1 P.1, + Ideal.ramificationIdxIn_eq_ramificationIdx p.1 P.1 Gal(L/M), + Ideal.inertiaDegIn_eq_inertiaDeg p.1 P.1 Gal(L/M)] + +end FiniteConstants + +end Galois + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionPrincipalParts.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionPrincipalParts.lean new file mode 100644 index 0000000000..79c0f1326c --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionPrincipalParts.lean @@ -0,0 +1,423 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionLocalPoleQuotient +public import LeanPool.MarkoffModP.BGS.HasseWeil.FinitePrincipalParts +public import LeanPool.MarkoffModP.BGS.HasseWeil.RiemannSpaceConstants + +/-! +# Principal parts of an effective exhaustive divisor + +For an effective divisor `D` on the exhaustive places of a finite extension +of `K(X)`, this file forms the product of the local principal-part spaces over +the finite support of `D`. The local cumulative quotient calculation gives +this product dimension equal to `deg D`. + +The Riemann space `L(D)` maps diagonally to those principal parts. Its kernel +is exactly `L(0)`: vanishing of the principal part gives regularity on the +support, while membership in `L(D)` already gives regularity off the support. +Consequently `L(D) / L(0)` is finite-dimensional and has dimension at most +`deg D`. Under the exact-constant-field hypothesis, the denominator is the +space of constants. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +open BGS.CorvajaZannier +open Submodule +open scoped Polynomial BigOperators + +noncomputable section + + +variable (K : Type*) [Field K] [Fintype K] [DecidableEq K] + [DecidableEq (RatFunc K)] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +local instance finitePrincipalPartsConstantAlgebra : Algebra K L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K (RatFunc K))) + +local instance finitePrincipalPartsConstantTower : + IsScalarTower K (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + +/-- Principal parts at a place in the support of an effective exhaustive +divisor. -/ +abbrev finiteExtensionPrincipalPartAt + (D : FiniteExtensionDivisor K L) (P : ↥D.support) := + finiteExtensionLocalPoleSpace K L P.1 (D P.1).toNat ⧸ + relativeSubmodule + (finiteExtensionLocalPoleSpace K L P.1 0) + (finiteExtensionLocalPoleSpace K L P.1 (D P.1).toNat) + +/-- The finite product of local principal parts supported by `D`. -/ +abbrev finiteExtensionPrincipalPartsSpace + (D : FiniteExtensionDivisor K L) := + ∀ P : ↥D.support, finiteExtensionPrincipalPartAt K L D P + +/-- The natural-number weighted degree of an effective exhaustive divisor. -/ +def finiteExtensionEffectiveDivisorNatDegree + (D : FiniteExtensionDivisor K L) : ℕ := + ∑ P : ↥D.support, + (D P.1).toNat * finiteExtensionPlaceDegree K L P.1 + +omit [Fintype K] [DecidableEq K] [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] in +/-- A nonzero effective coefficient has positive natural part. -/ +theorem finiteExtensionDivisor_toNat_pos_of_mem_support + (D : FiniteExtensionDivisor K L) (hD : ∀ P, 0 ≤ D P) + (P : ↥D.support) : + 0 < (D P.1).toNat := by + rw [← Int.pos_iff_toNat_pos] + have hne : D P.1 ≠ 0 := Finsupp.mem_support_iff.mp P.2 + exact lt_of_le_of_ne (hD P.1) (Ne.symm hne) + +/-- Each supported local principal-part quotient is finite-dimensional. -/ +theorem finiteExtensionPrincipalPartAt_moduleFinite + (D : FiniteExtensionDivisor K L) (hD : ∀ P, 0 ≤ D P) + (P : ↥D.support) : + Module.Finite K (finiteExtensionPrincipalPartAt K L D P) := by + apply Module.finite_of_finrank_pos + rw [finiteExtensionLocalPoleSpace_cumulative_finrank K L P.1 + (D P.1).toNat] + exact Nat.mul_pos + (finiteExtensionDivisor_toNat_pos_of_mem_support K L D hD P) + (finiteExtensionPlaceDegree_pos K L P.1) + +/-- The supported product of local principal parts is finite-dimensional. -/ +theorem finiteExtensionPrincipalPartsSpace_moduleFinite + (D : FiniteExtensionDivisor K L) (hD : ∀ P, 0 ≤ D P) : + Module.Finite K (finiteExtensionPrincipalPartsSpace K L D) := by + let (P : ↥D.support) : Module.Finite K + (finiteExtensionPrincipalPartAt K L D P) := + finiteExtensionPrincipalPartAt_moduleFinite K L D hD P + exact Module.Finite.pi + +/-- The supported product has dimension equal to the natural weighted degree +of `D`. -/ +theorem finiteExtensionPrincipalPartsSpace_finrank + (D : FiniteExtensionDivisor K L) (hD : ∀ P, 0 ≤ D P) : + Module.finrank K (finiteExtensionPrincipalPartsSpace K L D) = + finiteExtensionEffectiveDivisorNatDegree K L D := by + let (P : ↥D.support) : Module.Finite K + (finiteExtensionPrincipalPartAt K L D P) := + finiteExtensionPrincipalPartAt_moduleFinite K L D hD P + let (P : ↥D.support) : Module.Free K + (finiteExtensionPrincipalPartAt K L D P) := + Module.Free.of_divisionRing K (finiteExtensionPrincipalPartAt K L D P) + rw [Module.finrank_pi_fintype] + apply Finset.sum_congr rfl + intro P _ + exact finiteExtensionLocalPoleSpace_cumulative_finrank K L P.1 + (D P.1).toNat + +omit [Fintype K] [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] in +/-- For an effective divisor, the natural weighted degree casts to the usual +integer-valued divisor degree. -/ +theorem finiteExtensionEffectiveDivisorNatDegree_cast + (D : FiniteExtensionDivisor K L) (hD : ∀ P, 0 ≤ D P) : + (finiteExtensionEffectiveDivisorNatDegree K L D : ℤ) = + finiteExtensionDivisorDegree K L D := by + rw [finiteExtensionEffectiveDivisorNatDegree, finiteExtensionDivisorDegree, + Finsupp.sum] + push_cast + calc + (∑ P : ↥D.support, + ((D P.1).toNat : ℤ) * + (finiteExtensionPlaceDegree K L P.1 : ℤ)) = + ∑ P ∈ D.support, + ((D P).toNat : ℤ) * + (finiteExtensionPlaceDegree K L P : ℤ) := + Finset.sum_coe_sort D.support (fun P => + ((D P).toNat : ℤ) * + (finiteExtensionPlaceDegree K L P : ℤ)) + _ = ∑ P ∈ D.support, + D P * (finiteExtensionPlaceDegree K L P : ℤ) := by + apply Finset.sum_congr rfl + intro P _ + rw [Int.toNat_of_nonneg (hD P)] + +/-- Membership in `L(D)` supplies the local pole bound at every place. -/ +theorem finiteExtensionRiemannSpace_le_localPoleSpace + (D : FiniteExtensionDivisor K L) (hD : ∀ P, 0 ≤ D P) + (P : FiniteExtensionPlace K L) : + finiteExtensionRiemannSpace K L D ≤ + finiteExtensionLocalPoleSpace K L P (D P).toNat := by + intro x hx + rw [mem_finiteExtensionRiemannSpace] at hx + rw [mem_finiteExtensionLocalPoleSpace_iff] + rcases hx with rfl | ⟨hx0, hx⟩ + · exact Or.inl rfl + · refine Or.inr ⟨hx0, ?_⟩ + have hcoeff : ((D P).toNat : ℤ) = D P := + Int.toNat_of_nonneg (hD P) + have hP := hx P + omega + +/-- The diagonal principal-parts map from `L(D)`. -/ +def finiteExtensionRiemannPrincipalPartsDiagonalMap + (D : FiniteExtensionDivisor K L) (hD : ∀ P, 0 ≤ D P) : + finiteExtensionRiemannSpace K L D →ₗ[K] + finiteExtensionPrincipalPartsSpace K L D := + LinearMap.pi fun P => + (relativeSubmodule + (finiteExtensionLocalPoleSpace K L P.1 0) + (finiteExtensionLocalPoleSpace K L P.1 (D P.1).toNat)).mkQ.comp + (Submodule.inclusion + (finiteExtensionRiemannSpace_le_localPoleSpace K L D hD P.1)) + +/-- The kernel of the diagonal map is the copy of `L(0)` inside `L(D)`. -/ +theorem finiteExtensionRiemannPrincipalPartsDiagonalMap_ker + (D : FiniteExtensionDivisor K L) (hD : ∀ P, 0 ≤ D P) : + LinearMap.ker + (finiteExtensionRiemannPrincipalPartsDiagonalMap K L D hD) = + relativeSubmodule + (finiteExtensionRiemannSpace K L 0) + (finiteExtensionRiemannSpace K L D) := by + ext x + rw [LinearMap.mem_ker, Submodule.mem_comap] + constructor + · intro hxker + rw [mem_finiteExtensionRiemannSpace] + have hxD := x.2 + rw [mem_finiteExtensionRiemannSpace] at hxD + rcases hxD with hx0 | ⟨hx0, hxorders⟩ + · exact Or.inl hx0 + · refine Or.inr ⟨hx0, ?_⟩ + intro P + by_cases hP : P ∈ D.support + · let P' : ↥D.support := ⟨P, hP⟩ + have hcomponent := congrFun hxker P' + change Submodule.Quotient.mk + (Submodule.inclusion + (finiteExtensionRiemannSpace_le_localPoleSpace + K L D hD P) x) = 0 at hcomponent + rw [Submodule.Quotient.mk_eq_zero] at hcomponent + change (x : L) ∈ + finiteExtensionLocalPoleSpace K L P 0 at hcomponent + rw [mem_finiteExtensionLocalPoleSpace_iff] at hcomponent + rcases hcomponent with hzero | ⟨_, horder⟩ + · exact (hx0 hzero).elim + · simpa using horder + · have hDP : D P = 0 := by + simpa [Finsupp.mem_support_iff] using hP + have horder := hxorders P + rw [hDP] at horder + simpa using horder + · intro hxzero + funext P + change Submodule.Quotient.mk + (Submodule.inclusion + (finiteExtensionRiemannSpace_le_localPoleSpace + K L D hD P.1) x) = 0 + rw [Submodule.Quotient.mk_eq_zero] + change (x : L) ∈ + finiteExtensionLocalPoleSpace K L P.1 0 + rw [mem_finiteExtensionRiemannSpace] at hxzero + rw [mem_finiteExtensionLocalPoleSpace_iff] + rcases hxzero with hxzero | ⟨hx0, hxorders⟩ + · exact Or.inl hxzero + · exact Or.inr ⟨hx0, by simpa using hxorders P.1⟩ + +/-- The diagonal map descends injectively from `L(D) / L(0)`. -/ +def finiteExtensionRiemannPrincipalPartsQuotientMap + (D : FiniteExtensionDivisor K L) (hD : ∀ P, 0 ≤ D P) : + (finiteExtensionRiemannSpace K L D ⧸ + relativeSubmodule + (finiteExtensionRiemannSpace K L 0) + (finiteExtensionRiemannSpace K L D)) →ₗ[K] + finiteExtensionPrincipalPartsSpace K L D := by + letI localPrincipalPartModule (P : ↥D.support) : Module K + (finiteExtensionPrincipalPartAt K L D P) := inferInstance + letI finitePrincipalPartsModule : Module K + (finiteExtensionPrincipalPartsSpace K L D) := + Pi.module ↥D.support + (fun P => finiteExtensionPrincipalPartAt K L D P) K + let f : finiteExtensionRiemannSpace K L D →ₗ[K] + finiteExtensionPrincipalPartsSpace K L D := + finiteExtensionRiemannPrincipalPartsDiagonalMap K L D hD + have hfker : f.ker = + relativeSubmodule + (finiteExtensionRiemannSpace K L 0) + (finiteExtensionRiemannSpace K L D) := by + simpa [f] using + finiteExtensionRiemannPrincipalPartsDiagonalMap_ker K L D hD + exact quotientLinearMapOfKerEq + (K := K) (V := finiteExtensionRiemannSpace K L D) + (W := finiteExtensionPrincipalPartsSpace K L D) f + (relativeSubmodule + (finiteExtensionRiemannSpace K L 0) + (finiteExtensionRiemannSpace K L D)) + hfker + +/-- The descended principal-parts map is injective. -/ +theorem finiteExtensionRiemannPrincipalPartsQuotientMap_injective + (D : FiniteExtensionDivisor K L) (hD : ∀ P, 0 ≤ D P) : + Function.Injective + (finiteExtensionRiemannPrincipalPartsQuotientMap K L D hD) := by + let localPrincipalPartModule (P : ↥D.support) : Module K + (finiteExtensionPrincipalPartAt K L D P) := inferInstance + let finitePrincipalPartsModule : Module K + (finiteExtensionPrincipalPartsSpace K L D) := + Pi.module ↥D.support + (fun P => finiteExtensionPrincipalPartAt K L D P) K + let f : finiteExtensionRiemannSpace K L D →ₗ[K] + finiteExtensionPrincipalPartsSpace K L D := + finiteExtensionRiemannPrincipalPartsDiagonalMap K L D hD + have hfker : f.ker = + relativeSubmodule + (finiteExtensionRiemannSpace K L 0) + (finiteExtensionRiemannSpace K L D) := by + simpa [f] using + finiteExtensionRiemannPrincipalPartsDiagonalMap_ker K L D hD + exact quotientLinearMapOfKerEq_injective + (K := K) (V := finiteExtensionRiemannSpace K L D) + (W := finiteExtensionPrincipalPartsSpace K L D) f + (relativeSubmodule + (finiteExtensionRiemannSpace K L 0) + (finiteExtensionRiemannSpace K L D)) + hfker + +/-- For an effective divisor, `L(D) / L(0)` is finite-dimensional. -/ +theorem finiteExtensionRiemannSpace_quotient_zero_moduleFinite + (D : FiniteExtensionDivisor K L) (hD : ∀ P, 0 ≤ D P) : + Module.Finite K + (finiteExtensionRiemannSpace K L D ⧸ + relativeSubmodule + (finiteExtensionRiemannSpace K L 0) + (finiteExtensionRiemannSpace K L D)) := by + let localPrincipalPartModule (P : ↥D.support) : Module K + (finiteExtensionPrincipalPartAt K L D P) := inferInstance + let finitePrincipalPartsModule : Module K + (finiteExtensionPrincipalPartsSpace K L D) := + Pi.module ↥D.support + (fun P => finiteExtensionPrincipalPartAt K L D P) K + let (P : ↥D.support) : Module.Finite K + (finiteExtensionPrincipalPartAt K L D P) := + finiteExtensionPrincipalPartAt_moduleFinite K L D hD P + let : Module.Finite K (finiteExtensionPrincipalPartsSpace K L D) := + Module.Finite.pi + let f : finiteExtensionRiemannSpace K L D →ₗ[K] + finiteExtensionPrincipalPartsSpace K L D := + finiteExtensionRiemannPrincipalPartsDiagonalMap K L D hD + have hfker : f.ker = + relativeSubmodule + (finiteExtensionRiemannSpace K L 0) + (finiteExtensionRiemannSpace K L D) := by + simpa [f] using + finiteExtensionRiemannPrincipalPartsDiagonalMap_ker K L D hD + let q := quotientLinearMapOfKerEq + (K := K) (V := finiteExtensionRiemannSpace K L D) + (W := finiteExtensionPrincipalPartsSpace K L D) f + (relativeSubmodule + (finiteExtensionRiemannSpace K L 0) + (finiteExtensionRiemannSpace K L D)) + hfker + have hq : Function.Injective q := + quotientLinearMapOfKerEq_injective + (K := K) (V := finiteExtensionRiemannSpace K L D) + (W := finiteExtensionPrincipalPartsSpace K L D) f + (relativeSubmodule + (finiteExtensionRiemannSpace K L 0) + (finiteExtensionRiemannSpace K L D)) + hfker + exact Module.Finite.of_injective q hq + +/-- Riemann's elementary principal-parts upper bound for an effective +exhaustive divisor. -/ +theorem finiteExtensionRiemannSpace_quotient_zero_finrank_le + (D : FiniteExtensionDivisor K L) (hD : ∀ P, 0 ≤ D P) : + Module.finrank K + (finiteExtensionRiemannSpace K L D ⧸ + relativeSubmodule + (finiteExtensionRiemannSpace K L 0) + (finiteExtensionRiemannSpace K L D)) ≤ + finiteExtensionEffectiveDivisorNatDegree K L D := by + let localPrincipalPartModule (P : ↥D.support) : Module K + (finiteExtensionPrincipalPartAt K L D P) := inferInstance + let finitePrincipalPartsModule : Module K + (finiteExtensionPrincipalPartsSpace K L D) := + Pi.module ↥D.support + (fun P => finiteExtensionPrincipalPartAt K L D P) K + let (P : ↥D.support) : Module.Finite K + (finiteExtensionPrincipalPartAt K L D P) := + finiteExtensionPrincipalPartAt_moduleFinite K L D hD P + let : Module.Finite K (finiteExtensionPrincipalPartsSpace K L D) := + Module.Finite.pi + let f : finiteExtensionRiemannSpace K L D →ₗ[K] + finiteExtensionPrincipalPartsSpace K L D := + finiteExtensionRiemannPrincipalPartsDiagonalMap K L D hD + have hfker : f.ker = + relativeSubmodule + (finiteExtensionRiemannSpace K L 0) + (finiteExtensionRiemannSpace K L D) := by + simpa [f] using + finiteExtensionRiemannPrincipalPartsDiagonalMap_ker K L D hD + let q := quotientLinearMapOfKerEq + (K := K) (V := finiteExtensionRiemannSpace K L D) + (W := finiteExtensionPrincipalPartsSpace K L D) f + (relativeSubmodule + (finiteExtensionRiemannSpace K L 0) + (finiteExtensionRiemannSpace K L D)) + hfker + have hq : Function.Injective q := + quotientLinearMapOfKerEq_injective + (K := K) (V := finiteExtensionRiemannSpace K L D) + (W := finiteExtensionPrincipalPartsSpace K L D) f + (relativeSubmodule + (finiteExtensionRiemannSpace K L 0) + (finiteExtensionRiemannSpace K L D)) + hfker + calc + Module.finrank K + (finiteExtensionRiemannSpace K L D ⧸ + relativeSubmodule + (finiteExtensionRiemannSpace K L 0) + (finiteExtensionRiemannSpace K L D)) ≤ + Module.finrank K (finiteExtensionPrincipalPartsSpace K L D) := + q.finrank_le_finrank_of_injective hq + _ = finiteExtensionEffectiveDivisorNatDegree K L D := + finiteExtensionPrincipalPartsSpace_finrank K L D hD + +/-- Integer-valued form of the principal-parts upper bound. -/ +theorem finiteExtensionRiemannSpace_quotient_zero_finrank_cast_le_degree + (D : FiniteExtensionDivisor K L) (hD : ∀ P, 0 ≤ D P) : + (Module.finrank K + (finiteExtensionRiemannSpace K L D ⧸ + relativeSubmodule + (finiteExtensionRiemannSpace K L 0) + (finiteExtensionRiemannSpace K L D)) : ℤ) ≤ + finiteExtensionDivisorDegree K L D := by + rw [← finiteExtensionEffectiveDivisorNatDegree_cast K L D hD] + exact_mod_cast finiteExtensionRiemannSpace_quotient_zero_finrank_le + K L D hD + +/-- With exact constants, the preceding quotient is literally `L(D)` modulo +the constant functions. -/ +theorem finiteExtensionRiemannSpace_mod_constants_finrank_cast_le_degree + (D : FiniteExtensionDivisor K L) (hD : ∀ P, 0 ≤ D P) + (hconstants : algebraicClosure K L = ⊥) : + (Module.finrank K + (finiteExtensionRiemannSpace K L D ⧸ + relativeSubmodule + (LinearMap.range (Algebra.linearMap K L)) + (finiteExtensionRiemannSpace K L D)) : ℤ) ≤ + finiteExtensionDivisorDegree K L D := by + rw [← finiteExtensionRiemannSpace_zero_eq_range K L hconstants] + exact finiteExtensionRiemannSpace_quotient_zero_finrank_cast_le_degree + K L D hD + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionRiemannEventualGrowth.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionRiemannEventualGrowth.lean new file mode 100644 index 0000000000..4ea30ce80d --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionRiemannEventualGrowth.lean @@ -0,0 +1,128 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.GeneralFiniteExtensionRiemannLower +public import Mathlib.Order.OrderIsoNat +public import Mathlib.Tactic + +/-! +# Eventual exact growth of one-point Riemann spaces + +A coarse Riemann lower bound and the one-place principal-parts upper bound +already force eventual exact linear growth. For a place `P`, define the +surplus + +`dim L(nP) + g - (n deg(P) + 1)`. + +The lower bound makes this a natural number without truncation, while the +one-place increment bound makes it antitone. Since a decreasing sequence of +natural numbers is eventually constant, `dim L((n+1)P) - dim L(nP)` is +eventually exactly `deg(P)`. + +This is the elementary stabilization input used in the divisor-class proof +of zeta rationality; it does not assume Riemann--Roch or a zeta theorem. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +open BGS.CorvajaZannier +open scoped Polynomial + +noncomputable section + + +variable (K : Type*) [Field K] [Fintype K] [DecidableEq K] + [DecidableEq (RatFunc K)] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +/-- The bounded nonnegative error in a one-point Riemann lower bound. -/ +def finiteExtensionOnePointRiemannSurplus + (P : FiniteExtensionPlace K L) (g n : ℕ) : ℕ := + Module.finrank K (finiteExtensionOnePointRiemannSpace K L P n) + g - + (n * finiteExtensionPlaceDegree K L P + 1) + +/-- The Riemann surplus is antitone: adding one copy of the pole place raises +dimension by at most the degree of that place. -/ +theorem finiteExtensionOnePointRiemannSurplus_antitone_of_lower + (P : FiniteExtensionPlace K L) (g : ℕ) + (hLower : ∀ n : ℕ, + n * finiteExtensionPlaceDegree K L P + 1 ≤ + Module.finrank K + (finiteExtensionOnePointRiemannSpace K L P n) + g) : + Antitone (finiteExtensionOnePointRiemannSurplus K L P g) := by + apply antitone_nat_of_succ_le + intro n + let D : FiniteExtensionDivisor K L := Finsupp.single P (n : ℤ) + have hD : ∀ v, 0 ≤ D v := by + intro v + by_cases hv : v = P + · subst v + simp [D] + · simp [D, Finsupp.single_eq_of_ne hv] + let : Module.Finite K (finiteExtensionRiemannSpace K L D) := + finiteExtensionRiemannSpace_effective_moduleFinite K L D hD + have hinc := finiteExtensionRiemannSpace_place_increment K L D hD P + have hdivisor : D + Finsupp.single P 1 = + Finsupp.single P ((n + 1 : ℕ) : ℤ) := by + ext v + by_cases hv : v = P + · subst v + simp [D] + · simp [D, Finsupp.single_eq_of_ne hv] + have hfinrank : + Module.finrank K + (finiteExtensionOnePointRiemannSpace K L P (n + 1)) ≤ + Module.finrank K + (finiteExtensionOnePointRiemannSpace K L P n) + + finiteExtensionPlaceDegree K L P := by + change Module.finrank K (finiteExtensionRiemannSpace K L + (Finsupp.single P (((n + 1 : ℕ) : ℤ)))) ≤ + Module.finrank K (finiteExtensionRiemannSpace K L + (Finsupp.single P (n : ℤ))) + finiteExtensionPlaceDegree K L P + rw [← hdivisor] + simpa only [D] using hinc.2 + have hn := hLower n + have hsucc := hLower (n + 1) + simp only [finiteExtensionOnePointRiemannSurplus, Nat.succ_mul] at hsucc ⊢ + omega + +/-- Any one-point Riemann lower bound implies that the dimension increment is +eventually exactly the place degree. -/ +theorem finiteExtensionOnePointRiemannSpace_eventually_exact_increment + (P : FiniteExtensionPlace K L) (g : ℕ) + (hLower : ∀ n : ℕ, + n * finiteExtensionPlaceDegree K L P + 1 ≤ + Module.finrank K + (finiteExtensionOnePointRiemannSpace K L P n) + g) : + ∃ N : ℕ, ∀ n : ℕ, N ≤ n → + Module.finrank K + (finiteExtensionOnePointRiemannSpace K L P (n + 1)) = + Module.finrank K + (finiteExtensionOnePointRiemannSpace K L P n) + + finiteExtensionPlaceDegree K L P := by + have hanti := + finiteExtensionOnePointRiemannSurplus_antitone_of_lower + K L P g hLower + obtain ⟨N, hN⟩ := WellFoundedLT.antitone_chain_condition hanti + refine ⟨N, ?_⟩ + intro n hn + have heq : finiteExtensionOnePointRiemannSurplus K L P g n = + finiteExtensionOnePointRiemannSurplus K L P g (n + 1) := + (hN n hn).symm.trans (hN (n + 1) (hn.trans (Nat.le_succ n))) + have hlowN := hLower n + have hlowSucc := hLower (n + 1) + simp only [finiteExtensionOnePointRiemannSurplus, Nat.succ_mul] at heq hlowSucc + omega + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionRiemannLowerFromGenus.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionRiemannLowerFromGenus.lean new file mode 100644 index 0000000000..5c566f8336 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionRiemannLowerFromGenus.lean @@ -0,0 +1,89 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionRiemannRoch +public import LeanPool.MarkoffModP.BGS.HasseWeil.OnePointDivisorSplit + +/-! +# One-point Riemann lower bounds from the intrinsic genus + +Riemann's inequality gives the intrinsic function-field genus itself as a +simultaneous budget for every one-point Riemann space. This applies to the +exhaustive BGS place type, including both finite and infinity places. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +open BGS.CorvajaZannier +open scoped Polynomial + +noncomputable section + +variable (K : Type*) [Field K] [Fintype K] [DecidableEq K] + [DecidableEq (RatFunc K)] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +local instance genusRiemannConstantAlgebra : Algebra K L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K (RatFunc K))) + +local instance genusRiemannConstantTower : + IsScalarTower K (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + +local instance (priority := 10) genusRiemannPolynomialAlgebra : Algebra K[X] L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K[X] (RatFunc K))) + +local instance genusRiemannPolynomialRatFuncTower : + IsScalarTower K[X] (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + +local instance genusRiemannConstantPolynomialTower : + IsScalarTower K K[X] L := + IsScalarTower.of_algebraMap_eq' rfl + +/-- Riemann's inequality gives the intrinsic genus as a simultaneous budget +for every one-point Riemann space in the exhaustive finite/infinity place +model. -/ +theorem finiteExtension_onePoint_riemann_lower_of_genus + [FunctionField.IsFullConstantField K L] + (P : FiniteExtensionPlace K L) (N : Nat) : + N * finiteExtensionPlaceDegree K L P + 1 ≤ + Module.finrank K (finiteExtensionOnePointRiemannSpace K L P N) + + FunctionField.genus K L := by + let D : FiniteExtensionDivisor K L := Finsupp.single P (N : Int) + let Dchart := finiteExtensionDivisorEquivChart K L D + have hRR := FunctionField.Chart.riemann_ineq K L Dchart + have hdegree : FunctionField.Chart.deg K L Dchart = + (N * finiteExtensionPlaceDegree K L P : Nat) := by + rw [← finiteExtensionDivisorDegree_eq_chart K L D] + dsimp only [D] + rw [finiteExtensionDivisorDegree_single] + norm_num + have hspace : FunctionField.Chart.RRspace K L Dchart = + finiteExtensionOnePointRiemannSpace K L P N := by + rw [← finiteExtensionRiemannSpace_eq_chart K L D] + rfl + rw [FunctionField.Chart.ell, hspace, hdegree, + ← FunctionField.genus_eq_genusChart K L] at hRR + change ((Module.finrank K + (finiteExtensionOnePointRiemannSpace K L P N) : Nat) : Int) ≥ + ((N * finiteExtensionPlaceDegree K L P : Nat) : Int) + 1 - + (FunctionField.genus K L : Int) at hRR + exact_mod_cast (show N * finiteExtensionPlaceDegree K L P + 1 ≤ + Module.finrank K (finiteExtensionOnePointRiemannSpace K L P N) + + FunctionField.genus K L by omega) + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionRiemannRoch.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionRiemannRoch.lean new file mode 100644 index 0000000000..05b6e58933 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionRiemannRoch.lean @@ -0,0 +1,635 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionDivisorClassRecurrence +public import LeanPool.MarkoffModP.RiemannRoch.CoordinateFree.RiemannRoch + +/-! +# Riemann--Roch for the exhaustive finite-extension place model + +This file identifies the exhaustive finite and infinite places used by the BGS +function-field development with the two-chart place model of the vendored +Riemann--Roch library. The identification transports residue degrees, +divisors, divisor degree, normalized valuations, and Riemann spaces. It then +applies the axiom-clean Riemann--Roch theorem to discharge the eventual uniform +Riemann formula required by the divisor-class recurrence. + +The only non-definitional chart issue is at infinity: the two developments +construct the same valuation subring using different `DecidableEq` instances. +We therefore record the identity-on-elements ring equivalence explicitly and +transport the integral closure and its height-one primes across it. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +open BGS.CorvajaZannier +open IsDedekindDomain Multiplicative WithZero +open scoped Polynomial + +noncomputable section + +variable (K : Type*) [Field K] [Fintype K] [DecidableEq K] + [DecidableEq (RatFunc K)] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +local instance riemannRochConstantAlgebra : Algebra K L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K (RatFunc K))) + +local instance riemannRochConstantRatFuncTower : IsScalarTower K (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + +local instance (priority := 10) riemannRochPolynomialAlgebra : Algebra K[X] L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K[X] (RatFunc K))) + +local instance riemannRochPolynomialRatFuncTower : + IsScalarTower K[X] (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + +local instance riemannRochConstantPolynomialTower : IsScalarTower K K[X] L := + IsScalarTower.of_algebraMap_eq' rfl + +local instance riemannRochInfinityBaseConstantAlgebra : + Algebra K (RatFuncInfinityIntegers K) := + (ratFuncInfinityConstantRingHom K).toAlgebra + +local instance riemannRochInfinityClosureModuleFinite : + Module.Finite (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.finite (RatFuncInfinityIntegers K) (RatFunc K) L + (RatFuncInfinityIntegralClosure K L) + +local instance riemannRochInfinityClosureIsIntegral : + Algebra.IsIntegral (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.isIntegral_algebra (RatFuncInfinityIntegers K) L + +local instance riemannRochInfinityBaseTorsionFreeTop : + Module.IsTorsionFree (RatFuncInfinityIntegers K) L := + Module.IsTorsionFree.trans_faithfulSMul + (RatFuncInfinityIntegers K) (RatFunc K) L + +local instance riemannRochInfinityClosureIsTorsionFree : + Module.IsTorsionFree (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.isTorsionFree (RatFuncInfinityIntegers K) L + +local instance riemannRochInfinityClosureIsDedekind : + IsDedekindDomain (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.isDedekindDomain + (RatFuncInfinityIntegers K) (RatFunc K) L + (RatFuncInfinityIntegralClosure K L) + +local instance riemannRochInfinityClosureIsFractionRing : + IsFractionRing (RatFuncInfinityIntegralClosure K L) L := + IsIntegralClosure.isFractionRing_of_finite_extension + (RatFuncInfinityIntegers K) (RatFunc K) L + (RatFuncInfinityIntegralClosure K L) + +local instance riemannRochInfinityClosureConstantAlgebra : + Algebra K (RatFuncInfinityIntegralClosure K L) := + RingHom.toAlgebra + ((algebraMap (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L)).comp + (algebraMap K (RatFuncInfinityIntegers K))) + +local instance riemannRochInfinityClosureConstantTower : + IsScalarTower K (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) := + IsScalarTower.of_algebraMap_eq' rfl + +/-- The BGS and Riemann--Roch infinity valuation subrings are the same +subring of `RatFunc K`; this equivalence makes the harmless instance-level +difference explicit. -/ +def finiteExtensionInfinityBaseRingEquiv : + RatFuncInfinityIntegers K ≃+* + FunctionField.Chart.inftyValuationSubring K where + toFun x := ⟨x.1, by + have hx := x.2 + unfold RatFuncInfinityIntegers at hx + rw [Valuation.mem_integer_iff] at hx + rw [Valuation.mem_valuationSubring_iff] + have hdec : (inferInstance : DecidableEq (RatFunc K)) = + Classical.decEq (RatFunc K) := Subsingleton.elim _ _ + cases hdec + exact hx⟩ + invFun x := ⟨x.1, by + have hx := x.2 + unfold FunctionField.Chart.inftyValuationSubring at hx + rw [Valuation.mem_valuationSubring_iff] at hx + unfold RatFuncInfinityIntegers + rw [Valuation.mem_integer_iff] + have hdec : (inferInstance : DecidableEq (RatFunc K)) = + Classical.decEq (RatFunc K) := Subsingleton.elim _ _ + cases hdec + exact hx⟩ + left_inv _ := rfl + right_inv _ := rfl + map_mul' _ _ := rfl + map_add' _ _ := rfl + +omit [Fintype K] [DecidableEq K] in +@[simp] +theorem finiteExtensionInfinityBaseRingEquiv_apply_coe + (x : RatFuncInfinityIntegers K) : + ((finiteExtensionInfinityBaseRingEquiv K x : + FunctionField.Chart.inftyValuationSubring K) : RatFunc K) = x := + rfl + +omit [Fintype K] [DecidableEq K] [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] in +private theorem isIntegral_infinityBase_iff (x : L) : + IsIntegral (RatFuncInfinityIntegers K) x ↔ + IsIntegral (FunctionField.Chart.inftyValuationSubring K) x := by + let e := finiteExtensionInfinityBaseRingEquiv K + have hforward : + (algebraMap (FunctionField.Chart.inftyValuationSubring K) L).comp + e.toRingHom = + algebraMap (RatFuncInfinityIntegers K) L := by + ext a + rfl + have hbackward : + (algebraMap (RatFuncInfinityIntegers K) L).comp + e.symm.toRingHom = + algebraMap (FunctionField.Chart.inftyValuationSubring K) L := by + ext a + rfl + constructor + · intro hx + have hx' : + ((algebraMap (FunctionField.Chart.inftyValuationSubring K) L).comp + e.toRingHom).IsIntegralElem x := by + rw [hforward] + exact hx + exact hx'.of_comp + · intro hx + have hx' : + ((algebraMap (RatFuncInfinityIntegers K) L).comp + e.symm.toRingHom).IsIntegralElem x := by + rw [hbackward] + exact hx + exact hx'.of_comp + +/-- Identity-on-`L` equivalence between the two infinity integral closures. -/ +def finiteExtensionInfinityIntegralClosureRingEquiv : + RatFuncInfinityIntegralClosure K L ≃+* + FunctionField.Chart.infiniteIntegers K L where + toFun x := ⟨x.1, by exact (isIntegral_infinityBase_iff K L x.1).mp x.2⟩ + invFun x := ⟨x.1, by exact (isIntegral_infinityBase_iff K L x.1).mpr x.2⟩ + left_inv _ := rfl + right_inv _ := rfl + map_mul' _ _ := rfl + map_add' _ _ := rfl + +omit [Fintype K] [DecidableEq K] [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] in +@[simp] +theorem finiteExtensionInfinityIntegralClosureRingEquiv_apply_coe + (x : RatFuncInfinityIntegralClosure K L) : + ((finiteExtensionInfinityIntegralClosureRingEquiv K L x : + FunctionField.Chart.infiniteIntegers K L) : L) = x := + rfl + +/-- Constant-field-linear form of the infinity integral-closure equivalence. -/ +def finiteExtensionInfinityIntegralClosureAlgEquiv : + RatFuncInfinityIntegralClosure K L ≃ₐ[K] + FunctionField.Chart.infiniteIntegers K L where + __ := finiteExtensionInfinityIntegralClosureRingEquiv K L + commutes' c := by + apply Subtype.ext + rfl + +/-- Places above the BGS infinity place are exactly the height-one primes of +the BGS infinity integral closure. -/ +def finiteExtensionInfinityPrimesOverEquivHeightOne : + FiniteExtensionInfinityPlace K L ≃ + HeightOneSpectrum (RatFuncInfinityIntegralClosure K L) where + toFun P := primeOverHeightOne (ratFuncInfinityPlace K) P + invFun q := ⟨q.asIdeal, q.isPrime, ⟨by + let A := RatFuncInfinityIntegers K + let : q.asIdeal.IsMaximal := q.isPrime.isMaximal q.ne_bot + have hq : q.asIdeal.under A = IsLocalRing.maximalIdeal A := + IsLocalRing.eq_maximalIdeal (Ideal.IsMaximal.under A q.asIdeal) + have hp : (ratFuncInfinityPlace K).asIdeal = + IsLocalRing.maximalIdeal A := + IsLocalRing.eq_maximalIdeal + ((ratFuncInfinityPlace K).isPrime.isMaximal + (ratFuncInfinityPlace K).ne_bot) + exact (hq.trans hp.symm).symm⟩⟩ + left_inv P := by + apply Subtype.ext + rfl + right_inv q := by + apply HeightOneSpectrum.ext + rfl + +/-- Infinity places in the exhaustive BGS model and in the Riemann--Roch chart. -/ +def finiteExtensionInfinityPlaceEquivChart : + FiniteExtensionInfinityPlace K L ≃ + HeightOneSpectrum (FunctionField.Chart.infiniteIntegers K L) := + (finiteExtensionInfinityPrimesOverEquivHeightOne K L).trans + (HeightOneSpectrum.equivOfRingEquiv + (finiteExtensionInfinityIntegralClosureRingEquiv K L)) + +/-- Equivalence from the exhaustive BGS place type to the Riemann--Roch +two-chart place type. -/ +def finiteExtensionPlaceEquivChart : + FiniteExtensionPlace K L ≃ FunctionField.Chart.PlaceA K L := + Equiv.sumCongr (Equiv.refl _) + (finiteExtensionInfinityPlaceEquivChart K L) + +noncomputable def finiteExtensionFiniteQuotientResidueAlgEquiv + (q : FiniteExtensionFinitePlace K L) : + (RatFuncFiniteIntegralClosure K L ⧸ q.asIdeal) ≃ₐ[K] + q.asIdeal.ResidueField := by + letI : q.asIdeal.IsMaximal := q.isPrime.isMaximal q.ne_bot + exact AlgEquiv.ofBijective + (IsScalarTower.toAlgHom K + (RatFuncFiniteIntegralClosure K L ⧸ q.asIdeal) + q.asIdeal.ResidueField) + (Ideal.bijective_algebraMap_quotient_residueField q.asIdeal) + +noncomputable def finiteExtensionInfinityQuotientResidueAlgEquiv + (q : HeightOneSpectrum (FunctionField.Chart.infiniteIntegers K L)) : + (FunctionField.Chart.infiniteIntegers K L ⧸ q.asIdeal) ≃ₐ[K] + q.asIdeal.ResidueField := by + letI : q.asIdeal.IsMaximal := q.isPrime.isMaximal q.ne_bot + exact AlgEquiv.ofBijective + (IsScalarTower.toAlgHom K + (FunctionField.Chart.infiniteIntegers K L ⧸ q.asIdeal) + q.asIdeal.ResidueField) + (Ideal.bijective_algebraMap_quotient_residueField q.asIdeal) + +noncomputable def finiteExtensionInfinityResidueAlgEquiv + (P : FiniteExtensionInfinityPlace K L) : + P.1.ResidueField ≃ₐ[K] + (finiteExtensionInfinityPlaceEquivChart K L P).asIdeal.ResidueField := by + let e := finiteExtensionInfinityIntegralClosureAlgEquiv K L + apply Ideal.residueFieldAlgEquiv P.1 + (finiteExtensionInfinityPlaceEquivChart K L P).asIdeal e + change P.1 = (P.1.comap e.symm).comap e + exact (Ideal.comap_of_equiv e.toRingEquiv).symm + +omit [Fintype K] in +/-- The exhaustive place degree agrees with the Riemann--Roch chart degree. -/ +theorem finiteExtensionPlaceDegree_eq_chart + (v : FiniteExtensionPlace K L) : + finiteExtensionPlaceDegree K L v = + FunctionField.Chart.placeDegree K L + (finiteExtensionPlaceEquivChart K L v) := by + rcases v with q | P + · rw [finiteExtensionFinitePlace_degree_eq_finrank_residueField K L q] + change Module.finrank K q.asIdeal.ResidueField = + Module.finrank K (RatFuncFiniteIntegralClosure K L ⧸ q.asIdeal) + exact (finiteExtensionFiniteQuotientResidueAlgEquiv K L q).toLinearEquiv.finrank_eq.symm + · rw [finiteExtensionInfinityPlace_degree_eq_finrank_residueField K L P] + let q := finiteExtensionInfinityPlaceEquivChart K L P + change Module.finrank K P.1.ResidueField = + Module.finrank K (FunctionField.Chart.infiniteIntegers K L ⧸ q.asIdeal) + exact (finiteExtensionInfinityResidueAlgEquiv K L P).toLinearEquiv.finrank_eq.trans + (finiteExtensionInfinityQuotientResidueAlgEquiv K L q).toLinearEquiv.finrank_eq.symm + +private theorem heightOneValuation_le_one_of_ringEquiv_of_asIdeal + {R S F : Type*} [CommRing R] [CommRing S] [Field F] + [Algebra R F] [Algebra S F] [IsFractionRing R F] [IsFractionRing S F] + [IsDedekindDomain R] [IsDedekindDomain S] + (e : R ≃+* S) + (halg : ∀ r : R, algebraMap S F (e r) = algebraMap R F r) + (q : HeightOneSpectrum R) (q' : HeightOneSpectrum S) + (hideal : q'.asIdeal = q.asIdeal.comap e.symm) + (x : F) (hx : q.valuation F x ≤ 1) : q'.valuation F x ≤ 1 := by + obtain ⟨n, d, hnd⟩ := q.exists_primeCompl_mul_eq_of_integer x hx + have hd' : e d.1 ∉ q'.asIdeal := by + intro hmem + have hd : (d.1 : R) ∉ q.asIdeal := d.2 + apply hd + rw [hideal] at hmem + change e.symm (e d.1) ∈ q.asIdeal at hmem + simpa using hmem + have hnd' : + x * algebraMap S F (e d.1) = algebraMap S F (e n) := by + simpa only [halg] using hnd + have hval := congrArg (q'.valuation F) hnd' + rw [map_mul, q'.valuation_eq_one_iff_notMem (K := F).2 hd'] at hval + simp only [mul_one] at hval + rw [hval] + exact q'.valuation_le_one (K := F) (e n) + +private theorem heightOneValuation_isEquiv_of_ringEquiv_of_asIdeal + {R S F : Type*} [CommRing R] [CommRing S] [Field F] + [Algebra R F] [Algebra S F] [IsFractionRing R F] [IsFractionRing S F] + [IsDedekindDomain R] [IsDedekindDomain S] + (e : R ≃+* S) + (halg : ∀ r : R, algebraMap S F (e r) = algebraMap R F r) + (q : HeightOneSpectrum R) (q' : HeightOneSpectrum S) + (hideal : q'.asIdeal = q.asIdeal.comap e.symm) : + (q.valuation F).IsEquiv (q'.valuation F) := by + apply Valuation.isEquiv_of_val_le_one + intro x + constructor + · exact heightOneValuation_le_one_of_ringEquiv_of_asIdeal + e halg q q' hideal x + · intro hx + have halg' : ∀ s : S, + algebraMap R F (e.symm s) = algebraMap S F s := by + intro s + rw [← halg (e.symm s), e.apply_symm_apply] + have hideal' : q.asIdeal = q'.asIdeal.comap e := by + ext r + rw [Ideal.mem_comap, hideal, Ideal.mem_comap] + simp + exact heightOneValuation_le_one_of_ringEquiv_of_asIdeal + e.symm halg' q' q hideal' x hx + +private theorem valuation_eq_of_isEquiv_of_surjective + {F : Type*} [Field F] (v w : Valuation F ℤᵐ⁰) + (hvw : v.IsEquiv w) (hv : Function.Surjective v) + (hw : Function.Surjective w) : v = w := by + obtain ⟨π, hvπ⟩ := hv (WithZero.exp (-1 : ℤ)) + have hπ : π ≠ 0 := by + apply (Valuation.ne_zero_iff v).mp + rw [hvπ] + exact WithZero.exp_ne_zero + have hwπ0 : w π ≠ 0 := + (hvw.eq_zero.ne).mp ((Valuation.ne_zero_iff v).2 hπ) + let m : ℤ := -WithZero.log (w π) + have hmpos : 0 < m := by + have hvπlt : v π < 1 := by + rw [hvπ, ← WithZero.exp_zero, WithZero.exp_lt_exp] + omega + have hwπlt : w π < 1 := hvw.lt_one_iff_lt_one.mp hvπlt + have hlog : WithZero.log (w π) < 0 := by + rw [← WithZero.log_one] + exact (WithZero.log_lt_log hwπ0 one_ne_zero).2 hwπlt + dsimp only [m] + omega + have hformula (x : F) (hx : x ≠ 0) : + w x = WithZero.exp (m * WithZero.log (v x)) := by + have hvx0 : v x ≠ 0 := (Valuation.ne_zero_iff v).2 hx + let n : ℤ := WithZero.log (v x) + have hvpow : v (π ^ (-n)) = v x := by + rw [map_zpow₀, hvπ, ← WithZero.exp_zsmul] + rw [← WithZero.exp_log hvx0] + congr 1 + dsimp only [n] + simp + have hwpow : w (π ^ (-n)) = w x := hvw.eq_iff.mp hvpow + calc + w x = w (π ^ (-n)) := hwpow.symm + _ = (w π) ^ (-n) := by rw [map_zpow₀] + _ = WithZero.exp ((-n) • WithZero.log (w π)) := by + rw [WithZero.exp_zsmul, WithZero.exp_log hwπ0] + _ = WithZero.exp (m * WithZero.log (v x)) := by + congr 1 + dsimp only [m, n] + ring + obtain ⟨y, hwy⟩ := hw (WithZero.exp (1 : ℤ)) + have hy : y ≠ 0 := by + apply (Valuation.ne_zero_iff w).mp + rw [hwy] + exact WithZero.exp_ne_zero + have hm : m * WithZero.log (v y) = 1 := by + apply WithZero.exp_injective + rw [← hformula y hy, hwy] + have hm1 : m = 1 := by + rcases Int.mul_eq_one_iff_eq_one_or_neg_one.mp hm with h | h + · exact h.1 + · omega + ext x + by_cases hx : x = 0 + · subst x + simp + · rw [hformula x hx, hm1, one_mul, + WithZero.exp_log ((Valuation.ne_zero_iff v).2 hx)] + +omit [Fintype K] [DecidableEq K] in +/-- The normalized infinity valuation is unchanged by the identity-on-`L` +integral-closure transport. -/ +theorem finiteExtensionInfinityPlaceValuation_eq_chart + (P : FiniteExtensionInfinityPlace K L) : + (primeOverHeightOne (ratFuncInfinityPlace K) P).valuation L = + (finiteExtensionInfinityPlaceEquivChart K L P).valuation L := by + let q := primeOverHeightOne + (R := RatFuncInfinityIntegers K) + (S := RatFuncInfinityIntegralClosure K L) + (ratFuncInfinityPlace K) P + let e := finiteExtensionInfinityIntegralClosureRingEquiv K L + let q' := finiteExtensionInfinityPlaceEquivChart K L P + have hideal : q'.asIdeal = q.asIdeal.comap e.symm := by + rfl + have hequiv : (q.valuation L).IsEquiv (q'.valuation L) := + heightOneValuation_isEquiv_of_ringEquiv_of_asIdeal + e (fun _ => rfl) q q' hideal + change q.valuation L = q'.valuation L + exact valuation_eq_of_isEquiv_of_surjective + (q.valuation L) (q'.valuation L) hequiv + (show Function.Surjective (q.valuation L) from + HeightOneSpectrum.valuation_surjective (K := L) q) + (show Function.Surjective (q'.valuation L) from + HeightOneSpectrum.valuation_surjective (K := L) q') + +/-- The normalized valuation attached to an exhaustive BGS place. -/ +def finiteExtensionPlaceValuation : + FiniteExtensionPlace K L → Valuation L ℤᵐ⁰ + | .inl q => q.valuation L + | .inr P => + (primeOverHeightOne (ratFuncInfinityPlace K) P).valuation L + +omit [Fintype K] [DecidableEq K] in +/-- Every exhaustive BGS place carries exactly the normalized valuation of +its corresponding Riemann--Roch chart place. -/ +theorem finiteExtensionPlaceValuation_eq_chart + (v : FiniteExtensionPlace K L) : + finiteExtensionPlaceValuation K L v = + FunctionField.Chart.placeValuation K L + (finiteExtensionPlaceEquivChart K L v) := by + rcases v with q | P + · rfl + · exact finiteExtensionInfinityPlaceValuation_eq_chart K L P + +/-- Transport of exhaustive divisors to the two-chart Riemann--Roch model. -/ +def finiteExtensionDivisorEquivChart : + FiniteExtensionDivisor K L ≃+ + FunctionField.Chart.DivisorA K L := + Finsupp.domCongr (finiteExtensionPlaceEquivChart K L) + +omit [Fintype K] in +/-- Divisor degree is preserved by the exhaustive-place/chart equivalence. -/ +theorem finiteExtensionDivisorDegree_eq_chart + (D : FiniteExtensionDivisor K L) : + finiteExtensionDivisorDegree K L D = + FunctionField.Chart.deg K L + (finiteExtensionDivisorEquivChart K L D) := by + classical + induction D using Finsupp.induction with + | zero => + simp [finiteExtensionDivisorDegree, FunctionField.Chart.deg, + finiteExtensionDivisorEquivChart] + | single_add v n D hv hn ih => + rw [map_add, finiteExtensionDivisorDegree_add, + FunctionField.Chart.deg_add, ih] + congr 1 + simp [finiteExtensionDivisorDegree, FunctionField.Chart.deg, + finiteExtensionDivisorEquivChart, Finsupp.domCongr_apply, + Finsupp.equivMapDomain_single, + finiteExtensionPlaceDegree_eq_chart] + +omit [Fintype K] in +/-- The valuation of a nonzero function is the exponential of the negative +coefficient of its exhaustive principal divisor. -/ +theorem finiteExtensionPlaceValuation_eq_exp_neg_principalDivisor + (x : L) (hx : x ≠ 0) (v : FiniteExtensionPlace K L) : + finiteExtensionPlaceValuation K L v x = + WithZero.exp (-(finiteExtensionPrincipalDivisor K L x v)) := by + rcases v with q | P + · change q.valuation L x = _ + rw [finiteExtensionPrincipalDivisor_inl_eq_finitePlaceOrder, + valuation_eq_exp_neg_finitePlaceOrder q x hx] + · change (primeOverHeightOne (ratFuncInfinityPlace K) P).valuation L x = _ + rw [finiteExtensionPrincipalDivisor_inr_eq_infinityPlaceOrder, + valuation_eq_exp_neg_finitePlaceOrder + (primeOverHeightOne (ratFuncInfinityPlace K) P) x hx] + +/-- The BGS all-place Riemann space is the Riemann--Roch chart space after +transporting its divisor. -/ +theorem finiteExtensionRiemannSpace_eq_chart + (D : FiniteExtensionDivisor K L) : + finiteExtensionRiemannSpace K L D = + FunctionField.Chart.RRspace K L + (finiteExtensionDivisorEquivChart K L D) := by + classical + ext x + rw [mem_finiteExtensionRiemannSpace, + FunctionField.Chart.mem_RRspace_iff] + constructor + · rintro (rfl | ⟨hx, horders⟩) + · intro w + rw [Valuation.map_zero] + exact zero_le + · intro w + let v := (finiteExtensionPlaceEquivChart K L).symm w + have horder := horders v + have hInt : + -(finiteExtensionPrincipalDivisor K L x v) ≤ D v := by + omega + have hExp : + WithZero.exp (-(finiteExtensionPrincipalDivisor K L x v)) ≤ + WithZero.exp (D v) := + WithZero.exp_le_exp.mpr hInt + have hprincipal : finiteExtensionPlaceValuation K L v x = + WithZero.exp (-(finiteExtensionPrincipalDivisor K L x v)) := + finiteExtensionPlaceValuation_eq_exp_neg_principalDivisor + K L x hx v + have hplace : finiteExtensionPlaceValuation K L v x = + FunctionField.Chart.placeValuation K L + (finiteExtensionPlaceEquivChart K L v) x := by + exact congrArg (fun u : Valuation L ℤᵐ⁰ => u x) + (finiteExtensionPlaceValuation_eq_chart K L v) + have hvw : finiteExtensionPlaceEquivChart K L v = w := + (finiteExtensionPlaceEquivChart K L).apply_symm_apply w + calc + FunctionField.Chart.placeValuation K L w x = + FunctionField.Chart.placeValuation K L + (finiteExtensionPlaceEquivChart K L v) x := by rw [hvw] + _ = finiteExtensionPlaceValuation K L v x := hplace.symm + _ = WithZero.exp (-(finiteExtensionPrincipalDivisor K L x v)) := + hprincipal + _ ≤ WithZero.exp (D v) := hExp + _ = WithZero.exp ((finiteExtensionDivisorEquivChart K L D) w) := by + simp [finiteExtensionDivisorEquivChart, Finsupp.domCongr_apply, v] + · intro hxchart + by_cases hx : x = 0 + · exact Or.inl hx + · refine Or.inr ⟨hx, ?_⟩ + intro v + have hchart := hxchart (finiteExtensionPlaceEquivChart K L v) + have hprincipal : finiteExtensionPlaceValuation K L v x = + WithZero.exp (-(finiteExtensionPrincipalDivisor K L x v)) := + finiteExtensionPlaceValuation_eq_exp_neg_principalDivisor + K L x hx v + have hplace : finiteExtensionPlaceValuation K L v x = + FunctionField.Chart.placeValuation K L + (finiteExtensionPlaceEquivChart K L v) x := by + exact congrArg (fun u : Valuation L ℤᵐ⁰ => u x) + (finiteExtensionPlaceValuation_eq_chart K L v) + have hExp : + WithZero.exp (-(finiteExtensionPrincipalDivisor K L x v)) ≤ + WithZero.exp (D v) := by + calc + WithZero.exp (-(finiteExtensionPrincipalDivisor K L x v)) = + finiteExtensionPlaceValuation K L v x := + hprincipal.symm + _ = FunctionField.Chart.placeValuation K L + (finiteExtensionPlaceEquivChart K L v) x := hplace + _ ≤ WithZero.exp + ((finiteExtensionDivisorEquivChart K L D) + (finiteExtensionPlaceEquivChart K L v)) := hchart + _ = WithZero.exp (D v) := by + simp [finiteExtensionDivisorEquivChart, Finsupp.domCongr_apply] + have hInt := WithZero.exp_le_exp.mp hExp + omega + +/-- Riemann--Roch supplies the uniform eventual formula with genus `g` and +threshold `2g` once the chosen finite constant field is full in `L`. -/ +theorem hasFiniteExtensionUniformEventualRiemannFormula_of_fullConstantField + [FunctionField.IsFullConstantField K L] : + HasFiniteExtensionUniformEventualRiemannFormula K L + (FunctionField.Chart.genus K L) + (2 * FunctionField.Chart.genus K L) := by + refine ⟨by omega, ?_⟩ + intro D n hn hdegree + let Dchart := finiteExtensionDivisorEquivChart K L D + have hspace : finiteExtensionRiemannSpace K L D = + FunctionField.Chart.RRspace K L Dchart := + finiteExtensionRiemannSpace_eq_chart K L D + have hdegreeChart : FunctionField.Chart.deg K L Dchart = (n : ℤ) := by + rw [← finiteExtensionDivisorDegree_eq_chart K L D] + exact hdegree + constructor + · rw [hspace] + exact FunctionField.Chart.finiteDimensional_RRspace K L Dchart + · rw [hspace] + change FunctionField.Chart.ell K L Dchart = + n + 1 - FunctionField.Chart.genus K L + obtain ⟨W, hW⟩ := FunctionField.Chart.exists_isCanonical K L + have hnZ : (2 : ℤ) * (FunctionField.Chart.genus K L : ℤ) ≤ + (n : ℤ) := by + exact_mod_cast hn + have hlarge : FunctionField.Chart.deg K L Dchart ≥ + 2 * (FunctionField.Chart.genus K L : ℤ) - 1 := by + rw [hdegreeChart] + omega + have hRR := FunctionField.Chart.ell_eq_of_deg_ge + K L hW Dchart hlarge + rw [hdegreeChart] at hRR + have hgn : FunctionField.Chart.genus K L ≤ n := by omega + omega + +/-- If the algebraic closure of the finite constant field inside `L` is +exactly the constants, the uniform eventual Riemann formula holds for a +canonical genus and threshold. -/ +theorem exists_hasFiniteExtensionUniformEventualRiemannFormula_of_constants + (hconstants : algebraicClosure K L = ⊥) : + ∃ genus threshold, + HasFiniteExtensionUniformEventualRiemannFormula + K L genus threshold := by + let : FunctionField.IsFullConstantField K L := + (FunctionField.isFullConstantField_iff_algebraicClosure_eq_bot K L).2 + hconstants + exact ⟨FunctionField.Chart.genus K L, + 2 * FunctionField.Chart.genus K L, + hasFiniteExtensionUniformEventualRiemannFormula_of_fullConstantField K L⟩ + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionRiemannShiftedEventualGrowth.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionRiemannShiftedEventualGrowth.lean new file mode 100644 index 0000000000..088c9bfe0a --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionRiemannShiftedEventualGrowth.lean @@ -0,0 +1,276 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionRiemannEventualGrowth +public import Mathlib.Tactic + +/-! +# Eventual growth after an effective divisor shift + +The one-point stabilization theorem is extended here from `L(nP)` to +`L(D + nP)`, where `D` is any effective exhaustive divisor. The hypotheses +retain only the two estimates used in the proof: + +* principal parts bound each one-step dimension increase by `deg(P)`; and +* an arbitrary coarse affine lower bound prevents an unbounded deficit. + +Thus the lower-bound intercept is a parameter rather than a genus formula. +Once the associated natural-number surplus stabilizes, dimensions grow by +exactly `deg(P)` at every subsequent step. Over a finite constant field this +also gives an exact formula for the cardinalities of the shifted Riemann +spaces. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +open BGS.CorvajaZannier +open scoped Polynomial + +noncomputable section + + +variable (K : Type*) [Field K] [Fintype K] [DecidableEq K] + [DecidableEq (RatFunc K)] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +/-- The divisor obtained by adding `n` copies of `P` to `D`. -/ +abbrev finiteExtensionRiemannShiftDivisor + (D : FiniteExtensionDivisor K L) (P : FiniteExtensionPlace K L) + (n : ℕ) : FiniteExtensionDivisor K L := + D + Finsupp.single P (n : ℤ) + +/-- The nonnegative error in an affine lower bound for +`dim L(D + nP)`. -/ +def finiteExtensionShiftedRiemannSurplus + (D : FiniteExtensionDivisor K L) (P : FiniteExtensionPlace K L) + (intercept error n : ℕ) : ℕ := + Module.finrank K + (finiteExtensionRiemannSpace K L + (finiteExtensionRiemannShiftDivisor K L D P n)) + error - + (n * finiteExtensionPlaceDegree K L P + intercept) + +/-- For effective `D`, a coarse affine lower bound makes the shifted +Riemann surplus antitone. -/ +theorem finiteExtensionShiftedRiemannSurplus_antitone_of_lower + (D : FiniteExtensionDivisor K L) (hD : ∀ v, 0 ≤ D v) + (P : FiniteExtensionPlace K L) (intercept error : ℕ) + (hLower : ∀ n : ℕ, + n * finiteExtensionPlaceDegree K L P + intercept ≤ + Module.finrank K + (finiteExtensionRiemannSpace K L + (finiteExtensionRiemannShiftDivisor K L D P n)) + error) : + Antitone + (finiteExtensionShiftedRiemannSurplus K L D P intercept error) := by + apply antitone_nat_of_succ_le + intro n + let E : FiniteExtensionDivisor K L := + finiteExtensionRiemannShiftDivisor K L D P n + have hE : ∀ v, 0 ≤ E v := by + intro v + by_cases hv : v = P + · subst v + have hn : (0 : ℤ) ≤ n := by positivity + simpa [E, finiteExtensionRiemannShiftDivisor] using + add_nonneg (hD P) hn + · simpa [E, finiteExtensionRiemannShiftDivisor, + Finsupp.single_eq_of_ne hv] using hD v + let : Module.Finite K (finiteExtensionRiemannSpace K L E) := + finiteExtensionRiemannSpace_effective_moduleFinite K L E hE + have hinc := finiteExtensionRiemannSpace_place_increment K L E hE P + have hdivisor : E + Finsupp.single P 1 = + finiteExtensionRiemannShiftDivisor K L D P (n + 1) := by + ext v + by_cases hv : v = P + · subst v + simp [E, finiteExtensionRiemannShiftDivisor] + ring + · simp [E, finiteExtensionRiemannShiftDivisor, + Finsupp.single_eq_of_ne hv] + have hfinrank : + Module.finrank K + (finiteExtensionRiemannSpace K L + (finiteExtensionRiemannShiftDivisor K L D P (n + 1))) ≤ + Module.finrank K + (finiteExtensionRiemannSpace K L + (finiteExtensionRiemannShiftDivisor K L D P n)) + + finiteExtensionPlaceDegree K L P := by + rw [← hdivisor] + simpa only [E] using hinc.2 + have hn := hLower n + have hsucc := hLower (n + 1) + simp only [finiteExtensionShiftedRiemannSurplus, Nat.succ_mul] at hsucc ⊢ + omega + +/-- A coarse affine lower bound forces the dimensions of `L(D + nP)` to +eventually increase by exactly `deg(P)` at every step. -/ +theorem finiteExtensionRiemannSpace_shift_eventually_exact_increment + (D : FiniteExtensionDivisor K L) (hD : ∀ v, 0 ≤ D v) + (P : FiniteExtensionPlace K L) (intercept error : ℕ) + (hLower : ∀ n : ℕ, + n * finiteExtensionPlaceDegree K L P + intercept ≤ + Module.finrank K + (finiteExtensionRiemannSpace K L + (finiteExtensionRiemannShiftDivisor K L D P n)) + error) : + ∃ N : ℕ, ∀ n : ℕ, N ≤ n → + Module.finrank K + (finiteExtensionRiemannSpace K L + (finiteExtensionRiemannShiftDivisor K L D P (n + 1))) = + Module.finrank K + (finiteExtensionRiemannSpace K L + (finiteExtensionRiemannShiftDivisor K L D P n)) + + finiteExtensionPlaceDegree K L P := by + have hanti := + finiteExtensionShiftedRiemannSurplus_antitone_of_lower + K L D hD P intercept error hLower + obtain ⟨N, hN⟩ := WellFoundedLT.antitone_chain_condition hanti + refine ⟨N, ?_⟩ + intro n hn + have heq : + finiteExtensionShiftedRiemannSurplus K L D P intercept error n = + finiteExtensionShiftedRiemannSurplus K L D P intercept error (n + 1) := + (hN n hn).symm.trans (hN (n + 1) (hn.trans (Nat.le_succ n))) + have hlowN := hLower n + have hlowSucc := hLower (n + 1) + simp only [finiteExtensionShiftedRiemannSurplus, Nat.succ_mul] at heq hlowSucc + omega + +/-- Iterating exact successive increments gives the closed dimension formula +from any stabilization index. -/ +theorem finiteExtensionRiemannSpace_shift_closedFormula_of_exact_increment + (D : FiniteExtensionDivisor K L) (P : FiniteExtensionPlace K L) + (N : ℕ) + (hIncrement : ∀ n : ℕ, N ≤ n → + Module.finrank K + (finiteExtensionRiemannSpace K L + (finiteExtensionRiemannShiftDivisor K L D P (n + 1))) = + Module.finrank K + (finiteExtensionRiemannSpace K L + (finiteExtensionRiemannShiftDivisor K L D P n)) + + finiteExtensionPlaceDegree K L P) : + ∀ m : ℕ, + Module.finrank K + (finiteExtensionRiemannSpace K L + (finiteExtensionRiemannShiftDivisor K L D P (N + m))) = + Module.finrank K + (finiteExtensionRiemannSpace K L + (finiteExtensionRiemannShiftDivisor K L D P N)) + + m * finiteExtensionPlaceDegree K L P := by + intro m + induction m with + | zero => simp + | succ m ih => + have hstep := hIncrement (N + m) (Nat.le_add_right N m) + calc + Module.finrank K + (finiteExtensionRiemannSpace K L + (finiteExtensionRiemannShiftDivisor K L D P (N + (m + 1)))) = + Module.finrank K + (finiteExtensionRiemannSpace K L + (finiteExtensionRiemannShiftDivisor K L D P ((N + m) + 1))) := by + rw [Nat.add_succ] + _ = Module.finrank K + (finiteExtensionRiemannSpace K L + (finiteExtensionRiemannShiftDivisor K L D P (N + m))) + + finiteExtensionPlaceDegree K L P := hstep + _ = (Module.finrank K + (finiteExtensionRiemannSpace K L + (finiteExtensionRiemannShiftDivisor K L D P N)) + + m * finiteExtensionPlaceDegree K L P) + + finiteExtensionPlaceDegree K L P := by rw [ih] + _ = Module.finrank K + (finiteExtensionRiemannSpace K L + (finiteExtensionRiemannShiftDivisor K L D P N)) + + (m + 1) * finiteExtensionPlaceDegree K L P := by + rw [Nat.add_mul, one_mul] + omega + +/-- Eventual exact affine dimension growth for `L(D + nP)`. -/ +theorem finiteExtensionRiemannSpace_shift_eventually_closedFormula + (D : FiniteExtensionDivisor K L) (hD : ∀ v, 0 ≤ D v) + (P : FiniteExtensionPlace K L) (intercept error : ℕ) + (hLower : ∀ n : ℕ, + n * finiteExtensionPlaceDegree K L P + intercept ≤ + Module.finrank K + (finiteExtensionRiemannSpace K L + (finiteExtensionRiemannShiftDivisor K L D P n)) + error) : + ∃ N : ℕ, ∀ m : ℕ, + Module.finrank K + (finiteExtensionRiemannSpace K L + (finiteExtensionRiemannShiftDivisor K L D P (N + m))) = + Module.finrank K + (finiteExtensionRiemannSpace K L + (finiteExtensionRiemannShiftDivisor K L D P N)) + + m * finiteExtensionPlaceDegree K L P := by + obtain ⟨N, hN⟩ := + finiteExtensionRiemannSpace_shift_eventually_exact_increment + K L D hD P intercept error hLower + exact ⟨N, + finiteExtensionRiemannSpace_shift_closedFormula_of_exact_increment + K L D P N hN⟩ + +/-- Cardinality form of eventual exact affine growth. It is stated without +division: after stabilization, adding `mP` multiplies the number of Riemann +space elements by `|K| ^ (m * deg(P))`. -/ +theorem finiteExtensionRiemannSpace_shift_eventually_cardinality_formula + (D : FiniteExtensionDivisor K L) (hD : ∀ v, 0 ≤ D v) + (P : FiniteExtensionPlace K L) (intercept error : ℕ) + (hLower : ∀ n : ℕ, + n * finiteExtensionPlaceDegree K L P + intercept ≤ + Module.finrank K + (finiteExtensionRiemannSpace K L + (finiteExtensionRiemannShiftDivisor K L D P n)) + error) : + ∃ N : ℕ, ∀ m : ℕ, + Nat.card + (finiteExtensionRiemannSpace K L + (finiteExtensionRiemannShiftDivisor K L D P (N + m))) = + Nat.card + (finiteExtensionRiemannSpace K L + (finiteExtensionRiemannShiftDivisor K L D P N)) * + Nat.card K ^ (m * finiteExtensionPlaceDegree K L P) := by + obtain ⟨N, hN⟩ := finiteExtensionRiemannSpace_shift_eventually_closedFormula + K L D hD P intercept error hLower + refine ⟨N, ?_⟩ + intro m + have hDN : ∀ v, + 0 ≤ finiteExtensionRiemannShiftDivisor K L D P N v := by + intro v + by_cases hv : v = P + · subst v + have hNnonneg : (0 : ℤ) ≤ N := by positivity + simpa [finiteExtensionRiemannShiftDivisor] using + add_nonneg (hD P) hNnonneg + · simpa [finiteExtensionRiemannShiftDivisor, + Finsupp.single_eq_of_ne hv] using hD v + have hDNm : ∀ v, + 0 ≤ finiteExtensionRiemannShiftDivisor K L D P (N + m) v := by + intro v + by_cases hv : v = P + · subst v + have hNmnonneg : (0 : ℤ) ≤ N + m := by positivity + simpa [finiteExtensionRiemannShiftDivisor] using + add_nonneg (hD P) hNmnonneg + · simpa [finiteExtensionRiemannShiftDivisor, + Finsupp.single_eq_of_ne hv] using hD v + let : Module.Finite K + (finiteExtensionRiemannSpace K L + (finiteExtensionRiemannShiftDivisor K L D P N)) := + finiteExtensionRiemannSpace_effective_moduleFinite K L _ hDN + let : Module.Finite K + (finiteExtensionRiemannSpace K L + (finiteExtensionRiemannShiftDivisor K L D P (N + m))) := + finiteExtensionRiemannSpace_effective_moduleFinite K L _ hDNm + rw [Module.natCard_eq_pow_finrank (K := K), hN m, pow_add, + ← Module.natCard_eq_pow_finrank (K := K)] + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionRiemannSpace.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionRiemannSpace.lean new file mode 100644 index 0000000000..9cd8c620e0 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionRiemannSpace.lean @@ -0,0 +1,376 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionOneSubGcdHeight +public import Mathlib.FieldTheory.Finite.Basic + +/-! +# Riemann spaces for finite extensions of a rational function field + +This file supplies the elementary divisor-linear-algebra layer needed by a +Bombieri--Stepanov proof of Hasse--Weil. For a divisor `D` on the exhaustive +finite and infinite places of a finite separable extension `L / K(X)`, it +defines the Riemann space + +`L(D) = {x : L | x = 0 or div(x) + D is effective}` + +as a `K`-submodule of `L`. It also proves the order-theoretic and +multiplicative properties of these spaces, together with their specialization +to the one-point filtration `L(nP)`. + +The integer-valued principal-divisor API is defined only for nonzero elements, +so zero is an explicit branch of the carrier predicate. Scalar closure uses +that a nonzero constant over the finite constant field has trivial principal +divisor. + +Two substantive stages are deliberately *not* postulated here: + +* finite-dimensionality of every `L(D)` over `K`; +* the Riemann--Roch lower bound, which can be stated without introducing genus + as `2 * deg D - deg K_can <= 2 * finrank_K L(D)`. + +The ambient function field `L` is not finite-dimensional over `K`, so the first +item is a genuine theorem and cannot be obtained by typeclass inference from +the ambient space. Both stages must be proved before `finrank` is used in the +Hasse--Weil argument. +-/ + +@[expose] public section + +namespace BGS.CorvajaZannier + +noncomputable section + +open scoped nonZeroDivisors Polynomial + +variable (K : Type*) [Field K] [Fintype K] [DecidableEq K] + [DecidableEq (RatFunc K)] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +local instance finiteExtensionRiemannSpaceConstantAlgebra : Algebra K L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K (RatFunc K))) + +local instance finiteExtensionRiemannSpaceConstantTower : + IsScalarTower K (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + +/-- A finitely supported divisor on all finite and infinite places of +`L / K(X)`. -/ +abbrev FiniteExtensionDivisor := FiniteExtensionPlace K L →₀ ℤ + +omit [Fintype K] [FiniteDimensional (RatFunc K) L] [Algebra.IsSeparable (RatFunc K) L] in +/-- Divisor degree is additive. -/ +theorem finiteExtensionDivisorDegree_add + (D E : FiniteExtensionDivisor K L) : + finiteExtensionDivisorDegree K L (D + E) = + finiteExtensionDivisorDegree K L D + + finiteExtensionDivisorDegree K L E := by + classical + simpa only [finiteExtensionDivisorDegree] using + (Finsupp.sum_add_index (f := D) (g := E) + (h := fun v e ↦ e * (finiteExtensionPlaceDegree K L v : ℤ)) + (by simp) (by intros; ring)) + +omit [Fintype K] in +/-- The product formula says that every nonzero principal divisor has degree +zero. -/ +theorem finiteExtensionDivisorDegree_principal + (x : L) (hx : x ≠ 0) : + finiteExtensionDivisorDegree K L + (finiteExtensionPrincipalDivisor K L x) = 0 := by + exact finiteExtensionPrincipalDivisorDegreeSum_eq_zero K L x hx + +omit [Fintype K] [FiniteDimensional (RatFunc K) L] [Algebra.IsSeparable (RatFunc K) L] in +/-- An effective divisor has nonnegative degree. -/ +theorem finiteExtensionDivisorDegree_nonnegative_of_effective + (D : FiniteExtensionDivisor K L) (hD : ∀ v, 0 ≤ D v) : + 0 ≤ finiteExtensionDivisorDegree K L D := by + apply D.sum_nonneg' + intro v + exact mul_nonneg (hD v) (by positivity) + +omit [Fintype K] [DecidableEq K] in +/-- Nonzero elements of the finite constant field have trivial exhaustive +principal divisor. -/ +theorem finiteExtensionPrincipalDivisor_algebraMap_constant [Finite K] + (c : K) (hc : c ≠ 0) : + finiteExtensionPrincipalDivisor K L (algebraMap K L c) = 0 := by + classical + let : Fintype K := Fintype.ofFinite K + let n := Fintype.card K - 1 + have hn : 0 < n := by + dsimp [n] + exact Nat.sub_pos_of_lt Fintype.one_lt_card + have hcL : algebraMap K L c ≠ 0 := by + simpa only [map_zero] using (algebraMap K L).injective.ne hc + have hpow : (algebraMap K L c) ^ n = 1 := by + rw [← map_pow, FiniteField.pow_card_sub_one_eq_one c hc, map_one] + have hdiv := finiteExtensionPrincipalDivisor_pow K L + (algebraMap K L c) hcL n + rw [hpow, finiteExtensionPrincipalDivisor_one K L] at hdiv + ext v + change finiteExtensionPrincipalDivisor K L (algebraMap K L c) v = (0 : ℤ) + have hv := congrArg (fun D : FiniteExtensionDivisor K L ↦ D v) hdiv + simp only [Finsupp.zero_apply, Finsupp.smul_apply, nsmul_eq_mul] at hv + exact (mul_eq_zero.mp hv.symm).resolve_left (by exact_mod_cast hn.ne') + +/-- The all-place Riemann space `L(D)`. Zero is handled separately because +the existing principal-divisor API assigns integer coefficients only to +nonzero functions. -/ +def finiteExtensionRiemannSpace (D : FiniteExtensionDivisor K L) : + Submodule K L where + carrier := {x | x = 0 ∨ (x ≠ 0 ∧ ∀ v, + 0 ≤ finiteExtensionPrincipalDivisor K L x v + D v)} + zero_mem' := Or.inl rfl + add_mem' := by + rintro x y (hx0 | ⟨hx0, hx⟩) (hy0 | ⟨hy0, hy⟩) + · exact Or.inl (by simp [hx0, hy0]) + · subst x + simpa only [zero_add, Set.mem_ofPred_eq] using + (Or.inr ⟨hy0, hy⟩ : y = 0 ∨ (y ≠ 0 ∧ ∀ v, + 0 ≤ finiteExtensionPrincipalDivisor K L y v + D v)) + · subst y + simpa only [add_zero, Set.mem_ofPred_eq] using + (Or.inr ⟨hx0, hx⟩ : x = 0 ∨ (x ≠ 0 ∧ ∀ v, + 0 ≤ finiteExtensionPrincipalDivisor K L x v + D v)) + · by_cases hxy : x + y = 0 + · exact Or.inl hxy + · refine Or.inr ⟨hxy, ?_⟩ + intro v + have horder := finiteExtensionPrincipalDivisor_add_ge_min + K L x y hx0 hy0 hxy v + have hxmin : -D v ≤ finiteExtensionPrincipalDivisor K L x v := by + have hxv := hx v + omega + have hymin : -D v ≤ finiteExtensionPrincipalDivisor K L y v := by + have hyv := hy v + omega + have hmin : -D v ≤ min + (finiteExtensionPrincipalDivisor K L x v) + (finiteExtensionPrincipalDivisor K L y v) := + le_min hxmin hymin + omega + smul_mem' := by + intro c x hx + by_cases hc : c = 0 + · subst c + exact Or.inl (zero_smul K x) + rcases hx with hx | ⟨hx, horders⟩ + · subst x + exact Or.inl (smul_zero c) + · have hcL : algebraMap K L c ≠ 0 := by + simpa only [map_zero] using (algebraMap K L).injective.ne hc + have hcx : c • x ≠ 0 := by + rw [Algebra.smul_def] + exact mul_ne_zero hcL hx + refine Or.inr ⟨hcx, ?_⟩ + intro v + rw [Algebra.smul_def, + finiteExtensionPrincipalDivisor_mul K L _ _ hcL hx, + finiteExtensionPrincipalDivisor_algebraMap_constant K L c hc] + simpa using horders v + +@[simp] +theorem mem_finiteExtensionRiemannSpace + {D : FiniteExtensionDivisor K L} {x : L} : + x ∈ finiteExtensionRiemannSpace K L D ↔ + x = 0 ∨ (x ≠ 0 ∧ ∀ v, + 0 ≤ finiteExtensionPrincipalDivisor K L x v + D v) := + Iff.rfl + +/-- Increasing the allowed divisor enlarges the Riemann space. -/ +theorem finiteExtensionRiemannSpace_mono + {D E : FiniteExtensionDivisor K L} (hDE : D ≤ E) : + finiteExtensionRiemannSpace K L D ≤ + finiteExtensionRiemannSpace K L E := by + intro x hx + rw [mem_finiteExtensionRiemannSpace] at hx ⊢ + rcases hx with hx | ⟨hx0, hx⟩ + · exact Or.inl hx + · refine Or.inr ⟨hx0, ?_⟩ + intro v + have hv := hDE v + have hxv := hx v + omega + +/-- Every constant belongs to `L(D)` when `D` is effective. -/ +theorem algebraMap_mem_finiteExtensionRiemannSpace_of_effective + {D : FiniteExtensionDivisor K L} (hD : ∀ v, 0 ≤ D v) (c : K) : + algebraMap K L c ∈ finiteExtensionRiemannSpace K L D := by + by_cases hc : c = 0 + · subst c + simp + · rw [mem_finiteExtensionRiemannSpace] + refine Or.inr ⟨?_, ?_⟩ + · simpa only [map_zero] using (algebraMap K L).injective.ne hc + intro v + rw [finiteExtensionPrincipalDivisor_algebraMap_constant K L c hc] + simpa using hD v + +/-- The Riemann spaces form a multiplicative divisor filtration. -/ +theorem finiteExtensionRiemannSpace_mul_mem + {D E : FiniteExtensionDivisor K L} {x y : L} + (hx : x ∈ finiteExtensionRiemannSpace K L D) + (hy : y ∈ finiteExtensionRiemannSpace K L E) : + x * y ∈ finiteExtensionRiemannSpace K L (D + E) := by + rw [mem_finiteExtensionRiemannSpace] at hx hy ⊢ + rcases hx with hx | ⟨hx0, hx⟩ + · exact Or.inl (by simp [hx]) + rcases hy with hy | ⟨hy0, hy⟩ + · exact Or.inl (by simp [hy]) + refine Or.inr ⟨mul_ne_zero hx0 hy0, ?_⟩ + intro v + rw [finiteExtensionPrincipalDivisor_mul K L x y hx0 hy0, + Finsupp.add_apply] + have hxv := hx v + have hyv := hy v + simp only [Finsupp.add_apply] at hxv hyv ⊢ + omega + +/-- Powers respect the multiplicative divisor filtration. -/ +theorem finiteExtensionRiemannSpace_pow_mem + {D : FiniteExtensionDivisor K L} {x : L} + (hx : x ∈ finiteExtensionRiemannSpace K L D) (n : ℕ) : + x ^ n ∈ finiteExtensionRiemannSpace K L (n • D) := by + rw [mem_finiteExtensionRiemannSpace] at hx ⊢ + rcases hx with hx | ⟨hx0, hx⟩ + · subst x + by_cases hn : n = 0 + · subst n + simp only [pow_zero, zero_nsmul] + refine Or.inr ⟨one_ne_zero, ?_⟩ + intro v + rw [finiteExtensionPrincipalDivisor_one K L] + simp + · exact Or.inl (zero_pow hn) + refine Or.inr ⟨pow_ne_zero n hx0, ?_⟩ + intro v + rw [finiteExtensionPrincipalDivisor_pow K L x hx0 n] + simp only [Finsupp.smul_apply, nsmul_eq_mul] + have hxv := hx v + have hn : (0 : ℤ) ≤ n := by positivity + nlinarith + +/-- The elementary vanishing half of Riemann--Roch: a divisor of negative +degree has no nonzero section. This uses only effectiveness and the product +formula, not Riemann--Roch. -/ +theorem finiteExtensionRiemannSpace_eq_bot_of_divisorDegree_neg + {D : FiniteExtensionDivisor K L} + (hD : finiteExtensionDivisorDegree K L D < 0) : + finiteExtensionRiemannSpace K L D = ⊥ := by + apply le_antisymm + · intro x hx + rw [Submodule.mem_bot] + rw [mem_finiteExtensionRiemannSpace] at hx + rcases hx with hx | ⟨hx0, hx⟩ + · exact hx + · exfalso + let E := finiteExtensionPrincipalDivisor K L x + D + have hEeffective : ∀ v, 0 ≤ E v := by + intro v + exact hx v + have hEdegree := + finiteExtensionDivisorDegree_nonnegative_of_effective K L E hEeffective + rw [finiteExtensionDivisorDegree_add, + finiteExtensionDivisorDegree_principal K L x hx0, zero_add] at hEdegree + omega + · exact bot_le + +/-- Functions whose only permitted pole is at `P`, with order at most `n`. -/ +def finiteExtensionOnePointRiemannSpace + (P : FiniteExtensionPlace K L) (n : ℕ) : Submodule K L := by + classical + exact finiteExtensionRiemannSpace K L (Finsupp.single P (n : ℤ)) + +/-- Membership in `L(nP)` is the expected pole bound at `P`, together with +regularity at every other place. -/ +theorem mem_finiteExtensionOnePointRiemannSpace_iff + (P : FiniteExtensionPlace K L) (n : ℕ) (x : L) : + x ∈ finiteExtensionOnePointRiemannSpace K L P n ↔ + x = 0 ∨ (x ≠ 0 ∧ + -(n : ℤ) ≤ finiteExtensionPrincipalDivisor K L x P ∧ + ∀ v, v ≠ P → 0 ≤ finiteExtensionPrincipalDivisor K L x v) := by + classical + rw [finiteExtensionOnePointRiemannSpace, + mem_finiteExtensionRiemannSpace] + constructor + · rintro (hx | ⟨hx0, hx⟩) + · exact Or.inl hx + · refine Or.inr ⟨hx0, ?_, ?_⟩ + · have hP := hx P + simp only [Finsupp.single_eq_same] at hP + omega + · intro v hv + have hvOrder := hx v + simp only [Finsupp.single_eq_of_ne hv] at hvOrder + simpa using hvOrder + · rintro (hx | ⟨hx0, hP, hAway⟩) + · exact Or.inl hx + · refine Or.inr ⟨hx0, ?_⟩ + intro v + by_cases hv : v = P + · subst v + simp only [Finsupp.single_eq_same] + omega + · simp only [Finsupp.single_eq_of_ne hv, add_zero] + exact hAway v hv + +/-- Every constant belongs to every one-point Riemann space. -/ +theorem algebraMap_mem_finiteExtensionOnePointRiemannSpace + (P : FiniteExtensionPlace K L) (n : ℕ) (c : K) : + algebraMap K L c ∈ finiteExtensionOnePointRiemannSpace K L P n := by + classical + apply algebraMap_mem_finiteExtensionRiemannSpace_of_effective K L + intro v + by_cases hv : v = P + · subst v + simp + · simp [Finsupp.single_eq_of_ne hv] + +/-- The one-point Riemann spaces are nested by pole order. -/ +theorem finiteExtensionOnePointRiemannSpace_mono + (P : FiniteExtensionPlace K L) {m n : ℕ} (hmn : m ≤ n) : + finiteExtensionOnePointRiemannSpace K L P m ≤ + finiteExtensionOnePointRiemannSpace K L P n := by + classical + apply finiteExtensionRiemannSpace_mono K L + intro v + by_cases hv : v = P + · subst v + simp only [Finsupp.single_eq_same] + exact_mod_cast hmn + · simp only [Finsupp.single_eq_of_ne hv] + exact le_rfl + +/-- Products add the allowed pole orders in the one-point filtration. -/ +theorem finiteExtensionOnePointRiemannSpace_mul_mem + (P : FiniteExtensionPlace K L) {m n : ℕ} {x y : L} + (hx : x ∈ finiteExtensionOnePointRiemannSpace K L P m) + (hy : y ∈ finiteExtensionOnePointRiemannSpace K L P n) : + x * y ∈ finiteExtensionOnePointRiemannSpace K L P (m + n) := by + classical + change x * y ∈ finiteExtensionRiemannSpace K L + (Finsupp.single P ((m + n : ℕ) : ℤ)) + have hmul := finiteExtensionRiemannSpace_mul_mem K L hx hy + have hdivisor : + Finsupp.single P ((m + n : ℕ) : ℤ) = + Finsupp.single P (m : ℤ) + Finsupp.single P (n : ℤ) := by + ext v + by_cases hv : v = P + · subst v + simp + · simp [Finsupp.single_eq_of_ne hv] + rw [hdivisor] + exact hmul + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionRiemannSpaceProjectivization.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionRiemannSpaceProjectivization.lean new file mode 100644 index 0000000000..1904c00555 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionRiemannSpaceProjectivization.lean @@ -0,0 +1,378 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.RiemannSpaceEffectiveIncrement +public import Mathlib.LinearAlgebra.Projectivization.Cardinality + +/-! +# Projectivized Riemann-space counts + +For a finite constant field, nonzero vectors in a finite-dimensional vector +space modulo multiplication by nonzero scalars form its projectivization. +This file records the three equivalent cardinality formulas needed in the +function-field zeta argument: + +* the quotient by the scalar action; +* the set of one-dimensional subspaces; and +* the geometric sum `1 + q + ... + q^(l - 1)`. + +The final statements specialize these formulas to every effective exhaustive +divisor, using the already proved finite-dimensionality of its Riemann space. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +open BGS.CorvajaZannier +open scoped LinearAlgebra.Projectivization Polynomial + +noncomputable section + +variable (K : Type*) [Field K] [Fintype K] +variable (V : Type*) [AddCommGroup V] [Module K V] + +omit [Fintype K] in +/-- One-dimensional subspaces of a finite vector space over `K` are counted +by the geometric sum in the dimension. -/ +theorem finiteVectorSpace_oneDimensionalSubspace_card_eq_geomSum [Finite K] : + Nat.card {W : Submodule K V // Module.finrank K W = 1} = + ∑ i ∈ Finset.range (Module.finrank K V), Nat.card K ^ i := by + rw [Nat.card_congr (Projectivization.equivSubmodule K V).symm] + exact Projectivization.card_of_finrank K V rfl + +omit [Fintype K] in +/-- The orbit quotient of nonzero vectors by nonzero scalar multiplication is +counted by the same geometric sum. -/ +theorem finiteVectorSpace_nonzeroScalarOrbitQuotient_card_eq_geomSum [Finite K] : + Nat.card + (Quotient + (MulAction.orbitRel Kˣ {v : V // v ≠ 0})) = + ∑ i ∈ Finset.range (Module.finrank K V), Nat.card K ^ i := by + rw [Nat.card_congr (Projectivization.equivQuotientOrbitRel K V).symm] + exact Projectivization.card_of_finrank K V rfl + +variable [Module.Finite K V] + +omit [Fintype K] in +/-- Division form of the projective-space cardinality formula. -/ +theorem finiteVectorSpace_nonzeroScalarOrbitQuotient_card_eq_div [Finite K] : + Nat.card + (Quotient + (MulAction.orbitRel Kˣ {v : V // v ≠ 0})) = + (Nat.card K ^ Module.finrank K V - 1) / (Nat.card K - 1) := by + rw [Nat.card_congr (Projectivization.equivQuotientOrbitRel K V).symm, + Projectivization.card'', Module.natCard_eq_pow_finrank (K := K)] + +variable [DecidableEq K] [DecidableEq (RatFunc K)] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +local instance projectivizedRiemannSpaceConstantAlgebra : Algebra K L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K (RatFunc K))) + +local instance projectivizedRiemannSpaceConstantTower : + IsScalarTower K (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + +/-- Effective exhaustive divisors in the principal-divisor class represented +by `D`. The sign convention matches the Riemann-space definition: +`x \in L(D)` gives the effective divisor `div(x) + D`. -/ +def EffectiveDivisorInPrincipalClass (D : FiniteExtensionDivisor K L) := + {E : FiniteExtensionDivisor K L // + (∀ v, 0 ≤ E v) ∧ + ∃ x : L, x ≠ 0 ∧ + E = finiteExtensionPrincipalDivisor K L x + D} + +/-- A nonzero Riemann-space section determines an effective divisor in the +principal class represented by `D`. -/ +def effectiveDivisorInPrincipalClassOfNonzeroSection + (D : FiniteExtensionDivisor K L) + (x : {x : finiteExtensionRiemannSpace K L D // x ≠ 0}) : + EffectiveDivisorInPrincipalClass K L D := by + have hx0 : (x.1.1 : L) ≠ 0 := Subtype.coe_injective.ne x.2 + refine ⟨finiteExtensionPrincipalDivisor K L x.1.1 + D, ?_, + x.1.1, hx0, rfl⟩ + have hxmem := x.1.2 + rw [mem_finiteExtensionRiemannSpace] at hxmem + rcases hxmem with hx | ⟨_, hx⟩ + · exact (hx0 hx).elim + · simpa only [Finsupp.add_apply] using hx + +/-- Multiplying a nonzero section by a nonzero base-field scalar does not +change its associated effective divisor. -/ +theorem effectiveDivisorInPrincipalClassOfNonzeroSection_smul + (D : FiniteExtensionDivisor K L) + (a b : {x : finiteExtensionRiemannSpace K L D // x ≠ 0}) + (c : K) (hab : a = c • (b : finiteExtensionRiemannSpace K L D)) : + effectiveDivisorInPrincipalClassOfNonzeroSection K L D a = + effectiveDivisorInPrincipalClassOfNonzeroSection K L D b := by + have hc : c ≠ 0 := by + intro hc + apply a.2 + simpa [hc] using hab + have hcL : algebraMap K L c ≠ 0 := + by simpa only [map_zero] using (algebraMap K L).injective.ne hc + have hb0 : (b.1.1 : L) ≠ 0 := Subtype.coe_injective.ne b.2 + apply Subtype.ext + dsimp only [effectiveDivisorInPrincipalClassOfNonzeroSection] + have habL : (a.1.1 : L) = algebraMap K L c * (b.1.1 : L) := by + simpa [Algebra.smul_def] using + congrArg (fun z : finiteExtensionRiemannSpace K L D ↦ (z.1 : L)) hab + rw [habL, finiteExtensionPrincipalDivisor_mul K L _ _ hcL hb0, + finiteExtensionPrincipalDivisor_algebraMap_constant K L c hc, zero_add] + +/-- Projectivizing the nonzero sections makes the associated effective +divisor independent of the chosen representative. -/ +def projectiveRiemannSectionToEffectiveDivisorInPrincipalClass + (D : FiniteExtensionDivisor K L) : + Projectivization K (finiteExtensionRiemannSpace K L D) → + EffectiveDivisorInPrincipalClass K L D := + Projectivization.lift + (effectiveDivisorInPrincipalClassOfNonzeroSection K L D) + (effectiveDivisorInPrincipalClassOfNonzeroSection_smul K L D) + +@[simp] +theorem projectiveRiemannSectionToEffectiveDivisorInPrincipalClass_mk + (D : FiniteExtensionDivisor K L) + (x : finiteExtensionRiemannSpace K L D) (hx : x ≠ 0) : + projectiveRiemannSectionToEffectiveDivisorInPrincipalClass K L D + (Projectivization.mk K x hx) = + effectiveDivisorInPrincipalClassOfNonzeroSection K L D ⟨x, hx⟩ := + rfl + +/-- Every effective divisor in the represented principal class arises from +a projective nonzero section. -/ +theorem projectiveRiemannSectionToEffectiveDivisorInPrincipalClass_surjective + (D : FiniteExtensionDivisor K L) : + Function.Surjective + (projectiveRiemannSectionToEffectiveDivisorInPrincipalClass K L D) := by + intro E + obtain ⟨hEeffective, x, hx0, hE⟩ := E.2 + have hxmem : x ∈ finiteExtensionRiemannSpace K L D := by + rw [mem_finiteExtensionRiemannSpace] + exact Or.inr ⟨hx0, by + intro v + have hv := hEeffective v + rw [hE, Finsupp.add_apply] at hv + exact hv⟩ + let xD : finiteExtensionRiemannSpace K L D := ⟨x, hxmem⟩ + have hxD0 : xD ≠ 0 := by + intro hxD + apply hx0 + exact congrArg Subtype.val hxD + refine ⟨Projectivization.mk K xD hxD0, ?_⟩ + apply Subtype.ext + change finiteExtensionPrincipalDivisor K L x + D = E.1 + exact hE.symm + +omit [Fintype K] [DecidableEq K] in +/-- Under exact constants, a nonzero function has zero exhaustive principal +divisor exactly when it is a nonzero base-field constant. -/ +theorem finiteExtensionPrincipalDivisor_eq_zero_iff_isBaseConstant [Finite K] + (hconstants : algebraicClosure K L = ⊥) (x : L) (hx0 : x ≠ 0) : + finiteExtensionPrincipalDivisor K L x = 0 ↔ + ∃ c : K, c ≠ 0 ∧ algebraMap K L c = x := by + classical + let : Fintype K := Fintype.ofFinite K + constructor + · intro hx + have hxmem : x ∈ finiteExtensionRiemannSpace K L 0 := by + rw [mem_finiteExtensionRiemannSpace] + exact Or.inr ⟨hx0, by simp [hx]⟩ + rw [finiteExtensionRiemannSpace_zero_eq_range K L hconstants] at hxmem + obtain ⟨c, hc⟩ := hxmem + refine ⟨c, ?_, hc⟩ + intro hc0 + subst c + exact hx0 (by simpa using hc.symm) + · rintro ⟨c, hc, rfl⟩ + exact finiteExtensionPrincipalDivisor_algebraMap_constant K L c hc + +omit [Fintype K] [DecidableEq K] in +/-- With exact constants, two nonzero functions have the same exhaustive +principal divisor exactly when they differ by a base-field scalar. -/ +theorem finiteExtensionPrincipalDivisor_eq_iff_exists_smul [Finite K] + (hconstants : algebraicClosure K L = ⊥) + (x y : L) (hx0 : x ≠ 0) (hy0 : y ≠ 0) : + finiteExtensionPrincipalDivisor K L x = + finiteExtensionPrincipalDivisor K L y ↔ + ∃ c : K, c • y = x := by + classical + let : Fintype K := Fintype.ofFinite K + constructor + · intro hxy + have hquot : finiteExtensionPrincipalDivisor K L (x / y) = 0 := by + rw [finiteExtensionPrincipalDivisor_div K L x y hx0 hy0, hxy, sub_self] + obtain ⟨c, _, hc⟩ := + (finiteExtensionPrincipalDivisor_eq_zero_iff_isBaseConstant + K L hconstants (x / y) (div_ne_zero hx0 hy0)).mp hquot + refine ⟨c, ?_⟩ + rw [Algebra.smul_def, hc, div_mul_cancel₀ x hy0] + · rintro ⟨c, hc⟩ + have hc0 : c ≠ 0 := by + intro hczero + subst c + exact hx0 (hc.symm.trans (zero_smul K y)) + have hcL : algebraMap K L c ≠ 0 := + by simpa only [map_zero] using (algebraMap K L).injective.ne hc0 + rw [← hc, Algebra.smul_def, + finiteExtensionPrincipalDivisor_mul K L _ _ hcL hy0, + finiteExtensionPrincipalDivisor_algebraMap_constant K L c hc0, zero_add] + +/-- Exact constants make the projective-section map injective. -/ +theorem projectiveRiemannSectionToEffectiveDivisorInPrincipalClass_injective + (D : FiniteExtensionDivisor K L) + (hconstants : algebraicClosure K L = ⊥) : + Function.Injective + (projectiveRiemannSectionToEffectiveDivisorInPrincipalClass K L D) := by + intro p q hpq + induction p using Projectivization.ind with + | h x hx => + induction q using Projectivization.ind with + | h y hy => + apply (Projectivization.mk_eq_mk_iff' K x y hx hy).2 + change + effectiveDivisorInPrincipalClassOfNonzeroSection K L D ⟨x, hx⟩ = + effectiveDivisorInPrincipalClassOfNonzeroSection K L D ⟨y, hy⟩ + at hpq + have hdivAdd : + finiteExtensionPrincipalDivisor K L x.1 + D = + finiteExtensionPrincipalDivisor K L y.1 + D := by + exact congrArg Subtype.val hpq + have hdiv : finiteExtensionPrincipalDivisor K L x.1 = + finiteExtensionPrincipalDivisor K L y.1 := add_right_cancel hdivAdd + have hx0 : (x.1 : L) ≠ 0 := by + intro hxzero + apply hx + exact Subtype.ext hxzero + have hy0 : (y.1 : L) ≠ 0 := by + intro hyzero + apply hy + exact Subtype.ext hyzero + obtain ⟨c, hc⟩ := + (finiteExtensionPrincipalDivisor_eq_iff_exists_smul + K L hconstants x.1 y.1 + hx0 hy0).mp hdiv + refine ⟨c, Subtype.ext ?_⟩ + exact hc + +/-- With exact constants, projective nonzero sections are equivalent to the +effective divisors in the represented principal class. -/ +def projectiveRiemannSectionEquivEffectiveDivisorInPrincipalClass + (D : FiniteExtensionDivisor K L) + (hconstants : algebraicClosure K L = ⊥) : + Projectivization K (finiteExtensionRiemannSpace K L D) ≃ + EffectiveDivisorInPrincipalClass K L D := + Equiv.ofBijective + (projectiveRiemannSectionToEffectiveDivisorInPrincipalClass K L D) + ⟨projectiveRiemannSectionToEffectiveDivisorInPrincipalClass_injective + K L D hconstants, + projectiveRiemannSectionToEffectiveDivisorInPrincipalClass_surjective + K L D⟩ + +/-- Nonzero sections of `L(D)` modulo nonzero constant scalars satisfy the +projective-space `Nat.card` identity. The following finiteness theorem turns +this into an ordinary finite count when `D` is effective. -/ +theorem effectiveRiemannSpace_nonzeroScalarOrbitQuotient_card_eq_geomSum + (D : FiniteExtensionDivisor K L) : + Nat.card + (Quotient + (MulAction.orbitRel Kˣ + {x : finiteExtensionRiemannSpace K L D // x ≠ 0})) = + ∑ i ∈ Finset.range + (Module.finrank K (finiteExtensionRiemannSpace K L D)), + Nat.card K ^ i := by + exact finiteVectorSpace_nonzeroScalarOrbitQuotient_card_eq_geomSum + K (finiteExtensionRiemannSpace K L D) + +/-- For effective `D`, the scalar-orbit quotient of nonzero sections is a +finite type. -/ +theorem effectiveRiemannSpace_nonzeroScalarOrbitQuotient_finite + (D : FiniteExtensionDivisor K L) (hD : ∀ v, 0 ≤ D v) : + Finite + (Quotient + (MulAction.orbitRel Kˣ + {x : finiteExtensionRiemannSpace K L D // x ≠ 0})) := by + let : Module.Finite K (finiteExtensionRiemannSpace K L D) := + finiteExtensionRiemannSpace_effective_moduleFinite K L D hD + let : Finite (finiteExtensionRiemannSpace K L D) := + Module.finite_of_finite K + exact Finite.of_equiv + (Projectivization K (finiteExtensionRiemannSpace K L D)) + (Projectivization.equivQuotientOrbitRel K + (finiteExtensionRiemannSpace K L D)) + +/-- Division form of the projectivized effective Riemann-space count. -/ +theorem effectiveRiemannSpace_nonzeroScalarOrbitQuotient_card_eq_div + (D : FiniteExtensionDivisor K L) (hD : ∀ v, 0 ≤ D v) : + Nat.card + (Quotient + (MulAction.orbitRel Kˣ + {x : finiteExtensionRiemannSpace K L D // x ≠ 0})) = + (Nat.card K ^ + Module.finrank K (finiteExtensionRiemannSpace K L D) - 1) / + (Nat.card K - 1) := by + let : Module.Finite K (finiteExtensionRiemannSpace K L D) := + finiteExtensionRiemannSpace_effective_moduleFinite K L D hD + exact finiteVectorSpace_nonzeroScalarOrbitQuotient_card_eq_div + K (finiteExtensionRiemannSpace K L D) + +omit [Fintype K] [DecidableEq K] in +/-- Under exact constants, an effective divisor class represented by an +effective `D` is finite. -/ +theorem effectiveDivisorInPrincipalClass_finite [Finite K] + (D : FiniteExtensionDivisor K L) (hD : ∀ v, 0 ≤ D v) + (hconstants : algebraicClosure K L = ⊥) : + Finite (EffectiveDivisorInPrincipalClass K L D) := by + classical + let : Fintype K := Fintype.ofFinite K + let : Module.Finite K (finiteExtensionRiemannSpace K L D) := + finiteExtensionRiemannSpace_effective_moduleFinite K L D hD + let : Finite (finiteExtensionRiemannSpace K L D) := + Module.finite_of_finite K + exact Finite.of_equiv + (Projectivization K (finiteExtensionRiemannSpace K L D)) + (projectiveRiemannSectionEquivEffectiveDivisorInPrincipalClass + K L D hconstants) + +/-- Cardinality of the effective divisors in a fixed principal class under +the exact-constants hypothesis. -/ +theorem effectiveDivisorInPrincipalClass_card_eq_geomSum + (D : FiniteExtensionDivisor K L) + (hconstants : algebraicClosure K L = ⊥) : + Nat.card (EffectiveDivisorInPrincipalClass K L D) = + ∑ i ∈ Finset.range + (Module.finrank K (finiteExtensionRiemannSpace K L D)), + Nat.card K ^ i := by + rw [Nat.card_congr + (projectiveRiemannSectionEquivEffectiveDivisorInPrincipalClass + K L D hconstants).symm] + exact Projectivization.card_of_finrank K + (finiteExtensionRiemannSpace K L D) rfl + +/-- Division form of the fixed-principal-class count. -/ +theorem effectiveDivisorInPrincipalClass_card_eq_div + (D : FiniteExtensionDivisor K L) (hD : ∀ v, 0 ≤ D v) + (hconstants : algebraicClosure K L = ⊥) : + Nat.card (EffectiveDivisorInPrincipalClass K L D) = + (Nat.card K ^ + Module.finrank K (finiteExtensionRiemannSpace K L D) - 1) / + (Nat.card K - 1) := by + let : Module.Finite K (finiteExtensionRiemannSpace K L D) := + finiteExtensionRiemannSpace_effective_moduleFinite K L D hD + rw [Nat.card_congr + (projectiveRiemannSectionEquivEffectiveDivisorInPrincipalClass + K L D hconstants).symm, + Projectivization.card'', Module.natCard_eq_pow_finrank (K := K)] + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionStandardZetaRationality.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionStandardZetaRationality.lean new file mode 100644 index 0000000000..1ed04afed3 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionStandardZetaRationality.lean @@ -0,0 +1,170 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionZetaNumeratorNoncancellation +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionIndexedZetaRationalityAutomatic +public import LeanPool.MarkoffModP.BGS.HasseWeil.FormalZetaRationalityDegree +public import LeanPool.MarkoffModP.BGS.HasseWeil.FormalZetaTrace + +/-! +# Standard zeta rationality after proving degree index one + +This file packages the exact downstream consequence of F. K. Schmidt's +degree-index theorem. Once the exhaustive divisor-degree index is one, the +automatic indexed zeta rational form becomes the standard curve denominator +`(1 - T) (1 - qT)`. The Riemann--Roch construction also retains a concrete +numerator-degree bound and numerator noncancellation at `T = 1`. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +noncomputable section + +open BGS.CorvajaZannier +open scoped Polynomial + +variable (K : Type*) [Field K] [Fintype K] [DecidableEq K] + [DecidableEq (RatFunc K)] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +local instance standardZetaConstantAlgebra : Algebra K L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K (RatFunc K))) + +local instance standardZetaConstantTower : IsScalarTower K (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + +local instance (priority := 10) standardZetaPolynomialAlgebra : + Algebra K[X] L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K[X] (RatFunc K))) + +local instance standardZetaPolynomialTower : + IsScalarTower K[X] (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + +local instance standardZetaConstantPolynomialTower : + IsScalarTower K K[X] L := + IsScalarTower.of_algebraMap_eq' rfl + +/-- An indexed zeta rational form with index one is exactly a standard curve +zeta rational form. -/ +theorem hasCurveZetaRationalForm_of_indexed_index_one + (Z : PowerSeries ℂ) (q : ℕ) (P : Polynomial ℂ) + (hindexed : HasIndexedCurveZetaRationalForm Z q 1 P) : + HasCurveZetaRationalForm Z q P := by + simpa [HasIndexedCurveZetaRationalForm, indexedCurveZetaDenominator, + HasCurveZetaRationalForm, curveZetaDenominator, linearPowerSeriesFactor] + using hindexed + +/-- Uniform Riemann--Roch and degree index one give a normalized standard +zeta numerator. Its degree is bounded by the same truncation length used in +the indexed recurrence, and its value at `T = 1` is nonzero. -/ +theorem exists_finiteExtensionClosedPlaceZeta_rational_with_natDegree_lt_of_uniformRiemann + (genus threshold : ℕ) + (hconstants : algebraicClosure K L = + (⊥ : IntermediateField K L)) + (hRiemann : HasFiniteExtensionUniformEventualRiemannFormula + K L genus threshold) + (hindex : finiteExtensionDivisorDegreeIndex K L = 1) : + ∃ P : Polynomial ℂ, + P.coeff 0 = 1 ∧ + P.eval 1 ≠ 0 ∧ + P.natDegree < threshold + 2 ∧ + HasCurveZetaRationalForm + (formalPointCountZeta + (finiteExtensionClosedPlaceExtensionCount K L)) + (Nat.card K) P := by + obtain ⟨P, hPzero, hPdegree, hPindexed⟩ := + exists_formalPointCountZeta_indexed_rational_with_natDegree_lt_of_effectiveDivisor_recurrences + (finiteExtensionEffectiveDivisorCount K L) + (finiteExtensionClosedPlaceExtensionCount K L) + (Nat.card K) (finiteExtensionDivisorDegreeIndex K L) + threshold + (finiteExtensionDivisorDegreeIndex_pos K L) + (finiteExtensionEffectiveDivisorCount_zero K L) + (finiteExtensionEffectiveDivisorPointCountRecurrence K L) + (fun n hn => + finiteExtensionEffectiveDivisorCount_indexed_eventual_recurrence_complex + K L genus threshold n hconstants hRiemann hn) + have hPone : P.eval 1 ≠ 0 := + finiteExtensionClosedPlaceZeta_indexedNumerator_eval_one_ne_zero_of_uniformRiemann + K L genus threshold hconstants hRiemann P hPindexed + have hPdegree' : P.natDegree < threshold + 2 := by + simpa [hindex] using hPdegree + have hPstandard : + HasCurveZetaRationalForm + (formalPointCountZeta + (finiteExtensionClosedPlaceExtensionCount K L)) + (Nat.card K) P := by + rw [hindex] at hPindexed + exact hasCurveZetaRationalForm_of_indexed_index_one _ _ _ hPindexed + exact ⟨P, hPzero, hPone, hPdegree', hPstandard⟩ + +/-- Exact constants and degree index one give the standard curve zeta form +with numerator degree strictly below `2g + 2`, where `g` is the transported +function-field genus. -/ +theorem exists_finiteExtensionClosedPlaceZeta_rational_with_genus_degree_bound + (hconstants : algebraicClosure K L = + (⊥ : IntermediateField K L)) + (hindex : finiteExtensionDivisorDegreeIndex K L = 1) : + ∃ P : Polynomial ℂ, + P.coeff 0 = 1 ∧ + P.eval 1 ≠ 0 ∧ + P.natDegree < 2 * FunctionField.genus K L + 2 ∧ + HasCurveZetaRationalForm + (formalPointCountZeta + (finiteExtensionClosedPlaceExtensionCount K L)) + (Nat.card K) P := by + let : FunctionField.IsFullConstantField K L := + (FunctionField.isFullConstantField_iff_algebraicClosure_eq_bot K L).2 + hconstants + simpa only [FunctionField.genus_eq_genusChart K L] using + exists_finiteExtensionClosedPlaceZeta_rational_with_natDegree_lt_of_uniformRiemann + K L (FunctionField.Chart.genus K L) + (2 * FunctionField.Chart.genus K L) hconstants + (hasFiniteExtensionUniformEventualRiemannFormula_of_fullConstantField K L) + hindex + +/-- If the intrinsic genus is at most `budget`, the standard numerator has at +most `2 * budget + 1` reciprocal roots. The same polynomial carries the +formal extension point-count trace formula. -/ +theorem exists_finiteExtensionClosedPlaceZeta_trace_with_degree_budget + (budget : ℕ) + (hconstants : algebraicClosure K L = + (⊥ : IntermediateField K L)) + (hindex : finiteExtensionDivisorDegreeIndex K L = 1) + (hgenus : FunctionField.genus K L ≤ budget) : + ∃ P : Polynomial ℂ, + P.coeff 0 = 1 ∧ + P.eval 1 ≠ 0 ∧ + P.natDegree ≤ 2 * budget + 1 ∧ + HasCurveZetaRationalForm + (formalPointCountZeta + (finiteExtensionClosedPlaceExtensionCount K L)) + (Nat.card K) P ∧ + HasZetaNumeratorPointCountFormula + (Nat.card K) + (finiteExtensionClosedPlaceExtensionCount K L) P := by + obtain ⟨P, hPzero, hPone, hPdegree, hPform⟩ := + exists_finiteExtensionClosedPlaceZeta_rational_with_genus_degree_bound + K L hconstants hindex + have hdegreeBudget : P.natDegree ≤ 2 * budget + 1 := by + omega + exact ⟨P, hPzero, hPone, hdegreeBudget, hPform, + hasZetaNumeratorPointCountFormula_of_formalPointCountZeta_rational + (Nat.card K) (finiteExtensionClosedPlaceExtensionCount K L) + P hPzero hPform⟩ + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionTotalDifferentEffectiveDivisor.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionTotalDifferentEffectiveDivisor.lean new file mode 100644 index 0000000000..2c5915fd05 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionTotalDifferentEffectiveDivisor.lean @@ -0,0 +1,158 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionEffectiveDivisorSplit +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionCanonicalDifferentDivisor + +/-! +# The total effective different divisor + +This file packages the finite and above-infinity different multiplicities in +one exhaustive effective divisor, and identifies its weighted degree with the +sum of the two numerical different degrees already used by Riemann--Hurwitz. + +Unlike the canonical divisor attached to `dX`, this effective divisor records +the total different itself: its infinity coefficients do not contain the +additional `-2e` correction coming from the pole of `dX`. +-/ + +@[expose] public section + +open scoped BigOperators nonZeroDivisors Polynomial + +namespace BGS.HasseWeil + +noncomputable section + +open BGS.CorvajaZannier IsDedekindDomain + +variable (K : Type*) [Field K] [Finite K] + [DecidableEq K] [DecidableEq (RatFunc K)] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +local instance totalDifferentFintype : Fintype K := Fintype.ofFinite K + +local instance (priority := 10) totalDifferentPolynomialAlgebra : Algebra K[X] L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K[X] (RatFunc K))) + +local instance totalDifferentPolynomialScalarTower : + IsScalarTower K[X] (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + +local instance totalDifferentFiniteIntegralClosureModuleFinite : + Module.Finite K[X] (RatFuncFiniteIntegralClosure K L) := + Module.IsNoetherian.finite K[X] (RatFuncFiniteIntegralClosure K L) + +local instance totalDifferentFiniteIntegralClosureIsIntegral : + Algebra.IsIntegral K[X] (RatFuncFiniteIntegralClosure K L) := + IsIntegralClosure.isIntegral_algebra K[X] L + +local instance totalDifferentPolynomialTorsionFreeTop : + Module.IsTorsionFree K[X] L := + Module.IsTorsionFree.trans_faithfulSMul K[X] (RatFunc K) L + +local instance totalDifferentFiniteIntegralClosureIsTorsionFree : + Module.IsTorsionFree K[X] (RatFuncFiniteIntegralClosure K L) := + IsIntegralClosure.isTorsionFree K[X] L + +local instance totalDifferentInfinityIntegralClosureModuleFinite : + Module.Finite (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.finite (RatFuncInfinityIntegers K) (RatFunc K) L + (RatFuncInfinityIntegralClosure K L) + +local instance totalDifferentInfinityIntegralClosureIsIntegral : + Algebra.IsIntegral (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.isIntegral_algebra (RatFuncInfinityIntegers K) L + +local instance totalDifferentInfinityTorsionFreeTop : + Module.IsTorsionFree (RatFuncInfinityIntegers K) L := + Module.IsTorsionFree.trans_faithfulSMul + (RatFuncInfinityIntegers K) (RatFunc K) L + +local instance totalDifferentInfinityIntegralClosureIsTorsionFree : + Module.IsTorsionFree (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.isTorsionFree (RatFuncInfinityIntegers K) L + +local instance totalDifferentInfinityIntegralClosureIsDedekindDomain : + IsDedekindDomain (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.isDedekindDomain + (RatFuncInfinityIntegers K) (RatFunc K) L + (RatFuncInfinityIntegralClosure K L) + +local instance totalDifferentInfinityPlaceFintype : + Fintype (FiniteExtensionInfinityPlace K L) := + Set.Finite.fintype + (IsDedekindDomain.primesOver_finite + (ratFuncInfinityPlace K).asIdeal + (RatFuncInfinityIntegralClosure K L)) + +/-- The effective divisor whose coefficient at every exhaustive place is the +local multiplicity of the trace different. -/ +def finiteExtensionTotalDifferentEffectiveDivisor : + FiniteExtensionEffectiveDivisor K L := + (differentMultiplicityDivisor K[X] + (RatFuncFiniteIntegralClosure K L) + (finiteExtensionFiniteDifferentIdeal_ne_bot K L)).sumElim + (Finsupp.equivFunOnFinite.symm fun P => + multiplicity P.1 + (differentIdeal (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L))) + +omit [Finite K] [DecidableEq K] in +@[simp] +theorem finiteExtensionTotalDifferentEffectiveDivisor_inl + (P : FiniteExtensionFinitePlace K L) : + finiteExtensionTotalDifferentEffectiveDivisor K L (.inl P) = + multiplicity P.asIdeal + (differentIdeal K[X] (RatFuncFiniteIntegralClosure K L)) := by + simp [finiteExtensionTotalDifferentEffectiveDivisor] + +omit [Finite K] [DecidableEq K] in +@[simp] +theorem finiteExtensionTotalDifferentEffectiveDivisor_inr + (P : FiniteExtensionInfinityPlace K L) : + finiteExtensionTotalDifferentEffectiveDivisor K L (.inr P) = + multiplicity P.1 + (differentIdeal (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L)) := by + simp [finiteExtensionTotalDifferentEffectiveDivisor] + +omit [Finite K] in +/-- The exhaustive effective different has degree equal to the finite +different degree plus the above-infinity different degree. -/ +theorem finiteExtensionTotalDifferentEffectiveDivisor_degree : + finiteExtensionEffectiveDivisorDegree K L + (finiteExtensionTotalDifferentEffectiveDivisor K L) = + finiteExtensionFiniteDifferentDegree K L + (finiteExtensionFiniteDifferentIdeal_ne_bot K L) + + infinityDifferentDegree K L := by + rw [finiteExtensionEffectiveDivisorDegree] + rw [finiteExtensionTotalDifferentEffectiveDivisor, Finsupp.sum_sumElim] + congr 1 + · rw [finiteExtensionFiniteDifferentDegree] + apply Finsupp.sum_congr + intro P _ + simp only [Function.comp_apply, finiteExtensionPlaceDegree] + ac_rfl + · rw [infinityDifferentDegree] + rw [Finsupp.sum_fintype _ _ (fun _ => by simp)] + apply Finset.sum_congr rfl + intro P _ + simp only [Function.comp_apply, finiteExtensionPlaceDegree] + simp + ac_rfl + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionZeroCounting.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionZeroCounting.lean new file mode 100644 index 0000000000..259351aaef --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionZeroCounting.lean @@ -0,0 +1,198 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionPrincipalDivisor +public import Mathlib.Tactic + +/-! +# Zero counting from principal-divisor height + +This file isolates the divisor-theoretic counting step used after a +Hasse--Weil estimate. Every place has positive degree, so each distinct zero +of a function contributes at least one to the degree of its positive divisor. +The product formula then identifies that degree with the pole height. + +No point-count estimate is used here. In particular, the genuinely +Hasse--Weil input can remain a separate upstream theorem. +-/ + +@[expose] public section + +open scoped nonZeroDivisors Polynomial BigOperators +open IsDedekindDomain + +namespace BGS.HasseWeil + +open BGS.CorvajaZannier + +noncomputable section + +variable (K : Type*) [Field K] [DecidableEq K] [DecidableEq (RatFunc K)] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +local instance (priority := 10) zeroCountingPolynomialAlgebra : + Algebra K[X] L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K[X] (RatFunc K))) + +local instance zeroCountingPolynomialScalarTower : + IsScalarTower K[X] (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + +local instance zeroCountingFiniteIntegralClosureModuleFinite : + Module.Finite K[X] (RatFuncFiniteIntegralClosure K L) := + Module.IsNoetherian.finite K[X] (RatFuncFiniteIntegralClosure K L) + +local instance zeroCountingInfinityIntegralClosureModuleFinite : + Module.Finite (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.finite (RatFuncInfinityIntegers K) (RatFunc K) L + (RatFuncInfinityIntegralClosure K L) + +/-- Every finite or above-infinity place of a finite separable function-field +extension has positive degree. -/ +theorem finiteExtensionPlaceDegree_pos + (v : FiniteExtensionPlace K L) : + 0 < finiteExtensionPlaceDegree K L v := by + cases v with + | inl q => + rw [finiteExtensionPlaceDegree] + exact Nat.mul_pos + (Ideal.inertiaDeg_pos q.asIdeal K[X]) + ((finitePlaceNormalizedPrime + (HeightOneSpectrum.under K[X] q)).property.1.irreducible.natDegree_pos) + | inr P => + simpa [finiteExtensionPlaceDegree] using + Ideal.inertiaDeg_pos P.1 (RatFuncInfinityIntegers K) + +/-- The finite set of places where `x` has positive order. -/ +def finiteExtensionZeroPlaces (x : L) : + Finset (FiniteExtensionPlace K L) := + (finiteExtensionPrincipalDivisor K L x).support.filter + (fun v => 0 < finiteExtensionPrincipalDivisor K L x v) + +omit [DecidableEq K] in +@[simp] theorem mem_finiteExtensionZeroPlaces_iff + (x : L) (v : FiniteExtensionPlace K L) : + v ∈ finiteExtensionZeroPlaces K L x ↔ + 0 < finiteExtensionPrincipalDivisor K L x v := by + simp only [finiteExtensionZeroPlaces, Finset.mem_filter, + Finsupp.mem_support_iff] + omega + +/-- The degree of the positive divisor is the weighted sum over the zero +places. -/ +theorem finiteExtensionPositiveDegree_eq_sum_zeroPlaces + (x : L) : + finiteExtensionPositiveDegree K L x = + ∑ v ∈ finiteExtensionZeroPlaces K L x, + (finiteExtensionPrincipalDivisor K L x v).toNat * + finiteExtensionPlaceDegree K L v := by + rfl + +/-- Any finite set of positive-order places has cardinality at most the degree +of the positive divisor. -/ +theorem card_le_finiteExtensionPositiveDegree_of_orders_positive + (x : L) (S : Finset (FiniteExtensionPlace K L)) + (hpositive : ∀ v ∈ S, 0 < finiteExtensionPrincipalDivisor K L x v) : + S.card ≤ finiteExtensionPositiveDegree K L x := by + let weight : FiniteExtensionPlace K L → ℕ := fun v => + (finiteExtensionPrincipalDivisor K L x v).toNat * + finiteExtensionPlaceDegree K L v + have hsubset : S ⊆ finiteExtensionZeroPlaces K L x := by + intro v hv + exact (mem_finiteExtensionZeroPlaces_iff K L x v).2 (hpositive v hv) + calc + S.card = ∑ _v ∈ S, 1 := by simp + _ ≤ ∑ v ∈ S, weight v := by + apply Finset.sum_le_sum + intro v hv + have horder : 0 < (finiteExtensionPrincipalDivisor K L x v).toNat := + Int.pos_iff_toNat_pos.mp (hpositive v hv) + have hdegree : 0 < finiteExtensionPlaceDegree K L v := + finiteExtensionPlaceDegree_pos K L v + simpa [weight] using Nat.one_le_iff_ne_zero.mpr + (Nat.mul_ne_zero (Nat.ne_of_gt horder) (Nat.ne_of_gt hdegree)) + _ ≤ ∑ v ∈ finiteExtensionZeroPlaces K L x, weight v := by + exact Finset.sum_le_sum_of_subset_of_nonneg hsubset (by omega) + _ = finiteExtensionPositiveDegree K L x := by + rw [finiteExtensionPositiveDegree_eq_sum_zeroPlaces K L x] + +/-- Any finite family of positive-order places contributes its full +residue-degree weight to the positive divisor. This is the form needed when +degree-one and degree-two closed points are counted simultaneously over a +quadratic constant-field extension. -/ +theorem sum_placeDegree_le_finiteExtensionPositiveDegree_of_orders_positive + (x : L) (S : Finset (FiniteExtensionPlace K L)) + (hpositive : ∀ v ∈ S, 0 < finiteExtensionPrincipalDivisor K L x v) : + ∑ v ∈ S, finiteExtensionPlaceDegree K L v ≤ + finiteExtensionPositiveDegree K L x := by + let weight : FiniteExtensionPlace K L → ℕ := fun v => + (finiteExtensionPrincipalDivisor K L x v).toNat * + finiteExtensionPlaceDegree K L v + have hsubset : S ⊆ finiteExtensionZeroPlaces K L x := by + intro v hv + exact (mem_finiteExtensionZeroPlaces_iff K L x v).2 (hpositive v hv) + calc + ∑ v ∈ S, finiteExtensionPlaceDegree K L v ≤ + ∑ v ∈ S, weight v := by + apply Finset.sum_le_sum + intro v hv + have horder : 1 ≤ (finiteExtensionPrincipalDivisor K L x v).toNat := by + have horderPositive : + 0 < (finiteExtensionPrincipalDivisor K L x v).toNat := + Int.pos_iff_toNat_pos.mp (hpositive v hv) + omega + exact Nat.le_mul_of_pos_left + (finiteExtensionPlaceDegree K L v) horder + _ ≤ ∑ v ∈ finiteExtensionZeroPlaces K L x, weight v := by + exact Finset.sum_le_sum_of_subset_of_nonneg hsubset (by omega) + _ = finiteExtensionPositiveDegree K L x := by + rw [finiteExtensionPositiveDegree_eq_sum_zeroPlaces K L x] + +/-- Weighted positive-order place counting in terms of pole height. -/ +theorem sum_placeDegree_le_finiteExtensionHeight_of_orders_positive + (x : L) (hx : x ≠ 0) + (S : Finset (FiniteExtensionPlace K L)) + (hpositive : ∀ v ∈ S, 0 < finiteExtensionPrincipalDivisor K L x v) : + ∑ v ∈ S, finiteExtensionPlaceDegree K L v ≤ + finiteExtensionHeight K L x := by + rw [← finiteExtensionPositiveDegree_eq_height K L x hx] + exact sum_placeDegree_le_finiteExtensionPositiveDegree_of_orders_positive + K L x S hpositive + +/-- If a finite type injects into positive-order places of a nonzero function, +then its cardinality is bounded by the pole height of that function. -/ +theorem Fintype.card_le_finiteExtensionHeight_of_injective_orders_positive + {ι : Type*} [Fintype ι] + (x : L) (hx : x ≠ 0) + (place : ι → FiniteExtensionPlace K L) + (hinjective : Function.Injective place) + (hpositive : ∀ i, 0 < finiteExtensionPrincipalDivisor K L x (place i)) : + Fintype.card ι ≤ finiteExtensionHeight K L x := by + classical + let S : Finset (FiniteExtensionPlace K L) := Finset.univ.image place + have hcard : S.card = Fintype.card ι := by + simpa [S] using Finset.card_image_of_injective Finset.univ hinjective + have hSpositive : + ∀ v ∈ S, 0 < finiteExtensionPrincipalDivisor K L x v := by + intro v hv + rcases Finset.mem_image.mp hv with ⟨i, _hi, rfl⟩ + exact hpositive i + calc + Fintype.card ι = S.card := hcard.symm + _ ≤ finiteExtensionPositiveDegree K L x := + card_le_finiteExtensionPositiveDegree_of_orders_positive K L x S hSpositive + _ = finiteExtensionHeight K L x := + finiteExtensionPositiveDegree_eq_height K L x hx + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionZetaDegreeExtensionIdentity.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionZetaDegreeExtensionIdentity.lean new file mode 100644 index 0000000000..77524574f5 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionZetaDegreeExtensionIdentity.lean @@ -0,0 +1,72 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionDivisorDegreeIndex +public import LeanPool.MarkoffModP.BGS.HasseWeil.ClosedPlaceEulerRecurrence +public import LeanPool.MarkoffModP.BGS.HasseWeil.FormalZetaConstantExtensionIdentity + +/-! +# Degree support and the constant-extension zeta identity + +This file specializes the formal constant-extension identity to the exhaustive +closed-place point-count sequence. The divisor-degree index itself supplies +the required divisibility support. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +noncomputable section + +open BGS.CorvajaZannier + +variable (K : Type*) [Field K] [Fintype K] [DecidableEq K] + [DecidableEq (RatFunc K)] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +/-- The exhaustive closed-place count vanishes outside multiples of the +divisor-degree index. -/ +theorem finiteExtensionClosedPlaceExtensionCount_eq_zero_of_not_dvd_index + (n : ℕ) + (hn : ¬ finiteExtensionDivisorDegreeIndex K L ∣ n) : + finiteExtensionClosedPlaceExtensionCount K L n = 0 := by + classical + simp only [finiteExtensionClosedPlaceExtensionCount] + apply Finset.sum_eq_zero + intro P _ + split_ifs with hdegree + · exact False.elim (hn + ((finiteExtensionDivisorDegreeIndex_dvd_placeDegree K L P.1).trans + hdegree)) + · rfl + +/-- Once the geometric constant extension supplies its exact point-count +relation, the corresponding zeta identity follows automatically. -/ +theorem finiteExtensionClosedPlaceZeta_hasDegreeExtensionIdentity + (extendedPointCount : ℕ → ℕ) + (hcount : ∀ r, + extendedPointCount r = + finiteExtensionClosedPlaceExtensionCount K L + (finiteExtensionDivisorDegreeIndex K L * r)) : + HasFormalDegreeExtensionZetaIdentity + (formalPointCountZeta + (finiteExtensionClosedPlaceExtensionCount K L)) + (formalPointCountZeta extendedPointCount) + (finiteExtensionDivisorDegreeIndex K L) := by + exact formalPointCountZeta_hasDegreeExtensionIdentity + (finiteExtensionClosedPlaceExtensionCount K L) + extendedPointCount (finiteExtensionDivisorDegreeIndex K L) + (finiteExtensionDivisorDegreeIndex_pos K L) hcount + (finiteExtensionClosedPlaceExtensionCount_eq_zero_of_not_dvd_index K L) + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionZetaDegreeIndexOne.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionZetaDegreeIndexOne.lean new file mode 100644 index 0000000000..304257127b --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionZetaDegreeIndexOne.lean @@ -0,0 +1,240 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.ConstantExtensionClosedPlaceCount +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionConstants +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionIndexedZetaRationalityAutomatic +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionZetaDegreeExtensionIdentity +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionZetaNumeratorNoncancellation +public import LeanPool.MarkoffModP.BGS.HasseWeil.FormalZetaDegreeIndexOneIndexed +public import LeanPool.MarkoffModP.BGS.HasseWeil.RatFuncExactConstantExtension + +/-! +# The geometric F. K. Schmidt composition + +This file composes indexed zeta rationality, numerator noncancellation, the +formal constant-extension identity, and indexed rationality after exact +constant extension. The extension is never assumed to have degree index one. + +The only geometric input left explicit is the closed-place count identity for +the constant extension whose degree is the original divisor-degree index. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +noncomputable section + +open BGS.CorvajaZannier +open scoped Polynomial TensorProduct + +variable (K : Type*) [Field K] [Fintype K] [DecidableEq K] + [DecidableEq (RatFunc K)] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +local instance degreeIndexOneAutomaticConstantAlgebra : Algebra K L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K (RatFunc K))) + +local instance degreeIndexOneAutomaticConstantTower : + IsScalarTower K (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + +/-- Exact constants automatically give an indexed rational numerator which +does not vanish at `T = 1`. -/ +theorem exists_finiteExtensionClosedPlaceZeta_indexed_rational_nonvanishing_of_constants + (hconstants : algebraicClosure K L = + (⊥ : IntermediateField K L)) : + ∃ P : Polynomial ℂ, + P.coeff 0 = 1 ∧ P.eval 1 ≠ 0 ∧ + HasIndexedCurveZetaRationalForm + (formalPointCountZeta + (finiteExtensionClosedPlaceExtensionCount K L)) + (Nat.card K) (finiteExtensionDivisorDegreeIndex K L) P := by + obtain ⟨genus, threshold, hRiemann⟩ := + exists_hasFiniteExtensionUniformEventualRiemannFormula_of_constants + K L hconstants + exact exists_finiteExtensionClosedPlaceZeta_indexed_rational_nonvanishing + K L genus threshold hconstants hRiemann + +variable (C S N : Type*) [Field C] [Field S] [Field N] + [Fintype C] [Fintype S] [DecidableEq C] [DecidableEq (RatFunc C)] + [Algebra (RatFunc C) N] [FiniteDimensional (RatFunc C) N] + [Algebra.IsSeparable (RatFunc C) N] + [Algebra C S] [FiniteDimensional C S] [IsGalois C S] + +local instance degreeIndexOneBaseConstantAlgebra : Algebra C N := + RingHom.toAlgebra ((algebraMap (RatFunc C) N).comp + (algebraMap C (RatFunc C))) + +local instance degreeIndexOneBaseConstantTower : + IsScalarTower C (RatFunc C) N := + IsScalarTower.of_algebraMap_eq' rfl + +/-- The exhaustive closed-place point-count sequence of the exact constant +extension, packaged with its canonical `S(X)`-function-field structure. -/ +noncomputable def exactConstantExtensionClosedPlaceExtensionCount + (hExact : algebraicClosure C N = + (⊥ : IntermediateField C N)) (r : ℕ) : ℕ := by + let E := ExactConstantExtension C N S + letI : Field E := exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc S) E := + ratFuncExactConstantExtensionAlgebra C S N hExact + letI : SMul (RatFunc S) E := Algebra.toSMul + letI : Module (RatFunc S) E := Algebra.toModule + letI : FiniteDimensional (RatFunc S) E := + finiteDimensional_over_extendedRatFunc C S N hExact + letI : Algebra.IsSeparable (RatFunc S) E := + isSeparable_over_extendedRatFunc C S N hExact + letI : DecidableEq S := infinityBridgeDecidableEqConstants S + letI : DecidableEq (RatFunc S) := + closedPlaceRatFuncConstantsDecidableEq S + exact finiteExtensionClosedPlaceExtensionCount S E r + +omit [Fintype C] [DecidableEq C] [DecidableEq (RatFunc C)] in +/-- Replacing the former explicit `Classical.decEq` choices by the canonical +closed-place choices does not change the exact-constant-extension count. -/ +theorem exactConstantExtensionClosedPlaceExtensionCount_eq_classical_decidableEq + (hExact : algebraicClosure C N = + (⊥ : IntermediateField C N)) (r : ℕ) : + exactConstantExtensionClosedPlaceExtensionCount C S N hExact r = + (by + let E := ExactConstantExtension C N S + letI : Field E := exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc S) E := + ratFuncExactConstantExtensionAlgebra C S N hExact + letI : SMul (RatFunc S) E := Algebra.toSMul + letI : Module (RatFunc S) E := Algebra.toModule + letI : FiniteDimensional (RatFunc S) E := + finiteDimensional_over_extendedRatFunc C S N hExact + letI : Algebra.IsSeparable (RatFunc S) E := + isSeparable_over_extendedRatFunc C S N hExact + letI : DecidableEq S := Classical.decEq S + letI : DecidableEq (RatFunc S) := Classical.decEq (RatFunc S) + exact finiteExtensionClosedPlaceExtensionCount S E r) := by + unfold exactConstantExtensionClosedPlaceExtensionCount + congr 1 + +/-- Noncircular geometric F. K. Schmidt theorem. + +`S/C` is required to have degree equal to the original divisor-degree index. +The sole remaining geometric relation says that the closed-place point count +after this constant extension at level `r` is the original count at level +`d*r`. Indexed rationality of both zeta series, including the extension, is +derived internally. -/ +theorem finiteExtensionDivisorDegreeIndex_eq_one_of_exactConstantExtension_closedPlaceCount + (hExact : algebraicClosure C N = + (⊥ : IntermediateField C N)) + (hdegree : Module.finrank C S = + finiteExtensionDivisorDegreeIndex C N) + (hcount : ∀ r, + exactConstantExtensionClosedPlaceExtensionCount C S N hExact r = + finiteExtensionClosedPlaceExtensionCount C N + (finiteExtensionDivisorDegreeIndex C N * r)) : + finiteExtensionDivisorDegreeIndex C N = 1 := by + let E := ExactConstantExtension C N S + let d := finiteExtensionDivisorDegreeIndex C N + let : Field E := exactConstantExtensionField C N S hExact + let : Algebra (RatFunc S) E := + ratFuncExactConstantExtensionAlgebra C S N hExact + let : SMul (RatFunc S) E := Algebra.toSMul + let : Module (RatFunc S) E := Algebra.toModule + let : FiniteDimensional (RatFunc S) E := + finiteDimensional_over_extendedRatFunc C S N hExact + let : Algebra.IsSeparable (RatFunc S) E := + isSeparable_over_extendedRatFunc C S N hExact + let : DecidableEq S := infinityBridgeDecidableEqConstants S + let : DecidableEq (RatFunc S) := + closedPlaceRatFuncConstantsDecidableEq S + let extendedConstantAlgebra : Algebra S E := + RingHom.toAlgebra ((algebraMap (RatFunc S) E).comp + (algebraMap S (RatFunc S))) + let tensorConstantAlgebra : Algebra S E := + Algebra.TensorProduct.leftAlgebra + have hconstantMap (s : S) : + (@algebraMap S E _ _ extendedConstantAlgebra) s = + (@algebraMap S E _ _ tensorConstantAlgebra) s := by + exact (ratFuncToExactConstantExtension C S N hExact).commutes s + have hAlgebraicTransfer (z : E) + (hz : @IsAlgebraic S E _ _ extendedConstantAlgebra z) : + @IsAlgebraic S E _ _ tensorConstantAlgebra z := by + rcases hz with ⟨p, hp, hpz⟩ + refine ⟨p, hp, ?_⟩ + have hmapEq : + (@algebraMap S E _ _ extendedConstantAlgebra) = + (@algebraMap S E _ _ tensorConstantAlgebra) := by + ext s + exact hconstantMap s + change Polynomial.eval₂ + (@algebraMap S E _ _ extendedConstantAlgebra) z p = 0 at hpz + change Polynomial.eval₂ + (@algebraMap S E _ _ tensorConstantAlgebra) z p = 0 + rw [← hmapEq] + exact hpz + have hTensorRange (z : E) + (hz : @IsAlgebraic S E _ _ tensorConstantAlgebra z) : + z ∈ Set.range (@algebraMap S E _ _ tensorConstantAlgebra) := by + let : Algebra S E := tensorConstantAlgebra + have hTensorExact : algebraicClosure S E = + (⊥ : IntermediateField S E) := + exactConstantExtension_algebraicClosure_eq_bot C N S hExact + have hzClosure : z ∈ algebraicClosure S E := + mem_algebraicClosure_iff.mpr hz + have hzBot : z ∈ (⊥ : IntermediateField S E) := by + rw [← hTensorExact] + exact hzClosure + exact hzBot + let : Algebra S E := extendedConstantAlgebra + have hExtendedExact : algebraicClosure S E = + (⊥ : IntermediateField S E) := by + apply eq_bot_iff.mpr + intro z hz + have hzExtended : @IsAlgebraic S E _ _ extendedConstantAlgebra z := + mem_algebraicClosure_iff.mp hz + obtain ⟨s, hs⟩ := hTensorRange z + (hAlgebraicTransfer z hzExtended) + exact ⟨s, (hconstantMap s).trans hs⟩ + obtain ⟨P, _, hPone, hPindexed⟩ := + exists_finiteExtensionClosedPlaceZeta_indexed_rational_nonvanishing_of_constants + C N hExact + obtain ⟨extendedP, _, hExtendedIndexed⟩ := + exists_finiteExtensionClosedPlaceZeta_indexed_rational_of_constants + S E hExtendedExact + have hcard : Nat.card S = Nat.card C ^ d := by + rw [Module.natCard_eq_pow_finrank (K := C) (V := S), hdegree] + have hExtensionIdentity : HasFormalDegreeExtensionZetaIdentity + (formalPointCountZeta + (finiteExtensionClosedPlaceExtensionCount C N)) + (formalPointCountZeta + (finiteExtensionClosedPlaceExtensionCount S E)) d := by + apply finiteExtensionClosedPlaceZeta_hasDegreeExtensionIdentity C N + intro r + rw [← hcount r] + rfl + apply degreeIndex_eq_one_of_two_indexed_rationalForms_and_degreeExtension + (formalPointCountZeta + (finiteExtensionClosedPlaceExtensionCount C N)) + (formalPointCountZeta + (finiteExtensionClosedPlaceExtensionCount S E)) + (Nat.card C) d (finiteExtensionDivisorDegreeIndex S E) + P extendedP + · rw [← Fintype.card_eq_nat_card] + exact Fintype.one_lt_card + · exact finiteExtensionDivisorDegreeIndex_pos C N + · exact finiteExtensionDivisorDegreeIndex_pos S E + · exact hPone + · exact hPindexed + · simpa only [hcard] using hExtendedIndexed + · exact hExtensionIdentity + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionZetaDegreeIndexOneAutomatic.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionZetaDegreeIndexOneAutomatic.lean new file mode 100644 index 0000000000..ba8077fc88 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionZetaDegreeIndexOneAutomatic.lean @@ -0,0 +1,101 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.ConstantExtensionClosedPlaceSplittingFormula +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionZetaDegreeIndexOneFromAllCounts +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionStandardZetaRationality + +/-! +# Automatic divisor-degree index one + +The exact constant-extension splitting formula supplies the sole geometric +hypothesis of the noncircular F. K. Schmidt argument. Consequently a finite +separable function field with exact constants has divisor-degree index one. +-/ + +@[expose] public section + +open scoped Polynomial + +namespace BGS.HasseWeil + +noncomputable section + +variable (C N : Type*) [Field C] [Fintype C] + [DecidableEq C] [DecidableEq (RatFunc C)] + [Field N] [Algebra (RatFunc C) N] + [FiniteDimensional (RatFunc C) N] + [Algebra.IsSeparable (RatFunc C) N] + +local instance automaticIndexOneBaseConstantAlgebra : Algebra C N := + bridgeBaseConstantAlgebra C N + +local instance automaticIndexOneBaseConstantTower : + IsScalarTower C (RatFunc C) N := + IsScalarTower.of_algebraMap_eq' rfl + +/-- F. K. Schmidt's divisor-index-one theorem, with the constant-extension +closed-place identity discharged internally. -/ +theorem finiteExtensionDivisorDegreeIndex_eq_one_of_exactConstants + (hExact : algebraicClosure C N = + (⊥ : IntermediateField C N)) : + finiteExtensionDivisorDegreeIndex C N = 1 := by + apply + finiteExtensionDivisorDegreeIndex_eq_one_of_all_exactConstantExtension_closedPlaceCount + C N hExact + intro S _ _ _ _ _ level + rw [exactConstantExtensionClosedPlaceExtensionCount_eq_classical_decidableEq] + have hcount := exactConstantExtensionClosedPlaceExtensionCount_eq + C S N hExact level + convert hcount using 1 <;> congr 1 + +/-- Exact constants now give the standard curve zeta form without a separate +divisor-index hypothesis. -/ +theorem exists_finiteExtensionClosedPlaceZeta_rational_with_genus_degree_bound_of_exactConstants + (hExact : algebraicClosure C N = + (⊥ : IntermediateField C N)) : + ∃ P : Polynomial ℂ, + P.coeff 0 = 1 ∧ + P.eval 1 ≠ 0 ∧ + P.natDegree < 2 * FunctionField.genus C N + 2 ∧ + HasCurveZetaRationalForm + (formalPointCountZeta + (finiteExtensionClosedPlaceExtensionCount C N)) + (Nat.card C) P := by + exact exists_finiteExtensionClosedPlaceZeta_rational_with_genus_degree_bound + C N hExact + (finiteExtensionDivisorDegreeIndex_eq_one_of_exactConstants + C N hExact) + +/-- Exact constants and an intrinsic genus budget give the standard zeta +trace package with no remaining degree-index premise. -/ +theorem exists_finiteExtensionClosedPlaceZeta_trace_with_degree_budget_of_exactConstants + (budget : ℕ) + (hExact : algebraicClosure C N = + (⊥ : IntermediateField C N)) + (hgenus : FunctionField.genus C N ≤ budget) : + ∃ P : Polynomial ℂ, + P.coeff 0 = 1 ∧ + P.eval 1 ≠ 0 ∧ + P.natDegree ≤ 2 * budget + 1 ∧ + HasCurveZetaRationalForm + (formalPointCountZeta + (finiteExtensionClosedPlaceExtensionCount C N)) + (Nat.card C) P ∧ + HasZetaNumeratorPointCountFormula + (Nat.card C) + (finiteExtensionClosedPlaceExtensionCount C N) P := by + exact exists_finiteExtensionClosedPlaceZeta_trace_with_degree_budget + C N budget hExact + (finiteExtensionDivisorDegreeIndex_eq_one_of_exactConstants + C N hExact) + hgenus + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionZetaDegreeIndexOneFromAllCounts.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionZetaDegreeIndexOneFromAllCounts.lean new file mode 100644 index 0000000000..5620ef8361 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionZetaDegreeIndexOneFromAllCounts.lean @@ -0,0 +1,73 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionZetaDegreeIndexOne +public import Mathlib.FieldTheory.Finite.Extension + +/-! +# Choosing the constant extension of divisor-index degree + +The geometric F. K. Schmidt composition in +`FiniteExtensionZetaDegreeIndexOne` accepts a finite constant extension whose +degree is the divisor-degree index. Finite-field theory supplies such an +extension in every positive degree. This file isolates that final choice: +if the closed-place splitting identity is available for every finite Galois +constant extension, then the divisor-degree index is one. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +noncomputable section + +open BGS.CorvajaZannier + +variable (C N : Type*) [Field C] [Fintype C] [DecidableEq C] + [DecidableEq (RatFunc C)] + [Field N] [Algebra (RatFunc C) N] + [FiniteDimensional (RatFunc C) N] + [Algebra.IsSeparable (RatFunc C) N] + +local instance selectedExtensionBaseConstantAlgebra : Algebra C N := + RingHom.toAlgebra ((algebraMap (RatFunc C) N).comp + (algebraMap C (RatFunc C))) + +local instance selectedExtensionBaseConstantTower : + IsScalarTower C (RatFunc C) N := + IsScalarTower.of_algebraMap_eq' rfl + +/-- It suffices to prove the exact constant-extension closed-place identity +uniformly for finite Galois extensions of the constant field. The required +extension of degree equal to the divisor-degree index is the standard finite +field extension `FiniteField.Extension`. -/ +theorem finiteExtensionDivisorDegreeIndex_eq_one_of_all_exactConstantExtension_closedPlaceCount + (hExact : algebraicClosure C N = (⊥ : IntermediateField C N)) + (hcount : ∀ (S : Type) [Field S] [Fintype S] [Algebra C S] + [FiniteDimensional C S] [IsGalois C S], ∀ r, + exactConstantExtensionClosedPlaceExtensionCount C S N hExact r = + finiteExtensionClosedPlaceExtensionCount C N + (Module.finrank C S * r)) : + finiteExtensionDivisorDegreeIndex C N = 1 := by + let d := finiteExtensionDivisorDegreeIndex C N + have hd : 0 < d := finiteExtensionDivisorDegreeIndex_pos C N + let p := ringChar C + let : Fact p.Prime := ⟨CharP.char_is_prime C p⟩ + let : NeZero d := ⟨hd.ne'⟩ + let : Fintype (FiniteField.Extension C p d) := + Fintype.ofFinite (FiniteField.Extension C p d) + apply finiteExtensionDivisorDegreeIndex_eq_one_of_exactConstantExtension_closedPlaceCount + C (FiniteField.Extension C p d) N hExact + · simpa [d] using FiniteField.finrank_extension C p d + · intro r + simpa [d, FiniteField.finrank_extension] using + hcount (FiniteField.Extension C p d) r + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionZetaNumeratorNoncancellation.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionZetaNumeratorNoncancellation.lean new file mode 100644 index 0000000000..b3b5f48fc0 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionZetaNumeratorNoncancellation.lean @@ -0,0 +1,389 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionIndexedZetaRationality +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionZetaSimplePole +public import Mathlib.Algebra.Polynomial.Expand +public import Mathlib.RingTheory.PowerSeries.Expand + +/-! +# Noncancellation of the indexed zeta numerator + +The strict divisor-count growth across one degree-index step detects the +uncancelled factor `1 - T^d` in the indexed zeta denominator. This file +proves the formal coefficient statement and then specializes it to the +finite-extension effective-divisor series. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +noncomputable section + +open scoped Polynomial PowerSeries + +/-- The partial sum of the coefficients of +`Z(T) (1 - T) (1 - q T)` is the boundary difference +`Z_{n+1} - q Z_n`. -/ +theorem sum_range_coeff_mul_curveZetaDenominator + (Z : PowerSeries ℂ) (q n : ℕ) : + (∑ k ∈ Finset.range (n + 2), + PowerSeries.coeff k (Z * curveZetaDenominator q)) = + PowerSeries.coeff (n + 1) Z - + (q : ℂ) * PowerSeries.coeff n Z := by + induction n with + | zero => + rw [show 0 + 2 = 2 by omega] + simp only [Finset.sum_range_succ, Finset.sum_range_zero, zero_add] + have hcoeffOne : + PowerSeries.coeff 1 (curveZetaDenominator q) = + -((q : ℂ) + 1) := by + rw [curveZetaDenominator, PowerSeries.coeff_one_mul] + simp [linearPowerSeriesFactor] + rw [PowerSeries.coeff_zero_eq_constantCoeff, map_mul, + PowerSeries.coeff_one_mul, hcoeffOne] + simp [curveZetaDenominator, linearPowerSeriesFactor] + ring + | succ n ih => + rw [show n + 1 + 2 = (n + 2) + 1 by omega, + Finset.sum_range_succ, ih, + coeff_mul_curveZetaDenominator_succ_succ] + ring + +/-- For an ordinary curve denominator, every sufficiently late strict +boundary difference forces the numerator to be nonzero at `T = 1`. -/ +theorem curveZetaNumerator_eval_one_ne_zero_of_boundary + (Z : PowerSeries ℂ) (q n : ℕ) (P : Polynomial ℂ) + (hdegree : P.natDegree < n + 2) + (hboundary : (q : ℂ) * PowerSeries.coeff n Z ≠ + PowerSeries.coeff (n + 1) Z) + (hform : HasCurveZetaRationalForm Z q P) : + P.eval 1 ≠ 0 := by + have heval : P.eval 1 = + PowerSeries.coeff (n + 1) Z - + (q : ℂ) * PowerSeries.coeff n Z := by + rw [Polynomial.eval_eq_sum_range' hdegree] + simp only [one_pow, mul_one] + have hcoeff : ∀ k, + P.coeff k = PowerSeries.coeff k + (Z * curveZetaDenominator q) := by + intro k + have h := congrArg (PowerSeries.coeff k) hform + simpa only [Polynomial.coeff_coe] using h.symm + simp_rw [hcoeff] + exact sum_range_coeff_mul_curveZetaDenominator Z q n + rw [heval, sub_ne_zero] + exact hboundary.symm + +/-- Compress a power series supported in degrees divisible by `d`. -/ +def compressPowerSeries (d : ℕ) (Z : PowerSeries ℂ) : PowerSeries ℂ := + PowerSeries.mk fun n => PowerSeries.coeff (d * n) Z + +/-- Expanding the compressed series recovers a series supported on multiples +of `d`. -/ +theorem expand_compressPowerSeries_eq + (Z : PowerSeries ℂ) (d : ℕ) (hd : 0 < d) + (hsupport : ∀ n, ¬ d ∣ n → PowerSeries.coeff n Z = 0) : + PowerSeries.expand d hd.ne' (compressPowerSeries d Z) = Z := by + ext n + rw [PowerSeries.coeff_expand] + split_ifs with hn + · simp only [compressPowerSeries, PowerSeries.coeff_mk] + rw [show d * (n / d) = n by + rw [mul_comm, Nat.div_mul_cancel hn]] + · exact (hsupport n hn).symm + +/-- Power-series expansion sends the ordinary denominator over `q^d` to the +indexed denominator over `q`. -/ +theorem expand_curveZetaDenominator + (q d : ℕ) (hd : 0 < d) : + PowerSeries.expand d hd.ne' (curveZetaDenominator (q ^ d)) = + indexedCurveZetaDenominator q d := by + simp [curveZetaDenominator, indexedCurveZetaDenominator, + linearPowerSeriesFactor] + +/-- Polynomial and power-series expansion commute with the polynomial +coercion. -/ +theorem coe_polynomial_expand + (P : Polynomial ℂ) (d : ℕ) (hd : 0 < d) : + ((Polynomial.expand ℂ d P : Polynomial ℂ) : PowerSeries ℂ) = + PowerSeries.expand d hd.ne' (P : PowerSeries ℂ) := by + ext n + rw [Polynomial.coeff_coe, Polynomial.coeff_expand hd, + PowerSeries.coeff_expand] + split_ifs <;> simp only [Polynomial.coeff_coe] + +/-- Indexed rationality for a series supported on multiples of `d` compresses +to ordinary rationality, with numerator `P.contract d`. -/ +theorem hasCurveZetaRationalForm_compress_of_indexed + (Z : PowerSeries ℂ) (q d : ℕ) (P : Polynomial ℂ) + (hd : 0 < d) + (hsupport : ∀ n, ¬ d ∣ n → PowerSeries.coeff n Z = 0) + (hindexed : HasIndexedCurveZetaRationalForm Z q d P) : + HasCurveZetaRationalForm (compressPowerSeries d Z) (q ^ d) + (P.contract d) := by + let B := compressPowerSeries d Z + have hexpanded : + PowerSeries.expand d hd.ne' + (B * curveZetaDenominator (q ^ d)) = + (P : PowerSeries ℂ) := by + rw [map_mul, expand_compressPowerSeries_eq Z d hd hsupport, + expand_curveZetaDenominator q d hd] + exact hindexed + ext n + have h := congrArg (PowerSeries.coeff (d * n)) hexpanded + simpa only [B, PowerSeries.coeff_expand_mul, + Polynomial.coeff_coe, Polynomial.coeff_contract hd.ne', mul_comm] using h + +/-- Under the same support hypothesis, the indexed polynomial is the +`d`-fold expansion of its contraction. -/ +theorem polynomial_expand_contract_eq_of_indexed + (Z : PowerSeries ℂ) (q d : ℕ) (P : Polynomial ℂ) + (hd : 0 < d) + (hsupport : ∀ n, ¬ d ∣ n → PowerSeries.coeff n Z = 0) + (hindexed : HasIndexedCurveZetaRationalForm Z q d P) : + Polynomial.expand ℂ d (P.contract d) = P := by + apply Polynomial.coe_injective ℂ + rw [coe_polynomial_expand (P.contract d) d hd] + let B := compressPowerSeries d Z + have hform := hasCurveZetaRationalForm_compress_of_indexed + Z q d P hd hsupport hindexed + calc + PowerSeries.expand d hd.ne' ((P.contract d : Polynomial ℂ) : + PowerSeries ℂ) = + PowerSeries.expand d hd.ne' + (B * curveZetaDenominator (q ^ d)) := by rw [hform] + _ = Z * indexedCurveZetaDenominator q d := by + rw [map_mul, expand_compressPowerSeries_eq Z d hd hsupport, + expand_curveZetaDenominator q d hd] + _ = (P : PowerSeries ℂ) := hindexed + +/-- A sufficiently late strict growth witness in one admissible degree forces +noncancellation of the indexed numerator at `T = 1`. + +The bound `P.natDegree < n + 2*d` is the exact condition needed after +compressing degrees by `d`; the admissibility condition `d ∣ n` identifies +the boundary coefficients with consecutive compressed coefficients. -/ +theorem indexedCurveZetaNumerator_eval_one_ne_zero_of_growth + (Z : PowerSeries ℂ) (A : ℕ → ℕ) (q d n : ℕ) + (P : Polynomial ℂ) + (hd : 0 < d) + (hcoeff : ∀ m, PowerSeries.coeff m Z = (A m : ℂ)) + (hsupport : ∀ m, ¬ d ∣ m → A m = 0) + (hn : d ∣ n) + (hdegree : P.natDegree < n + 2 * d) + (hgrowth : q ^ d * A n < A (n + d)) + (hindexed : HasIndexedCurveZetaRationalForm Z q d P) : + P.eval 1 ≠ 0 := by + let B := compressPowerSeries d Z + let R := P.contract d + have hZsupport : ∀ m, ¬ d ∣ m → PowerSeries.coeff m Z = 0 := by + intro m hm + rw [hcoeff, hsupport m hm] + norm_num + have hform : HasCurveZetaRationalForm B (q ^ d) R := by + exact hasCurveZetaRationalForm_compress_of_indexed + Z q d P hd hZsupport hindexed + have hPexpand : Polynomial.expand ℂ d R = P := by + exact polynomial_expand_contract_eq_of_indexed + Z q d P hd hZsupport hindexed + obtain ⟨k, hk⟩ := hn + have hnEq : n = d * k := by omega + have hdegreeR : R.natDegree < k + 2 := by + have hdegreeExpand : + (Polynomial.expand ℂ d R).natDegree < (k + 2) * d := by + rw [hPexpand] + calc + P.natDegree < n + 2 * d := hdegree + _ = (k + 2) * d := by rw [hnEq]; ring + rw [Polynomial.natDegree_expand] at hdegreeExpand + exact (Nat.mul_lt_mul_right hd).mp hdegreeExpand + have hboundary : ((q ^ d : ℕ) : ℂ) * PowerSeries.coeff k B ≠ + PowerSeries.coeff (k + 1) B := by + intro heq + have hcoeffBoundary : ((q ^ d : ℕ) : ℂ) * (A n : ℂ) = + (A (n + d) : ℂ) := by + simpa only [B, compressPowerSeries, PowerSeries.coeff_mk, + hcoeff, hnEq, Nat.mul_add, Nat.mul_one] using heq + have hNat : q ^ d * A n = A (n + d) := by + exact_mod_cast hcoeffBoundary + exact (Nat.ne_of_lt hgrowth) hNat + have hRone : R.eval 1 ≠ 0 := + curveZetaNumerator_eval_one_ne_zero_of_boundary + B (q ^ d) k R hdegreeR hboundary hform + have heval : P.eval 1 = R.eval 1 := by + rw [← hPexpand, Polynomial.expand_eval] + simp + rwa [heval] + +/-- The coefficient-cast effective-divisor series inherits indexed numerator +noncancellation from any sufficiently late admissible strict-growth witness. -/ +theorem effectiveDivisorCountSeries_indexedNumerator_eval_one_ne_zero_of_growth + (A : ℕ → ℕ) (q d n : ℕ) (P : Polynomial ℂ) + (hd : 0 < d) + (hsupport : ∀ m, ¬ d ∣ m → A m = 0) + (hn : d ∣ n) + (hdegree : P.natDegree < n + 2 * d) + (hgrowth : q ^ d * A n < A (n + d)) + (hindexed : HasIndexedCurveZetaRationalForm + (effectiveDivisorCountSeries A) q d P) : + P.eval 1 ≠ 0 := by + apply indexedCurveZetaNumerator_eval_one_ne_zero_of_growth + (effectiveDivisorCountSeries A) A q d n P hd + · intro m + simp [effectiveDivisorCountSeries] + · exact hsupport + · exact hn + · exact hdegree + · exact hgrowth + · exact hindexed + +open BGS.CorvajaZannier + +variable (K : Type*) [Field K] [Fintype K] [DecidableEq K] + [DecidableEq (RatFunc K)] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +local instance numeratorNoncancellationConstantAlgebra : Algebra K L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K (RatFunc K))) + +local instance numeratorNoncancellationConstantTower : + IsScalarTower K (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + +/-- The finite-extension effective-divisor series is supported precisely in +degrees admissible for the divisor-degree index. -/ +theorem finiteExtensionEffectiveDivisorCount_eq_zero_of_not_dvd_index + (n : ℕ) + (hn : ¬ finiteExtensionDivisorDegreeIndex K L ∣ n) : + finiteExtensionEffectiveDivisorCount K L n = 0 := by + rw [finiteExtensionEffectiveDivisorCount] + apply Fintype.card_eq_zero_iff.mpr + refine ⟨fun D => + (not_exists_finiteExtensionDivisor_degree_eq_of_not_dvd K L n hn) ?_⟩ + refine ⟨finiteExtensionEffectiveDivisorToDivisor K L D.1, ?_⟩ + rw [← finiteExtensionEffectiveDivisorDegree_cast K L D.1, D.2] + +/-- Strict growth witnesses supplied by uniform Riemann--Roch can be chosen +beyond any prescribed lower degree and remain divisible by the canonical +divisor-degree index. -/ +theorem exists_finiteExtensionEffectiveDivisorCount_pow_mul_lt_add_index_ge + (genus threshold lowerBound : ℕ) + (hconstants : algebraicClosure K L = + (⊥ : IntermediateField K L)) + (hRiemann : HasFiniteExtensionUniformEventualRiemannFormula + K L genus threshold) : + ∃ n, lowerBound ≤ n ∧ threshold ≤ n ∧ + finiteExtensionDivisorDegreeIndex K L ∣ n ∧ + Nat.card K ^ finiteExtensionDivisorDegreeIndex K L * + finiteExtensionEffectiveDivisorCount K L n < + finiteExtensionEffectiveDivisorCount K L + (n + finiteExtensionDivisorDegreeIndex K L) := by + let d := finiteExtensionDivisorDegreeIndex K L + let m := lowerBound + threshold + let n := m * d + have hd : 0 < d := finiteExtensionDivisorDegreeIndex_pos K L + have hlower : lowerBound ≤ n := by + dsimp only [n, m] + nlinarith + have hthreshold : threshold ≤ n := by + dsimp only [n, m] + nlinarith + refine ⟨n, hlower, hthreshold, ?_, ?_⟩ + · dsimp only [n, d] + exact dvd_mul_left _ _ + · apply + finiteExtensionEffectiveDivisorCount_pow_mul_lt_add_index_of_uniformRiemann + K L genus threshold n hconstants hRiemann hthreshold + exact ⟨by simpa [n, d] using + finiteExtensionDivisorClassOfDegreeIndexMul K L m⟩ + +/-- Uniform Riemann--Roch forces noncancellation for every indexed rational +form of the finite-extension effective-divisor series. -/ +theorem finiteExtensionEffectiveDivisorZeta_indexedNumerator_eval_one_ne_zero_of_uniformRiemann + (genus threshold : ℕ) + (hconstants : algebraicClosure K L = + (⊥ : IntermediateField K L)) + (hRiemann : HasFiniteExtensionUniformEventualRiemannFormula + K L genus threshold) + (P : Polynomial ℂ) + (hindexed : HasIndexedCurveZetaRationalForm + (effectiveDivisorCountSeries + (finiteExtensionEffectiveDivisorCount K L)) + (Nat.card K) (finiteExtensionDivisorDegreeIndex K L) P) : + P.eval 1 ≠ 0 := by + obtain ⟨n, hnDegree, _, hnDvd, hgrowth⟩ := + exists_finiteExtensionEffectiveDivisorCount_pow_mul_lt_add_index_ge + K L genus threshold (P.natDegree + 1) hconstants hRiemann + apply + effectiveDivisorCountSeries_indexedNumerator_eval_one_ne_zero_of_growth + (finiteExtensionEffectiveDivisorCount K L) (Nat.card K) + (finiteExtensionDivisorDegreeIndex K L) n P + · exact finiteExtensionDivisorDegreeIndex_pos K L + · intro m hm + exact finiteExtensionEffectiveDivisorCount_eq_zero_of_not_dvd_index + K L m hm + · exact hnDvd + · have hd := finiteExtensionDivisorDegreeIndex_pos K L + omega + · exact hgrowth + · exact hindexed + +/-- Uniform Riemann--Roch also forces noncancellation for every indexed +rational form of the exhaustive closed-place point-count zeta series. -/ +theorem finiteExtensionClosedPlaceZeta_indexedNumerator_eval_one_ne_zero_of_uniformRiemann + (genus threshold : ℕ) + (hconstants : algebraicClosure K L = + (⊥ : IntermediateField K L)) + (hRiemann : HasFiniteExtensionUniformEventualRiemannFormula + K L genus threshold) + (P : Polynomial ℂ) + (hindexed : HasIndexedCurveZetaRationalForm + (formalPointCountZeta + (finiteExtensionClosedPlaceExtensionCount K L)) + (Nat.card K) (finiteExtensionDivisorDegreeIndex K L) P) : + P.eval 1 ≠ 0 := by + apply + finiteExtensionEffectiveDivisorZeta_indexedNumerator_eval_one_ne_zero_of_uniformRiemann + K L genus threshold hconstants hRiemann P + rw [effectiveDivisorCountSeries_eq_formalPointCountZeta + (finiteExtensionEffectiveDivisorCount K L) + (finiteExtensionClosedPlaceExtensionCount K L) + (finiteExtensionEffectiveDivisorCount_zero K L) + (finiteExtensionEffectiveDivisorPointCountRecurrence K L)] + exact hindexed + +/-- The finite-extension closed-place zeta series has an indexed rational +form whose numerator is normalized and does not vanish at `T = 1`. -/ +theorem exists_finiteExtensionClosedPlaceZeta_indexed_rational_nonvanishing + (genus threshold : ℕ) + (hconstants : algebraicClosure K L = + (⊥ : IntermediateField K L)) + (hRiemann : HasFiniteExtensionUniformEventualRiemannFormula + K L genus threshold) : + ∃ P : Polynomial ℂ, + P.coeff 0 = 1 ∧ P.eval 1 ≠ 0 ∧ + HasIndexedCurveZetaRationalForm + (formalPointCountZeta + (finiteExtensionClosedPlaceExtensionCount K L)) + (Nat.card K) (finiteExtensionDivisorDegreeIndex K L) P := by + obtain ⟨P, hPzero, hPform⟩ := + exists_finiteExtensionClosedPlaceZeta_indexed_rational + K L genus threshold hconstants hRiemann + refine ⟨P, hPzero, ?_, hPform⟩ + exact + finiteExtensionClosedPlaceZeta_indexedNumerator_eval_one_ne_zero_of_uniformRiemann + K L genus threshold hconstants hRiemann P hPform + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionZetaSimplePole.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionZetaSimplePole.lean new file mode 100644 index 0000000000..870f17d0e6 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteExtensionZetaSimplePole.lean @@ -0,0 +1,162 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionDivisorClassRecurrence + +/-! +# A discrete simple-pole witness for the divisor zeta series + +The eventual Riemann--Roch class formula shows that, in every sufficiently +large admissible degree, advancing by the divisor-degree index produces more +effective divisors than multiplication by the corresponding power of the +constant-field cardinality. This is the coefficient-level noncancellation +behind the simple pole at `T = 1`. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +noncomputable section + +open BGS.CorvajaZannier +open scoped Polynomial + +variable (K : Type*) [Field K] [Fintype K] [DecidableEq K] + [DecidableEq (RatFunc K)] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +local instance simplePoleConstantAlgebra : Algebra K L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K (RatFunc K))) + +local instance simplePoleConstantTower : IsScalarTower K (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + +private theorem geomSum_add' (q a b : ℕ) : + (∑ i ∈ Finset.range (a + b), q ^ i) = + (∑ i ∈ Finset.range a, q ^ i) + + q ^ a * ∑ i ∈ Finset.range b, q ^ i := by + rw [Finset.sum_range_add, Finset.mul_sum] + apply congrArg₂ (· + ·) rfl + apply Finset.sum_congr rfl + intro i _ + rw [pow_add] + +/-- Multiples of the canonical index divisor give actual divisor classes in +all integer degrees that are nonnegative multiples of the index. -/ +def finiteExtensionDivisorClassOfDegreeIndexMul (m : ℕ) : + FiniteExtensionDivisorClassOfDegree K L + ((m * finiteExtensionDivisorDegreeIndex K L : ℕ) : ℤ) := by + let D := m • finiteExtensionDivisorIndexRepresentative K L + refine ⟨finiteExtensionDivisorClassMap K L D, ?_⟩ + rw [finiteExtensionDivisorClassDegree_mk] + change finiteExtensionDivisorDegreeHom K L D = _ + rw [map_nsmul] + change m • finiteExtensionDivisorDegree K L + (finiteExtensionDivisorIndexRepresentative K L) = _ + rw [finiteExtensionDivisorIndexRepresentative_degree] + norm_num [D] + +/-- In an admissible large degree, the effective-divisor coefficient grows +strictly more than the geometric `q^d` multiple when the degree is advanced +by the divisor-degree index `d`. -/ +theorem finiteExtensionEffectiveDivisorCount_pow_mul_lt_add_index_of_uniformRiemann + (genus threshold n : ℕ) + (hconstants : algebraicClosure K L = ⊥) + (hRiemann : HasFiniteExtensionUniformEventualRiemannFormula + K L genus threshold) + (hn : threshold ≤ n) + (hclass : Nonempty + (FiniteExtensionDivisorClassOfDegree K L (n : ℤ))) : + Nat.card K ^ finiteExtensionDivisorDegreeIndex K L * + finiteExtensionEffectiveDivisorCount K L n < + finiteExtensionEffectiveDivisorCount K L + (n + finiteExtensionDivisorDegreeIndex K L) := by + let d := finiteExtensionDivisorDegreeIndex K L + let q := Nat.card K + let h := Nat.card (FiniteExtensionDivisorClassOfDegree K L (n : ℤ)) + let ell := n + 1 - genus + have hd : 0 < d := finiteExtensionDivisorDegreeIndex_pos K L + have hn1 : threshold ≤ n + d := by omega + have hgenus : genus ≤ n := hRiemann.1.trans hn + let : Finite (FiniteExtensionDivisorClassOfDegree K L (n : ℤ)) := + finiteExtensionDivisorClassOfDegree_finite_of_uniformRiemann + K L genus threshold n hRiemann hn + let : Nonempty (FiniteExtensionDivisorClassOfDegree K L (n : ℤ)) := + hclass + have hh : 0 < h := by + exact Nat.card_pos + have hsum : 0 < ∑ i ∈ Finset.range d, q ^ i := by + have hle : q ^ 0 ≤ ∑ i ∈ Finset.range d, q ^ i := by + apply Finset.single_le_sum + · intro i _ + exact Nat.zero_le _ + · exact Finset.mem_range.mpr hd + simpa using lt_of_lt_of_le (by simp : 0 < q ^ 0) hle + have hcount0 := + finiteExtensionEffectiveDivisorCount_eq_classCount_mul_geomSum_of_uniformRiemann + K L genus threshold n hconstants hRiemann hn + have hcount1 := + finiteExtensionEffectiveDivisorCount_eq_classCount_mul_geomSum_of_uniformRiemann + K L genus threshold (n + d) hconstants hRiemann hn1 + have hclasses : + Nat.card (FiniteExtensionDivisorClassOfDegree K L ((n + d : ℕ) : ℤ)) = + h := by + rw [← finiteExtensionDivisorClassOfDegree_natCard_add_index K L n] + have hell : n + d + 1 - genus = d + ell := by + dsimp only [ell] + omega + have hformula : + finiteExtensionEffectiveDivisorCount K L (n + d) = + q ^ d * finiteExtensionEffectiveDivisorCount K L n + + h * ∑ i ∈ Finset.range d, q ^ i := by + rw [hcount0, hcount1] + change + Nat.card (FiniteExtensionDivisorClassOfDegree K L + ((n + d : ℕ) : ℤ)) * + (∑ i ∈ Finset.range (n + d + 1 - genus), q ^ i) = + q ^ d * + (h * ∑ i ∈ Finset.range (n + 1 - genus), q ^ i) + + h * ∑ i ∈ Finset.range d, q ^ i + rw [hclasses, hell, geomSum_add' q d ell] + dsimp only [ell] + ring + rw [hformula] + exact Nat.lt_add_of_pos_right (Nat.mul_pos hh hsum) + +/-- There is always a sufficiently large admissible coefficient witnessing +the strict simple-pole growth. -/ +theorem exists_finiteExtensionEffectiveDivisorCount_pow_mul_lt_add_index + (genus threshold : ℕ) + (hconstants : algebraicClosure K L = ⊥) + (hRiemann : HasFiniteExtensionUniformEventualRiemannFormula + K L genus threshold) : + ∃ n, threshold ≤ n ∧ + Nat.card K ^ finiteExtensionDivisorDegreeIndex K L * + finiteExtensionEffectiveDivisorCount K L n < + finiteExtensionEffectiveDivisorCount K L + (n + finiteExtensionDivisorDegreeIndex K L) := by + let d := finiteExtensionDivisorDegreeIndex K L + let n := threshold * d + have hd : 0 < d := finiteExtensionDivisorDegreeIndex_pos K L + have hn : threshold ≤ n := by + dsimp only [n] + nlinarith + refine ⟨n, hn, ?_⟩ + apply + finiteExtensionEffectiveDivisorCount_pow_mul_lt_add_index_of_uniformRiemann + K L genus threshold n hconstants hRiemann hn + dsimp only [n, d] + exact ⟨finiteExtensionDivisorClassOfDegreeIndexMul K L threshold⟩ + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteFieldCompositum.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteFieldCompositum.lean new file mode 100644 index 0000000000..7e4ae19434 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteFieldCompositum.lean @@ -0,0 +1,155 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteFieldSubfield + +/-! +# Composita of finite fields + +Suppose two finite extensions `S / C` and `K / C` are embedded in a common +finite field `T` and generate `T`. Their degrees determine the compositum: + +`[T : C] = lcm([S : C], [K : C])`. + +The relative form is + +`[T : S] = [K : C] / gcd([S : C], [K : C])`. + +Generation is expressed by surjectivity of the canonical tensor-product map. +This formulation is designed to apply directly to residue fields after a +constant extension. +-/ + +@[expose] public section + +open scoped TensorProduct + +namespace BGS.HasseWeil + +noncomputable section + +/-- A finite field generated by two embedded finite subfields has degree the +least common multiple of their degrees over the common finite field. -/ +theorem finiteField_finrank_eq_lcm_of_tensorLift_surjective + (C S K T : Type*) + [Field C] [Field S] [Field K] [Field T] + [Algebra C S] [Algebra C K] [Algebra C T] + [Finite C] [Finite S] [Finite K] [Finite T] + (f : S →ₐ[C] T) (g : K →ₐ[C] T) + (hfg : ∀ s k, Commute (f s) (g k)) + (hsurj : Function.Surjective (Algebra.TensorProduct.lift f g hfg)) : + Module.finrank C T = + Nat.lcm (Module.finrank C S) (Module.finrank C K) := by + let : Fintype C := Fintype.ofFinite C + let : Fintype S := Fintype.ofFinite S + let : Fintype K := Fintype.ofFinite K + let : Fintype T := Fintype.ofFinite T + let m := Module.finrank C S + let n := Module.finrank C K + let l := Nat.lcm m n + let q := Fintype.card C + have hm : m ∣ Module.finrank C T := + FiniteField.nonempty_algHom_iff_finrank_dvd.mp ⟨f⟩ + have hn : n ∣ Module.finrank C T := + FiniteField.nonempty_algHom_iff_finrank_dvd.mp ⟨g⟩ + have hl_dvd : l ∣ Module.finrank C T := + Nat.lcm_dvd_iff.mpr ⟨hm, hn⟩ + have hm_l : m ∣ l := Nat.dvd_lcm_left m n + have hn_l : n ∣ l := Nat.dvd_lcm_right m n + have hS (s : S) : s ^ (q ^ l) = s := by + obtain ⟨a, ha⟩ := hm_l + rw [ha, pow_mul, ← Module.card_eq_pow_finrank] + exact FiniteField.pow_card_pow a s + have hK (k : K) : k ^ (q ^ l) = k := by + obtain ⟨a, ha⟩ := hn_l + rw [ha, pow_mul, ← Module.card_eq_pow_finrank] + exact FiniteField.pow_card_pow a k + let φ := FiniteField.frobeniusAlgHom C T ^ l + have hφ (x : T) : φ x = x ^ (q ^ l) := by + simp [φ, q, AlgHom.coe_pow, FiniteField.coe_frobeniusAlgHom, + pow_iterate] + have hTensor (y : S ⊗[C] K) : + φ (Algebra.TensorProduct.lift f g hfg y) = + Algebra.TensorProduct.lift f g hfg y := by + induction y using TensorProduct.inductionOn with + | tmul s k => + rw [Algebra.TensorProduct.lift_tmul, map_mul, hφ, hφ] + have hs : (f s) ^ (q ^ l) = f s := by + rw [← map_pow, hS] + have hk : (g k) ^ (q ^ l) = g k := by + rw [← map_pow, hK] + rw [hs, hk] + | add x y hx hy => + rw [map_add, map_add, hx, hy] + have hpow (x : T) : x ^ (q ^ l) = x := by + obtain ⟨y, rfl⟩ := hsurj x + rw [← hφ] + exact hTensor y + have hl0 : l ≠ 0 := + (Nat.lcm_pos Module.finrank_pos Module.finrank_pos).ne' + have hcard : Fintype.card T ≤ q ^ l := by + have hroots := Polynomial.card_le_degree_of_subset_roots + (R := T) (p := Polynomial.X ^ (q ^ l) - Polynomial.X) + (Z := Finset.univ) (fun x _ => by + rw [Polynomial.mem_roots'] + constructor + · exact FiniteField.X_pow_card_pow_sub_X_ne_zero T hl0 + Fintype.one_lt_card + · simp [hpow x]) + rw [FiniteField.X_pow_card_pow_sub_X_natDegree_eq T hl0 + Fintype.one_lt_card] at hroots + exact hroots + have hle : Module.finrank C T ≤ l := by + rw [← Nat.pow_le_pow_iff_right (a := q) Fintype.one_lt_card] + rw [← Module.card_eq_pow_finrank (K := C) (V := T)] + exact hcard + exact Nat.le_antisymm hle (Nat.le_of_dvd + (Module.finrank_pos (R := C) (M := T)) hl_dvd) + +/-- Relative-degree form of the finite-field compositum formula. -/ +theorem finiteField_finrank_over_left_eq_div_gcd_of_tensorLift_surjective + (C S K T : Type*) + [Field C] [Field S] [Field K] [Field T] + [Algebra C S] [Algebra C K] [Algebra C T] + [Finite C] [Finite S] [Finite K] [Finite T] + [Algebra S T] [IsScalarTower C S T] + (g : K →ₐ[C] T) + (hsurj : Function.Surjective (Algebra.TensorProduct.lift + (IsScalarTower.toAlgHom C S T) g + (fun _ _ => Commute.all _ _))) : + Module.finrank S T = + Module.finrank C K / + Nat.gcd (Module.finrank C S) (Module.finrank C K) := by + let m := Module.finrank C S + let n := Module.finrank C K + let d := Nat.gcd m n + let l := Nat.lcm m n + let r := Module.finrank S T + have htotal : Module.finrank C T = l := + finiteField_finrank_eq_lcm_of_tensorLift_surjective + C S K T (IsScalarTower.toAlgHom C S T) g + (fun _ _ => Commute.all _ _) hsurj + have hmr : m * r = l := by + exact (Module.finrank_mul_finrank C S T).trans htotal + have hdr : d * r = n := by + apply Nat.mul_left_cancel + (Module.finrank_pos (R := C) (M := S)) + calc + m * (d * r) = d * (m * r) := by ac_rfl + _ = d * l := by rw [hmr] + _ = m * n := Nat.gcd_mul_lcm m n + have hdpos : 0 < d := Nat.gcd_pos_of_pos_left n + (Module.finrank_pos (R := C) (M := S)) + change r = n / d + symm + apply Nat.div_eq_of_eq_mul_left hdpos + simpa [mul_comm] using hdr.symm + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteFieldConstantExtensionNormalization.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteFieldConstantExtensionNormalization.lean new file mode 100644 index 0000000000..52c25e6ddc --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteFieldConstantExtensionNormalization.lean @@ -0,0 +1,195 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteFieldPolynomialNormalization +public import LeanPool.MarkoffModP.BGS.HasseWeil.PolynomialTensorCancel + +/-! +# Normalization in a finite constant extension + +Let `N` be a `C[X]`-algebra and let `S / C` be a finite extension of finite +fields. Combining smooth base change for integral closure with explicit +polynomial tensor cancellation gives + +`S ⊗[C] integralClosure C[X] N ≃ integralClosure S[X] (S ⊗[C] N)`. + +The normalization comparison is first kept over `S[X]`, so it transports +contractions of height-one primes to the polynomial base. Its restriction +to `S` is retained for residue-field dimension calculations. The values of +both equivalences on pure tensors are recorded explicitly. +-/ + +@[expose] public section + +open scoped Polynomial TensorProduct + +namespace BGS.HasseWeil + +noncomputable section + +variable (C S N : Type*) [Field C] [Field S] [Algebra C S] + [CommRing N] [Algebra C[X] N] + +local instance normalizationBaseConstantAlgebra : Algebra C N := + RingHom.toAlgebra ((algebraMap C[X] N).comp (algebraMap C C[X])) + +local instance normalizationBaseConstantPolynomialTower : + IsScalarTower C C[X] N := + IsScalarTower.of_algebraMap_eq' rfl + +local instance normalizationCoefficientPolynomialAlgebra : + Algebra C[X] S[X] := + Polynomial.algebra C S + +/-- The polynomial algebra structure on the constant-extended ambient ring. +It sends `X` to `1 ⊗ algebraMap C[X] N X`. This public name lets downstream +function-field constructions install exactly the same algebra structure. -/ +@[reducible] +noncomputable def constantExtensionTensorPolynomialAlgebra : + Algebra S[X] (S ⊗[C] N) := + polynomialTensorCancelTargetPolynomialExtensionAlgebra C S N + +/-- The matching polynomial algebra structure on the constant tensor of the +original normalization. -/ +@[reducible] +noncomputable def constantExtensionNormalizationTensorPolynomialAlgebra : + Algebra S[X] (S ⊗[C] integralClosure C[X] N) := + polynomialTensorCancelTargetPolynomialExtensionAlgebra C S + (integralClosure C[X] N) + +local instance normalizationTargetPolynomialAlgebra : + Algebra S[X] (S ⊗[C] N) := + constantExtensionTensorPolynomialAlgebra C S N + +local instance normalizationSourcePolynomialAlgebra : + Algebra S[X] (S ⊗[C] integralClosure C[X] N) := + constantExtensionNormalizationTensorPolynomialAlgebra C S N + +local instance normalizationTargetConstantAlgebra : Algebra S (S ⊗[C] N) := + Algebra.TensorProduct.leftAlgebra + +local instance normalizationTargetConstantPolynomialTower : + IsScalarTower S S[X] (S ⊗[C] N) := + IsScalarTower.of_algebraMap_eq' (by + apply RingHom.ext + intro s + change s ⊗ₜ[C] (1 : N) = + Polynomial.aeval + (polynomialTensorCancelEvaluationPoint C S N) (Polynomial.C s) + simp) + +local instance normalizationTargetIntegralClosureConstantAlgebra : + Algebra S (integralClosure S[X] (S ⊗[C] N)) := + RingHom.toAlgebra + ((algebraMap S[X] (integralClosure S[X] (S ⊗[C] N))).comp + (algebraMap S S[X])) + +/-- After a finite extension of finite constants, normalization commutes with +constant extension as an equivalence over the polynomial ring `S[X]`. -/ +noncomputable def finiteFieldConstantExtensionIntegralClosurePolynomialAlgEquiv + [Fintype C] [Finite S] : + S ⊗[C] integralClosure C[X] N ≃ₐ[S[X]] + integralClosure S[X] (S ⊗[C] N) := + (polynomialTensorCancelOverCoefficientPolynomial C S + (integralClosure C[X] N)).symm |>.trans + (finiteFieldPolynomialIntegralClosureBaseChangeAlgEquiv C S N) |>.trans + (polynomialTensorCancelOverCoefficientPolynomial C S N).mapIntegralClosure + +/-- The polynomial-algebra normalization equivalence sends a pure tensor to +the corresponding pure tensor in the extended ambient algebra. -/ +@[simp] +theorem finiteFieldConstantExtensionIntegralClosurePolynomialAlgEquiv_tmul + [Fintype C] [Finite S] + (s : S) (a : integralClosure C[X] N) : + (((finiteFieldConstantExtensionIntegralClosurePolynomialAlgEquiv C S N) + (s ⊗ₜ[C] a) : integralClosure S[X] (S ⊗[C] N)) : + S ⊗[C] N) = + s ⊗ₜ[C] (a : N) := by + simp [finiteFieldConstantExtensionIntegralClosurePolynomialAlgEquiv, + finiteFieldPolynomialIntegralClosureBaseChangeAlgEquiv, + polynomialIntegralClosureBaseChangeAlgEquiv, + TensorProduct.toIntegralClosure] + +/-- After a finite extension of finite constants, the normalization is the +constant tensor extension of the original normalization. -/ +noncomputable def finiteFieldConstantExtensionIntegralClosureAlgEquiv + [Fintype C] [Finite S] : + S ⊗[C] integralClosure C[X] N ≃ₐ[S] + integralClosure S[X] (S ⊗[C] N) := by + letI : Algebra S[X] (S[X] ⊗[C[X]] N) := + Algebra.TensorProduct.leftAlgebra + letI : Algebra S (S[X] ⊗[C[X]] integralClosure C[X] N) := + Algebra.TensorProduct.leftAlgebra + let e : S[X] ⊗[C[X]] integralClosure C[X] N ≃+* + integralClosure S[X] (S ⊗[C] N) := + (finiteFieldPolynomialIntegralClosureBaseChangeAlgEquiv C S N).toRingEquiv.trans + (polynomialTensorCancelOverCoefficientPolynomial C S N).mapIntegralClosure.toRingEquiv + exact + { (polynomialTensorCancel C S + (integralClosure C[X] N)).symm.toRingEquiv.trans e with + commutes' := fun s => by + apply Subtype.ext + simp only [AlgEquiv.symm_toRingEquiv, RingEquiv.symm_mk, AlgEquiv.toEquiv_eq_coe, + AlgEquiv.symm_toEquiv_eq_symm, finiteFieldPolynomialIntegralClosureBaseChangeAlgEquiv, + polynomialIntegralClosureBaseChangeAlgEquiv, TensorProduct.toIntegralClosure, + RingEquiv.toEquiv_eq_coe, Algebra.TensorProduct.algebraMap_apply, Algebra.algebraMap_self, + RingHom.id_apply, Equiv.toFun_as_coe, EquivLike.coe_coe, RingEquiv.coe_trans, + RingEquiv.coe_mk, AlgEquiv.coe_ofBijective, Function.comp_apply, + polynomialTensorCancel_symm_tmul, AlgEquiv.coe_mapIntegralClosure, AlgHom.coe_codRestrict, + Algebra.TensorProduct.map_tmul, AlgHom.coe_id, id_eq, Subalgebra.coe_val, + OneMemClass.coe_one, polynomialTensorCancelOverCoefficientPolynomial_apply, + polynomialTensorCancel_tmul, Polynomial.aeval_C, Algebra.TensorProduct.tmul_mul_tmul, + mul_one, e] + change s ⊗ₜ[C] (1 : N) = + algebraMap S[X] (S ⊗[C] N) (Polynomial.C s) + change s ⊗ₜ[C] (1 : N) = + Polynomial.aeval + (polynomialTensorCancelEvaluationPoint C S N) (Polynomial.C s) + simp } + +/-- The normalization equivalence sends a pure tensor to the corresponding +pure tensor in the extended function algebra. -/ +@[simp] +theorem finiteFieldConstantExtensionIntegralClosureAlgEquiv_tmul + [Fintype C] [Finite S] + (s : S) (a : integralClosure C[X] N) : + (((finiteFieldConstantExtensionIntegralClosureAlgEquiv C S N) + (s ⊗ₜ[C] a) : integralClosure S[X] (S ⊗[C] N)) : + S ⊗[C] N) = + s ⊗ₜ[C] (a : N) := by + simp [finiteFieldConstantExtensionIntegralClosureAlgEquiv, + finiteFieldPolynomialIntegralClosureBaseChangeAlgEquiv, + polynomialIntegralClosureBaseChangeAlgEquiv, + TensorProduct.toIntegralClosure] + +/-- The normalization comparison with its constant-algebra structures erased. +This is the stable interface for constructions that only need the underlying +ring map and should not depend on the particular `S`-algebra instances used to +build the comparison. -/ +noncomputable def finiteFieldConstantExtensionIntegralClosureRingEquiv + [Fintype C] [Finite S] : + S ⊗[C] integralClosure C[X] N ≃+* + integralClosure S[X] (S ⊗[C] N) := + (finiteFieldConstantExtensionIntegralClosureAlgEquiv C S N).toRingEquiv + +/-- The instance-free normalization comparison has the expected value on a +pure tensor. -/ +@[simp] +theorem finiteFieldConstantExtensionIntegralClosureRingEquiv_tmul + [Fintype C] [Finite S] + (s : S) (a : integralClosure C[X] N) : + (((finiteFieldConstantExtensionIntegralClosureRingEquiv C S N) + (s ⊗ₜ[C] a) : integralClosure S[X] (S ⊗[C] N)) : + S ⊗[C] N) = + s ⊗ₜ[C] (a : N) := + finiteFieldConstantExtensionIntegralClosureAlgEquiv_tmul C S N s a + +end + + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteFieldConstantExtensionResidue.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteFieldConstantExtensionResidue.lean new file mode 100644 index 0000000000..54a8082ec0 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteFieldConstantExtensionResidue.lean @@ -0,0 +1,294 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.ConstantTensorResidue +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteFieldConstantExtensionNormalization + +/-! +# Residue degrees after finite constant extension + +This file transports the abstract residue-tensor calculation across the +normalization equivalence. If `q` is a maximal ideal of the normalization +after extending finite constants from `C` to `S`, and `p` is its contraction +to the old normalization, then + +`[κ(q) : C] = lcm([S : C], [κ(p) : C])` + +and hence + +`[κ(q) : S] = [κ(p) : C] / gcd([S : C], [κ(p) : C])`. + +In particular, `q` is rational over `S` whenever the downstairs residue +degree divides `[S : C]`. +-/ + +@[expose] public section + +open scoped Polynomial TensorProduct + +namespace BGS.HasseWeil + +noncomputable section + +variable (C S N : Type*) [Field C] [Field S] [Algebra C S] + [Fintype C] [Finite S] + [CommRing N] [Algebra C[X] N] + +local instance constantExtensionResidueBaseConstantAlgebra : Algebra C N := + RingHom.toAlgebra ((algebraMap C[X] N).comp (algebraMap C C[X])) + +local instance constantExtensionResidueBaseConstantPolynomialTower : + IsScalarTower C C[X] N := + IsScalarTower.of_algebraMap_eq' rfl + +local instance constantExtensionResidueCoefficientPolynomialAlgebra : + Algebra C[X] S[X] := + Polynomial.algebra C S + +local instance constantExtensionResidueOldNormalizationConstantAlgebra : + Algebra C (integralClosure C[X] N) := + RingHom.toAlgebra + ((algebraMap C[X] (integralClosure C[X] N)).comp + (algebraMap C C[X])) + +local instance constantExtensionResidueTargetPolynomialAlgebra : + Algebra S[X] (S ⊗[C] N) := + polynomialTensorCancelTargetPolynomialExtensionAlgebra C S N + +local instance constantExtensionResidueTargetConstantAlgebra : + Algebra S (S ⊗[C] N) := + Algebra.TensorProduct.leftAlgebra + +local instance constantExtensionResidueTargetConstantPolynomialTower : + IsScalarTower S S[X] (S ⊗[C] N) := + IsScalarTower.of_algebraMap_eq' (by + apply RingHom.ext + intro s + change s ⊗ₜ[C] (1 : N) = + Polynomial.aeval + (polynomialTensorCancelEvaluationPoint C S N) (Polynomial.C s) + simp) + +local instance constantExtensionResidueTargetNormalizationConstantAlgebra : + Algebra S (integralClosure S[X] (S ⊗[C] N)) := + RingHom.toAlgebra + ((algebraMap S[X] (integralClosure S[X] (S ⊗[C] N))).comp + (algebraMap S S[X])) + +local instance constantExtensionResidueTargetNormalizationBaseAlgebra : + Algebra C (integralClosure S[X] (S ⊗[C] N)) := + RingHom.toAlgebra + ((algebraMap S (integralClosure S[X] (S ⊗[C] N))).comp + (algebraMap C S)) + +local instance constantExtensionResidueTargetNormalizationConstantTower : + IsScalarTower C S (integralClosure S[X] (S ⊗[C] N)) := + IsScalarTower.of_algebraMap_eq' rfl + +/-- Pull a maximal ideal of the base-changed normalization back to the tensor +model of that normalization. -/ +def finiteFieldConstantExtensionTensorIdeal + (q : Ideal (integralClosure S[X] (S ⊗[C] N))) : + Ideal (S ⊗[C] integralClosure C[X] N) := + q.comap + (finiteFieldConstantExtensionIntegralClosureAlgEquiv C S N).toRingHom + +/-- The inclusion of the old normalization into the normalization after +constant extension. -/ +def finiteFieldConstantExtensionIntegralClosureAlgHom : + integralClosure C[X] N →ₐ[C] + integralClosure S[X] (S ⊗[C] N) := + ((finiteFieldConstantExtensionIntegralClosureAlgEquiv C S N).restrictScalars + C).toAlgHom.comp + (Algebra.TensorProduct.includeRight + (R := C) (A := S) (B := integralClosure C[X] N)) + +/-- Ring-homomorphism form of the old-normalization inclusion. -/ +def finiteFieldConstantExtensionIntegralClosureRingHom : + integralClosure C[X] N →+* + integralClosure S[X] (S ⊗[C] N) := + (finiteFieldConstantExtensionIntegralClosureAlgHom C S N).toRingHom + +/-- Contract an upstairs maximal ideal to the old normalization. -/ +def finiteFieldConstantExtensionDownstairsIdeal + (q : Ideal (integralClosure S[X] (S ⊗[C] N))) : + Ideal (integralClosure C[X] N) := + q.comap (finiteFieldConstantExtensionIntegralClosureRingHom C S N) + +@[simp] +theorem finiteFieldConstantExtensionDownstairsIdeal_eq + (q : Ideal (integralClosure S[X] (S ⊗[C] N))) : + finiteFieldConstantExtensionDownstairsIdeal C S N q = + (finiteFieldConstantExtensionTensorIdeal C S N q).comap + (Algebra.TensorProduct.includeRight + (R := C) (A := S) (B := integralClosure C[X] N)).toRingHom := + rfl + +@[simp] +theorem finiteFieldConstantExtensionIntegralClosureRingHom_coe + (a : integralClosure C[X] N) : + (((finiteFieldConstantExtensionIntegralClosureRingHom C S N a : + integralClosure S[X] (S ⊗[C] N)) : S ⊗[C] N)) = + (1 : S) ⊗ₜ[C] (a : N) := by + exact finiteFieldConstantExtensionIntegralClosureAlgEquiv_tmul + C S N 1 a + +local instance finiteFieldConstantExtensionTensorIdeal_isMaximal + (q : Ideal (integralClosure S[X] (S ⊗[C] N))) [q.IsMaximal] : + (finiteFieldConstantExtensionTensorIdeal C S N q).IsMaximal := by + unfold finiteFieldConstantExtensionTensorIdeal + exact Ideal.comap_isMaximal_of_surjective + (finiteFieldConstantExtensionIntegralClosureAlgEquiv C S N).toRingHom + (finiteFieldConstantExtensionIntegralClosureAlgEquiv C S N).surjective + +local instance finiteFieldConstantExtensionDownstairsIdeal_isPrime + (q : Ideal (integralClosure S[X] (S ⊗[C] N))) [q.IsMaximal] : + (finiteFieldConstantExtensionDownstairsIdeal C S N q).IsPrime := by + unfold finiteFieldConstantExtensionDownstairsIdeal + exact Ideal.comap_isPrime + (f := finiteFieldConstantExtensionIntegralClosureRingHom C S N) + (K := q) + +/-- The normalization equivalence induces an `S`-algebra equivalence of the +corresponding residue fields. -/ +def finiteFieldConstantExtensionResidueFieldAlgEquiv + (q : Ideal (integralClosure S[X] (S ⊗[C] N))) [q.IsMaximal] : + (finiteFieldConstantExtensionTensorIdeal C S N q).ResidueField ≃ₐ[S] + q.ResidueField := + Ideal.residueFieldAlgEquiv + (finiteFieldConstantExtensionTensorIdeal C S N q) q + (finiteFieldConstantExtensionIntegralClosureAlgEquiv C S N) rfl + +local instance finiteFieldConstantExtensionTensorResidueFinite + (q : Ideal (integralClosure S[X] (S ⊗[C] N))) [q.IsMaximal] + [Finite q.ResidueField] : + Finite (finiteFieldConstantExtensionTensorIdeal C S N q).ResidueField := + let eS := finiteFieldConstantExtensionResidueFieldAlgEquiv C S N q + Finite.of_injective eS eS.injective + +local instance finiteFieldConstantExtensionDownstairsResidueFinite + (q : Ideal (integralClosure S[X] (S ⊗[C] N))) [q.IsMaximal] + [Finite q.ResidueField] : + Finite + (finiteFieldConstantExtensionDownstairsIdeal C S N q).ResidueField := by + let q₀ := finiteFieldConstantExtensionTensorIdeal C S N q + let p := finiteFieldConstantExtensionDownstairsIdeal C S N q + let fp : p.ResidueField →ₐ[C] q₀.ResidueField := + Ideal.ResidueField.mapₐ p q₀ + (Algebra.TensorProduct.includeRight + (R := C) (A := S) (B := integralClosure C[X] N)) rfl + exact Finite.of_injective fp fp.injective + +/-- The contraction of an upstairs maximal ideal is maximal. The proof uses +the already established embedding of its residue field into the finite +upstairs residue field: the downstairs quotient is therefore a finite domain, +and hence a field. -/ +theorem finiteFieldConstantExtensionDownstairsIdeal_isMaximal + (q : Ideal (integralClosure S[X] (S ⊗[C] N))) [q.IsMaximal] + [Finite q.ResidueField] : + (finiteFieldConstantExtensionDownstairsIdeal C S N q).IsMaximal := by + let p := finiteFieldConstantExtensionDownstairsIdeal C S N q + let : Finite p.ResidueField := by + change Finite + (finiteFieldConstantExtensionDownstairsIdeal C S N q).ResidueField + infer_instance + let : Finite (integralClosure C[X] N ⧸ p) := + Finite.of_injective + (algebraMap (integralClosure C[X] N ⧸ p) p.ResidueField) + p.injective_algebraMap_quotient_residueField + exact (Ideal.Quotient.maximal_ideal_iff_isField_quotient p).mpr + (Finite.isField_of_domain (integralClosure C[X] N ⧸ p)) + +/-- Absolute residue-degree form of the constant-extension compositum +formula. -/ +theorem finiteFieldConstantExtensionResidue_finrank_eq_lcm + (q : Ideal (integralClosure S[X] (S ⊗[C] N))) [q.IsMaximal] + [Finite q.ResidueField] : + Module.finrank C q.ResidueField = + Nat.lcm (Module.finrank C S) + (Module.finrank C + (finiteFieldConstantExtensionDownstairsIdeal C S N q).ResidueField) := by + let q₀ := finiteFieldConstantExtensionTensorIdeal C S N q + let : q₀.IsMaximal := + finiteFieldConstantExtensionTensorIdeal_isMaximal C S N q + let eS := finiteFieldConstantExtensionResidueFieldAlgEquiv C S N q + let p := q₀.comap (Algebra.TensorProduct.includeRight + (R := C) (A := S) (B := integralClosure C[X] N)).toRingHom + let : Finite p.ResidueField := by + change Finite + (finiteFieldConstantExtensionDownstairsIdeal C S N q).ResidueField + infer_instance + have h := constantTensorResidue_finrank_eq_lcm + C (integralClosure C[X] N) S q₀ + change Module.finrank C q.ResidueField = + Nat.lcm (Module.finrank C S) + (Module.finrank C + (q₀.comap (Algebra.TensorProduct.includeRight + (R := C) (A := S) (B := integralClosure C[X] N)).toRingHom).ResidueField) + calc + Module.finrank C q.ResidueField = Module.finrank C q₀.ResidueField := + (eS.restrictScalars C).toLinearEquiv.finrank_eq.symm + _ = _ := h + +/-- Relative residue-degree form of the constant-extension compositum +formula. -/ +theorem finiteFieldConstantExtensionResidue_finrank_over_constants_eq_div_gcd + (q : Ideal (integralClosure S[X] (S ⊗[C] N))) [q.IsMaximal] + [Finite q.ResidueField] : + Module.finrank S q.ResidueField = + Module.finrank C + (finiteFieldConstantExtensionDownstairsIdeal C S N q).ResidueField / + Nat.gcd (Module.finrank C S) + (Module.finrank C + (finiteFieldConstantExtensionDownstairsIdeal C S N q).ResidueField) := by + let m := Module.finrank C S + let n := Module.finrank C + (finiteFieldConstantExtensionDownstairsIdeal C S N q).ResidueField + let d := Nat.gcd m n + let l := Nat.lcm m n + let r := Module.finrank S q.ResidueField + have htotal : Module.finrank C q.ResidueField = l := + finiteFieldConstantExtensionResidue_finrank_eq_lcm C S N q + have hmr : m * r = l := by + exact (Module.finrank_mul_finrank C S q.ResidueField).trans htotal + have hdr : d * r = n := by + apply Nat.mul_left_cancel + (Module.finrank_pos (R := C) (M := S)) + calc + m * (d * r) = d * (m * r) := by ac_rfl + _ = d * l := by rw [hmr] + _ = m * n := Nat.gcd_mul_lcm m n + have hdpos : 0 < d := Nat.gcd_pos_of_pos_left n + (Module.finrank_pos (R := C) (M := S)) + change r = n / d + symm + apply Nat.div_eq_of_eq_mul_left hdpos + simpa [mul_comm] using hdr.symm + +/-- If the downstairs residue degree divides the constant-extension degree, +then the upstairs maximal ideal has residue degree one over the enlarged +constants. -/ +theorem finiteFieldConstantExtensionResidue_finrank_eq_one_of_dvd + (q : Ideal (integralClosure S[X] (S ⊗[C] N))) [q.IsMaximal] + [Finite q.ResidueField] + (hdiv : Module.finrank C + (finiteFieldConstantExtensionDownstairsIdeal C S N q).ResidueField ∣ + Module.finrank C S) : + Module.finrank S q.ResidueField = 1 := by + rw [finiteFieldConstantExtensionResidue_finrank_over_constants_eq_div_gcd + C S N q] + rw [Nat.gcd_eq_right_iff_dvd.mpr hdiv] + exact Nat.div_self + (Module.finrank_pos (R := C) + (M := (finiteFieldConstantExtensionDownstairsIdeal + C S N q).ResidueField)) + +end + + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteFieldDivisibleExtension.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteFieldDivisibleExtension.lean new file mode 100644 index 0000000000..62da75aee4 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteFieldDivisibleExtension.lean @@ -0,0 +1,121 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import Mathlib.FieldTheory.Finite.Extension + +/-! +# Nested canonical finite-field extensions + +If `a ∣ b`, finite-field theory supplies an embedding from the chosen +degree-`a` extension into the chosen degree-`b` extension. This file fixes +one such embedding and records the scalar-tower and degree consequences used +by the constant-extension Hasse--Weil argument. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +noncomputable section + +variable (K : Type*) [Field K] [Fintype K] +variable (p a b : ℕ) [Fact p.Prime] [CharP K p] +variable [NeZero a] [NeZero b] + +/-- A chosen `K`-algebra embedding between canonical finite-field extensions +whose degrees satisfy `a ∣ b`. -/ +noncomputable def finiteFieldExtensionAlgHomOfDvd (h : a ∣ b) : + FiniteField.Extension K p a →ₐ[K] + FiniteField.Extension K p b := + (FiniteField.nonempty_algHom_of_finrank_dvd (F := K) + (K := FiniteField.Extension K p a) + (L := FiniteField.Extension K p b) (by + rw [FiniteField.finrank_extension, FiniteField.finrank_extension] + exact h)).some + +/-- The algebra structure selected by `finiteFieldExtensionAlgHomOfDvd`. -/ +@[reducible] noncomputable def finiteFieldExtensionAlgebraOfDvd + (h : a ∣ b) : + Algebra (FiniteField.Extension K p a) + (FiniteField.Extension K p b) := + (finiteFieldExtensionAlgHomOfDvd K p a b h).toAlgebra + +/-- The selected divisible-degree embedding is compatible with the original +coefficient field. -/ +theorem finiteFieldExtension_isScalarTower_of_dvd (h : a ∣ b) : + letI : Algebra (FiniteField.Extension K p a) + (FiniteField.Extension K p b) := + finiteFieldExtensionAlgebraOfDvd K p a b h + IsScalarTower K (FiniteField.Extension K p a) + (FiniteField.Extension K p b) := by + let : Algebra (FiniteField.Extension K p a) + (FiniteField.Extension K p b) := + finiteFieldExtensionAlgebraOfDvd K p a b h + apply IsScalarTower.of_algebraMap_eq' + ext c + exact (finiteFieldExtensionAlgHomOfDvd K p a b h).commutes c |>.symm + +/-- The relative degree of the chosen nested extension is the quotient of +the two absolute degrees. -/ +theorem finrank_finiteFieldExtension_of_dvd (h : a ∣ b) : + letI : Algebra (FiniteField.Extension K p a) + (FiniteField.Extension K p b) := + finiteFieldExtensionAlgebraOfDvd K p a b h + Module.finrank (FiniteField.Extension K p a) + (FiniteField.Extension K p b) = b / a := by + let E := FiniteField.Extension K p a + let L := FiniteField.Extension K p b + let : Algebra E L := finiteFieldExtensionAlgebraOfDvd K p a b h + let : IsScalarTower K E L := + finiteFieldExtension_isScalarTower_of_dvd K p a b h + let : Module.Finite E L := Module.Finite.of_finite + have hmul : Module.finrank K E * Module.finrank E L = + Module.finrank K L := Module.finrank_mul_finrank K E L + rw [FiniteField.finrank_extension K p a, + FiniteField.finrank_extension K p b] at hmul + apply (Nat.eq_div_iff_mul_eq_left (NeZero.ne a) h).2 + simpa [Nat.mul_comm] using hmul.symm + +/-- The chosen degree-`2a` extension is quadratic over the chosen degree-`a` +subfield. -/ +theorem finrank_double_finiteFieldExtension : + letI : Algebra (FiniteField.Extension K p a) + (FiniteField.Extension K p (2 * a)) := + finiteFieldExtensionAlgebraOfDvd K p a (2 * a) ⟨2, by omega⟩ + Module.finrank (FiniteField.Extension K p a) + (FiniteField.Extension K p (2 * a)) = 2 := by + rw [finrank_finiteFieldExtension_of_dvd K p a (2 * a) ⟨2, by omega⟩] + simpa [Nat.mul_comm] using Nat.mul_div_cancel_left 2 (NeZero.pos a) + +omit [Fintype K] in +/-- Cardinality of the degree-`2a` extension is the square of the +degree-`a` extension's cardinality. -/ +theorem natCard_double_finiteFieldExtension_eq_sq [Finite K] : + Nat.card (FiniteField.Extension K p (2 * a)) = + Nat.card (FiniteField.Extension K p a) ^ 2 := by + rw [FiniteField.natCard_extension K p (2 * a), + FiniteField.natCard_extension K p a] + ring + +omit [Fintype K] in +/-- A positive multiple of the extension degree is already large enough to +dominate that degree. This elementary growth estimate is what makes one +fixed multiple work uniformly in the Stepanov construction. -/ +theorem degree_le_natCard_finiteFieldExtension_mul [Finite K] + (d n : ℕ) [NeZero (d * n)] (hn : 0 < n) : + d ≤ Nat.card (FiniteField.Extension K p (d * n)) := by + rw [FiniteField.natCard_extension K p (d * n)] + have hcard : 1 < Nat.card K := Finite.one_lt_card + have hdPow : d ≤ Nat.card K ^ d := + (Nat.lt_pow_self hcard).le + exact hdPow.trans (Nat.pow_le_pow_right (Nat.card_pos) + (Nat.le_mul_of_pos_right d hn)) + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteFieldInfinityDifferent.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteFieldInfinityDifferent.lean new file mode 100644 index 0000000000..4870cb13ea --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteFieldInfinityDifferent.lean @@ -0,0 +1,347 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.RatFuncInfinityLocalization +public import LeanPool.MarkoffModP.BGS.HasseWeil.ConstantFieldInfinityBase +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteFieldPolynomialDifferent +public import Mathlib.Algebra.Polynomial.Eval.Subring +public import Mathlib.Algebra.Polynomial.GroupRingAction +public import Mathlib.FieldTheory.Galois.Basic + +/-! +# The different of a finite coefficient extension at infinity + +For a finite Galois extension `S / C`, the infinity valuation ring over `S` +is the localization of the reciprocal polynomial ring `S[X]` at the image of +the reciprocal-origin complement from `C[X]`. The key denominator argument +uses the product of all Galois conjugates of a polynomial. + +This localization description transports finiteness and formal +unramifiedness from `C[X] → S[X]`. Consequently the local different of the +coefficient extension at infinity is the unit ideal. +-/ + +@[expose] public section + +open scoped Polynomial TensorProduct nonZeroDivisors + +namespace BGS.HasseWeil + +open BGS.CorvajaZannier + +noncomputable section + +attribute [local instance] FractionRing.liftAlgebra + FractionRing.isScalarTower_liftAlgebra + +variable (C S : Type*) [Field C] [Field S] + [Algebra C S] [FiniteDimensional C S] [IsGalois C S] + +local instance finiteFieldInfinityDifferentDecidableEqC : DecidableEq C := + Classical.decEq C +local instance finiteFieldInfinityDifferentDecidableEqS : DecidableEq S := + Classical.decEq S +local instance finiteFieldInfinityDifferentDecidableEqRatFuncC : + DecidableEq (RatFunc C) := Classical.decEq (RatFunc C) +local instance finiteFieldInfinityDifferentDecidableEqRatFuncS : + DecidableEq (RatFunc S) := Classical.decEq (RatFunc S) + +local instance finiteFieldInfinityDifferentCoefficientPolynomialAlgebra : + Algebra C[X] S[X] := + Polynomial.algebra C S + +local instance finiteFieldInfinityDifferentReciprocalPolynomialAlgebra : + Algebra S[X] (RatFuncInfinityIntegers S) := + ratFuncInfinityReciprocalPolynomialAlgebra S + +local instance finiteFieldInfinityDifferentCoefficientOriginPrime : + (Ideal.span ({Polynomial.X} : Set C[X])).IsPrime := + (Ideal.span_singleton_prime Polynomial.X_ne_zero).mpr Polynomial.prime_X + +local instance finiteFieldInfinityDifferentExtensionOriginPrime : + (Ideal.span ({Polynomial.X} : Set S[X])).IsPrime := + (Ideal.span_singleton_prime Polynomial.X_ne_zero).mpr Polynomial.prime_X + +omit [FiniteDimensional C S] [IsGalois C S] in +private theorem coefficientPrimeCompl_le_reciprocalPrimeCompl : + Algebra.algebraMapSubmonoid S[X] + (Ideal.span ({Polynomial.X} : Set C[X])).primeCompl ≤ + (Ideal.span ({Polynomial.X} : Set S[X])).primeCompl := by + rintro _ ⟨p, hp, rfl⟩ + intro hmap + change p ∉ Ideal.span ({Polynomial.X} : Set C[X]) at hp + apply hp + rw [Ideal.mem_span_singleton, Polynomial.X_dvd_iff] + apply (algebraMap C S).injective + have hzero : + (algebraMap C[X] S[X] p).coeff 0 = 0 := + Polynomial.X_dvd_iff.mp (Ideal.mem_span_singleton.mp hmap) + simpa [Polynomial.algebraMap_def] using hzero + +private theorem exists_coefficient_multiple_of_not_mem_reciprocalOrigin + (p : S[X]) + (hp : p ∉ Ideal.span ({Polynomial.X} : Set S[X])) : + ∃ m : C[X], + m ∉ Ideal.span ({Polynomial.X} : Set C[X]) ∧ + p ∣ algebraMap C[X] S[X] m := by + let G := S ≃ₐ[C] S + let P : S[X] := ∏ g : G, g • p + have hp0 : p.coeff 0 ≠ 0 := by + intro hp0 + apply hp + rw [Ideal.mem_span_singleton, Polynomial.X_dvd_iff] + exact hp0 + have hPfixed (g : G) : g • P = P := by + exact Finset.smul_prod_perm p g + have hcoeffRange (n : ℕ) : + P.coeff n ∈ Set.range (algebraMap C S) := by + rw [IsGalois.mem_range_algebraMap_iff_fixed] + intro g + have hcoeffFixed := + congrArg (fun q : S[X] => q.coeff n) (hPfixed g) + simp only [Polynomial.smul_eq_map, Polynomial.coeff_map] at hcoeffFixed + change g • P.coeff n = P.coeff n at hcoeffFixed + calc + g (P.coeff n) = g • P.coeff n := + (AlgEquiv.smul_def g (P.coeff n)).symm + _ = P.coeff n := hcoeffFixed + have hPrange : + P ∈ (Polynomial.mapRingHom (algebraMap C S)).range := by + rw [Polynomial.mem_map_range] + exact hcoeffRange + obtain ⟨m, hm⟩ := hPrange + have hp_dvd_P : p ∣ P := by + have h := Finset.dvd_prod_of_mem (fun g : G => g • p) + (Finset.mem_univ (1 : G)) + change p ∣ ∏ g : G, g • p + simpa using h + have hP0 : P.coeff 0 ≠ 0 := by + change (∏ g : G, g • p).coeff 0 ≠ 0 + rw [Polynomial.coeff_zero_prod] + exact Finset.prod_ne_zero_iff.mpr fun g _ => by + rw [show (g • p).coeff 0 = g • p.coeff 0 by + simp [Polynomial.smul_eq_map]] + exact (smul_ne_zero_iff_ne g).2 hp0 + have hm0map : algebraMap C S (m.coeff 0) = P.coeff 0 := by + have := congrArg (fun q : S[X] => q.coeff 0) hm + simpa using this + have hm0 : m.coeff 0 ≠ 0 := by + intro hm0 + apply hP0 + rw [← hm0map, hm0, map_zero] + refine ⟨m, ?_, ?_⟩ + · intro hmOrigin + exact hm0 (Polynomial.X_dvd_iff.mp + (Ideal.mem_span_singleton.mp hmOrigin)) + · change p ∣ Polynomial.map (algebraMap C S) m + have hm' : Polynomial.map (algebraMap C S) m = P := hm + rw [hm'] + exact hp_dvd_P + +/-- The infinity valuation ring over `S` is already obtained by localizing +`S[X]` at the image of the reciprocal-origin complement from `C[X]`. -/ +theorem ratFuncInfinityIntegers_isLocalization_coefficientPrimeCompl : + IsLocalization + (Algebra.algebraMapSubmonoid S[X] + (Ideal.span ({Polynomial.X} : Set C[X])).primeCompl) + (RatFuncInfinityIntegers S) := by + let M := Algebra.algebraMapSubmonoid S[X] + (Ideal.span ({Polynomial.X} : Set C[X])).primeCompl + let N := (Ideal.span ({Polynomial.X} : Set S[X])).primeCompl + have hMN : M ≤ N := + coefficientPrimeCompl_le_reciprocalPrimeCompl C S + have hdiv : ∀ p ∈ N, ∃ m ∈ M, p ∣ m := by + intro p hp + obtain ⟨m, hmOrigin, hp_dvd⟩ := + exists_coefficient_multiple_of_not_mem_reciprocalOrigin C S p hp + exact ⟨algebraMap C[X] S[X] m, ⟨m, hmOrigin, rfl⟩, hp_dvd⟩ + exact (IsLocalization.iff_of_le_of_exists_dvd + (M := M) N hMN hdiv).mpr + (ratFuncInfinityIntegers_isLocalization_reciprocal S) + +section Corollaries + +local instance finiteFieldInfinityDifferentBaseReciprocalPolynomialAlgebra : + Algebra C[X] (RatFuncInfinityIntegers C) := + ratFuncInfinityReciprocalPolynomialAlgebra C + +local instance finiteFieldInfinityDifferentCoefficientAlgebra : + Algebra (RatFuncInfinityIntegers C) (RatFuncInfinityIntegers S) := + RingHom.toAlgebra (ratFuncInfinityIntegersRingHom C S) + +local instance (priority := low) + finiteFieldInfinityDifferentBasePolynomialExtensionAlgebra : + Algebra C[X] (RatFuncInfinityIntegers S) := + RingHom.toAlgebra + ((algebraMap S[X] (RatFuncInfinityIntegers S)).comp + (algebraMap C[X] S[X])) + +local instance finiteFieldInfinityDifferentCoefficientPolynomialTower : + IsScalarTower C[X] S[X] (RatFuncInfinityIntegers S) := + IsScalarTower.of_algebraMap_eq' + (RingHom.algebraMap_toAlgebra _) + +omit [FiniteDimensional C S] [IsGalois C S] in +private theorem ratFuncCoefficientAlgHom_reciprocalPolynomialRingHom + (p : C[X]) : + ratFuncCoefficientAlgHom C S + (((reciprocalPolynomialRingHom C p : + RatFuncInfinityIntegers C) : RatFunc C)) = + ((reciprocalPolynomialRingHom S (algebraMap C[X] S[X] p) : + RatFuncInfinityIntegers S) : RatFunc S) := by + rw [reciprocalPolynomialRingHom_coe, + reciprocalPolynomialRingHom_coe] + change (ratFuncCoefficientAlgHom C S).toRingHom + (Polynomial.eval₂ RatFunc.C (1 / RatFunc.X) p) = _ + rw [Polynomial.hom_eval₂] + have hX : ratFuncCoefficientAlgHom C S RatFunc.X = RatFunc.X := by + have h := ratFuncCoefficientAlgHom_algebraMap C S Polynomial.X + simpa using h + have hcoeff : + (ratFuncCoefficientAlgHom C S).toRingHom.comp RatFunc.C = + RatFunc.C.comp (algebraMap C S) := by + ext c + change ratFuncCoefficientAlgHom C S + (algebraMap C (RatFunc C) c) = + algebraMap S (RatFunc S) (algebraMap C S c) + rw [(ratFuncCoefficientAlgHom C S).commutes] + exact IsScalarTower.algebraMap_apply C S (RatFunc S) c + have hrecip : (ratFuncCoefficientAlgHom C S).toRingHom + (1 / RatFunc.X) = 1 / RatFunc.X := by + rw [one_div, map_inv₀] + have hX' : (ratFuncCoefficientAlgHom C S).toRingHom RatFunc.X = + RatFunc.X := hX + simpa [hX'] + rw [hcoeff, hrecip] + change Polynomial.eval₂ (RatFunc.C.comp (algebraMap C S)) + (1 / RatFunc.X) p = + Polynomial.eval₂ RatFunc.C (1 / RatFunc.X) + (Polynomial.map (algebraMap C S) p) + rw [Polynomial.eval₂_map] + +omit [FiniteDimensional C S] [IsGalois C S] in +private theorem reciprocalPolynomialAlgebraMap_commutes (p : C[X]) : + algebraMap (RatFuncInfinityIntegers C) (RatFuncInfinityIntegers S) + (algebraMap C[X] (RatFuncInfinityIntegers C) p) = + algebraMap C[X] (RatFuncInfinityIntegers S) p := by + simp only [RingHom.algebraMap_toAlgebra, RingHom.comp_apply] + apply Subtype.ext + exact ratFuncCoefficientAlgHom_reciprocalPolynomialRingHom C S p + +local instance finiteFieldInfinityDifferentBasePolynomialCoefficientTower : + IsScalarTower C[X] (RatFuncInfinityIntegers C) + (RatFuncInfinityIntegers S) := + IsScalarTower.of_algebraMap_eq fun p => + (reciprocalPolynomialAlgebraMap_commutes C S p).symm + +local instance finiteFieldInfinityDifferentCoefficientPolynomialModuleFinite : + Module.Finite C[X] S[X] := by + let : Module.Finite C[X] (C[X] ⊗[C] S) := + Module.Finite.base_change C C[X] S + exact Module.Finite.equiv + (Algebra.IsPushout.equiv C C[X] S S[X]).toLinearEquiv + +/-- The coefficient extension of infinity valuation rings is finite. -/ +theorem ratFuncInfinityIntegers_coefficient_moduleFinite : + Module.Finite (RatFuncInfinityIntegers C) + (RatFuncInfinityIntegers S) := by + let : IsLocalization + (Ideal.span ({Polynomial.X} : Set C[X])).primeCompl + (RatFuncInfinityIntegers C) := + ratFuncInfinityIntegers_isLocalization_reciprocal C + let : IsLocalization + (Algebra.algebraMapSubmonoid S[X] + (Ideal.span ({Polynomial.X} : Set C[X])).primeCompl) + (RatFuncInfinityIntegers S) := + ratFuncInfinityIntegers_isLocalization_coefficientPrimeCompl C S + exact Module.Finite.of_isLocalization C[X] S[X] + (Ideal.span ({Polynomial.X} : Set C[X])).primeCompl + +local instance finiteFieldInfinityDifferentCoefficientModuleFinite : + Module.Finite (RatFuncInfinityIntegers C) + (RatFuncInfinityIntegers S) := + ratFuncInfinityIntegers_coefficient_moduleFinite C S + +local instance finiteFieldInfinityDifferentCoefficientIsTorsionFree : + Module.IsTorsionFree (RatFuncInfinityIntegers C) + (RatFuncInfinityIntegers S) := by + rw [Module.isTorsionFree_iff_algebraMap_injective] + exact ratFuncInfinityIntegersRingHom_injective C S + +/-- The coefficient extension of infinity valuation rings is formally +unramified. -/ +theorem ratFuncInfinityIntegers_coefficient_formallyUnramified : + Algebra.FormallyUnramified (RatFuncInfinityIntegers C) + (RatFuncInfinityIntegers S) := by + let : IsLocalization + (Ideal.span ({Polynomial.X} : Set C[X])).primeCompl + (RatFuncInfinityIntegers C) := + ratFuncInfinityIntegers_isLocalization_reciprocal C + let : IsLocalization + (Algebra.algebraMapSubmonoid S[X] + (Ideal.span ({Polynomial.X} : Set C[X])).primeCompl) + (RatFuncInfinityIntegers S) := + ratFuncInfinityIntegers_isLocalization_coefficientPrimeCompl C S + let : IsLocalization + (Submonoid.map (algebraMap C[X] S[X]) + (Ideal.span ({Polynomial.X} : Set C[X])).primeCompl) + (RatFuncInfinityIntegers S) := by + simpa only [Algebra.algebraMapSubmonoid] using + ratFuncInfinityIntegers_isLocalization_coefficientPrimeCompl C S + let : Algebra.FormallyUnramified C[X] S[X] := + coefficientPolynomial_formallyUnramified C S + exact Algebra.FormallyUnramified.localization_map + (R := C[X]) (S := S[X]) + (Rₘ := RatFuncInfinityIntegers C) + (Sₘ := RatFuncInfinityIntegers S) + (Ideal.span ({Polynomial.X} : Set C[X])).primeCompl + +/-- A finite Galois coefficient extension has unit different at the infinity +valuation ring. -/ +theorem ratFuncInfinityIntegers_coefficient_differentIdeal_eq_top : + differentIdeal (RatFuncInfinityIntegers C) + (RatFuncInfinityIntegers S) = ⊤ := by + let A := RatFuncInfinityIntegers C + let B := RatFuncInfinityIntegers S + let : Algebra.FormallyUnramified A B := + ratFuncInfinityIntegers_coefficient_formallyUnramified C S + let : IsIntegralClosure B A (FractionRing B) := + IsIntegralClosure.of_isIntegrallyClosed B A (FractionRing B) + let : Algebra.IsAlgebraic (FractionRing A) (FractionRing B) := + isAlgebraic_of_isFractionRing A B .. + let : IsLocalization + (Algebra.algebraMapSubmonoid B A⁰) (FractionRing B) := + IsIntegralClosure.isLocalization A (FractionRing A) + (FractionRing B) B + let : FiniteDimensional (FractionRing A) (FractionRing B) := + Module.Finite.of_isLocalization A B A⁰ + let : Algebra.FormallyUnramified B (FractionRing B) := + Algebra.FormallyUnramified.of_isLocalization B⁰ + let : Algebra.FormallyUnramified A (FractionRing B) := + Algebra.FormallyUnramified.comp A B (FractionRing B) + let : Algebra.FormallyUnramified (FractionRing A) (FractionRing B) := + Algebra.FormallyUnramified.localization_base A⁰ + let : Algebra.IsSeparable (FractionRing A) (FractionRing B) := + Algebra.FormallyUnramified.isSeparable + (FractionRing A) (FractionRing B) + by_contra htop + obtain ⟨P, hPmax, hdiffP⟩ := + Ideal.exists_le_maximal (differentIdeal A B) htop + let : P.IsPrime := hPmax.isPrime + have hunram : Algebra.IsUnramifiedAt A P := by + exact Algebra.formallyUnramified_iff_forall.mp + (show Algebra.FormallyUnramified A B from inferInstance) + ⟨P, hPmax.isPrime⟩ + exact (not_dvd_differentIdeal_iff.mpr hunram) + (Ideal.dvd_iff_le.mpr hdiffP) + +end Corollaries + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteFieldPolynomialDifferent.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteFieldPolynomialDifferent.lean new file mode 100644 index 0000000000..eb4e30325a --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteFieldPolynomialDifferent.lean @@ -0,0 +1,140 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import Mathlib.RingTheory.DedekindDomain.Different +public import Mathlib.RingTheory.PolynomialAlgebra +public import Mathlib.RingTheory.Unramified.Field + +/-! +# The different of a separable coefficient extension + +Let `S / C` be a finite separable extension of fields. For the coefficientwise +algebra structure on `S[X]` over `C[X]`, the different ideal is the unit ideal. + +The proof first identifies `S[X]` with the polynomial base change +`C[X] ⊗[C] S`. Formal unramifiedness therefore follows from separability of +`S / C`. After localizing both polynomial rings, the induced extension of +rational function fields is finite and formally unramified, hence separable. +The local characterization of the Dedekind different then excludes every +maximal ideal from the support of the different. + +The final corollary specializes this to arbitrary extensions of finite fields; +their finiteness and separability are supplied by typeclass inference. +-/ + +@[expose] public section + +open scoped Polynomial TensorProduct + +namespace BGS.HasseWeil + +noncomputable section + +variable (C S : Type*) [Field C] [Field S] + [Algebra C S] [FiniteDimensional C S] [Algebra.IsSeparable C S] + +local instance differentCoefficientPolynomialAlgebra : Algebra C[X] S[X] := + Polynomial.algebra C S + +local instance differentCoefficientPolynomialTower : IsScalarTower C C[X] S[X] := + IsScalarTower.of_algebraMap_eq' (by + ext c + simp) + +local instance differentConstantPolynomialTower : IsScalarTower C S S[X] := + IsScalarTower.of_algebraMap_eq' (by + ext c + simp) + +attribute [local instance] FractionRing.liftAlgebra + +local instance differentCoefficientPolynomialModuleFinite : Module.Finite C[X] S[X] := by + let : Module.Finite C[X] (C[X] ⊗[C] S) := + Module.Finite.base_change C C[X] S + exact Module.Finite.equiv + (Algebra.IsPushout.equiv C C[X] S S[X]).toLinearEquiv + +local instance differentCoefficientPolynomialFormallyUnramified : + Algebra.FormallyUnramified C[X] S[X] := by + let : Algebra.FormallyUnramified C S := + Algebra.FormallyUnramified.of_isSeparable C S + let : Algebra.FormallyUnramified C[X] (C[X] ⊗[C] S) := + Algebra.FormallyUnramified.base_change C[X] + exact Algebra.FormallyUnramified.of_equiv + (Algebra.IsPushout.equiv C C[X] S S[X]) + +local instance differentCoefficientRationalFunctionAlgebraic : + Algebra.IsAlgebraic (FractionRing C[X]) (FractionRing S[X]) := + isAlgebraic_of_isFractionRing C[X] S[X] .. + +local instance differentCoefficientPolynomialIntegralClosure : + IsIntegralClosure S[X] C[X] (FractionRing S[X]) := + IsIntegralClosure.of_isIntegrallyClosed S[X] C[X] (FractionRing S[X]) + +local instance differentCoefficientRationalFunctionLocalization : + IsLocalization + (Algebra.algebraMapSubmonoid S[X] (nonZeroDivisors C[X])) + (FractionRing S[X]) := + IsIntegralClosure.isLocalization C[X] (FractionRing C[X]) + (FractionRing S[X]) S[X] + +local instance differentCoefficientRationalFunctionFiniteDimensional : + FiniteDimensional (FractionRing C[X]) (FractionRing S[X]) := + Module.Finite.of_isLocalization C[X] S[X] (nonZeroDivisors C[X]) + +local instance differentCoefficientRationalFunctionFormallyUnramified : + Algebra.FormallyUnramified + (FractionRing C[X]) (FractionRing S[X]) := by + let : Algebra.FormallyUnramified C[X] (FractionRing S[X]) := inferInstance + exact Algebra.FormallyUnramified.localization_base (nonZeroDivisors C[X]) + +local instance differentCoefficientRationalFunctionSeparable : + Algebra.IsSeparable (FractionRing C[X]) (FractionRing S[X]) := + Algebra.FormallyUnramified.isSeparable + (FractionRing C[X]) (FractionRing S[X]) + +omit [FiniteDimensional C S] in +/-- A finite separable extension of coefficient fields induces a formally +unramified extension of polynomial rings. -/ +theorem coefficientPolynomial_formallyUnramified : + Algebra.FormallyUnramified C[X] S[X] := + inferInstance + +/-- A finite separable extension of coefficient fields induces a separable +extension of the corresponding rational function fields. -/ +theorem coefficientRationalFunction_isSeparable : + Algebra.IsSeparable (FractionRing C[X]) (FractionRing S[X]) := + inferInstance + +/-- For a finite separable coefficient-field extension, the different of the +coefficientwise polynomial-ring extension is the unit ideal. -/ +theorem coefficientPolynomial_differentIdeal_eq_top : + differentIdeal C[X] S[X] = ⊤ := by + by_contra htop + obtain ⟨P, hPmax, hdiffP⟩ := + Ideal.exists_le_maximal (differentIdeal C[X] S[X]) htop + let : P.IsPrime := hPmax.isPrime + have hunram : Algebra.IsUnramifiedAt C[X] P := by + exact + Algebra.formallyUnramified_iff_forall.mp + (show Algebra.FormallyUnramified C[X] S[X] from inferInstance) + ⟨P, hPmax.isPrime⟩ + exact + (not_dvd_differentIdeal_iff.mpr hunram) + (Ideal.dvd_iff_le.mpr hdiffP) + +/-- In particular, every extension of finite fields has unit different after +coefficientwise extension of polynomial rings. -/ +theorem finiteFieldPolynomial_differentIdeal_eq_top + (k F : Type*) [Field k] [Fintype k] [Field F] [Finite F] [Algebra k F] : + differentIdeal k[X] F[X] = ⊤ := + coefficientPolynomial_differentIdeal_eq_top k F + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteFieldPolynomialNormalization.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteFieldPolynomialNormalization.lean new file mode 100644 index 0000000000..d609215679 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteFieldPolynomialNormalization.lean @@ -0,0 +1,68 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import Mathlib.RingTheory.PolynomialAlgebra +public import Mathlib.RingTheory.Smooth.Field +public import Mathlib.RingTheory.Smooth.IntegralClosure + +/-! +# Normalization after finite constant extension + +Smooth base change commutes with integral closure. Applied to the coefficient +extension `C[X] → S[X]`, this identifies the base change of the normalization +of a `C[X]`-algebra with the normalization of its polynomial base change. + +The first declaration records the general smooth statement. The second +specializes it to finite fields: finiteness makes `S / C` finite type, while +the perfectness of `C` supplies formal smoothness. +-/ + +@[expose] public section + +open scoped Polynomial TensorProduct + +namespace BGS.HasseWeil + +noncomputable section + +variable (C S N : Type*) [Field C] [Field S] [Algebra C S] + [CommRing N] [Algebra C[X] N] + +local instance finiteFieldNormalizationPolynomialCoefficientAlgebra : + Algebra C[X] S[X] := + Polynomial.algebra C S + +/-- Smooth coefficient extension commutes with normalization over the +polynomial base. -/ +noncomputable def polynomialIntegralClosureBaseChangeAlgEquiv + [Algebra.Smooth C S] : + S[X] ⊗[C[X]] integralClosure C[X] N ≃ₐ[S[X]] + integralClosure S[X] (S[X] ⊗[C[X]] N) := by + letI : Algebra.Smooth C[X] (C[X] ⊗[C] S) := inferInstance + letI : Algebra.Smooth C[X] S[X] := + Algebra.Smooth.of_equiv (Algebra.IsPushout.equiv C C[X] S S[X]) + exact AlgEquiv.ofBijective + (TensorProduct.toIntegralClosure C[X] S[X] N) + TensorProduct.toIntegralClosure_bijective_of_smooth + +/-- For an extension of finite fields, coefficient extension commutes with +normalization over the polynomial base. -/ +noncomputable def finiteFieldPolynomialIntegralClosureBaseChangeAlgEquiv + [Fintype C] [Finite S] : + S[X] ⊗[C[X]] integralClosure C[X] N ≃ₐ[S[X]] + integralClosure S[X] (S[X] ⊗[C[X]] N) := by + letI : Algebra.Smooth C S := + { formallySmooth := inferInstance + finitePresentation := + Algebra.FinitePresentation.of_finiteType.mp inferInstance } + exact polynomialIntegralClosureBaseChangeAlgEquiv C S N + +end + + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteFieldSubfield.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteFieldSubfield.lean new file mode 100644 index 0000000000..6cf98b3f44 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteFieldSubfield.lean @@ -0,0 +1,91 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import Mathlib.FieldTheory.Finite.GaloisField + +/-! +# Finite subfields in a common overfield + +Finite fields have a unique subfield of each possible degree inside a fixed +finite overfield. The form needed for constant extensions is an inclusion of +the ranges of two specified embeddings: if the degree of `A / C` divides the +degree of `B / C`, then the image of `A` lies in the image of `B`. + +The proof is elementary and keeps the embeddings explicit. The image of `B` +already supplies `#B` roots of `X ^ (#B) - X`; the polynomial has at most +`#B` roots. Divisibility of extension degrees then shows that every element +of the image of `A` is another root of the same polynomial. +-/ + +@[expose] public section + +open Polynomial + +namespace BGS.HasseWeil + +noncomputable section + +/-- In a common finite overfield, the image of a finite field of degree `d` +is contained in the image of one of degree `n` whenever `d ∣ n` over the +same finite base field. -/ +theorem finiteField_fieldRange_le_of_finrank_dvd + {C A B Ω : Type*} + [Field C] [Field A] [Field B] [Field Ω] + [Algebra C A] [Algebra C B] [Algebra C Ω] + [Finite C] [Finite A] [Finite B] [Finite Ω] + (f : A →ₐ[C] Ω) (g : B →ₐ[C] Ω) + (hdiv : Module.finrank C A ∣ Module.finrank C B) : + f.fieldRange ≤ g.fieldRange := by + let : Fintype C := Fintype.ofFinite C + let : Fintype A := Fintype.ofFinite A + let : Fintype B := Fintype.ofFinite B + let : Fintype Ω := Fintype.ofFinite Ω + classical + let p : Ω[X] := X ^ Fintype.card B - X + have hcardB : 1 < Fintype.card B := Fintype.one_lt_card + have hp0 : p ≠ 0 := FiniteField.X_pow_card_sub_X_ne_zero Ω hcardB + have himageRoots : Finset.univ.image g ⊆ p.roots.toFinset := by + intro y hy + rw [Finset.mem_image] at hy + obtain ⟨x, -, rfl⟩ := hy + rw [Multiset.mem_toFinset, Polynomial.mem_roots hp0, IsRoot.def] + simp only [p, eval_sub, eval_pow, eval_X] + rw [← map_pow, FiniteField.pow_card, sub_self] + have himageCard : (Finset.univ.image g).card = Fintype.card B := by + rw [Finset.card_image_iff.mpr] + · exact Finset.card_univ + · exact g.injective.injOn + have hrootsCard : p.roots.toFinset.card ≤ Fintype.card B := by + calc + p.roots.toFinset.card ≤ p.roots.card := Multiset.toFinset_card_le _ + _ ≤ p.natDegree := Polynomial.card_roots' p + _ = Fintype.card B := + FiniteField.X_pow_card_sub_X_natDegree_eq Ω hcardB + have hrootsEq : p.roots.toFinset = Finset.univ.image g := by + exact (Finset.eq_of_subset_of_card_le himageRoots + (by simpa [himageCard] using hrootsCard)).symm + intro y hy + rw [AlgHom.mem_fieldRange] at hy ⊢ + obtain ⟨x, rfl⟩ := hy + obtain ⟨k, hk⟩ := hdiv + have hroot : f x ∈ p.roots := by + rw [Polynomial.mem_roots hp0, IsRoot.def] + simp only [p, eval_sub, eval_pow, eval_X] + rw [Module.card_eq_pow_finrank (K := C) (V := B), hk, pow_mul, + ← Module.card_eq_pow_finrank (K := C) (V := A)] + rw [← map_pow, FiniteField.pow_card_pow, sub_self] + have hmem : f x ∈ Finset.univ.image g := by + rw [← hrootsEq] + exact Multiset.mem_toFinset.mpr hroot + rw [Finset.mem_image] at hmem + obtain ⟨z, -, hz⟩ := hmem + exact ⟨z, hz⟩ + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteLinearIndependenceBound.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteLinearIndependenceBound.lean new file mode 100644 index 0000000000..82ec1a5a2d --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/FiniteLinearIndependenceBound.lean @@ -0,0 +1,66 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import Mathlib.LinearAlgebra.Basis.VectorSpace +public import Mathlib.LinearAlgebra.Dimension.StrongRankCondition +public import Mathlib.LinearAlgebra.FreeModule.Finite.Basic + +/-! +# Finite-dimensionality from uniform finite independence bounds + +Čech obstruction spaces are naturally presented as quotients of an +infinite-dimensional function field. It is often easier to bound each +finite linearly independent family than to exhibit one global finite set of +generators. The lemma below packages the standard basis argument converting +that uniform bound into finite-dimensionality and a `finrank` estimate. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +noncomputable section + +universe u v + +/-- If every finite linearly independent family in a vector space has at +most `g` elements, then the whole space is finite-dimensional of dimension +at most `g`. -/ +theorem moduleFinite_and_finrank_le_of_finite_linearIndependent_card_le + {K : Type u} {V : Type v} + [DivisionRing K] [AddCommGroup V] [Module K V] + (g : ℕ) + (hbound : ∀ (ι : Type v) [Fintype ι] (v : ι → V), + LinearIndependent K v → Fintype.card ι ≤ g) : + Module.Finite K V ∧ Module.finrank K V ≤ g := by + classical + let b := Module.Basis.ofVectorSpace K V + let ι := Module.Basis.ofVectorSpaceIndex K V + have hιFinite : Finite ι := by + rw [← not_infinite_iff_finite] + intro hιInfinite + let : Infinite ι := hιInfinite + obtain ⟨s, hs⟩ := Infinite.exists_subset_card_eq ι (g + 1) + let v : s → V := fun i ↦ b i.1 + have hv : LinearIndependent K v := + b.linearIndependent.comp _ Subtype.val_injective + have hle := hbound s v hv + have hcard : Fintype.card s = g + 1 := by + simpa only [Fintype.card_coe] using hs + omega + let : Finite ι := hιFinite + let : Fintype ι := Fintype.ofFinite ι + let hfinite : Module.Finite K V := Module.Finite.of_basis b + let : Module.Finite K V := hfinite + refine ⟨hfinite, ?_⟩ + rw [Module.finrank_eq_card_basis b] + exact hbound ι b b.linearIndependent + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/FinitePlaceApproximation.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/FinitePlaceApproximation.lean new file mode 100644 index 0000000000..ce8202564d --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/FinitePlaceApproximation.lean @@ -0,0 +1,281 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import Mathlib.RingTheory.DedekindDomain.AdicValuation +public import Mathlib.RingTheory.DedekindDomain.Ideal.Lemmas +public import Mathlib.RingTheory.Localization.Integer +public import Mathlib.Tactic + +/-! +# Weak approximation at finite places + +This file proves the finite-place weak-approximation theorem needed for +function-field Riemann--Roch constructions. For finitely many distinct +height-one prime ideals, one may prescribe an element of the fraction field +to arbitrary positive order. The resulting global fraction is integral at +every other height-one prime. + +The proof is elementary Dedekind-domain algebra. First clear all prescribed +fractions by one denominator. The numerator is then chosen by the Chinese +remainder theorem. At a selected prime the modulus contains both the desired +precision and the multiplicity of the common denominator. At every other +prime dividing the denominator, a zero residue cancels the complete +denominator multiplicity. + +Mathlib's multiplicative adic valuation is `exp (-order)`. Thus +`v.valuation L (z - x) ≤ exp (-n)` means that `z - x` has additive order at +least `n`, while `v.valuation L z ≤ 1` means that `z` is regular at `v`. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +open IsDedekindDomain UniqueFactorizationMonoid +open scoped nonZeroDivisors + +noncomputable section + +/-- If the numerator contains every occurrence of a height-one prime in the +denominator, the resulting fraction is integral at that prime. -/ +theorem valuation_div_algebraMap_le_one_of_mem_denominatorPower + {R L : Type*} [CommRing R] [IsDedekindDomain R] + [Field L] [Algebra R L] [IsFractionRing R L] + (v : HeightOneSpectrum R) (numerator denominator : R) + (hdenominator : denominator ≠ 0) + (hnumerator : numerator ∈ + v.asIdeal ^ + (normalizedFactors (Ideal.span ({denominator} : Set R))).count v.asIdeal) : + v.valuation L + (algebraMap R L numerator / algebraMap R L denominator) ≤ 1 := by + classical + let m : ℕ := + (normalizedFactors (Ideal.span ({denominator} : Set R))).count v.asIdeal + have hspan : Ideal.span ({denominator} : Set R) ≠ (⊥ : Ideal R) := by + exact Ideal.span_singleton_eq_bot.not.mpr hdenominator + have hdenominatorValuation : + v.intValuation denominator = WithZero.exp (-(m : ℤ)) := by + rw [v.intValuation_eq_exp_neg_multiplicity hdenominator, + multiplicity_eq_count_normalizedFactors v.irreducible hspan] + simp [m] + have hnumeratorValuation : + v.intValuation numerator ≤ WithZero.exp (-(m : ℤ)) := by + exact (v.intValuation_le_pow_iff_mem numerator m).mpr hnumerator + calc + v.valuation L + (algebraMap R L numerator / algebraMap R L denominator) = + v.valuation L (algebraMap R L numerator) / + v.valuation L (algebraMap R L denominator) := + (v.valuation L).map_div _ _ + _ = v.intValuation numerator / WithZero.exp (-(m : ℤ)) := by + rw [v.valuation_of_algebraMap, v.valuation_of_algebraMap, + hdenominatorValuation] + _ ≤ 1 := + (div_le_one₀ (show 0 < WithZero.exp (-(m : ℤ)) from + WithZero.exp_pos)).mpr hnumeratorValuation + +/-- A congruence modulo the desired prime power plus the denominator +multiplicity gives the corresponding adic approximation bound after division +by the denominator. -/ +theorem valuation_sub_div_algebraMap_le_of_mem_denominatorPrecisionPower + {R L : Type*} [CommRing R] [IsDedekindDomain R] + [Field L] [Algebra R L] [IsFractionRing R L] + (v : HeightOneSpectrum R) (numerator target denominator : R) + (precision : ℕ) (hdenominator : denominator ≠ 0) + (hnumerator : numerator - target ∈ + v.asIdeal ^ + (precision + + (normalizedFactors (Ideal.span ({denominator} : Set R))).count v.asIdeal)) : + v.valuation L + (algebraMap R L numerator / algebraMap R L denominator - + algebraMap R L target / algebraMap R L denominator) ≤ + WithZero.exp (-(precision : ℤ)) := by + classical + let m : ℕ := + (normalizedFactors (Ideal.span ({denominator} : Set R))).count v.asIdeal + have hspan : Ideal.span ({denominator} : Set R) ≠ (⊥ : Ideal R) := by + exact Ideal.span_singleton_eq_bot.not.mpr hdenominator + have hdenominatorValuation : + v.intValuation denominator = WithZero.exp (-(m : ℤ)) := by + rw [v.intValuation_eq_exp_neg_multiplicity hdenominator, + multiplicity_eq_count_normalizedFactors v.irreducible hspan] + simp [m] + have hnumeratorValuation : + v.intValuation (numerator - target) ≤ + WithZero.exp (-((precision + m : ℕ) : ℤ)) := by + exact (v.intValuation_le_pow_iff_mem (numerator - target) + (precision + m)).mpr hnumerator + have hfractionIdentity : + algebraMap R L numerator / algebraMap R L denominator - + algebraMap R L target / algebraMap R L denominator = + algebraMap R L (numerator - target) / algebraMap R L denominator := by + rw [map_sub] + ring + rw [hfractionIdentity] + calc + v.valuation L + (algebraMap R L (numerator - target) / + algebraMap R L denominator) = + v.intValuation (numerator - target) / + WithZero.exp (-(m : ℤ)) := by + rw [(v.valuation L).map_div, v.valuation_of_algebraMap, + v.valuation_of_algebraMap, hdenominatorValuation] + _ ≤ WithZero.exp (-((precision + m : ℕ) : ℤ)) / + WithZero.exp (-(m : ℤ)) := + (div_le_div_iff_of_pos_right + (show 0 < WithZero.exp (-(m : ℤ)) from WithZero.exp_pos)).mpr + hnumeratorValuation + _ = WithZero.exp (-(precision : ℤ)) := by + rw [← WithZero.exp_sub] + congr 1 + push_cast + omega + +/-- Chinese-remainder numerator selection with simultaneous denominator +cancellation. At selected primes the congruence precision is increased by +the denominator multiplicity. Every unselected prime factor of the +denominator divides the chosen numerator to its full multiplicity. -/ +theorem exists_numerator_prescribedPrimePower_and_denominatorSupport + {R : Type*} [CommRing R] [IsDedekindDomain R] + (selected : Finset (Ideal R)) (denominatorIdeal : Ideal R) + (hselectedPrime : ∀ P ∈ selected, Prime P) + (target : selected → R) (precision : selected → ℕ) : + ∃ numerator : R, + (∀ P : selected, + numerator - target P ∈ + (P : Ideal R) ^ + (precision P + + (normalizedFactors denominatorIdeal).count (P : Ideal R))) ∧ + (∀ Q ∈ (normalizedFactors denominatorIdeal).toFinset, + Q ∉ selected → + numerator ∈ Q ^ (normalizedFactors denominatorIdeal).count Q) := by + classical + let support : Finset (Ideal R) := + selected ∪ (normalizedFactors denominatorIdeal).toFinset + let exponent : Ideal R → ℕ := fun Q => + if hQ : Q ∈ selected then + precision ⟨Q, hQ⟩ + (normalizedFactors denominatorIdeal).count Q + else + (normalizedFactors denominatorIdeal).count Q + let residue : support → R := fun Q => + if hQ : (Q : Ideal R) ∈ selected then target ⟨Q, hQ⟩ else 0 + have hsupportPrime : ∀ Q ∈ support, Prime Q := by + intro Q hQ + rcases Finset.mem_union.mp hQ with hQselected | hQdenominator + · exact hselectedPrime Q hQselected + · exact prime_of_normalized_factor Q + (Multiset.mem_toFinset.mp hQdenominator) + obtain ⟨numerator, hnumerator⟩ := + IsDedekindDomain.exists_forall_sub_mem_ideal + (s := support) (P := id) exponent hsupportPrime + (by + intro i hi j hj hij + simpa using hij) + residue + refine ⟨numerator, ?_, ?_⟩ + · intro P + have hPsupport : (P : Ideal R) ∈ support := + Finset.mem_union_left _ P.property + have h := hnumerator (P : Ideal R) hPsupport + simpa [residue, exponent, P.property] using h + · intro Q hQdenominator hQselected + have hQsupport : Q ∈ support := + Finset.mem_union_right _ hQdenominator + have h := hnumerator Q hQsupport + simpa [residue, exponent, hQselected] using h + +/-- Finite-place weak approximation in a Dedekind fraction field. + +The selected ideals must be prime. The function `target` prescribes a local +fraction at each selected ideal, and `precision` prescribes its approximation +order. The returned global fraction has that approximation order at every +selected height-one place and is integral at every unselected height-one +place. -/ +theorem exists_fraction_approximating_at_finitePlaces_regular_elsewhere + {R L : Type*} [CommRing R] [IsDedekindDomain R] + [Field L] [Algebra R L] [IsFractionRing R L] + (selected : Finset (Ideal R)) + (hselectedPrime : ∀ P ∈ selected, Prime P) + (target : Ideal R → L) (precision : Ideal R → ℕ) : + ∃ z : L, + (∀ v : HeightOneSpectrum R, v.asIdeal ∈ selected → + v.valuation L (z - target v.asIdeal) ≤ + WithZero.exp (-(precision v.asIdeal : ℤ))) ∧ + (∀ v : HeightOneSpectrum R, v.asIdeal ∉ selected → + v.valuation L z ≤ 1) := by + classical + let denominator : nonZeroDivisors R := + IsLocalization.commonDenom (nonZeroDivisors R) selected target + let localNumerator : selected → R := + IsLocalization.integerMultiple (nonZeroDivisors R) selected target + obtain ⟨numerator, hselected, hdenominatorSupport⟩ := + exists_numerator_prescribedPrimePower_and_denominatorSupport + selected (Ideal.span ({(denominator : R)} : Set R)) + hselectedPrime localNumerator (fun P => precision (P : Ideal R)) + let z : L := + algebraMap R L numerator / algebraMap R L (denominator : R) + refine ⟨z, ?_, ?_⟩ + · intro v hv + let P : selected := ⟨v.asIdeal, hv⟩ + have hlocal := + valuation_sub_div_algebraMap_le_of_mem_denominatorPrecisionPower + (L := L) v numerator (localNumerator P) (denominator : R) + (precision v.asIdeal) + (nonZeroDivisors.ne_zero denominator.property) + (by simpa [P] using hselected P) + have hmap' : + algebraMap R L (localNumerator P) = + algebraMap R L (denominator : R) * target v.asIdeal := by + change algebraMap R L + (IsLocalization.integerMultiple (nonZeroDivisors R) selected target P) = + algebraMap R L + ((IsLocalization.commonDenom + (nonZeroDivisors R) selected target : nonZeroDivisors R) : R) * + target v.asIdeal + rw [IsLocalization.map_integerMultiple] + simp only [Submonoid.smul_def, Algebra.smul_def] + rfl + have hdenominatorMap : algebraMap R L (denominator : R) ≠ 0 := by + intro hzero + apply nonZeroDivisors.ne_zero denominator.property + apply IsFractionRing.injective R L + rw [map_zero] + exact hzero + have htarget : + algebraMap R L (localNumerator P) / + algebraMap R L (denominator : R) = + target v.asIdeal := by + rw [hmap'] + field_simp + change v.valuation L + (algebraMap R L numerator / algebraMap R L (denominator : R) - + target v.asIdeal) ≤ WithZero.exp (-(precision v.asIdeal : ℤ)) + rw [← htarget] + exact hlocal + · intro v hv + have hnumeratorPower : numerator ∈ + v.asIdeal ^ + (normalizedFactors + (Ideal.span ({(denominator : R)} : Set R))).count v.asIdeal := by + by_cases hfactor : v.asIdeal ∈ + (normalizedFactors + (Ideal.span ({(denominator : R)} : Set R))).toFinset + · exact hdenominatorSupport v.asIdeal hfactor hv + · have hcount : + (normalizedFactors + (Ideal.span ({(denominator : R)} : Set R))).count v.asIdeal = 0 := by + exact Multiset.count_eq_zero.mpr (by simpa only [Multiset.mem_toFinset] using hfactor) + simp [hcount] + simpa [z] using + valuation_div_algebraMap_le_one_of_mem_denominatorPower + (L := L) v numerator (denominator : R) + (nonZeroDivisors.ne_zero denominator.property) hnumeratorPower + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/FinitePlaceFrobeniusFiber.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/FinitePlaceFrobeniusFiber.lean new file mode 100644 index 0000000000..9a26b02ae6 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/FinitePlaceFrobeniusFiber.lean @@ -0,0 +1,244 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionPlaceTower + +/-! +# Local place actions in a Frobenius fiber + +This file supplies the local ideal-theoretic bridge used by the +Frobenius-coset step of the Hasse--Weil argument. + +First, if a maximal ideal has residue degree one over a constant field `S`, +then the kernel of the constant restriction map on its decomposition group is +exactly its inertia group. This is proved directly from the induced action on +the residue field; it assumes no point-count estimate. + +Second, relative Galois conjugation preserves absolute place degree, so it +acts on places of any prescribed degree. On each finite or infinity +restriction fiber, the stabilizer of a point is identified with the existing +decomposition group. +-/ + +@[expose] public section + +open scoped Pointwise Polynomial + +namespace BGS.HasseWeil + +noncomputable section + +open BGS.CorvajaZannier +open IsDedekindDomain + +section ResidueDegreeOne + +variable {C S A G : Type*} + [Field C] [Field S] [CommRing A] + [Algebra C S] [Algebra S A] + [Group G] [MulSemiringAction G A] + +/-- If a maximal ideal has residue degree one over `S`, and the action on the +ambient ring restricts along `π` to the stated action on `S`, then the kernel +of `π` on the decomposition group is exactly the inertia group. -/ +theorem stabilizerRestriction_ker_eq_inertia_of_residue_finrank_one + (q : Ideal A) [q.IsMaximal] + (π : G →* (S ≃ₐ[C] S)) + (hcompat : ∀ (g : G) (s : S), + g • algebraMap S A s = algebraMap S A (π g s)) + (hdegree : Module.finrank S q.ResidueField = 1) : + (π.comp (MulAction.stabilizer G q).subtype).ker = + q.inertia (MulAction.stabilizer G q) := by + ext g + change π g.1 = 1 ↔ ∀ x : A, g.1 • x - x ∈ q + constructor + · intro hg x + have hsurj : Function.Surjective (algebraMap S q.ResidueField) := + (Algebra.finrank_eq_one_iff_bijective_algebraMap.mp hdegree).2 + obtain ⟨s, hs⟩ := hsurj (algebraMap A q.ResidueField x) + have hx : x - algebraMap S A s ∈ q := by + rw [← Ideal.algebraMap_residueField_eq_zero] + rw [map_sub, ← IsScalarTower.algebraMap_apply S A q.ResidueField, hs, + sub_self] + have hgx : g.1 • (x - algebraMap S A s) ∈ q := by + have hmem := Ideal.smul_mem_pointwise_smul g.1 + (x - algebraMap S A s) q hx + rw [g.2] at hmem + exact hmem + have hfixs : g.1 • algebraMap S A s = algebraMap S A s := by + rw [hcompat, hg] + rfl + simpa [smul_sub, hfixs] using q.sub_mem hgx hx + · intro hg + apply AlgEquiv.ext + intro s + have hsMem : algebraMap S A (π g.1 s) - algebraMap S A s ∈ q := by + simpa [hcompat] using hg (algebraMap S A s) + have hAZero : algebraMap A q.ResidueField + (algebraMap S A (π g.1 s - s)) = 0 := + Ideal.algebraMap_residueField_eq_zero.mpr (by + simpa only [map_sub] using hsMem) + have hsZero : algebraMap S q.ResidueField (π g.1 s - s) = 0 := by + calc + algebraMap S q.ResidueField (π g.1 s - s) = + algebraMap A q.ResidueField + (algebraMap S A (π g.1 s - s)) := + IsScalarTower.algebraMap_apply S A q.ResidueField _ + _ = 0 := hAZero + have : π g.1 s - s = 0 := by + apply (algebraMap S q.ResidueField).injective + simpa using hsZero + simpa using sub_eq_zero.mp this + +end ResidueDegreeOne + +section FunctionFieldPlaces + +variable (K : Type*) [Field K] [DecidableEq K] [DecidableEq (RatFunc K)] +variable (M : Type*) [Field M] [Algebra (RatFunc K) M] + [FiniteDimensional (RatFunc K) M] + [Algebra.IsSeparable (RatFunc K) M] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + [Algebra M L] [IsScalarTower (RatFunc K) M L] + [IsGalois M L] + +omit [Algebra.IsSeparable (RatFunc K) M] [Algebra.IsSeparable (RatFunc K) L] in +/-- Relative Galois conjugation preserves the absolute degree of a finite +place. -/ +theorem finiteExtensionFinitePlace_degree_finitePlaceGalSmul + (g : Gal(L/M)) (P : FiniteExtensionFinitePlace K L) : + finiteExtensionPlaceDegree K L + (.inl (finitePlaceGalSmul K M L g P)) = + finiteExtensionPlaceDegree K L (.inl P) := by + rw [finiteExtensionPlaceDegree_inl_eq_mul_relativeInertiaDeg K M L, + finiteExtensionPlaceDegree_inl_eq_mul_relativeInertiaDeg K M L] + rw [finitePlaceUnder_finitePlaceGalSmul] + have hlocal := + finitePlaceRelative_ramificationIdx_inertiaDeg_eq_of_same_under + K M L (finitePlaceGalSmul K M L g P) P + (finitePlaceUnder_finitePlaceGalSmul K M L g P) + rw [hlocal.2] + +omit [Algebra.IsSeparable (RatFunc K) L] in +/-- Relative Galois conjugation preserves the absolute degree of a place +above infinity. -/ +theorem finiteExtensionInfinityPlace_degree_infinityPlaceGalSmul + (g : Gal(L/M)) (P : FiniteExtensionInfinityPlace K L) : + finiteExtensionPlaceDegree K L + (.inr (infinityPlaceGalSmul K M L g P)) = + finiteExtensionPlaceDegree K L (.inr P) := by + rw [finiteExtensionPlaceDegree_inr_eq_mul_relativeInertiaDeg K M L, + finiteExtensionPlaceDegree_inr_eq_mul_relativeInertiaDeg K M L] + rw [infinityPlaceUnder_infinityPlaceGalSmul] + have hlocal := + infinityPlaceRelative_ramificationIdx_inertiaDeg_eq_of_same_under + K M L (infinityPlaceGalSmul K M L g P) P + (infinityPlaceUnder_infinityPlaceGalSmul K M L g P) + rw [hlocal.2] + +/-- Finite places of a prescribed absolute degree. -/ +abbrev FiniteExtensionFinitePlaceOfDegree (d : ℕ) := + {P : FiniteExtensionFinitePlace K L // + finiteExtensionPlaceDegree K L (.inl P) = d} + +/-- Places above infinity of a prescribed absolute degree. -/ +abbrev FiniteExtensionInfinityPlaceOfDegree (d : ℕ) := + {P : FiniteExtensionInfinityPlace K L // + finiteExtensionPlaceDegree K L (.inr P) = d} + +/-- The relative Galois action on finite places restricts to places of any +prescribed absolute degree. -/ +@[implicit_reducible] +noncomputable def finitePlaceOfDegreeGalAction (d : ℕ) : + MulAction Gal(L/M) (FiniteExtensionFinitePlaceOfDegree K L d) := by + letI := finitePlaceGalAction K M L + exact + { smul := fun g P => ⟨finitePlaceGalSmul K M L g P.1, by + rw [finiteExtensionFinitePlace_degree_finitePlaceGalSmul K M L g P.1, + P.2]⟩ + one_smul := fun P => by + apply Subtype.ext + exact one_smul Gal(L/M) P.1 + mul_smul := fun g h P => by + apply Subtype.ext + exact mul_smul g h P.1 } + +/-- The relative Galois action on places above infinity restricts to places +of any prescribed absolute degree. -/ +@[implicit_reducible] +noncomputable def infinityPlaceOfDegreeGalAction (d : ℕ) : + MulAction Gal(L/M) (FiniteExtensionInfinityPlaceOfDegree K L d) := by + letI := infinityPlaceGalAction K M L + exact + { smul := fun g P => ⟨infinityPlaceGalSmul K M L g P.1, by + rw [finiteExtensionInfinityPlace_degree_infinityPlaceGalSmul + K M L g P.1, P.2]⟩ + one_smul := fun P => by + apply Subtype.ext + exact one_smul Gal(L/M) P.1 + mul_smul := fun g h P => by + apply Subtype.ext + exact mul_smul g h P.1 } + +omit [DecidableEq K] [DecidableEq (RatFunc K)] + [Algebra.IsSeparable (RatFunc K) M] [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] in +/-- On a finite-place restriction fiber, the point stabilizer is the usual +decomposition group of the underlying place. -/ +theorem finitePlaceUnderFiber_stabilizer_eq_decompositionGroup + (P : FiniteExtensionFinitePlace K M) + (Q : FinitePlaceUnderFiber K M L P) : + letI := finitePlaceUnderFiberGalAction K M L P + MulAction.stabilizer Gal(L/M) Q = + finitePlaceDecompositionGroup K M L Q.1 := by + let := finiteIntegralClosureGalAction K M L + let := finitePlaceUnderFiberGalAction K M L P + ext g + change (g • Q = Q) ↔ g • Q.1.asIdeal = Q.1.asIdeal + constructor + · intro hg + have hplace : finitePlaceGalSmul K M L g Q.1 = Q.1 := + congrArg Subtype.val hg + exact congrArg HeightOneSpectrum.asIdeal hplace + · intro hg + apply Subtype.ext + apply HeightOneSpectrum.ext + exact hg + +omit [DecidableEq K] [Algebra.IsSeparable (RatFunc K) M] [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] in +/-- On an infinity-place restriction fiber, the point stabilizer is the +usual decomposition group of the underlying place. -/ +theorem infinityPlaceUnderFiber_stabilizer_eq_decompositionGroup + (P : FiniteExtensionInfinityPlace K M) + (Q : InfinityPlaceUnderFiber K M L P) : + letI := infinityPlaceUnderFiberGalAction K M L P + MulAction.stabilizer Gal(L/M) Q = + infinityPlaceDecompositionGroup K M L Q.1 := by + let := infinityIntegralClosureGalAction K M L + let := infinityPlaceUnderFiberGalAction K M L P + ext g + change (g • Q = Q) ↔ g • Q.1.1 = Q.1.1 + constructor + · intro hg + have hplace : infinityPlaceGalSmul K M L g Q.1 = Q.1 := + congrArg Subtype.val hg + exact congrArg Subtype.val hplace + · intro hg + apply Subtype.ext + apply Subtype.ext + exact hg + +end FunctionFieldPlaces + +end + + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/FinitePlaceNormalizationTransport.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/FinitePlaceNormalizationTransport.lean new file mode 100644 index 0000000000..99a509ebe1 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/FinitePlaceNormalizationTransport.lean @@ -0,0 +1,270 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.ConstantFieldFinitePlaceDegree + +/-! +# Transporting normalization ideals to finite places + +The project's finite places are height-one prime ideals in +`RatFuncFiniteIntegralClosure S T`. Constant-extension arguments naturally +produce another normalization model together with an equivalence over +`S[X]`. This file transports height-one ideals, residue fields, residue +degrees, and contractions across such an equivalence. + +There is one typeclass subtlety. A canonical embedding `RatFunc S → T` +induces an `S[X]`-algebra structure on `T`, while a geometric construction +may already carry a propositionally equal polynomial algebra structure. +The algebra-map bridge below turns a pointwise compatibility theorem into an +equivalence with `RatFuncFiniteIntegralClosure S T`; it does not assume the +two structures are definitionally equal. +-/ + +@[expose] public section + +open scoped Polynomial + +open IsDedekindDomain + +namespace BGS.HasseWeil + +noncomputable section + +variable {C A B R : Type*} + [CommRing C] [CommRing A] [CommRing B] [CommRing R] + [Algebra C A] [Algebra C B] + +/-- An algebra equivalence transports height-one prime ideals. -/ +def heightOneSpectrumEquivOfAlgEquiv (e : A ≃ₐ[C] B) : + HeightOneSpectrum A ≃ HeightOneSpectrum B := + HeightOneSpectrum.equivOfRingEquiv e.toRingEquiv + +@[simp] +theorem heightOneSpectrumEquivOfAlgEquiv_asIdeal (e : A ≃ₐ[C] B) + (q : HeightOneSpectrum A) : + (heightOneSpectrumEquivOfAlgEquiv e q).asIdeal = + q.asIdeal.comap e.symm := + rfl + +/-- Residue fields at corresponding height-one ideals are equivalent over +the common coefficient ring. -/ +def heightOneSpectrumResidueFieldAlgEquiv (e : A ≃ₐ[C] B) + (q : HeightOneSpectrum A) : + q.asIdeal.ResidueField ≃ₐ[C] + (heightOneSpectrumEquivOfAlgEquiv e q).asIdeal.ResidueField := + Ideal.residueFieldAlgEquiv q.asIdeal + (heightOneSpectrumEquivOfAlgEquiv e q).asIdeal e + (by + change q.asIdeal = (q.asIdeal.comap e.symm).comap e + exact (Ideal.comap_of_equiv e.toRingEquiv).symm) + +/-- Corresponding residue fields have the same degree over the common +coefficient field. -/ +theorem heightOneSpectrum_residueField_finrank_eq + {k A B : Type*} [Field k] [CommRing A] [CommRing B] + [Algebra k A] [Algebra k B] + (e : A ≃ₐ[k] B) (q : HeightOneSpectrum A) : + Module.finrank k q.asIdeal.ResidueField = + Module.finrank k + (heightOneSpectrumEquivOfAlgEquiv e q).asIdeal.ResidueField := + (heightOneSpectrumResidueFieldAlgEquiv e q).toLinearEquiv.finrank_eq + +section Contraction + +variable [IsDedekindDomain R] [IsDomain A] [IsDomain B] + [Algebra R A] [Algebra R B] + [Algebra.IsIntegral R A] [Algebra.IsIntegral R B] + +/-- Transport by an equivalence over the base ring preserves the prime ideal +below a height-one ideal. -/ +@[simp] +theorem heightOneSpectrumEquivOfAlgEquiv_under + (e : A ≃ₐ[R] B) (q : HeightOneSpectrum A) : + HeightOneSpectrum.under R (heightOneSpectrumEquivOfAlgEquiv e q) = + HeightOneSpectrum.under R q := by + apply HeightOneSpectrum.ext + ext x + change e.symm (algebraMap R B x) ∈ q.asIdeal ↔ + algebraMap R A x ∈ q.asIdeal + rw [e.symm.commutes] + +/-- The same contraction result when the equivalence is over a smaller +coefficient ring and compatibility with the base algebra maps is supplied +separately. -/ +@[simp] +theorem heightOneSpectrumEquivOfAlgEquiv_under_of_algebraMap_eq + (e : A ≃ₐ[C] B) + (h : e.toRingHom.comp (algebraMap R A) = algebraMap R B) + (q : HeightOneSpectrum A) : + HeightOneSpectrum.under R (heightOneSpectrumEquivOfAlgEquiv e q) = + HeightOneSpectrum.under R q := by + apply HeightOneSpectrum.ext + ext x + change e.symm (algebraMap R B x) ∈ q.asIdeal ↔ + algebraMap R A x ∈ q.asIdeal + have hx := DFunLike.congr_fun h x + rw [← hx] + change e.symm (e (algebraMap R A x)) ∈ q.asIdeal ↔ + algebraMap R A x ∈ q.asIdeal + rw [e.symm_apply_apply] + +end Contraction + +section PolynomialAlgebraBridge + +open BGS.CorvajaZannier + +variable (S T : Type*) [Field S] [Field T] + [Algebra (RatFunc S) T] + +/-- The polynomial algebra structure on `T` induced by its +`RatFunc S`-algebra structure. -/ +@[reducible] +noncomputable def ratFuncInducedPolynomialAlgebra : Algebra S[X] T := + RingHom.toAlgebra ((algebraMap (RatFunc S) T).comp + (algebraMap S[X] (RatFunc S))) + +/-- Pointwise compatibility of polynomial algebra maps identifies a chosen +`S[X]`-algebra structure with the structure induced from `RatFunc S`. -/ +theorem ratFuncInducedPolynomialAlgebra_eq + (a : Algebra S[X] T) + (h : ∀ p : S[X], + algebraMap (RatFunc S) T (algebraMap S[X] (RatFunc S) p) = + @algebraMap S[X] T _ _ a p) : + ratFuncInducedPolynomialAlgebra S T = a := by + apply Algebra.algebra_ext + intro p + exact h p + +/-- Equality of the ambient polynomial algebra structures identifies their +integral closures, one of which is the project's rational-function model. -/ +noncomputable def integralClosureAlgEquivRatFuncFiniteOfEq + (a : Algebra S[X] T) + (h : ratFuncInducedPolynomialAlgebra S T = a) : + letI := a + integralClosure S[X] T ≃ₐ[S[X]] RatFuncFiniteIntegralClosure S T := by + subst a + exact AlgEquiv.refl + +/-- A polynomial restriction formula for `RatFunc S → T` gives the +normalization equivalence needed by the finite-place model. -/ +noncomputable def integralClosureAlgEquivRatFuncFiniteOfAlgebraMap + (a : Algebra S[X] T) + (h : ∀ p : S[X], + algebraMap (RatFunc S) T (algebraMap S[X] (RatFunc S) p) = + @algebraMap S[X] T _ _ a p) : + letI := a + integralClosure S[X] T ≃ₐ[S[X]] RatFuncFiniteIntegralClosure S T := + integralClosureAlgEquivRatFuncFiniteOfEq S T a + (ratFuncInducedPolynomialAlgebra_eq S T a h) + +variable (A : Type*) [CommRing A] [Algebra S[X] A] + +/-- Compose a geometric normalization equivalence with the polynomial +algebra bridge, landing in `RatFuncFiniteIntegralClosure S T`. -/ +noncomputable def normalizationAlgEquivRatFuncFiniteOfAlgebraMap + (a : Algebra S[X] T) + (e : letI := a + A ≃ₐ[S[X]] integralClosure S[X] T) + (h : ∀ p : S[X], + algebraMap (RatFunc S) T (algebraMap S[X] (RatFunc S) p) = + @algebraMap S[X] T _ _ a p) : + A ≃ₐ[S[X]] RatFuncFiniteIntegralClosure S T := by + letI := a + exact e.trans + (integralClosureAlgEquivRatFuncFiniteOfAlgebraMap S T a h) + +end PolynomialAlgebraBridge + +section FiniteExtensionFinitePlace + +open BGS.CorvajaZannier + +variable (S T A : Type*) [Field S] [Field T] [CommRing A] + [Algebra (RatFunc S) T] + +local instance finitePlacePolynomialTopAlgebra : Algebra S[X] T := + ratFuncInducedPolynomialAlgebra S T + +variable [Algebra S[X] A] + +local instance finitePlaceSourceConstantAlgebra : Algebra S A := + RingHom.toAlgebra ((algebraMap S[X] A).comp (algebraMap S S[X])) + +local instance finitePlaceTargetConstantAlgebra : + Algebra S (RatFuncFiniteIntegralClosure S T) := + RingHom.toAlgebra ((algebraMap S[X] + (RatFuncFiniteIntegralClosure S T)).comp (algebraMap S S[X])) + +local instance finitePlaceSourceConstantTower : IsScalarTower S S[X] A := + IsScalarTower.of_algebraMap_eq' rfl + +local instance finitePlaceTargetConstantTower : + IsScalarTower S S[X] (RatFuncFiniteIntegralClosure S T) := + IsScalarTower.of_algebraMap_eq' rfl + +local instance finitePlaceTargetIntegral : + Algebra.IsIntegral S[X] (RatFuncFiniteIntegralClosure S T) := + IsIntegralClosure.isIntegral_algebra S[X] T + +/-- An equivalence of normalization models over `S[X]` transports their +height-one ideals to the project's finite-place type. -/ +def finiteExtensionFinitePlaceEquivOfNormalizationAlgEquiv + (e : A ≃ₐ[S[X]] RatFuncFiniteIntegralClosure S T) : + HeightOneSpectrum A ≃ FiniteExtensionFinitePlace S T := + heightOneSpectrumEquivOfAlgEquiv (e.restrictScalars S) + +@[simp] +theorem finiteExtensionFinitePlaceEquivOfNormalizationAlgEquiv_asIdeal + (e : A ≃ₐ[S[X]] RatFuncFiniteIntegralClosure S T) + (q : HeightOneSpectrum A) : + (finiteExtensionFinitePlaceEquivOfNormalizationAlgEquiv + S T A e q).asIdeal = q.asIdeal.comap e.symm := + rfl + +/-- A normalization equivalence transports the residue field at each +height-one ideal as an `S`-algebra. -/ +def finiteExtensionFinitePlaceResidueFieldAlgEquivOfNormalization + (e : A ≃ₐ[S[X]] RatFuncFiniteIntegralClosure S T) + (q : HeightOneSpectrum A) : + q.asIdeal.ResidueField ≃ₐ[S] + (finiteExtensionFinitePlaceEquivOfNormalizationAlgEquiv + S T A e q).asIdeal.ResidueField := + heightOneSpectrumResidueFieldAlgEquiv (e.restrictScalars S) q + +/-- The constant-field residue degree is unchanged when replacing a +normalization by an equivalent model. -/ +theorem finiteExtensionFinitePlace_residueField_finrank_eq_of_normalization + (e : A ≃ₐ[S[X]] RatFuncFiniteIntegralClosure S T) + (q : HeightOneSpectrum A) : + Module.finrank S q.asIdeal.ResidueField = + Module.finrank S + (finiteExtensionFinitePlaceEquivOfNormalizationAlgEquiv + S T A e q).asIdeal.ResidueField := + (finiteExtensionFinitePlaceResidueFieldAlgEquivOfNormalization + S T A e q).toLinearEquiv.finrank_eq + +variable [IsDomain A] [Algebra.IsIntegral S[X] A] + +/-- The finite place below a transported ideal agrees with the contraction +of the source ideal to `S[X]`. -/ +@[simp] +theorem finiteExtensionFinitePlaceEquivOfNormalizationAlgEquiv_under + (e : A ≃ₐ[S[X]] RatFuncFiniteIntegralClosure S T) + (q : HeightOneSpectrum A) : + HeightOneSpectrum.under S[X] + (finiteExtensionFinitePlaceEquivOfNormalizationAlgEquiv S T A e q) = + HeightOneSpectrum.under S[X] q := by + exact heightOneSpectrumEquivOfAlgEquiv_under e q + +end FiniteExtensionFinitePlace + +end + + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/FinitePrincipalParts.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/FinitePrincipalParts.lean new file mode 100644 index 0000000000..4731ee8025 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/FinitePrincipalParts.lean @@ -0,0 +1,431 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.CechRiemannLinearAlgebra +public import LeanPool.MarkoffModP.BGS.HasseWeil.LocalPoleFiltration +public import Mathlib.LinearAlgebra.Dimension.Constructions + +/-! +# Finite principal parts + +This file assembles the one-place calculation in `LocalPoleFiltration` over a +finite family of discrete valuation rings. At one place the principal parts +of order at most `n` are the genuine quotient + +`localPoleSpace π n / localPoleSpace π 0`. + +The filtration by pole order proves that its dimension is `n` times the +residue-field degree. Taking a finite product therefore has dimension the +weighted degree of the chosen pole bounds. + +The last section constructs the diagonal principal-parts map on any global +subspace satisfying those pole bounds. Its kernel is exactly the subspace +regular at every chosen place. Thus, once the all-place function-field layer +identifies that regular subspace with the constants, the quotient by constants +embeds in this finite-dimensional principal-parts space. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +open Submodule +open scoped nonZeroDivisors + +noncomputable section + +section OnePlace + +variable {K R L : Type*} [Field K] [CommRing R] + [IsDedekindDomain R] [IsDiscreteValuationRing R] + [Field L] [Algebra K R] [Algebra R L] [Algebra K L] + [IsScalarTower K R L] [IsFractionRing R L] + +omit [IsDedekindDomain R] [IsDiscreteValuationRing R] [IsFractionRing R L] in +/-- Monotonicity of the local pole filtration for an arbitrary increase in +the allowed pole order. -/ +theorem localPoleSpace_mono_of_le (π : R) {m n : ℕ} (hmn : m ≤ n) : + localPoleSpace (K := K) (L := L) π m ≤ + localPoleSpace (K := K) (L := L) π n := by + induction n, hmn using Nat.le_induction with + | base => exact le_rfl + | succ n _ ih => + exact ih.trans (by simpa [Nat.succ_eq_add_one] using + localPoleSpace_mono (K := K) (L := L) π n) + +/-- Principal parts of order at most `n` at one DVR. -/ +abbrev localPrincipalPartSpace (π : R) (n : ℕ) := + localPoleSpace (K := K) (L := L) π n ⧸ + relativeSubmodule + (localPoleSpace (K := K) (L := L) π 0) + (localPoleSpace (K := K) (L := L) π n) + +/-- The last graded layer in the local pole filtration. -/ +abbrev localPrincipalPartLayer (π : R) (n : ℕ) := + localPoleSpace (K := K) (L := L) π (n + 1) ⧸ + relativeSubmodule + (localPoleSpace (K := K) (L := L) π n) + (localPoleSpace (K := K) (L := L) π (n + 1)) + +/-- Enlarging the pole bound by one gives an inclusion of principal-part +spaces. -/ +def localPrincipalPartInclusion (π : R) (n : ℕ) : + localPrincipalPartSpace (K := K) (L := L) π n →ₗ[K] + localPrincipalPartSpace (K := K) (L := L) π (n + 1) := by + let hnn : localPoleSpace (K := K) (L := L) π n ≤ + localPoleSpace (K := K) (L := L) π (n + 1) := + localPoleSpace_mono (K := K) (L := L) π n + let inclusion : localPoleSpace (K := K) (L := L) π n →ₗ[K] + localPoleSpace (K := K) (L := L) π (n + 1) := + Submodule.inclusion hnn + exact (Submodule.comap + (localPoleSpace (K := K) (L := L) π n).subtype + (localPoleSpace (K := K) (L := L) π 0)).mapQ + (Submodule.comap + (localPoleSpace (K := K) (L := L) π (n + 1)).subtype + (localPoleSpace (K := K) (L := L) π 0)) inclusion (by + intro x hx + change (x : L) ∈ localPoleSpace (K := K) (L := L) π 0 at hx ⊢ + exact hx) + +/-- Forgetting the top pole layer maps principal parts of order `n + 1` onto +the last local quotient. -/ +def localPrincipalPartLayerMap (π : R) (n : ℕ) : + localPrincipalPartSpace (K := K) (L := L) π (n + 1) →ₗ[K] + localPrincipalPartLayer (K := K) (L := L) π n := by + apply Submodule.factor + intro x hx + change (x : L) ∈ localPoleSpace (K := K) (L := L) π 0 at hx + change (x : L) ∈ localPoleSpace (K := K) (L := L) π n + exact localPoleSpace_mono_of_le (K := K) (L := L) π (Nat.zero_le n) hx + +omit [IsDedekindDomain R] [IsDiscreteValuationRing R] [IsFractionRing R L] in +theorem localPrincipalPartInclusion_injective (π : R) (n : ℕ) : + Function.Injective + (localPrincipalPartInclusion (K := K) (L := L) π n) := by + rw [← LinearMap.ker_eq_bot] + ext x + refine Submodule.Quotient.induction_on _ x ?_ + intro x + rw [LinearMap.mem_ker, Submodule.mem_bot] + change (Submodule.Quotient.mk + (Submodule.inclusion + (localPoleSpace_mono (K := K) (L := L) π n) x) = 0) ↔ + Submodule.Quotient.mk x = 0 + rw [Submodule.Quotient.mk_eq_zero, Submodule.Quotient.mk_eq_zero] + rfl + +omit [IsDedekindDomain R] [IsDiscreteValuationRing R] [IsFractionRing R L] in +theorem range_localPrincipalPartInclusion_eq_ker_layerMap + (π : R) (n : ℕ) : + LinearMap.range + (localPrincipalPartInclusion (K := K) (L := L) π n) = + LinearMap.ker + (localPrincipalPartLayerMap (K := K) (L := L) π n) := by + ext x + constructor + · rintro ⟨y, rfl⟩ + apply LinearMap.mem_ker.mpr + refine Submodule.Quotient.induction_on _ y ?_ + intro y + simp [localPrincipalPartInclusion, localPrincipalPartLayerMap] + · intro hx + obtain ⟨x, rfl⟩ := Quotient.exists_rep x + rw [LinearMap.mem_ker] at hx + change Submodule.Quotient.mk x = 0 at hx + rw [Submodule.Quotient.mk_eq_zero] at hx + let y : localPoleSpace (K := K) (L := L) π n := ⟨x.1, hx⟩ + refine ⟨Submodule.Quotient.mk y, ?_⟩ + rfl + +/-- Every local principal-part space is finite-dimensional. -/ +theorem localPrincipalPartSpace_finite + (π : R) (hπ : π ≠ 0) + (hπIdeal : (IsDiscreteValuationRing.maximalIdeal R).asIdeal = + Ideal.span {π}) (n : ℕ) + [Module.Finite K (IsLocalRing.ResidueField R)] : + Module.Finite K (localPrincipalPartSpace (K := K) (L := L) π n) := by + induction n with + | zero => + have htop : Submodule.comap + (localPoleSpace (K := K) (L := L) π 0).subtype + (localPoleSpace (K := K) (L := L) π 0) = ⊤ := by + ext x + simp + change Module.Finite K + (localPoleSpace (K := K) (L := L) π 0 ⧸ + Submodule.comap + (localPoleSpace (K := K) (L := L) π 0).subtype + (localPoleSpace (K := K) (L := L) π 0)) + rw [htop] + infer_instance + | succ n ih => + let f := localPrincipalPartLayerMap (K := K) (L := L) π n + let : Module.Finite K (localPrincipalPartLayer (K := K) (L := L) π n) := + Module.Finite.equiv + (localPoleQuotientEquivResidueField + (K := K) (L := L) π hπ hπIdeal n).symm + let : Module.Finite K f.ker := by + rw [show f.ker = LinearMap.range + (localPrincipalPartInclusion (K := K) (L := L) π n) by + exact (range_localPrincipalPartInclusion_eq_ker_layerMap + (K := K) (L := L) π n).symm] + infer_instance + let : Module.Finite K f.range := inferInstance + let : Module.Finite K + (localPrincipalPartSpace (K := K) (L := L) π (n + 1) ⧸ f.ker) := + Module.Finite.equiv f.quotKerEquivRange.symm + exact Module.Finite.of_submodule_quotient f.ker + +/-- The dimension of the genuine local principal-part quotient is the pole +order times the residue-field degree. -/ +theorem localPrincipalPartSpace_finrank + (π : R) (hπ : π ≠ 0) + (hπIdeal : (IsDiscreteValuationRing.maximalIdeal R).asIdeal = + Ideal.span {π}) (n : ℕ) + [Module.Finite K (IsLocalRing.ResidueField R)] : + Module.finrank K (localPrincipalPartSpace (K := K) (L := L) π n) = + n * Module.finrank K (IsLocalRing.ResidueField R) := by + induction n with + | zero => + have htop : Submodule.comap + (localPoleSpace (K := K) (L := L) π 0).subtype + (localPoleSpace (K := K) (L := L) π 0) = ⊤ := by + ext x + simp + change Module.finrank K + (localPoleSpace (K := K) (L := L) π 0 ⧸ + Submodule.comap + (localPoleSpace (K := K) (L := L) π 0).subtype + (localPoleSpace (K := K) (L := L) π 0)) = + 0 * Module.finrank K (IsLocalRing.ResidueField R) + rw [htop] + simpa using (Module.finrank_zero_of_subsingleton + (R := K) + (M := localPoleSpace (K := K) (L := L) π 0 ⧸ + (⊤ : Submodule K + (localPoleSpace (K := K) (L := L) π 0)))) + | succ n ih => + let := localPrincipalPartSpace_finite + (K := K) (L := L) π hπ hπIdeal n + let := localPrincipalPartSpace_finite + (K := K) (L := L) π hπ hπIdeal (n + 1) + let f := localPrincipalPartLayerMap (K := K) (L := L) π n + have hsurj : Function.Surjective f := by + intro x + obtain ⟨x, rfl⟩ := Quotient.exists_rep x + exact ⟨Submodule.Quotient.mk x, rfl⟩ + have hker := range_localPrincipalPartInclusion_eq_ker_layerMap + (K := K) (L := L) π n + have hker' : f.ker = LinearMap.range + (localPrincipalPartInclusion (K := K) (L := L) π n) := by + simpa [f] using hker.symm + calc + Module.finrank K + (localPrincipalPartSpace (K := K) (L := L) π (n + 1)) = + Module.finrank K f.range + Module.finrank K f.ker := + f.finrank_range_add_finrank_ker.symm + _ = Module.finrank K + (localPrincipalPartLayer (K := K) (L := L) π n) + + Module.finrank K + (localPrincipalPartSpace (K := K) (L := L) π n) := by + rw [show f.range = ⊤ from LinearMap.range_eq_top.mpr hsurj, + finrank_top, hker', + LinearMap.finrank_range_of_inj + (localPrincipalPartInclusion_injective + (K := K) (L := L) π n)] + _ = Module.finrank K (IsLocalRing.ResidueField R) + + n * Module.finrank K (IsLocalRing.ResidueField R) := by + rw [localPoleQuotient_finrank + (K := K) (L := L) π hπ hπIdeal n, ih] + _ = (n + 1) * Module.finrank K (IsLocalRing.ResidueField R) := by + simp [Nat.add_mul, Nat.add_comm] + +end OnePlace + +section QuotientByKernel + +variable {K V W : Type*} [Field K] + [AddCommGroup V] [Module K V] [AddCommGroup W] [Module K W] + +/-- A linear map descends injectively after quotienting by a submodule known +to be its kernel. -/ +def quotientLinearMapOfKerEq + (f : V →ₗ[K] W) (P : Submodule K V) (hker : f.ker = P) : + (V ⧸ P) →ₗ[K] W := + P.liftQ f hker.symm.le + +theorem quotientLinearMapOfKerEq_injective + (f : V →ₗ[K] W) (P : Submodule K V) (hker : f.ker = P) : + Function.Injective (quotientLinearMapOfKerEq f P hker) := by + rw [← LinearMap.ker_eq_bot] + exact Submodule.ker_liftQ_eq_bot P f hker.symm.le hker.le + +/-- The quotient by the kernel of a map into a finite-dimensional space has +dimension at most that of the target. -/ +theorem finrank_quotient_le_of_ker_eq + (f : V →ₗ[K] W) (P : Submodule K V) (hker : f.ker = P) + [Module.Finite K W] : + Module.finrank K (V ⧸ P) ≤ Module.finrank K W := by + rw [← hker, f.quotKerEquivRange.finrank_eq] + exact f.range.finrank_le + +end QuotientByKernel + +section FiniteFamily + +variable {K L I : Type*} [Field K] [Field L] [Fintype I] + {R : I → Type*} + [∀ i, CommRing (R i)] [∀ i, IsDedekindDomain (R i)] + [∀ i, IsDiscreteValuationRing (R i)] + [∀ i, Algebra K (R i)] [∀ i, Algebra (R i) L] [Algebra K L] + [∀ i, IsScalarTower K (R i) L] [∀ i, IsFractionRing (R i) L] + +/-- A finite family of local principal-part spaces. -/ +abbrev finitePrincipalPartsSpace (π : ∀ i, R i) (n : I → ℕ) := + ∀ i, localPrincipalPartSpace (K := K) (L := L) (π i) (n i) + +/-- The weighted degree of a finite family of pole bounds. -/ +def finitePrincipalPartsDegree (n : I → ℕ) : ℕ := + ∑ i, n i * Module.finrank K (IsLocalRing.ResidueField (R i)) + +/-- Finite principal parts have dimension equal to the weighted pole degree. -/ +theorem finitePrincipalPartsSpace_finrank + (π : ∀ i, R i) (hπ : ∀ i, π i ≠ 0) + (hπIdeal : ∀ i, + (IsDiscreteValuationRing.maximalIdeal (R i)).asIdeal = + Ideal.span {π i}) (n : I → ℕ) + [∀ i, Module.Finite K (IsLocalRing.ResidueField (R i))] : + Module.finrank K (finitePrincipalPartsSpace (K := K) (L := L) π n) = + finitePrincipalPartsDegree (K := K) (R := R) n := by + let localPrincipalPartModule (i : I) : Module K + (localPrincipalPartSpace (K := K) (L := L) (π i) (n i)) := + inferInstance + let finitePrincipalPartsModule : Module K + (finitePrincipalPartsSpace (K := K) (L := L) π n) := + Pi.module I + (fun i => localPrincipalPartSpace (K := K) (L := L) (π i) (n i)) K + let (i : I) : Module.Finite K + (localPrincipalPartSpace (K := K) (L := L) (π i) (n i)) := + localPrincipalPartSpace_finite + (K := K) (L := L) (π i) (hπ i) (hπIdeal i) (n i) + let (i : I) : Module.Free K + (localPrincipalPartSpace (K := K) (L := L) (π i) (n i)) := + Module.Free.of_divisionRing K + (localPrincipalPartSpace (K := K) (L := L) (π i) (n i)) + rw [Module.finrank_pi_fintype] + apply Finset.sum_congr rfl + intro i _ + exact localPrincipalPartSpace_finrank + (K := K) (L := L) (π i) (hπ i) (hπIdeal i) (n i) + +/-- A global subspace with the prescribed local pole bounds maps diagonally +to its finite family of principal parts. -/ +def finitePrincipalPartsDiagonalMap + (π : ∀ i, R i) (n : I → ℕ) (S : Submodule K L) + (hS : ∀ i, S ≤ localPoleSpace (K := K) (L := L) (π i) (n i)) : + S →ₗ[K] finitePrincipalPartsSpace (K := K) (L := L) π n := + LinearMap.pi fun i => + (Submodule.comap + (localPoleSpace (K := K) (L := L) (π i) (n i)).subtype + (localPoleSpace (K := K) (L := L) (π i) 0)).mkQ.comp + (Submodule.inclusion (hS i)) + +/-- The elements of a global subspace that are regular at every chosen +place. -/ +def regularAtFiniteFamily + (π : ∀ i, R i) (S : Submodule K L) : Submodule K S := + ⨅ i, Submodule.comap S.subtype + (localPoleSpace (K := K) (L := L) (π i) 0) + +omit [Fintype I] [∀ i, IsDedekindDomain (R i)] + [∀ i, IsDiscreteValuationRing (R i)] + [∀ i, IsFractionRing (R i) L] in +/-- The kernel of the diagonal principal-parts map is exactly simultaneous +regularity at the chosen places. -/ +theorem finitePrincipalPartsDiagonalMap_ker + (π : ∀ i, R i) (n : I → ℕ) (S : Submodule K L) + (hS : ∀ i, S ≤ localPoleSpace (K := K) (L := L) (π i) (n i)) : + LinearMap.ker + (finitePrincipalPartsDiagonalMap + (K := K) (L := L) π n S hS) = + regularAtFiniteFamily (K := K) (L := L) π S := by + ext x + rw [LinearMap.mem_ker] + constructor + · intro hx + rw [regularAtFiniteFamily, Submodule.mem_iInf] + intro i + have hi := congrFun hx i + change Submodule.Quotient.mk + (Submodule.inclusion (hS i) x) = 0 at hi + rw [Submodule.Quotient.mk_eq_zero] at hi + exact hi + · intro hx + funext i + rw [regularAtFiniteFamily, Submodule.mem_iInf] at hx + change Submodule.Quotient.mk + (Submodule.inclusion (hS i) x) = 0 + rw [Submodule.Quotient.mk_eq_zero] + exact hx i + +/-- Consequently, the global quotient by simultaneous regularity has +dimension at most the weighted pole degree. -/ +theorem finrank_quotient_regularAtFiniteFamily_le_degree + (π : ∀ i, R i) (hπ : ∀ i, π i ≠ 0) + (hπIdeal : ∀ i, + (IsDiscreteValuationRing.maximalIdeal (R i)).asIdeal = + Ideal.span {π i}) + (n : I → ℕ) (S : Submodule K L) + (hS : ∀ i, S ≤ localPoleSpace (K := K) (L := L) (π i) (n i)) + [∀ i, Module.Finite K (IsLocalRing.ResidueField (R i))] : + Module.finrank K + (S ⧸ regularAtFiniteFamily (K := K) (L := L) π S) ≤ + finitePrincipalPartsDegree (K := K) (R := R) n := by + let localPrincipalPartModule (i : I) : Module K + (localPrincipalPartSpace (K := K) (L := L) (π i) (n i)) := + inferInstance + let finitePrincipalPartsModule : Module K + (finitePrincipalPartsSpace (K := K) (L := L) π n) := + Pi.module I + (fun i => localPrincipalPartSpace (K := K) (L := L) (π i) (n i)) K + let (i : I) : Module.Finite K + (localPrincipalPartSpace (K := K) (L := L) (π i) (n i)) := + localPrincipalPartSpace_finite + (K := K) (L := L) (π i) (hπ i) (hπIdeal i) (n i) + let : Module.Finite K + (finitePrincipalPartsSpace (K := K) (L := L) π n) := inferInstance + let f : S →ₗ[K] finitePrincipalPartsSpace (K := K) (L := L) π n := + finitePrincipalPartsDiagonalMap (K := K) (L := L) π n S hS + have hfker : f.ker = regularAtFiniteFamily (K := K) (L := L) π S := by + simpa [f] using finitePrincipalPartsDiagonalMap_ker + (K := K) (L := L) π n S hS + let q := quotientLinearMapOfKerEq + (K := K) (V := S) + (W := finitePrincipalPartsSpace (K := K) (L := L) π n) f + (regularAtFiniteFamily (K := K) (L := L) π S) hfker + have hq : Function.Injective q := + quotientLinearMapOfKerEq_injective + (K := K) (V := S) + (W := finitePrincipalPartsSpace (K := K) (L := L) π n) f + (regularAtFiniteFamily (K := K) (L := L) π S) hfker + calc + Module.finrank K + (S ⧸ regularAtFiniteFamily (K := K) (L := L) π S) ≤ + Module.finrank K + (finitePrincipalPartsSpace (K := K) (L := L) π n) := + q.finrank_le_finrank_of_injective hq + _ = finitePrincipalPartsDegree (K := K) (R := R) n := + finitePrincipalPartsSpace_finrank + (K := K) (L := L) π hπ hπIdeal n + +end FiniteFamily + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/FinsuppWeightedFiber.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/FinsuppWeightedFiber.lean new file mode 100644 index 0000000000..6c1c00914f --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/FinsuppWeightedFiber.lean @@ -0,0 +1,102 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.ConstantExtensionClosedPlaceCount + +/-! +# Weighted degree cancellation over finite-support fibers + +This file upgrades the unweighted finite-family constant-extension identity to +finitely supported multiplicities. The ambient types need not be finite: a +nonzero downstairs coefficient forces every point in its fiber into the +finite upstairs support, so the relevant fiber can be counted there. +-/ + +@[expose] public section + +namespace Finsupp + +/-- Weighted form of the constant-extension degree cancellation. Suppose +upstairs multiplicities are pulled back from downstairs, upstairs degrees are +obtained by division by `gcd(r, degree)`, and the full fiber has that gcd as +its cardinality. Then the two finitely supported weighted degree sums agree. + +No finiteness assumption is imposed on `Base` or `Up`; only the supports of +the two `Finsupp`s are used as finite indexing sets. -/ +theorem sum_mul_degree_eq_of_div_gcd_fibers + {Base Up : Type*} + (down : Up → Base) + (baseDegree : Base → ℕ) (upDegree : Up → ℕ) + (baseMultiplicity : Base →₀ ℕ) + (upMultiplicity : Up →₀ ℕ) + (extensionDegree : ℕ) + (hmultiplicity : ∀ Q, + upMultiplicity Q = baseMultiplicity (down Q)) + (hdegree : ∀ Q, + upDegree Q = baseDegree (down Q) / + Nat.gcd extensionDegree (baseDegree (down Q))) + (hfiber : ∀ P, + Nat.card {Q : Up // down Q = P} = + Nat.gcd extensionDegree (baseDegree P)) : + upMultiplicity.sum (fun Q m ↦ m * upDegree Q) = + baseMultiplicity.sum (fun P m ↦ m * baseDegree P) := by + classical + rw [Finsupp.sum, Finsupp.sum] + have hmaps : ∀ Q ∈ upMultiplicity.support, + down Q ∈ baseMultiplicity.support := by + intro Q hQ + rw [Finsupp.mem_support_iff] at hQ ⊢ + simpa only [← hmultiplicity Q] using hQ + rw [← Finset.sum_fiberwise_of_maps_to hmaps] + apply Finset.sum_congr rfl + intro P hP + have hfiber_subset : {Q : Up | down Q = P} ⊆ + (upMultiplicity.support : Set Up) := by + intro Q hQP + change Q ∈ upMultiplicity.support + rw [Finsupp.mem_support_iff, hmultiplicity Q, hQP] + exact Finsupp.mem_support_iff.mp hP + let : Fintype {Q : Up // down Q = P} := + (upMultiplicity.support.finite_toSet.subset hfiber_subset).fintype + let fiberSupport := upMultiplicity.support.filter (fun Q ↦ down Q = P) + let fiberEquiv : {Q : Up // Q ∈ fiberSupport} ≃ + {Q : Up // down Q = P} := + { toFun := fun Q ↦ + ⟨Q.1, (Finset.mem_filter.mp Q.2).2⟩ + invFun := fun Q ↦ + ⟨Q.1, Finset.mem_filter.mpr ⟨hfiber_subset Q.2, Q.2⟩⟩ + left_inv := fun Q ↦ Subtype.ext rfl + right_inv := fun Q ↦ Subtype.ext rfl } + have hcard : fiberSupport.card = + Nat.gcd extensionDegree (baseDegree P) := by + calc + fiberSupport.card = Fintype.card fiberSupport := + (Fintype.card_coe fiberSupport).symm + _ = Fintype.card {Q : Up // down Q = P} := + Fintype.card_congr fiberEquiv + _ = Nat.card {Q : Up // down Q = P} := + Nat.card_eq_fintype_card.symm + _ = Nat.gcd extensionDegree (baseDegree P) := hfiber P + rw [Finset.sum_const_nat] + · rw [hcard] + calc + Nat.gcd extensionDegree (baseDegree P) * + (baseMultiplicity P * + (baseDegree P / Nat.gcd extensionDegree (baseDegree P))) = + baseMultiplicity P * + (Nat.gcd extensionDegree (baseDegree P) * + (baseDegree P / Nat.gcd extensionDegree (baseDegree P))) := by + ac_rfl + _ = baseMultiplicity P * baseDegree P := by + rw [Nat.mul_div_cancel' + (Nat.gcd_dvd_right extensionDegree (baseDegree P))] + · intro Q hQ + simp only [hmultiplicity, hdegree] + rw [(Finset.mem_filter.mp hQ).2] + +end Finsupp diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/FixedPointAverage.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/FixedPointAverage.lean new file mode 100644 index 0000000000..2c957fb752 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/FixedPointAverage.lean @@ -0,0 +1,283 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import Mathlib.GroupTheory.GroupAction.Quotient +public import Mathlib.GroupTheory.Index +public import Mathlib.SetTheory.Cardinal.Finite + +/-! +# Fixed-point averaging for finite transitive actions + +This file isolates the Burnside-counting identity used in the fixed-field +part of the Hasse--Weil argument. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +open scoped BigOperators + +/-- For a nonempty finite transitive `G`-set, the sum over group elements of +the number of fixed points is exactly the order of `G`. -/ +theorem sum_card_fixedBy_eq_card_group_of_isPretransitive + (G X : Type*) [Group G] [Fintype G] [MulAction G X] [Finite X] + [MulAction.IsPretransitive G X] [Nonempty X] : + (∑ g : G, Nat.card (MulAction.fixedBy X g)) = Nat.card G := by + let : Fintype X := Fintype.ofFinite X + let (g : G) : Fintype (MulAction.fixedBy X g) := Fintype.ofFinite _ + let Ω := MulAction.orbitRel.Quotient G X + let : Fintype Ω := Fintype.ofFinite Ω + have hΩ : Fintype.card Ω = 1 := + Fintype.card_eq_one_iff_nonempty_unique.mpr + ((MulAction.pretransitive_iff_unique_quotient_of_nonempty G X).mp inferInstance) + dsimp only [Ω] at hΩ + simp_rw [Nat.card_eq_fintype_card] + rw [MulAction.sum_card_fixedBy_eq_card_orbits_mul_card_group, hΩ, one_mul] + +/-- A finite family of nonempty transitive `G`-sets contributes `|G|` fixed +points per fiber after summing over all group elements. -/ +theorem sum_card_fixedBy_fibers_eq_card_mul_card_group + {ι G : Type*} [Fintype ι] [Group G] [Fintype G] + (X : ι → Type*) [∀ i, MulAction G (X i)] [∀ i, Finite (X i)] + [∀ i, MulAction.IsPretransitive G (X i)] [∀ i, Nonempty (X i)] : + (∑ g : G, ∑ i : ι, Nat.card (MulAction.fixedBy (X i) g)) = + Nat.card ι * Nat.card G := by + classical + rw [Finset.sum_comm] + calc + (∑ i : ι, ∑ g : G, Nat.card (MulAction.fixedBy (X i) g)) = + ∑ _i : ι, Nat.card G := by + apply Finset.sum_congr rfl + intro i _ + exact sum_card_fixedBy_eq_card_group_of_isPretransitive G (X i) + _ = Nat.card ι * Nat.card G := by simp + +/-- If every point stabilizer maps onto a quotient group, then the kernel of +that quotient map still acts transitively. This is the transitivity input for +the Frobenius-coset form of Burnside averaging. -/ +theorem MonoidHom.ker_isPretransitive_of_stabilizer_surjective + {G C X : Type*} [Group G] [Group C] [MulAction G X] + [MulAction.IsPretransitive G X] + (π : G →* C) + (hstab : ∀ x : X, Function.Surjective + (π.comp (MulAction.stabilizer G x).subtype)) : + MulAction.IsPretransitive π.ker X := by + constructor + intro x y + obtain ⟨g, hg⟩ := MulAction.exists_smul_eq G x y + obtain ⟨h, hh⟩ := hstab x (π g) + change π (h : G) = π g at hh + have hfix : (h : G) • x = x := h.2 + have hinv : ((h : MulAction.stabilizer G x) : G)⁻¹ • x = x := by + exact (congrArg (fun z : X => (h : G)⁻¹ • z) hfix.symm).trans + (inv_smul_smul (h : G) x) + refine ⟨⟨g * (h : G)⁻¹, ?_⟩, ?_⟩ + · change π (g * (h : G)⁻¹) = 1 + rw [map_mul, map_inv, hh] + exact mul_inv_cancel (π g) + · change (g * (h : G)⁻¹) • x = y + simpa only [mul_smul, hinv] using hg + +/-- A homomorphism of finite groups is surjective when the source cardinality +is the product of the kernel and target cardinalities. -/ +theorem MonoidHom.surjective_of_card_eq_card_ker_mul_card + {G C : Type*} [Group G] [Group C] [Finite G] [Finite C] + (π : G →* C) + (hcard : Nat.card G = Nat.card π.ker * Nat.card C) : + Function.Surjective π := by + apply MonoidHom.surjective_of_card_ker_le_div + rw [hcard, Nat.mul_comm (Nat.card π.ker) (Nat.card C), + Nat.mul_div_right _ Nat.card_pos] + +/-- Incidence pairs between elements in one quotient fiber and their fixed +points can be transposed into stabilizer elements in that fiber. -/ +def MonoidHom.sigmaFiberFixedByEquivSigmaStabilizerFiber + {G C X : Type*} [Group G] [Group C] [MulAction G X] + (π : G →* C) (c : C) : + (Σ g : π ⁻¹' ({c} : Set C), MulAction.fixedBy X g.1) ≃ + (Σ x : X, + (π.comp (MulAction.stabilizer G x).subtype) ⁻¹' ({c} : Set C)) where + toFun p := + ⟨p.2.1, ⟨⟨p.1.1, p.2.2⟩, p.1.2⟩⟩ + invFun p := + ⟨⟨p.2.1.1, p.2.2⟩, ⟨p.1, p.2.1.2⟩⟩ + left_inv _ := rfl + right_inv _ := rfl + +/-- Stabilizer kernels, summed over points, are the same incidence type as +fixed points of elements in the global kernel. -/ +def MonoidHom.sigmaStabilizerKerEquivSigmaKerFixedBy + {G C X : Type*} [Group G] [Group C] [MulAction G X] + (π : G →* C) : + (Σ x : X, (π.comp (MulAction.stabilizer G x).subtype).ker) ≃ + (Σ g : π.ker, MulAction.fixedBy X g) where + toFun p := + ⟨⟨p.2.1.1, p.2.2⟩, ⟨p.1, p.2.1.2⟩⟩ + invFun p := + ⟨p.2.1, ⟨⟨p.1.1, p.2.2⟩, p.1.2⟩⟩ + left_inv _ := rfl + right_inv _ := rfl + +/-- Coset form of Burnside's lemma. For a finite transitive `G`-set, if the +restriction of `π : G → C` to every point stabilizer is surjective, then the +sum of fixed-point counts over any fiber of `π` is exactly `|ker π|`. + +In Stichtenoth's fixed-field argument, `π` is the constant-field Frobenius +quotient and the fiber is a Frobenius coset. -/ +theorem sum_card_fixedBy_quotientFiber_eq_card_ker + {G C X : Type*} [Group G] [Group C] [Finite G] + [MulAction G X] [Finite X] [MulAction.IsPretransitive G X] + [Nonempty X] + (π : G →* C) + (hstab : ∀ x : X, Function.Surjective + (π.comp (MulAction.stabilizer G x).subtype)) + (c : C) : + letI : Fintype (π ⁻¹' ({c} : Set C)) := Fintype.ofFinite _ + (∑ g : π ⁻¹' ({c} : Set C), + Nat.card (MulAction.fixedBy X g.1)) = Nat.card π.ker := by + classical + let : Fintype G := Fintype.ofFinite G + let : Fintype X := Fintype.ofFinite X + let : Fintype (π ⁻¹' ({c} : Set C)) := Fintype.ofFinite _ + let (x : X) : Fintype + ((π.comp (MulAction.stabilizer G x).subtype) ⁻¹' ({c} : Set C)) := + Fintype.ofFinite _ + let : MulAction.IsPretransitive π.ker X := + MonoidHom.ker_isPretransitive_of_stabilizer_surjective π hstab + let (g : π ⁻¹' ({c} : Set C)) : + Fintype (MulAction.fixedBy X g.1) := Fintype.ofFinite _ + let (g : π.ker) : Fintype (MulAction.fixedBy X g) := Fintype.ofFinite _ + let e₁ := + MonoidHom.sigmaFiberFixedByEquivSigmaStabilizerFiber (X := X) π c + let e₂ : + (Σ x : X, + (π.comp (MulAction.stabilizer G x).subtype) ⁻¹' ({c} : Set C)) ≃ + (Σ x : X, (π.comp (MulAction.stabilizer G x).subtype).ker) := + Equiv.sigmaCongrRight fun x : X => + MonoidHom.fiberEquivKerOfSurjective + (f := π.comp (MulAction.stabilizer G x).subtype) (hstab x) c + let e₃ := MonoidHom.sigmaStabilizerKerEquivSigmaKerFixedBy (X := X) π + calc + (∑ g : π ⁻¹' ({c} : Set C), + Nat.card (MulAction.fixedBy X g.1)) = + Fintype.card (Σ g : π ⁻¹' ({c} : Set C), + MulAction.fixedBy X g.1) := by + simp_rw [Nat.card_eq_fintype_card, Fintype.card_sigma] + _ = Fintype.card (Σ g : π.ker, MulAction.fixedBy X g) := by + exact Fintype.card_congr (e₁.trans (e₂.trans e₃)) + _ = ∑ g : π.ker, Nat.card (MulAction.fixedBy X g) := by + simp_rw [Nat.card_eq_fintype_card, Fintype.card_sigma] + _ = Nat.card π.ker := + sum_card_fixedBy_eq_card_group_of_isPretransitive π.ker X + +/-- Finite-family form of Frobenius-coset Burnside averaging. If the +constant-quotient map is surjective on every stabilizer in every transitive +fiber, then summing the fixed-point counts first over the quotient fiber and +then over the family contributes one copy of `|ker π|` per family member. + +For a function-field cover, the family is the finite set of rational base +places and `X i` is the corresponding restriction fiber of top places. -/ +theorem sum_card_fixedBy_quotientFiber_fibers_eq_card_mul_card_ker + {ι G C : Type*} [Fintype ι] [Group G] [Group C] + [Finite G] + (X : ι → Type*) [∀ i, MulAction G (X i)] [∀ i, Finite (X i)] + [∀ i, MulAction.IsPretransitive G (X i)] [∀ i, Nonempty (X i)] + (π : G →* C) + (hstab : ∀ i (x : X i), Function.Surjective + (π.comp (MulAction.stabilizer G x).subtype)) + (c : C) : + letI : Fintype (π ⁻¹' ({c} : Set C)) := Fintype.ofFinite _ + (∑ g : π ⁻¹' ({c} : Set C), + ∑ i : ι, Nat.card (MulAction.fixedBy (X i) g.1)) = + Nat.card ι * Nat.card π.ker := by + classical + let : Fintype (π ⁻¹' ({c} : Set C)) := Fintype.ofFinite _ + rw [Finset.sum_comm] + calc + (∑ i : ι, ∑ g : π ⁻¹' ({c} : Set C), + Nat.card (MulAction.fixedBy (X i) g.1)) = + ∑ _i : ι, Nat.card π.ker := by + apply Finset.sum_congr rfl + intro i _ + exact sum_card_fixedBy_quotientFiber_eq_card_ker + π (hstab i) c + _ = Nat.card ι * Nat.card π.ker := by simp + +/-- A group action restricted to a fiber of an invariant map. -/ +@[implicit_reducible] +def invariantFiberMulAction + {G X ι : Type*} [Group G] [MulAction G X] + (base : X → ι) (hbase : ∀ (g : G) (x : X), base (g • x) = base x) + (i : ι) : MulAction G {x : X // base x = i} where + smul g x := ⟨g • x.1, (hbase g x.1).trans x.2⟩ + one_smul x := by + apply Subtype.ext + exact one_smul G x.1 + mul_smul g h x := by + apply Subtype.ext + exact mul_smul g h x.1 + +/-- Fixed points of an invariant global type are the disjoint union of the +fixed points in its fibers. This is the nonduplicating assembly used when a +top place is indexed by its restricted base place. -/ +def fixedByEquivSigmaInvariantFiberFixedBy + {G X ι : Type*} [Group G] [MulAction G X] + (base : X → ι) (hbase : ∀ (g : G) (x : X), base (g • x) = base x) + (g : G) : + MulAction.fixedBy X g ≃ + Σ i : ι, + @MulAction.fixedBy G {x : X // base x = i} + _ (invariantFiberMulAction base hbase i) g where + toFun x := + ⟨base x.1, ⟨⟨x.1, rfl⟩, by + apply Subtype.ext + exact x.2⟩⟩ + invFun x := ⟨x.2.1.1, congrArg Subtype.val x.2.2⟩ + left_inv x := by + apply Subtype.ext + rfl + right_inv x := by + rcases x with ⟨i, ⟨⟨x, hxi⟩, hxg⟩⟩ + subst i + rfl + +/-- Cardinal form of the invariant-fiber fixed-point decomposition. -/ +theorem natCard_fixedBy_eq_sum_natCard_invariantFiberFixedBy + {G X ι : Type*} [Group G] [MulAction G X] + [Finite X] [Fintype ι] + (base : X → ι) (hbase : ∀ (g : G) (x : X), base (g • x) = base x) + (g : G) : + Nat.card (MulAction.fixedBy X g) = + ∑ i : ι, + Nat.card + (@MulAction.fixedBy G {x : X // base x = i} + _ (invariantFiberMulAction base hbase i) g) := by + rw [Nat.card_congr + (fixedByEquivSigmaInvariantFiberFixedBy base hbase g), Nat.card_sigma] + +/-- Cardinality form of the Frobenius-coset Burnside lemma. It replaces +stabilizer-surjectivity by the exact decomposition-group order identity used +in the function-field argument. -/ +theorem sum_card_fixedBy_quotientFiber_eq_card_ker_of_stabilizer_card + {G C X : Type*} [Group G] [Group C] [Finite G] [Finite C] + [MulAction G X] [Finite X] [MulAction.IsPretransitive G X] + [Nonempty X] + (π : G →* C) + (hcard : ∀ x : X, + Nat.card (MulAction.stabilizer G x) = + Nat.card (π.comp (MulAction.stabilizer G x).subtype).ker * Nat.card C) + (c : C) : + letI : Fintype (π ⁻¹' ({c} : Set C)) := Fintype.ofFinite _ + (∑ g : π ⁻¹' ({c} : Set C), + Nat.card (MulAction.fixedBy X g.1)) = Nat.card π.ker := by + apply sum_card_fixedBy_quotientFiber_eq_card_ker π (fun x => ?_) c + exact MonoidHom.surjective_of_card_eq_card_ker_mul_card + (π.comp (MulAction.stabilizer G x).subtype) (hcard x) + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/FormalZetaConstantExtensionIdentity.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/FormalZetaConstantExtensionIdentity.lean new file mode 100644 index 0000000000..304db8ec48 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/FormalZetaConstantExtensionIdentity.lean @@ -0,0 +1,207 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.FormalZetaDegreeIndexOne +public import LeanPool.MarkoffModP.BGS.HasseWeil.FormalZetaUniqueness + +/-! +# Formal zeta identity under a constant extension + +Let `N r` be the point count over the degree-`r` extension of the original +constant field. If all nonzero counts occur in degrees divisible by `d`, +and the point counts after the degree-`d` constant extension satisfy + +`N_extended r = N (d * r)`, + +then the exponential point-count zeta series satisfy + +`Z_extended(T^d) = Z(T)^d`. + +The proof does not assume this identity. It reindexes the logarithmic +derivative series and then applies the already proved uniqueness theorem for +normalized formal differential equations. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +noncomputable section + +open scoped PowerSeries + +/-- Reindexing the point-count derivative series under a degree-`d` +constant extension. Only positive indices occur in this series, so the +count and support hypotheses are correspondingly restricted to positive +integers. -/ +theorem subst_pointCountDerivativeSeries_mul_derivative_X_pow + (pointCount extendedPointCount : ℕ → ℕ) (d : ℕ) (hd : 0 < d) + (hcount : ∀ r, 0 < r → + extendedPointCount r = pointCount (d * r)) + (hsupport : ∀ n, 0 < n → ¬ d ∣ n → pointCount n = 0) : + PowerSeries.subst (PowerSeries.X ^ d) + (pointCountDerivativeSeries extendedPointCount) * + PowerSeries.derivative (R := ℂ) (PowerSeries.X ^ d) = + pointCountDerivativeSeries (fun n => d * pointCount n) := by + ext n + rw [PowerSeries.derivative_pow] + simp only [PowerSeries.derivative_X, mul_one] + rw [show PowerSeries.subst (PowerSeries.X ^ d) + (pointCountDerivativeSeries extendedPointCount) * + ((d : PowerSeries ℂ) * PowerSeries.X ^ (d - 1)) = + (d : PowerSeries ℂ) * + (PowerSeries.subst (PowerSeries.X ^ d) + (pointCountDerivativeSeries extendedPointCount) * + PowerSeries.X ^ (d - 1)) by ring] + rw [show (d : PowerSeries ℂ) = PowerSeries.C (d : ℂ) by simp] + simp only [PowerSeries.coeff_C_mul, PowerSeries.coeff_mul_X_pow', + pointCountDerivativeSeries, PowerSeries.coeff_mk] + split_ifs with hn + · rw [PowerSeries.coeff_subst_X_pow hd.ne'] + split_ifs with hdiv + · simp only [PowerSeries.coeff_mk, map_natCast] + rw [hcount _ (Nat.succ_pos _)] + have harg : d * ((n - (d - 1)) / d + 1) = n + 1 := by + rw [mul_add, Nat.mul_div_cancel' hdiv] + omega + rw [harg] + norm_cast + · have hnot : ¬ d ∣ n + 1 := by + intro hplus + apply hdiv + have heq : (n + 1) - d = n - (d - 1) := by omega + simpa only [heq] using Nat.dvd_sub hplus (dvd_refl d) + rw [hsupport (n + 1) (by omega) hnot] + simp + · have hnot : ¬ d ∣ n + 1 := by + intro hplus + have hle : d ≤ n + 1 := Nat.le_of_dvd (by omega) hplus + omega + rw [hsupport (n + 1) (by omega) hnot] + simp + +/-- Multiplying every point count by `d` multiplies its derivative series by +the constant series `d`. -/ +theorem pointCountDerivativeSeries_nat_mul + (pointCount : ℕ → ℕ) (d : ℕ) : + pointCountDerivativeSeries (fun n => d * pointCount n) = + (d : PowerSeries ℂ) * pointCountDerivativeSeries pointCount := by + ext n + rw [show (d : PowerSeries ℂ) = PowerSeries.C (d : ℂ) by simp] + rw [PowerSeries.coeff_C_mul] + simp [pointCountDerivativeSeries] + +/-- The exponential point-count zeta series is normalized at `T = 0`. -/ +@[simp] theorem constantCoeff_formalPointCountZeta (pointCount : ℕ → ℕ) : + PowerSeries.constantCoeff (formalPointCountZeta pointCount) = 1 := by + rw [← PowerSeries.coeff_zero_eq_constantCoeff_apply] + rw [formalPointCountZeta, + PowerSeries.coeff_subst' (pointCountLogSeries_hasSubst pointCount)] + rw [finsum_eq_single _ 0] + · simp [pointCountLogSeries] + · intro e he + simp [pointCountLogSeries, zero_pow he] + +/-- The formal constant-extension zeta identity, with hypotheses restricted +to the positive indices that actually occur in the zeta series. -/ +theorem formalPointCountZeta_hasDegreeExtensionIdentity_of_positive + (pointCount extendedPointCount : ℕ → ℕ) (d : ℕ) (hd : 0 < d) + (hcount : ∀ r, 0 < r → + extendedPointCount r = pointCount (d * r)) + (hsupport : ∀ n, 0 < n → ¬ d ∣ n → pointCount n = 0) : + HasFormalDegreeExtensionZetaIdentity + (formalPointCountZeta pointCount) + (formalPointCountZeta extendedPointCount) d := by + rw [HasFormalDegreeExtensionZetaIdentity] + let F : PowerSeries ℂ := PowerSeries.subst + (PowerSeries.X ^ d : PowerSeries ℂ) + (formalPointCountZeta extendedPointCount) + let G := formalPointCountZeta pointCount ^ d + let A := pointCountDerivativeSeries (fun n => d * pointCount n) + let hs : PowerSeries.HasSubst (PowerSeries.X ^ d : PowerSeries ℂ) := + PowerSeries.HasSubst.X_pow hd.ne' + have hconstant : PowerSeries.constantCoeff F = + PowerSeries.constantCoeff G := by + rw [show F = PowerSeries.subst (PowerSeries.X ^ d) + (formalPointCountZeta extendedPointCount) by rfl] + rw [PowerSeries.constantCoeff_subst_X_pow hd.ne'] + simp [G] + have hF : PowerSeries.derivative (R := ℂ) F = F * A := by + have htrace := + formalPointCountZeta_hasPointCountDerivative extendedPointCount + rw [HasFormalZetaPointCountDerivative] at htrace + calc + PowerSeries.derivative (R := ℂ) F = + PowerSeries.subst (PowerSeries.X ^ d) + (PowerSeries.derivative (R := ℂ) + (formalPointCountZeta extendedPointCount)) * + PowerSeries.derivative (R := ℂ) (PowerSeries.X ^ d) := by + exact PowerSeries.derivative_subst hs + _ = PowerSeries.subst (PowerSeries.X ^ d) + (formalPointCountZeta extendedPointCount * + pointCountDerivativeSeries extendedPointCount) * + PowerSeries.derivative (R := ℂ) (PowerSeries.X ^ d) := by rw [htrace] + _ = F * (PowerSeries.subst (PowerSeries.X ^ d) + (pointCountDerivativeSeries extendedPointCount) * + PowerSeries.derivative (R := ℂ) (PowerSeries.X ^ d)) := by + rw [PowerSeries.subst_mul hs] + simp only [F] + rw [mul_assoc] + _ = F * A := by + rw [subst_pointCountDerivativeSeries_mul_derivative_X_pow + pointCount extendedPointCount d hd hcount hsupport] + have hG : PowerSeries.derivative (R := ℂ) G = G * A := by + have htrace := formalPointCountZeta_hasPointCountDerivative pointCount + rw [HasFormalZetaPointCountDerivative] at htrace + have hpred : d - 1 + 1 = d := + Nat.sub_add_cancel (Nat.one_le_iff_ne_zero.mpr hd.ne') + have hzpow : formalPointCountZeta pointCount ^ (d - 1) * + formalPointCountZeta pointCount = + formalPointCountZeta pointCount ^ d := by + rw [← pow_succ, hpred] + calc + PowerSeries.derivative (R := ℂ) G = + (d : PowerSeries ℂ) * + formalPointCountZeta pointCount ^ (d - 1) * + PowerSeries.derivative (R := ℂ) + (formalPointCountZeta pointCount) := by + exact PowerSeries.derivative_pow + (formalPointCountZeta pointCount) d + _ = (d : PowerSeries ℂ) * + formalPointCountZeta pointCount ^ (d - 1) * + (formalPointCountZeta pointCount * + pointCountDerivativeSeries pointCount) := by rw [htrace] + _ = (formalPointCountZeta pointCount ^ (d - 1) * + formalPointCountZeta pointCount) * + ((d : PowerSeries ℂ) * + pointCountDerivativeSeries pointCount) := by ring + _ = G * A := by + rw [hzpow, ← pointCountDerivativeSeries_nat_mul] + exact powerSeries_eq_of_constantCoeff_eq_of_derivative_eq_mul + F G A hconstant hF hG + +/-- The formal constant-extension zeta identity from all-index count and +degree-support relations. This is the convenient downstream form. -/ +theorem formalPointCountZeta_hasDegreeExtensionIdentity + (pointCount extendedPointCount : ℕ → ℕ) (d : ℕ) (hd : 0 < d) + (hcount : ∀ r, + extendedPointCount r = pointCount (d * r)) + (hsupport : ∀ n, ¬ d ∣ n → pointCount n = 0) : + HasFormalDegreeExtensionZetaIdentity + (formalPointCountZeta pointCount) + (formalPointCountZeta extendedPointCount) d := by + apply formalPointCountZeta_hasDegreeExtensionIdentity_of_positive + pointCount extendedPointCount d hd + · intro r _ + exact hcount r + · intro n _ hn + exact hsupport n hn + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/FormalZetaDegreeIndexOne.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/FormalZetaDegreeIndexOne.lean new file mode 100644 index 0000000000..3673c5512a --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/FormalZetaDegreeIndexOne.lean @@ -0,0 +1,212 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.FormalZetaRationality +public import Mathlib.RingTheory.PowerSeries.Substitution + +/-! +# An ordinary-extension specialization of the degree-index argument + +Suppose a zeta series has the indexed denominator + +`(1 - T^d) (1 - q^d T^d)`. + +After extending the constants by degree `d`, the formal identity is + +`Z_extended(T^d) = Z(T)^d`. + +If the extended zeta series has the ordinary denominator over the enlarged +constant field, clearing denominators gives + +`P_extended(T^d) D(T)^(d - 1) = P(T)^d`. + +For `d > 1`, evaluation at `T = 1` forces `P(1) = 0`. Thus the single, +explicit noncancellation hypothesis `P(1) ≠ 0` forces `d = 1`. This file +contains only that formal algebra. Its ordinary-rationality premise for the +extended zeta series is deliberately stronger than indexed rationality and is +not used to close the geometric F. K. Schmidt argument. The noncircular +indexed-to-indexed theorem is in `FormalZetaDegreeIndexOneIndexed`. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +noncomputable section + +open Polynomial +open scoped PowerSeries + +/-- Polynomial realization of the indexed curve-zeta denominator. -/ +def indexedCurveZetaDenominatorPolynomial (q d : ℕ) : Polynomial ℂ := + (1 - Polynomial.X ^ d) * + (1 - Polynomial.C ((q : ℂ) ^ d) * Polynomial.X ^ d) + +@[simp, norm_cast] theorem coe_indexedCurveZetaDenominatorPolynomial + (q d : ℕ) : + (indexedCurveZetaDenominatorPolynomial q d : PowerSeries ℂ) = + indexedCurveZetaDenominator q d := by + simp only [indexedCurveZetaDenominatorPolynomial, + indexedCurveZetaDenominator, + Polynomial.coe_mul, Polynomial.coe_sub, Polynomial.coe_one, + Polynomial.coe_pow, Polynomial.coe_X, Polynomial.coe_C] + +@[simp] theorem indexedCurveZetaDenominatorPolynomial_eval_one + (q d : ℕ) : + (indexedCurveZetaDenominatorPolynomial q d).eval 1 = 0 := by + simp [indexedCurveZetaDenominatorPolynomial] + +/-- The formal constant-extension identity +`Z_extended(T^d) = Z(T)^d`. + +This is kept as an explicit proposition because proving it for the geometric +closed-place zeta series is a separate part of the constant-extension +argument. -/ +def HasFormalDegreeExtensionZetaIdentity + (Z extendedZeta : PowerSeries ℂ) (d : ℕ) : Prop := + PowerSeries.subst (PowerSeries.X ^ d) extendedZeta = Z ^ d + +/-- Substituting `T^d` into a polynomial power series agrees with polynomial +composition by `T^d`. -/ +theorem subst_coe_eq_coe_comp_X_pow + (Q : Polynomial ℂ) (d : ℕ) (hd : 0 < d) : + PowerSeries.subst (PowerSeries.X ^ d) (Q : PowerSeries ℂ) = + ((Q.comp (Polynomial.X ^ d) : Polynomial ℂ) : PowerSeries ℂ) := by + rw [PowerSeries.subst_coe (PowerSeries.HasSubst.X_pow hd.ne')] + change Polynomial.aeval (PowerSeries.X ^ d) Q = _ + induction Q using Polynomial.induction_on' with + | add p q hp hq => + simp only [map_add, hp, hq, Polynomial.add_comp, Polynomial.coe_add] + | monomial n a => + simp [Polynomial.monomial_comp] + +/-- Substituting `T^d` into the ordinary denominator over the degree-`d` +constant extension produces the indexed denominator over the original +constant field. -/ +theorem subst_curveZetaDenominator_pow + (q d : ℕ) (hd : 0 < d) : + PowerSeries.subst (PowerSeries.X ^ d) + (curveZetaDenominator (q ^ d)) = + indexedCurveZetaDenominator q d := by + let hs : PowerSeries.HasSubst (PowerSeries.X ^ d : PowerSeries ℂ) := + PowerSeries.HasSubst.X_pow hd.ne' + have hsone : PowerSeries.subst (PowerSeries.X ^ d : PowerSeries ℂ) + (1 : PowerSeries ℂ) = (1 : PowerSeries ℂ) := by + rw [← PowerSeries.coe_substAlgHom hs] + exact map_one (PowerSeries.substAlgHom hs) + rw [curveZetaDenominator, PowerSeries.subst_mul hs] + simp only [linearPowerSeriesFactor, + PowerSeries.subst_sub hs, PowerSeries.subst_mul hs, + hsone, PowerSeries.subst_C, PowerSeries.subst_X hs, + indexedCurveZetaDenominator] + norm_num + +/-- Clearing the base and constant-extension denominators leaves exactly +`d - 1` copies of the indexed denominator. + +No noncancellation hypothesis is used here. -/ +theorem clearedNumeratorIdentity_of_indexed_rational_and_degreeExtension + (Z extendedZeta : PowerSeries ℂ) (q d : ℕ) + (P extendedP : Polynomial ℂ) + (hd : 0 < d) + (hindexed : HasIndexedCurveZetaRationalForm Z q d P) + (hextended : HasCurveZetaRationalForm extendedZeta (q ^ d) extendedP) + (hextension : HasFormalDegreeExtensionZetaIdentity Z extendedZeta d) : + extendedP.comp (Polynomial.X ^ d) * + indexedCurveZetaDenominatorPolynomial q d ^ (d - 1) = + P ^ d := by + let hs : PowerSeries.HasSubst (PowerSeries.X ^ d : PowerSeries ℂ) := + PowerSeries.HasSubst.X_pow hd.ne' + have hextendedCleared : + Z ^ d * indexedCurveZetaDenominator q d = + ((extendedP.comp (Polynomial.X ^ d) : Polynomial ℂ) : + PowerSeries ℂ) := by + have h := congrArg + (PowerSeries.subst (PowerSeries.X ^ d : PowerSeries ℂ)) hextended + rw [PowerSeries.subst_mul hs, hextension, + subst_curveZetaDenominator_pow q d hd, + subst_coe_eq_coe_comp_X_pow extendedP d hd] at h + exact h + have hindexedPow : + Z ^ d * indexedCurveZetaDenominator q d ^ d = + ((P ^ d : Polynomial ℂ) : PowerSeries ℂ) := by + have h := congrArg (fun F : PowerSeries ℂ => F ^ d) hindexed + simpa only [mul_pow, Polynomial.coe_pow] using h + have hpred : d - 1 + 1 = d := + Nat.sub_add_cancel (Nat.one_le_iff_ne_zero.mpr hd.ne') + apply Polynomial.coe_injective ℂ + simp only [Polynomial.coe_mul, Polynomial.coe_pow, + coe_indexedCurveZetaDenominatorPolynomial] + calc + ((extendedP.comp (Polynomial.X ^ d) : Polynomial ℂ) : + PowerSeries ℂ) * indexedCurveZetaDenominator q d ^ (d - 1) = + (Z ^ d * indexedCurveZetaDenominator q d) * + indexedCurveZetaDenominator q d ^ (d - 1) := by + rw [hextendedCleared] + _ = Z ^ d * indexedCurveZetaDenominator q d ^ d := by + rw [mul_assoc, mul_comm (indexedCurveZetaDenominator q d), + ← pow_succ, hpred] + _ = (P : PowerSeries ℂ) ^ d := by + simpa only [Polynomial.coe_pow] using hindexedPow + +/-- If `d > 1`, the cleared identity forces the original indexed numerator +to vanish at `T = 1`. This is the formal pole-order mismatch. -/ +theorem indexedNumerator_eval_one_eq_zero_of_clearedIdentity + (q d : ℕ) (P extendedP : Polynomial ℂ) + (hd : 0 < d) (htwo : 2 ≤ d) + (hcleared : + extendedP.comp (Polynomial.X ^ d) * + indexedCurveZetaDenominatorPolynomial q d ^ (d - 1) = + P ^ d) : + P.eval 1 = 0 := by + have hpredPos : 0 < d - 1 := by omega + have heval := congrArg (Polynomial.eval 1) hcleared + have hzero' : 0 = P.eval 1 ^ d := by + simpa only [Polynomial.eval_mul, Polynomial.eval_pow, + indexedCurveZetaDenominatorPolynomial_eval_one, + zero_pow hpredPos.ne', mul_zero] using heval + exact (pow_eq_zero_iff hd.ne').mp hzero'.symm + +/-- Pure polynomial form of the F. K. Schmidt conclusion: numerator +noncancellation at `T = 1` rules out every positive index greater than one. -/ +theorem degreeIndex_eq_one_of_clearedNumeratorIdentity + (q d : ℕ) (P extendedP : Polynomial ℂ) + (hd : 0 < d) (hPone : P.eval 1 ≠ 0) + (hcleared : + extendedP.comp (Polynomial.X ^ d) * + indexedCurveZetaDenominatorPolynomial q d ^ (d - 1) = + P ^ d) : + d = 1 := by + by_contra hne + have htwo : 2 ≤ d := by omega + exact hPone + (indexedNumerator_eval_one_eq_zero_of_clearedIdentity + q d P extendedP hd htwo hcleared) + +/-- Conditional ordinary-extension specialization of the degree-index theorem. + +This algebraic implication is retained as a convenience lemma. The geometric +development does not use its strong ordinary-rationality premise for the +degree-`d` constant extension; it uses the indexed-to-indexed replacement +instead. -/ +theorem degreeIndex_eq_one_of_indexed_rational_and_degreeExtension + (Z extendedZeta : PowerSeries ℂ) (q d : ℕ) + (P extendedP : Polynomial ℂ) + (hd : 0 < d) + (hPone : P.eval 1 ≠ 0) + (hindexed : HasIndexedCurveZetaRationalForm Z q d P) + (hextended : HasCurveZetaRationalForm extendedZeta (q ^ d) extendedP) + (hextension : HasFormalDegreeExtensionZetaIdentity Z extendedZeta d) : + d = 1 := by + apply degreeIndex_eq_one_of_clearedNumeratorIdentity q d P extendedP hd hPone + exact clearedNumeratorIdentity_of_indexed_rational_and_degreeExtension + Z extendedZeta q d P extendedP hd hindexed hextended hextension + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/FormalZetaDegreeIndexOneIndexed.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/FormalZetaDegreeIndexOneIndexed.lean new file mode 100644 index 0000000000..bf5e50488e --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/FormalZetaDegreeIndexOneIndexed.lean @@ -0,0 +1,202 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.FormalZetaDegreeIndexOne + +/-! +# The noncircular indexed F. K. Schmidt argument + +The degree-index argument must not assume that the constant extension already +has divisor-degree index one. This file repairs that dependency: both the +original zeta series and the zeta series after extending constants are allowed +to have indexed denominators. + +After substituting `T ^ d` into the extended indexed denominator, clearing +denominators gives + +`P_extended(T ^ d) D_d(T) ^ d = P(T) ^ d D_(d e)(T)`. + +Here `d` is the original degree index and `e` is the (a priori arbitrary) +degree index after constant extension. If `d > 1`, the derivative at `T = 1` +of the left side vanishes to order at least two. The right side has a simple +zero there when `P(1) ≠ 0`. This contradiction proves `d = 1` without +assuming the conclusion for the constant extension. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +noncomputable section + +open Polynomial +open scoped PowerSeries + +/-- Substituting `T ^ d` into an indexed denominator over the degree-`d` +constant extension multiplies its index by `d`. -/ +theorem subst_indexedCurveZetaDenominator + (q d e : ℕ) (hd : 0 < d) : + PowerSeries.subst (PowerSeries.X ^ d) + (indexedCurveZetaDenominator (q ^ d) e) = + indexedCurveZetaDenominator q (d * e) := by + let hs : PowerSeries.HasSubst (PowerSeries.X ^ d : PowerSeries ℂ) := + PowerSeries.HasSubst.X_pow hd.ne' + have hsone : PowerSeries.subst (PowerSeries.X ^ d : PowerSeries ℂ) + (1 : PowerSeries ℂ) = (1 : PowerSeries ℂ) := by + rw [← PowerSeries.coe_substAlgHom hs] + exact map_one (PowerSeries.substAlgHom hs) + rw [indexedCurveZetaDenominator, PowerSeries.subst_mul hs] + simp only [PowerSeries.subst_sub hs, PowerSeries.subst_mul hs, + PowerSeries.subst_pow hs, hsone, PowerSeries.subst_C, + PowerSeries.subst_X hs, indexedCurveZetaDenominator] + congr 1 + · ring + · simp only [Nat.cast_pow, pow_mul] + rfl + +/-- Clearing two indexed rational forms across a degree-`d` constant +extension. In particular, no ordinary rational form is assumed for the +extended curve. -/ +theorem clearedNumeratorIdentity_of_two_indexed_rationalForms + (Z extendedZeta : PowerSeries ℂ) (q d e : ℕ) + (P extendedP : Polynomial ℂ) + (hd : 0 < d) + (hindexed : HasIndexedCurveZetaRationalForm Z q d P) + (hextended : + HasIndexedCurveZetaRationalForm extendedZeta (q ^ d) e extendedP) + (hextension : HasFormalDegreeExtensionZetaIdentity Z extendedZeta d) : + extendedP.comp (Polynomial.X ^ d) * + indexedCurveZetaDenominatorPolynomial q d ^ d = + P ^ d * indexedCurveZetaDenominatorPolynomial q (d * e) := by + let hs : PowerSeries.HasSubst (PowerSeries.X ^ d : PowerSeries ℂ) := + PowerSeries.HasSubst.X_pow hd.ne' + have hextendedCleared : + Z ^ d * indexedCurveZetaDenominator q (d * e) = + ((extendedP.comp (Polynomial.X ^ d) : Polynomial ℂ) : + PowerSeries ℂ) := by + have h := congrArg + (PowerSeries.subst (PowerSeries.X ^ d : PowerSeries ℂ)) hextended + rw [PowerSeries.subst_mul hs, hextension, + subst_indexedCurveZetaDenominator q d e hd, + subst_coe_eq_coe_comp_X_pow extendedP d hd] at h + exact h + have hindexedPow : + Z ^ d * indexedCurveZetaDenominator q d ^ d = + ((P ^ d : Polynomial ℂ) : PowerSeries ℂ) := by + have h := congrArg (fun F : PowerSeries ℂ => F ^ d) hindexed + simpa only [mul_pow, Polynomial.coe_pow] using h + apply Polynomial.coe_injective ℂ + simp only [Polynomial.coe_mul, Polynomial.coe_pow, + coe_indexedCurveZetaDenominatorPolynomial] + calc + ((extendedP.comp (Polynomial.X ^ d) : Polynomial ℂ) : + PowerSeries ℂ) * indexedCurveZetaDenominator q d ^ d = + (Z ^ d * indexedCurveZetaDenominator q (d * e)) * + indexedCurveZetaDenominator q d ^ d := by rw [hextendedCleared] + _ = (Z ^ d * indexedCurveZetaDenominator q d ^ d) * + indexedCurveZetaDenominator q (d * e) := by ring + _ = ((P ^ d : Polynomial ℂ) : PowerSeries ℂ) * + indexedCurveZetaDenominator q (d * e) := by rw [hindexedPow] + _ = (P : PowerSeries ℂ) ^ d * + indexedCurveZetaDenominator q (d * e) := by + simp only [Polynomial.coe_pow] + +/-- The indexed denominator has a simple zero at `T = 1`; this is its exact +derivative there. -/ +theorem indexedCurveZetaDenominatorPolynomial_derivative_eval_one + (q n : ℕ) : + (indexedCurveZetaDenominatorPolynomial q n).derivative.eval 1 = + -(n : ℂ) * (1 - (q : ℂ) ^ n) := by + rw [indexedCurveZetaDenominatorPolynomial, Polynomial.derivative_mul] + simp only [Polynomial.derivative_sub, Polynomial.derivative_one, + Polynomial.derivative_pow, Polynomial.derivative_X, + Polynomial.eval_add, Polynomial.eval_mul, Polynomial.eval_sub, + Polynomial.eval_one, Polynomial.eval_zero, Polynomial.eval_C, + Polynomial.eval_pow, Polynomial.eval_X] + ring + +/-- Over a nontrivial finite field, every positive-index zeta denominator has +a nonzero derivative at `T = 1`. -/ +theorem indexedCurveZetaDenominatorPolynomial_derivative_eval_one_ne_zero + (q n : ℕ) (hq : 1 < q) (hn : 0 < n) : + (indexedCurveZetaDenominatorPolynomial q n).derivative.eval 1 ≠ 0 := by + rw [indexedCurveZetaDenominatorPolynomial_derivative_eval_one] + apply mul_ne_zero + · exact neg_ne_zero.mpr (Nat.cast_ne_zero.mpr hn.ne') + · apply sub_ne_zero.mpr + norm_cast + exact (Nat.one_lt_pow hn.ne' hq).ne + +/-- At `T = 1`, a product containing at least two copies of the indexed +denominator has zero derivative. -/ +theorem derivative_eval_one_mul_indexedDenominator_pow_eq_zero + (Q : Polynomial ℂ) (q d : ℕ) (htwo : 2 ≤ d) : + (Q * indexedCurveZetaDenominatorPolynomial q d ^ d).derivative.eval 1 = 0 := by + rw [Polynomial.derivative_mul] + simp only [Polynomial.eval_add, Polynomial.eval_mul, + Polynomial.eval_pow, indexedCurveZetaDenominatorPolynomial_eval_one, + zero_pow (by omega : d ≠ 0), mul_zero, + Polynomial.derivative_pow, Polynomial.eval_C] + rw [zero_pow (by omega : d - 1 ≠ 0)] + ring + +/-- At `T = 1`, differentiating a numerator times one indexed denominator +leaves the numerator value times the derivative of that denominator. -/ +theorem derivative_eval_one_pow_mul_indexedDenominator + (P : Polynomial ℂ) (q d n : ℕ) : + (P ^ d * indexedCurveZetaDenominatorPolynomial q n).derivative.eval 1 = + P.eval 1 ^ d * + (indexedCurveZetaDenominatorPolynomial q n).derivative.eval 1 := by + rw [Polynomial.derivative_mul] + simp only [Polynomial.eval_add, Polynomial.eval_mul, + Polynomial.eval_pow, indexedCurveZetaDenominatorPolynomial_eval_one, + mul_zero, zero_add] + +/-- Pure polynomial form of the noncircular F. K. Schmidt conclusion. -/ +theorem degreeIndex_eq_one_of_twoIndexed_clearedNumeratorIdentity + (q d e : ℕ) (P extendedP : Polynomial ℂ) + (hq : 1 < q) (hd : 0 < d) (he : 0 < e) + (hPone : P.eval 1 ≠ 0) + (hcleared : + extendedP.comp (Polynomial.X ^ d) * + indexedCurveZetaDenominatorPolynomial q d ^ d = + P ^ d * indexedCurveZetaDenominatorPolynomial q (d * e)) : + d = 1 := by + by_contra hne + have htwo : 2 ≤ d := by omega + have hderiv := + congrArg (fun R : Polynomial ℂ => R.derivative.eval 1) hcleared + rw [derivative_eval_one_mul_indexedDenominator_pow_eq_zero + (extendedP.comp (Polynomial.X ^ d)) q d htwo, + derivative_eval_one_pow_mul_indexedDenominator P q d (d * e)] at hderiv + have hdenom : + (indexedCurveZetaDenominatorPolynomial q (d * e)).derivative.eval 1 ≠ 0 := + indexedCurveZetaDenominatorPolynomial_derivative_eval_one_ne_zero + q (d * e) hq (Nat.mul_pos hd he) + exact (mul_ne_zero (pow_ne_zero d hPone) hdenom) hderiv.symm + +/-- Noncircular formal F. K. Schmidt theorem. The extended zeta series may +have any positive degree index `e`; only indexed rationality is required. -/ +theorem degreeIndex_eq_one_of_two_indexed_rationalForms_and_degreeExtension + (Z extendedZeta : PowerSeries ℂ) (q d e : ℕ) + (P extendedP : Polynomial ℂ) + (hq : 1 < q) (hd : 0 < d) (he : 0 < e) + (hPone : P.eval 1 ≠ 0) + (hindexed : HasIndexedCurveZetaRationalForm Z q d P) + (hextended : + HasIndexedCurveZetaRationalForm extendedZeta (q ^ d) e extendedP) + (hextension : HasFormalDegreeExtensionZetaIdentity Z extendedZeta d) : + d = 1 := by + apply degreeIndex_eq_one_of_twoIndexed_clearedNumeratorIdentity + q d e P extendedP hq hd he hPone + exact clearedNumeratorIdentity_of_two_indexed_rationalForms + Z extendedZeta q d e P extendedP hd hindexed hextended hextension + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/FormalZetaEuler.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/FormalZetaEuler.lean new file mode 100644 index 0000000000..e88b56e6fb --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/FormalZetaEuler.lean @@ -0,0 +1,117 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.FormalZetaRationality +public import LeanPool.MarkoffModP.BGS.HasseWeil.FormalZetaUniqueness + +/-! +# Euler recurrences for a formal effective-divisor zeta series + +This file packages the exact formal boundary between the remaining +closed-place combinatorics and zeta rationality. A coefficient sequence `A` +satisfies Euler's recurrence when marking one degree unit in an effective +divisor gives the convolution with extension point counts. That recurrence +is precisely the coefficient form of `Z' = Z * pointCountDerivativeSeries`. + +Together with the proved uniqueness and eventual-recurrence results, this +turns the two explicit coefficient identities into either the indexed or the +standard polynomial zeta numerator. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +noncomputable section + +/-- The formal power series with effective-divisor counts as coefficients. -/ +def effectiveDivisorCountSeries (A : ℕ → ℕ) : PowerSeries ℂ := + PowerSeries.mk fun n => (A n : ℂ) + +/-- Euler's marked-effective-divisor recurrence. The antidiagonal form is +exactly the multiplication formula for formal power series. -/ +def HasEffectiveDivisorPointCountRecurrence + (A pointCount : ℕ → ℕ) : Prop := + ∀ n : ℕ, + A (n + 1) * (n + 1) = + ∑ ij ∈ Finset.HasAntidiagonal.antidiagonal n, + A ij.1 * pointCount (ij.2 + 1) + +/-- Euler's recurrence is the formal point-count derivative identity. -/ +theorem effectiveDivisorCountSeries_hasPointCountDerivative + (A pointCount : ℕ → ℕ) + (hrec : HasEffectiveDivisorPointCountRecurrence A pointCount) : + HasFormalZetaPointCountDerivative + (effectiveDivisorCountSeries A) pointCount := by + rw [HasFormalZetaPointCountDerivative] + apply PowerSeries.ext + intro n + rw [PowerSeries.coeff_derivative, PowerSeries.coeff_mul] + simp only [effectiveDivisorCountSeries, PowerSeries.coeff_mk, + pointCountDerivativeSeries] + exact_mod_cast hrec n + +/-- A normalized effective-divisor series satisfying Euler's recurrence is +the canonical exponential point-count zeta series. -/ +theorem effectiveDivisorCountSeries_eq_formalPointCountZeta + (A pointCount : ℕ → ℕ) (hA0 : A 0 = 1) + (hrec : HasEffectiveDivisorPointCountRecurrence A pointCount) : + effectiveDivisorCountSeries A = formalPointCountZeta pointCount := by + apply eq_formalPointCountZeta_of_normalized_pointCountDerivative + · simp [effectiveDivisorCountSeries, hA0] + · exact effectiveDivisorCountSeries_hasPointCountDerivative A pointCount hrec + +/-- Euler's recurrence and an eventual step-one divisor recurrence produce +the normalized standard curve-zeta numerator for the point-count series. -/ +theorem exists_formalPointCountZeta_rational_of_effectiveDivisor_recurrences + (A pointCount : ℕ → ℕ) (q N : ℕ) + (hA0 : A 0 = 1) + (hEuler : HasEffectiveDivisorPointCountRecurrence A pointCount) + (hlinear : ∀ n, N ≤ n → + (A (n + 2) : ℂ) = + ((q : ℂ) + 1) * (A (n + 1) : ℂ) - (q : ℂ) * (A n : ℂ)) : + ∃ P : Polynomial ℂ, + P.coeff 0 = 1 ∧ + HasCurveZetaRationalForm (formalPointCountZeta pointCount) q P := by + obtain ⟨P, hP0, hP⟩ := + exists_normalized_curveZetaRationalForm_of_eventual_coeff_recurrence + (effectiveDivisorCountSeries A) q N + (by simp [effectiveDivisorCountSeries, hA0]) + (by simpa [effectiveDivisorCountSeries] using hlinear) + refine ⟨P, hP0, ?_⟩ + rw [← effectiveDivisorCountSeries_eq_formalPointCountZeta + A pointCount hA0 hEuler] + exact hP + +/-- The corresponding indexed conclusion before the divisor-degree index is +proved to be one. -/ +theorem exists_formalPointCountZeta_indexed_rational_of_effectiveDivisor_recurrences + (A pointCount : ℕ → ℕ) (q d N : ℕ) (hd : 0 < d) + (hA0 : A 0 = 1) + (hEuler : HasEffectiveDivisorPointCountRecurrence A pointCount) + (hlinear : ∀ n, N ≤ n → + (A (n + 2 * d) : ℂ) = + ((q : ℂ) ^ d + 1) * (A (n + d) : ℂ) - + (q : ℂ) ^ d * (A n : ℂ)) : + ∃ P : Polynomial ℂ, + P.coeff 0 = 1 ∧ + HasIndexedCurveZetaRationalForm + (formalPointCountZeta pointCount) q d P := by + obtain ⟨P, hP0, hP⟩ := + exists_normalized_indexedCurveZetaRationalForm_of_eventual_coeff_recurrence + (effectiveDivisorCountSeries A) q d N hd + (by simp [effectiveDivisorCountSeries, hA0]) + (by simpa [effectiveDivisorCountSeries] using hlinear) + refine ⟨P, hP0, ?_⟩ + rw [← effectiveDivisorCountSeries_eq_formalPointCountZeta + A pointCount hA0 hEuler] + exact hP + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/FormalZetaEulerDegree.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/FormalZetaEulerDegree.lean new file mode 100644 index 0000000000..ece4c482ff --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/FormalZetaEulerDegree.lean @@ -0,0 +1,75 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.FormalZetaEuler +public import LeanPool.MarkoffModP.BGS.HasseWeil.FormalZetaRationalityDegree + +/-! +# Euler composition with numerator-degree bounds + +This file combines the marked-divisor Euler recurrence with the truncation +degree bounds. It is the degree-aware version of the compositions in +`FormalZetaEuler`. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +noncomputable section + +/-- Euler's recurrence and an eventual step-one divisor recurrence produce +a normalized standard numerator of degree `< N + 2`. -/ +theorem exists_formalPointCountZeta_rational_with_natDegree_lt_of_effectiveDivisor_recurrences + (A pointCount : ℕ → ℕ) (q N : ℕ) + (hA0 : A 0 = 1) + (hEuler : HasEffectiveDivisorPointCountRecurrence A pointCount) + (hlinear : ∀ n, N ≤ n → + (A (n + 2) : ℂ) = + ((q : ℂ) + 1) * (A (n + 1) : ℂ) - (q : ℂ) * (A n : ℂ)) : + ∃ P : Polynomial ℂ, + P.coeff 0 = 1 ∧ P.natDegree < N + 2 ∧ + HasCurveZetaRationalForm (formalPointCountZeta pointCount) q P := by + obtain ⟨P, hP0, hPdegree, hP⟩ := + exists_normalized_curveZetaRationalForm_with_natDegree_lt + (effectiveDivisorCountSeries A) q N + (by simp [effectiveDivisorCountSeries, hA0]) + (by simpa [effectiveDivisorCountSeries] using hlinear) + refine ⟨P, hP0, hPdegree, ?_⟩ + rw [← effectiveDivisorCountSeries_eq_formalPointCountZeta + A pointCount hA0 hEuler] + exact hP + +/-- Before proving the divisor index is one, the same composition gives an +indexed numerator of degree `< N + 2d`. -/ +theorem + exists_formalPointCountZeta_indexed_rational_with_natDegree_lt_of_effectiveDivisor_recurrences + (A pointCount : ℕ → ℕ) (q d N : ℕ) (hd : 0 < d) + (hA0 : A 0 = 1) + (hEuler : HasEffectiveDivisorPointCountRecurrence A pointCount) + (hlinear : ∀ n, N ≤ n → + (A (n + 2 * d) : ℂ) = + ((q : ℂ) ^ d + 1) * (A (n + d) : ℂ) - + (q : ℂ) ^ d * (A n : ℂ)) : + ∃ P : Polynomial ℂ, + P.coeff 0 = 1 ∧ P.natDegree < N + 2 * d ∧ + HasIndexedCurveZetaRationalForm + (formalPointCountZeta pointCount) q d P := by + obtain ⟨P, hP0, hPdegree, hP⟩ := + exists_normalized_indexedCurveZetaRationalForm_with_natDegree_lt + (effectiveDivisorCountSeries A) q d N hd + (by simp [effectiveDivisorCountSeries, hA0]) + (by simpa [effectiveDivisorCountSeries] using hlinear) + refine ⟨P, hP0, hPdegree, ?_⟩ + rw [← effectiveDivisorCountSeries_eq_formalPointCountZeta + A pointCount hA0 hEuler] + exact hP + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/FormalZetaHasseBound.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/FormalZetaHasseBound.lean new file mode 100644 index 0000000000..eebbb210bf --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/FormalZetaHasseBound.lean @@ -0,0 +1,79 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.FormalZetaTrace + +/-! +# The Hasse bound from formal zeta rationality + +This module records the final analytic composition in the zeta-function +route. Once the canonical formal point-count zeta series has curve-rational +form with numerator `P`, and the point-count error over the even extensions +has square-root growth, the base-field Hasse bound follows with coefficient +`P.natDegree`. + +The two hypotheses are deliberately explicit. In particular, this theorem +does not construct the zeta numerator or prove the geometric extension-point +estimate. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +open Filter Asymptotics + +noncomputable section + +/-- Formal point-count zeta rationality and a two-sided square-root estimate +over the even extensions imply the base-field Hasse bound. -/ +theorem abs_pointCount_sub_card_sub_one_le_of_formalPointCountZeta_rational_and_evenError_isBigO + (q : ℕ) (pointCount : ℕ → ℕ) (P : Polynomial ℂ) + (hP0 : P.coeff 0 = 1) + (hrational : + HasCurveZetaRationalForm (formalPointCountZeta pointCount) q P) + (herror : + (fun n : ℕ ↦ + (pointCount (2 * n) : ℂ) - (q : ℂ) ^ (2 * n) - 1) =O[atTop] + fun n : ℕ ↦ (q : ℝ) ^ n) : + |(pointCount 1 : ℝ) - q - 1| ≤ + (P.natDegree : ℝ) * Real.sqrt q := by + apply abs_pointCount_sub_card_sub_one_le_of_zetaNumerator_and_evenError_isBigO + q pointCount P + · exact + hasZetaNumeratorPointCountFormula_of_formalPointCountZeta_rational + q pointCount P hP0 hrational + · exact herror + +/-- Formal point-count zeta rationality and a two-sided square-root estimate +along any fixed positive divisible-even subsequence imply the base-field +Hasse bound. -/ +theorem + abs_pointCount_sub_card_sub_one_le_of_formalPointCountZeta_rational_and_divisibleEvenError_isBigO + (q δ : ℕ) (pointCount : ℕ → ℕ) (P : Polynomial ℂ) + (hq : 0 < q) (hδ : 0 < δ) + (hP0 : P.coeff 0 = 1) + (hrational : + HasCurveZetaRationalForm (formalPointCountZeta pointCount) q P) + (herror : + (fun n : ℕ ↦ + (pointCount (2 * δ * n) : ℂ) - (q : ℂ) ^ (2 * δ * n) - 1) =O[atTop] + fun n : ℕ ↦ ((q : ℝ) ^ δ) ^ n) : + |(pointCount 1 : ℝ) - q - 1| ≤ + (P.natDegree : ℝ) * Real.sqrt q := by + apply + abs_pointCount_sub_card_sub_one_le_of_zetaNumerator_and_divisibleEvenError_isBigO + q δ pointCount P hq hδ + · exact + hasZetaNumeratorPointCountFormula_of_formalPointCountZeta_rational + q pointCount P hP0 hrational + · exact herror + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/FormalZetaRationality.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/FormalZetaRationality.lean new file mode 100644 index 0000000000..d6f49b1e7c --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/FormalZetaRationality.lean @@ -0,0 +1,183 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.FormalZetaTrace +public import Mathlib.RingTheory.PowerSeries.Trunc + +/-! +# Formal zeta rationality from an eventual coefficient recurrence + +This file isolates the algebraic last step in the divisor-count proof of +zeta rationality. If the coefficients of a power series eventually satisfy +the recurrence with characteristic polynomial `(1 - T)(1 - qT)`, then +multiplication by that denominator has finite support. Its truncation is +therefore an actual polynomial numerator. + +No geometric or point-count hypothesis is used here. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +noncomputable section + +/-- Expanded form of the standard curve-zeta denominator. -/ +theorem curveZetaDenominator_eq_quadratic (q : ℕ) : + curveZetaDenominator q = + 1 - PowerSeries.C ((q : ℂ) + 1) * PowerSeries.X + + PowerSeries.C (q : ℂ) * PowerSeries.X ^ 2 := by + simp [curveZetaDenominator, linearPowerSeriesFactor] + ring + +/-- The coefficient of `Z(T)(1-T)(1-qT)` in terms of three consecutive +coefficients of `Z`. -/ +theorem coeff_mul_curveZetaDenominator_succ_succ + (Z : PowerSeries ℂ) (q n : ℕ) : + PowerSeries.coeff (n + 2) (Z * curveZetaDenominator q) = + PowerSeries.coeff (n + 2) Z - + ((q : ℂ) + 1) * PowerSeries.coeff (n + 1) Z + + (q : ℂ) * PowerSeries.coeff n Z := by + rw [curveZetaDenominator_eq_quadratic] + rw [show Z * (1 - PowerSeries.C ((q : ℂ) + 1) * PowerSeries.X + + PowerSeries.C (q : ℂ) * PowerSeries.X ^ 2) = + Z - PowerSeries.C ((q : ℂ) + 1) * (Z * PowerSeries.X) + + PowerSeries.C (q : ℂ) * (Z * PowerSeries.X ^ 2) by ring] + rw [map_add, map_sub] + simp only [PowerSeries.coeff_C_mul, PowerSeries.coeff_mul_X_pow'] + simp + +/-- A power series whose coefficients vanish from `N` onward is exactly its +`N`-term polynomial truncation. -/ +theorem powerSeries_eq_coe_trunc_of_coeff_eq_zero + {R : Type*} [CommSemiring R] (F : PowerSeries R) (N : ℕ) + (hzero : ∀ n, N ≤ n → PowerSeries.coeff n F = 0) : + F = (PowerSeries.trunc N F : PowerSeries R) := by + ext n + rw [Polynomial.coeff_coe, PowerSeries.coeff_trunc] + split_ifs with hn + · rfl + · exact hzero n (Nat.le_of_not_gt hn) + +/-- An eventual recurrence with roots `1` and `q` produces a polynomial +curve-zeta numerator. -/ +theorem exists_curveZetaRationalForm_of_eventual_coeff_recurrence + (Z : PowerSeries ℂ) (q N : ℕ) + (hrec : ∀ n, N ≤ n → + PowerSeries.coeff (n + 2) Z = + ((q : ℂ) + 1) * PowerSeries.coeff (n + 1) Z - + (q : ℂ) * PowerSeries.coeff n Z) : + ∃ P : Polynomial ℂ, HasCurveZetaRationalForm Z q P := by + let F := Z * curveZetaDenominator q + have hzero : ∀ m, N + 2 ≤ m → PowerSeries.coeff m F = 0 := by + intro m hm + obtain ⟨n, rfl⟩ := Nat.exists_eq_add_of_le hm + have hn : N ≤ N + n := Nat.le_add_right N n + rw [show N + 2 + n = (N + n) + 2 by omega] + rw [coeff_mul_curveZetaDenominator_succ_succ] + rw [hrec (N + n) hn] + ring + refine ⟨PowerSeries.trunc (N + 2) F, ?_⟩ + exact powerSeries_eq_coe_trunc_of_coeff_eq_zero F (N + 2) hzero + +/-- Normalized constant coefficient is preserved by the recurrence +construction. -/ +theorem exists_normalized_curveZetaRationalForm_of_eventual_coeff_recurrence + (Z : PowerSeries ℂ) (q N : ℕ) + (hZ0 : PowerSeries.constantCoeff Z = 1) + (hrec : ∀ n, N ≤ n → + PowerSeries.coeff (n + 2) Z = + ((q : ℂ) + 1) * PowerSeries.coeff (n + 1) Z - + (q : ℂ) * PowerSeries.coeff n Z) : + ∃ P : Polynomial ℂ, + P.coeff 0 = 1 ∧ HasCurveZetaRationalForm Z q P := by + obtain ⟨P, hP⟩ := + exists_curveZetaRationalForm_of_eventual_coeff_recurrence Z q N hrec + refine ⟨P, ?_, hP⟩ + have hconstant := congrArg PowerSeries.constantCoeff hP + simpa [HasCurveZetaRationalForm, hZ0] using hconstant.symm + +/-- The denominator that occurs before proving that the divisor-degree index +is one. An index `d` permits nonzero divisor coefficients only along residue +classes modulo `d`. -/ +def indexedCurveZetaDenominator (q d : ℕ) : PowerSeries ℂ := + (1 - PowerSeries.X ^ d) * + (1 - PowerSeries.C ((q : ℂ) ^ d) * PowerSeries.X ^ d) + +/-- Rationality with a possibly nontrivial divisor-degree index. -/ +def HasIndexedCurveZetaRationalForm + (Z : PowerSeries ℂ) (q d : ℕ) (P : Polynomial ℂ) : Prop := + Z * indexedCurveZetaDenominator q d = (P : PowerSeries ℂ) + +/-- Coefficient expansion for the indexed denominator. -/ +theorem coeff_mul_indexedCurveZetaDenominator + (Z : PowerSeries ℂ) (q d n : ℕ) : + PowerSeries.coeff (n + 2 * d) + (Z * indexedCurveZetaDenominator q d) = + PowerSeries.coeff (n + 2 * d) Z - + ((q : ℂ) ^ d + 1) * PowerSeries.coeff (n + d) Z + + (q : ℂ) ^ d * PowerSeries.coeff n Z := by + rw [indexedCurveZetaDenominator] + rw [show Z * ((1 - PowerSeries.X ^ d) * + (1 - PowerSeries.C ((q : ℂ) ^ d) * PowerSeries.X ^ d)) = + Z - (Z * PowerSeries.X ^ d) - + PowerSeries.C ((q : ℂ) ^ d) * (Z * PowerSeries.X ^ d) + + PowerSeries.C ((q : ℂ) ^ d) * + (Z * PowerSeries.X ^ (2 * d)) by ring] + rw [map_add, map_sub, map_sub] + simp only [PowerSeries.coeff_C_mul, PowerSeries.coeff_mul_X_pow'] + rw [ite_eq_left (by omega : d ≤ n + 2 * d), + ite_eq_left (by omega : 2 * d ≤ n + 2 * d)] + simp only [show n + 2 * d - d = n + d by omega, + show n + 2 * d - 2 * d = n by omega] + ring + +/-- An eventual step-`d` recurrence produces an indexed polynomial zeta +numerator. The case `d = 1` is the standard curve denominator above. -/ +theorem exists_indexedCurveZetaRationalForm_of_eventual_coeff_recurrence + (Z : PowerSeries ℂ) (q d N : ℕ) + (hrec : ∀ n, N ≤ n → + PowerSeries.coeff (n + 2 * d) Z = + ((q : ℂ) ^ d + 1) * PowerSeries.coeff (n + d) Z - + (q : ℂ) ^ d * PowerSeries.coeff n Z) : + ∃ P : Polynomial ℂ, HasIndexedCurveZetaRationalForm Z q d P := by + let F := Z * indexedCurveZetaDenominator q d + have hzero : ∀ m, N + 2 * d ≤ m → PowerSeries.coeff m F = 0 := by + intro m hm + obtain ⟨n, rfl⟩ := Nat.exists_eq_add_of_le hm + have hn : N ≤ N + n := Nat.le_add_right N n + rw [show N + 2 * d + n = (N + n) + 2 * d by omega] + rw [coeff_mul_indexedCurveZetaDenominator] + rw [hrec (N + n) hn] + ring + refine ⟨PowerSeries.trunc (N + 2 * d) F, ?_⟩ + exact powerSeries_eq_coe_trunc_of_coeff_eq_zero F (N + 2 * d) hzero + +/-- Normalized indexed rationality. -/ +theorem exists_normalized_indexedCurveZetaRationalForm_of_eventual_coeff_recurrence + (Z : PowerSeries ℂ) (q d N : ℕ) + (hd : 0 < d) + (hZ0 : PowerSeries.constantCoeff Z = 1) + (hrec : ∀ n, N ≤ n → + PowerSeries.coeff (n + 2 * d) Z = + ((q : ℂ) ^ d + 1) * PowerSeries.coeff (n + d) Z - + (q : ℂ) ^ d * PowerSeries.coeff n Z) : + ∃ P : Polynomial ℂ, + P.coeff 0 = 1 ∧ HasIndexedCurveZetaRationalForm Z q d P := by + obtain ⟨P, hP⟩ := + exists_indexedCurveZetaRationalForm_of_eventual_coeff_recurrence + Z q d N hrec + refine ⟨P, ?_, hP⟩ + have hconstant := congrArg PowerSeries.constantCoeff hP + simpa [HasIndexedCurveZetaRationalForm, indexedCurveZetaDenominator, hZ0, + Nat.ne_of_gt hd] + using hconstant.symm + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/FormalZetaRationalityDegree.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/FormalZetaRationalityDegree.lean new file mode 100644 index 0000000000..48cac779f6 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/FormalZetaRationalityDegree.lean @@ -0,0 +1,94 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.FormalZetaRationality + +/-! +# Degree bounds in formal zeta rationality + +The recurrence construction in `FormalZetaRationality` chooses its numerator +as a finite truncation. This file exposes the resulting degree bound, which +is needed to turn a Riemann--Roch threshold into a uniform Hasse coefficient. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +noncomputable section + +/-- A normalized eventual step-one recurrence produces a numerator whose +degree is strictly smaller than the truncation length `N + 2`. -/ +theorem exists_normalized_curveZetaRationalForm_with_natDegree_lt + (Z : PowerSeries ℂ) (q N : ℕ) + (hZ0 : PowerSeries.constantCoeff Z = 1) + (hrec : ∀ n, N ≤ n → + PowerSeries.coeff (n + 2) Z = + ((q : ℂ) + 1) * PowerSeries.coeff (n + 1) Z - + (q : ℂ) * PowerSeries.coeff n Z) : + ∃ P : Polynomial ℂ, + P.coeff 0 = 1 ∧ P.natDegree < N + 2 ∧ + HasCurveZetaRationalForm Z q P := by + let F := Z * curveZetaDenominator q + have hzero : ∀ m, N + 2 ≤ m → PowerSeries.coeff m F = 0 := by + intro m hm + obtain ⟨n, rfl⟩ := Nat.exists_eq_add_of_le hm + have hn : N ≤ N + n := Nat.le_add_right N n + rw [show N + 2 + n = (N + n) + 2 by omega] + rw [coeff_mul_curveZetaDenominator_succ_succ] + rw [hrec (N + n) hn] + ring + let P := PowerSeries.trunc (N + 2) F + have hform : HasCurveZetaRationalForm Z q P := by + exact powerSeries_eq_coe_trunc_of_coeff_eq_zero F (N + 2) hzero + have hdegree : P.natDegree < N + 2 := by + simpa [P, show N + 2 = (N + 1) + 1 by omega] using + (PowerSeries.natDegree_trunc_lt F (N + 1)) + have hconstant := congrArg PowerSeries.constantCoeff hform + have hP0 : P.coeff 0 = 1 := by + simpa [HasCurveZetaRationalForm, hZ0] using hconstant.symm + exact ⟨P, hP0, hdegree, hform⟩ + +/-- The indexed recurrence likewise exposes the exact truncation-degree +bound `N + 2d`. -/ +theorem exists_normalized_indexedCurveZetaRationalForm_with_natDegree_lt + (Z : PowerSeries ℂ) (q d N : ℕ) (hd : 0 < d) + (hZ0 : PowerSeries.constantCoeff Z = 1) + (hrec : ∀ n, N ≤ n → + PowerSeries.coeff (n + 2 * d) Z = + ((q : ℂ) ^ d + 1) * PowerSeries.coeff (n + d) Z - + (q : ℂ) ^ d * PowerSeries.coeff n Z) : + ∃ P : Polynomial ℂ, + P.coeff 0 = 1 ∧ P.natDegree < N + 2 * d ∧ + HasIndexedCurveZetaRationalForm Z q d P := by + let F := Z * indexedCurveZetaDenominator q d + have hzero : ∀ m, N + 2 * d ≤ m → PowerSeries.coeff m F = 0 := by + intro m hm + obtain ⟨n, rfl⟩ := Nat.exists_eq_add_of_le hm + have hn : N ≤ N + n := Nat.le_add_right N n + rw [show N + 2 * d + n = (N + n) + 2 * d by omega] + rw [coeff_mul_indexedCurveZetaDenominator] + rw [hrec (N + n) hn] + ring + let P := PowerSeries.trunc (N + 2 * d) F + have hform : HasIndexedCurveZetaRationalForm Z q d P := by + exact powerSeries_eq_coe_trunc_of_coeff_eq_zero F (N + 2 * d) hzero + have hlength : 0 < N + 2 * d := by omega + have hdegree : P.natDegree < N + 2 * d := by + have hpred : N + 2 * d - 1 + 1 = N + 2 * d := by omega + simpa [P, hpred] using + (PowerSeries.natDegree_trunc_lt F (N + 2 * d - 1)) + have hconstant := congrArg PowerSeries.constantCoeff hform + have hP0 : P.coeff 0 = 1 := by + simpa [HasIndexedCurveZetaRationalForm, indexedCurveZetaDenominator, + hZ0, Nat.ne_of_gt hd] using hconstant.symm + exact ⟨P, hP0, hdegree, hform⟩ + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/FormalZetaTrace.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/FormalZetaTrace.lean new file mode 100644 index 0000000000..73a5263215 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/FormalZetaTrace.lean @@ -0,0 +1,283 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.ZetaNumeratorSpectral +public import Mathlib.RingTheory.PowerSeries.Derivative +public import Mathlib.RingTheory.PowerSeries.Exp +public import Mathlib.RingTheory.PowerSeries.Inverse +public import Mathlib.RingTheory.PowerSeries.Substitution +public import Mathlib.RingTheory.PowerSeries.WellKnown + +/-! +# Formal logarithmic derivatives of zeta functions + +Recover point-count coefficients from logarithmic derivatives of formal zeta series and their +linear factors. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +open Polynomial +open scoped BigOperators PowerSeries + +noncomputable section + +def negativeXLogDerivative (f : PowerSeries ℂ) : PowerSeries ℂ := + -PowerSeries.X * PowerSeries.derivative (R := ℂ) f * f⁻¹ + +def linearPowerSeriesFactor (a : ℂ) : PowerSeries ℂ := + 1 - PowerSeries.C a * PowerSeries.X + +@[simp] theorem constantCoeff_linearPowerSeriesFactor (a : ℂ) : + PowerSeries.constantCoeff (linearPowerSeriesFactor a) = 1 := by + simp [linearPowerSeriesFactor] + +theorem linearPowerSeriesFactor_inv (a : ℂ) : + (linearPowerSeriesFactor a)⁻¹ = + PowerSeries.rescale a (PowerSeries.mk 1) := by + apply (PowerSeries.inv_eq_iff_mul_eq_one (by simp)).2 + have h := congrArg (PowerSeries.rescale a) + (PowerSeries.mk_one_mul_one_sub_eq_one ℂ) + simpa [linearPowerSeriesFactor, mul_comm] using h + +theorem derivative_linearPowerSeriesFactor (a : ℂ) : + PowerSeries.derivative (R := ℂ) (linearPowerSeriesFactor a) = -PowerSeries.C a := by + simp only [linearPowerSeriesFactor, map_sub, PowerSeries.derivative_one, + Derivation.leibniz, PowerSeries.derivative_X, PowerSeries.derivative_C, + smul_eq_mul, mul_one, mul_zero, add_zero, zero_sub] + +@[simp] theorem coeff_negativeXLogDerivative_linearPowerSeriesFactor + (a : ℂ) (n : ℕ) : + PowerSeries.coeff (n + 1) + (negativeXLogDerivative (linearPowerSeriesFactor a)) = a ^ (n + 1) := by + rw [negativeXLogDerivative, linearPowerSeriesFactor_inv] + rw [derivative_linearPowerSeriesFactor] + simp only [neg_mul_neg] + rw [mul_assoc, PowerSeries.coeff_succ_X_mul, + PowerSeries.coeff_C_mul, PowerSeries.coeff_rescale, PowerSeries.coeff_mk] + simp [pow_succ, mul_comm] + +theorem inverse_mul_of_constantCoeff_ne_zero + (f g : PowerSeries ℂ) + (hf : PowerSeries.constantCoeff f ≠ 0) + (hg : PowerSeries.constantCoeff g ≠ 0) : + (f * g)⁻¹ = f⁻¹ * g⁻¹ := by + apply (PowerSeries.inv_eq_iff_mul_eq_one (by simpa using mul_ne_zero hf hg)).2 + calc + (f⁻¹ * g⁻¹) * (f * g) = (f⁻¹ * f) * (g⁻¹ * g) := by ring + _ = 1 := by rw [PowerSeries.inv_mul_cancel f hf, + PowerSeries.inv_mul_cancel g hg, one_mul] + +theorem negativeXLogDerivative_mul + (f g : PowerSeries ℂ) + (hf : PowerSeries.constantCoeff f ≠ 0) + (hg : PowerSeries.constantCoeff g ≠ 0) : + negativeXLogDerivative (f * g) = + negativeXLogDerivative f + negativeXLogDerivative g := by + unfold negativeXLogDerivative + rw [Derivation.leibniz, + inverse_mul_of_constantCoeff_ne_zero f g hf hg] + simp only [smul_eq_mul] + calc + -PowerSeries.X * (f * PowerSeries.derivative g + + g * PowerSeries.derivative f) * (f⁻¹ * g⁻¹) = + (-PowerSeries.X * PowerSeries.derivative g * g⁻¹) * (f * f⁻¹) + + (-PowerSeries.X * PowerSeries.derivative f * f⁻¹) * (g * g⁻¹) := by ring + _ = -PowerSeries.X * PowerSeries.derivative f * f⁻¹ + + -PowerSeries.X * PowerSeries.derivative g * g⁻¹ := by + rw [PowerSeries.mul_inv_cancel f hf, PowerSeries.mul_inv_cancel g hg] + ring + +theorem negativeXLogDerivative_prod_linearPowerSeriesFactor + {I : Type*} [Fintype I] + (a : I → ℂ) : + negativeXLogDerivative (∏ i, linearPowerSeriesFactor (a i)) = + ∑ i, negativeXLogDerivative (linearPowerSeriesFactor (a i)) := by + classical + refine Finset.induction_on (Finset.univ : Finset I) ?_ ?_ + · simp [negativeXLogDerivative] + · intro i s hi hs + rw [Finset.prod_insert hi, Finset.sum_insert hi, + negativeXLogDerivative_mul] + · rw [hs] + · simp + · simp + +theorem coeff_negativeXLogDerivative_prod_linearPowerSeriesFactor + {I : Type*} [Fintype I] + (a : I → ℂ) (n : ℕ) : + PowerSeries.coeff (n + 1) + (negativeXLogDerivative (∏ i, linearPowerSeriesFactor (a i))) = + ∑ i, a i ^ (n + 1) := by + classical + rw [negativeXLogDerivative_prod_linearPowerSeriesFactor] + simp + +/-- The formal series whose coefficient at `n` is the point count over the +extension of degree `n + 1`. -/ +def pointCountDerivativeSeries (pointCount : ℕ → ℕ) : PowerSeries ℂ := + PowerSeries.mk fun n => (pointCount (n + 1) : ℂ) + +/-- Euler's logarithmic-derivative identity for a point-count zeta series. -/ +def HasFormalZetaPointCountDerivative + (Z : PowerSeries ℂ) (pointCount : ℕ → ℕ) : Prop := + PowerSeries.derivative (R := ℂ) Z = Z * pointCountDerivativeSeries pointCount + +/-- The formal logarithm `∑ₙ Nₙ Tⁿ/n` attached to extension point counts. -/ +def pointCountLogSeries (pointCount : ℕ → ℕ) : PowerSeries ℂ := + PowerSeries.mk fun n => + if n = 0 then 0 else (pointCount n : ℂ) / (n : ℂ) + +@[simp] theorem constantCoeff_pointCountLogSeries (pointCount : ℕ → ℕ) : + PowerSeries.constantCoeff (pointCountLogSeries pointCount) = 0 := by + simp [pointCountLogSeries] + +theorem pointCountLogSeries_hasSubst (pointCount : ℕ → ℕ) : + PowerSeries.HasSubst (pointCountLogSeries pointCount) := + PowerSeries.HasSubst.of_constantCoeff_zero + (constantCoeff_pointCountLogSeries pointCount) + +/-- The formal exponential definition +`exp(∑ₙ Nₙ Tⁿ/n)` of the point-count zeta series. -/ +def formalPointCountZeta (pointCount : ℕ → ℕ) : PowerSeries ℂ := + (PowerSeries.exp ℂ).subst (pointCountLogSeries pointCount) + +theorem derivative_pointCountLogSeries (pointCount : ℕ → ℕ) : + PowerSeries.derivative (R := ℂ) (pointCountLogSeries pointCount) = + pointCountDerivativeSeries pointCount := by + ext n + rw [PowerSeries.coeff_derivative] + simp [pointCountLogSeries, pointCountDerivativeSeries, + Nat.cast_add, Nat.cast_one] + field_simp + +theorem formalPointCountZeta_hasPointCountDerivative + (pointCount : ℕ → ℕ) : + HasFormalZetaPointCountDerivative + (formalPointCountZeta pointCount) pointCount := by + rw [HasFormalZetaPointCountDerivative, formalPointCountZeta, + PowerSeries.derivative_subst (pointCountLogSeries_hasSubst pointCount), + PowerSeries.derivative_exp, derivative_pointCountLogSeries] + +/-- The denominator `(1 - T)(1 - qT)` of the zeta function of a curve over +the field with `q` elements. -/ +def curveZetaDenominator (q : ℕ) : PowerSeries ℂ := + linearPowerSeriesFactor 1 * linearPowerSeriesFactor (q : ℂ) + +@[simp] theorem constantCoeff_curveZetaDenominator (q : ℕ) : + PowerSeries.constantCoeff (curveZetaDenominator q) = 1 := by + simp [curveZetaDenominator] + +/-- Rationality in the normalized curve form. -/ +def HasCurveZetaRationalForm + (Z : PowerSeries ℂ) (q : ℕ) (P : Polynomial ℂ) : Prop := + Z * curveZetaDenominator q = (P : PowerSeries ℂ) + +theorem coeff_negativeXLogDerivative_polynomial + (P : Polynomial ℂ) (hP0 : P.coeff 0 = 1) (n : ℕ) : + PowerSeries.coeff (n + 1) + (negativeXLogDerivative (P : PowerSeries ℂ)) = + ∑ i, reciprocalRootParameter P i ^ (n + 1) := by + let a : Fin P.natDegree → ℂ := reciprocalRootParameter P + have hfactor : P = ∏ i, (1 - Polynomial.C (a i) * Polynomial.X) := by + simpa only [a] using polynomial_eq_prod_reciprocalRootParameter P hP0 + have hfactorSeries := + congrArg (Polynomial.coeToPowerSeries.ringHom : + Polynomial ℂ →+* PowerSeries ℂ) hfactor + have hseries : + (P : PowerSeries ℂ) = + ∏ i, linearPowerSeriesFactor (a i) := by + simpa [linearPowerSeriesFactor] using hfactorSeries + rw [hseries] + simpa only [a] using + coeff_negativeXLogDerivative_prod_linearPowerSeriesFactor a n + +theorem coeff_negativeXLogDerivative_curveZetaDenominator + (q n : ℕ) : + PowerSeries.coeff (n + 1) + (negativeXLogDerivative (curveZetaDenominator q)) = + 1 + (q : ℂ) ^ (n + 1) := by + rw [curveZetaDenominator, + negativeXLogDerivative_mul _ _ (by simp) (by simp), map_add] + rw [coeff_negativeXLogDerivative_linearPowerSeriesFactor, + coeff_negativeXLogDerivative_linearPowerSeriesFactor] + simp + +theorem coeff_negativeXLogDerivative_of_pointCountDerivative + (Z : PowerSeries ℂ) (pointCount : ℕ → ℕ) + (hZ0 : PowerSeries.constantCoeff Z = 1) + (htrace : HasFormalZetaPointCountDerivative Z pointCount) + (n : ℕ) : + PowerSeries.coeff (n + 1) (negativeXLogDerivative Z) = + -(pointCount (n + 1) : ℂ) := by + have hZne : PowerSeries.constantCoeff Z ≠ 0 := by simp [hZ0] + have hcancel := PowerSeries.mul_inv_cancel Z hZne + have hseries : + negativeXLogDerivative Z = + -PowerSeries.X * pointCountDerivativeSeries pointCount := by + rw [negativeXLogDerivative, htrace] + calc + -PowerSeries.X * + (Z * pointCountDerivativeSeries pointCount) * Z⁻¹ = + (-PowerSeries.X * pointCountDerivativeSeries pointCount) * (Z * Z⁻¹) := by + ring + _ = -PowerSeries.X * pointCountDerivativeSeries pointCount := by + rw [hcancel, mul_one] + rw [hseries] + simp [pointCountDerivativeSeries] + +/-- A normalized rational zeta series satisfying Euler's derivative identity +produces the reciprocal-root extension point-count formula. -/ +theorem hasZetaNumeratorPointCountFormula_of_formalZeta + (q : ℕ) (pointCount : ℕ → ℕ) + (Z : PowerSeries ℂ) (P : Polynomial ℂ) + (hP0 : P.coeff 0 = 1) + (htrace : HasFormalZetaPointCountDerivative Z pointCount) + (hrational : HasCurveZetaRationalForm Z q P) : + HasZetaNumeratorPointCountFormula q pointCount P := by + have hZ0 : PowerSeries.constantCoeff Z = 1 := by + have h := congrArg PowerSeries.constantCoeff hrational + simpa [HasCurveZetaRationalForm, hP0] using h + have hZne : PowerSeries.constantCoeff Z ≠ 0 := by simp [hZ0] + have hDne : PowerSeries.constantCoeff (curveZetaDenominator q) ≠ 0 := by simp + have hlog : + negativeXLogDerivative Z + + negativeXLogDerivative (curveZetaDenominator q) = + negativeXLogDerivative (P : PowerSeries ℂ) := by + rw [← negativeXLogDerivative_mul Z (curveZetaDenominator q) hZne hDne] + exact congrArg negativeXLogDerivative hrational + refine ⟨hP0, ?_⟩ + intro m hm + obtain ⟨n, rfl⟩ := Nat.exists_eq_succ_of_ne_zero (by omega : m ≠ 0) + have hcoeff := congrArg (PowerSeries.coeff (n + 1)) hlog + rw [map_add, + coeff_negativeXLogDerivative_of_pointCountDerivative Z pointCount hZ0 htrace, + coeff_negativeXLogDerivative_curveZetaDenominator, + coeff_negativeXLogDerivative_polynomial P hP0] at hcoeff + rw [← sum_reciprocalRootParameter_pow] + simp only [pow_succ] at hcoeff ⊢ + linear_combination -hcoeff + +/-- For the canonical exponential point-count zeta series, rationality in +curve form is the only remaining premise needed for the numerator trace +formula. -/ +theorem hasZetaNumeratorPointCountFormula_of_formalPointCountZeta_rational + (q : ℕ) (pointCount : ℕ → ℕ) (P : Polynomial ℂ) + (hP0 : P.coeff 0 = 1) + (hrational : + HasCurveZetaRationalForm (formalPointCountZeta pointCount) q P) : + HasZetaNumeratorPointCountFormula q pointCount P := + hasZetaNumeratorPointCountFormula_of_formalZeta q pointCount + (formalPointCountZeta pointCount) P hP0 + (formalPointCountZeta_hasPointCountDerivative pointCount) hrational + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/FormalZetaUniqueness.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/FormalZetaUniqueness.lean new file mode 100644 index 0000000000..ca74fdc1d3 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/FormalZetaUniqueness.lean @@ -0,0 +1,89 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.FormalZetaTrace + +/-! +# Uniqueness of a normalized formal point-count zeta series + +Over the complex numbers, the differential equation + +`Z' = Z * A` + +together with the constant coefficient of `Z` determines a formal power +series uniquely. This gives the formal bridge needed after proving Euler's +coefficient identity for an effective-divisor zeta series: that series is the +canonical exponential `formalPointCountZeta`. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +noncomputable section + +/-- Two formal power series with the same constant coefficient and the same +logarithmic-derivative equation are equal. -/ +theorem powerSeries_eq_of_constantCoeff_eq_of_derivative_eq_mul + (F G A : PowerSeries ℂ) + (hconstant : PowerSeries.constantCoeff F = PowerSeries.constantCoeff G) + (hF : PowerSeries.derivative (R := ℂ) F = F * A) + (hG : PowerSeries.derivative (R := ℂ) G = G * A) : + F = G := by + apply PowerSeries.ext + intro n + induction n using Nat.strong_induction_on with + | h n ih => + cases n with + | zero => + simpa only [PowerSeries.coeff_zero_eq_constantCoeff_apply] using hconstant + | succ n => + have hFc := congrArg (PowerSeries.coeff n) hF + have hGc := congrArg (PowerSeries.coeff n) hG + rw [PowerSeries.coeff_derivative] at hFc hGc + have hmul : PowerSeries.coeff n (F * A) = + PowerSeries.coeff n (G * A) := by + rw [PowerSeries.coeff_mul, PowerSeries.coeff_mul] + apply Finset.sum_congr rfl + intro ij hij + have hle : ij.1 ≤ n := + Finset.HasAntidiagonal.antidiagonal.fst_le hij + rw [show PowerSeries.coeff ij.1 F = PowerSeries.coeff ij.1 G by + exact ih ij.1 (Nat.lt_succ_of_le hle)] + have hcast : (n : ℂ) + 1 ≠ 0 := by + exact_mod_cast Nat.succ_ne_zero n + apply mul_right_cancel₀ hcast + calc + PowerSeries.coeff (n + 1) F * ((n : ℂ) + 1) = + PowerSeries.coeff n (F * A) := hFc + _ = PowerSeries.coeff n (G * A) := hmul + _ = PowerSeries.coeff (n + 1) G * ((n : ℂ) + 1) := hGc.symm + +/-- A normalized series satisfying Euler's point-count derivative identity +is the canonical exponential point-count zeta series. -/ +theorem eq_formalPointCountZeta_of_normalized_pointCountDerivative + (Z : PowerSeries ℂ) (pointCount : ℕ → ℕ) + (hZ0 : PowerSeries.constantCoeff Z = 1) + (htrace : HasFormalZetaPointCountDerivative Z pointCount) : + Z = formalPointCountZeta pointCount := by + apply powerSeries_eq_of_constantCoeff_eq_of_derivative_eq_mul + Z (formalPointCountZeta pointCount) (pointCountDerivativeSeries pointCount) + · rw [hZ0, ← PowerSeries.coeff_zero_eq_constantCoeff_apply] + rw [formalPointCountZeta, + PowerSeries.coeff_subst' + (pointCountLogSeries_hasSubst pointCount)] + rw [finsum_eq_single _ 0] + · simp [pointCountLogSeries] + · intro d hd + simp [pointCountLogSeries, zero_pow hd] + · exact htrace + · exact formalPointCountZeta_hasPointCountDerivative pointCount + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/FrobeniusPlaceCardinality.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/FrobeniusPlaceCardinality.lean new file mode 100644 index 0000000000..68f257b130 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/FrobeniusPlaceCardinality.lean @@ -0,0 +1,216 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.FinitePlaceFrobeniusFiber + +/-! +# Cardinalities of Frobenius place stabilizers + +This file supplies the local cardinality identities required by the +Frobenius-coset form of Burnside averaging. + +Suppose a place of a relative Galois extension has absolute degree `[S : C]` +and lies above a degree-one place. Multiplicativity of place degree then says +that its relative inertia degree is `[S : C]`. The decomposition-group formula +and the finite-field identity + +`|Aut_C(S)| = [S : C]` + +show that its stabilizer has cardinality + +`|restricted quotient kernel| * |Aut_C(S)|`, + +provided the restricted quotient kernel is identified with inertia. Both +finite places and places above infinity are covered, first for the underlying +decomposition groups and then in the restriction-fiber actions used by +`sum_card_fixedBy_quotientFiber_eq_card_ker_of_stabilizer_card`. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +noncomputable section + +open BGS.CorvajaZannier + +variable (C : Type*) [Field C] [Fintype C] + [DecidableEq C] [DecidableEq (RatFunc C)] +variable (M : Type*) [Field M] [Algebra (RatFunc C) M] + [FiniteDimensional (RatFunc C) M] + [Algebra.IsSeparable (RatFunc C) M] +variable (L : Type*) [Field L] [Algebra (RatFunc C) L] + [FiniteDimensional (RatFunc C) L] + [Algebra.IsSeparable (RatFunc C) L] + [Algebra M L] [IsScalarTower (RatFunc C) M L] + [IsGalois M L] +variable (S : Type*) [Field S] [Algebra C S] + [FiniteDimensional C S] [IsGalois C S] + +omit [Fintype C] in +/-- A finite place of degree `[S : C]` above a degree-one place has the +decomposition-group cardinality required by Frobenius-coset averaging, once +the restricted constant quotient kernel is identified with inertia. -/ +theorem finitePlaceDecompositionGroup_card_eq_restrictedKernel_mul_card_constantAut [Finite C] + (π : Gal(L/M) →* (S ≃ₐ[C] S)) + (Q : FiniteExtensionFinitePlace C L) + (hTop : finiteExtensionPlaceDegree C L (.inl Q) = Module.finrank C S) + (hBase : finiteExtensionPlaceDegree C M + (.inl (finitePlaceUnder C M L Q)) = 1) + (hker : + letI := finiteIntegralClosureGalAction C M L + (π.comp (finitePlaceDecompositionGroup C M L Q).subtype).ker = + Q.asIdeal.inertia (finitePlaceDecompositionGroup C M L Q)) : + Nat.card (finitePlaceDecompositionGroup C M L Q) = + Nat.card + (π.comp (finitePlaceDecompositionGroup C M L Q).subtype).ker * + Nat.card (S ≃ₐ[C] S) := by + let : Fintype C := Fintype.ofFinite C + let := finiteIntegralClosureGalAction C M L + have hrelative : + finitePlaceRelativeInertiaDeg C M L Q = Module.finrank C S := by + have hdegree := + finiteExtensionPlaceDegree_inl_eq_mul_relativeInertiaDeg C M L Q + rw [hTop, hBase, one_mul] at hdegree + exact hdegree.symm + have hkernel : + Nat.card + (π.comp (finitePlaceDecompositionGroup C M L Q).subtype).ker = + finitePlaceRelativeRamificationIdx C M L Q := by + rw [hker] + change Nat.card + ((Q.asIdeal.inertia Gal(L/M)).subgroupOf + (finitePlaceDecompositionGroup C M L Q)) = _ + calc + Nat.card + ((Q.asIdeal.inertia Gal(L/M)).subgroupOf + (finitePlaceDecompositionGroup C M L Q)) = + Nat.card (Q.asIdeal.inertia Gal(L/M)) := + Nat.card_congr + (Subgroup.subgroupOfEquivOfLe + (Ideal.inertia_le_stabilizer (M := Gal(L/M)) Q.asIdeal)).toEquiv + _ = finitePlaceRelativeRamificationIdx C M L Q := + finitePlaceInertiaGroup_card_eq_ramificationIdx C M L Q + rw [finitePlaceDecompositionGroup_card_eq_ramificationIdx_mul_inertiaDeg, + ← hkernel, hrelative, ← IsGalois.card_aut_eq_finrank C S] + +omit [Fintype C] in +/-- The corresponding decomposition-group cardinality identity for a place +above infinity. -/ +theorem infinityPlaceDecompositionGroup_card_eq_restrictedKernel_mul_card_constantAut [Finite C] + (π : Gal(L/M) →* (S ≃ₐ[C] S)) + (Q : FiniteExtensionInfinityPlace C L) + (hTop : finiteExtensionPlaceDegree C L (.inr Q) = Module.finrank C S) + (hBase : finiteExtensionPlaceDegree C M + (.inr (infinityPlaceUnder C M L Q)) = 1) + (hker : + letI := infinityIntegralClosureGalAction C M L + (π.comp (infinityPlaceDecompositionGroup C M L Q).subtype).ker = + Q.1.inertia (infinityPlaceDecompositionGroup C M L Q)) : + Nat.card (infinityPlaceDecompositionGroup C M L Q) = + Nat.card + (π.comp (infinityPlaceDecompositionGroup C M L Q).subtype).ker * + Nat.card (S ≃ₐ[C] S) := by + let : Fintype C := Fintype.ofFinite C + let := infinityIntegralClosureGalAction C M L + have hrelative : + infinityPlaceRelativeInertiaDeg C M L Q = Module.finrank C S := by + have hdegree := + finiteExtensionPlaceDegree_inr_eq_mul_relativeInertiaDeg C M L Q + rw [hTop, hBase, one_mul] at hdegree + exact hdegree.symm + have hkernel : + Nat.card + (π.comp (infinityPlaceDecompositionGroup C M L Q).subtype).ker = + infinityPlaceRelativeRamificationIdx C M L Q := by + rw [hker] + change Nat.card + ((Q.1.inertia Gal(L/M)).subgroupOf + (infinityPlaceDecompositionGroup C M L Q)) = _ + calc + Nat.card + ((Q.1.inertia Gal(L/M)).subgroupOf + (infinityPlaceDecompositionGroup C M L Q)) = + Nat.card (Q.1.inertia Gal(L/M)) := + Nat.card_congr + (Subgroup.subgroupOfEquivOfLe + (Ideal.inertia_le_stabilizer (M := Gal(L/M)) Q.1)).toEquiv + _ = infinityPlaceRelativeRamificationIdx C M L Q := + infinityPlaceInertiaGroup_card_eq_ramificationIdx C M L Q + rw [infinityPlaceDecompositionGroup_card_eq_ramificationIdx_mul_inertiaDeg, + ← hkernel, hrelative, ← IsGalois.card_aut_eq_finrank C S] + +omit [Fintype C] in +/-- Restriction-fiber form of the finite-place cardinality identity. Its +conclusion is exactly the stabilizer hypothesis consumed by the cardinality +form of Frobenius-coset Burnside averaging. -/ +theorem finitePlaceUnderFiber_stabilizer_card_eq_restrictedKernel_mul_card_constantAut [Finite C] + (π : Gal(L/M) →* (S ≃ₐ[C] S)) + (P : FiniteExtensionFinitePlace C M) + (Q : FinitePlaceUnderFiber C M L P) + (hTop : finiteExtensionPlaceDegree C L (.inl Q.1) = Module.finrank C S) + (hBase : finiteExtensionPlaceDegree C M (.inl P) = 1) + (hker : + letI := finiteIntegralClosureGalAction C M L + letI := finitePlaceUnderFiberGalAction C M L P + (π.comp (MulAction.stabilizer Gal(L/M) Q).subtype).ker = + Q.1.asIdeal.inertia (MulAction.stabilizer Gal(L/M) Q)) : + letI := finiteIntegralClosureGalAction C M L + letI := finitePlaceUnderFiberGalAction C M L P + Nat.card (MulAction.stabilizer Gal(L/M) Q) = + Nat.card + (π.comp (MulAction.stabilizer Gal(L/M) Q).subtype).ker * + Nat.card (S ≃ₐ[C] S) := by + let : Fintype C := Fintype.ofFinite C + let := finiteIntegralClosureGalAction C M L + let := finitePlaceUnderFiberGalAction C M L P + have hBase' : finiteExtensionPlaceDegree C M + (.inl (finitePlaceUnder C M L Q.1)) = 1 := by + rw [Q.2] + exact hBase + have hstab := + finitePlaceUnderFiber_stabilizer_eq_decompositionGroup C M L P Q + rw [hstab] at hker ⊢ + exact finitePlaceDecompositionGroup_card_eq_restrictedKernel_mul_card_constantAut + C M L S π Q.1 hTop hBase' hker + +omit [Fintype C] in +/-- Restriction-fiber form of the infinity-place cardinality identity. -/ +theorem infinityPlaceUnderFiber_stabilizer_card_eq_restrictedKernel_mul_card_constantAut [Finite C] + (π : Gal(L/M) →* (S ≃ₐ[C] S)) + (P : FiniteExtensionInfinityPlace C M) + (Q : InfinityPlaceUnderFiber C M L P) + (hTop : finiteExtensionPlaceDegree C L (.inr Q.1) = Module.finrank C S) + (hBase : finiteExtensionPlaceDegree C M (.inr P) = 1) + (hker : + letI := infinityIntegralClosureGalAction C M L + letI := infinityPlaceUnderFiberGalAction C M L P + (π.comp (MulAction.stabilizer Gal(L/M) Q).subtype).ker = + Q.1.1.inertia (MulAction.stabilizer Gal(L/M) Q)) : + letI := infinityIntegralClosureGalAction C M L + letI := infinityPlaceUnderFiberGalAction C M L P + Nat.card (MulAction.stabilizer Gal(L/M) Q) = + Nat.card + (π.comp (MulAction.stabilizer Gal(L/M) Q).subtype).ker * + Nat.card (S ≃ₐ[C] S) := by + let : Fintype C := Fintype.ofFinite C + let := infinityIntegralClosureGalAction C M L + let := infinityPlaceUnderFiberGalAction C M L P + have hBase' : finiteExtensionPlaceDegree C M + (.inr (infinityPlaceUnder C M L Q.1)) = 1 := by + rw [Q.2] + exact hBase + have hstab := + infinityPlaceUnderFiber_stabilizer_eq_decompositionGroup C M L P Q + rw [hstab] at hker ⊢ + exact infinityPlaceDecompositionGroup_card_eq_restrictedKernel_mul_card_constantAut + C M L S π Q.1 hTop hBase' hker + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/FrobeniusRestriction.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/FrobeniusRestriction.lean new file mode 100644 index 0000000000..b1c6eaf73a --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/FrobeniusRestriction.lean @@ -0,0 +1,280 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.PoleDivisor +public import LeanPool.MarkoffModP.BGS.HasseWeil.TensorRestriction +public import Mathlib.FieldTheory.Finite.Basic +public import Mathlib.Tactic + +/-! +# Frobenius restriction over a finite constant field + +Let `K` be a finite field and put `q = #K`. The map +`x ↦ x ^ (q ^ n)` on any commutative `K`-algebra is the `n`-th iterate of +the relative Frobenius. In particular it is a genuine `K`-algebra +endomorphism: no Frobenius-twisted scalar action is needed. + +This file packages that endomorphism as an algebra homomorphism and as a +linear map, specializes the two tensor-restriction orientations, and records +the principal-divisor and pole-budget identities needed by the Stepanov +restriction argument. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +open BGS.CorvajaZannier +open scoped TensorProduct nonZeroDivisors Polynomial + +noncomputable section + +section FiniteFieldAlgebra + +variable (K A : Type*) [Field K] [Fintype K] + [CommRing A] [Algebra K A] + +/-- The `n`-fold relative Frobenius on a commutative algebra over the finite +field `K`. Its underlying function is `x ↦ x ^ ((#K) ^ n)`. -/ +def powCardAlgHom (n : ℕ) : A →ₐ[K] A := + FiniteField.frobeniusAlgHom K A ^ n + +@[simp] +theorem powCardAlgHom_apply (n : ℕ) (x : A) : + powCardAlgHom K A n x = x ^ (Fintype.card K ^ n) := by + simp only [powCardAlgHom, AlgHom.coe_pow, + FiniteField.coe_frobeniusAlgHom, pow_iterate] + +/-- The `K`-linear map underlying the `n`-fold relative Frobenius. -/ +def powCardLinearMap (n : ℕ) : A →ₗ[K] A := + (powCardAlgHom K A n).toLinearMap + +@[simp] +theorem powCardLinearMap_apply (n : ℕ) (x : A) : + powCardLinearMap K A n x = x ^ (Fintype.card K ^ n) := by + simp [powCardLinearMap] + +@[simp] +theorem powCardLinearMap_add (n : ℕ) (x y : A) : + powCardLinearMap K A n (x + y) = + powCardLinearMap K A n x + powCardLinearMap K A n y := by + exact map_add (powCardLinearMap K A n) x y + +@[simp] +theorem powCardLinearMap_smul (n : ℕ) (c : K) (x : A) : + powCardLinearMap K A n (c • x) = c • powCardLinearMap K A n x := by + exact map_smul (powCardLinearMap K A n) c x + +@[simp] +theorem powCardLinearMap_mul (n : ℕ) (x y : A) : + powCardLinearMap K A n (x * y) = + powCardLinearMap K A n x * powCardLinearMap K A n y := by + exact map_mul (powCardAlgHom K A n) x y + +variable {K A : Type*} [Field K] [Fintype K] + [CommRing A] [Algebra K A] +variable {R S T : Submodule K A} + +/-- The tensor restriction induced by `(x, y) ↦ x * y ^ ((#K) ^ n)`. -/ +def powCardTensorRestriction + (n : ℕ) + (hmul : ∀ x : R, ∀ y : S, + (x : A) * (y : A) ^ (Fintype.card K ^ n) ∈ T) : + R ⊗[K] S →ₗ[K] T := + tensorRestriction (powCardAlgHom K A n) (fun x y => by + simpa only [powCardAlgHom_apply] using hmul x y) + +@[simp] +theorem powCardTensorRestriction_tmul + (n : ℕ) + (hmul : ∀ x : R, ∀ y : S, + (x : A) * (y : A) ^ (Fintype.card K ^ n) ∈ T) + (x : R) (y : S) : + powCardTensorRestriction n hmul (x ⊗ₜ[K] y) = + ⟨(x : A) * (y : A) ^ (Fintype.card K ^ n), hmul x y⟩ := by + apply Subtype.ext + simp [powCardTensorRestriction] + +/-- The swapped tensor restriction induced by +`(x, y) ↦ x ^ ((#K) ^ n) * y`. -/ +def powCardSwappedTensorRestriction + (n : ℕ) + (hmul : ∀ x : R, ∀ y : S, + (x : A) ^ (Fintype.card K ^ n) * (y : A) ∈ T) : + R ⊗[K] S →ₗ[K] T := + swappedTensorRestriction (powCardAlgHom K A n) (fun x y => by + simpa only [powCardAlgHom_apply] using hmul x y) + +@[simp] +theorem powCardSwappedTensorRestriction_tmul + (n : ℕ) + (hmul : ∀ x : R, ∀ y : S, + (x : A) ^ (Fintype.card K ^ n) * (y : A) ∈ T) + (x : R) (y : S) : + powCardSwappedTensorRestriction n hmul (x ⊗ₜ[K] y) = + ⟨(x : A) ^ (Fintype.card K ^ n) * (y : A), hmul x y⟩ := by + apply Subtype.ext + simp [powCardSwappedTensorRestriction] + +end FiniteFieldAlgebra + +section FiniteExtension + +variable (K : Type*) [Field K] [Fintype K] [DecidableEq K] + [DecidableEq (RatFunc K)] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +local instance frobeniusRestrictionConstantAlgebra : Algebra K L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K (RatFunc K))) + +local instance frobeniusRestrictionConstantTower : + IsScalarTower K (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + +omit [DecidableEq K] in +/-- Raising to `(#K) ^ n` scales every exhaustive place order by that +integer. -/ +theorem finiteExtensionPrincipalDivisor_powCardLinearMap + (x : L) (hx : x ≠ 0) (n : ℕ) : + finiteExtensionPrincipalDivisor K L (powCardLinearMap K L n x) = + (Fintype.card K ^ n) • finiteExtensionPrincipalDivisor K L x := by + classical + rw [powCardLinearMap_apply, + finiteExtensionPrincipalDivisor_pow K L x hx] + +omit [DecidableEq K] in +/-- Pointwise form of the Frobenius order-scaling identity. -/ +theorem finiteExtensionPrincipalDivisor_powCardLinearMap_apply + (x : L) (hx : x ≠ 0) (n : ℕ) + (v : FiniteExtensionPlace K L) : + finiteExtensionPrincipalDivisor K L (powCardLinearMap K L n x) v = + ((Fintype.card K ^ n : ℕ) : ℤ) * + finiteExtensionPrincipalDivisor K L x v := by + classical + rw [finiteExtensionPrincipalDivisor_powCardLinearMap K L x hx n] + simp only [Finsupp.smul_apply, nsmul_eq_mul] + +omit [DecidableEq K] in +/-- The pole divisor is scaled by the same power of the constant-field +cardinality under iterated Frobenius. -/ +theorem finiteExtensionPoleDivisor_powCardLinearMap + (x : L) (hx : x ≠ 0) (n : ℕ) : + finiteExtensionPoleDivisor K L (powCardLinearMap K L n x) = + (Fintype.card K ^ n) • finiteExtensionPoleDivisor K L x := by + classical + ext v + rw [finiteExtensionPoleDivisor_apply, + finiteExtensionPrincipalDivisor_powCardLinearMap_apply K L x hx n v] + simp only [Finsupp.smul_apply, nsmul_eq_mul] + rw [finiteExtensionPoleDivisor_apply] + have hs : (0 : ℤ) < (Fintype.card K ^ n : ℕ) := by + exact_mod_cast pow_pos Fintype.card_pos n + by_cases hv : finiteExtensionPrincipalDivisor K L x v < 0 + · have hscaled : + ((Fintype.card K ^ n : ℕ) : ℤ) * + finiteExtensionPrincipalDivisor K L x v < 0 := + mul_neg_of_pos_of_neg hs hv + rw [ite_eq_left hscaled, ite_eq_left hv] + ring + · have hscaled : ¬ + ((Fintype.card K ^ n : ℕ) : ℤ) * + finiteExtensionPrincipalDivisor K L x v < 0 := + not_lt_of_ge (mul_nonneg hs.le (le_of_not_gt hv)) + rw [ite_eq_right hscaled, ite_eq_right hv, mul_zero] + +/-- Iterated Frobenius sends `L(D)` into `L((#K)^n D)`. -/ +theorem powCardLinearMap_mem_scaledRiemannSpace + {D : FiniteExtensionDivisor K L} {x : L} + (hx : x ∈ finiteExtensionRiemannSpace K L D) (n : ℕ) : + powCardLinearMap K L n x ∈ finiteExtensionRiemannSpace K L + ((Fintype.card K ^ n) • D) := by + simpa only [powCardLinearMap_apply] using + finiteExtensionRiemannSpace_pow_mem K L hx (Fintype.card K ^ n) + +/-- The pole budget for `(x, y) ↦ x * y ^ ((#K)^n)`. -/ +theorem mul_powCardLinearMap_mem_poleDivisor_budget + (x y : L) (hx : x ≠ 0) (hy : y ≠ 0) (n : ℕ) : + x * powCardLinearMap K L n y ∈ finiteExtensionRiemannSpace K L + (finiteExtensionPoleDivisor K L x + + (Fintype.card K ^ n) • finiteExtensionPoleDivisor K L y) := by + exact finiteExtensionRiemannSpace_mul_mem K L + (mem_finiteExtensionRiemannSpace_poleDivisor K L x hx) + (powCardLinearMap_mem_scaledRiemannSpace K L + (mem_finiteExtensionRiemannSpace_poleDivisor K L y hy) n) + +/-- The pole budget for the swapped product +`(x, y) ↦ x ^ ((#K)^n) * y`. -/ +theorem powCardLinearMap_mul_mem_poleDivisor_budget + (x y : L) (hx : x ≠ 0) (hy : y ≠ 0) (n : ℕ) : + powCardLinearMap K L n x * y ∈ finiteExtensionRiemannSpace K L + ((Fintype.card K ^ n) • finiteExtensionPoleDivisor K L x + + finiteExtensionPoleDivisor K L y) := by + exact finiteExtensionRiemannSpace_mul_mem K L + (powCardLinearMap_mem_scaledRiemannSpace K L + (mem_finiteExtensionRiemannSpace_poleDivisor K L x hx) n) + (mem_finiteExtensionRiemannSpace_poleDivisor K L y hy) + +/-- Tensor restriction between Riemann spaces in the unswapped orientation. -/ +def powCardRiemannTensorRestriction + (D E : FiniteExtensionDivisor K L) (n : ℕ) : + finiteExtensionRiemannSpace K L D ⊗[K] + finiteExtensionRiemannSpace K L E →ₗ[K] + finiteExtensionRiemannSpace K L + (D + (Fintype.card K ^ n) • E) := + powCardTensorRestriction n (fun x y => + finiteExtensionRiemannSpace_mul_mem K L x.property + (finiteExtensionRiemannSpace_pow_mem K L y.property + (Fintype.card K ^ n))) + +@[simp] +theorem powCardRiemannTensorRestriction_tmul + (D E : FiniteExtensionDivisor K L) (n : ℕ) + (x : finiteExtensionRiemannSpace K L D) + (y : finiteExtensionRiemannSpace K L E) : + powCardRiemannTensorRestriction K L D E n (x ⊗ₜ[K] y) = + ⟨(x : L) * (y : L) ^ (Fintype.card K ^ n), + finiteExtensionRiemannSpace_mul_mem K L x.property + (finiteExtensionRiemannSpace_pow_mem K L y.property + (Fintype.card K ^ n))⟩ := by + apply Subtype.ext + simp [powCardRiemannTensorRestriction] + +/-- Tensor restriction between Riemann spaces in the swapped orientation. -/ +def powCardSwappedRiemannTensorRestriction + (D E : FiniteExtensionDivisor K L) (n : ℕ) : + finiteExtensionRiemannSpace K L D ⊗[K] + finiteExtensionRiemannSpace K L E →ₗ[K] + finiteExtensionRiemannSpace K L + ((Fintype.card K ^ n) • D + E) := + powCardSwappedTensorRestriction n (fun x y => + finiteExtensionRiemannSpace_mul_mem K L + (finiteExtensionRiemannSpace_pow_mem K L x.property + (Fintype.card K ^ n)) y.property) + +@[simp] +theorem powCardSwappedRiemannTensorRestriction_tmul + (D E : FiniteExtensionDivisor K L) (n : ℕ) + (x : finiteExtensionRiemannSpace K L D) + (y : finiteExtensionRiemannSpace K L E) : + powCardSwappedRiemannTensorRestriction K L D E n (x ⊗ₜ[K] y) = + ⟨(x : L) ^ (Fintype.card K ^ n) * (y : L), + finiteExtensionRiemannSpace_mul_mem K L + (finiteExtensionRiemannSpace_pow_mem K L x.property + (Fintype.card K ^ n)) + y.property⟩ := by + apply Subtype.ext + simp [powCardSwappedRiemannTensorRestriction] + +end FiniteExtension + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/FrobeniusTwistGroup.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/FrobeniusTwistGroup.lean new file mode 100644 index 0000000000..18e85489b7 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/FrobeniusTwistGroup.lean @@ -0,0 +1,69 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import Mathlib.GroupTheory.SpecificGroups.Cyclic + +/-! +# Cyclic subgroups generated by Frobenius twists + +The Galois-theoretic lower-bound argument uses elements `(σ, τ)` in a direct +product. The first component `σ` generates the constant-field Galois group, +while the order of the second finite group divides the order of `σ`. + +This file records the resulting elementary group facts: every twist has the +same order as `σ`, its cyclic subgroup meets the kernel of first projection +trivially, and that cyclic subgroup has the expected cardinality. These are +the group-theoretic inputs for taking fixed fields of Frobenius twists. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +section + +variable {A B : Type*} [Group A] [Group B] + +/-- If the order of the finite second factor divides the order of `a`, then +the pair `(a,b)` has the same order as `a`. -/ +theorem orderOf_prod_eq_left_of_natCard_dvd + (a : A) (b : B) (hcard : Nat.card B ∣ orderOf a) : + orderOf (a, b) = orderOf a := by + rw [Prod.orderOf, Nat.lcm_eq_left_iff_dvd] + exact (orderOf_dvd_natCard b).trans hcard + +/-- The cyclic subgroup generated by a Frobenius twist meets the kernel of +first projection trivially. -/ +theorem zpowers_prod_inf_fst_ker_eq_bot_of_natCard_dvd + (a : A) (b : B) (hcard : Nat.card B ∣ orderOf a) : + Subgroup.zpowers (a, b) ⊓ (MonoidHom.fst A B).ker = ⊥ := by + apply le_antisymm + · intro x hx + rw [Subgroup.mem_bot] + obtain ⟨k, rfl⟩ := Subgroup.mem_zpowers_iff.mp hx.1 + have ha : a ^ k = 1 := by + have hk := MonoidHom.mem_ker.mp hx.2 + change ((a, b) ^ k).1 = 1 at hk + simpa using hk + have hdiv : (orderOf a : ℤ) ∣ k := + orderOf_dvd_iff_zpow_eq_one.mpr ha + rw [← orderOf_dvd_iff_zpow_eq_one, + orderOf_prod_eq_left_of_natCard_dvd a b hcard] + exact hdiv + · exact bot_le + +/-- The cyclic subgroup generated by a Frobenius twist has cardinality equal +to the order of the constant-field generator. -/ +theorem natCard_zpowers_prod_eq_orderOf_left_of_natCard_dvd + (a : A) (b : B) (hcard : Nat.card B ∣ orderOf a) : + Nat.card (Subgroup.zpowers (a, b)) = orderOf a := by + rw [Nat.card_zpowers, orderOf_prod_eq_left_of_natCard_dvd a b hcard] + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/FunctionFieldConstantExtension.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/FunctionFieldConstantExtension.lean new file mode 100644 index 0000000000..e91e042856 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/FunctionFieldConstantExtension.lean @@ -0,0 +1,263 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveFunctionField +public import Mathlib.FieldTheory.LinearDisjoint +public import Mathlib.RingTheory.Flat.Basic +public import Mathlib.RingTheory.Localization.BaseChange +public import Mathlib.RingTheory.TensorProduct.MvPolynomial +public import Mathlib.RingTheory.TensorProduct.Quotient + +/-! +# Constant extensions of plane-curve function fields + +This file constructs scalar extension at both the affine coordinate-ring and +function-field levels. If `E / K` is algebraic and the base-changed plane +curve stays irreducible, then + +`E ⊗[K] K(C) ≃ₐ[E] E(C_E)`. + +The proof identifies the tensor product of `E` with the fraction field of the +coordinate ring as the fraction field of the tensor-product coordinate ring. +It then transports this fraction field through the explicit base-change +equivalence for the plane-curve coordinate ring. No Galois, Frobenius, place, +or point-counting assertion is made here. +-/ + +@[expose] public section + +open scoped TensorProduct nonZeroDivisors + +namespace BGS.HasseWeil + +noncomputable section + +section TensorFraction + +variable (K E A : Type*) [Field K] [Field E] [CommRing A] + [Algebra K E] [Algebra K A] + +/-- Tensor the fraction field of `A` with an extension field `E / K`. -/ +abbrev TensorFraction := E ⊗[K] FractionRing A + +/-- Tensor `A` itself with an extension field `E / K`. -/ +abbrev TensorBase := E ⊗[K] A + +/-- Localize the tensor-product base ring at the images of the nonzero +elements of `A`. -/ +abbrev TensorBaseLocalization := Localization + (A⁰.map (Algebra.TensorProduct.includeRight (R := K) (A := E) (B := A))) + +noncomputable instance tensorBaseTensorFractionAlgebra : + Algebra (TensorBase K E A) (TensorFraction K E A) := + (Algebra.TensorProduct.map (AlgHom.id K E) + (IsScalarTower.toAlgHom K A (FractionRing A))).toAlgebra + +theorem tensorBaseTensorFraction_algebraMap_tmul (e : E) (a : A) : + algebraMap (TensorBase K E A) (TensorFraction K E A) (e ⊗ₜ[K] a) = + e ⊗ₜ[K] algebraMap A (FractionRing A) a := by + change Algebra.TensorProduct.map (AlgHom.id K E) + (IsScalarTower.toAlgHom K A (FractionRing A)) (e ⊗ₜ[K] a) = _ + rw [Algebra.TensorProduct.map_tmul] + rfl + +instance tensorBaseTensorFractionScalarTower : + IsScalarTower E (TensorBase K E A) (TensorFraction K E A) := + IsScalarTower.of_algebraMap_eq' (by + ext e + change e ⊗ₜ[K] 1 = + algebraMap (TensorBase K E A) (TensorFraction K E A) (e ⊗ₜ[K] 1) + rw [tensorBaseTensorFraction_algebraMap_tmul] + simp) + +variable [IsDomain A] [IsDomain (TensorBase K E A)] + +private theorem tensorBase_nonZero_map : + A⁰.map (Algebra.TensorProduct.includeRight (R := K) (A := E) (B := A)) ≤ + (TensorBase K E A)⁰ := by + intro z hz + rcases hz with ⟨a, ha, rfl⟩ + rw [mem_nonZeroDivisors_iff_ne_zero] + intro hzero + apply nonZeroDivisors.ne_zero ha + apply Algebra.TensorProduct.includeRight_injective + (R := K) (A := E) (B := A) (algebraMap K E).injective + simpa using hzero + +/-- Tensoring the fraction field agrees with localizing the tensor-product +base ring at the nonzero elements coming from `A`. -/ +noncomputable def tensorFractionLocalizationEquiv : + TensorFraction K E A ≃ₐ[E] TensorBaseLocalization K E A := + IsLocalization.tensorProductEquivOfMapIncludeRight K E A⁰ + (FractionRing A) (TensorBaseLocalization K E A) + +omit [IsDomain A] [IsDomain (TensorBase K E A)] in +theorem tensorFractionLocalizationEquiv_algebraMap (z : TensorBase K E A) : + tensorFractionLocalizationEquiv K E A + (algebraMap (TensorBase K E A) (TensorFraction K E A) z) = + algebraMap (TensorBase K E A) (TensorBaseLocalization K E A) z := by + induction z using TensorProduct.inductionOn with + | tmul e a => + exact IsLocalization.tensorProductEquivOfMapIncludeRight_tmul + A A⁰ (FractionRing A) (TensorBaseLocalization K E A) e a + | add x y hx hy => simp only [map_add, hx, hy] + +local instance tensorFractionIsDomain : IsDomain (TensorFraction K E A) := by + let : IsDomain (TensorBaseLocalization K E A) := + IsLocalization.isDomain_localization (tensorBase_nonZero_map K E A) + exact (tensorFractionLocalizationEquiv K E A).toMulEquiv.isDomain_iff.mpr + inferInstance + +noncomputable local instance tensorFractionField [Algebra.IsAlgebraic K E] : + Field (TensorFraction K E A) := + (Algebra.TensorProduct.isField_of_isAlgebraic K E (FractionRing A) + (.inl inferInstance)).toField + +omit [IsDomain A] [IsDomain (TensorBase K E A)] in +private theorem tensorProduct_map_id_injective + {B : Type*} [CommRing B] [Algebra K B] + (F : A →ₐ[K] B) (hF : Function.Injective F) : + Function.Injective + (Algebra.TensorProduct.map (AlgHom.id E E) F) := by + have heq : + (Algebra.TensorProduct.map (AlgHom.id E E) F).toLinearMap.restrictScalars K = + F.toLinearMap.lTensor E := by + ext e a + simp + rw [← heq] at * + exact Module.Flat.lTensor_preserves_injective_linearMap F.toLinearMap hF + +local instance tensorBaseTensorFractionFaithfulSMul : + FaithfulSMul (TensorBase K E A) (TensorFraction K E A) := + (faithfulSMul_iff_algebraMap_injective _ _).mpr + (tensorProduct_map_id_injective K E A + (IsScalarTower.toAlgHom K A (FractionRing A)) + (IsFractionRing.injective A (FractionRing A))) + +/-- If the scalar-extended base ring is a domain and `E / K` is algebraic, +then tensoring the fraction field produces the fraction field of the +scalar-extended base ring. -/ +theorem tensorFraction_isFractionRing [Algebra.IsAlgebraic K E] : + IsFractionRing (TensorBase K E A) (TensorFraction K E A) := by + apply IsFractionRing.of_field + intro z + let e := tensorFractionLocalizationEquiv K E A + obtain ⟨⟨x, s⟩, hs⟩ := IsLocalization.surj + (A⁰.map (Algebra.TensorProduct.includeRight + (R := K) (A := E) (B := A))) (e z) + refine ⟨x, s, ?_⟩ + have hsT : + z * algebraMap (TensorBase K E A) (TensorFraction K E A) s = + algebraMap (TensorBase K E A) (TensorFraction K E A) x := by + apply e.injective + simpa only [e, map_mul, + tensorFractionLocalizationEquiv_algebraMap] using hs + apply (eq_div_iff ?_).mpr + · exact hsT + · exact map_ne_zero_of_mem_nonZeroDivisors _ + (FaithfulSMul.algebraMap_injective _ _) + (tensorBase_nonZero_map K E A s.property) + +end TensorFraction + +section PlaneCurve + +open BGS.CorvajaZannier + +variable (K E : Type*) [Field K] [Field E] [Algebra K E] + (f : MvPolynomial (Fin 2) K) + +/-- Scalar extension of a plane-curve coordinate ring, as an equivalence of +algebras over the enlarged constant field. -/ +noncomputable def planeCurveCoordinateRingBaseChangeAlgEquiv : + E ⊗[K] PlaneCurveCoordinateRing f ≃ₐ[E] + PlaneCurveCoordinateRing (MvPolynomial.map (algebraMap K E) f) := by + let P := MvPolynomial (Fin 2) K + let PE := MvPolynomial (Fin 2) E + let I : Ideal P := Ideal.span {f} + let eP : E ⊗[K] P ≃ₐ[E] PE := + MvPolynomial.algebraTensorAlgEquiv K E + let IT : Ideal (E ⊗[K] P) := + I.map (Algebra.TensorProduct.includeRight (R := K) (A := E) (B := P)) + let IE : Ideal PE := + Ideal.span {MvPolynomial.map (algebraMap K E) f} + have hideal : IE = IT.map eP.toRingEquiv.toRingHom := by + simp only [IE, IT, I, Ideal.map_span, Set.image_singleton] + congr 2 + symm + change (MvPolynomial.algebraTensorAlgEquiv K E) (1 ⊗ₜ[K] f) = + MvPolynomial.map (algebraMap K E) f + simpa only [one_smul] using + (MvPolynomial.algebraTensorAlgEquiv_tmul + (R := K) (A := E) (a := (1 : E)) f) + exact + (Algebra.TensorProduct.tensorQuotientEquiv + (R := K) E P E I).trans + (Ideal.quotientEquivAlg IT IE eP hideal) + +/-- If the base-changed equation is irreducible, then its tensor-product +coordinate ring is a domain. -/ +theorem planeCurveCoordinateRingBaseChange_isDomain + (hfE : Irreducible (MvPolynomial.map (algebraMap K E) f)) : + IsDomain (E ⊗[K] PlaneCurveCoordinateRing f) := by + let : IsDomain (PlaneCurveCoordinateRing + (MvPolynomial.map (algebraMap K E) f)) := + planeCurveCoordinateRing_isDomain hfE + exact (planeCurveCoordinateRingBaseChangeAlgEquiv K E f).toMulEquiv.isDomain_iff.mpr + inferInstance + +variable (hf : Irreducible f) + (hfE : Irreducible (MvPolynomial.map (algebraMap K E) f)) + [Algebra.IsAlgebraic K E] + +/-- Constant extension commutes with passing from an irreducible plane-curve +coordinate ring to its function field. -/ +noncomputable def planeCurveFunctionFieldBaseChangeAlgEquiv : + E ⊗[K] PlaneCurveFunctionField f ≃ₐ[E] + PlaneCurveFunctionField (MvPolynomial.map (algebraMap K E) f) := by + letI : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + letI : IsDomain (E ⊗[K] PlaneCurveCoordinateRing f) := + planeCurveCoordinateRingBaseChange_isDomain K E f hfE + letI : IsFractionRing + (E ⊗[K] PlaneCurveCoordinateRing f) + (E ⊗[K] PlaneCurveFunctionField f) := + tensorFraction_isFractionRing K E (PlaneCurveCoordinateRing f) + exact IsFractionRing.algEquivOfAlgEquiv + (R := E) + (A := E ⊗[K] PlaneCurveCoordinateRing f) + (B := PlaneCurveCoordinateRing + (MvPolynomial.map (algebraMap K E) f)) + (K := E ⊗[K] PlaneCurveFunctionField f) + (L := PlaneCurveFunctionField + (MvPolynomial.map (algebraMap K E) f)) + (planeCurveCoordinateRingBaseChangeAlgEquiv K E f) + +theorem planeCurveFunctionFieldBaseChangeAlgEquiv_tmul_one (e : E) : + planeCurveFunctionFieldBaseChangeAlgEquiv K E f hf hfE + (e ⊗ₜ[K] 1) = + algebraMap E + (PlaneCurveFunctionField + (MvPolynomial.map (algebraMap K E) f)) e := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let : IsDomain (E ⊗[K] PlaneCurveCoordinateRing f) := + planeCurveCoordinateRingBaseChange_isDomain K E f hfE + let : IsFractionRing + (E ⊗[K] PlaneCurveCoordinateRing f) + (E ⊗[K] PlaneCurveFunctionField f) := + tensorFraction_isFractionRing K E (PlaneCurveCoordinateRing f) + change planeCurveFunctionFieldBaseChangeAlgEquiv K E f hf hfE + (algebraMap E (E ⊗[K] PlaneCurveFunctionField f) e) = _ + exact (planeCurveFunctionFieldBaseChangeAlgEquiv K E f hf hfE).commutes e + +end PlaneCurve + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/FunctionFieldConstantField.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/FunctionFieldConstantField.lean new file mode 100644 index 0000000000..86b7e1c2a1 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/FunctionFieldConstantField.lean @@ -0,0 +1,226 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.FunctionFieldNormalClosure +public import LeanPool.MarkoffModP.BGS.HasseWeil.OnePointLeadingCoefficient +public import Mathlib.FieldTheory.Finite.GaloisField + +/-! +# The algebraic constant field of a finite function field + +For a finite separable extension `N / K(t)`, define its algebraic constant +field to be the relative algebraic closure of `K` in `N`. When `K` is finite, +this constant field is finite-dimensional over `K`. + +The finiteness proof is place-theoretic. Algebraic constants are integral over +`K[X]`, hence map into the finite integral closure. Reduction modulo any +height-one prime is injective on the constant field, because it is a field. +Choosing a prime above `(X)` embeds the constants into a finite quotient. +-/ + +@[expose] public section + +open scoped Polynomial + +namespace BGS.HasseWeil + +noncomputable section + +open BGS.CorvajaZannier +open IsDedekindDomain + +attribute [local instance high] Module.Free.of_divisionRing + +variable (K N : Type*) [Field K] [Field N] + [DecidableEq K] [DecidableEq (RatFunc K)] + [Algebra (RatFunc K) N] + [FiniteDimensional (RatFunc K) N] + [Algebra.IsSeparable (RatFunc K) N] + +local instance functionFieldConstantAlgebra : Algebra K N := + RingHom.toAlgebra ((algebraMap (RatFunc K) N).comp + (algebraMap K (RatFunc K))) + +local instance functionFieldConstantRatFuncTower : + IsScalarTower K (RatFunc K) N := + IsScalarTower.of_algebraMap_eq' rfl + +local instance (priority := 10) functionFieldConstantPolynomialAlgebra : + Algebra K[X] N := + RingHom.toAlgebra ((algebraMap (RatFunc K) N).comp + (algebraMap K[X] (RatFunc K))) + +local instance functionFieldConstantPolynomialRatFuncTower : + IsScalarTower K[X] (RatFunc K) N := + IsScalarTower.of_algebraMap_eq' rfl + +local instance functionFieldConstantPolynomialTower : + IsScalarTower K K[X] N := + IsScalarTower.of_algebraMap_eq' rfl + +local instance functionFieldConstantPolynomialTorsionFreeTop : + Module.IsTorsionFree K[X] N := + Module.IsTorsionFree.trans_faithfulSMul K[X] (RatFunc K) N + +local instance functionFieldConstantFiniteClosureAlgebra : + Algebra K (RatFuncFiniteIntegralClosure K N) := + RingHom.toAlgebra ((algebraMap K[X] + (RatFuncFiniteIntegralClosure K N)).comp (algebraMap K K[X])) + +local instance functionFieldConstantFiniteClosureTower : + IsScalarTower K K[X] (RatFuncFiniteIntegralClosure K N) := + IsScalarTower.of_algebraMap_eq' rfl + +local instance functionFieldConstantFiniteClosureModuleFinite : + Module.Finite K[X] (RatFuncFiniteIntegralClosure K N) := + Module.IsNoetherian.finite K[X] (RatFuncFiniteIntegralClosure K N) + +local instance functionFieldConstantFiniteClosureIntegral : + Algebra.IsIntegral K[X] (RatFuncFiniteIntegralClosure K N) := + IsIntegralClosure.isIntegral_algebra K[X] N + +local instance functionFieldConstantFiniteClosureTorsionFree : + Module.IsTorsionFree K[X] (RatFuncFiniteIntegralClosure K N) := + IsIntegralClosure.isTorsionFree K[X] N + +local instance functionFieldConstantFiniteClosureDedekind : + IsDedekindDomain (RatFuncFiniteIntegralClosure K N) := + IsIntegralClosure.isDedekindDomain K[X] (RatFunc K) N + (RatFuncFiniteIntegralClosure K N) + +/-- The algebraic constant field of `N / K(t)`. -/ +abbrev FunctionFieldConstantField := algebraicClosure K N + +/-- Algebraic constants are integral over the finite polynomial model. -/ +def functionFieldConstantToFiniteIntegralClosure : + FunctionFieldConstantField K N →ₐ[K] + RatFuncFiniteIntegralClosure K N where + toFun c := ⟨c.1, c.2.tower_top⟩ + map_one' := rfl + map_mul' _ _ := rfl + map_zero' := rfl + map_add' _ _ := rfl + commutes' _ := rfl + +local instance functionFieldConstantFinitePlaceMaximal + (Q : FiniteExtensionFinitePlace K N) : + Q.asIdeal.IsMaximal := Q.isMaximal + +/-- Reduction modulo a finite place, restricted to the algebraic constant +field. -/ +def functionFieldConstantQuotientAlgHom + (Q : FiniteExtensionFinitePlace K N) : + FunctionFieldConstantField K N →ₐ[K] + (RatFuncFiniteIntegralClosure K N ⧸ Q.asIdeal) := + (Ideal.Quotient.mkₐ K Q.asIdeal).comp + (functionFieldConstantToFiniteIntegralClosure K N) + +omit [DecidableEq K] [DecidableEq (RatFunc K)] + [FiniteDimensional (RatFunc K) N] + [Algebra.IsSeparable (RatFunc K) N] in +/-- Reduction at a finite place is injective on algebraic constants. -/ +theorem functionFieldConstantQuotientAlgHom_injective + (Q : FiniteExtensionFinitePlace K N) : + Function.Injective (functionFieldConstantQuotientAlgHom K N Q) := + (functionFieldConstantQuotientAlgHom K N Q).injective + +omit [DecidableEq K] in +omit [DecidableEq (RatFunc K)] in +/-- The residue field of a rational-function finite place is finite over a +finite constant field. -/ +theorem ratFuncFinitePlaceResidueField_finite [Finite K] + (p : HeightOneSpectrum K[X]) : Finite p.asIdeal.ResidueField := by + classical + let r := finitePlaceNormalizedPrime p + have hr0 : (r : K[X]) ≠ 0 := r.property.1.ne_zero + have hrmonic : (r : K[X]).Monic := + (Polynomial.normalize_eq_self_iff_monic hr0).mp r.property.2 + have hp : p.asIdeal = Ideal.span ({(r : K[X])} : Set K[X]) := by + calc + p.asIdeal = (normalizedPrimeFinitePlace (K := K) r).asIdeal := by + rw [normalizedPrimeFinitePlace_finitePlaceNormalizedPrime] + _ = Ideal.span ({(r : K[X])} : Set K[X]) := rfl + let : Module.Finite K (K[X] ⧸ p.asIdeal) := by + rw [hp] + exact hrmonic.finite_quotient + let : Finite (K[X] ⧸ p.asIdeal) := Module.finite_of_finite K + infer_instance + +omit [DecidableEq K] in +omit [DecidableEq (RatFunc K)] in +/-- Every finite-place residue field of a finite separable function field is +finite over a finite constant field. -/ +theorem finiteExtensionFinitePlaceResidueField_finite [Finite K] + (P : FiniteExtensionFinitePlace K N) : Finite P.asIdeal.ResidueField := by + classical + let p := HeightOneSpectrum.under K[X] P + let : Finite p.asIdeal.ResidueField := + ratFuncFinitePlaceResidueField_finite K p + let : P.asIdeal.LiesOver p.asIdeal := ⟨rfl⟩ + let := Localization.AtPrime.algebraOfLiesOver p.asIdeal P.asIdeal + let _ : IsScalarTower K[X] (Localization.AtPrime p.asIdeal) + (Localization.AtPrime P.asIdeal) := inferInstance + let : Algebra.QuasiFiniteAt K[X] P.asIdeal := inferInstance + let : Module.Finite p.asIdeal.ResidueField P.asIdeal.ResidueField := + inferInstance + exact Module.finite_of_finite p.asIdeal.ResidueField + +omit [DecidableEq K] in +/-- Over a finite base field, the algebraic constant field of a finite +separable function field is finite-dimensional. -/ +noncomputable instance functionFieldConstantField_finiteDimensional [Finite K] : + FiniteDimensional K (FunctionFieldConstantField K N) := by + classical + let p : HeightOneSpectrum K[X] := Polynomial.idealX K + obtain ⟨Q, hQprime, hQcomap⟩ := + Ideal.exists_ideal_over_prime_of_isIntegral_of_isDomain + (S := RatFuncFiniteIntegralClosure K N) p.asIdeal (by + intro x hx + have hxA : algebraMap K[X] (RatFuncFiniteIntegralClosure K N) x = 0 := + (RingHom.mem_ker).mp hx + have hxN : algebraMap K[X] N x = 0 := + congrArg Subtype.val hxA + have hx0 : x = 0 := by + exact FaithfulSMul.algebraMap_injective K[X] N (by simpa using hxN) + subst x + exact p.asIdeal.zero_mem) + let P : p.asIdeal.primesOver (RatFuncFiniteIntegralClosure K N) := + ⟨Q, hQprime, ⟨hQcomap.symm⟩⟩ + let q : FiniteExtensionFinitePlace K N := primeOverHeightOne p P + let : Finite q.asIdeal.ResidueField := + finiteExtensionFinitePlaceResidueField_finite K N q + let : Finite (RatFuncFiniteIntegralClosure K N ⧸ q.asIdeal) := + Finite.of_injective + (algebraMap (RatFuncFiniteIntegralClosure K N ⧸ q.asIdeal) + q.asIdeal.ResidueField) + (Ideal.injective_algebraMap_quotient_residueField q.asIdeal) + let : Module.Finite K + (RatFuncFiniteIntegralClosure K N ⧸ q.asIdeal) := + Module.Finite.of_finite + exact FiniteDimensional.of_injective + (functionFieldConstantQuotientAlgHom K N q).toLinearMap + (functionFieldConstantQuotientAlgHom_injective K N q) + +omit [DecidableEq K] in +/-- The algebraic constant field is a finite type when the original constants +are finite. -/ +noncomputable instance functionFieldConstantField_finite [Finite K] : + Finite (FunctionFieldConstantField K N) := by + classical + exact Module.finite_of_finite K + +omit [DecidableEq K] in +/-- The algebraic constant field is Galois over the finite base field. -/ +noncomputable instance functionFieldConstantField_isGalois [Finite K] : + IsGalois K (FunctionFieldConstantField K N) := by + classical + exact inferInstance + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/FunctionFieldNormalClosure.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/FunctionFieldNormalClosure.lean new file mode 100644 index 0000000000..f65647e761 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/FunctionFieldNormalClosure.lean @@ -0,0 +1,86 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionPlaceTower +public import Mathlib.FieldTheory.Galois.GaloisClosure +public import Mathlib.FieldTheory.IsSepClosed + +/-! +# A finite Galois closure for a one-variable function field + +For a finite separable extension `L / K(t)`, choose an embedding of `L` into +the absolute separable closure of `K(t)` and take its normal closure there. +The result is a finite Galois extension of `K(t)` containing an embedded copy +of `L`. + +This is the field-theoretic Galois-closure layer required by the twisted +fixed-field argument. It does not identify the algebraic constant field of +the closure or construct any Frobenius complements. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +noncomputable section + +variable (K L : Type*) [Field K] [Field L] + [Algebra (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +/-- A chosen `K(t)`-embedding of the function field into the absolute +separable closure of `K(t)`. -/ +def functionFieldSeparableClosureEmbedding : + L →ₐ[RatFunc K] SeparableClosure (RatFunc K) := + IsSepClosed.lift + +/-- The normal closure of the chosen embedded copy of `L` inside the absolute +separable closure of `K(t)`. -/ +def FunctionFieldNormalClosure : + IntermediateField (RatFunc K) (SeparableClosure (RatFunc K)) := + IntermediateField.normalClosure (RatFunc K) + (functionFieldSeparableClosureEmbedding K L).fieldRange + (SeparableClosure (RatFunc K)) + +/-- The original function field embeds into its chosen normal closure. -/ +def functionFieldToNormalClosure : + L →ₐ[RatFunc K] FunctionFieldNormalClosure K L := + (functionFieldSeparableClosureEmbedding K L).codRestrict + (FunctionFieldNormalClosure K L).toSubalgebra (fun x => by + exact IntermediateField.le_normalClosure + (functionFieldSeparableClosureEmbedding K L).fieldRange + ⟨x, rfl⟩) + +theorem functionFieldToNormalClosure_injective : + Function.Injective (functionFieldToNormalClosure K L) := + (functionFieldToNormalClosure K L).injective + +variable [FiniteDimensional (RatFunc K) L] + +/-- The chosen normal closure remains finite over `K(t)`. -/ +noncomputable instance functionFieldNormalClosure_finiteDimensional : + FiniteDimensional (RatFunc K) (FunctionFieldNormalClosure K L) := by + let : FiniteDimensional (RatFunc K) + (functionFieldSeparableClosureEmbedding K L).fieldRange := + (functionFieldSeparableClosureEmbedding K L).toLinearMap.finiteDimensional_range + change FiniteDimensional (RatFunc K) + (IntermediateField.normalClosure (RatFunc K) + (functionFieldSeparableClosureEmbedding K L).fieldRange + (SeparableClosure (RatFunc K))) + infer_instance + +/-- The chosen normal closure is Galois over `K(t)`. -/ +noncomputable instance functionFieldNormalClosure_isGalois : + IsGalois (RatFunc K) (FunctionFieldNormalClosure K L) := + IsGalois.normalClosure (RatFunc K) + (functionFieldSeparableClosureEmbedding K L).fieldRange + (SeparableClosure (RatFunc K)) + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/FunctionFieldNormalClosureConstantBase.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/FunctionFieldNormalClosureConstantBase.lean new file mode 100644 index 0000000000..3a4987f82c --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/FunctionFieldNormalClosureConstantBase.lean @@ -0,0 +1,174 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.FunctionFieldNormalClosureConstants +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionQuotient + +/-! +# The constant-base field inside the function-field normal closure + +Let `N / K(t)` be the chosen function-field normal closure and let `C` be its +algebraic constant field. The restriction map + +`Gal(N/K(t)) → Gal(C/K)` + +is already known to be onto. This file defines the fixed field of its kernel. +Every element of `C` lies in that fixed field, so it gives a genuine tower +`C ⊆ L_C ⊆ N`; moreover `N / L_C` is finite Galois. The general exact +constant-extension and Frobenius-quotient theorems can therefore be applied +directly to the normal closure used by the Hasse--Weil proof. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +noncomputable section + + +variable (K L : Type*) [Field K] [Field L] + [Fintype K] [DecidableEq K] [DecidableEq (RatFunc K)] + [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +/-- The fixed field of the automorphisms of the normal closure that act +trivially on all algebraic constants. -/ +abbrev FunctionFieldNormalClosureConstantBase := + IntermediateField.fixedField + (functionFieldNormalClosureConstantRestriction K L).ker + +/-- Algebraic constants embed into the fixed field of the restriction +kernel. -/ +def functionFieldNormalClosureConstantToBase : + FunctionFieldNormalClosureConstantField K L →ₐ[K] + FunctionFieldNormalClosureConstantBase K L where + toFun c := ⟨c.1, by + apply (IntermediateField.mem_fixedField_iff + (H := (functionFieldNormalClosureConstantRestriction K L).ker) c.1).mpr + intro g hg + exact (mem_functionFieldNormalClosureConstantRestriction_ker_iff + K L g).mp hg c⟩ + map_one' := rfl + map_mul' _ _ := rfl + map_zero' := rfl + map_add' _ _ := rfl + commutes' _ := rfl + +/-- The induced algebra structure of the kernel fixed field over the full +constant field. -/ +@[reducible] noncomputable instance functionFieldNormalClosureConstantBaseAlgebra : + Algebra (FunctionFieldNormalClosureConstantField K L) + (FunctionFieldNormalClosureConstantBase K L) := + (functionFieldNormalClosureConstantToBase K L).toAlgebra + +local instance normalClosureConstantBaseSMul : + SMul (FunctionFieldNormalClosureConstantField K L) + (FunctionFieldNormalClosureConstantBase K L) := Algebra.toSMul + +local instance normalClosureConstantBaseModule : + Module (FunctionFieldNormalClosureConstantField K L) + (FunctionFieldNormalClosureConstantBase K L) := Algebra.toModule + +/-- The embeddings of the constants into the fixed field and into the normal +closure form a scalar tower. -/ +noncomputable instance functionFieldNormalClosureConstantBase_isScalarTower : + IsScalarTower (FunctionFieldNormalClosureConstantField K L) + (FunctionFieldNormalClosureConstantBase K L) + (FunctionFieldNormalClosure K L) := by + apply IsScalarTower.of_algebraMap_eq' + ext c + rfl + +/-- The normal closure is finite over the kernel fixed field. -/ +noncomputable instance + functionFieldNormalClosure_finiteDimensional_over_constantBase : + FiniteDimensional (FunctionFieldNormalClosureConstantBase K L) + (FunctionFieldNormalClosure K L) := by + infer_instance + +/-- The normal closure is Galois over the kernel fixed field. -/ +noncomputable instance functionFieldNormalClosure_isGalois_over_constantBase : + IsGalois (FunctionFieldNormalClosureConstantBase K L) + (FunctionFieldNormalClosure K L) := by + infer_instance + +section Extension + +variable (S : Type*) [Field S] + [Algebra (FunctionFieldNormalClosureConstantField K L) S] + [FiniteDimensional (FunctionFieldNormalClosureConstantField K L) S] + [IsGalois (FunctionFieldNormalClosureConstantField K L) S] + +/-- The generic exact-constant field structure specializes to the chosen +function-field normal closure. -/ +@[reducible] noncomputable instance + functionFieldNormalClosureExactConstantExtensionField : + Field (ExactConstantExtension + (FunctionFieldNormalClosureConstantField K L) + (FunctionFieldNormalClosure K L) S) := + exactConstantExtensionField + (FunctionFieldNormalClosureConstantField K L) + (FunctionFieldNormalClosure K L) S + (functionFieldNormalClosureConstantField_isExact K L) + +/-- The Galois group of the specialized constant extension is the product of +the new constant Galois group and the kernel-fixed-field Galois group. -/ +noncomputable def functionFieldNormalClosureConstantExtensionAutMulEquiv : + let := exactConstantExtensionBaseAlgebra + (FunctionFieldNormalClosureConstantField K L) + (FunctionFieldNormalClosureConstantBase K L) + (FunctionFieldNormalClosure K L) S + (S ≃ₐ[FunctionFieldNormalClosureConstantField K L] S) × + (FunctionFieldNormalClosure K L ≃ₐ[ + FunctionFieldNormalClosureConstantBase K L] + FunctionFieldNormalClosure K L) ≃* + (ExactConstantExtension + (FunctionFieldNormalClosureConstantField K L) + (FunctionFieldNormalClosure K L) S ≃ₐ[ + FunctionFieldNormalClosureConstantBase K L] + ExactConstantExtension + (FunctionFieldNormalClosureConstantField K L) + (FunctionFieldNormalClosure K L) S) := by + let := exactConstantExtensionBaseAlgebra + (FunctionFieldNormalClosureConstantField K L) + (FunctionFieldNormalClosureConstantBase K L) + (FunctionFieldNormalClosure K L) S + exact exactConstantExtensionAutMulEquiv + (FunctionFieldNormalClosureConstantField K L) + (FunctionFieldNormalClosureConstantBase K L) + (FunctionFieldNormalClosure K L) S + (functionFieldNormalClosureConstantField_isExact K L) + +omit [Fintype K] [DecidableEq K] [DecidableEq (RatFunc K)] in +/-- The specialized constant quotient is onto. -/ +theorem functionFieldNormalClosureConstantExtensionQuotient_surjective : + let := exactConstantExtensionBaseAlgebra + (FunctionFieldNormalClosureConstantField K L) + (FunctionFieldNormalClosureConstantBase K L) + (FunctionFieldNormalClosure K L) S + Function.Surjective (exactConstantExtensionConstantQuotient + (FunctionFieldNormalClosureConstantField K L) + (FunctionFieldNormalClosureConstantBase K L) + (FunctionFieldNormalClosure K L) S + (functionFieldNormalClosureConstantField_isExact K L)) := by + let := exactConstantExtensionBaseAlgebra + (FunctionFieldNormalClosureConstantField K L) + (FunctionFieldNormalClosureConstantBase K L) + (FunctionFieldNormalClosure K L) S + exact exactConstantExtensionConstantQuotient_surjective + (FunctionFieldNormalClosureConstantField K L) + (FunctionFieldNormalClosureConstantBase K L) + (FunctionFieldNormalClosure K L) S + (functionFieldNormalClosureConstantField_isExact K L) + +end Extension + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/FunctionFieldNormalClosureConstants.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/FunctionFieldNormalClosureConstants.lean new file mode 100644 index 0000000000..3064bd1b8a --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/FunctionFieldNormalClosureConstants.lean @@ -0,0 +1,170 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.FunctionFieldConstantField +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneConstantField + +/-! +# Constants and restriction for the function-field Galois closure + +Equip the chosen normal closure of `L / K(t)` with its induced `K`-algebra +structure, take the algebraic constant field, and restrict every +`K(t)`-automorphism to those constants. Over a finite base field the constant +field is finite Galois and its automorphism group is cyclic, generated by +Frobenius. The restriction map is surjective: a constant fixed by its image +is fixed by the full Galois group over `K(t)`, hence lies in `K(t)`; because it +is algebraic over `K`, the exact constant-field theorem for `K(t)` puts it in +`K`. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +noncomputable section + +variable (K L : Type*) [Field K] [Field L] + [Fintype K] [DecidableEq K] [DecidableEq (RatFunc K)] + [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +noncomputable instance functionFieldNormalClosureConstantAlgebra : + Algebra K (FunctionFieldNormalClosure K L) := + RingHom.toAlgebra + ((algebraMap (RatFunc K) (FunctionFieldNormalClosure K L)).comp + (algebraMap K (RatFunc K))) + +noncomputable instance functionFieldNormalClosureConstantTower : + IsScalarTower K (RatFunc K) (FunctionFieldNormalClosure K L) := + IsScalarTower.of_algebraMap_eq' rfl + +/-- The algebraic constant field of the chosen Galois closure. -/ +abbrev FunctionFieldNormalClosureConstantField := + FunctionFieldConstantField K (FunctionFieldNormalClosure K L) + +/-- Restriction of a `K(t)`-automorphism of the normal closure to its algebraic +constant field. -/ +def functionFieldNormalClosureConstantRestriction : + Gal(FunctionFieldNormalClosure K L/RatFunc K) →* + Gal((FunctionFieldNormalClosureConstantField K L) / K) where + toFun g := (g.restrictScalars K).algebraicClosure + map_one' := by + ext x + rfl + map_mul' g h := by + ext x + rfl + +omit [Fintype K] [DecidableEq K] [DecidableEq (RatFunc K)] + [FiniteDimensional (RatFunc K) L] in +theorem functionFieldNormalClosureConstantRestriction_apply + (g : Gal(FunctionFieldNormalClosure K L/RatFunc K)) + (c : FunctionFieldNormalClosureConstantField K L) : + functionFieldNormalClosureConstantRestriction K L g c = + ⟨g c.1, by + exact (map_mem_algebraicClosure_iff + (g.restrictScalars K).toAlgHom).mpr c.2⟩ := rfl + +omit [Fintype K] [DecidableEq K] [DecidableEq (RatFunc K)] + [FiniteDimensional (RatFunc K) L] in +/-- The kernel consists exactly of automorphisms fixing every algebraic +constant. -/ +theorem mem_functionFieldNormalClosureConstantRestriction_ker_iff + (g : Gal(FunctionFieldNormalClosure K L/RatFunc K)) : + g ∈ (functionFieldNormalClosureConstantRestriction K L).ker ↔ + ∀ c : FunctionFieldNormalClosureConstantField K L, g c.1 = c.1 := by + rw [MonoidHom.mem_ker] + constructor + · intro hg c + have hc := DFunLike.congr_fun hg c + exact congrArg Subtype.val hc + · intro hg + apply AlgEquiv.ext + intro c + apply Subtype.ext + exact hg c + +omit [DecidableEq (RatFunc K)] in +/-- Every automorphism of the algebraic constant field extends to an +automorphism of the normal closure over `K(t)`. + +The proof uses fixed fields rather than constructing a constant compositum. +If an algebraic constant is fixed by the image of the restriction map, then +it is fixed by every automorphism of the normal closure over `K(t)`, so the +Galois fixed-field theorem puts it in `K(t)`. The rational function field has +no elements algebraic over `K` except `K` itself. Thus the image has trivial +fixed field and is the full constant-field Galois group. -/ +theorem functionFieldNormalClosureConstantRestriction_surjective : + Function.Surjective + (functionFieldNormalClosureConstantRestriction K L) := by + let N := FunctionFieldNormalClosure K L + let C := FunctionFieldNormalClosureConstantField K L + let rho := functionFieldNormalClosureConstantRestriction K L + suffices hfixed : IntermediateField.fixedField rho.range = + (⊥ : IntermediateField K C) from + MonoidHom.range_eq_top.mp <| + IntermediateField.fixingSubgroup_fixedField rho.range ▸ + hfixed ▸ IntermediateField.fixingSubgroup_bot + refine eq_bot_iff.mpr ?_ + intro c hc + have hcFixed : ∀ g : Gal(N / (RatFunc K)), g c.1 = c.1 := by + intro g + have hcg := (IntermediateField.mem_fixedField_iff + (H := rho.range) c).mp hc (rho g) ⟨g, rfl⟩ + exact congrArg Subtype.val hcg + obtain ⟨r, hr⟩ := + (IsGalois.mem_range_algebraMap_iff_fixed c.1).mpr hcFixed + have hrIntegral : IsIntegral K r := by + apply (isIntegral_algHom_iff + (IsScalarTower.toAlgHom K (RatFunc K) N) + (algebraMap (RatFunc K) N).injective).mp + have hcIntegral : IsIntegral K c.1 := + (mem_algebraicClosure_iff.mp c.2).isIntegral + rw [IsScalarTower.toAlgHom_apply, hr] + exact hcIntegral + have hrBot : r ∈ (⊥ : IntermediateField K (RatFunc K)) := by + rw [← ratFunc_algebraicClosure_eq_bot K] + exact hrIntegral + obtain ⟨k, hk⟩ := IntermediateField.mem_bot.mp hrBot + apply IntermediateField.mem_bot.mpr + refine ⟨k, ?_⟩ + apply Subtype.ext + change algebraMap K N k = c.1 + rw [← hr, ← hk] + rfl + +omit [Fintype K] [DecidableEq K] [DecidableEq (RatFunc K)] + [FiniteDimensional (RatFunc K) L] in +/-- After enlarging the base constants to the algebraic constants of the +normal closure, that field is the exact constant field: no further element of +the normal closure is algebraic over it. -/ +theorem functionFieldNormalClosureConstantField_isExact : + algebraicClosure (FunctionFieldNormalClosureConstantField K L) + (FunctionFieldNormalClosure K L) = + (⊥ : IntermediateField (FunctionFieldNormalClosureConstantField K L) + (FunctionFieldNormalClosure K L)) := + algebraicClosure.algebraicClosure_eq_bot K (FunctionFieldNormalClosure K L) + +local instance normalClosureConstantModule : + Module K (FunctionFieldNormalClosureConstantField K L) := Algebra.toModule + +omit [DecidableEq (RatFunc K)] in +omit [DecidableEq K] in +/-- Frobenius on the finite algebraic constant field has order equal to its +degree over `K`. -/ +theorem orderOf_functionFieldNormalClosureConstantFrobenius : + orderOf (FiniteField.frobeniusAlgEquivOfAlgebraic K + (FunctionFieldNormalClosureConstantField K L)) = + Module.finrank K (FunctionFieldNormalClosureConstantField K L) := + FiniteField.orderOf_frobeniusAlgEquivOfAlgebraic K + (FunctionFieldNormalClosureConstantField K L) + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/FunctionFieldNormalClosureOriginalCompositum.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/FunctionFieldNormalClosureOriginalCompositum.lean new file mode 100644 index 0000000000..27a310a63f --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/FunctionFieldNormalClosureOriginalCompositum.lean @@ -0,0 +1,486 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionAutomorphism +public import LeanPool.MarkoffModP.BGS.HasseWeil.FunctionFieldNormalClosureRatFuncEquiv +public import LeanPool.MarkoffModP.BGS.HasseWeil.RatFuncExactConstantExtension + +/-! +# The original function field after enlarging the normal-closure constants + +Let `F / K(t)` be finite separable, let `N` be the chosen normal closure, and +let `C` be the full algebraic constant field of `N`. If `K` is already the +exact constant field of `F`, linear disjointness identifies the scalar +extension `C ⊗[K] F` with its multiplication image `CF` inside `N`. + +This file constructs that image as an intermediate field, equips it with the +`C(t)`-structure inherited from the constant base inside `N`, and records the +two structural facts needed downstream: `N / CF` is finite Galois and `C` is +the exact constant field of `CF`. +-/ + +@[expose] public section + +open scoped Polynomial TensorProduct + +namespace BGS.HasseWeil + +noncomputable section + + +variable (K F : Type*) [Field K] [Field F] + [Fintype K] [DecidableEq K] [DecidableEq (RatFunc K)] + [Algebra K F] + [Algebra (RatFunc K) F] + [IsScalarTower K (RatFunc K) F] + [FiniteDimensional (RatFunc K) F] + [Algebra.IsSeparable (RatFunc K) F] + +local instance originalCompositumNormalClosureSMul : + SMul K (FunctionFieldNormalClosure K F) := Algebra.toSMul + +local instance originalCompositumNormalClosureModule : + Module K (FunctionFieldNormalClosure K F) := Algebra.toModule + +local instance originalCompositumNormalClosureSelfTower : + IsScalarTower K K (FunctionFieldNormalClosure K F) := + ⟨fun x y z => (smul_smul x y z).symm⟩ + +local instance originalCompositumBaseConstantSMul : + SMul K (FunctionFieldNormalClosureConstantField K F) := Algebra.toSMul + +local instance originalCompositumBaseConstantModule : + Module K (FunctionFieldNormalClosureConstantField K F) := Algebra.toModule + +local instance originalCompositumConstantBaseSMul : + SMul (FunctionFieldNormalClosureConstantField K F) + (FunctionFieldNormalClosureConstantBase K F) := Algebra.toSMul + +local instance originalCompositumConstantBaseModule : + Module (FunctionFieldNormalClosureConstantField K F) + (FunctionFieldNormalClosureConstantBase K F) := Algebra.toModule + +/-- Multiplication of the two embedded factors `C` and `F` inside the normal +closure. Before exactness is imposed this is merely an algebra homomorphism +from the tensor product; exactness will make its source a field and hence the +map injective. -/ +noncomputable def functionFieldNormalClosureOriginalMultiplication : + ExactConstantExtension K F + (FunctionFieldNormalClosureConstantField K F) →ₐ[K] + FunctionFieldNormalClosure K F := + Algebra.TensorProduct.lift + (FunctionFieldNormalClosureConstantField K F).val + ((functionFieldToNormalClosure K F).restrictScalars K) + (fun _ _ => Commute.all _ _) + +omit [Fintype K] [DecidableEq K] [DecidableEq (RatFunc K)] [FiniteDimensional (RatFunc K) F] in +@[simp] +theorem functionFieldNormalClosureOriginalMultiplication_tmul + (c : FunctionFieldNormalClosureConstantField K F) (x : F) : + functionFieldNormalClosureOriginalMultiplication K F (c ⊗ₜ[K] x) = + c.1 * functionFieldToNormalClosure K F x := by + simp [functionFieldNormalClosureOriginalMultiplication] + +/-- The compositum `CF` inside the chosen normal closure, realized as the +field range of tensor multiplication. -/ +noncomputable def FunctionFieldNormalClosureOriginalCompositum + (hExact : algebraicClosure K F = (⊥ : IntermediateField K F)) : + IntermediateField K (FunctionFieldNormalClosure K F) := by + letI : Field (ExactConstantExtension K F + (FunctionFieldNormalClosureConstantField K F)) := + exactConstantExtensionField K F + (FunctionFieldNormalClosureConstantField K F) hExact + exact (functionFieldNormalClosureOriginalMultiplication K F).fieldRange + +/-- Tensor scalar extension is the same field as the compositum `CF` inside +the normal closure. -/ +noncomputable def exactConstantExtensionOriginalCompositumAlgEquiv + (hExact : algebraicClosure K F = (⊥ : IntermediateField K F)) : + ExactConstantExtension K F + (FunctionFieldNormalClosureConstantField K F) ≃ₐ[K] + FunctionFieldNormalClosureOriginalCompositum K F hExact := by + letI : Field (ExactConstantExtension K F + (FunctionFieldNormalClosureConstantField K F)) := + exactConstantExtensionField K F + (FunctionFieldNormalClosureConstantField K F) hExact + exact AlgEquiv.ofInjectiveField + (functionFieldNormalClosureOriginalMultiplication K F) + +omit [DecidableEq K] [DecidableEq (RatFunc K)] in +/-- Every algebraic constant of the normal closure belongs to `CF`. -/ +theorem functionFieldNormalClosureConstant_mem_originalCompositum + (hExact : algebraicClosure K F = (⊥ : IntermediateField K F)) + (c : FunctionFieldNormalClosureConstantField K F) : + c.1 ∈ FunctionFieldNormalClosureOriginalCompositum K F hExact := by + let : Field (ExactConstantExtension K F + (FunctionFieldNormalClosureConstantField K F)) := + exactConstantExtensionField K F + (FunctionFieldNormalClosureConstantField K F) hExact + exact ⟨c ⊗ₜ[K] (1 : F), by simp⟩ + +omit [DecidableEq (RatFunc K)] [DecidableEq K] in +/-- The original rational-function field belongs to `CF`. -/ +theorem functionFieldNormalClosureRatFunc_mem_originalCompositum + (hExact : algebraicClosure K F = (⊥ : IntermediateField K F)) + (r : RatFunc K) : + algebraMap (RatFunc K) (FunctionFieldNormalClosure K F) r ∈ + FunctionFieldNormalClosureOriginalCompositum K F hExact := by + let : Field (ExactConstantExtension K F + (FunctionFieldNormalClosureConstantField K F)) := + exactConstantExtensionField K F + (FunctionFieldNormalClosureConstantField K F) hExact + refine ⟨1 ⊗ₜ[K] algebraMap (RatFunc K) F r, ?_⟩ + simp [functionFieldNormalClosureOriginalMultiplication] + +/-- The inclusion of the full constant field into `CF`. -/ +noncomputable def functionFieldNormalClosureConstantToOriginalCompositum + (hExact : algebraicClosure K F = (⊥ : IntermediateField K F)) : + FunctionFieldNormalClosureConstantField K F →ₐ[K] + FunctionFieldNormalClosureOriginalCompositum K F hExact := + (FunctionFieldNormalClosureConstantField K F).val.codRestrict + (FunctionFieldNormalClosureOriginalCompositum K F hExact).toSubalgebra + (functionFieldNormalClosureConstant_mem_originalCompositum K F hExact) + +/-- The compositum is naturally an algebra over the full constant field. -/ +@[reducible] noncomputable instance + functionFieldNormalClosureOriginalCompositumConstantAlgebra + (hExact : algebraicClosure K F = (⊥ : IntermediateField K F)) : + Algebra (FunctionFieldNormalClosureConstantField K F) + (FunctionFieldNormalClosureOriginalCompositum K F hExact) := + (functionFieldNormalClosureConstantToOriginalCompositum K F hExact).toAlgebra + +local instance originalCompositumConstantSMul + (hExact : algebraicClosure K F = (⊥ : IntermediateField K F)) : + SMul (FunctionFieldNormalClosureConstantField K F) + (FunctionFieldNormalClosureOriginalCompositum K F hExact) := Algebra.toSMul + +local instance originalCompositumConstantModule + (hExact : algebraicClosure K F = (⊥ : IntermediateField K F)) : + Module (FunctionFieldNormalClosureConstantField K F) + (FunctionFieldNormalClosureOriginalCompositum K F hExact) := Algebra.toModule + +/-- The tensor/compositum equivalence respects the enlarged constants. -/ +noncomputable def exactConstantExtensionOriginalCompositumConstantAlgEquiv + (hExact : algebraicClosure K F = (⊥ : IntermediateField K F)) : + let : Field (ExactConstantExtension K F + (FunctionFieldNormalClosureConstantField K F)) := + exactConstantExtensionField K F + (FunctionFieldNormalClosureConstantField K F) hExact + let : Algebra (FunctionFieldNormalClosureConstantField K F) + (ExactConstantExtension K F + (FunctionFieldNormalClosureConstantField K F)) := + Algebra.TensorProduct.leftAlgebra + ExactConstantExtension K F + (FunctionFieldNormalClosureConstantField K F) ≃ₐ[ + FunctionFieldNormalClosureConstantField K F] + FunctionFieldNormalClosureOriginalCompositum K F hExact := by + intro model1 model2 + refine + { exactConstantExtensionOriginalCompositumAlgEquiv K F hExact with + commutes' := ?_ } + intro c + apply Subtype.ext + change functionFieldNormalClosureOriginalMultiplication K F + (c ⊗ₜ[K] (1 : F)) = c.1 + simp + +/-- The constant embedding into `CF` agrees with its embedding into `N`. -/ +noncomputable instance + functionFieldNormalClosureOriginalCompositumConstantTower + (hExact : algebraicClosure K F = (⊥ : IntermediateField K F)) : + IsScalarTower (FunctionFieldNormalClosureConstantField K F) + (FunctionFieldNormalClosureOriginalCompositum K F hExact) + (FunctionFieldNormalClosure K F) := by + apply IsScalarTower.of_algebraMap_eq' + ext c + rfl + +/-- The inclusion of `K(t)` into `CF`. -/ +noncomputable def functionFieldNormalClosureRatFuncToOriginalCompositum + (hExact : algebraicClosure K F = (⊥ : IntermediateField K F)) : + RatFunc K →ₐ[K] + FunctionFieldNormalClosureOriginalCompositum K F hExact := + (IsScalarTower.toAlgHom K (RatFunc K) + (FunctionFieldNormalClosure K F)).codRestrict + (FunctionFieldNormalClosureOriginalCompositum K F hExact).toSubalgebra + (functionFieldNormalClosureRatFunc_mem_originalCompositum K F hExact) + +/-- The compositum is naturally a `K(t)`-algebra. -/ +@[reducible] noncomputable instance + functionFieldNormalClosureOriginalCompositumRatFuncAlgebra + (hExact : algebraicClosure K F = (⊥ : IntermediateField K F)) : + Algebra (RatFunc K) + (FunctionFieldNormalClosureOriginalCompositum K F hExact) := + (functionFieldNormalClosureRatFuncToOriginalCompositum K F hExact).toAlgebra + +/-- The `K(t)` embedding into `CF` agrees with its embedding into `N`. -/ +noncomputable instance + functionFieldNormalClosureOriginalCompositumRatFuncTower + (hExact : algebraicClosure K F = (⊥ : IntermediateField K F)) : + IsScalarTower (RatFunc K) + (FunctionFieldNormalClosureOriginalCompositum K F hExact) + (FunctionFieldNormalClosure K F) := by + apply IsScalarTower.of_algebraMap_eq' + ext r + rfl + +omit [DecidableEq K] [DecidableEq (RatFunc K)] in +/-- The constant base `C(t)` inside `N` is contained in the larger compositum +`CF`. -/ +theorem functionFieldNormalClosureConstantBase_le_originalCompositum + (hExact : algebraicClosure K F = (⊥ : IntermediateField K F)) + (b : FunctionFieldNormalClosureConstantBase K F) : + b.1 ∈ FunctionFieldNormalClosureOriginalCompositum K F hExact := by + classical + have hb : b.1 ∈ functionFieldNormalClosureConstantCompositum K F := by + rw [← functionFieldNormalClosureConstantBase_eq_compositum K F] + exact b.2 + refine IntermediateField.adjoin_induction (RatFunc K) + (p := fun z _ => + z ∈ FunctionFieldNormalClosureOriginalCompositum K F hExact) + ?_ ?_ ?_ ?_ ?_ hb + · rintro _ ⟨c, rfl⟩ + exact functionFieldNormalClosureConstant_mem_originalCompositum + K F hExact c + · exact functionFieldNormalClosureRatFunc_mem_originalCompositum + K F hExact + · intro x y _ _ hx hy + exact (FunctionFieldNormalClosureOriginalCompositum K F hExact).add_mem hx hy + · intro x _ hx + exact (FunctionFieldNormalClosureOriginalCompositum K F hExact).inv_mem hx + · intro x y _ _ hx hy + exact (FunctionFieldNormalClosureOriginalCompositum K F hExact).mul_mem hx hy + +/-- Inclusion of the constant base `C(t)` into `CF`, linear over `C`. -/ +noncomputable def functionFieldNormalClosureConstantBaseToOriginalCompositum + (hExact : algebraicClosure K F = (⊥ : IntermediateField K F)) : + FunctionFieldNormalClosureConstantBase K F →ₐ[ + FunctionFieldNormalClosureConstantField K F] + FunctionFieldNormalClosureOriginalCompositum K F hExact where + toFun b := ⟨b.1, + functionFieldNormalClosureConstantBase_le_originalCompositum + K F hExact b⟩ + map_one' := rfl + map_mul' _ _ := rfl + map_zero' := rfl + map_add' _ _ := rfl + commutes' _ := rfl + +private theorem originalCompositum_ratFunc_algHom_ext + {C M : Type*} [Field C] [Field M] [Algebra C M] + (f g : RatFunc C →ₐ[C] M) (hX : f RatFunc.X = g RatFunc.X) : f = g := by + have hRing : f.toRingHom = g.toRingHom := by + apply IsFractionRing.ringHom_ext (A := C[X]) + intro p + induction p using Polynomial.induction_on' with + | add p q hp hq => + simpa only [map_add] using congrArg₂ (fun x y => x + y) hp hq + | monomial n c => + rw [← Polynomial.C_mul_X_pow_eq_monomial] + simp only [map_mul, map_pow, RatFunc.algebraMap_C, + RatFunc.algebraMap_X] + rw [← RatFunc.algebraMap_eq_C] + have hfc : f.toRingHom (algebraMap C (RatFunc C) c) = + algebraMap C M c := f.commutes c + have hgc : g.toRingHom (algebraMap C (RatFunc C) c) = + algebraMap C M c := g.commutes c + have hX' : f.toRingHom RatFunc.X = g.toRingHom RatFunc.X := hX + rw [hfc, hgc, hX'] + exact DFunLike.ext _ _ (fun r => DFunLike.congr_fun hRing r) + +/-- The standard coefficient algebra structure on `C(t)` used by the +rational-function equivalence. -/ +@[reducible] noncomputable instance (priority := 2000) + functionFieldNormalClosureConstantFieldRatFuncAlgebraForOriginalCompositum : + Algebra (FunctionFieldNormalClosureConstantField K F) + (RatFunc (FunctionFieldNormalClosureConstantField K F)) := + ratFuncSelfAlgebra (FunctionFieldNormalClosureConstantField K F) + +/-- The `C(t)`-algebra structure on `CF`, transported through the canonical +equivalence `C(t) ≃ C K(t)` inside the normal closure. -/ +noncomputable def + functionFieldNormalClosureOriginalCompositumConstantRatFuncAlgHom + (hExact : algebraicClosure K F = (⊥ : IntermediateField K F)) : + RatFunc (FunctionFieldNormalClosureConstantField K F) →ₐ[ + FunctionFieldNormalClosureConstantField K F] + FunctionFieldNormalClosureOriginalCompositum K F hExact := + (functionFieldNormalClosureConstantBaseToOriginalCompositum K F hExact).comp + (functionFieldNormalClosureConstantBaseRatFuncAlgEquiv K F).toAlgHom + +/-- `CF` as an algebra over the enlarged rational-function field `C(t)`. -/ +@[reducible] noncomputable instance + functionFieldNormalClosureOriginalCompositumConstantRatFuncAlgebra + (hExact : algebraicClosure K F = (⊥ : IntermediateField K F)) : + Algebra (RatFunc (FunctionFieldNormalClosureConstantField K F)) + (FunctionFieldNormalClosureOriginalCompositum K F hExact) := + (functionFieldNormalClosureOriginalCompositumConstantRatFuncAlgHom + K F hExact).toAlgebra + +/-- The two embeddings of `K` into `CF`, directly and through `C`, agree. -/ +noncomputable instance + functionFieldNormalClosureOriginalCompositumBaseConstantTower + (hExact : algebraicClosure K F = (⊥ : IntermediateField K F)) : + IsScalarTower K (FunctionFieldNormalClosureConstantField K F) + (FunctionFieldNormalClosureOriginalCompositum K F hExact) := by + apply IsScalarTower.of_algebraMap_eq' + ext k + rfl + +omit [DecidableEq K] in +/-- The chosen normal closure is finite over the original compositum `CF`. -/ +noncomputable instance + functionFieldNormalClosure_finiteDimensional_over_originalCompositum + (hExact : algebraicClosure K F = (⊥ : IntermediateField K F)) : + FiniteDimensional + (FunctionFieldNormalClosureOriginalCompositum K F hExact) + (FunctionFieldNormalClosure K F) := by + classical + let : Module.Finite + (FunctionFieldNormalClosureOriginalCompositum K F hExact) + (FunctionFieldNormalClosure K F) := + Module.Finite.of_restrictScalars_finite (RatFunc K) + (FunctionFieldNormalClosureOriginalCompositum K F hExact) + (FunctionFieldNormalClosure K F) + infer_instance + +omit [DecidableEq K] in +/-- The chosen normal closure remains Galois after enlarging the base from +`K(t)` to the intermediate field `CF`. -/ +noncomputable instance functionFieldNormalClosure_isGalois_over_originalCompositum + (hExact : algebraicClosure K F = (⊥ : IntermediateField K F)) : + IsGalois (FunctionFieldNormalClosureOriginalCompositum K F hExact) + (FunctionFieldNormalClosure K F) := by + classical + exact IsGalois.tower_top_of_isGalois (RatFunc K) + (FunctionFieldNormalClosureOriginalCompositum K F hExact) + (FunctionFieldNormalClosure K F) + +omit [DecidableEq K] [DecidableEq (RatFunc K)] in +/-- Enlarging the original function field to `CF` introduces exactly the +constants `C` and no others. -/ +theorem functionFieldNormalClosureOriginalCompositumConstantField_isExact + (hExact : algebraicClosure K F = (⊥ : IntermediateField K F)) : + algebraicClosure (FunctionFieldNormalClosureConstantField K F) + (FunctionFieldNormalClosureOriginalCompositum K F hExact) = + (⊥ : IntermediateField (FunctionFieldNormalClosureConstantField K F) + (FunctionFieldNormalClosureOriginalCompositum K F hExact)) := by + let M := FunctionFieldNormalClosureOriginalCompositum K F hExact + let N := FunctionFieldNormalClosure K F + let C := FunctionFieldNormalClosureConstantField K F + let i : M →ₐ[C] N := + { toFun := fun x => x.1 + map_one' := rfl + map_mul' := fun _ _ => rfl + map_zero' := rfl + map_add' := fun _ _ => rfl + commutes' := fun _ => rfl } + apply eq_bot_iff.mpr + intro z hz + have hzN : i z ∈ algebraicClosure C N := + (map_mem_algebraicClosure_iff i).mpr hz + rw [functionFieldNormalClosureConstantField_isExact K F] at hzN + obtain ⟨c, hc⟩ := IntermediateField.mem_bot.mp hzN + apply IntermediateField.mem_bot.mpr + refine ⟨c, ?_⟩ + apply Subtype.ext + exact hc + +end + +noncomputable section + +section CanonicalConstantPresentation + + +variable (K F : Type*) [Field K] [Field F] + [Fintype K] [DecidableEq K] [DecidableEq (RatFunc K)] + [Algebra (RatFunc K) F] + [FiniteDimensional (RatFunc K) F] + [Algebra.IsSeparable (RatFunc K) F] + +/-- The constant algebra on `F` obtained by restricting the given +`K(t)`-algebra. This named definition is useful when applying constructions +whose constant algebra is definitionally this restriction. -/ +@[reducible] noncomputable def functionFieldCanonicalConstantAlgebra : + Algebra K F := + RingHom.toAlgebra + ((algebraMap (RatFunc K) F).comp (algebraMap K (RatFunc K))) + +omit [DecidableEq K] [DecidableEq (RatFunc K)] in +private theorem originalMultiplicationCanonicalRatFunc_X : + let : Algebra K F := functionFieldCanonicalConstantAlgebra K F + let : IsScalarTower K (RatFunc K) F := IsScalarTower.of_algebraMap_eq' rfl + ∀ (hExact : algebraicClosure K F = (⊥ : IntermediateField K F)), + functionFieldNormalClosureOriginalMultiplication K F + (ratFuncToExactConstantExtension K + (FunctionFieldNormalClosureConstantField K F) F hExact RatFunc.X) = + algebraMap (RatFunc K) (FunctionFieldNormalClosure K F) RatFunc.X := by + intro model1 model2 hExact + let C := FunctionFieldNormalClosureConstantField K F + let : Algebra K[X] F := + RingHom.toAlgebra + ((algebraMap (RatFunc K) F).comp (algebraMap K[X] (RatFunc K))) + rw [ratFuncToExactConstantExtension_X] + simp only [polynomialTensorCancelEvaluationPoint, Algebra.TensorProduct.includeRight_apply] + rw [functionFieldNormalClosureOriginalMultiplication_tmul] + change (1 : FunctionFieldNormalClosure K F) * + functionFieldToNormalClosure K F (algebraMap K[X] F Polynomial.X) = _ + rw [one_mul] + change functionFieldToNormalClosure K F + (algebraMap (RatFunc K) F (algebraMap K[X] (RatFunc K) Polynomial.X)) = _ + rw [RatFunc.algebraMap_X] + exact (functionFieldToNormalClosure K F).commutes RatFunc.X + +/-- For the canonical restricted constant algebra, the tensor/compositum +equivalence is linear over `C(t)`, not merely over `K`. -/ +noncomputable def + exactConstantExtensionOriginalCompositumCanonicalRatFuncAlgEquiv : + let : Algebra K F := functionFieldCanonicalConstantAlgebra K F + let : IsScalarTower K (RatFunc K) F := + IsScalarTower.of_algebraMap_eq' rfl + ∀ (hExact : algebraicClosure K F = (⊥ : IntermediateField K F)), + let C := FunctionFieldNormalClosureConstantField K F + let E := ExactConstantExtension K F C + let M := FunctionFieldNormalClosureOriginalCompositum K F hExact + let : Field E := exactConstantExtensionField K F C hExact + let : Algebra C E := Algebra.TensorProduct.leftAlgebra + let : Algebra (RatFunc C) E := + ratFuncExactConstantExtensionAlgebra K C F hExact + E ≃ₐ[RatFunc C] M := by + intro model1 model2 hExact C E M model3 model4 model5 + letI : Algebra C (RatFunc C) := ratFuncSelfAlgebra C + letI : Algebra K[X] F := + RingHom.toAlgebra + ((algebraMap (RatFunc K) F).comp + (algebraMap K[X] (RatFunc K))) + let eC : E ≃ₐ[C] M := + exactConstantExtensionOriginalCompositumConstantAlgEquiv K F hExact + let f : RatFunc C →ₐ[C] M := + eC.toAlgHom.comp (ratFuncToExactConstantExtension K C F hExact) + let g : RatFunc C →ₐ[C] M := + functionFieldNormalClosureOriginalCompositumConstantRatFuncAlgHom + K F hExact + exact + { eC with + commutes' := by + intro r + have hX : f RatFunc.X = g RatFunc.X := by + apply Subtype.ext + have hfX := originalMultiplicationCanonicalRatFunc_X K F hExact + have hgX := congrArg Subtype.val + (functionFieldNormalClosureConstantBaseRatFuncAlgEquiv_X K F) + exact hfX.trans hgX.symm + have hfg : f = g := + originalCompositum_ratFunc_algHom_ext (C := C) (M := M) f g hX + exact DFunLike.congr_fun hfg r } + +end CanonicalConstantPresentation + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/FunctionFieldNormalClosureOriginalField.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/FunctionFieldNormalClosureOriginalField.lean new file mode 100644 index 0000000000..819c64340d --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/FunctionFieldNormalClosureOriginalField.lean @@ -0,0 +1,133 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionPlaceAlgEquiv +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionClosedPlaceAlgEquiv +public import LeanPool.MarkoffModP.BGS.HasseWeil.FunctionFieldNormalClosure + +/-! +# The original field inside its chosen normal closure + +The chosen embedding of a finite separable function field into its normal +closure has a field range. This file names that intermediate field, records +the tautological algebra equivalence with the original presentation, and +transports exact constants and rational-place counts across it. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +noncomputable section + +variable (K F : Type*) [Field K] [Field F] + [Algebra (RatFunc K) F] + [FiniteDimensional (RatFunc K) F] + [Algebra.IsSeparable (RatFunc K) F] + +/-- The embedded copy of the original function field inside its chosen +normal closure. -/ +abbrev FunctionFieldNormalClosureOriginalField : + IntermediateField (RatFunc K) (FunctionFieldNormalClosure K F) := + (functionFieldToNormalClosure K F).fieldRange + +/-- The original presentation is equivalent, over `K(X)`, to its embedded +copy in the normal closure. -/ +noncomputable def functionFieldNormalClosureOriginalFieldAlgEquiv : + F ≃ₐ[RatFunc K] FunctionFieldNormalClosureOriginalField K F := + (functionFieldToNormalClosure K F).equivFieldRange + +/-- The normal closure is finite over the embedded original field. -/ +noncomputable instance + functionFieldNormalClosure_finiteDimensional_over_originalField : + FiniteDimensional (FunctionFieldNormalClosureOriginalField K F) + (FunctionFieldNormalClosure K F) := by + exact Module.Finite.right (RatFunc K) + (FunctionFieldNormalClosureOriginalField K F) + (FunctionFieldNormalClosure K F) + +/-- The normal closure remains Galois after replacing the rational base by +the embedded original field. -/ +noncomputable instance functionFieldNormalClosure_isGalois_over_originalField : + IsGalois (FunctionFieldNormalClosureOriginalField K F) + (FunctionFieldNormalClosure K F) := + IsGalois.tower_top_of_isGalois (RatFunc K) + (FunctionFieldNormalClosureOriginalField K F) + (FunctionFieldNormalClosure K F) + +section Constants + +variable [Algebra K F] [IsScalarTower K (RatFunc K) F] + +local instance originalFieldImageConstantAlgebra : + Algebra K (FunctionFieldNormalClosureOriginalField K F) := + RingHom.toAlgebra + ((algebraMap (RatFunc K) + (FunctionFieldNormalClosureOriginalField K F)).comp + (algebraMap K (RatFunc K))) + +local instance originalFieldImageConstantTower : + IsScalarTower K (RatFunc K) + (FunctionFieldNormalClosureOriginalField K F) := + IsScalarTower.of_algebraMap_eq' + (R := K) (S := RatFunc K) + (A := FunctionFieldNormalClosureOriginalField K F) rfl + +omit [FiniteDimensional (RatFunc K) F] in +/-- Exactness of the constant field is unchanged when the original function +field is replaced by its embedded image in the normal closure. -/ +theorem functionFieldNormalClosureOriginalField_algebraicClosure_eq_bot + (hExact : algebraicClosure K F = (⊥ : IntermediateField K F)) : + algebraicClosure K (FunctionFieldNormalClosureOriginalField K F) = + (⊥ : IntermediateField K + (FunctionFieldNormalClosureOriginalField K F)) := by + let e : F ≃ₐ[K] FunctionFieldNormalClosureOriginalField K F := + (functionFieldNormalClosureOriginalFieldAlgEquiv K F).restrictScalars K + have hmap := algebraicClosure.map_eq_of_algEquiv e + rw [hExact] at hmap + simpa only [IntermediateField.map_bot] using hmap.symm + +end Constants + +section Places + +variable [DecidableEq K] [DecidableEq (RatFunc K)] + +/-- The original presentation and its embedded normal-closure image have the +same complete rational-place count. -/ +theorem functionFieldNormalClosureOriginalField_rationalPlaceCount_eq : + finiteExtensionRationalPlaceCount K F = + finiteExtensionRationalPlaceCount K + (FunctionFieldNormalClosureOriginalField K F) := + finiteExtensionRationalPlaceCount_eq_of_algEquiv K F + (FunctionFieldNormalClosureOriginalField K F) + (functionFieldNormalClosureOriginalFieldAlgEquiv K F) + +end Places + +section ClosedPlaces + +variable [Fintype K] [DecidableEq K] [DecidableEq (RatFunc K)] + +/-- The entire closed-place extension-count sequence is unchanged when the +original presentation is replaced by its image in the normal closure. -/ +theorem + functionFieldNormalClosureOriginalField_closedPlaceExtensionCount_eq + (r : ℕ) : + finiteExtensionClosedPlaceExtensionCount K F r = + finiteExtensionClosedPlaceExtensionCount K + (FunctionFieldNormalClosureOriginalField K F) r := + finiteExtensionClosedPlaceExtensionCount_eq_of_algEquiv K F + (FunctionFieldNormalClosureOriginalField K F) + (functionFieldNormalClosureOriginalFieldAlgEquiv K F) r + +end ClosedPlaces + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/FunctionFieldNormalClosureRatFuncBase.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/FunctionFieldNormalClosureRatFuncBase.lean new file mode 100644 index 0000000000..0cbb0559b7 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/FunctionFieldNormalClosureRatFuncBase.lean @@ -0,0 +1,216 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.FunctionFieldNormalClosureConstantBase +public import LeanPool.MarkoffModP.BGS.HasseWeil.RatFuncConstantExtension +public import Mathlib.FieldTheory.RatFunc.AsPolynomial + +/-! +# The rational-function constant base of the normal closure + +Let `N / K(t)` be the chosen function-field normal closure and let `C` be its +full algebraic constant field. The field generated in `N` by `K(t)` and `C` +is exactly the fixed field of the automorphisms acting trivially on `C`. +This is the Galois-theoretic identification of that fixed field with the +constant extension `C(t)`. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +noncomputable section + + +variable (K L : Type*) [Field K] [Field L] + [Fintype K] [DecidableEq K] [DecidableEq (RatFunc K)] + [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +local instance ratFuncBaseConstantSMul : + SMul (FunctionFieldNormalClosureConstantField K L) + (FunctionFieldNormalClosureConstantBase K L) := Algebra.toSMul + +local instance ratFuncBaseConstantModule : + Module (FunctionFieldNormalClosureConstantField K L) + (FunctionFieldNormalClosureConstantBase K L) := Algebra.toModule + +local instance normalClosureConstantBaseRatFuncTower : + IsScalarTower K (RatFunc K) (FunctionFieldNormalClosureConstantBase K L) := + IsScalarTower.of_algebraMap_eq' rfl + +/-- The compositum of the original rational function field and the algebraic +constant field, formed inside the chosen normal closure. -/ +def functionFieldNormalClosureConstantCompositum : + IntermediateField (RatFunc K) (FunctionFieldNormalClosure K L) := + IntermediateField.adjoin (RatFunc K) + (Set.range (fun c : FunctionFieldNormalClosureConstantField K L => c.1)) + +omit [Fintype K] [DecidableEq K] [DecidableEq (RatFunc K)] [FiniteDimensional (RatFunc K) L] in +/-- The subgroup fixing the constant compositum is precisely the kernel of +restriction to the algebraic constant field. -/ +theorem functionFieldNormalClosureConstantCompositum_fixingSubgroup : + (functionFieldNormalClosureConstantCompositum K L).fixingSubgroup = + (functionFieldNormalClosureConstantRestriction K L).ker := by + apply le_antisymm + · intro g hg + rw [MonoidHom.mem_ker] + apply AlgEquiv.ext + intro c + apply Subtype.ext + exact (IntermediateField.mem_fixingSubgroup_iff + (functionFieldNormalClosureConstantCompositum K L) g).mp hg c.1 + (IntermediateField.subset_adjoin (RatFunc K) _ ⟨c, rfl⟩) + · apply (IntermediateField.le_iff_le + (functionFieldNormalClosureConstantRestriction K L).ker + (functionFieldNormalClosureConstantCompositum K L)).mp + unfold functionFieldNormalClosureConstantCompositum + rw [IntermediateField.adjoin_le_iff] + rintro _ ⟨c, rfl⟩ + exact (functionFieldNormalClosureConstantToBase K L c).property + +omit [Fintype K] [DecidableEq K] [DecidableEq (RatFunc K)] in +/-- The kernel fixed field is the compositum `K(t)C` inside the normal +closure. -/ +theorem functionFieldNormalClosureConstantBase_eq_compositum : + FunctionFieldNormalClosureConstantBase K L = + functionFieldNormalClosureConstantCompositum K L := by + change IntermediateField.fixedField + (functionFieldNormalClosureConstantRestriction K L).ker = _ + rw [show (functionFieldNormalClosureConstantRestriction K L).ker = + (functionFieldNormalClosureConstantCompositum K L).fixingSubgroup by + exact (functionFieldNormalClosureConstantCompositum_fixingSubgroup + K L).symm] + exact IsGalois.fixedField_fixingSubgroup + (functionFieldNormalClosureConstantCompositum K L) + +/-- The original parameter `t` as an element of the kernel fixed field. -/ +def functionFieldNormalClosureConstantBaseX : + FunctionFieldNormalClosureConstantBase K L := + ⟨algebraMap (RatFunc K) (FunctionFieldNormalClosure K L) RatFunc.X, by + apply (IntermediateField.mem_fixedField_iff + (H := (functionFieldNormalClosureConstantRestriction K L).ker) _).mpr + intro g hg + exact g.commutes RatFunc.X⟩ + +/-- The `K`-, `C`-, and kernel-fixed-field algebra structures form a tower. -/ +noncomputable instance functionFieldNormalClosureConstantBase_constantTower : + IsScalarTower K (FunctionFieldNormalClosureConstantField K L) + (FunctionFieldNormalClosureConstantBase K L) := by + apply IsScalarTower.of_algebraMap_eq' + ext k + rfl + +omit [Fintype K] [DecidableEq K] [DecidableEq (RatFunc K)] [FiniteDimensional (RatFunc K) L] in +/-- The original parameter remains transcendental after adjoining all +algebraic constants of the normal closure. -/ +theorem functionFieldNormalClosureConstantBaseX_transcendental : + Transcendental (FunctionFieldNormalClosureConstantField K L) + (functionFieldNormalClosureConstantBaseX K L) := by + let : Algebra.IsAlgebraic K (FunctionFieldNormalClosureConstantField K L) := + algebraicClosure.isAlgebraic K (FunctionFieldNormalClosure K L) + let : Algebra.IsIntegral K (FunctionFieldNormalClosureConstantField K L) := + Algebra.IsAlgebraic.isIntegral + intro hx + have hxIntegralK : IsIntegral K + (functionFieldNormalClosureConstantBaseX K L) := + isIntegral_trans _ hx.isIntegral + have hxRatFunc : IsIntegral K (RatFunc.X : RatFunc K) := by + apply (isIntegral_algHom_iff + (IsScalarTower.toAlgHom K (RatFunc K) + (FunctionFieldNormalClosureConstantBase K L)) + (algebraMap (RatFunc K) + (FunctionFieldNormalClosureConstantBase K L)).injective).mp + simpa [functionFieldNormalClosureConstantBaseX] using hxIntegralK + exact RatFunc.transcendental_X hxRatFunc.isAlgebraic + +omit [Fintype K] [DecidableEq K] [DecidableEq (RatFunc K)] in +/-- The kernel fixed field is generated over the full constant field by the +original rational parameter. -/ +theorem functionFieldNormalClosureConstantBase_adjoin_X : + IntermediateField.adjoin + (FunctionFieldNormalClosureConstantField K L) + ({functionFieldNormalClosureConstantBaseX K L} : + Set (FunctionFieldNormalClosureConstantBase K L)) = ⊤ := by + let C := FunctionFieldNormalClosureConstantField K L + let B := FunctionFieldNormalClosureConstantBase K L + let N := FunctionFieldNormalClosure K L + let x : B := functionFieldNormalClosureConstantBaseX K L + let D : IntermediateField C B := IntermediateField.adjoin C ({x} : Set B) + let f : RatFunc K →ₐ[K] B := IsScalarTower.toAlgHom K (RatFunc K) B + have hfX : f RatFunc.X = x := rfl + have hfieldRange : f.fieldRange = + IntermediateField.adjoin K ({x} : Set B) := by + calc + f.fieldRange = IntermediateField.map f + (⊤ : IntermediateField K (RatFunc K)) := + AlgHom.fieldRange_eq_map f + _ = IntermediateField.map f + (IntermediateField.adjoin K ({RatFunc.X} : Set (RatFunc K))) := by + rw [RatFunc.adjoin_X] + _ = IntermediateField.adjoin K (f '' ({RatFunc.X} : Set (RatFunc K))) := + IntermediateField.adjoin_map K _ f + _ = IntermediateField.adjoin K ({x} : Set B) := by + congr 1 + ext y + simp only [Set.mem_image, Set.mem_singleton_iff] + constructor + · rintro ⟨z, rfl, rfl⟩ + exact hfX + · intro hy + refine ⟨RatFunc.X, rfl, ?_⟩ + simpa [hy] using hfX + have hRatFuncRange : f.fieldRange ≤ D.restrictScalars K := by + rw [hfieldRange] + apply IntermediateField.adjoin_simple_le_iff.mpr + rw [IntermediateField.mem_restrictScalars] + exact IntermediateField.subset_adjoin C ({x} : Set B) (Set.mem_singleton x) + have hRatFunc (r : RatFunc K) : + algebraMap (RatFunc K) B r ∈ D := by + rw [← IntermediateField.mem_restrictScalars K] + apply hRatFuncRange + exact ⟨r, rfl⟩ + apply top_unique + intro y hy + change y ∈ D + have hyCompositum : y.1 ∈ functionFieldNormalClosureConstantCompositum K L := by + rw [← functionFieldNormalClosureConstantBase_eq_compositum K L] + exact y.2 + refine IntermediateField.adjoin_induction (RatFunc K) + (p := fun z hz => ∀ hzB : z ∈ FunctionFieldNormalClosureConstantBase K L, + (⟨z, hzB⟩ : B) ∈ D) ?_ ?_ ?_ ?_ ?_ hyCompositum y.2 + · rintro z ⟨c, rfl⟩ hzB + exact D.algebraMap_mem c + · intro r hzB + exact hRatFunc r + · intro z w hz hw hzD hwD hzwB + have hzB : z ∈ FunctionFieldNormalClosureConstantBase K L := by + rw [functionFieldNormalClosureConstantBase_eq_compositum K L] + exact hz + have hwB : w ∈ FunctionFieldNormalClosureConstantBase K L := by + rw [functionFieldNormalClosureConstantBase_eq_compositum K L] + exact hw + exact D.add_mem (hzD hzB) (hwD hwB) + · intro z hz hzD hzInvB + have hzB : z ∈ FunctionFieldNormalClosureConstantBase K L := by + rw [functionFieldNormalClosureConstantBase_eq_compositum K L] + exact hz + exact D.inv_mem (hzD hzB) + · intro z w hz hw hzD hwD hzwB + have hzB : z ∈ FunctionFieldNormalClosureConstantBase K L := by + rw [functionFieldNormalClosureConstantBase_eq_compositum K L] + exact hz + have hwB : w ∈ FunctionFieldNormalClosureConstantBase K L := by + rw [functionFieldNormalClosureConstantBase_eq_compositum K L] + exact hw + exact D.mul_mem (hzD hzB) (hwD hwB) + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/FunctionFieldNormalClosureRatFuncEquiv.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/FunctionFieldNormalClosureRatFuncEquiv.lean new file mode 100644 index 0000000000..9dbe104895 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/FunctionFieldNormalClosureRatFuncEquiv.lean @@ -0,0 +1,97 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.FunctionFieldNormalClosureRatFuncBase + +/-! +# The rational-function equivalence for the normal-closure constant base + +This file packages the generation theorem from +`FunctionFieldNormalClosureRatFuncBase` as an explicit algebra equivalence +between `C(t)` and the kernel fixed field. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +noncomputable section + + +/-- A field generated by one transcendental element is a rational function field. -/ +noncomputable def ratFuncEquivOfAdjoinEqTop + {C B : Type*} [Field C] [Field B] [Algebra C B] + (x : B) (hx : Transcendental C x) + (hgen : IntermediateField.adjoin C ({x} : Set B) = ⊤) : + RatFunc C ≃ₐ[C] B := + (RatFunc.algEquivOfTranscendental x hx).trans + ((IntermediateField.equivOfEq hgen).trans IntermediateField.topEquiv) + +@[simp] private theorem ratFuncEquivOfAdjoinEqTop_X + {C B : Type*} [Field C] [Field B] [Algebra C B] + (x : B) (hx : Transcendental C x) + (hgen : IntermediateField.adjoin C ({x} : Set B) = ⊤) : + ratFuncEquivOfAdjoinEqTop x hx hgen RatFunc.X = x := by + simp [ratFuncEquivOfAdjoinEqTop] + +/-- The canonical constant-field algebra on its rational function field. -/ +@[reducible] noncomputable def ratFuncSelfAlgebra + (C : Type*) [Field C] : Algebra C (RatFunc C) := + RatFunc.instAlgebraOfPolynomial C C + +variable (K L : Type*) [Field K] [Field L] + [Fintype K] [DecidableEq K] [DecidableEq (RatFunc K)] + [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +local instance functionFieldNormalClosureConstantFieldRatFuncAlgebra : + Algebra (FunctionFieldNormalClosureConstantField K L) + (RatFunc (FunctionFieldNormalClosureConstantField K L)) := + ratFuncSelfAlgebra (FunctionFieldNormalClosureConstantField K L) + +/-- The kernel fixed field is canonically the rational function field over +the exact constant field, with the original parameter corresponding to `X`. +-/ +noncomputable def functionFieldNormalClosureConstantBaseRatFuncAlgEquiv : + RatFunc (FunctionFieldNormalClosureConstantField K L) ≃ₐ[ + FunctionFieldNormalClosureConstantField K L] + FunctionFieldNormalClosureConstantBase K L := + ratFuncEquivOfAdjoinEqTop + (functionFieldNormalClosureConstantBaseX K L) + (functionFieldNormalClosureConstantBaseX_transcendental K L) + (functionFieldNormalClosureConstantBase_adjoin_X K L) + +/-- The rational-function specialization that sends `X` to the original +parameter in the kernel fixed field. -/ +noncomputable def functionFieldNormalClosureConstantBaseRatFuncAlgHom : + RatFunc (FunctionFieldNormalClosureConstantField K L) →ₐ[ + FunctionFieldNormalClosureConstantField K L] + FunctionFieldNormalClosureConstantBase K L := + (functionFieldNormalClosureConstantBaseRatFuncAlgEquiv K L).toAlgHom + +omit [Fintype K] [DecidableEq K] [DecidableEq (RatFunc K)] in +/-- The rational-function specialization onto the kernel fixed field is +surjective because the parameter generates that field over its constants. -/ +theorem functionFieldNormalClosureConstantBaseRatFuncAlgHom_surjective : + Function.Surjective + (functionFieldNormalClosureConstantBaseRatFuncAlgHom K L) := + (functionFieldNormalClosureConstantBaseRatFuncAlgEquiv K L).surjective + +omit [Fintype K] [DecidableEq K] [DecidableEq (RatFunc K)] in +@[simp] +theorem functionFieldNormalClosureConstantBaseRatFuncAlgEquiv_X : + functionFieldNormalClosureConstantBaseRatFuncAlgEquiv K L RatFunc.X = + functionFieldNormalClosureConstantBaseX K L := by + exact ratFuncEquivOfAdjoinEqTop_X + (C := FunctionFieldNormalClosureConstantField K L) + (B := FunctionFieldNormalClosureConstantBase K L) _ _ _ + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/GaloisAverage.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/GaloisAverage.lean new file mode 100644 index 0000000000..da540bd409 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/GaloisAverage.lean @@ -0,0 +1,172 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.FixedPointAverage +public import Mathlib.Algebra.CharP.Defs +public import Mathlib.Algebra.Order.Star.Real +public import Mathlib.Analysis.Asymptotics.Defs +public import Mathlib.Tactic + +/-! +# The finite averaging step in the Corvaja--Zannier Hasse--Weil argument + +The Galois-closure argument produces finitely many twisted fixed-point error +terms. Every twist has the same upper bound, while their sum is small. The +elementary lemma below converts those facts into a two-sided bound for each +individual twist. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +open scoped BigOperators +open Filter Asymptotics + +/-- If every term in a nonempty finite family is at most `B` and the total +sum has absolute value at most `A`, then every term has a two-sided bound. +This is the numerical core of the Galois-twist averaging step. -/ +theorem abs_le_of_uniform_upper_and_abs_sum_le + {ι : Type*} [Fintype ι] + (E : ι → ℝ) (i : ι) (A B : ℝ) + (hB : 0 ≤ B) (hupper : ∀ j, E j ≤ B) + (hsum : |∑ j, E j| ≤ A) : + |E i| ≤ A + (Fintype.card ι - 1 : ℕ) * B := by + classical + have hA : 0 ≤ A := (abs_nonneg _).trans hsum + have hcard : 1 ≤ Fintype.card ι := Fintype.card_pos_iff.mpr ⟨i⟩ + have heraseCard : (Finset.univ.erase i).card = Fintype.card ι - 1 := by + rw [Finset.card_erase_of_mem (Finset.mem_univ i), Finset.card_univ] + have hrest : ∑ j ∈ Finset.univ.erase i, E j ≤ + (Fintype.card ι - 1 : ℕ) * B := by + calc + ∑ j ∈ Finset.univ.erase i, E j ≤ + ∑ _j ∈ Finset.univ.erase i, B := by + exact Finset.sum_le_sum fun j _ => hupper j + _ = (Fintype.card ι - 1 : ℕ) * B := by + simp [heraseCard] + have hsumSplit : ∑ j, E j = E i + ∑ j ∈ Finset.univ.erase i, E j := by + rw [← Finset.sum_erase_add _ _ (Finset.mem_univ i)] + ring + have hlowerSum : -A ≤ ∑ j, E j := (abs_le.mp hsum).1 + have hlower : -(A + (Fintype.card ι - 1 : ℕ) * B) ≤ E i := by + rw [hsumSplit] at hlowerSum + linarith + have hupper' : E i ≤ A + (Fintype.card ι - 1 : ℕ) * B := by + by_cases hsingleton : Fintype.card ι = 1 + · have huniv : (Finset.univ : Finset ι) = {i} := + univ_eq_singleton_of_card_one i hsingleton + have hEi : |E i| ≤ A := by simpa [huniv] using hsum + simpa [hsingleton] using (le_trans (le_abs_self (E i)) hEi) + · have htwo : 2 ≤ Fintype.card ι := by omega + have hcoefficientNat : 1 ≤ Fintype.card ι - 1 := by omega + have hcoefficient : (1 : ℝ) ≤ (Fintype.card ι - 1 : ℕ) := by + exact_mod_cast hcoefficientNat + calc + E i ≤ B := hupper i + _ ≤ (Fintype.card ι - 1 : ℕ) * B := by + exact le_mul_of_one_le_left hB hcoefficient + _ ≤ A + (Fintype.card ι - 1 : ℕ) * B := le_add_of_nonneg_left hA + exact abs_le.mpr ⟨hlower, hupper'⟩ + +/-- Sequence form of Galois averaging. A uniform `B * rho ^ n` upper bound +for all twists, together with a bounded total error, gives the same geometric +growth rate as a two-sided bound for every twist. -/ +theorem abs_twistError_le_geometric_of_uniform_upper_and_abs_sum_le + {ι : Type*} [Fintype ι] + (E : ℕ → ι → ℝ) (i : ι) (A B rho : ℝ) + (hA : 0 ≤ A) (hB : 0 ≤ B) (hrho : 1 ≤ rho) + (hupper : ∀ n j, E n j ≤ B * rho ^ n) + (hsum : ∀ n, |∑ j, E n j| ≤ A) (n : ℕ) : + |E n i| ≤ (A + (Fintype.card ι - 1 : ℕ) * B) * rho ^ n := by + classical + have hrhoPow : 1 ≤ rho ^ n := one_le_pow₀ hrho + have hgeometricNonneg : 0 ≤ B * rho ^ n := by positivity + have hraw := abs_le_of_uniform_upper_and_abs_sum_le + (E n) i A (B * rho ^ n) hgeometricNonneg (hupper n) (hsum n) + calc + |E n i| ≤ A + (Fintype.card ι - 1 : ℕ) * (B * rho ^ n) := hraw + _ ≤ A * rho ^ n + (Fintype.card ι - 1 : ℕ) * (B * rho ^ n) := by + gcongr + simpa using (mul_le_mul_of_nonneg_left hrhoPow hA) + _ = (A + (Fintype.card ι - 1 : ℕ) * B) * rho ^ n := by ring + +/-- The finite averaging estimate gives the geometric `O(rho ^ n)` bound +needed by the zeta-function power-sum argument. -/ +theorem twistError_isBigO_geometric_of_uniform_upper_and_abs_sum_le + {ι : Type*} [Fintype ι] + (E : ℕ → ι → ℝ) (i : ι) (A B rho : ℝ) + (hA : 0 ≤ A) (hB : 0 ≤ B) (hrho : 1 ≤ rho) + (hupper : ∀ n j, E n j ≤ B * rho ^ n) + (hsum : ∀ n, |∑ j, E n j| ≤ A) : + (fun n : ℕ ↦ E n i) =O[atTop] fun n : ℕ ↦ rho ^ n := by + classical + let C : ℝ := A + ((Fintype.card ι - 1 : ℕ) : ℝ) * B + have hC : 0 ≤ C := by + dsimp [C] + positivity + apply IsBigO.of_bound C + filter_upwards [] with n + rw [Real.norm_eq_abs, Real.norm_eq_abs, + abs_of_nonneg (pow_nonneg (le_trans zero_le_one hrho) n)] + simpa only [C] using + abs_twistError_le_geometric_of_uniform_upper_and_abs_sum_le + E i A B rho hA hB hrho hupper hsum n + +/-- If a nonempty finite family is uniformly close to `center` and its sum +is close to `card · base`, then `base` is close to `center`. The deliberately +division-free bound is convenient for integral point counts and is uniform +when the family cardinality is fixed. -/ +theorem abs_base_sub_center_le_of_average_and_pointwise + {ι : Type*} [Fintype ι] [Nonempty ι] + (x : ι → ℝ) (base center A B : ℝ) + (_hA : 0 ≤ A) (_hB : 0 ≤ B) + (haverage : |∑ i, x i - (Fintype.card ι : ℝ) * base| ≤ A) + (hpointwise : ∀ i, |x i - center| ≤ B) : + |base - center| ≤ A + (Fintype.card ι : ℝ) * B := by + classical + have hcardNat : 1 ≤ Fintype.card ι := + Fintype.card_pos_iff.mpr inferInstance + have hcard : (1 : ℝ) ≤ Fintype.card ι := by + exact_mod_cast hcardNat + have hsum : |∑ i, (x i - center)| ≤ + (Fintype.card ι : ℝ) * B := by + calc + |∑ i, (x i - center)| ≤ ∑ i, |x i - center| := + Finset.abs_sum_le_sum_abs _ _ + _ ≤ ∑ _i : ι, B := Finset.sum_le_sum fun i _ => hpointwise i + _ = (Fintype.card ι : ℝ) * B := by + rw [Finset.sum_const, Finset.card_univ, nsmul_eq_mul] + have hscaled : |(Fintype.card ι : ℝ) * (base - center)| ≤ + A + (Fintype.card ι : ℝ) * B := by + have hid : (Fintype.card ι : ℝ) * (base - center) = + -(∑ i, x i - (Fintype.card ι : ℝ) * base) + + ∑ i, (x i - center) := by + simp only [Finset.sum_sub_distrib, Finset.sum_const, + Finset.card_univ, nsmul_eq_mul] + ring + rw [hid] + calc + |-(∑ i, x i - (Fintype.card ι : ℝ) * base) + + ∑ i, (x i - center)| ≤ + |-(∑ i, x i - (Fintype.card ι : ℝ) * base)| + + |∑ i, (x i - center)| := abs_add_le _ _ + _ ≤ A + (Fintype.card ι : ℝ) * B := by + gcongr + simpa only [abs_neg] using haverage + have hnonneg : 0 ≤ |base - center| := abs_nonneg _ + calc + |base - center| ≤ + (Fintype.card ι : ℝ) * |base - center| := by + nlinarith + _ = |(Fintype.card ι : ℝ) * (base - center)| := by + rw [abs_mul, abs_of_nonneg (by positivity : + (0 : ℝ) ≤ Fintype.card ι)] + _ ≤ A + (Fintype.card ι : ℝ) * B := hscaled + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/GaloisTowerFactorialDegree.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/GaloisTowerFactorialDegree.lean new file mode 100644 index 0000000000..9598c56401 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/GaloisTowerFactorialDegree.lean @@ -0,0 +1,63 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import Mathlib.FieldTheory.Galois.Basic + +/-! +# A common factorial degree for Galois groups in a field tower + +For `R ⊆ L ⊆ N`, the order of `Gal(N/L)` is at most `[N:R]`. +Consequently every such intermediate Galois-group order divides the +factorial of the top degree. This supplies one auxiliary constant-extension +degree that works simultaneously for the rational base and the original +compositum in the Frobenius-twist argument. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +noncomputable section + +/-- The Galois group over the bottom field itself divides the factorial of +the extension degree. -/ +theorem natCard_aut_dvd_finrank_factorial + (R N : Type*) [Field R] [Field N] [Algebra R N] + [FiniteDimensional R N] [IsGalois R N] : + Nat.card (N ≃ₐ[R] N) ∣ (Module.finrank R N).factorial := by + rw [IsGalois.card_aut_eq_finrank] + exact Nat.dvd_factorial Module.finrank_pos le_rfl + +variable (R L N : Type*) [Field R] [Field L] [Field N] + [Algebra R L] [Algebra L N] [Algebra R N] + [IsScalarTower R L N] + [FiniteDimensional R L] [FiniteDimensional L N] + [IsGalois L N] + +/-- The intermediate Galois group order is bounded by the degree over the +bottom field. -/ +theorem natCard_aut_le_finrank_of_tower : + Nat.card (N ≃ₐ[L] N) ≤ Module.finrank R N := by + rw [IsGalois.card_aut_eq_finrank] + calc + Module.finrank L N ≤ + Module.finrank R L * Module.finrank L N := + Nat.le_mul_of_pos_left _ Module.finrank_pos + _ = Module.finrank R N := Module.finrank_mul_finrank R L N + +/-- A single factorial of the top degree is divisible by the order of every +intermediate Galois group in the tower. -/ +theorem natCard_aut_dvd_finrank_factorial_of_tower : + Nat.card (N ≃ₐ[L] N) ∣ (Module.finrank R N).factorial := by + exact Nat.dvd_factorial + (Nat.card_pos : 0 < Nat.card (N ≃ₐ[L] N)) + (natCard_aut_le_finrank_of_tower R L N) + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/GeneralBivariateAffineHasseWeil.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/GeneralBivariateAffineHasseWeil.lean new file mode 100644 index 0000000000..c9953daf8f --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/GeneralBivariateAffineHasseWeil.lean @@ -0,0 +1,188 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionHasseWeil +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneAffineHasseWeilFromZeta +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneConstantField +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneCurveGenusBoundAutomatic +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneFrobeniusReduction + +/-! +# The general affine bivariate Hasse--Weil theorem + +The closed Hasse--Weil theorem for finite separable extensions of `K(X)` is +applied to the function field of a separating absolutely irreducible plane +curve. Exact constants and the bidegree genus budget identify its intrinsic +Hasse bound, while the existing normalization-to-affine comparison gives the +coefficient `8`. Frobenius deflation then removes both separating-coordinate +hypotheses without changing the affine point count or increasing the supplied +bidegree bounds. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +open BGS.CorvajaZannier + +noncomputable section + +/-- The coefficient-`8` affine Hasse--Weil estimate for a separating +absolutely irreducible plane equation. -/ +theorem + abs_affinePlaneCurveZeros_card_sub_card_le_eight_mul_bidegree_of_separating + {K : Type*} [Field K] [Fintype K] [DecidableEq K] + {f : MvPolynomial (Fin 2) K} {firstDegree secondDegree : ℕ} + (hfirst : 0 < firstDegree) + (hsecond : 0 < secondDegree) + (hdegree : BGS.External.HasBidegreeAtMost + f firstDegree secondDegree) + (habsolute : Irreducible + (MvPolynomial.map (algebraMap K (AlgebraicClosure K)) f)) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) : + |((BGS.External.affinePlaneCurveZeros K f).card : ℝ) - + (Fintype.card K : ℝ)| ≤ + 8 * Real.sqrt (Fintype.card K : ℝ) * + (firstDegree : ℝ) * (secondDegree : ℝ) := by + classical + let hf : Irreducible f := + irreducible_of_irreducible_map_algebraicClosure habsolute + letI : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let L := PlaneCurveFunctionField f + let canonicalAlg : Algebra K L := inferInstance + let ratAlg : Algebra (RatFunc K) L := + planeCurveFirstCoordinateRatFuncAlgebra f hx + letI : Algebra (RatFunc K) L := ratAlg + letI : SMul (RatFunc K) L := ratAlg.toSMul + letI : Module (RatFunc K) L := ratAlg.toModule + letI : FiniteDimensional (RatFunc K) L := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + letI : Algebra.IsSeparable (RatFunc K) L := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + letI : DecidableEq (RatFunc K) := Classical.decEq _ + let inducedAlg : Algebra K L := bridgeBaseConstantAlgebra K L + have hinducedAlg : inducedAlg = canonicalAlg := by + apply Algebra.algebra_ext + intro c + change (@ratFuncSpecialization K L _ _ canonicalAlg + (planeCurveFunction f 0) hx) (RatFunc.C c) = + @algebraMap K L _ _ canonicalAlg c + have h := DFunLike.congr_fun + (@ratFuncSpecialization_comp_polynomial_algebraMap + K L _ _ canonicalAlg (planeCurveFunction f 0) hx) + (Polynomial.C c) + simpa using h + letI : Algebra K L := inducedAlg + let budget := (firstDegree - 1) * (secondDegree - 1) + have hExactCanonical : + @algebraicClosure K L _ _ canonicalAlg = + (⊥ : @IntermediateField K L _ _ canonicalAlg) := by + simpa only [L] using + planeCurveFunctionField_algebraicClosure_eq_bot + f habsolute hpartialSecond + have hExact : algebraicClosure K L = + (⊥ : IntermediateField K L) := by + change @algebraicClosure K L _ _ inducedAlg = + (⊥ : @IntermediateField K L _ _ inducedAlg) + rw [hinducedAlg] + exact hExactCanonical + have hgenusActualCanonical : + @FunctionField.genus K L _ _ canonicalAlg ≤ + planeCurveBidegreeGenusBudget f := by + simpa only [L] using + planeCurve_genus_le_bidegreeGenusBudget + habsolute hpartialFirst hpartialSecond + have hfirstDegree : MvPolynomial.degreeOf 0 f ≤ firstDegree := + degreeOf_first_le_of_hasBidegreeAtMost hdegree + have hsecondDegree : MvPolynomial.degreeOf 1 f ≤ secondDegree := + degreeOf_second_le_of_hasBidegreeAtMost hdegree + have hbudget : planeCurveBidegreeGenusBudget f ≤ budget := by + dsimp only [planeCurveBidegreeGenusBudget, budget] + exact Nat.mul_le_mul + (Nat.sub_le_sub_right hfirstDegree 1) + (Nat.sub_le_sub_right hsecondDegree 1) + have hgenusCanonical : + @FunctionField.genus K L _ _ canonicalAlg ≤ budget := + hgenusActualCanonical.trans hbudget + have hgenus : FunctionField.genus K L ≤ budget := by + change @FunctionField.genus K L _ _ inducedAlg ≤ budget + rw [hinducedAlg] + exact hgenusCanonical + have hhasse := finiteExtensionClosedPlaceHasseWeil K L hExact + rw [finiteExtensionClosedPlaceExtensionCount_one_eq_rationalPlaceCount K L] + at hhasse + have hnormalization : + |(separatingPlaneCurveRationalPlaceCount f hf hpartialSecond : ℝ) - + (Fintype.card K : ℝ) - 1| ≤ + (2 * (budget : ℝ) + 1) * + Real.sqrt (Fintype.card K : ℝ) := by + change + |(@finiteExtensionRationalPlaceCount K _ _ L _ ratAlg + (Classical.decEq (RatFunc K)) : ℝ) - + (Fintype.card K : ℝ) - 1| ≤ + (2 * (budget : ℝ) + 1) * Real.sqrt (Fintype.card K : ℝ) + have hhasse' : + |(@finiteExtensionRationalPlaceCount K _ _ L _ ratAlg + (Classical.decEq (RatFunc K)) : ℝ) - + (Fintype.card K : ℝ) - 1| ≤ + (2 * FunctionField.genus K L + 1 : ℝ) * + Real.sqrt (Fintype.card K : ℝ) := by + simpa only [Fintype.card_eq_nat_card] using hhasse + apply hhasse'.trans + apply mul_le_mul_of_nonneg_right _ (Real.sqrt_nonneg _) + exact_mod_cast Nat.add_le_add_right (Nat.mul_le_mul_left 2 hgenus) 1 + rw [affinePlaneCurveZeros_card_eq_affinePlaneCurvePoint_card] + exact + abs_affinePlaneCurvePoint_card_sub_card_le_eight_mul_bidegree_of_rationalPlaceHasse + hdegree hf hpartialFirst hpartialSecond hfirst hsecond + (show 2 * budget + 1 ≤ + 2 * ((firstDegree - 1) * (secondDegree - 1)) + 1 by rfl) + (by simpa using hnormalization) + +/-- The coefficient-`8` affine Hasse--Weil estimate for every absolutely +irreducible bivariate equation of positive supplied bidegree. -/ +theorem abs_affinePlaneCurveZeros_card_sub_card_le_eight_mul_bidegree + (K : Type*) [Field K] [Fintype K] [DecidableEq K] + (f : MvPolynomial (Fin 2) K) (firstDegree secondDegree : ℕ) + (hfirst : 0 < firstDegree) + (hsecond : 0 < secondDegree) + (hdegree : BGS.External.HasBidegreeAtMost + f firstDegree secondDegree) + (habsolute : Irreducible + (MvPolynomial.map (algebraMap K (AlgebraicClosure K)) f)) : + |((BGS.External.affinePlaneCurveZeros K f).card : ℝ) - + (Fintype.card K : ℝ)| ≤ + 8 * Real.sqrt (Fintype.card K : ℝ) * + (firstDegree : ℝ) * (secondDegree : ℝ) := by + exact abs_affinePlaneCurveZeros_card_sub_card_le_of_separating_case + K f firstDegree secondDegree hdegree habsolute + (fun g hgdegree hgabsolute hgpartialFirst hgpartialSecond => + abs_affinePlaneCurveZeros_card_sub_card_le_eight_mul_bidegree_of_separating + hfirst hsecond hgdegree hgabsolute hgpartialFirst hgpartialSecond) + +/-- The in-repository inhabitant of the general affine bivariate +Hasse--Weil interface. -/ +theorem bivariateAffineHasseWeilBound_eight : + BGS.External.BivariateAffineHasseWeilBound 8 := by + intro K _ _ _ f firstDegree secondDegree hfirst hsecond hdegree habsolute + exact abs_affinePlaneCurveZeros_card_sub_card_le_eight_mul_bidegree + K f firstDegree secondDegree hfirst hsecond hdegree habsolute + +/-- The in-repository inhabitant of the general affine bivariate +Hasse--Weil interface. -/ +theorem generalBivariateAffineHasseWeilTheorem : + BGS.External.GeneralBivariateAffineHasseWeilTheorem := by + exact ⟨8, by norm_num, bivariateAffineHasseWeilBound_eight⟩ + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/GeneralFiniteExtensionRiemannLower.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/GeneralFiniteExtensionRiemannLower.lean new file mode 100644 index 0000000000..da3b2c1ad2 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/GeneralFiniteExtensionRiemannLower.lean @@ -0,0 +1,315 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneInfinityRiemannLower +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneFinitePlaceRiemannLower +public import LeanPool.MarkoffModP.BGS.HasseWeil.RatFuncParameterPole +public import Mathlib.FieldTheory.PrimitiveElement +public import Mathlib.Tactic + +/-! +# A coarse Riemann inequality for arbitrary function fields + +This file derives the amount of Riemann-space growth needed by the intrinsic +Stepanov argument without appealing to an external Riemann--Roch theorem. + +For a finite separable extension `L / K(X)`, choose a primitive element `y`. +The monomials `X^i y^j` with `j < [L : K(X)]` are linearly independent. Their +pole divisors give a cofinal family of effective divisors supported above +infinity and hence a coarse, but uniform-for-`L`, Riemann inequality. The +finite-place approximation theorem then transfers this inequality to every +one-point divisor at a finite place. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +open BGS.CorvajaZannier +open scoped nonZeroDivisors Polynomial BigOperators + +noncomputable section + + +variable (K : Type*) [Field K] [Fintype K] [DecidableEq K] + [DecidableEq (RatFunc K)] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +local instance generalRiemannConstantAlgebra : Algebra K L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K (RatFunc K))) + +local instance generalRiemannConstantTower : + IsScalarTower K (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + +local instance generalRiemannInfinityModuleFinite : + Module.Finite (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.finite (RatFuncInfinityIntegers K) (RatFunc K) L + (RatFuncInfinityIntegralClosure K L) + +/-- A monomial grid with the expected `X`-height gives a Riemann inequality +for every effective divisor supported above infinity. -/ +theorem infinitySupported_riemann_lower_of_monomial + (x y : L) (hx0 : x ≠ 0) (hy0 : y ≠ 0) (b : Nat) + (hLI : ∀ n, LinearIndependent K + (planeMonomialGrid x y (n + 1) b)) + (hxHeight : finiteExtensionHeight K L x = b) + (hxInfinity : ∀ P : FiniteExtensionInfinityPlace K L, + 0 < finiteExtensionPoleDivisor K L x (.inr P)) : + ∀ (E : FiniteExtensionDivisor K L), + (∀ v, 0 ≤ E v) → + (∀ q : FiniteExtensionFinitePlace K L, E (.inl q) = 0) → + (finiteExtensionDivisorDegree K L E).toNat + 1 ≤ + Module.finrank K (finiteExtensionRiemannSpace K L E) + + ((b - 1) * finiteExtensionHeight K L y + 1) := by + intro E hE hEfinite + let H := finiteExtensionPoleDivisor K L x + have hH : ∀ v, 0 ≤ H v := + finiteExtensionPoleDivisor_effective K L x + obtain ⟨n, hEH⟩ := + exists_nsmul_ge_of_effective_supportedAtInfinity + K L E H hE hEfinite hH hxInfinity + let D : FiniteExtensionDivisor K L := + planeMonomialPoleBudget K L x y n b + have hD : ∀ v, 0 ≤ D v := by + intro v + dsimp only [D, planeMonomialPoleBudget] + simp only [Finsupp.add_apply, Finsupp.nsmul_apply] + exact add_nonneg + (nsmul_nonneg (finiteExtensionPoleDivisor_effective K L x v) n) + (nsmul_nonneg (finiteExtensionPoleDivisor_effective K L y v) (b - 1)) + have hED : E ≤ D := by + intro v + have hleft := hEH v + dsimp only [H] at hleft + dsimp only [D, planeMonomialPoleBudget] + exact hleft.trans (le_add_of_nonneg_right + (nsmul_nonneg (finiteExtensionPoleDivisor_effective K L y v) (b - 1))) + let A : FiniteExtensionDivisor K L := D - E + have hA : ∀ v, 0 ≤ A v := by + intro v + dsimp only [A] + exact sub_nonneg.mpr (hED v) + have hsplit : E + A = D := by + dsimp only [A] + abel + let : Module.Finite K (finiteExtensionRiemannSpace K L E) := + finiteExtensionRiemannSpace_effective_moduleFinite K L E hE + have hstrip := + finiteExtensionRiemannSpace_add_effective K L E A hE hA + rw [hsplit] at hstrip + have hmono : (n + 1) * b ≤ + Module.finrank K (finiteExtensionRiemannSpace K L D) := by + let hfiniteD : Module.Finite K (finiteExtensionRiemannSpace K L D) := + finiteExtensionRiemannSpace_effective_moduleFinite K L D hD + exact add_one_mul_le_finrank_poleDivisorBudget + K L x y hx0 hy0 n b (hLI n) hfiniteD + have hDdegree : finiteExtensionDivisorDegree K L D = + (n * b + (b - 1) * finiteExtensionHeight K L y : Nat) := by + dsimp only [D, planeMonomialPoleBudget] + rw [finiteExtensionDivisorDegree_pow_mul_pow_budget, hxHeight] + push_cast + ring + have hDdegreeNonnegative : 0 ≤ finiteExtensionDivisorDegree K L D := + finiteExtensionDivisorDegree_nonnegative_of_effective K L D hD + have hDdegreeNat : (finiteExtensionDivisorDegree K L D).toNat = + n * b + (b - 1) * finiteExtensionHeight K L y := by + apply Int.ofNat_injective + rw [Int.ofNat_eq_natCast, Int.toNat_of_nonneg hDdegreeNonnegative] + exact hDdegree + have hDriemann : (finiteExtensionDivisorDegree K L D).toNat + 1 ≤ + Module.finrank K (finiteExtensionRiemannSpace K L D) + + ((b - 1) * finiteExtensionHeight K L y + 1) := by + rw [hDdegreeNat] + have hnb : n * b ≤ (n + 1) * b := + Nat.mul_le_mul_right b (Nat.le_succ n) + omega + have hEdegreeNonnegative : 0 ≤ finiteExtensionDivisorDegree K L E := + finiteExtensionDivisorDegree_nonnegative_of_effective K L E hE + have hAdegreeNonnegative : 0 ≤ finiteExtensionDivisorDegree K L A := + finiteExtensionDivisorDegree_nonnegative_of_effective K L A hA + have hdegreeSplit : + (finiteExtensionDivisorDegree K L D).toNat = + (finiteExtensionDivisorDegree K L E).toNat + + (finiteExtensionDivisorDegree K L A).toNat := by + have hdegree : finiteExtensionDivisorDegree K L D = + finiteExtensionDivisorDegree K L E + + finiteExtensionDivisorDegree K L A := by + rw [← hsplit, finiteExtensionDivisorDegree_add] + rw [hdegree, Int.toNat_add hEdegreeNonnegative hAdegreeNonnegative] + have hstripRank : + Module.finrank K (finiteExtensionRiemannSpace K L D) ≤ + Module.finrank K (finiteExtensionRiemannSpace K L E) + + (finiteExtensionDivisorDegree K L A).toNat := hstrip.2 + have hcombined : + (finiteExtensionDivisorDegree K L E).toNat + + (finiteExtensionDivisorDegree K L A).toNat + 1 ≤ + (Module.finrank K (finiteExtensionRiemannSpace K L E) + + (finiteExtensionDivisorDegree K L A).toNat) + + ((b - 1) * finiteExtensionHeight K L y + 1) := by + calc + (finiteExtensionDivisorDegree K L E).toNat + + (finiteExtensionDivisorDegree K L A).toNat + 1 = + (finiteExtensionDivisorDegree K L D).toNat + 1 := by + rw [hdegreeSplit] + _ ≤ Module.finrank K (finiteExtensionRiemannSpace K L D) + + ((b - 1) * finiteExtensionHeight K L y + 1) := hDriemann + _ ≤ (Module.finrank K (finiteExtensionRiemannSpace K L E) + + (finiteExtensionDivisorDegree K L A).toNat) + + ((b - 1) * finiteExtensionHeight K L y + 1) := + Nat.add_le_add_right hstripRank _ + omega + +/-- A nonzero primitive element and the exact pole height of `X` supply the +monomial hypotheses of `infinitySupported_riemann_lower_of_monomial`. -/ +theorem infinitySupported_riemann_lower_of_primitive + (x y : L) (hx0 : x ≠ 0) (hy0 : y ≠ 0) + (hxMap : algebraMap (RatFunc K) L RatFunc.X = x) + (hprimitive : IntermediateField.adjoin (RatFunc K) {y} = ⊤) + (hxHeight : finiteExtensionHeight K L x = + Module.finrank (RatFunc K) L) + (hxInfinity : ∀ P : FiniteExtensionInfinityPlace K L, + 0 < finiteExtensionPoleDivisor K L x (.inr P)) : + ∀ (E : FiniteExtensionDivisor K L), + (∀ v, 0 ≤ E v) → + (∀ q : FiniteExtensionFinitePlace K L, E (.inl q) = 0) → + (finiteExtensionDivisorDegree K L E).toNat + 1 ≤ + Module.finrank K (finiteExtensionRiemannSpace K L E) + + ((Module.finrank (RatFunc K) L - 1) * + finiteExtensionHeight K L y + 1) := by + let d := Module.finrank (RatFunc K) L + have hyInt : IsIntegral (RatFunc K) y := IsIntegral.of_finite _ _ + have hdegree : (minpoly (RatFunc K) y).natDegree = d := by + calc + (minpoly (RatFunc K) y).natDegree = + Module.finrank (RatFunc K) + (IntermediateField.adjoin (RatFunc K) {y}) := + (IntermediateField.adjoin.finrank hyInt).symm + _ = Module.finrank (RatFunc K) + (⊤ : IntermediateField (RatFunc K) L) := by + rw [hprimitive] + _ = Module.finrank (RatFunc K) L := by + rw [IntermediateField.finrank_top'] + have hLI : ∀ n, LinearIndependent K + (planeMonomialGrid x y (n + 1) d) := by + intro n + have h := planeMonomialGrid_linearIndependent_of_transcendental_minpoly + (RatFunc.X : RatFunc K) y (n + 1) d RatFunc.transcendental_X + (by rw [hdegree]) + rw [hxMap] at h + exact h + simpa only [d] using + infinitySupported_riemann_lower_of_monomial K L x y hx0 hy0 d hLI + (by simpa only [d] using hxHeight) hxInfinity + +omit [Fintype K] [DecidableEq K] [DecidableEq (RatFunc K)] in +/-- A finite separable extension has a primitive element which can be chosen +nonzero, including the degree-one case. -/ +theorem exists_nonzero_primitive_element : + ∃ y : L, y ≠ 0 ∧ + IntermediateField.adjoin (RatFunc K) {y} = ⊤ := by + obtain ⟨y, hy⟩ := Field.exists_primitive_element (RatFunc K) L + by_cases hy0 : y = 0 + · subst y + refine ⟨1, one_ne_zero, ?_⟩ + simpa using hy + · exact ⟨y, hy0, hy⟩ + +/-- The coarse primitive-element Riemann inequality at every finite place. -/ +theorem finitePlace_riemann_lower_of_primitive + (x y : L) (hx0 : x ≠ 0) (hy0 : y ≠ 0) + (hxMap : algebraMap (RatFunc K) L RatFunc.X = x) + (hprimitive : IntermediateField.adjoin (RatFunc K) {y} = ⊤) + (hxHeight : finiteExtensionHeight K L x = + Module.finrank (RatFunc K) L) + (hxInfinity : ∀ P : FiniteExtensionInfinityPlace K L, + 0 < finiteExtensionPoleDivisor K L x (.inr P)) : + ∀ (q : FiniteExtensionFinitePlace K L) (N : ℕ), + N * finiteExtensionPlaceDegree K L (.inl q) + 1 ≤ + Module.finrank K (finiteExtensionOnePointRiemannSpace K L (.inl q) N) + + ((Module.finrank (RatFunc K) L - 1) * + finiteExtensionHeight K L y + 1) := by + intro q N + let g := (Module.finrank (RatFunc K) L - 1) * + finiteExtensionHeight K L y + 1 + have hinfinity := infinitySupported_riemann_lower_of_primitive + K L x y hx0 hy0 hxMap hprimitive hxHeight hxInfinity + by_cases hN : N = 0 + · subst N + have hzero := hinfinity + (0 : FiniteExtensionDivisor K L) (by simp) (by simp) + have hdegreezero : + finiteExtensionDivisorDegree K L + (0 : FiniteExtensionDivisor K L) = 0 := by + simp [finiteExtensionDivisorDegree] + rw [hdegreezero] at hzero + simp only [Int.toNat_zero, zero_add] at hzero + simp only [zero_mul, zero_add] + change 1 ≤ Module.finrank K + (finiteExtensionRiemannSpace K L (Finsupp.single (.inl q) 0)) + g + rw [Finsupp.single_zero] + simpa only [g] using hzero + · have hNpos : 0 < N := Nat.pos_of_ne_zero hN + obtain ⟨E, hE, hEfinite, hrank⟩ := + exists_infinityDivisor_finitePlacePrincipalParts_rank K L q N hNpos + have hEinfinity : + (finiteExtensionDivisorDegree K L E).toNat + 1 ≤ + Module.finrank K (finiteExtensionRiemannSpace K L E) + g := by + simpa only [g] using hinfinity E hE hEfinite + let Dq : FiniteExtensionDivisor K L := + Finsupp.single (.inl q) (N : ℤ) + have hDq : ∀ v, 0 ≤ Dq v := by + intro v + by_cases hv : v = (.inl q : FiniteExtensionPlace K L) + · subst v + simp [Dq] + · simp [Dq, Finsupp.single_eq_of_ne hv] + let : Module.Finite K (finiteExtensionRiemannSpace K L Dq) := + finiteExtensionRiemannSpace_effective_moduleFinite K L Dq hDq + have hstrip := finiteExtensionRiemannSpace_add_effective + K L Dq E hDq hE + change N * finiteExtensionPlaceDegree K L (.inl q) + 1 ≤ + Module.finrank K (finiteExtensionRiemannSpace K L Dq) + g + have hDqEq : Dq = Finsupp.single (.inl q) (N : ℤ) := rfl + rw [← hDqEq] at hrank + omega + +/-- Every finite separable extension of `K(X)` admits a single natural-number +budget for Riemann's inequality at all of its finite places. The budget is +constructed from a nonzero primitive element; no genus or Riemann--Roch input +is assumed. -/ +theorem exists_finitePlace_riemann_lower_budget : + ∃ g : ℕ, ∀ (q : FiniteExtensionFinitePlace K L) (N : ℕ), + N * finiteExtensionPlaceDegree K L (.inl q) + 1 ≤ + Module.finrank K + (finiteExtensionOnePointRiemannSpace K L (.inl q) N) + g := by + let x : L := algebraMap (RatFunc K) L RatFunc.X + obtain ⟨y, hy0, hprimitive⟩ := exists_nonzero_primitive_element K L + let g := (Module.finrank (RatFunc K) L - 1) * + finiteExtensionHeight K L y + 1 + refine ⟨g, ?_⟩ + have hx0 : x ≠ 0 := by + dsimp only [x] + simpa using (algebraMap (RatFunc K) L).injective.ne RatFunc.X_ne_zero + have hxInfinity : ∀ P : FiniteExtensionInfinityPlace K L, + 0 < finiteExtensionPoleDivisor K L x (.inr P) := by + intro P + dsimp only [x] + rw [finiteExtensionPoleDivisor_ratFuncX_inr_eq_ramificationIdx] + exact_mod_cast P.1.ramificationIdx_pos (RatFuncInfinityIntegers K) + simpa only [g] using + finitePlace_riemann_lower_of_primitive K L x y hx0 hy0 rfl + hprimitive (finiteExtensionHeight_ratFuncX_eq_finrank K L) hxInfinity + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/GeneralSquareFieldStepanovCount.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/GeneralSquareFieldStepanovCount.lean new file mode 100644 index 0000000000..c4ccf7b681 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/GeneralSquareFieldStepanovCount.lean @@ -0,0 +1,237 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.RationalPlace +public import LeanPool.MarkoffModP.BGS.HasseWeil.SquareFieldResidue +public import LeanPool.MarkoffModP.BGS.HasseWeil.SquareFieldStepanovZeroCount +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionCanonicalDifferentDivisor +public import Mathlib.Tactic + +/-! +# A square-field Stepanov bound for arbitrary function fields + +The one-point Stepanov construction is intrinsic to a finite separable +extension of a rational function field. This file applies it to the complete +type of degree-one places, rather than to the regular affine points of a +chosen plane model. + +Choose one rational place as the pole. Every rational finite place away from +it is a zero-counting place; at most one rational finite place is omitted. +The rational places above infinity contribute at most the degree of the +function-field extension, by the fundamental ramification-inertia equality. +This gives a uniform estimate suitable for the Frobenius fixed-field twists. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +open BGS.CorvajaZannier +open scoped Polynomial + +noncomputable section + + +variable (K S : Type*) [Field K] [Fintype K] + [Field S] [Fintype S] [DecidableEq S] [Algebra K S] + [DecidableEq (RatFunc S)] +variable (L : Type*) [Field L] [Algebra (RatFunc S) L] + [FiniteDimensional (RatFunc S) L] + [Algebra.IsSeparable (RatFunc S) L] + +local instance generalSquareFieldConstantAlgebra : Algebra S L := + RingHom.toAlgebra ((algebraMap (RatFunc S) L).comp + (algebraMap S (RatFunc S))) + +local instance generalSquareFieldConstantTower : + IsScalarTower S (RatFunc S) L := + IsScalarTower.of_algebraMap_eq' rfl + +local instance generalSquareFieldInfinityModuleFinite : + Module.Finite (RatFuncInfinityIntegers S) + (RatFuncInfinityIntegralClosure S L) := + IsIntegralClosure.finite (RatFuncInfinityIntegers S) (RatFunc S) L + (RatFuncInfinityIntegralClosure S L) + +local instance generalSquareFieldInfinityIntegral : + Algebra.IsIntegral (RatFuncInfinityIntegers S) + (RatFuncInfinityIntegralClosure S L) := + IsIntegralClosure.isIntegral_algebra (RatFuncInfinityIntegers S) L + +local instance generalSquareFieldInfinityTorsionFree : + Module.IsTorsionFree (RatFuncInfinityIntegers S) + (RatFuncInfinityIntegralClosure S L) := + IsIntegralClosure.isTorsionFree (RatFuncInfinityIntegers S) L + +local instance generalSquareFieldInfinityDedekind : + IsDedekindDomain (RatFuncInfinityIntegralClosure S L) := + IsIntegralClosure.isDedekindDomain (RatFuncInfinityIntegers S) + (RatFunc S) L (RatFuncInfinityIntegralClosure S L) + +omit [Fintype S] in +/-- The number of rational places above infinity is at most the function-field +degree. -/ +theorem rationalInfinityPlace_card_le_finrank : + Nat.card (FiniteExtensionRationalInfinityPlace S L) ≤ + Module.finrank (RatFunc S) L := by + let : Fintype (FiniteExtensionInfinityPlace S L) := + Set.Finite.fintype (IsDedekindDomain.primesOver_finite + (ratFuncInfinityPlace S).asIdeal + (RatFuncInfinityIntegralClosure S L)) + calc + Nat.card (FiniteExtensionRationalInfinityPlace S L) ≤ + Nat.card (FiniteExtensionInfinityPlace S L) := + Nat.card_le_card_of_injective Subtype.val Subtype.val_injective + _ = Fintype.card (FiniteExtensionInfinityPlace S L) := + Nat.card_eq_fintype_card + _ = ∑ P : FiniteExtensionInfinityPlace S L, 1 := by simp + _ ≤ ∑ P : FiniteExtensionInfinityPlace S L, + P.1.ramificationIdx (RatFuncInfinityIntegers S) * + P.1.inertiaDeg (RatFuncInfinityIntegers S) := by + apply Finset.sum_le_sum + intro P _ + exact Right.one_le_mul + (Ideal.ramificationIdx_pos P.1 (RatFuncInfinityIntegers S)) + (Ideal.inertiaDeg_pos P.1 (RatFuncInfinityIntegers S)) + _ = Module.finrank (RatFunc S) L := + finiteExtensionInfinity_sum_ramification_inertia_eq_finrank S L + +/-- The intrinsic one-point square-field Stepanov bound for all degree-one +places of a finite separable function field, using Riemann's inequality only +at rational finite places. + +If a rational finite place exists, it is chosen as the pole in the Stepanov +construction. If none exists, all rational places lie above infinity and the +fundamental ramification--inertia equality gives the required bound directly. +Thus no Riemann inequality at an infinity place is needed. -/ +theorem finiteExtensionRationalPlaceCount_le_squareFieldStepanov_of_finitePlaceRiemann + (g : Nat) + (hcard : Fintype.card S = (Fintype.card K) ^ 2) + (hconstants : algebraicClosure S L = ⊥) + (hriemann : ∀ (Q : FiniteExtensionRationalFinitePlace S L) N, + N + 1 ≤ Module.finrank S + (finiteExtensionOnePointRiemannSpace S L (.inl Q.1) N) + g) + (hlarge : (g + 1) * (g + 2) ≤ Fintype.card K) : + finiteExtensionRationalPlaceCount S L ≤ + Fintype.card S + (2 * g + 1) * Fintype.card K + + Module.finrank (RatFunc S) L := by + classical + let s := Fintype.card K + let ell := stepanovEll s + let m := stepanovM g s + have hs : 0 < s := Fintype.card_pos + have hbudget : ell + s * m + 1 = + Fintype.card S + (2 * g + 1) * s := by + calc + ell + s * m + 1 = (s - 1) + s * (s + 2 * g) + 1 := by + rfl + _ = s + s * (s + 2 * g) := by omega + _ = s ^ 2 + (2 * g + 1) * s := by ring + _ = Fintype.card S + (2 * g + 1) * s := by rw [hcard] + by_cases hnonempty : + Nonempty (FiniteExtensionRationalFinitePlace S L) + · let Q0 : FiniteExtensionRationalFinitePlace S L := + Classical.choice hnonempty + let P : FiniteExtensionPlace S L := .inl Q0.1 + have hdegreeP : finiteExtensionPlaceDegree S L P = 1 := Q0.2 + obtain ⟨u, du, v, dv, c, hu, hv, _hc, hsecond, hfirst⟩ := + exists_squareField_onePointStepanovAuxiliary_of_degree_one + K S L P g hconstants hdegreeP (hriemann Q0) hlarge + let p : FiniteExtensionRationalFinitePlace S L → Prop := fun Q => + (Sum.inl Q.1 : FiniteExtensionPlace S L) = P + let Away := {Q : FiniteExtensionRationalFinitePlace S L // ¬ p Q} + let : Fintype Away := Fintype.ofFinite _ + let place : Away → FiniteExtensionFinitePlace S L := fun Q => Q.1.1 + have hplaceInjective : Function.Injective place := by + intro Q R hQR + apply Subtype.ext + apply Subtype.ext + exact hQR + have haway : ∀ Q : Away, + (Sum.inl (place Q) : FiniteExtensionPlace S L) ≠ P := by + intro Q + exact Q.2 + have hsquare : ∀ (Q : Away) (z : (place Q).asIdeal.ResidueField), + z ^ (Fintype.card K) ^ 2 = z := by + intro Q + exact finiteExtensionFinitePlace_residue_squareFrobenius_of_degree_one + K S L hcard (place Q) Q.1.2 + have hAway : Nat.card Away ≤ ell + s * m := by + have h := Fintype.card_le_of_squareFieldStepanovAuxiliary + K S L P ell m u du v dv c hu hv hdegreeP place + hplaceInjective haway hsquare hsecond hfirst + simpa only [Nat.card_eq_fintype_card] using h + have hpSubsingleton : Subsingleton + {Q : FiniteExtensionRationalFinitePlace S L // p Q} := by + constructor + intro Q R + apply Subtype.ext + apply Subtype.ext + exact Sum.inl.inj (Q.2.trans R.2.symm) + have hpCard : Nat.card + {Q : FiniteExtensionRationalFinitePlace S L // p Q} ≤ 1 := by + let := hpSubsingleton + simpa using Nat.card_le_card_of_injective + (fun _ : {Q : FiniteExtensionRationalFinitePlace S L // p Q} => + (Unit.unit : Unit)) + (fun Q R _ => Subsingleton.elim Q R) + have hfinite : Nat.card (FiniteExtensionRationalFinitePlace S L) ≤ + ell + s * m + 1 := by + calc + Nat.card (FiniteExtensionRationalFinitePlace S L) = + Nat.card + ({Q : FiniteExtensionRationalFinitePlace S L // p Q} ⊕ Away) := + Nat.card_congr (Equiv.sumCompl p).symm + _ = Nat.card + {Q : FiniteExtensionRationalFinitePlace S L // p Q} + + Nat.card Away := Nat.card_sum + _ ≤ 1 + (ell + s * m) := Nat.add_le_add hpCard hAway + _ = ell + s * m + 1 := by omega + rw [finiteExtensionRationalPlaceCount, Nat.card_sum] + calc + Nat.card (FiniteExtensionRationalFinitePlace S L) + + Nat.card (FiniteExtensionRationalInfinityPlace S L) ≤ + (ell + s * m + 1) + Module.finrank (RatFunc S) L := + Nat.add_le_add hfinite (rationalInfinityPlace_card_le_finrank S L) + _ = Fintype.card S + (2 * g + 1) * Fintype.card K + + Module.finrank (RatFunc S) L := by rw [hbudget] + · let : IsEmpty (FiniteExtensionRationalFinitePlace S L) := + ⟨fun Q => hnonempty ⟨Q⟩⟩ + rw [finiteExtensionRationalPlaceCount, Nat.card_sum] + simp only [Nat.card_of_isEmpty, zero_add] + exact (rationalInfinityPlace_card_le_finrank S L).trans + (Nat.le_add_left (Module.finrank (RatFunc S) L) + (Fintype.card S + (2 * g + 1) * Fintype.card K)) + +/-- The intrinsic one-point square-field Stepanov bound for all degree-one +places of a finite separable function field. + +This compatibility wrapper preserves the original API. Its stronger +hypothesis supplies the finite-place Riemann inequalities required by +`finiteExtensionRationalPlaceCount_le_squareFieldStepanov_of_finitePlaceRiemann`. +-/ +theorem finiteExtensionRationalPlaceCount_le_squareFieldStepanov + (g : Nat) + (hcard : Fintype.card S = (Fintype.card K) ^ 2) + (hconstants : algebraicClosure S L = ⊥) + (hriemann : ∀ (P : FiniteExtensionPlace S L), + finiteExtensionPlaceDegree S L P = 1 → ∀ N, + N + 1 ≤ Module.finrank S + (finiteExtensionOnePointRiemannSpace S L P N) + g) + (hlarge : (g + 1) * (g + 2) ≤ Fintype.card K) : + finiteExtensionRationalPlaceCount S L ≤ + Fintype.card S + (2 * g + 1) * Fintype.card K + + Module.finrank (RatFunc S) L := by + apply finiteExtensionRationalPlaceCount_le_squareFieldStepanov_of_finitePlaceRiemann + K S L g hcard hconstants _ hlarge + intro Q N + exact hriemann (.inl Q.1) Q.2 N + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/GeneralSquareFieldStepanovCountAutomatic.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/GeneralSquareFieldStepanovCountAutomatic.lean new file mode 100644 index 0000000000..36f0cebd8f --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/GeneralSquareFieldStepanovCountAutomatic.lean @@ -0,0 +1,69 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.GeneralFiniteExtensionRiemannLower +public import LeanPool.MarkoffModP.BGS.HasseWeil.GeneralSquareFieldStepanovCount + +/-! +# Automatic intrinsic Stepanov bounds + +The arbitrary-function-field Stepanov theorem asks only for a finite-place +Riemann budget. The primitive-element construction supplies such a budget +for every finite separable function field. This file composes those results, +leaving only the explicit large-square-field inequality for the constructed +budget. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +open BGS.CorvajaZannier + +noncomputable section + + +variable (K S : Type*) [Field K] [Fintype K] + [Field S] [Fintype S] [DecidableEq S] [Algebra K S] + [DecidableEq (RatFunc S)] +variable (L : Type*) [Field L] [Algebra (RatFunc S) L] + [FiniteDimensional (RatFunc S) L] + [Algebra.IsSeparable (RatFunc S) L] + +local instance automaticSquareFieldConstantAlgebra : Algebra S L := + RingHom.toAlgebra ((algebraMap (RatFunc S) L).comp + (algebraMap S (RatFunc S))) + +local instance automaticSquareFieldConstantTower : + IsScalarTower S (RatFunc S) L := + IsScalarTower.of_algebraMap_eq' rfl + +/-- Every finite separable function field with exact constants has an +intrinsic Stepanov budget. Once the half-sized field is large relative to +that constructed budget, its complete degree-one place count satisfies the +square-field upper bound. -/ +theorem exists_squareFieldStepanov_budget + (hcard : Fintype.card S = (Fintype.card K) ^ 2) + (hconstants : algebraicClosure S L = ⊥) : + ∃ g : ℕ, + (g + 1) * (g + 2) ≤ Fintype.card K → + finiteExtensionRationalPlaceCount S L ≤ + Fintype.card S + (2 * g + 1) * Fintype.card K + + Module.finrank (RatFunc S) L := by + obtain ⟨g, hriemann⟩ := exists_finitePlace_riemann_lower_budget S L + refine ⟨g, fun hlarge => ?_⟩ + apply + finiteExtensionRationalPlaceCount_le_squareFieldStepanov_of_finitePlaceRiemann + K S L g hcard hconstants _ hlarge + intro Q N + have h := hriemann Q.1 N + simpa only [Q.2, Nat.mul_one] using h + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/IdealMultiplicityMap.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/IdealMultiplicityMap.lean new file mode 100644 index 0000000000..97d109f8eb --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/IdealMultiplicityMap.lean @@ -0,0 +1,62 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import Mathlib.RingTheory.RamificationInertia.Ramification + +/-! +# Multiplicity after extending an ideal + +The `emultiplicity` theorem in mathlib is the generic local factorization +statement. This file records the `Nat`-valued wrapper used by the +exact-constant genus transport, first for a specified pair of height-one +places and then with the lower place chosen by `under`. +-/ + +@[expose] public section + +open IsDedekindDomain + +namespace BGS.HasseWeil + +noncomputable section + +variable {R S : Type*} [CommRing R] [CommRing S] + [IsDedekindDomain R] [IsDedekindDomain S] + [Algebra R S] [Module.IsTorsionFree R S] + +/-- Extending a nonzero ideal multiplies its multiplicity at a height-one +prime by the ramification index of that prime. -/ +theorem multiplicity_map_eq_ramificationIdx_mul + (v : HeightOneSpectrum R) (w : HeightOneSpectrum S) + [w.asIdeal.LiesOver v.asIdeal] + (I : Ideal R) (hI : I ≠ ⊥) : + multiplicity w.asIdeal (I.map (algebraMap R S)) = + w.asIdeal.ramificationIdx R * multiplicity v.asIdeal I := by + refine multiplicity_eq_of_emultiplicity_eq_some ?_ + rw [Ideal.IsDedekindDomain.emultiplicity_map_eq_ramificationIdx'_mul + hI v.irreducible w.irreducible w.ne_bot, + Ideal.ramificationIdx'_eq_ramificationIdx v.asIdeal w.asIdeal v.ne_bot, + Nat.cast_mul, + (FiniteMultiplicity.of_prime_left v.prime hI).emultiplicity_eq_multiplicity] + +variable [Algebra.IsIntegral R S] + +/-- The same formula with the lower place chosen canonically by contraction. -/ +theorem multiplicity_map_eq_ramificationIdx_mul_under + (w : HeightOneSpectrum S) (I : Ideal R) (hI : I ≠ ⊥) : + multiplicity w.asIdeal (I.map (algebraMap R S)) = + w.asIdeal.ramificationIdx R * + multiplicity (w.under R).asIdeal I := by + let : w.asIdeal.LiesOver (w.under R).asIdeal := ⟨rfl⟩ + simpa using + multiplicity_map_eq_ramificationIdx_mul + (R := R) (S := S) (w.under R) w I hI + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/LinearFunctionalGluing.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/LinearFunctionalGluing.lean new file mode 100644 index 0000000000..f4ed9dd221 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/LinearFunctionalGluing.lean @@ -0,0 +1,91 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import Mathlib.LinearAlgebra.Basis.VectorSpace +public import Mathlib.LinearAlgebra.LinearPMap + +/-! +# Gluing and extending linear functionals + +This file isolates the linear-algebra step used by the cotrace construction +of a Weil functional. A functional on a subspace `U` which vanishes on +`U ∩ V` glues with the zero functional on `V`; over a field the glued +functional then extends to the ambient vector space. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +noncomputable section + +variable {k E F : Type*} [Field k] + [AddCommGroup E] [Module k E] + [AddCommGroup F] [Module k F] + +/-- A linear map on `U` which vanishes whenever its argument also lies in +`V` extends to the ambient space while vanishing on all of `V`. -/ +theorem exists_linearMap_extending_eq_zero_on + (U V : Submodule k E) (f : U →ₗ[k] F) + (hUV : ∀ x : U, (x : E) ∈ V → f x = 0) : + ∃ g : E →ₗ[k] F, g.comp U.subtype = f ∧ V ≤ LinearMap.ker g := by + let pf : LinearPMap (RingHom.id k) E F := ⟨U, f⟩ + let pzero : LinearPMap (RingHom.id k) E F := ⟨V, 0⟩ + have hagree : ∀ (x : pf.domain) (y : pzero.domain), + (x : E) = y → pf x = pzero y := by + intro x y hxy + change f x = 0 + apply hUV x + exact hxy ▸ y.property + let glued := pf.sup pzero hagree + obtain ⟨g, hg⟩ := LinearMap.exists_extend glued.toFun + refine ⟨g, ?_, ?_⟩ + · apply LinearMap.ext + intro x + let x' : glued.domain := ⟨x, Submodule.mem_sup_left x.property⟩ + have hpf := (pf.left_le_sup pzero hagree).2 + (x := x) (y := x') rfl + have hgx := LinearMap.congr_fun hg x' + exact hgx.trans hpf.symm + · intro x hx + rw [LinearMap.mem_ker] + let x' : glued.domain := ⟨x, Submodule.mem_sup_right hx⟩ + have hpzero := (pf.right_le_sup pzero hagree).2 + (x := ⟨x, hx⟩) (y := x') rfl + have hgx := LinearMap.congr_fun hg x' + exact hgx.trans (hpzero.symm.trans (by rfl)) + +/-- Intersection-subtype form of +`exists_linearMap_extending_eq_zero_on`. -/ +theorem exists_linearMap_extending_eq_zero_on_inf + (U V : Submodule k E) (f : U →ₗ[k] F) + (hUV : ∀ x : ↥(U ⊓ V), f ⟨x, x.property.1⟩ = 0) : + ∃ g : E →ₗ[k] F, g.comp U.subtype = f ∧ V ≤ LinearMap.ker g := by + apply exists_linearMap_extending_eq_zero_on U V f + intro x hx + exact hUV ⟨x, x.property, hx⟩ + +/-- If the original functional is nonzero, the ambient extension can be +chosen nonzero as well. -/ +theorem exists_ne_zero_linearMap_extending_eq_zero_on_inf + (U V : Submodule k E) (f : U →ₗ[k] F) + (hUV : ∀ x : ↥(U ⊓ V), f ⟨x, x.property.1⟩ = 0) + (hf : f ≠ 0) : + ∃ g : E →ₗ[k] F, + g.comp U.subtype = f ∧ V ≤ LinearMap.ker g ∧ g ≠ 0 := by + obtain ⟨g, hgU, hgV⟩ := + exists_linearMap_extending_eq_zero_on_inf U V f hUV + refine ⟨g, hgU, hgV, ?_⟩ + intro hg + apply hf + rw [← hgU, hg] + rfl + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/LocalPoleCumulativeQuotient.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/LocalPoleCumulativeQuotient.lean new file mode 100644 index 0000000000..b0e9aa2d02 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/LocalPoleCumulativeQuotient.lean @@ -0,0 +1,215 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.LocalPoleFiltration +public import Mathlib.RingTheory.LocalRing.Length +public import Mathlib.RingTheory.LocalRing.Quotient + +/-! +# Cumulative local principal parts + +For a DVR uniformizer `π`, the quotient of functions with pole order at most +`n` by the regular functions is the quotient of the DVR by the `n`th power +of its maximal ideal. Over a finite constant field its dimension is +therefore `n` times the residue-field degree. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +open scoped nonZeroDivisors + +noncomputable section + +variable {K R L : Type*} [Field K] [CommRing R] + [IsDedekindDomain R] [IsDiscreteValuationRing R] + [Field L] [Algebra K R] [Algebra R L] [Algebra K L] + [IsScalarTower K R L] [IsFractionRing R L] + +omit [IsDedekindDomain R] [IsDiscreteValuationRing R] + [IsFractionRing R L] in +private theorem cumulativeLocalPoleSpace_regular (π : R) (n : ℕ) : + ∀ x : localPoleSpace (K := K) (L := L) π n, + ∃ r : R, algebraMap R L (π ^ n) * x.1 = algebraMap R L r := by + intro x + exact x.2 + +/-- The normalized numerator modulo the `n`th power of the maximal ideal. -/ +def localPolePrincipalPartMap (π : R) (n : ℕ) : + localPoleSpace (K := K) (L := L) π n →ₗ[K] + R ⧸ IsLocalRing.maximalIdeal R ^ n := + (Ideal.Quotient.mkₐ K (IsLocalRing.maximalIdeal R ^ n)).toLinearMap.comp + (localNormalizedLiftLinearMap + (localPoleSpace (K := K) (L := L) π n) + (algebraMap R L (π ^ n)) + (by exact cumulativeLocalPoleSpace_regular (K := K) (L := L) π n)) + +theorem localPolePrincipalPartMap_surjective + (π : R) (hπ : π ≠ 0) (n : ℕ) : + Function.Surjective + (localPolePrincipalPartMap (K := K) (L := L) π n) := by + intro z + obtain ⟨r, rfl⟩ := Ideal.Quotient.mk_surjective z + have hdenom : algebraMap R L (π ^ n) ≠ 0 := by + rw [map_pow] + exact pow_ne_zero n (by + simpa using (IsFractionRing.injective R L).ne hπ) + let x : L := (algebraMap R L (π ^ n))⁻¹ * algebraMap R L r + have hx : algebraMap R L (π ^ n) * x = algebraMap R L r := by + dsimp only [x] + rw [← mul_assoc, mul_inv_cancel₀ hdenom, one_mul] + let x' : localPoleSpace (K := K) (L := L) π n := ⟨x, r, hx⟩ + refine ⟨x', ?_⟩ + change Ideal.Quotient.mk (IsLocalRing.maximalIdeal R ^ n) + (localNormalizedLift + (localPoleSpace (K := K) (L := L) π n) + (algebraMap R L (π ^ n)) + (cumulativeLocalPoleSpace_regular (K := K) (L := L) π n) x') = + Ideal.Quotient.mk (IsLocalRing.maximalIdeal R ^ n) r + congr 1 + apply IsFractionRing.injective R L + rw [← hx] + exact (localNormalizedLift_spec + (localPoleSpace (K := K) (L := L) π n) + (algebraMap R L (π ^ n)) + (cumulativeLocalPoleSpace_regular (K := K) (L := L) π n) x').symm + +theorem localPolePrincipalPartMap_ker + (π : R) (hπ : π ≠ 0) + (hπIdeal : IsLocalRing.maximalIdeal R = Ideal.span {π}) (n : ℕ) : + (localPolePrincipalPartMap (K := K) (L := L) π n).ker = + Submodule.comap + (localPoleSpace (K := K) (L := L) π n).subtype + (localPoleSpace (K := K) (L := L) π 0) := by + ext x + rw [LinearMap.mem_ker, Submodule.mem_comap] + change Ideal.Quotient.mk (IsLocalRing.maximalIdeal R ^ n) + (localNormalizedLift + (localPoleSpace (K := K) (L := L) π n) + (algebraMap R L (π ^ n)) + (cumulativeLocalPoleSpace_regular (K := K) (L := L) π n) x) = 0 ↔ _ + rw [Ideal.Quotient.eq_zero_iff_mem] + constructor + · intro hr + rw [hπIdeal, Ideal.span_singleton_pow, + Ideal.mem_span_singleton] at hr + obtain ⟨s, hs⟩ := hr + rw [mem_localPoleSpace_iff] + refine ⟨s, ?_⟩ + simp only [pow_zero, map_one, one_mul] + have hlift := localNormalizedLift_spec + (localPoleSpace (K := K) (L := L) π n) + (algebraMap R L (π ^ n)) + (cumulativeLocalPoleSpace_regular (K := K) (L := L) π n) x + rw [hs, map_mul] at hlift + have hdenom : algebraMap R L (π ^ n) ≠ 0 := by + rw [map_pow] + exact pow_ne_zero n (by + simpa using (IsFractionRing.injective R L).ne hπ) + apply mul_left_cancel₀ hdenom + exact hlift + · rintro ⟨s, hs⟩ + have hliftEq : localNormalizedLift + (localPoleSpace (K := K) (L := L) π n) + (algebraMap R L (π ^ n)) + (cumulativeLocalPoleSpace_regular (K := K) (L := L) π n) x = + π ^ n * s := by + apply IsFractionRing.injective R L + rw [map_mul, ← hs] + simp only [pow_zero, map_one, one_mul] + change algebraMap R L + (localNormalizedLift + (localPoleSpace (K := K) (L := L) π n) + (algebraMap R L (π ^ n)) + (cumulativeLocalPoleSpace_regular (K := K) (L := L) π n) x) = + algebraMap R L (π ^ n) * x.1 + exact (localNormalizedLift_spec + (localPoleSpace (K := K) (L := L) π n) + (algebraMap R L (π ^ n)) + (cumulativeLocalPoleSpace_regular (K := K) (L := L) π n) x).symm + rw [hliftEq, hπIdeal, Ideal.span_singleton_pow, + Ideal.mem_span_singleton] + exact ⟨s, rfl⟩ + +/-- Cumulative local principal parts are the quotient by the corresponding +power of the maximal ideal. -/ +def localPoleCumulativeQuotientEquiv + (π : R) (hπ : π ≠ 0) + (hπIdeal : IsLocalRing.maximalIdeal R = Ideal.span {π}) (n : ℕ) : + (localPoleSpace (K := K) (L := L) π n ⧸ + Submodule.comap + (localPoleSpace (K := K) (L := L) π n).subtype + (localPoleSpace (K := K) (L := L) π 0)) ≃ₗ[K] + R ⧸ IsLocalRing.maximalIdeal R ^ n := by + let f := localPolePrincipalPartMap (K := K) (L := L) π n + have hsurj : Function.Surjective f := + localPolePrincipalPartMap_surjective (K := K) (L := L) π hπ n + have hker := localPolePrincipalPartMap_ker + (K := K) (L := L) π hπ hπIdeal n + rw [← hker] + exact f.quotKerEquivOfSurjective hsurj + +/-- Over a finite constant field, allowing poles through order `n` creates +exactly `n` copies of the local residue field. -/ +theorem localPoleCumulativeQuotient_finrank + [Fintype K] (π : R) (hπ : π ≠ 0) + (hπIdeal : IsLocalRing.maximalIdeal R = Ideal.span {π}) (n : ℕ) + [Finite (IsLocalRing.ResidueField R)] : + Module.finrank K + (localPoleSpace (K := K) (L := L) π n ⧸ + Submodule.comap + (localPoleSpace (K := K) (L := L) π n).subtype + (localPoleSpace (K := K) (L := L) π 0)) = + n * Module.finrank K (IsLocalRing.ResidueField R) := by + let I := IsLocalRing.maximalIdeal R ^ n + let : Finite (R ⧸ I) := + IsLocalRing.finite_quotient_iff.mpr ⟨n, le_rfl⟩ + let : Module.Finite K (R ⧸ I) := Module.Finite.of_finite + let : Module.Finite K (IsLocalRing.ResidueField R) := + Module.Finite.of_finite + have hlocalLength : Module.length R (R ⧸ I) = n := by + exact IsDiscreteValuationRing.length_quotient_pow_maximalIdeal R n + have hbaseRank : Module.finrank K (IsLocalRing.ResidueField K) = 1 := by + rw [Algebra.finrank_eq_one_iff_bijective_algebraMap] + exact ⟨(algebraMap K (IsLocalRing.ResidueField K)).injective, + Ideal.Quotient.mk_surjective⟩ + have hresidueLength : + Module.length (IsLocalRing.ResidueField K) + (IsLocalRing.ResidueField R) = + Module.finrank K (IsLocalRing.ResidueField R) := by + rw [Module.length_eq_finrank] + have hresidueRank : + Module.finrank (IsLocalRing.ResidueField K) + (IsLocalRing.ResidueField R) = + Module.finrank K (IsLocalRing.ResidueField R) := by + calc + Module.finrank (IsLocalRing.ResidueField K) + (IsLocalRing.ResidueField R) = + 1 * Module.finrank (IsLocalRing.ResidueField K) + (IsLocalRing.ResidueField R) := by simp + _ = Module.finrank K (IsLocalRing.ResidueField K) * + Module.finrank (IsLocalRing.ResidueField K) + (IsLocalRing.ResidueField R) := by rw [hbaseRank] + _ = Module.finrank K (IsLocalRing.ResidueField R) := + Module.finrank_mul_finrank K (IsLocalRing.ResidueField K) + (IsLocalRing.ResidueField R) + exact_mod_cast hresidueRank + rw [(localPoleCumulativeQuotientEquiv + (K := K) (L := L) π hπ hπIdeal n).finrank_eq] + change Module.finrank K (R ⧸ I) = _ + have hlength : Module.length K (R ⧸ I) = + n * Module.finrank K (IsLocalRing.ResidueField R) := by + rw [IsLocalRing.length_restrictScalars K R (R ⧸ I), + hlocalLength, hresidueLength] + rw [Module.length_eq_finrank] at hlength + exact_mod_cast hlength + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/LocalPoleFiltration.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/LocalPoleFiltration.lean new file mode 100644 index 0000000000..98d8b71e0e --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/LocalPoleFiltration.lean @@ -0,0 +1,230 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.RiemannSpaceFinitePlaceIncrement +public import Mathlib.LinearAlgebra.Isomorphisms + +/-! +# The local pole filtration of a discrete valuation ring + +This file isolates the exact local calculation behind principal parts. If +`R` is a discrete valuation ring in its fraction field `L` and `π` is a +uniformizer, the functions whose pole order is at most `n` form a +`K`-submodule of `L`. Consecutive levels have quotient equal to the residue +field of `R`. + +Unlike the corresponding global Riemann-space increment, this calculation is +an equality: locally every leading residue has a lift. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +open scoped nonZeroDivisors + +noncomputable section + +variable {K R L : Type*} [Field K] [CommRing R] + [IsDedekindDomain R] [IsDiscreteValuationRing R] + [Field L] [Algebra K R] [Algebra R L] [Algebra K L] + [IsScalarTower K R L] [IsFractionRing R L] + +/-- The local functions whose denominator is bounded by `π ^ n`. -/ +def localPoleSpace (π : R) (n : ℕ) : Submodule K L where + carrier := {x | ∃ r : R, algebraMap R L (π ^ n) * x = algebraMap R L r} + zero_mem' := ⟨0, by simp⟩ + add_mem' := by + rintro x y ⟨rx, hx⟩ ⟨ry, hy⟩ + refine ⟨rx + ry, ?_⟩ + rw [map_add, ← hx, ← hy] + ring + smul_mem' := by + rintro c x ⟨r, hr⟩ + refine ⟨c • r, ?_⟩ + rw [show algebraMap R L (c • r) = c • algebraMap R L r by + exact map_smul (IsScalarTower.toAlgHom K R L) c r] + simp only [Algebra.smul_def] + rw [← hr] + ring + +omit [IsDedekindDomain R] [IsDiscreteValuationRing R] [IsFractionRing R L] in +theorem mem_localPoleSpace_iff (π : R) (n : ℕ) (x : L) : + x ∈ localPoleSpace (K := K) (L := L) π n ↔ + ∃ r : R, algebraMap R L (π ^ n) * x = algebraMap R L r := + Iff.rfl + +omit [IsDedekindDomain R] [IsDiscreteValuationRing R] [IsFractionRing R L] in +/-- Increasing the allowed pole order enlarges the local pole space. -/ +theorem localPoleSpace_mono (π : R) (n : ℕ) : + localPoleSpace (K := K) (L := L) π n ≤ + localPoleSpace (K := K) (L := L) π (n + 1) := by + rintro x ⟨r, hr⟩ + refine ⟨π * r, ?_⟩ + calc + algebraMap R L (π ^ (n + 1)) * x = + algebraMap R L π * (algebraMap R L (π ^ n) * x) := by + rw [pow_succ, map_mul] + ring + _ = algebraMap R L π * algebraMap R L r := congrArg _ hr + _ = algebraMap R L (π * r) := by rw [map_mul] + +omit [IsDedekindDomain R] [IsDiscreteValuationRing R] [IsFractionRing R L] in +private theorem localPoleSpace_regular + (π : R) (n : ℕ) : + ∀ x : localPoleSpace (K := K) (L := L) π n, + ∃ r : R, algebraMap R L (π ^ n) * x.1 = algebraMap R L r := by + intro x + exact x.2 + +/-- The leading-residue map on the `n`th local pole space. -/ +def localPoleLeadingResidueMap (π : R) (n : ℕ) : + localPoleSpace (K := K) (L := L) π n →ₗ[K] + IsLocalRing.ResidueField R := + localLeadingResidueLinearMap + (localPoleSpace (K := K) (L := L) π n) + (algebraMap R L (π ^ n)) + (by exact localPoleSpace_regular (K := K) (L := L) π n) + +omit [IsDedekindDomain R] [IsDiscreteValuationRing R] in +private theorem localPoleNormalizedLift_eq + (π : R) (n : ℕ) + (x : localPoleSpace (K := K) (L := L) π n) (r : R) + (hr : algebraMap R L (π ^ n) * x.1 = algebraMap R L r) : + localNormalizedLift + (localPoleSpace (K := K) (L := L) π n) + (algebraMap R L (π ^ n)) + (localPoleSpace_regular (K := K) (L := L) π n) x = r := by + apply IsFractionRing.injective R L + rw [← hr] + exact (localNormalizedLift_spec + (localPoleSpace (K := K) (L := L) π n) + (algebraMap R L (π ^ n)) + (localPoleSpace_regular (K := K) (L := L) π n) x).symm + +/-- Every residue class occurs as a leading coefficient. -/ +theorem localPoleLeadingResidueMap_surjective + (π : R) (hπ : π ≠ 0) (n : ℕ) : + Function.Surjective + (localPoleLeadingResidueMap (K := K) (L := L) π n) := by + intro z + obtain ⟨r, hr⟩ := + (Ideal.Quotient.mk_surjective + (I := IsLocalRing.maximalIdeal R)) z + let πL : L := algebraMap R L π + have hπL : πL ≠ 0 := by + simpa [πL] using (IsFractionRing.injective R L).ne hπ + let x : L := (algebraMap R L (π ^ n))⁻¹ * algebraMap R L r + have hdenom : algebraMap R L (π ^ n) ≠ 0 := by + rw [map_pow] + exact pow_ne_zero n hπL + have hx : algebraMap R L (π ^ n) * x = algebraMap R L r := by + dsimp only [x] + rw [← mul_assoc, mul_inv_cancel₀ hdenom, one_mul] + let x' : localPoleSpace (K := K) (L := L) π n := ⟨x, r, hx⟩ + refine ⟨x', ?_⟩ + change Ideal.Quotient.mk (IsLocalRing.maximalIdeal R) + (localNormalizedLift + (localPoleSpace (K := K) (L := L) π n) + (algebraMap R L (π ^ n)) + (localPoleSpace_regular (K := K) (L := L) π n) x') = z + rw [localPoleNormalizedLift_eq (K := K) (L := L) π n x' r hx] + exact hr + +/-- The kernel of the leading-residue map is the preceding local pole +space. -/ +theorem localPoleLeadingResidueMap_ker + (π : R) (hπ : π ≠ 0) + (hπIdeal : (IsDiscreteValuationRing.maximalIdeal R).asIdeal = + Ideal.span {π}) (n : ℕ) : + (localPoleLeadingResidueMap (K := K) (L := L) π (n + 1)).ker = + Submodule.comap + (localPoleSpace (K := K) (L := L) π (n + 1)).subtype + (localPoleSpace (K := K) (L := L) π n) := by + ext x + rw [LinearMap.mem_ker, Submodule.mem_comap] + rw [localPoleLeadingResidueMap, localLeadingResidueLinearMap_eq_zero_iff] + constructor + · intro hx + change localNormalizedLift + (localPoleSpace (K := K) (L := L) π (n + 1)) + (algebraMap R L (π ^ (n + 1))) + (localPoleSpace_regular (K := K) (L := L) π (n + 1)) x ∈ + (IsDiscreteValuationRing.maximalIdeal R).asIdeal at hx + rw [hπIdeal, Ideal.mem_span_singleton] at hx + obtain ⟨s, hs⟩ := hx + refine ⟨s, ?_⟩ + have hlift := localNormalizedLift_spec + (localPoleSpace (K := K) (L := L) π (n + 1)) + (algebraMap R L (π ^ (n + 1))) + (localPoleSpace_regular (K := K) (L := L) π (n + 1)) x + rw [hs] at hlift + have hπL : algebraMap R L π ≠ 0 := + by simpa using (IsFractionRing.injective R L).ne hπ + apply mul_left_cancel₀ hπL + calc + algebraMap R L π * (algebraMap R L (π ^ n) * x.1) = + algebraMap R L (π ^ (n + 1)) * x.1 := by + rw [pow_succ, map_mul] + ring + _ = algebraMap R L (π * s) := hlift + _ = algebraMap R L π * algebraMap R L s := by rw [map_mul] + · rintro ⟨s, hs⟩ + have hliftEq : localNormalizedLift + (localPoleSpace (K := K) (L := L) π (n + 1)) + (algebraMap R L (π ^ (n + 1))) + (localPoleSpace_regular (K := K) (L := L) π (n + 1)) x = π * s := by + apply localPoleNormalizedLift_eq + calc + algebraMap R L (π ^ (n + 1)) * x.1 = + algebraMap R L π * (algebraMap R L (π ^ n) * x.1) := by + rw [pow_succ, map_mul] + ring + _ = algebraMap R L π * algebraMap R L s := congrArg _ hs + _ = algebraMap R L (π * s) := by rw [map_mul] + rw [hliftEq] + change π * s ∈ (IsDiscreteValuationRing.maximalIdeal R).asIdeal + rw [hπIdeal, Ideal.mem_span_singleton] + exact ⟨s, rfl⟩ + +/-- Consecutive local pole spaces have quotient the residue field. -/ +noncomputable def localPoleQuotientEquivResidueField + (π : R) (hπ : π ≠ 0) + (hπIdeal : (IsDiscreteValuationRing.maximalIdeal R).asIdeal = + Ideal.span {π}) (n : ℕ) : + (localPoleSpace (K := K) (L := L) π (n + 1) ⧸ + Submodule.comap + (localPoleSpace (K := K) (L := L) π (n + 1)).subtype + (localPoleSpace (K := K) (L := L) π n)) ≃ₗ[K] + IsLocalRing.ResidueField R := by + let f := localPoleLeadingResidueMap (K := K) (L := L) π (n + 1) + have hsurj : Function.Surjective f := + localPoleLeadingResidueMap_surjective (K := K) (L := L) π hπ (n + 1) + have hker := localPoleLeadingResidueMap_ker + (K := K) (L := L) π hπ hπIdeal n + rw [← hker] + exact f.quotKerEquivOfSurjective hsurj + +/-- The exact dimension of one local principal-part layer. -/ +theorem localPoleQuotient_finrank + (π : R) (hπ : π ≠ 0) + (hπIdeal : (IsDiscreteValuationRing.maximalIdeal R).asIdeal = + Ideal.span {π}) (n : ℕ) + [Module.Finite K (IsLocalRing.ResidueField R)] : + Module.finrank K + (localPoleSpace (K := K) (L := L) π (n + 1) ⧸ + Submodule.comap + (localPoleSpace (K := K) (L := L) π (n + 1)).subtype + (localPoleSpace (K := K) (L := L) π n)) = + Module.finrank K (IsLocalRing.ResidueField R) := + (localPoleQuotientEquivResidueField + (K := K) (L := L) π hπ hπIdeal n).finrank_eq + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/OnePointBase.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/OnePointBase.lean new file mode 100644 index 0000000000..530ee24427 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/OnePointBase.lean @@ -0,0 +1,216 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionCanonicalAuxiliaryInfinityPlace +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionRiemannSpace +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionZeroCounting + +/-! +# Finiteness of the height-zero one-point Riemann space + +For a finite separable extension `L / K(X)` over a finite field, the functions +regular at every exhaustive place form a finite-dimensional `K`-vector space. + +The proof chooses a branch above infinity and reduces a function modulo that +branch. Every height-zero function has a lift to the corresponding local +ring. If two such functions have the same residue, their difference has +positive order at the chosen branch and nonnegative order everywhere else. +The degree-weighted product formula rules this out unless the difference is +zero. Thus the height-zero space injects into a finite residue field. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +open BGS.CorvajaZannier +open scoped nonZeroDivisors Polynomial BigOperators +open IsDedekindDomain + +noncomputable section + + +variable (K : Type*) [Field K] [Fintype K] [DecidableEq K] + [DecidableEq (RatFunc K)] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +local instance onePointBaseConstantAlgebra : Algebra K L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K (RatFunc K))) + +local instance onePointBaseConstantTower : IsScalarTower K (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + +local instance onePointBaseInfinityIntegralClosureModuleFinite : + Module.Finite (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.finite (RatFuncInfinityIntegers K) (RatFunc K) L + (RatFuncInfinityIntegralClosure K L) + +local instance onePointBaseInfinityIntegralClosureIsIntegral : + Algebra.IsIntegral (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.isIntegral_algebra (RatFuncInfinityIntegers K) L + +local instance onePointBaseInfinityBaseTorsionFreeTop : + Module.IsTorsionFree (RatFuncInfinityIntegers K) L := + Module.IsTorsionFree.trans_faithfulSMul + (RatFuncInfinityIntegers K) (RatFunc K) L + +local instance onePointBaseInfinityIntegralClosureIsTorsionFree : + Module.IsTorsionFree (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.isTorsionFree (RatFuncInfinityIntegers K) L + +local instance onePointBaseInfinityIntegralClosureIsDedekindDomain : + IsDedekindDomain (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.isDedekindDomain + (RatFuncInfinityIntegers K) (RatFunc K) L + (RatFuncInfinityIntegralClosure K L) + +local instance onePointBaseInfinityIntegralClosureIsFractionRing : + IsFractionRing (RatFuncInfinityIntegralClosure K L) L := + IsIntegralClosure.isFractionRing_of_finite_extension + (RatFuncInfinityIntegers K) (RatFunc K) L + (RatFuncInfinityIntegralClosure K L) + +/-- The height-zero member of the one-point filtration is finite-dimensional +over the finite constant field. -/ +theorem finiteExtensionOnePointRiemannSpace_zero_moduleFinite + (P : FiniteExtensionPlace K L) : + Module.Finite K (finiteExtensionOnePointRiemannSpace K L P 0) := by + let Q : FiniteExtensionInfinityPlace K L := Classical.choice + (inferInstance : Nonempty (FiniteExtensionInfinityPlace K L)) + let : Algebra (RatFuncInfinityIntegralClosure K L) + (RatFuncInfinityIntegralClosure K L) := + Algebra.id (RatFuncInfinityIntegralClosure K L) + let _ : DistribMulAction (RatFuncInfinityIntegralClosure K L) + (RatFuncInfinityIntegralClosure K L) := + (Algebra.toModule : Module (RatFuncInfinityIntegralClosure K L) + (RatFuncInfinityIntegralClosure K L)).toDistribMulAction + let : Algebra (RatFuncInfinityIntegralClosure K L) + (FiniteExtensionInfinityPlaceLocalRing K L Q) := + OreLocalization.instAlgebra + let R := FiniteExtensionInfinityPlaceLocalRing K L Q + let := finiteExtensionInfinityPlaceLocalAlgebra (K := K) (L := L) Q + let := finiteExtensionInfinityPlaceLocalIsFractionRing (K := K) (L := L) Q + let : IsDiscreteValuationRing R := + IsLocalization.AtPrime.isDiscreteValuationRing_of_dedekind_domain + (RatFuncInfinityIntegralClosure K L) + (primeOverHeightOne (ratFuncInfinityPlace K) Q).ne_bot R + let : Finite Q.1.ResidueField := + finiteExtensionInfinityPlace_residueField_finite (K := K) (L := L) Q + let V := finiteExtensionOnePointRiemannSpace K L P 0 + have hliftExists : ∀ x : V, ∃ r : R, + (x.1 : L) = finiteExtensionInfinityPlaceLocalizationToField + (K := K) (L := L) Q r := by + intro x + apply finiteExtensionInfinityPlace_exists_local_lift_of_orderTop_nonnegative + (K := K) (L := L) Q x.1 + by_cases hx0 : x.1 = 0 + · simp only [finiteExtensionInfinityPlaceLocalOrderTop, hx0] + erw [finitePlaceOrderTop_zero] + exact le_top + · rw [finiteExtensionInfinityPlaceLocalOrderTop_eq_globalOrder Q x.1 hx0] + have hxmem := + (mem_finiteExtensionOnePointRiemannSpace_iff K L P 0 x.1).mp x.2 + rcases hxmem with hxmem | ⟨_, hP, hAway⟩ + · exact (hx0 hxmem).elim + · have hnonneg : + 0 ≤ finiteExtensionPrincipalDivisor K L x.1 (.inr Q) := by + by_cases hQP : (Sum.inr Q : FiniteExtensionPlace K L) = P + · rw [hQP] + simpa using hP + · exact hAway (.inr Q) hQP + exact_mod_cast (by + simpa only [finiteExtensionPrincipalDivisor_inr_eq_infinityPlaceOrder] + using hnonneg) + let lift : V → R := fun x => Classical.choose (hliftExists x) + have lift_spec (x : V) : + (x.1 : L) = finiteExtensionInfinityPlaceLocalizationToField + (K := K) (L := L) Q (lift x) := + Classical.choose_spec (hliftExists x) + let residue : V → Q.1.ResidueField := fun x => + IsLocalRing.residue R (lift x) + have hresidueInjective : Function.Injective residue := by + intro x y hxy + apply Subtype.ext + by_contra hne + let r : R := lift x - lift y + have hrResidue : IsLocalRing.residue R r = 0 := by + dsimp only [r] + rw [map_sub] + exact sub_eq_zero.mpr hxy + have hrMem : r ∈ IsLocalRing.maximalIdeal R := + (IsLocalRing.residue_eq_zero_iff r).mp hrResidue + have hrMap : finiteExtensionInfinityPlaceLocalizationToField + (K := K) (L := L) Q r = x.1 - y.1 := by + dsimp [r] + calc + finiteExtensionInfinityPlaceLocalizationToField + (K := K) (L := L) Q (lift x - lift y) = + finiteExtensionInfinityPlaceLocalizationToField + (K := K) (L := L) Q (lift x) - + finiteExtensionInfinityPlaceLocalizationToField + (K := K) (L := L) Q (lift y) := + (finiteExtensionInfinityPlaceLocalizationToField + (K := K) (L := L) Q).map_sub (lift x) (lift y) + _ = x.1 - y.1 := by rw [← lift_spec x, ← lift_spec y] + have hrNe : r ≠ 0 := by + intro hr0 + apply hne + apply sub_eq_zero.mp + rw [← hrMap, hr0, map_zero] + have hrOrder : + (1 : ℤ) ≤ finitePlaceOrder + (IsDiscreteValuationRing.maximalIdeal R) + (algebraMap R L r) := + one_le_finitePlaceOrder_algebraMap_of_mem + (R := R) (L := L) + (IsDiscreteValuationRing.maximalIdeal R) r hrMem hrNe + have hQOrder : + 0 < finiteExtensionPrincipalDivisor K L (x.1 - y.1) (.inr Q) := by + rw [finiteExtensionPrincipalDivisor_inr_eq_infinityPlaceOrder, + ← hrMap, ← finiteExtensionInfinityPlaceLocalOrder_eq_globalOrder Q] + change 0 < finitePlaceOrder + (IsDiscreteValuationRing.maximalIdeal R) (algebraMap R L r) + omega + have hdNe : x.1 - y.1 ≠ 0 := sub_ne_zero.mpr hne + have hdMem : x.1 - y.1 ∈ V := V.sub_mem x.2 y.2 + have hdOrders : ∀ v : FiniteExtensionPlace K L, + 0 ≤ finiteExtensionPrincipalDivisor K L (x.1 - y.1) v := by + intro v + rcases (mem_finiteExtensionOnePointRiemannSpace_iff + K L P 0 (x.1 - y.1)).mp hdMem with hd0 | ⟨_, hP, hAway⟩ + · exact (hdNe hd0).elim + · by_cases hv : v = P + · rw [hv] + simpa using hP + · exact hAway v hv + have hDegreePos : + 0 < finiteExtensionPrincipalDivisorDegreeSum K L (x.1 - y.1) := by + rw [finiteExtensionPrincipalDivisorDegreeSum] + apply Finsupp.sum_pos' + · intro v _hv + exact mul_nonneg (hdOrders v) (by positivity) + · refine ⟨.inr Q, ?_, ?_⟩ + · exact Finsupp.mem_support_iff.mpr (ne_of_gt hQOrder) + · exact mul_pos hQOrder (by + exact_mod_cast finiteExtensionPlaceDegree_pos K L (.inr Q)) + have hDegreeZero := + finiteExtensionPrincipalDivisorDegreeSum_eq_zero K L (x.1 - y.1) hdNe + omega + let : Finite V := Finite.of_injective residue hresidueInjective + change Module.Finite K V + infer_instance + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/OnePointDivisorSplit.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/OnePointDivisorSplit.lean new file mode 100644 index 0000000000..e373f77f7f --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/OnePointDivisorSplit.lean @@ -0,0 +1,158 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionRiemannSpace +public import Mathlib.Tactic + +/-! +# Splitting an effective divisor at one place + +The one-point Stepanov argument starts with a many-pole divisor supplied by +plane monomials, then removes every allowed pole except the distinguished +one. This file records the elementary divisor identities needed for that +comparison. The actual codimension estimate is kept separate. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +open BGS.CorvajaZannier + +noncomputable section + +variable (K : Type*) [Field K] [Fintype K] [DecidableEq K] + [DecidableEq (RatFunc K)] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +/-- Delete the coefficient of `D` at `P`, retaining all other coefficients. -/ +def finiteExtensionDivisorAway + (D : FiniteExtensionDivisor K L) (P : FiniteExtensionPlace K L) : + FiniteExtensionDivisor K L := + D - Finsupp.single P (D P) + +omit [Fintype K] [DecidableEq K] [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] in +@[simp] +theorem finiteExtensionDivisorAway_apply_self + (D : FiniteExtensionDivisor K L) (P : FiniteExtensionPlace K L) : + finiteExtensionDivisorAway K L D P P = 0 := by + simp [finiteExtensionDivisorAway] + +omit [Fintype K] [DecidableEq K] [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] in +@[simp] +theorem finiteExtensionDivisorAway_apply_of_ne + (D : FiniteExtensionDivisor K L) (P v : FiniteExtensionPlace K L) + (hv : v ≠ P) : + finiteExtensionDivisorAway K L D P v = D v := by + simp [finiteExtensionDivisorAway, hv] + +omit [Fintype K] [DecidableEq K] [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] in +/-- Splitting off the `P` coefficient recovers the original divisor. -/ +theorem single_add_finiteExtensionDivisorAway + (D : FiniteExtensionDivisor K L) (P : FiniteExtensionPlace K L) : + Finsupp.single P (D P) + finiteExtensionDivisorAway K L D P = D := by + ext v + by_cases hv : v = P + · subst v + simp + · simp [finiteExtensionDivisorAway] + +omit [Fintype K] [DecidableEq K] [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] in +/-- Removing one coefficient preserves effectiveness. -/ +theorem finiteExtensionDivisorAway_effective + (D : FiniteExtensionDivisor K L) (P : FiniteExtensionPlace K L) + (hD : ∀ v, 0 ≤ D v) : + ∀ v, 0 ≤ finiteExtensionDivisorAway K L D P v := by + intro v + by_cases hv : v = P + · subst v + simp + · simpa [finiteExtensionDivisorAway, hv] using hD v + +omit [Fintype K] [FiniteDimensional (RatFunc K) L] [Algebra.IsSeparable (RatFunc K) L] in +/-- The degree of a divisor supported at one place. -/ +@[simp] +theorem finiteExtensionDivisorDegree_single + (P : FiniteExtensionPlace K L) (z : ℤ) : + finiteExtensionDivisorDegree K L (Finsupp.single P z) = + z * (finiteExtensionPlaceDegree K L P : ℤ) := by + classical + simp [finiteExtensionDivisorDegree] + +omit [Fintype K] [FiniteDimensional (RatFunc K) L] [Algebra.IsSeparable (RatFunc K) L] in +/-- Divisor degree changes sign under negation. -/ +theorem finiteExtensionDivisorDegree_neg + (D : FiniteExtensionDivisor K L) : + finiteExtensionDivisorDegree K L (-D) = + -finiteExtensionDivisorDegree K L D := by + have h := finiteExtensionDivisorDegree_add K L D (-D) + rw [add_neg_cancel] at h + have hzero : finiteExtensionDivisorDegree K L (0 : FiniteExtensionDivisor K L) = 0 := by + simp [finiteExtensionDivisorDegree] + rw [hzero] at h + omega + +omit [Fintype K] [FiniteDimensional (RatFunc K) L] [Algebra.IsSeparable (RatFunc K) L] in +/-- Divisor degree respects subtraction. -/ +theorem finiteExtensionDivisorDegree_sub + (D E : FiniteExtensionDivisor K L) : + finiteExtensionDivisorDegree K L (D - E) = + finiteExtensionDivisorDegree K L D - + finiteExtensionDivisorDegree K L E := by + rw [sub_eq_add_neg, finiteExtensionDivisorDegree_add, + finiteExtensionDivisorDegree_neg] + rfl + +omit [Fintype K] [FiniteDimensional (RatFunc K) L] [Algebra.IsSeparable (RatFunc K) L] in +/-- Degree bookkeeping for the divisor away from the selected place. -/ +theorem finiteExtensionDivisorDegree_away + (D : FiniteExtensionDivisor K L) (P : FiniteExtensionPlace K L) : + finiteExtensionDivisorDegree K L (finiteExtensionDivisorAway K L D P) = + finiteExtensionDivisorDegree K L D - + D P * (finiteExtensionPlaceDegree K L P : ℤ) := by + rw [finiteExtensionDivisorAway, finiteExtensionDivisorDegree_sub, + finiteExtensionDivisorDegree_single] + +omit [Fintype K] [DecidableEq K] [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] in +/-- For an effective divisor, its one-place part is coefficientwise below it. -/ +theorem single_coeff_le_of_effective + (D : FiniteExtensionDivisor K L) (P : FiniteExtensionPlace K L) + (hD : ∀ v, 0 ≤ D v) : + Finsupp.single P (D P) ≤ D := by + intro v + by_cases hv : v = P + · subst v + simp + · simpa [Finsupp.single_eq_of_ne hv] using hD v + +/-- The one-point space using the selected coefficient embeds in the full +Riemann space of an effective divisor. -/ +theorem onePointRiemannSpace_le_of_effective + (D : FiniteExtensionDivisor K L) (P : FiniteExtensionPlace K L) + (hD : ∀ v, 0 ≤ D v) : + finiteExtensionOnePointRiemannSpace K L P (D P).toNat ≤ + finiteExtensionRiemannSpace K L D := by + have hcoeff : ((D P).toNat : ℤ) = D P := + Int.toNat_of_nonneg (hD P) + change finiteExtensionRiemannSpace K L + (Finsupp.single P ((D P).toNat : ℤ)) ≤ + finiteExtensionRiemannSpace K L D + rw [hcoeff] + exact finiteExtensionRiemannSpace_mono K L + (single_coeff_le_of_effective K L D P hD) + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/OnePointHeight.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/OnePointHeight.lean new file mode 100644 index 0000000000..dda6364111 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/OnePointHeight.lean @@ -0,0 +1,125 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionRiemannSpace +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionZeroCounting + +/-! +# Heights and zero counts in a one-point Riemann space + +This file supplies the direct bridge from membership in the one-point +Riemann space `L(nP)` to the pole height used by the exhaustive +principal-divisor API. + +For a nonzero `x ∈ L(nP)`, every negative-order place is `P` and its pole +order is at most `n`. Unfolding `finiteExtensionHeight` therefore gives the +bound `height(x) ≤ n * deg(P)`. Combining this with the existing positive-order +place count gives the corresponding Tao-style zero-count estimate. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +open BGS.CorvajaZannier +open scoped nonZeroDivisors Polynomial BigOperators + +noncomputable section + +variable (K : Type*) [Field K] [Fintype K] [DecidableEq K] + [DecidableEq (RatFunc K)] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +local instance onePointHeightConstantAlgebra : Algebra K L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K (RatFunc K))) + +local instance onePointHeightConstantTower : + IsScalarTower K (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + +/-- A nonzero function in `L(nP)` has pole height at most `n * deg(P)`. + +This is proved directly from the exhaustive principal-divisor support and +the definition of `finiteExtensionHeight`; it does not invoke an abstract +divisor-degree estimate. -/ +theorem finiteExtensionHeight_le_of_mem_onePointRiemannSpace + (P : FiniteExtensionPlace K L) (n : ℕ) (x : L) (hx : x ≠ 0) + (hxSpace : x ∈ finiteExtensionOnePointRiemannSpace K L P n) : + finiteExtensionHeight K L x ≤ n * finiteExtensionPlaceDegree K L P := by + classical + have hxDescription := + (mem_finiteExtensionOnePointRiemannSpace_iff K L P n x).mp hxSpace + rcases hxDescription with hxZero | ⟨_hx, hP, hAway⟩ + · exact (hx hxZero).elim + let D := finiteExtensionPrincipalDivisor K L x + let negativeSupport := D.support.filter (fun v ↦ D v < 0) + have hsubset : negativeSupport ⊆ {P} := by + intro v hv + have hvneg : D v < 0 := (Finset.mem_filter.mp hv).2 + apply Finset.mem_singleton.mpr + by_contra hvP + have hvnonneg : 0 ≤ D v := hAway v hvP + omega + have horder : (-D P).toNat ≤ n := by + have hP' : -(n : ℤ) ≤ D P := by simpa [D] using hP + rw [Int.toNat_le] + omega + calc + finiteExtensionHeight K L x = + ∑ v ∈ negativeSupport, (-D v).toNat * finiteExtensionPlaceDegree K L v := rfl + _ ≤ ∑ v ∈ ({P} : Finset (FiniteExtensionPlace K L)), + (-D v).toNat * finiteExtensionPlaceDegree K L v := by + exact Finset.sum_le_sum_of_subset_of_nonneg hsubset (by omega) + _ = (-D P).toNat * finiteExtensionPlaceDegree K L P := by simp + _ ≤ n * finiteExtensionPlaceDegree K L P := + Nat.mul_le_mul_right (finiteExtensionPlaceDegree K L P) horder + +/-- Degree-one specialization of +`finiteExtensionHeight_le_of_mem_onePointRiemannSpace`. -/ +theorem finiteExtensionHeight_le_of_mem_onePointRiemannSpace_degree_one + (P : FiniteExtensionPlace K L) (n : ℕ) (x : L) (hx : x ≠ 0) + (hxSpace : x ∈ finiteExtensionOnePointRiemannSpace K L P n) + (hdegree : finiteExtensionPlaceDegree K L P = 1) : + finiteExtensionHeight K L x ≤ n := by + simpa [hdegree] using + finiteExtensionHeight_le_of_mem_onePointRiemannSpace K L P n x hx hxSpace + +/-- Tao-style zero count: a finite family injecting into positive-order +places of a nonzero `x ∈ L(nP)` has cardinality at most `n * deg(P)`. -/ +theorem Fintype.card_le_mul_placeDegree_of_onePointRiemannSpace + {ι : Type*} [Fintype ι] + (P : FiniteExtensionPlace K L) (n : ℕ) (x : L) (hx : x ≠ 0) + (hxSpace : x ∈ finiteExtensionOnePointRiemannSpace K L P n) + (place : ι → FiniteExtensionPlace K L) + (hinjective : Function.Injective place) + (hpositive : ∀ i, 0 < finiteExtensionPrincipalDivisor K L x (place i)) : + Fintype.card ι ≤ n * finiteExtensionPlaceDegree K L P := by + exact (Fintype.card_le_finiteExtensionHeight_of_injective_orders_positive + K L x hx place hinjective hpositive).trans + (finiteExtensionHeight_le_of_mem_onePointRiemannSpace K L P n x hx hxSpace) + +/-- Degree-one specialization of the one-point zero count. -/ +theorem Fintype.card_le_of_onePointRiemannSpace_degree_one + {ι : Type*} [Fintype ι] + (P : FiniteExtensionPlace K L) (n : ℕ) (x : L) (hx : x ≠ 0) + (hxSpace : x ∈ finiteExtensionOnePointRiemannSpace K L P n) + (hdegree : finiteExtensionPlaceDegree K L P = 1) + (place : ι → FiniteExtensionPlace K L) + (hinjective : Function.Injective place) + (hpositive : ∀ i, 0 < finiteExtensionPrincipalDivisor K L x (place i)) : + Fintype.card ι ≤ n := by + simpa [hdegree] using + Fintype.card_le_mul_placeDegree_of_onePointRiemannSpace + K L P n x hx hxSpace place hinjective hpositive + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/OnePointIncrement.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/OnePointIncrement.lean new file mode 100644 index 0000000000..d8c4690859 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/OnePointIncrement.lean @@ -0,0 +1,138 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.OnePointBase +public import LeanPool.MarkoffModP.BGS.HasseWeil.RiemannSpaceFinitePlaceIncrement +public import LeanPool.MarkoffModP.BGS.HasseWeil.RiemannSpaceInfinityPlaceIncrement + +/-! +# Successive growth of one-point Riemann spaces + +The local residue argument bounds the jump from `L(nP)` to `L((n+1)P)` by +the degree of `P`. Iterating from `L(0)` also supplies finite-dimensionality +at every level of the one-point filtration. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +open BGS.CorvajaZannier +open scoped Polynomial + +noncomputable section + + +variable (K : Type*) [Field K] [Fintype K] [DecidableEq K] + [DecidableEq (RatFunc K)] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +/-- One step in the one-point filtration is finite-dimensional and has +dimension jump at most the degree of the distinguished place. -/ +theorem finiteExtensionOnePointRiemannSpace_increment + (P : FiniteExtensionPlace K L) (n : ℕ) + [Module.Finite K (finiteExtensionOnePointRiemannSpace K L P n)] : + Module.Finite K + (finiteExtensionOnePointRiemannSpace K L P (n + 1)) ∧ + Module.finrank K + (finiteExtensionOnePointRiemannSpace K L P (n + 1)) ≤ + Module.finrank K + (finiteExtensionOnePointRiemannSpace K L P n) + + finiteExtensionPlaceDegree K L P := by + classical + change Module.Finite K + (finiteExtensionRiemannSpace K L + (Finsupp.single P ((n + 1 : ℕ) : ℤ))) ∧ + Module.finrank K + (finiteExtensionRiemannSpace K L + (Finsupp.single P ((n + 1 : ℕ) : ℤ))) ≤ + Module.finrank K + (finiteExtensionRiemannSpace K L + (Finsupp.single P (n : ℤ))) + + finiteExtensionPlaceDegree K L P + have hD : ∀ v, 0 ≤ (Finsupp.single P (n : ℤ) : + FiniteExtensionDivisor K L) v := by + intro v + by_cases hv : v = P + · subst v + simp + · simp [Finsupp.single_eq_of_ne hv] + rcases P with q | q + · have hbase : Module.Finite K + (finiteExtensionRiemannSpace K L + (Finsupp.single (.inl q) (n : ℤ))) := by + change Module.Finite K + (finiteExtensionOnePointRiemannSpace K L (.inl q) n) + infer_instance + let := hbase + have h := finiteExtensionRiemannSpace_finitePlace_increment + K L (Finsupp.single (.inl q) (n : ℤ)) hD q + have hdivisor : + Finsupp.single (.inl q) (n : ℤ) + Finsupp.single (.inl q) 1 = + (Finsupp.single (.inl q) ((n + 1 : ℕ) : ℤ) : + FiniteExtensionDivisor K L) := by + ext v + by_cases hv : v = (.inl q : FiniteExtensionPlace K L) + · subst v + simp + · simp [Finsupp.single_eq_of_ne hv] + rw [hdivisor] at h + exact h + · have hbase : Module.Finite K + (finiteExtensionRiemannSpace K L + (Finsupp.single (.inr q) (n : ℤ))) := by + change Module.Finite K + (finiteExtensionOnePointRiemannSpace K L (.inr q) n) + infer_instance + let := hbase + have h := finiteExtensionRiemannSpace_infinityPlace_increment + K L (Finsupp.single (.inr q) (n : ℤ)) hD q + have hdivisor : + Finsupp.single (.inr q) (n : ℤ) + Finsupp.single (.inr q) 1 = + (Finsupp.single (.inr q) ((n + 1 : ℕ) : ℤ) : + FiniteExtensionDivisor K L) := by + ext v + by_cases hv : v = (.inr q : FiniteExtensionPlace K L) + · subst v + simp + · simp [Finsupp.single_eq_of_ne hv] + rw [hdivisor] at h + exact h + +/-- Every member of a one-point Riemann filtration is finite-dimensional. -/ +theorem finiteExtensionOnePointRiemannSpace_moduleFinite + (P : FiniteExtensionPlace K L) : + ∀ n, Module.Finite K + (finiteExtensionOnePointRiemannSpace K L P n) := by + intro n + induction n with + | zero => + exact finiteExtensionOnePointRiemannSpace_zero_moduleFinite K L P + | succ n ih => + let : Module.Finite K + (finiteExtensionOnePointRiemannSpace K L P n) := ih + exact (finiteExtensionOnePointRiemannSpace_increment K L P n).1 + +/-- Uniform dimension-jump bound for the one-point filtration. -/ +theorem finiteExtensionOnePointRiemannSpace_finrank_succ_le + (P : FiniteExtensionPlace K L) (n : ℕ) : + Module.finrank K + (finiteExtensionOnePointRiemannSpace K L P (n + 1)) ≤ + Module.finrank K + (finiteExtensionOnePointRiemannSpace K L P n) + + finiteExtensionPlaceDegree K L P := by + let : Module.Finite K + (finiteExtensionOnePointRiemannSpace K L P n) := + finiteExtensionOnePointRiemannSpace_moduleFinite K L P n + exact (finiteExtensionOnePointRiemannSpace_increment K L P n).2 + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/OnePointLeadingCoefficient.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/OnePointLeadingCoefficient.lean new file mode 100644 index 0000000000..5d392a6dbe --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/OnePointLeadingCoefficient.lean @@ -0,0 +1,600 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionRiemannSpace +public import LeanPool.MarkoffModP.BGS.HasseWeil.OnePointStrictLevels +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.DedekindLeadingTermCancellation +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.DedekindLocalizationOrder +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionResidueSurjectivity +public import Mathlib.FieldTheory.Finiteness + +/-! +# Leading coefficients at a single place + +Compare residue-field degrees and lift constant residues through the local rings of finite and +infinite places. +-/ + +@[expose] public section + +namespace BGS.CorvajaZannier + +noncomputable section + +open scoped nonZeroDivisors Polynomial +open IsDedekindDomain + +private noncomputable def residueFieldAlgEquivOfIdealEqOver + {C A : Type*} [CommRing C] [CommRing A] [Algebra C A] + {I J : Ideal A} [I.IsPrime] [J.IsPrime] (h : I = J) : + I.ResidueField ≃ₐ[C] J.ResidueField := by + subst J + exact AlgEquiv.refl + +private theorem constantResidue_surjective_of_ideal_eq + {C A : Type*} [CommRing C] [CommRing A] [Algebra C A] + {I J : Ideal A} [I.IsPrime] [J.IsPrime] (h : I = J) + (hJ : Function.Surjective (algebraMap C J.ResidueField)) : + Function.Surjective (algebraMap C I.ResidueField) := by + let e := residueFieldAlgEquivOfIdealEqOver (C := C) h + intro z + obtain ⟨c, hc⟩ := hJ (e z) + refine ⟨c, e.injective ?_⟩ + simpa [e] using hc + +@[reducible] private noncomputable def canonicalFractionRingAlgebra + (A : Type*) [CommRing A] [IsDomain A] : + Algebra A (FractionRing A) := inferInstance + +section LocalizationResidue + +variable {C R S : Type*} [Field C] [CommRing R] [IsDedekindDomain R] + [Algebra C R] + [CommRing S] [Algebra R S] + [Algebra C S] [IsScalarTower C R S] + +/-- Surjectivity of constants onto a height-one residue field is preserved +when the Dedekind domain is localized at that place. -/ +theorem localizationAtPrime_constantResidue_surjective + (q : HeightOneSpectrum R) [IsLocalization q.asIdeal.primeCompl S] + [IsLocalRing S] + (hresidue : Function.Surjective + (algebraMap C q.asIdeal.ResidueField)) : + Function.Surjective + (algebraMap C + (IsLocalRing.maximalIdeal S).ResidueField) := by + intro z + let m := IsLocalRing.maximalIdeal S + let : q.asIdeal.IsMaximal := q.isMaximal + let : m.IsMaximal := by + simpa [m] using (IsLocalRing.maximalIdeal.isMaximal S) + obtain ⟨s, hs⟩ := m.algebraMap_residueField_surjective z + let e := IsLocalization.AtPrime.equivQuotMaximalIdeal q.asIdeal S + let rbar : R ⧸ q.asIdeal := e.symm (Ideal.Quotient.mk m s) + obtain ⟨c, hc⟩ := hresidue + (algebraMap (R ⧸ q.asIdeal) q.asIdeal.ResidueField rbar) + refine ⟨c, ?_⟩ + change algebraMap C m.ResidueField c = z + rw [← hs] + rw [IsScalarTower.algebraMap_apply C S m.ResidueField] + simp only [IsScalarTower.algebraMap_apply S (S ⧸ m) m.ResidueField] + congr 1 + have hq : algebraMap R (R ⧸ q.asIdeal) (algebraMap C R c) = rbar := by + apply q.asIdeal.injective_algebraMap_quotient_residueField + simpa only [IsScalarTower.algebraMap_apply C R + q.asIdeal.ResidueField, + IsScalarTower.algebraMap_apply R (R ⧸ q.asIdeal) + q.asIdeal.ResidueField] using hc + calc + algebraMap S (S ⧸ m) (algebraMap C S c) = + e (algebraMap R (R ⧸ q.asIdeal) (algebraMap C R c)) := by + rw [IsScalarTower.algebraMap_apply C R S] + change Ideal.Quotient.mk m + (algebraMap R S (algebraMap C R c)) = + e (Ideal.Quotient.mk q.asIdeal (algebraMap C R c)) + simpa [e, m] using + (IsLocalization.AtPrime.equivQuotMaximalIdeal_apply_mk + q.asIdeal S (algebraMap C R c)).symm + _ = e rbar := by rw [hq] + _ = algebraMap S (S ⧸ m) s := by simp [rbar, m] + +end LocalizationResidue + +section DegreeOneResidue + +attribute [local instance high] Module.Free.of_divisionRing + +variable (K : Type*) [Field K] [Fintype K] [DecidableEq K] + [DecidableEq (RatFunc K)] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +local instance (priority := 10) onePointPolynomialAlgebra : Algebra K[X] L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K[X] (RatFunc K))) + +local instance onePointPolynomialScalarTower : + IsScalarTower K[X] (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + +local instance onePointFiniteConstantAlgebra : + Algebra K (RatFuncFiniteIntegralClosure K L) := + RingHom.toAlgebra ((algebraMap K[X] + (RatFuncFiniteIntegralClosure K L)).comp (algebraMap K K[X])) + +local instance onePointFiniteConstantTower : + IsScalarTower K K[X] (RatFuncFiniteIntegralClosure K L) := + IsScalarTower.of_algebraMap_eq' rfl + +local instance onePointInfinityConstantAlgebra : + Algebra K (RatFuncInfinityIntegers K) := + (ratFuncInfinityConstantRingHom K).toAlgebra + +local instance onePointInfinityConstantTower : + IsScalarTower K (RatFuncInfinityIntegers K) (RatFunc K) := + IsScalarTower.of_algebraMap_eq' rfl + +local instance onePointInfinityClosureConstantAlgebra : + Algebra K (RatFuncInfinityIntegralClosure K L) := + RingHom.toAlgebra + ((algebraMap (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L)).comp + (algebraMap K (RatFuncInfinityIntegers K))) + +local instance onePointInfinityClosureConstantTower : + IsScalarTower K (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) := + IsScalarTower.of_algebraMap_eq' rfl + +private noncomputable def onePointResidueFieldAlgEquivOfIdealEq + {I J : Ideal K[X]} [I.IsPrime] [J.IsPrime] (h : I = J) : + I.ResidueField ≃ₐ[K] J.ResidueField := by + subst J + exact AlgEquiv.refl + +omit [Fintype K] [DecidableEq (RatFunc K)] in +/-- The degree of a rational-function finite place is the dimension of its +residue field over the constant field. -/ +theorem ratFuncFinitePlaceDegree_eq_finrank_residueField + (p : HeightOneSpectrum K[X]) : + ratFuncFinitePlaceDegree p = + Module.finrank K p.asIdeal.ResidueField := by + let r := finitePlaceNormalizedPrime p + have hp : normalizedPrimeFinitePlace (K := K) r = p := + normalizedPrimeFinitePlace_finitePlaceNormalizedPrime p + have hpIdeal : p.asIdeal = Ideal.span {(r : K[X])} := by + rw [← show (normalizedPrimeFinitePlace (K := K) r).asIdeal = + p.asIdeal by exact congrArg HeightOneSpectrum.asIdeal hp] + rfl + let : (Ideal.span {(r : K[X])}).IsPrime := + (normalizedPrimeFinitePlace (K := K) r).isPrime + let : (Ideal.span {(r : K[X])}).IsMaximal := + (inferInstance : (Ideal.span {(r : K[X])}).IsPrime).isMaximal (by + simpa only [ne_eq, Ideal.span_singleton_eq_bot] using + r.property.1.ne_zero) + let ep := onePointResidueFieldAlgEquivOfIdealEq (K := K) hpIdeal + let e : (K[X] ⧸ Ideal.span {(r : K[X])}) ≃ₐ[K] + (Ideal.span {(r : K[X])}).ResidueField := + AlgEquiv.ofBijective + (IsScalarTower.toAlgHom K + (K[X] ⧸ Ideal.span {(r : K[X])}) + (Ideal.span {(r : K[X])}).ResidueField) + (Ideal.bijective_algebraMap_quotient_residueField _) + symm + calc + Module.finrank K p.asIdeal.ResidueField = + Module.finrank K (Ideal.span {(r : K[X])}).ResidueField := + ep.toLinearEquiv.finrank_eq + _ = + Module.finrank K (K[X] ⧸ Ideal.span {(r : K[X])}) := + e.toLinearEquiv.finrank_eq.symm + _ = (r : K[X]).natDegree := + (AdjoinRoot.powerBasis r.property.1.ne_zero).finrank + _ = ratFuncFinitePlaceDegree p := by + rw [ratFuncFinitePlaceDegree] + +omit [Fintype K] in +/-- At a finite extension place, the exhaustive place degree is exactly the +constant-field dimension of the residue field. -/ +theorem finiteExtensionFinitePlace_degree_eq_finrank_residueField + (q : FiniteExtensionFinitePlace K L) : + finiteExtensionPlaceDegree K L (.inl q) = + Module.finrank K q.asIdeal.ResidueField := by + let p := HeightOneSpectrum.under K[X] q + let : q.asIdeal.LiesOver p.asIdeal := ⟨rfl⟩ + let hLocalAlg := + Localization.AtPrime.algebraOfLiesOver p.asIdeal q.asIdeal + have : IsScalarTower K[X] (Localization.AtPrime p.asIdeal) + (Localization.AtPrime q.asIdeal) := inferInstance + rw [finiteExtensionPlaceDegree, Ideal.inertiaDeg_eq p.asIdeal q.asIdeal] + rw [ratFuncFinitePlaceDegree_eq_finrank_residueField K p] + rw [mul_comm, Module.finrank_mul_finrank] + +omit [Fintype K] [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] in +/-- At an infinity extension place, the exhaustive place degree is exactly +the constant-field dimension of the residue field. -/ +theorem finiteExtensionInfinityPlace_degree_eq_finrank_residueField + (P : FiniteExtensionInfinityPlace K L) : + finiteExtensionPlaceDegree K L (.inr P) = + Module.finrank K P.1.ResidueField := by + let p := (ratFuncInfinityPlace K).asIdeal + let hLocalAlg := Localization.AtPrime.algebraOfLiesOver p P.1 + have : IsScalarTower (RatFuncInfinityIntegers K) (Localization.AtPrime p) + (Localization.AtPrime P.1) := inferInstance + let : Algebra p.ResidueField P.1.ResidueField := + IsLocalRing.ResidueField.instAlgebra + let : IsScalarTower K p.ResidueField P.1.ResidueField := inferInstance + rw [finiteExtensionPlaceDegree, Ideal.inertiaDeg_eq p P.1] + have hbase : Module.finrank K p.ResidueField = 1 := by + simpa [p] using + (ratFuncInfinityPlaceResidueEquiv K).toLinearEquiv.finrank_eq + calc + Module.finrank p.ResidueField P.1.ResidueField = + 1 * Module.finrank p.ResidueField P.1.ResidueField := by simp + _ = Module.finrank K p.ResidueField * + Module.finrank p.ResidueField P.1.ResidueField := by rw [hbase] + _ = Module.finrank K P.1.ResidueField := + Module.finrank_mul_finrank K p.ResidueField P.1.ResidueField + +omit [Fintype K] in +/-- Degree one forces constants to fill the residue field at a finite +extension place. -/ +theorem finiteExtensionFinitePlace_constantResidue_surjective_of_degree_one + (q : FiniteExtensionFinitePlace K L) + (hq : finiteExtensionPlaceDegree K L (.inl q) = 1) : + Function.Surjective (algebraMap K q.asIdeal.ResidueField) := by + have hfinrank : Module.finrank K q.asIdeal.ResidueField = 1 := by + rw [← finiteExtensionFinitePlace_degree_eq_finrank_residueField K L q] + exact hq + exact (Algebra.finrank_eq_one_iff_bijective_algebraMap.mp hfinrank).2 + +omit [Fintype K] [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] in +/-- Degree one forces constants to fill the residue field at an infinity +extension place. -/ +theorem finiteExtensionInfinityPlace_constantResidue_surjective_of_degree_one + (P : FiniteExtensionInfinityPlace K L) + (hP : finiteExtensionPlaceDegree K L (.inr P) = 1) : + Function.Surjective (algebraMap K P.1.ResidueField) := by + have hfinrank : Module.finrank K P.1.ResidueField = 1 := by + rw [← finiteExtensionInfinityPlace_degree_eq_finrank_residueField K L P] + exact hP + exact (Algebra.finrank_eq_one_iff_bijective_algebraMap.mp hfinrank).2 + +end DegreeOneResidue + +section GlobalDedekindCancellation + +variable {C R L : Type*} [Field C] [CommRing R] [IsDedekindDomain R] + [Field L] [Algebra C R] [Algebra R L] [Algebra C L] + [IsScalarTower C R L] [IsFractionRing R L] + +/-- Global height-one cancellation obtained by applying the DVR theorem after +localizing at the chosen Dedekind place. -/ +theorem exists_constant_finitePlaceOrder_sub_mul_eq_zero_or_lt_of_residue + (q : HeightOneSpectrum R) + (hresidue : Function.Surjective + (algebraMap C q.asIdeal.ResidueField)) + (x y : L) (hx : x ≠ 0) (hy : y ≠ 0) + (horder : finitePlaceOrder q x = finitePlaceOrder q y) : + ∃ c : C, + x - algebraMap C L c * y = 0 ∨ + finitePlaceOrder q x < + finitePlaceOrder q (x - algebraMap C L c * y) := by + let S := Localization.AtPrime q.asIdeal + let : Algebra C S := + Algebra.ofModule smul_mul_assoc mul_smul_comm + let : IsScalarTower C R S := inferInstance + let toField : S →+* L := + IsLocalization.lift + (S := S) (M := q.asIdeal.primeCompl) + (g := algebraMap R L) fun d => + IsLocalization.map_units L + ⟨d.1, q.asIdeal.primeCompl_le_nonZeroDivisors d.2⟩ + let : Algebra S L := toField.toAlgebra + let : IsScalarTower R S L := by + apply IsScalarTower.of_algebraMap_eq' + exact (IsLocalization.lift_comp _).symm + let : IsFractionRing S L := + IsFractionRing.isFractionRing_of_isDomain_of_isLocalization + q.asIdeal.primeCompl S L + let : IsDiscreteValuationRing S := + IsLocalization.AtPrime.isDiscreteValuationRing_of_dedekind_domain + R q.ne_bot S + let : IsScalarTower C S L := by + apply IsScalarTower.of_algebraMap_eq' + ext c + simp only [RingHom.comp_apply, + IsScalarTower.algebraMap_apply C R L, + IsScalarTower.algebraMap_apply C R S, + IsScalarTower.algebraMap_apply R S L] + let v := IsDiscreteValuationRing.maximalIdeal S + have hlocalResidue : Function.Surjective + (algebraMap C v.asIdeal.ResidueField) := by + have hvIdeal : v.asIdeal = IsLocalRing.maximalIdeal S := + IsLocalRing.eq_maximalIdeal v.isMaximal + apply constantResidue_surjective_of_ideal_eq hvIdeal + exact localizationAtPrime_constantResidue_surjective + (C := C) (R := R) (S := S) q hresidue + have hlocalOrder : finitePlaceOrder v x = finitePlaceOrder v y := by + simpa [v, S, localizationAtPrime_finitePlaceOrder_eq q] using horder + obtain ⟨c, hc⟩ := + exists_constant_finitePlaceOrder_sub_mul_eq_zero_or_lt + v hlocalResidue x y hx hy hlocalOrder + refine ⟨c, hc.elim Or.inl (fun hlt => Or.inr ?_)⟩ + simpa [v, S, localizationAtPrime_finitePlaceOrder_eq q] using hlt + +end GlobalDedekindCancellation + +section FiniteExtensionCancellation + + +variable (K : Type*) [Field K] [Fintype K] [DecidableEq K] + [DecidableEq (RatFunc K)] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +local instance onePointCancellationConstantAlgebra : Algebra K L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K (RatFunc K))) + +local instance onePointCancellationConstantTower : + IsScalarTower K (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + +local instance (priority := 10) onePointCancellationPolynomialAlgebra : + Algebra K[X] L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K[X] (RatFunc K))) + +local instance onePointCancellationPolynomialTower : + IsScalarTower K[X] (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + +local instance onePointCancellationFiniteConstantAlgebra : + Algebra K (RatFuncFiniteIntegralClosure K L) := + RingHom.toAlgebra ((algebraMap K[X] + (RatFuncFiniteIntegralClosure K L)).comp (algebraMap K K[X])) + +local instance onePointCancellationInfinityBaseConstantAlgebra : + Algebra K (RatFuncInfinityIntegers K) := + (ratFuncInfinityConstantRingHom K).toAlgebra + +local instance onePointCancellationInfinityConstantAlgebra : + Algebra K (RatFuncInfinityIntegralClosure K L) := + RingHom.toAlgebra + ((algebraMap (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L)).comp + (algebraMap K (RatFuncInfinityIntegers K))) + +local instance onePointCancellationFiniteIsDedekindDomain : + IsDedekindDomain (RatFuncFiniteIntegralClosure K L) := + integralClosure.isDedekindDomain K[X] (RatFunc K) L + +local instance onePointCancellationFiniteIsFractionRing : + IsFractionRing (RatFuncFiniteIntegralClosure K L) L := + integralClosure.isFractionRing_of_finite_extension (RatFunc K) L + +local instance onePointCancellationInfinityIsDedekindDomain : + IsDedekindDomain (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.isDedekindDomain + (RatFuncInfinityIntegers K) (RatFunc K) L + (RatFuncInfinityIntegralClosure K L) + +local instance onePointCancellationInfinityIsFractionRing : + IsFractionRing (RatFuncInfinityIntegralClosure K L) L := + integralClosure.isFractionRing_of_finite_extension (RatFunc K) L + +private local instance onePointCancellationInfinityCanonicalFractionAlgebra : + Algebra (RatFuncInfinityIntegralClosure K L) + (FractionRing (RatFuncInfinityIntegralClosure K L)) := + canonicalFractionRingAlgebra (RatFuncInfinityIntegralClosure K L) + +local instance onePointCancellationInfinityBaseTorsionFreeTop : + Module.IsTorsionFree (RatFuncInfinityIntegers K) L := + Module.IsTorsionFree.trans_faithfulSMul + (RatFuncInfinityIntegers K) (RatFunc K) L + +local instance onePointCancellationInfinityIsTorsionFree : + Module.IsTorsionFree (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.isTorsionFree (RatFuncInfinityIntegers K) L + +local instance onePointCancellationFiniteConstantTowerToField : + IsScalarTower K (RatFuncFiniteIntegralClosure K L) L := by + apply IsScalarTower.of_algebraMap_eq' + ext c + simp only [RingHom.comp_apply] + rw [IsScalarTower.algebraMap_apply K (RatFunc K) L] + rfl + +local instance onePointCancellationInfinityConstantTowerToField : + IsScalarTower K (RatFuncInfinityIntegralClosure K L) L := by + apply IsScalarTower.of_algebraMap_eq' + ext c + simp only [RingHom.comp_apply] + rw [IsScalarTower.algebraMap_apply K (RatFunc K) L] + rfl + +omit [DecidableEq K] in +omit [Fintype K] in +private theorem finiteExtensionPrincipalDivisor_inr_eq_finitePlaceOrder + (x : L) (P : FiniteExtensionInfinityPlace K L) : + finiteExtensionPrincipalDivisor K L x (.inr P) = + finitePlaceOrder + (primeOverHeightOne (ratFuncInfinityPlace K) P) x := by + classical + rw [finiteExtensionPrincipalDivisor_inr] + symm + simpa [ratFuncInfinityIntegralClosureFractionRingEquiv] using + fractionRingAlgEquiv_finitePlaceOrder_eq + (R := RatFuncInfinityIntegralClosure K L) (L := L) + (primeOverHeightOne (ratFuncInfinityPlace K) P) + ((ratFuncInfinityIntegralClosureFractionRingEquiv K L).symm x) + +omit [Fintype K] in +/-- At a degree-one exhaustive place, equal-order nonzero functions admit a +strict constant leading-term cancellation. -/ +theorem exists_constant_finiteExtensionPlaceOrder_sub_mul_eq_zero_or_lt + (P : FiniteExtensionPlace K L) + (hP : finiteExtensionPlaceDegree K L P = 1) + (x y : L) (hx : x ≠ 0) (hy : y ≠ 0) + (horder : finiteExtensionPrincipalDivisor K L x P = + finiteExtensionPrincipalDivisor K L y P) : + ∃ c : K, + x - algebraMap K L c * y = 0 ∨ + finiteExtensionPrincipalDivisor K L x P < + finiteExtensionPrincipalDivisor K L + (x - algebraMap K L c * y) P := by + cases P with + | inl q => + have hresidue := + finiteExtensionFinitePlace_constantResidue_surjective_of_degree_one + K L q hP + have horder' : finitePlaceOrder q x = finitePlaceOrder q y := by + simpa only [finiteExtensionPrincipalDivisor_inl_eq_finitePlaceOrder] + using horder + obtain ⟨c, hc⟩ := + exists_constant_finitePlaceOrder_sub_mul_eq_zero_or_lt_of_residue + (C := K) (R := RatFuncFiniteIntegralClosure K L) (L := L) + q hresidue x y hx hy horder' + refine ⟨c, hc.imp id ?_⟩ + intro hlt + simpa only [finiteExtensionPrincipalDivisor_inl_eq_finitePlaceOrder] + using hlt + | inr P => + let q := primeOverHeightOne + (R := RatFuncInfinityIntegers K) + (S := RatFuncInfinityIntegralClosure K L) + (ratFuncInfinityPlace K) P + have hresidue : Function.Surjective + (algebraMap K q.asIdeal.ResidueField) := by + change Function.Surjective (algebraMap K P.1.ResidueField) + exact + finiteExtensionInfinityPlace_constantResidue_surjective_of_degree_one + K L P hP + have horder' : finitePlaceOrder q x = finitePlaceOrder q y := by + simpa only [q, + finiteExtensionPrincipalDivisor_inr_eq_finitePlaceOrder] + using horder + obtain ⟨c, hc⟩ := + exists_constant_finitePlaceOrder_sub_mul_eq_zero_or_lt_of_residue + (C := K) (R := RatFuncInfinityIntegralClosure K L) (L := L) + q hresidue x y hx hy horder' + refine ⟨c, hc.imp id ?_⟩ + intro hlt + simpa only [q, + finiteExtensionPrincipalDivisor_inr_eq_finitePlaceOrder] + using hlt + +/-- At a degree-one place, cancelling the common leading coefficient of two +nonzero sections with exact pole order `n` either gives zero or lowers the +allowed pole order by one. -/ +theorem exists_constant_sub_mul_mem_onePointRiemannSpace_pred + (P : FiniteExtensionPlace K L) + (hP : finiteExtensionPlaceDegree K L P = 1) + {n : ℕ} (hn : 0 < n) {x y : L} + (hx : x ∈ finiteExtensionOnePointRiemannSpace K L P n) + (hy : y ∈ finiteExtensionOnePointRiemannSpace K L P n) + (hx0 : x ≠ 0) (hy0 : y ≠ 0) + (hxOrder : finiteExtensionPrincipalDivisor K L x P = -(n : ℤ)) + (hyOrder : finiteExtensionPrincipalDivisor K L y P = -(n : ℤ)) : + ∃ c : K, + x - algebraMap K L c * y = 0 ∨ + x - algebraMap K L c * y ∈ + finiteExtensionOnePointRiemannSpace K L P (n - 1) := by + have hxyOrder : finiteExtensionPrincipalDivisor K L x P = + finiteExtensionPrincipalDivisor K L y P := + hxOrder.trans hyOrder.symm + obtain ⟨c, hc⟩ := + exists_constant_finiteExtensionPlaceOrder_sub_mul_eq_zero_or_lt + K L P hP x y hx0 hy0 hxyOrder + refine ⟨c, hc.elim Or.inl (fun hlt => ?_)⟩ + let z := x - algebraMap K L c * y + by_cases hz0 : z = 0 + · exact Or.inl (by simpa [z] using hz0) + · refine Or.inr ?_ + rw [mem_finiteExtensionOnePointRiemannSpace_iff] + refine Or.inr ⟨hz0, ?_, ?_⟩ + · change -((n - 1 : ℕ) : ℤ) ≤ + finiteExtensionPrincipalDivisor K L z P + have hzOrder : -(n : ℤ) < + finiteExtensionPrincipalDivisor K L z P := by + simpa [z, hxOrder] using hlt + omega + · have hcy : algebraMap K L c * y ∈ + finiteExtensionOnePointRiemannSpace K L P n := by + have hsmul := + (finiteExtensionOnePointRiemannSpace K L P n).smul_mem c hy + simpa only [Algebra.smul_def] using hsmul + have hzMem : z ∈ finiteExtensionOnePointRiemannSpace K L P n := by + exact (finiteExtensionOnePointRiemannSpace K L P n).sub_mem hx hcy + rcases + (mem_finiteExtensionOnePointRiemannSpace_iff K L P n z).mp hzMem with + hz | ⟨_, _, hAway⟩ + · exact (hz0 hz).elim + · exact hAway + +/-- If the degree-one one-point filtration grows at level `n + 1`, one new +section is a pivot for the whole quotient. Its pole order is exactly +`-(n + 1)`, and every section of the larger space becomes a scalar multiple +of it modulo the preceding space. -/ +theorem exists_onePointRiemannSpace_pivot_of_lt + (P : FiniteExtensionPlace K L) + (hP : finiteExtensionPlaceDegree K L P = 1) (n : ℕ) + (hstrict : finiteExtensionOnePointRiemannSpace K L P n < + finiteExtensionOnePointRiemannSpace K L P (n + 1)) : + ∃ y : L, + y ∈ finiteExtensionOnePointRiemannSpace K L P (n + 1) ∧ + finiteExtensionPrincipalDivisor K L y P = -((n + 1 : ℕ) : ℤ) ∧ + ∀ x : L, + x ∈ finiteExtensionOnePointRiemannSpace K L P (n + 1) → + ∃ c : K, + x - c • y ∈ finiteExtensionOnePointRiemannSpace K L P n := by + have hnotle : ¬ finiteExtensionOnePointRiemannSpace K L P (n + 1) ≤ + finiteExtensionOnePointRiemannSpace K L P n := + not_le_of_gt hstrict + have hexists : ∃ y : L, + y ∈ finiteExtensionOnePointRiemannSpace K L P (n + 1) ∧ + y ∉ finiteExtensionOnePointRiemannSpace K L P n := by + by_contra h + apply hnotle + intro y hy + by_contra hyNot + exact h ⟨y, hy, hyNot⟩ + obtain ⟨y, hySucc, hyNot⟩ := hexists + obtain ⟨hy0, hyOrder⟩ := + BGS.HasseWeil.onePointRiemannSpace_order_eq_neg_succ_of_mem_not_mem + K L P n hySucc hyNot + refine ⟨y, hySucc, hyOrder, ?_⟩ + intro x hxSucc + by_cases hxMem : x ∈ finiteExtensionOnePointRiemannSpace K L P n + · refine ⟨0, ?_⟩ + simpa using hxMem + · obtain ⟨hx0, hxOrder⟩ := + BGS.HasseWeil.onePointRiemannSpace_order_eq_neg_succ_of_mem_not_mem + K L P n hxSucc hxMem + obtain ⟨c, hc⟩ := + exists_constant_sub_mul_mem_onePointRiemannSpace_pred + K L P hP (Nat.zero_lt_succ n) hxSucc hySucc hx0 hy0 hxOrder hyOrder + refine ⟨c, ?_⟩ + rcases hc with hzero | hmem + · have hzero' : x - c • y = 0 := by + simpa only [Algebra.smul_def] using hzero + rw [hzero'] + exact Submodule.zero_mem _ + · simpa only [Algebra.smul_def, Nat.succ_sub_one] using hmem + +end FiniteExtensionCancellation + +end + +end BGS.CorvajaZannier diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/OnePointPoleSemigroup.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/OnePointPoleSemigroup.lean new file mode 100644 index 0000000000..c4e227e33b --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/OnePointPoleSemigroup.lean @@ -0,0 +1,297 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.OnePointSectionSelection +public import Mathlib.Tactic + +/-! +# One-point pole-order semigroups +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +open BGS.CorvajaZannier +open scoped Polynomial + +noncomputable section + +/-- The elements at most `n` missing from an additive submonoid of `ℕ`. -/ +noncomputable def addSubmonoidGapsBelowOrAt + (H : AddSubmonoid ℕ) (n : ℕ) : Finset ℕ := by + classical + exact (Finset.range (n + 1)).filter (fun i => i ∉ H) + +private noncomputable def addSubmonoidMembersBelowOrAt + (H : AddSubmonoid ℕ) (n : ℕ) : Finset ℕ := by + classical + exact (Finset.range (n + 1)).filter (fun i => i ∈ H) + +private noncomputable def addSubmonoidPositiveMembersBelow + (H : AddSubmonoid ℕ) (n : ℕ) : Finset ℕ := by + classical + exact (Finset.range n).filter (fun i => i + 1 ∈ H) + +/-- Reflection through `i ↦ n - i` proves the elementary conductor bound: +if at most `g` elements up to `n` are gaps and `n ≥ 2g`, then `n` belongs to +the additive submonoid. -/ +theorem addSubmonoid_mem_of_card_gaps_le + (H : AddSubmonoid ℕ) (n g : ℕ) + (hgaps : (addSubmonoidGapsBelowOrAt H n).card ≤ g) + (hlarge : 2 * g ≤ n) : + n ∈ H := by + classical + by_contra hn + let members := addSubmonoidMembersBelowOrAt H n + let gaps := addSubmonoidGapsBelowOrAt H n + have hreflect : members.card ≤ gaps.card := by + apply Finset.card_le_card_of_injOn (fun i => n - i) + · intro i hi + have hi' : i < n + 1 ∧ i ∈ H := by + have hiFin : i ∈ addSubmonoidMembersBelowOrAt H n := hi + simpa only [addSubmonoidMembersBelowOrAt, Finset.mem_filter, + Finset.mem_range] using hiFin + have hreflected : n - i ∉ H := by + intro hreflected + have hsum : n - i + i = n := + Nat.sub_add_cancel (Nat.le_of_lt_succ hi'.1) + apply hn + rw [← hsum] + exact H.add_mem hreflected hi'.2 + have hreflectedRange : n - i < n + 1 := Nat.sub_lt_succ n i + have hreflectedFin : n - i ∈ addSubmonoidGapsBelowOrAt H n := by + rw [addSubmonoidGapsBelowOrAt, Finset.mem_filter, Finset.mem_range] + exact ⟨hreflectedRange, hreflected⟩ + exact hreflectedFin + · intro i hi j hj heq + have hi' : i < n + 1 ∧ i ∈ H := by + have hiFin : i ∈ addSubmonoidMembersBelowOrAt H n := hi + simpa only [addSubmonoidMembersBelowOrAt, Finset.mem_filter, + Finset.mem_range] using hiFin + have hj' : j < n + 1 ∧ j ∈ H := by + have hjFin : j ∈ addSubmonoidMembersBelowOrAt H n := hj + simpa only [addSubmonoidMembersBelowOrAt, Finset.mem_filter, + Finset.mem_range] using hjFin + have hiSum : n - i + i = n := + Nat.sub_add_cancel (Nat.le_of_lt_succ hi'.1) + have hjSum : n - j + j = n := + Nat.sub_add_cancel (Nat.le_of_lt_succ hj'.1) + change n - i = n - j at heq + apply Nat.add_left_cancel (n := n - j) + calc + (n - j) + i = (n - i) + i := by rw [heq] + _ = n := hiSum + _ = (n - j) + j := hjSum.symm + have hpartition : members.card + gaps.card = n + 1 := by + simpa only [members, gaps, addSubmonoidMembersBelowOrAt, + addSubmonoidGapsBelowOrAt, Finset.card_range] using + (Finset.card_filter_add_card_filter_not + (s := Finset.range (n + 1)) (p := fun i => i ∈ H)) + have hgap : gaps.card ≤ g := by + simpa only [gaps] using hgaps + omega + +private theorem one_add_card_positive_members_eq_card_members + (H : AddSubmonoid ℕ) : ∀ n : ℕ, + 1 + (addSubmonoidPositiveMembersBelow H n).card = + (addSubmonoidMembersBelowOrAt H n).card := by + classical + intro n + induction n with + | zero => + change 1 = ((Finset.range 1).filter (fun i => i ∈ H)).card + simp only [Finset.range_one, Finset.filter_singleton] + rw [ite_eq_left H.zero_mem] + simp + | succ n ih => + by_cases hn : n + 1 ∈ H + · have hpositive : + (addSubmonoidPositiveMembersBelow H (n + 1)).card = + (addSubmonoidPositiveMembersBelow H n).card + 1 := by + rw [addSubmonoidPositiveMembersBelow, Finset.range_add_one, + Finset.filter_insert, ite_eq_left hn, Finset.card_insert_of_notMem] + · rfl + · simp + have hmembers : + (addSubmonoidMembersBelowOrAt H (n + 1)).card = + (addSubmonoidMembersBelowOrAt H n).card + 1 := by + rw [addSubmonoidMembersBelowOrAt] + rw [show n + 1 + 1 = (n + 1) + 1 by omega, + Finset.range_add_one, Finset.filter_insert, ite_eq_left hn, + Finset.card_insert_of_notMem] + · rfl + · simp + rw [hpositive, hmembers] + omega + · have hpositive : + (addSubmonoidPositiveMembersBelow H (n + 1)).card = + (addSubmonoidPositiveMembersBelow H n).card := by + rw [addSubmonoidPositiveMembersBelow, Finset.range_add_one, + Finset.filter_insert, ite_eq_right hn, + addSubmonoidPositiveMembersBelow] + have hmembers : + (addSubmonoidMembersBelowOrAt H (n + 1)).card = + (addSubmonoidMembersBelowOrAt H n).card := by + rw [addSubmonoidMembersBelowOrAt] + rw [show n + 1 + 1 = (n + 1) + 1 by omega, + Finset.range_add_one, Finset.filter_insert, ite_eq_right hn, + addSubmonoidMembersBelowOrAt] + rw [hpositive, hmembers] + exact ih + +private theorem card_gaps_le_of_card_positive_members_ge + (H : AddSubmonoid ℕ) (n g : ℕ) + (hmembers : n - g ≤ + (addSubmonoidPositiveMembersBelow H n).card) + (hgn : g ≤ n) : + (addSubmonoidGapsBelowOrAt H n).card ≤ g := by + classical + let members := addSubmonoidMembersBelowOrAt H n + let gaps := addSubmonoidGapsBelowOrAt H n + have hmemberCard : 1 + + (addSubmonoidPositiveMembersBelow H n).card = members.card := by + simpa only [members] using one_add_card_positive_members_eq_card_members H n + have hpartition : members.card + gaps.card = n + 1 := by + simpa only [members, gaps, addSubmonoidMembersBelowOrAt, + addSubmonoidGapsBelowOrAt, Finset.card_range] using + (Finset.card_filter_add_card_filter_not + (s := Finset.range (n + 1)) (p := fun i => i ∈ H)) + change gaps.card ≤ g + omega + +variable (K : Type*) [Field K] [Fintype K] [DecidableEq K] + [DecidableEq (RatFunc K)] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +local instance onePointPoleSemigroupConstantAlgebra : Algebra K L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K (RatFunc K))) + +local instance onePointPoleSemigroupConstantTower : + IsScalarTower K (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + +/-- Exact pole orders at `P` of nonzero functions regular away from `P`. -/ +def onePointPoleOrderSemigroup + (P : FiniteExtensionPlace K L) : AddSubmonoid ℕ where + carrier := {n | ∃ x : L, x ≠ 0 ∧ + finiteExtensionPrincipalDivisor K L x P = -(n : ℤ) ∧ + ∀ v, v ≠ P → 0 ≤ finiteExtensionPrincipalDivisor K L x v} + zero_mem' := by + refine ⟨1, one_ne_zero, ?_, ?_⟩ + · rw [finiteExtensionPrincipalDivisor_one K L] + simp + · intro v hv + rw [finiteExtensionPrincipalDivisor_one K L] + simp + add_mem' := by + rintro m n ⟨x, hx0, hxP, hxAway⟩ ⟨y, hy0, hyP, hyAway⟩ + refine ⟨x * y, mul_ne_zero hx0 hy0, ?_, ?_⟩ + · rw [finiteExtensionPrincipalDivisor_mul K L x y hx0 hy0, + Finsupp.add_apply, hxP, hyP] + push_cast + ring + · intro v hv + rw [finiteExtensionPrincipalDivisor_mul K L x y hx0 hy0, + Finsupp.add_apply] + exact add_nonneg (hxAway v hv) (hyAway v hv) + +omit [Fintype K] in +omit [DecidableEq K] in +@[simp] +theorem mem_onePointPoleOrderSemigroup_iff + (P : FiniteExtensionPlace K L) (n : ℕ) : + n ∈ onePointPoleOrderSemigroup K L P ↔ + ∃ x : L, x ≠ 0 ∧ + finiteExtensionPrincipalDivisor K L x P = -(n : ℤ) ∧ + ∀ v, v ≠ P → 0 ≤ finiteExtensionPrincipalDivisor K L x v := + Iff.rfl + +/-- A positive exact pole order is equivalent to strict growth at that level. -/ +theorem succ_mem_onePointPoleOrderSemigroup_iff_lt + (P : FiniteExtensionPlace K L) (n : ℕ) : + n + 1 ∈ onePointPoleOrderSemigroup K L P ↔ + finiteExtensionOnePointRiemannSpace K L P n < + finiteExtensionOnePointRiemannSpace K L P (n + 1) := by + constructor + · rintro ⟨x, hx0, hxP, hxAway⟩ + have hxSucc : x ∈ finiteExtensionOnePointRiemannSpace K L P (n + 1) := by + rw [mem_finiteExtensionOnePointRiemannSpace_iff] + exact Or.inr ⟨hx0, by rw [hxP], hxAway⟩ + have hxNot : x ∉ finiteExtensionOnePointRiemannSpace K L P n := by + intro hx + rcases (mem_finiteExtensionOnePointRiemannSpace_iff K L P n x).mp hx with + rfl | ⟨_, hxLower, _⟩ + · exact hx0 rfl + · rw [hxP] at hxLower + omega + apply lt_of_le_of_ne (finiteExtensionOnePointRiemannSpace_mono K L P (by omega)) + intro heq + apply hxNot + rw [heq] + exact hxSucc + · intro hstrict + obtain ⟨x, hxSucc, hxNot⟩ := SetLike.exists_of_lt hstrict + obtain ⟨hx0, hxP⟩ := + onePointRiemannSpace_order_eq_neg_succ_of_mem_not_mem K L P n hxSucc hxNot + rcases (mem_finiteExtensionOnePointRiemannSpace_iff K L P (n + 1) x).mp + hxSucc with rfl | ⟨_, _, hxAway⟩ + · exact (hx0 rfl).elim + · exact ⟨x, hx0, hxP, hxAway⟩ + +/-- A degree-one place whose one-point spaces satisfy the coarse Riemann lower +bound has every pole order at least twice the genus budget. -/ +theorem mem_onePointPoleOrderSemigroup_of_two_mul_le + (P : FiniteExtensionPlace K L) + (hdegree : finiteExtensionPlaceDegree K L P = 1) + (hconstants : algebraicClosure K L = ⊥) + (g n : ℕ) + (hlower : ∀ m : ℕ, + m + 1 ≤ Module.finrank K + (finiteExtensionOnePointRiemannSpace K L P m) + g) + (hlarge : 2 * g ≤ n) : + n ∈ onePointPoleOrderSemigroup K L P := by + have hgn : g ≤ n := by omega + have hlower' : 1 + finiteExtensionPlaceDegree K L P * (n - g) ≤ + Module.finrank K (finiteExtensionOnePointRiemannSpace K L P n) := by + have h := hlower n + rw [hdegree] + simp only [one_mul] + omega + have hstrict : n - g ≤ + (strictFiltrationLevels + (fun m => finiteExtensionOnePointRiemannSpace K L P m) n).card := + le_card_onePointStrictLevels_of_finrank_lower K L P n (n - g) + hconstants hlower' + have hstrictEq : + strictFiltrationLevels + (fun m => finiteExtensionOnePointRiemannSpace K L P m) n = + addSubmonoidPositiveMembersBelow + (onePointPoleOrderSemigroup K L P) n := by + classical + ext i + simp only [strictFiltrationLevels, addSubmonoidPositiveMembersBelow, + Finset.mem_filter, Finset.mem_range] + rw [succ_mem_onePointPoleOrderSemigroup_iff_lt K L P i] + have hpositive : n - g ≤ + (addSubmonoidPositiveMembersBelow + (onePointPoleOrderSemigroup K L P) n).card := by + rw [← hstrictEq] + exact hstrict + apply addSubmonoid_mem_of_card_gaps_le + (onePointPoleOrderSemigroup K L P) n g + · exact card_gaps_le_of_card_positive_members_ge + (onePointPoleOrderSemigroup K L P) n g hpositive hgn + · exact hlarge + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/OnePointSectionSelection.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/OnePointSectionSelection.lean new file mode 100644 index 0000000000..bd4db4e09e --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/OnePointSectionSelection.lean @@ -0,0 +1,233 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.OnePointIncrement +public import LeanPool.MarkoffModP.BGS.HasseWeil.OnePointStepanovGrid +public import LeanPool.MarkoffModP.BGS.HasseWeil.RiemannSpaceConstants +public import Mathlib.Data.Fintype.EquivFin + +/-! +# Selecting one-point sections with distinct pole orders + +The local jump bound converts a Riemann-space dimension lower bound into +many strict levels of the pole filtration. Choosing one section at each +strict level, and adjoining the constant section, produces a linearly +independent family with distinct pole-order digits in a prescribed range. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +open BGS.CorvajaZannier +open scoped Polynomial + +noncomputable section + + +variable (K : Type*) [Field K] [Fintype K] [DecidableEq K] + [DecidableEq (RatFunc K)] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +local instance sectionSelectionConstantAlgebra : Algebra K L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K (RatFunc K))) + +local instance sectionSelectionConstantTower : + IsScalarTower K (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + +/-- With exact constants, the initial one-point Riemann space has dimension +one. -/ +theorem finiteExtensionOnePointRiemannSpace_zero_finrank + (P : FiniteExtensionPlace K L) + (hconstants : algebraicClosure K L = ⊥) : + Module.finrank K (finiteExtensionOnePointRiemannSpace K L P 0) = 1 := by + classical + change Module.finrank K + (finiteExtensionRiemannSpace K L (Finsupp.single P (0 : ℤ))) = 1 + have hzero : Finsupp.single P (0 : ℤ) = + (0 : FiniteExtensionDivisor K L) := by + ext v + by_cases hv : v = P <;> simp [hv] + rw [hzero] + exact finiteExtensionRiemannSpace_zero_finrank K L hconstants + +/-- A final dimension lower bound forces the stated number of strict levels +in the one-point filtration. -/ +theorem le_card_onePointStrictLevels_of_finrank_lower + (P : FiniteExtensionPlace K L) (N m : ℕ) + (hconstants : algebraicClosure K L = ⊥) + (hlower : + 1 + finiteExtensionPlaceDegree K L P * m ≤ + Module.finrank K (finiteExtensionOnePointRiemannSpace K L P N)) : + m ≤ (strictFiltrationLevels + (fun n => finiteExtensionOnePointRiemannSpace K L P n) N).card := by + apply le_card_strictFiltrationLevels_of_initial_add_mul_le_finrank + (R := fun n => finiteExtensionOnePointRiemannSpace K L P n) + (d := finiteExtensionPlaceDegree K L P) + · exact finiteExtensionPlaceDegree_pos K L P + · intro n + exact finiteExtensionOnePointRiemannSpace_mono K L P (by omega) + · intro n + exact finiteExtensionOnePointRiemannSpace_finrank_succ_le K L P n + · rw [finiteExtensionOnePointRiemannSpace_zero_finrank K L P hconstants] + exact hlower + +/-- Select a prescribed number of positive-pole sections from the strict +levels below `N`. -/ +theorem exists_onePointSections_of_le_card_strictLevels + (P : FiniteExtensionPlace K L) (N m : ℕ) + (hm : m ≤ (strictFiltrationLevels + (fun n => finiteExtensionOnePointRiemannSpace K L P n) N).card) : + ∃ (f : Fin m → L) (d : Fin m → ℕ), + (∀ i, f i ∈ finiteExtensionOnePointRiemannSpace K L P N) ∧ + (∀ i, f i ≠ 0) ∧ + (∀ i, finiteExtensionPrincipalDivisor K L (f i) P = -(d i : ℤ)) ∧ + Function.Injective d ∧ + (∀ i, 0 < d i ∧ d i ≤ N) ∧ + LinearIndependent K f := by + classical + let I := {n // n ∈ strictFiltrationLevels + (fun r => finiteExtensionOnePointRiemannSpace K L P r) N} + obtain ⟨F, hF, hFinjective⟩ := + exists_onePointRiemannSpace_sections_indexed_by_strictLevels K L P N + have hcard : Fintype.card (Fin m) ≤ Fintype.card I := by + rw [Fintype.card_fin] + simpa only [I, Fintype.card_coe] using hm + let e : Fin m ↪ I := + Classical.choice (Function.Embedding.nonempty_of_card_le hcard) + let f : Fin m → L := fun i => F (e i) + let d : Fin m → ℕ := fun i => (e i).1 + 1 + have hdPositive (i : Fin m) : 0 < d i := by + simp [d] + have hdLe (i : Fin m) : d i ≤ N := by + have hiRange : (e i).1 ∈ Finset.range N := + (Finset.mem_filter.mp (e i).2).1 + have hiLt : (e i).1 < N := Finset.mem_range.mp hiRange + simp only [d] + omega + have hfMem (i : Fin m) : + f i ∈ finiteExtensionOnePointRiemannSpace K L P N := by + apply finiteExtensionOnePointRiemannSpace_mono K L P (hdLe i) + exact (hF (e i)).1 + have hfNotMem (i : Fin m) : + f i ∉ finiteExtensionOnePointRiemannSpace K L P (e i).1 := + (hF (e i)).2.1 + have hfNe (i : Fin m) : f i ≠ 0 := by + intro hzero + apply hfNotMem i + rw [hzero] + exact Submodule.zero_mem _ + have hfOrder (i : Fin m) : + finiteExtensionPrincipalDivisor K L (f i) P = -(d i : ℤ) := by + simpa only [f, d] using (hF (e i)).2.2 + have hdInjective : Function.Injective d := by + intro i j hij + apply e.injective + apply Subtype.ext + simp only [d] at hij + omega + have horderInjective : Function.Injective + (fun i => finiteExtensionPrincipalDivisor K L (f i) P) := by + intro i j hij + apply hdInjective + have hcast : -(d i : ℤ) = -(d j : ℤ) := by + rw [← hfOrder i, ← hfOrder j] + exact hij + exact_mod_cast (neg_inj.mp hcast) + refine ⟨f, d, hfMem, hfNe, hfOrder, hdInjective, + fun i => ⟨hdPositive i, hdLe i⟩, ?_⟩ + exact linearIndependent_of_injective_finiteExtensionPrincipalDivisor_order + K L P f hfNe horderInjective + +/-- Adjoin the constant section to a selected positive-pole family. The +resulting pole digits start at zero and remain pairwise distinct. -/ +theorem exists_onePointSectionsWithConstant_of_le_card_strictLevels + (P : FiniteExtensionPlace K L) (N m : ℕ) + (hm : m ≤ (strictFiltrationLevels + (fun n => finiteExtensionOnePointRiemannSpace K L P n) N).card) : + ∃ (f : Option (Fin m) → L) (d : Option (Fin m) → ℕ), + (∀ i, f i ∈ finiteExtensionOnePointRiemannSpace K L P N) ∧ + (∀ i, f i ≠ 0) ∧ + (∀ i, finiteExtensionPrincipalDivisor K L (f i) P = -(d i : ℤ)) ∧ + Function.Injective d ∧ + (∀ i, d i ≤ N) ∧ + LinearIndependent K f := by + classical + obtain ⟨f₀, d₀, hf₀Mem, hf₀Ne, hf₀Order, hd₀Injective, + hd₀Range, hf₀LI⟩ := + exists_onePointSections_of_le_card_strictLevels K L P N m hm + let f : Option (Fin m) → L + | none => 1 + | some i => f₀ i + let d : Option (Fin m) → ℕ + | none => 0 + | some i => d₀ i + have hfMem : ∀ i, f i ∈ + finiteExtensionOnePointRiemannSpace K L P N := by + intro i + cases i with + | none => + simpa [f] using + algebraMap_mem_finiteExtensionOnePointRiemannSpace K L P N (1 : K) + | some i => simpa [f] using hf₀Mem i + have hfNe : ∀ i, f i ≠ 0 := by + intro i + cases i with + | none => simp [f] + | some i => simpa [f] using hf₀Ne i + have hfOrder : ∀ i, + finiteExtensionPrincipalDivisor K L (f i) P = -(d i : ℤ) := by + intro i + cases i with + | none => + simp [f, d, finiteExtensionPrincipalDivisor_one] + | some i => simpa [f, d] using hf₀Order i + have hdInjective : Function.Injective d := by + intro i j hij + cases i with + | none => + cases j with + | none => rfl + | some j => + exfalso + have hj := (hd₀Range j).1 + simp [d] at hij + omega + | some i => + cases j with + | none => + exfalso + have hi := (hd₀Range i).1 + simp [d] at hij + omega + | some j => + congr 1 + exact hd₀Injective (by simpa [d] using hij) + have horderInjective : Function.Injective + (fun i => finiteExtensionPrincipalDivisor K L (f i) P) := by + intro i j hij + apply hdInjective + have hcast : -(d i : ℤ) = -(d j : ℤ) := by + rw [← hfOrder i, ← hfOrder j] + exact hij + exact_mod_cast (neg_inj.mp hcast) + refine ⟨f, d, hfMem, hfNe, hfOrder, hdInjective, ?_, ?_⟩ + · intro i + cases i with + | none => simp [d] + | some i => simpa [d] using (hd₀Range i).2 + · exact linearIndependent_of_injective_finiteExtensionPrincipalDivisor_order + K L P f hfNe horderInjective + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/OnePointStepanovBasisGrid.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/OnePointStepanovBasisGrid.lean new file mode 100644 index 0000000000..ffe613443e --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/OnePointStepanovBasisGrid.lean @@ -0,0 +1,182 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.FrobeniusRestriction +public import LeanPool.MarkoffModP.BGS.HasseWeil.OnePointStepanovGrid +public import Mathlib.Tactic + +/-! +# One-point Stepanov grids from a full Riemann-space basis + +The usual mixed-order grid chooses both tensor factors at distinct strict +levels. For a place of degree greater than one, that discards most of the +second Riemann space. This file proves that the second family may instead +be any linearly independent family. + +Group a relation by the first index. Frobenius linearity turns each row +into `u i * Frobenius (row i)`. Every nonzero such term has order + +`-d i + (#K) * order (row i)`. + +The digits `d i < #K` are distinct, so these orders remain distinct modulo +`#K`, independently of the orders of the rows. A unique least-order term +then rules out a nontrivial relation. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +open BGS.CorvajaZannier +open scoped Polynomial BigOperators + +noncomputable section + +section FrobeniusInjectivity + +variable (K A : Type*) [Field K] [Fintype K] + [Field A] [Algebra K A] + +/-- Frobenius iteration is injective on a field. -/ +theorem powCardLinearMap_injective (n : ℕ) : + Function.Injective (powCardLinearMap K A n) := by + exact (powCardAlgHom K A n).injective + +end FrobeniusInjectivity + +private theorem digit_eq_of_neg_add_mul_eq + {s d e : ℕ} (hd : d < s) (he : e < s) + {a b : ℤ} + (h : -(d : ℤ) + (s : ℤ) * a = -(e : ℤ) + (s : ℤ) * b) : + d = e := by + have hdiv : (s : ℤ) ∣ (d : ℤ) - (e : ℤ) := by + refine ⟨a - b, ?_⟩ + linarith + have habs : |(d : ℤ) - (e : ℤ)| < (s : ℤ) := by + rw [abs_lt] + constructor <;> omega + have hzero := Int.eq_zero_of_abs_lt_dvd hdiv habs + exact_mod_cast (sub_eq_zero.mp hzero) + +variable (K : Type*) [Field K] [Fintype K] [DecidableEq K] + [DecidableEq (RatFunc K)] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +local instance basisGridConstantAlgebra : Algebra K L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K (RatFunc K))) + +local instance basisGridConstantTower : + IsScalarTower K (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + +omit [DecidableEq K] in +/-- A bounded distinct first pole-order digit and an arbitrary linearly +independent second family produce a linearly independent Frobenius product +grid. -/ +theorem onePointStepanovBasisGrid_linearIndependent + {α β : Type*} [Finite α] [Finite β] + (P : FiniteExtensionPlace K L) + (u : α → L) (d : α → ℕ) (v : β → L) + (hu : ∀ i, u i ≠ 0) + (huOrder : ∀ i, + finiteExtensionPrincipalDivisor K L (u i) P = -(d i : ℤ)) + (hdInjective : Function.Injective d) + (hdigit : ∀ i, d i < Fintype.card K) + (hvLI : LinearIndependent K v) : + LinearIndependent K + (fun ij : α × β => u ij.1 * (v ij.2) ^ Fintype.card K) := by + classical + let : Fintype α := Fintype.ofFinite α + let : Fintype β := Fintype.ofFinite β + rw [Fintype.linearIndependent_iff] + intro c hrelation ij + by_contra hcZero + let row : α → L := fun i => ∑ j, c (i, j) • v j + have hrowNe : row ij.1 ≠ 0 := by + intro hzero + have hcoeff := (Fintype.linearIndependent_iff.mp hvLI) + (fun j => c (ij.1, j)) hzero ij.2 + exact hcZero hcoeff + let S : Finset α := Finset.univ.filter (fun i => row i ≠ 0) + have hijS : ij.1 ∈ S := by simp [S, hrowNe] + have hSnonempty : S.Nonempty := ⟨ij.1, hijS⟩ + let term : α → L := fun i => + u i * powCardLinearMap K L 1 (row i) + have htermNe : ∀ i ∈ S, term i ≠ 0 := by + intro i hi + have hpowNe : powCardLinearMap K L 1 (row i) ≠ 0 := by + intro hzero + apply (Finset.mem_filter.mp hi).2 + apply powCardLinearMap_injective K L 1 + simpa using hzero + exact mul_ne_zero (hu i) hpowNe + have htermOrder (i : α) (hi : i ∈ S) : + finiteExtensionPrincipalDivisor K L (term i) P = + -(d i : ℤ) + (Fintype.card K : ℤ) * + finiteExtensionPrincipalDivisor K L (row i) P := by + change finiteExtensionPrincipalDivisor K L + (u i * powCardLinearMap K L 1 (row i)) P = _ + have hpowNe : powCardLinearMap K L 1 (row i) ≠ 0 := by + intro hzero + apply (Finset.mem_filter.mp hi).2 + apply powCardLinearMap_injective K L 1 + simpa using hzero + rw [finiteExtensionPrincipalDivisor_mul K L _ _ (hu i) hpowNe] + simp only [Finsupp.add_apply] + rw [finiteExtensionPrincipalDivisor_powCardLinearMap_apply K L + (row i) ((Finset.mem_filter.mp hi).2) 1 P, + huOrder i] + simp + have htermOrderInjective : ∀ i ∈ S, ∀ j ∈ S, + finiteExtensionPrincipalDivisor K L (term i) P = + finiteExtensionPrincipalDivisor K L (term j) P → i = j := by + intro i hi j hj hij + apply hdInjective + apply digit_eq_of_neg_add_mul_eq (hdigit i) (hdigit j) + rw [← htermOrder i hi, ← htermOrder j hj] + exact hij + have hsumRelation : ∑ i ∈ S, term i = 0 := by + calc + ∑ i ∈ S, term i = ∑ i, term i := by + apply Finset.sum_subset (Finset.subset_univ S) + intro i _ hi + have hrowZero : row i = 0 := by + simpa only [S, Finset.mem_filter, Finset.mem_univ, true_and, + not_ne_iff] using hi + simp [term, hrowZero] + _ = ∑ i, ∑ j, c (i, j) • + (u i * (v j) ^ Fintype.card K) := by + apply Finset.sum_congr rfl + intro i _ + simp only [term, row, map_sum, map_smul, + powCardLinearMap_apply, pow_one, Finset.mul_sum] + apply Finset.sum_congr rfl + intro j _ + simp only [Algebra.smul_def] + ring + _ = ∑ p : α × β, c p • + (u p.1 * (v p.2) ^ Fintype.card K) := by + rw [Fintype.sum_prod_type] + _ = 0 := hrelation + obtain ⟨i, hiS, hileast⟩ := S.exists_min_image + (fun j => finiteExtensionPrincipalDivisor K L (term j) P) hSnonempty + have htermMin : ∀ j ∈ S, j ≠ i → + finiteExtensionPrincipalDivisor K L (term i) P < + finiteExtensionPrincipalDivisor K L (term j) P := by + intro j hj hji + exact lt_of_le_of_ne (hileast j hj) + (fun heq => hji (htermOrderInjective j hj i hiS heq.symm)) + exact False.elim ((finiteExtensionPrincipalDivisor_sum_eq_of_unique_min + K L P S term i hiS htermNe htermMin).1 hsumRelation) + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/OnePointStepanovDegreeTwoAuxiliary.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/OnePointStepanovDegreeTwoAuxiliary.lean new file mode 100644 index 0000000000..6f93a259c1 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/OnePointStepanovDegreeTwoAuxiliary.lean @@ -0,0 +1,245 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.OnePointSectionSelection +public import LeanPool.MarkoffModP.BGS.HasseWeil.OnePointStepanovBasisGrid +public import LeanPool.MarkoffModP.BGS.HasseWeil.StepanovParameters +public import LeanPool.MarkoffModP.BGS.HasseWeil.StepanovRestrictionMaps +public import Mathlib.Tactic + +/-! +# Stepanov auxiliaries at places of degree at most two + +At a degree-two place the strict-level filtration can jump by two. Choosing +one section per strict level for both tensor factors therefore loses the +factor of two needed by the Stepanov dimension count. The first factor still +uses bounded distinct pole-order digits, while the second factor is now a +full basis of its one-point Riemann space. The basis-grid theorem proves +that the first restriction remains injective. + +With `ell = #K - 1` and `m = #K + 2g`, the same large-field hypothesis as in +the degree-one construction makes the coefficient dimension exceed the +second restriction target for every place degree `r ≤ 2`. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +open BGS.CorvajaZannier +open scoped Polynomial + +noncomputable section + + +variable (K : Type*) [Field K] [Fintype K] [DecidableEq K] + [DecidableEq (RatFunc K)] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +local instance degreeTwoAuxiliaryConstantAlgebra : Algebra K L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K (RatFunc K))) + +local instance degreeTwoAuxiliaryConstantTower : + IsScalarTower K (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + +/-- The one-point Riemann space at level `N` has dimension at most +`N * degree(P) + 1` when the constants are exactly `K`. -/ +theorem finiteExtensionOnePointRiemannSpace_finrank_upper + (P : FiniteExtensionPlace K L) + (hconstants : algebraicClosure K L = ⊥) : + ∀ N, Module.finrank K + (finiteExtensionOnePointRiemannSpace K L P N) ≤ + N * finiteExtensionPlaceDegree K L P + 1 := by + intro N + induction N with + | zero => + simpa using + (finiteExtensionOnePointRiemannSpace_zero_finrank K L P hconstants).le + | succ N ih => + have hstep := finiteExtensionOnePointRiemannSpace_finrank_succ_le + K L P N + calc + Module.finrank K + (finiteExtensionOnePointRiemannSpace K L P (N + 1)) ≤ + Module.finrank K + (finiteExtensionOnePointRiemannSpace K L P N) + + finiteExtensionPlaceDegree K L P := hstep + _ ≤ (N * finiteExtensionPlaceDegree K L P + 1) + + finiteExtensionPlaceDegree K L P := + Nat.add_le_add_right ih _ + _ = (N + 1) * finiteExtensionPlaceDegree K L P + 1 := by + rw [Nat.add_mul] + omega + +/-- The full-basis Stepanov coefficient space beats the target dimension at +every positive place degree at most two. -/ +theorem stepanov_dimension_inequality_degree_le_two + {g s r : ℕ} (hlarge : (g + 1) * (g + 2) ≤ s) + (hrpos : 0 < r) (hrle : r ≤ 2) : + r * (s * stepanovEll s + stepanovM g s) + 1 < + (stepanovEll s + 1 - g) * + (r * stepanovM g s + 1 - g) := by + have hr : r = 1 ∨ r = 2 := by omega + rcases hr with rfl | rfl + · simpa only [one_mul, Nat.mul_comm s (stepanovEll s)] using + (stepanov_dimension_inequality hlarge) + · have hs : 0 < s := by nlinarith + have hgs : g ≤ s := by nlinarith + have hell : stepanovEll s + 1 - g = s - g := by + simp only [stepanovEll] + omega + have hm : 2 * stepanovM g s + 1 - g = 2 * s + 3 * g + 1 := by + simp only [stepanovM] + omega + have hleft : 2 * (s * stepanovEll s + stepanovM g s) + 1 = + 2 * s ^ 2 + 4 * g + 1 := by + simp only [stepanovEll, stepanovM] + nlinarith [Nat.sub_add_cancel (show 1 ≤ s by omega)] + rw [hell, hm, hleft] + have hlargeZ : (((g + 1) * (g + 2) : ℕ) : ℤ) ≤ (s : ℤ) := by + exact_mod_cast hlarge + have hgoalZ : + ((2 * s ^ 2 + 4 * g + 1 : ℕ) : ℤ) < + (((s - g) * (2 * s + 3 * g + 1) : ℕ) : ℤ) := by + rw [Nat.cast_mul, Nat.cast_sub hgs] + push_cast at hlargeZ ⊢ + nlinarith [sq_nonneg (g : ℤ), + mul_nonneg (by positivity : (0 : ℤ) ≤ g) (sq_nonneg (g : ℤ))] + exact_mod_cast hgoalZ + +/-- A Riemann lower bound at a place of degree at most two produces a +nonzero Stepanov coefficient grid. The first family has bounded distinct +pole orders; the second family is a full basis of `L(mP)`. + +The returned second restriction equality is in the ambient function field, +so it can be consumed directly by the local square-Frobenius vanishing +argument. -/ +theorem exists_onePointStepanovBasisAuxiliary_of_degree_le_two + (P : FiniteExtensionPlace K L) (g : ℕ) + (hconstants : algebraicClosure K L = ⊥) + (hdegreeLe : finiteExtensionPlaceDegree K L P ≤ 2) + (hriemann : ∀ N, + N * finiteExtensionPlaceDegree K L P + 1 ≤ + Module.finrank K + (finiteExtensionOnePointRiemannSpace K L P N) + g) + (hlarge : (g + 1) * (g + 2) ≤ Fintype.card K) : + let s := Fintype.card K + let ell := stepanovEll s + let m := stepanovM g s + let V := finiteExtensionOnePointRiemannSpace K L P m + ∃ (u : Option (Fin (ell - g)) → L) + (du : Option (Fin (ell - g)) → ℕ) + (v : Fin (Module.finrank K V) → L) + (c : (Option (Fin (ell - g)) × + Fin (Module.finrank K V)) →₀ K), + (∀ i, u i ∈ finiteExtensionOnePointRiemannSpace K L P ell) ∧ + (∀ i, u i ≠ 0) ∧ + (∀ i, finiteExtensionPrincipalDivisor K L (u i) P = -(du i : ℤ)) ∧ + Function.Injective du ∧ + (∀ i, du i ≤ ell) ∧ + LinearIndependent K u ∧ + (∀ j, v j ∈ V) ∧ + LinearIndependent K v ∧ + c ≠ 0 ∧ + onePointStepanovSecondRestrictionMap K L u v s c = 0 ∧ + onePointStepanovFirstRestrictionMap K L u v s c ≠ 0 := by + let r := finiteExtensionPlaceDegree K L P + let s := Fintype.card K + let ell := stepanovEll s + let m := stepanovM g s + let V := finiteExtensionOnePointRiemannSpace K L P m + have hrpos : 0 < r := finiteExtensionPlaceDegree_pos K L P + have hrle : r ≤ 2 := hdegreeLe + have hlarge' : (g + 1) * (g + 2) ≤ s := hlarge + have hgltS : g < s := by nlinarith + have hgell : g ≤ ell := by + simp only [ell, stepanovEll] + omega + have helllt : ell < s := stepanovEll_lt hlarge' + have hellDecomp : ell = (ell - g) + g := by omega + have hstrictLower : + 1 + r * (ell - g) ≤ + Module.finrank K + (finiteExtensionOnePointRiemannSpace K L P ell) := by + have hcoarse := hriemann ell + change ell * r + 1 ≤ + Module.finrank K + (finiteExtensionOnePointRiemannSpace K L P ell) + g at hcoarse + have hellMul : ell * r = (ell - g) * r + g * r := by + calc + ell * r = ((ell - g) + g) * r := by rw [← hellDecomp] + _ = (ell - g) * r + g * r := Nat.add_mul _ _ _ + rw [hellMul] at hcoarse + have hgr : g ≤ g * r := Nat.le_mul_of_pos_right g hrpos + have htarget : 1 + (ell - g) * r ≤ + Module.finrank K + (finiteExtensionOnePointRiemannSpace K L P ell) := by + omega + simpa only [Nat.mul_comm r (ell - g)] using htarget + have hstrict : ell - g ≤ + (strictFiltrationLevels + (fun n => finiteExtensionOnePointRiemannSpace K L P n) ell).card := + le_card_onePointStrictLevels_of_finrank_lower + K L P ell (ell - g) hconstants hstrictLower + obtain ⟨u, du, huMem, huNe, huOrder, hduInjective, hduLe, huLI⟩ := + exists_onePointSectionsWithConstant_of_le_card_strictLevels + K L P ell (ell - g) hstrict + let : Module.Finite K V := + finiteExtensionOnePointRiemannSpace_moduleFinite K L P m + let b := Module.finBasis K V + let v : Fin (Module.finrank K V) → L := fun j => (b j : V) + have hvMem : ∀ j, v j ∈ V := fun j => (b j).property + have hvLI : LinearIndependent K v := by + rw [Fintype.linearIndependent_iff] + intro c hc j + apply (Fintype.linearIndependent_iff.mp b.linearIndependent c) _ j + apply V.subtype_injective + simpa only [map_sum, map_smul, map_zero, Submodule.subtype_apply, v] + using hc + have hgridLI : LinearIndependent K + (fun ij : Option (Fin (ell - g)) × Fin (Module.finrank K V) => + u ij.1 * (v ij.2) ^ s) := by + exact onePointStepanovBasisGrid_linearIndependent K L P u du v + huNe huOrder hduInjective (fun i => (hduLe i).trans_lt helllt) hvLI + have hupper : Module.finrank K + (finiteExtensionOnePointRiemannSpace K L P (s * ell + m)) ≤ + r * (s * ell + m) + 1 := by + have h := finiteExtensionOnePointRiemannSpace_finrank_upper + K L P hconstants (s * ell + m) + simpa only [r, Nat.mul_comm] using h + have hVlower : r * m + 1 - g ≤ Module.finrank K V := by + have h := hriemann m + simpa only [r, V, Nat.mul_comm] using (Nat.sub_le_iff_le_add.mpr h) + have hfirstCard : ell - g + 1 = ell + 1 - g := by omega + have hnumericBase := stepanov_dimension_inequality_degree_le_two + hlarge' hrpos hrle + have hnumeric : r * (s * ell + m) + 1 < + Fintype.card (Option (Fin (ell - g))) * + Fintype.card (Fin (Module.finrank K V)) := by + simp only [Fintype.card_option, Fintype.card_fin, hfirstCard] + exact hnumericBase.trans_le + (Nat.mul_le_mul_left (ell + 1 - g) hVlower) + obtain ⟨c, hcNe, hsecond, hfirst⟩ := + exists_onePointStepanovAuxiliary_of_target_finrank_upper + K L P u v ell m s (r * (s * ell + m) + 1) + huMem hvMem hgridLI hupper hnumeric + have hsecondRaw : + onePointStepanovSecondRestrictionMap K L u v s c = 0 := by + have h := congrArg Subtype.val hsecond + simpa only [onePointStepanovSecondCodRestrictionMap_coe, + Submodule.coe_zero] using h + exact ⟨u, du, v, c, huMem, huNe, huOrder, hduInjective, hduLe, + huLI, hvMem, hvLI, hcNe, hsecondRaw, hfirst⟩ + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/OnePointStepanovGrid.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/OnePointStepanovGrid.lean new file mode 100644 index 0000000000..3f83efdaf7 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/OnePointStepanovGrid.lean @@ -0,0 +1,306 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.OnePointStrictLevels +public import Mathlib.Tactic + +/-! +# One-point Stepanov grids + +At an arbitrary exhaustive place, a finite family of nonzero functions with +pairwise distinct principal-divisor orders is linearly independent over the +constant field. Applying this to products whose pole orders use a +mixed-radix encoding gives the one-point Stepanov grid. + +The distinguished place is not assumed to have degree one. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +open BGS.CorvajaZannier +open scoped nonZeroDivisors Polynomial BigOperators + +noncomputable section + +variable (K : Type*) [Field K] [Fintype K] [DecidableEq K] + [DecidableEq (RatFunc K)] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +local instance onePointStepanovGridConstantAlgebra : Algebra K L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K (RatFunc K))) + +local instance onePointStepanovGridConstantTower : + IsScalarTower K (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + +omit [Fintype K] [DecidableEq K] in +/-- Multiplication by a nonzero constant does not change the order at an +exhaustive place. -/ +theorem finiteExtensionPrincipalDivisor_smul_apply [Finite K] + (P : FiniteExtensionPlace K L) (c : K) (x : L) + (hc : c ≠ 0) (hx : x ≠ 0) : + finiteExtensionPrincipalDivisor K L (c • x) P = + finiteExtensionPrincipalDivisor K L x P := by + classical + have hcL : algebraMap K L c ≠ 0 := + by simpa only [map_zero] using (algebraMap K L).injective.ne hc + rw [Algebra.smul_def, + finiteExtensionPrincipalDivisor_mul K L _ _ hcL hx, + finiteExtensionPrincipalDivisor_algebraMap_constant K L c hc] + simp + +omit [Fintype K] [DecidableEq K] in +/-- If one summand has strictly smaller order than the other, then the sum is +nonzero and has the smaller order. -/ +theorem finiteExtensionPrincipalDivisor_add_eq_left_of_lt + (P : FiniteExtensionPlace K L) (x y : L) + (hx : x ≠ 0) (hy : y ≠ 0) + (hxyOrder : finiteExtensionPrincipalDivisor K L x P < + finiteExtensionPrincipalDivisor K L y P) : + x + y ≠ 0 ∧ + finiteExtensionPrincipalDivisor K L (x + y) P = + finiteExtensionPrincipalDivisor K L x P := by + have hxy : x + y ≠ 0 := by + intro hzero + have hyx : y = -x := + eq_neg_of_add_eq_zero_left (by simpa only [add_comm] using hzero) + have hneg := finiteExtensionPrincipalDivisor_neg_apply K L x hx P + rw [hyx, hneg] at hxyOrder + exact (lt_irrefl _ hxyOrder) + have hlower := finiteExtensionPrincipalDivisor_add_ge_min + K L x y hx hy hxy P + rw [min_eq_left (le_of_lt hxyOrder)] at hlower + have hreverse := finiteExtensionPrincipalDivisor_add_ge_min + K L (x + y) (-y) hxy (neg_ne_zero.mpr hy) + (by simpa only [add_neg_cancel_right] using hx) P + rw [show (x + y) + (-y) = x by ring, + finiteExtensionPrincipalDivisor_neg_apply K L y hy P] at hreverse + have hsumLeY : + finiteExtensionPrincipalDivisor K L (x + y) P ≤ + finiteExtensionPrincipalDivisor K L y P := by + by_contra hnot + have hyLeSum : finiteExtensionPrincipalDivisor K L y P ≤ + finiteExtensionPrincipalDivisor K L (x + y) P := le_of_not_ge hnot + rw [min_eq_right hyLeSum] at hreverse + omega + rw [min_eq_left hsumLeY] at hreverse + exact ⟨hxy, le_antisymm hreverse hlower⟩ + +omit [Fintype K] [DecidableEq K] in +/-- If every summand has order strictly above `a`, then their finite sum is +either zero or also has order strictly above `a`. -/ +theorem finiteExtensionPrincipalDivisor_sum_eq_zero_or_gt + {ι : Type*} (P : FiniteExtensionPlace K L) + (S : Finset ι) (f : ι → L) (a : ℤ) + (hf : ∀ i ∈ S, f i ≠ 0) + (horder : ∀ i ∈ S, a < finiteExtensionPrincipalDivisor K L (f i) P) : + (∑ i ∈ S, f i) = 0 ∨ + ((∑ i ∈ S, f i) ≠ 0 ∧ + a < finiteExtensionPrincipalDivisor K L (∑ i ∈ S, f i) P) := by + classical + induction S using Finset.induction_on with + | empty => simp + | @insert i S hi ih => + rw [Finset.sum_insert hi] + have hi0 : f i ≠ 0 := hf i (Finset.mem_insert_self i S) + have hiOrder : a < finiteExtensionPrincipalDivisor K L (f i) P := + horder i (Finset.mem_insert_self i S) + have hrest := ih + (fun j hj => hf j (Finset.mem_insert_of_mem hj)) + (fun j hj => horder j (Finset.mem_insert_of_mem hj)) + rcases hrest with hrestZero | ⟨hrest0, hrestOrder⟩ + · rw [hrestZero, add_zero] + exact Or.inr ⟨hi0, hiOrder⟩ + · by_cases hsum : f i + ∑ j ∈ S, f j = 0 + · exact Or.inl hsum + · refine Or.inr ⟨hsum, ?_⟩ + have hlower := finiteExtensionPrincipalDivisor_add_ge_min + K L (f i) (∑ j ∈ S, f j) hi0 hrest0 hsum P + exact (lt_min hiOrder hrestOrder).trans_le hlower + +omit [Fintype K] [DecidableEq K] in +/-- A unique least-order term controls a finite sum. -/ +theorem finiteExtensionPrincipalDivisor_sum_eq_of_unique_min + {ι : Type*} (P : FiniteExtensionPlace K L) + (S : Finset ι) (f : ι → L) (i : ι) (hi : i ∈ S) + (hf : ∀ j ∈ S, f j ≠ 0) + (hmin : ∀ j ∈ S, j ≠ i → + finiteExtensionPrincipalDivisor K L (f i) P < + finiteExtensionPrincipalDivisor K L (f j) P) : + (∑ j ∈ S, f j) ≠ 0 ∧ + finiteExtensionPrincipalDivisor K L (∑ j ∈ S, f j) P = + finiteExtensionPrincipalDivisor K L (f i) P := by + classical + let T := S.erase i + let r : L := ∑ j ∈ T, f j + have hrest := finiteExtensionPrincipalDivisor_sum_eq_zero_or_gt + K L P T f (finiteExtensionPrincipalDivisor K L (f i) P) + (fun j hj => hf j (Finset.mem_of_mem_erase hj)) + (fun j hj => hmin j (Finset.mem_of_mem_erase hj) + (Finset.ne_of_mem_erase hj)) + have hsum : (∑ j ∈ S, f j) = f i + r := by + rw [← Finset.sum_erase_add S f hi] + simp only [T, r] + ac_rfl + rcases hrest with hrestZero | ⟨hrest0, hrestOrder⟩ + · change r = 0 at hrestZero + rw [hsum, hrestZero, add_zero] + exact ⟨hf i hi, rfl⟩ + · change r ≠ 0 at hrest0 + change finiteExtensionPrincipalDivisor K L (f i) P < + finiteExtensionPrincipalDivisor K L r P at hrestOrder + rw [hsum] + exact finiteExtensionPrincipalDivisor_add_eq_left_of_lt + K L P (f i) r (hf i hi) hrest0 hrestOrder + +omit [Fintype K] [DecidableEq K] in +/-- A finite family of nonzero functions with pairwise distinct orders at one +exhaustive place is linearly independent over the constant field. -/ +theorem linearIndependent_of_injective_finiteExtensionPrincipalDivisor_order [Finite K] + {ι : Type*} [Finite ι] + (P : FiniteExtensionPlace K L) (f : ι → L) + (hf : ∀ i, f i ≠ 0) + (horder : Function.Injective + (fun i => finiteExtensionPrincipalDivisor K L (f i) P)) : + LinearIndependent K f := by + classical + let : Fintype ι := Fintype.ofFinite ι + rw [Fintype.linearIndependent_iff] + intro c hrelation + by_contra hnotZero + push Not at hnotZero + obtain ⟨i0, hi0⟩ := hnotZero + let S : Finset ι := Finset.univ.filter (fun i => c i ≠ 0) + have hSnonempty : S.Nonempty := by + exact ⟨i0, by simp [S, hi0]⟩ + obtain ⟨i, hiS, hileast⟩ := S.exists_min_image + (fun j => finiteExtensionPrincipalDivisor K L (f j) P) hSnonempty + let term : ι → L := fun j => c j • f j + have hterm0 : ∀ j ∈ S, term j ≠ 0 := by + intro j hj + have hcj : c j ≠ 0 := (Finset.mem_filter.mp hj).2 + change c j • f j ≠ 0 + rw [Algebra.smul_def] + exact mul_ne_zero + (by simpa only [map_zero] using (algebraMap K L).injective.ne hcj) + (hf j) + have htermOrder (j : ι) (hj : j ∈ S) : + finiteExtensionPrincipalDivisor K L (term j) P = + finiteExtensionPrincipalDivisor K L (f j) P := by + exact finiteExtensionPrincipalDivisor_smul_apply + K L P (c j) (f j) (Finset.mem_filter.mp hj).2 (hf j) + have htermMin : ∀ j ∈ S, j ≠ i → + finiteExtensionPrincipalDivisor K L (term i) P < + finiteExtensionPrincipalDivisor K L (term j) P := by + intro j hj hji + rw [htermOrder i hiS, htermOrder j hj] + exact lt_of_le_of_ne (hileast j hj) + (fun heq => hji (horder heq).symm) + have hsumNonzero := + (finiteExtensionPrincipalDivisor_sum_eq_of_unique_min + K L P S term i hiS hterm0 htermMin).1 + apply hsumNonzero + calc + (∑ j ∈ S, term j) = ∑ j, term j := by + apply Finset.sum_subset (Finset.subset_univ S) + intro j _hjUniv hjNotS + have hcj : c j = 0 := by + simp only [S, Finset.mem_filter, Finset.mem_univ, true_and, + not_ne_iff] at hjNotS + exact hjNotS + simp [term, hcj] + _ = 0 := by simpa only [term] using hrelation + +/-- Mixed-radix encoding of two pole-order digits. -/ +def onePointStepanovMixedOrder + {ι κ : Type*} (d : ι → ℕ) (e : κ → ℕ) (s : ℕ) + (ij : ι × κ) : ℕ := + d ij.1 + s * e ij.2 + +/-- If the first digit is strictly below the radix, the mixed pole-order +encoding is injective. -/ +theorem onePointStepanovMixedOrder_injective + {ι κ : Type*} (d : ι → ℕ) (e : κ → ℕ) (s : ℕ) + (hd : Function.Injective d) (he : Function.Injective e) + (hdigit : ∀ i, d i < s) : + Function.Injective (onePointStepanovMixedOrder d e s) := by + rintro ⟨i, j⟩ ⟨i', j'⟩ h + have hs : 0 < s := lt_of_le_of_lt (Nat.zero_le (d i)) (hdigit i) + have hdEq : d i = d i' := by + have hmod := congrArg (fun n : ℕ => n % s) h + simpa only [onePointStepanovMixedOrder, Nat.add_mul_mod_self_left, + Nat.mod_eq_of_lt (hdigit i), Nat.mod_eq_of_lt (hdigit i')] using hmod + have hi : i = i' := hd hdEq + subst i' + have heEq : e j = e j' := by + have hmul : s * e j = s * e j' := Nat.add_left_cancel h + exact Nat.eq_of_mul_eq_mul_left hs hmul + exact Prod.ext rfl (he heEq) + +omit [Fintype K] [DecidableEq K] in +/-- Exact order of a product in the one-point Stepanov grid. -/ +theorem onePointStepanovGrid_order + {ι κ : Type*} (P : FiniteExtensionPlace K L) + (f : ι → L) (g : κ → L) (d : ι → ℕ) (e : κ → ℕ) (s : ℕ) + (hf : ∀ i, f i ≠ 0) (hg : ∀ j, g j ≠ 0) + (hfOrder : ∀ i, finiteExtensionPrincipalDivisor K L (f i) P = + -(d i : ℤ)) + (hgOrder : ∀ j, finiteExtensionPrincipalDivisor K L (g j) P = + -(e j : ℤ)) + (ij : ι × κ) : + finiteExtensionPrincipalDivisor K L + (f ij.1 * (g ij.2) ^ s) P = + -(onePointStepanovMixedOrder d e s ij : ℤ) := by + rw [finiteExtensionPrincipalDivisor_mul K L _ _ + (hf ij.1) (pow_ne_zero s (hg ij.2)), + finiteExtensionPrincipalDivisor_pow K L _ (hg ij.2) s] + simp only [Finsupp.add_apply, Finsupp.smul_apply, nsmul_eq_mul, + hfOrder, hgOrder, onePointStepanovMixedOrder] + push_cast + ring + +omit [Fintype K] [DecidableEq K] in +/-- Two strict-level families whose first pole-order digit is below `s` +produce a linearly independent Stepanov product grid. -/ +theorem onePointStepanovGrid_linearIndependent [Finite K] + {ι κ : Type*} [Finite ι] [Finite κ] + (P : FiniteExtensionPlace K L) + (f : ι → L) (g : κ → L) (d : ι → ℕ) (e : κ → ℕ) (s : ℕ) + (hf : ∀ i, f i ≠ 0) (hg : ∀ j, g j ≠ 0) + (hfOrder : ∀ i, finiteExtensionPrincipalDivisor K L (f i) P = + -(d i : ℤ)) + (hgOrder : ∀ j, finiteExtensionPrincipalDivisor K L (g j) P = + -(e j : ℤ)) + (hd : Function.Injective d) (he : Function.Injective e) + (hdigit : ∀ i, d i < s) : + LinearIndependent K (fun ij : ι × κ => f ij.1 * (g ij.2) ^ s) := by + classical + apply linearIndependent_of_injective_finiteExtensionPrincipalDivisor_order + K L P + · intro ij + exact mul_ne_zero (hf ij.1) (pow_ne_zero s (hg ij.2)) + · intro ij ij' horderEq + apply onePointStepanovMixedOrder_injective d e s hd he hdigit + have hcast : + -(onePointStepanovMixedOrder d e s ij : ℤ) = + -(onePointStepanovMixedOrder d e s ij' : ℤ) := by + rw [← onePointStepanovGrid_order K L P f g d e s + hf hg hfOrder hgOrder ij, + ← onePointStepanovGrid_order K L P f g d e s + hf hg hfOrder hgOrder ij'] + exact horderEq + exact_mod_cast (neg_inj.mp hcast) + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/OnePointStrictLevels.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/OnePointStrictLevels.lean new file mode 100644 index 0000000000..98dc500a55 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/OnePointStrictLevels.lean @@ -0,0 +1,235 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.FilteredDimension +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionRiemannSpace + +/-! +# Strict levels in one-point filtrations + +This file separates the filtration-counting argument from any degree-one +leading-coefficient cancellation. For a nested filtration whose successive +finrank jumps are bounded by `d`, it bounds the final finrank by `d` times the +number of strict levels. A matching lower bound therefore forces many strict +levels. + +For the one-point Riemann filtration, a section that first appears at level +`n + 1` automatically has exact pole order `-(n + 1)`. Choosing one section +at every strict level gives a pairwise-distinct family of exact pole orders, +with no hypothesis on the degree of the distinguished place. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +noncomputable section + +variable {K L : Type*} [Field K] [AddCommGroup L] [Module K L] + +/-- Levels below `N` at which a nested filtration grows strictly. -/ +noncomputable def strictFiltrationLevels + (R : ℕ → Submodule K L) (N : ℕ) : Finset ℕ := by + classical + exact (Finset.range N).filter (fun n => R n < R (n + 1)) + +@[simp] +theorem strictFiltrationLevels_zero (R : ℕ → Submodule K L) : + strictFiltrationLevels R 0 = ∅ := by + simp [strictFiltrationLevels] + +theorem strictFiltrationLevels_succ_card_of_lt + (R : ℕ → Submodule K L) (n : ℕ) (h : R n < R (n + 1)) : + (strictFiltrationLevels R (n + 1)).card = + (strictFiltrationLevels R n).card + 1 := by + classical + simp only [strictFiltrationLevels, Finset.range_add_one, Finset.filter_insert] + rw [ite_eq_left h, Finset.card_insert_of_notMem] + simp + +theorem strictFiltrationLevels_succ_card_of_not_lt + (R : ℕ → Submodule K L) (n : ℕ) (h : ¬ R n < R (n + 1)) : + (strictFiltrationLevels R (n + 1)).card = + (strictFiltrationLevels R n).card := by + classical + simp only [strictFiltrationLevels, Finset.range_add_one, Finset.filter_insert] + rw [ite_eq_right h] + +/-- If every nontrivial step of a nested filtration has dimension increase at +most `d`, then the total dimension is bounded by `d` times the number of +strict steps, plus the initial dimension. -/ +theorem finrank_le_initial_add_mul_card_strictFiltrationLevels + (R : ℕ → Submodule K L) (d : ℕ) + (hnested : ∀ n, R n ≤ R (n + 1)) + (hjump : ∀ n, Module.finrank K (R (n + 1)) ≤ + Module.finrank K (R n) + d) : + ∀ N, Module.finrank K (R N) ≤ Module.finrank K (R 0) + + d * (strictFiltrationLevels R N).card := by + intro N + induction N with + | zero => simp + | succ n ih => + by_cases hstrict : R n < R (n + 1) + · calc + Module.finrank K (R (n + 1)) ≤ + Module.finrank K (R n) + d := hjump n + _ ≤ (Module.finrank K (R 0) + + d * (strictFiltrationLevels R n).card) + d := + Nat.add_le_add_right ih d + _ = Module.finrank K (R 0) + + d * (strictFiltrationLevels R (n + 1)).card := by + rw [strictFiltrationLevels_succ_card_of_lt R n hstrict] + simp [Nat.mul_add, Nat.add_assoc] + · have heq : R n = R (n + 1) := + eq_of_le_of_not_lt (hnested n) hstrict + calc + Module.finrank K (R (n + 1)) = Module.finrank K (R n) := by rw [← heq] + _ ≤ Module.finrank K (R 0) + + d * (strictFiltrationLevels R n).card := ih + _ = Module.finrank K (R 0) + + d * (strictFiltrationLevels R (n + 1)).card := by + rw [strictFiltrationLevels_succ_card_of_not_lt R n hstrict] + +/-- A lower dimension bound forces many strict filtration levels. -/ +theorem le_card_strictFiltrationLevels_of_initial_add_mul_le_finrank + (R : ℕ → Submodule K L) {d m N : ℕ} (hd : 0 < d) + (hnested : ∀ n, R n ≤ R (n + 1)) + (hjump : ∀ n, Module.finrank K (R (n + 1)) ≤ + Module.finrank K (R n) + d) + (hlower : Module.finrank K (R 0) + d * m ≤ + Module.finrank K (R N)) : + m ≤ (strictFiltrationLevels R N).card := by + have hupper := + finrank_le_initial_add_mul_card_strictFiltrationLevels + R d hnested hjump N + have hmul : d * m ≤ d * (strictFiltrationLevels R N).card := + Nat.le_of_add_le_add_left (hlower.trans hupper) + exact Nat.le_of_mul_le_mul_left hmul hd + +end + +end BGS.HasseWeil + +namespace BGS.HasseWeil + +open BGS.CorvajaZannier +open scoped Polynomial + +noncomputable section + + +variable (K : Type*) [Field K] [Fintype K] [DecidableEq K] + [DecidableEq (RatFunc K)] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +local instance strictLevelsConstantAlgebra : Algebra K L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K (RatFunc K))) + +local instance strictLevelsConstantTower : + IsScalarTower K (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + +omit [Fintype K] [DecidableEq K] [DecidableEq (RatFunc K)] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] in +private theorem exists_mem_not_mem_of_submodule_lt + {S T : Submodule K L} (h : S < T) : + ∃ x : L, x ∈ T ∧ x ∉ S := by + have hnotle : ¬ T ≤ S := not_le_of_gt h + by_contra hexists + apply hnotle + intro x hx + by_contra hxNot + exact hexists ⟨x, hx, hxNot⟩ + +/-- A section appearing for the first time at level `n + 1` has exact pole +order `-(n + 1)` at the distinguished place. No residue-degree hypothesis +is needed. -/ +theorem onePointRiemannSpace_order_eq_neg_succ_of_mem_not_mem + (P : FiniteExtensionPlace K L) (n : ℕ) {x : L} + (hxSucc : x ∈ finiteExtensionOnePointRiemannSpace K L P (n + 1)) + (hxNot : x ∉ finiteExtensionOnePointRiemannSpace K L P n) : + x ≠ 0 ∧ + finiteExtensionPrincipalDivisor K L x P = -((n + 1 : ℕ) : ℤ) := by + have hx0 : x ≠ 0 := by + intro hx + subst x + exact hxNot (Submodule.zero_mem _) + rcases + (mem_finiteExtensionOnePointRiemannSpace_iff K L P (n + 1) x).mp + hxSucc with + hx | ⟨_, hxLower, hxAway⟩ + · exact (hx0 hx).elim + · refine ⟨hx0, ?_⟩ + have hxNotLower : ¬ -(n : ℤ) ≤ + finiteExtensionPrincipalDivisor K L x P := by + intro hxLowerN + apply hxNot + rw [mem_finiteExtensionOnePointRiemannSpace_iff] + exact Or.inr ⟨hx0, hxLowerN, hxAway⟩ + have hxUpper : finiteExtensionPrincipalDivisor K L x P < -(n : ℤ) := + lt_of_not_ge hxNotLower + omega + +/-- Choose one section for every strict level below `N`. The chosen sections +have pairwise distinct exact pole orders, hence are themselves pairwise +distinct. -/ +theorem exists_onePointRiemannSpace_sections_indexed_by_strictLevels + (P : FiniteExtensionPlace K L) (N : ℕ) : + ∃ f : {n // n ∈ strictFiltrationLevels + (K := K) (L := L) + (fun m => finiteExtensionOnePointRiemannSpace K L P m) N} → L, + (∀ i, + f i ∈ finiteExtensionOnePointRiemannSpace K L P (i.1 + 1) ∧ + f i ∉ finiteExtensionOnePointRiemannSpace K L P i.1 ∧ + finiteExtensionPrincipalDivisor K L (f i) P = + -((i.1 + 1 : ℕ) : ℤ)) ∧ + Function.Injective f := by + classical + let I := {n // n ∈ strictFiltrationLevels + (K := K) (L := L) + (fun m => finiteExtensionOnePointRiemannSpace K L P m) N} + have hexists (i : I) : ∃ x : L, + x ∈ finiteExtensionOnePointRiemannSpace K L P (i.1 + 1) ∧ + x ∉ finiteExtensionOnePointRiemannSpace K L P i.1 ∧ + finiteExtensionPrincipalDivisor K L x P = + -((i.1 + 1 : ℕ) : ℤ) := by + have hiStrict : finiteExtensionOnePointRiemannSpace K L P i.1 < + finiteExtensionOnePointRiemannSpace K L P (i.1 + 1) := + (Finset.mem_filter.mp i.2).2 + obtain ⟨x, hxSucc, hxNot⟩ := + exists_mem_not_mem_of_submodule_lt K L hiStrict + obtain ⟨_, hxOrder⟩ := + onePointRiemannSpace_order_eq_neg_succ_of_mem_not_mem + K L P i.1 hxSucc hxNot + exact ⟨x, hxSucc, hxNot, hxOrder⟩ + let f : I → L := fun i => Classical.choose (hexists i) + have hf (i : I) : + f i ∈ finiteExtensionOnePointRiemannSpace K L P (i.1 + 1) ∧ + f i ∉ finiteExtensionOnePointRiemannSpace K L P i.1 ∧ + finiteExtensionPrincipalDivisor K L (f i) P = + -((i.1 + 1 : ℕ) : ℤ) := + Classical.choose_spec (hexists i) + refine ⟨f, hf, ?_⟩ + intro i j hij + apply Subtype.ext + have horders : -((i.1 + 1 : ℕ) : ℤ) = -((j.1 + 1 : ℕ) : ℤ) := by + calc + -((i.1 + 1 : ℕ) : ℤ) = + finiteExtensionPrincipalDivisor K L (f i) P := (hf i).2.2.symm + _ = finiteExtensionPrincipalDivisor K L (f j) P := by rw [hij] + _ = -((j.1 + 1 : ℕ) : ℤ) := (hf j).2.2 + omega + +end + + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/PlaneAffineCountTransfer.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/PlaneAffineCountTransfer.lean new file mode 100644 index 0000000000..8f041c302a --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/PlaneAffineCountTransfer.lean @@ -0,0 +1,175 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import Mathlib.Algebra.Order.Star.Real +public import Mathlib.Tactic + +/-! +# Numerical transfer from normalization counts to affine counts + +The geometric comparison between an affine plane curve and its normalization +is naturally expressed by two inequalities between natural-number +cardinalities. This file isolates the real absolute-value bookkeeping needed +to combine those inequalities with the closed Hasse--Weil bound. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +/-- If the affine and normalization counts differ by at most `error` in both +directions, then a Hasse--Weil bound for the normalization transfers to the +affine count, with the affine/projective constant `1` and `error` added. -/ +theorem abs_affine_sub_card_le_of_two_sided_count_comparison + (affine normalization fieldCard error : ℕ) + (upper : affine ≤ normalization + error) + (lower : normalization ≤ affine + error) + (bound : ℝ) + (hnormalization : + |(normalization : ℝ) - (fieldCard : ℝ) - 1| ≤ bound) : + |(affine : ℝ) - (fieldCard : ℝ)| ≤ bound + error + 1 := by + have hupperReal : + (affine : ℝ) - normalization ≤ error := by + have h : (affine : ℝ) ≤ normalization + error := by + exact_mod_cast upper + linarith + have hlowerReal : + -(error : ℝ) ≤ (affine : ℝ) - normalization := by + have h : (normalization : ℝ) ≤ affine + error := by + exact_mod_cast lower + linarith + have hcomparison : + |(affine : ℝ) - normalization| ≤ error := + abs_le.mpr ⟨hlowerReal, hupperReal⟩ + calc + |(affine : ℝ) - fieldCard| = + |((affine : ℝ) - normalization) + + ((normalization : ℝ) - fieldCard - 1) + 1| := by ring_nf + _ ≤ |(affine : ℝ) - normalization| + + |(normalization : ℝ) - fieldCard - 1| + |(1 : ℝ)| := + calc + |((affine : ℝ) - normalization) + + ((normalization : ℝ) - fieldCard - 1) + 1| ≤ + |((affine : ℝ) - normalization) + + ((normalization : ℝ) - fieldCard - 1)| + |(1 : ℝ)| := + abs_add_le _ _ + _ ≤ (|(affine : ℝ) - normalization| + + |(normalization : ℝ) - fieldCard - 1|) + |(1 : ℝ)| := + add_le_add (abs_add_le _ _) le_rfl + _ ≤ (error : ℝ) + bound + 1 := by + exact add_le_add (add_le_add hcomparison hnormalization) (by norm_num) + _ = bound + error + 1 := by ring + +/-- Large-degree branch of the affine estimate. A trivial fiber bound by +`fieldCard * smallDegree` already has Hasse--Weil scale whenever the other +coordinate degree is at least `sqrt fieldCard`. -/ +theorem abs_pointCount_sub_card_le_two_mul_sqrt_of_fiber_bound + (pointCount fieldCard smallDegree largeDegree : ℕ) + (hsmall : 0 < smallDegree) + (hcount : pointCount ≤ fieldCard * smallDegree) + (hlarge : Real.sqrt (fieldCard : ℝ) ≤ largeDegree) : + |(pointCount : ℝ) - fieldCard| ≤ + 2 * Real.sqrt (fieldCard : ℝ) * smallDegree * largeDegree := by + have hcountReal : (pointCount : ℝ) ≤ fieldCard * smallDegree := by + exact_mod_cast hcount + have hsmallReal : (1 : ℝ) ≤ smallDegree := by + exact_mod_cast hsmall + have hfieldNonneg : (0 : ℝ) ≤ fieldCard := by positivity + have hsqrtNonneg : 0 ≤ Real.sqrt (fieldCard : ℝ) := Real.sqrt_nonneg _ + have hsqrtSquare : + Real.sqrt (fieldCard : ℝ) * Real.sqrt (fieldCard : ℝ) = fieldCard := + Real.mul_self_sqrt hfieldNonneg + calc + |(pointCount : ℝ) - fieldCard| ≤ + |(pointCount : ℝ)| + |(fieldCard : ℝ)| := abs_sub _ _ + _ = (pointCount : ℝ) + fieldCard := by + rw [abs_of_nonneg (by positivity), abs_of_nonneg hfieldNonneg] + _ ≤ (fieldCard : ℝ) * smallDegree + fieldCard := by gcongr + _ ≤ 2 * (fieldCard : ℝ) * smallDegree := by nlinarith + _ = 2 * (Real.sqrt (fieldCard : ℝ) * + Real.sqrt (fieldCard : ℝ)) * smallDegree := by rw [hsqrtSquare] + _ = (2 * Real.sqrt (fieldCard : ℝ) * smallDegree) * + Real.sqrt (fieldCard : ℝ) := by ring + _ ≤ (2 * Real.sqrt (fieldCard : ℝ) * smallDegree) * largeDegree := + mul_le_mul_of_nonneg_left hlarge (by positivity) + _ = 2 * Real.sqrt (fieldCard : ℝ) * smallDegree * largeDegree := by ring + +/-- In the small-degree branch, the explicit resultant bound for the +second-coordinate critical locus is already of Hasse--Weil scale. -/ +theorem criticalCount_le_two_mul_sqrt + (criticalCount fieldCard firstDegree secondDegree : ℕ) + (hcritical : criticalCount ≤ + ((2 * secondDegree - 1) * firstDegree) * secondDegree) + (hsecond : (secondDegree : ℝ) ≤ Real.sqrt (fieldCard : ℝ)) : + (criticalCount : ℝ) ≤ + 2 * Real.sqrt (fieldCard : ℝ) * firstDegree * secondDegree := by + have hcoarseNat : criticalCount ≤ + (2 * secondDegree * firstDegree) * secondDegree := by + calc + criticalCount ≤ ((2 * secondDegree - 1) * firstDegree) * secondDegree := + hcritical + _ ≤ (2 * secondDegree * firstDegree) * secondDegree := + Nat.mul_le_mul_right secondDegree + (Nat.mul_le_mul_right firstDegree (Nat.sub_le _ _)) + have hcoarse : (criticalCount : ℝ) ≤ + (2 * secondDegree * firstDegree) * secondDegree := by + exact_mod_cast hcoarseNat + calc + (criticalCount : ℝ) ≤ + (2 * secondDegree * firstDegree) * secondDegree := hcoarse + _ = (2 * firstDegree * secondDegree) * secondDegree := by ring + _ ≤ (2 * firstDegree * secondDegree) * + Real.sqrt (fieldCard : ℝ) := + mul_le_mul_of_nonneg_left hsecond (by positivity) + _ = 2 * Real.sqrt (fieldCard : ℝ) * firstDegree * secondDegree := by ring + +/-- The coarse zeta numerator degree budget is bounded by three times the +bidegree product, which is sufficient for a universal affine coefficient. -/ +theorem zetaDegree_mul_sqrt_le_three_mul_bidegree + (zetaDegree fieldCard firstDegree secondDegree : ℕ) + (hfirst : 0 < firstDegree) (hsecond : 0 < secondDegree) + (hdegree : zetaDegree ≤ + 2 * ((firstDegree - 1) * (secondDegree - 1)) + 1) : + (zetaDegree : ℝ) * Real.sqrt (fieldCard : ℝ) ≤ + 3 * Real.sqrt (fieldCard : ℝ) * firstDegree * secondDegree := by + have hbudget : (firstDegree - 1) * (secondDegree - 1) ≤ + firstDegree * secondDegree := + Nat.mul_le_mul (Nat.sub_le _ _) (Nat.sub_le _ _) + have hone : 1 ≤ firstDegree * secondDegree := Nat.mul_pos hfirst hsecond + have hdegreeCoarse : zetaDegree ≤ 3 * (firstDegree * secondDegree) := by + calc + zetaDegree ≤ 2 * ((firstDegree - 1) * (secondDegree - 1)) + 1 := hdegree + _ ≤ 2 * (firstDegree * secondDegree) + 1 := by omega + _ ≤ 3 * (firstDegree * secondDegree) := by omega + have hdegreeReal : (zetaDegree : ℝ) ≤ + 3 * (firstDegree * secondDegree : ℕ) := by exact_mod_cast hdegreeCoarse + have hsqrtNonneg : 0 ≤ Real.sqrt (fieldCard : ℝ) := Real.sqrt_nonneg _ + calc + (zetaDegree : ℝ) * Real.sqrt (fieldCard : ℝ) ≤ + (3 * (firstDegree * secondDegree : ℕ) : ℝ) * + Real.sqrt (fieldCard : ℝ) := + mul_le_mul_of_nonneg_right hdegreeReal hsqrtNonneg + _ = 3 * Real.sqrt (fieldCard : ℝ) * firstDegree * secondDegree := by + push_cast + ring + +/-- The constant affine/projective correction `1` is absorbed by the +square-root bidegree scale over every nontrivial finite field. -/ +theorem one_le_sqrt_mul_bidegree + (fieldCard firstDegree secondDegree : ℕ) + (hfield : 1 ≤ fieldCard) + (hfirst : 0 < firstDegree) (hsecond : 0 < secondDegree) : + (1 : ℝ) ≤ Real.sqrt (fieldCard : ℝ) * firstDegree * secondDegree := by + have hsqrt : (1 : ℝ) ≤ Real.sqrt (fieldCard : ℝ) := by + exact Real.one_le_sqrt.mpr (by exact_mod_cast hfield) + have hfirstReal : (1 : ℝ) ≤ firstDegree := by exact_mod_cast hfirst + have hsecondReal : (1 : ℝ) ≤ secondDegree := by exact_mod_cast hsecond + exact one_le_mul_of_one_le_of_one_le + (one_le_mul_of_one_le_of_one_le hsqrt hfirstReal) hsecondReal + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/PlaneAffineFiberBound.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/PlaneAffineFiberBound.lean new file mode 100644 index 0000000000..7cb768f830 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/PlaneAffineFiberBound.lean @@ -0,0 +1,167 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneSingularPointBound +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.TorsionBidegreeCount +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.TorsionPointNormalization + +/-! +# Elementary affine plane-curve fiber bounds + +For an irreducible plane curve with positive degree in one coordinate, every +fiber in that direction is cut out by a nonzero univariate polynomial. This +gives the two elementary bounds + +`#C(K) ≤ #K * degree_y(f)` and `#C(K) ≤ #K * degree_x(f)`. + +These estimates handle the large-bidegree branch of the final affine +Hasse--Weil theorem, where a trivial fiber count is stronger than carrying +normalization error terms. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +noncomputable section + +open BGS.CorvajaZannier + +variable {K : Type*} [Field K] [Fintype K] [DecidableEq K] + +/-- Affine points are the sigma type of their first coordinate and the roots +of the corresponding second-coordinate specialization. -/ +def affinePlaneCurvePointEquivSecondCoordinateRoots + (f : MvPolynomial (Fin 2) K) : + AffinePlaneCurvePoint f ≃ + Σ x : K, {y : K // (secondCoordinateSpecialization f x).eval y = 0} where + toFun z := ⟨z.1.1, ⟨z.1.2, by + rw [secondCoordinateSpecialization_eval] + exact z.2⟩⟩ + invFun z := ⟨(z.1, z.2.1), by + rw [← secondCoordinateSpecialization_eval] + exact z.2.2⟩ + left_inv z := by + apply Subtype.ext + rfl + right_inv z := by + cases z + rfl + +/-- Counting the roots in every first-coordinate fiber bounds all affine +points by the field cardinality times a second-coordinate degree bound. -/ +theorem affinePlaneCurvePoint_card_le_card_mul_of_degreeOf_second_le + {f : MvPolynomial (Fin 2) K} {secondDegree : ℕ} + (hf : Irreducible f) + (hsecond : 0 < MvPolynomial.degreeOf 1 f) + (hdegreeSecond : MvPolynomial.degreeOf 1 f ≤ secondDegree) : + Fintype.card (AffinePlaneCurvePoint f) ≤ + Fintype.card K * secondDegree := by + let roots := fun x : K => + {y : K // (secondCoordinateSpecialization f x).eval y = 0} + have hFiber (x : K) : Fintype.card (roots x) ≤ secondDegree := + (polynomialEvalZeroSubtype_card_le_natDegree + (secondCoordinateSpecialization f x) + (secondCoordinateSpecialization_ne_zero_of_irreducible hf hsecond x)).trans + ((secondCoordinateSpecialization_natDegree_le_degreeOf_second f x).trans + hdegreeSecond) + calc + Fintype.card (AffinePlaneCurvePoint f) = + Fintype.card (Σ x : K, roots x) := + Fintype.card_congr (affinePlaneCurvePointEquivSecondCoordinateRoots f) + _ = ∑ x : K, Fintype.card (roots x) := Fintype.card_sigma + _ ≤ ∑ _x : K, secondDegree := + Finset.sum_le_sum fun x _ => hFiber x + _ = Fintype.card K * secondDegree := by simp + +/-- Public bidegree form of the second-coordinate fiber bound. -/ +theorem affinePlaneCurvePoint_card_le_card_mul_secondDegree + {f : MvPolynomial (Fin 2) K} {firstDegree secondDegree : ℕ} + (hdegree : BGS.External.HasBidegreeAtMost f firstDegree secondDegree) + (hf : Irreducible f) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) : + Fintype.card (AffinePlaneCurvePoint f) ≤ + Fintype.card K * secondDegree := by + exact affinePlaneCurvePoint_card_le_card_mul_of_degreeOf_second_le + hf (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + (degreeOf_second_le_of_hasBidegreeAtMost hdegree) + +/-- Swapping the two affine coordinates identifies the point sets of `f` and +the coordinate-swapped polynomial. -/ +def affinePlaneCurvePointEquivSwap (f : MvPolynomial (Fin 2) K) : + AffinePlaneCurvePoint f ≃ + AffinePlaneCurvePoint (swapPlaneCurveCoordinates f) where + toFun z := ⟨(z.1.2, z.1.1), by + rw [eval_swapPlaneCurveCoordinates] + exact z.2⟩ + invFun z := ⟨(z.1.2, z.1.1), by + have hz := z.2 + rw [eval_swapPlaneCurveCoordinates] at hz + exact hz⟩ + left_inv z := by + apply Subtype.ext + rfl + right_inv z := by + apply Subtype.ext + rfl + +omit [Fintype K] [DecidableEq K] in +/-- Coordinate swapping preserves irreducibility. -/ +theorem irreducible_swapPlaneCurveCoordinates + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) : + Irreducible (swapPlaneCurveCoordinates f) := by + change Irreducible + (MvPolynomial.renameEquiv K (Equiv.swap (0 : Fin 2) 1) f) + exact hf.map (MvPolynomial.renameEquiv K (Equiv.swap (0 : Fin 2) 1)) + +omit [Fintype K] [DecidableEq K] in +/-- After swapping, the second-coordinate degree is the original +first-coordinate degree. -/ +theorem degreeOf_second_swapPlaneCurveCoordinates + (f : MvPolynomial (Fin 2) K) : + MvPolynomial.degreeOf 1 (swapPlaneCurveCoordinates f) = + MvPolynomial.degreeOf 0 f := by + change MvPolynomial.degreeOf 1 + (MvPolynomial.rename (Equiv.swap (0 : Fin 2) 1) f) = _ + simpa using + (MvPolynomial.degreeOf_rename_of_injective + (p := f) (Equiv.swap (0 : Fin 2) 1).injective (0 : Fin 2)) + +/-- Public bidegree form of the symmetric first-coordinate fiber bound. -/ +theorem affinePlaneCurvePoint_card_le_card_mul_firstDegree + {f : MvPolynomial (Fin 2) K} {firstDegree secondDegree : ℕ} + (hdegree : BGS.External.HasBidegreeAtMost f firstDegree secondDegree) + (hf : Irreducible f) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) : + Fintype.card (AffinePlaneCurvePoint f) ≤ + Fintype.card K * firstDegree := by + rw [Fintype.card_congr (affinePlaneCurvePointEquivSwap f)] + apply affinePlaneCurvePoint_card_le_card_mul_of_degreeOf_second_le + (irreducible_swapPlaneCurveCoordinates hf) + · rw [degreeOf_second_swapPlaneCurveCoordinates] + exact degreeOf_first_pos_of_pderiv_ne_zero hpartialFirst + · rw [degreeOf_second_swapPlaneCurveCoordinates] + exact degreeOf_first_le_of_hasBidegreeAtMost hdegree + +/-- The external finite-set presentation has the same cardinality as the +affine-point subtype used by the normalization development. -/ +def affinePlaneCurveZerosEquivAffinePlaneCurvePoint + (f : MvPolynomial (Fin 2) K) : + ↑(BGS.External.affinePlaneCurveZeros K f) ≃ AffinePlaneCurvePoint f := + Equiv.subtypeEquivRight fun _ => BGS.External.mem_affinePlaneCurveZeros_iff + +theorem affinePlaneCurveZeros_card_eq_affinePlaneCurvePoint_card + (f : MvPolynomial (Fin 2) K) : + (BGS.External.affinePlaneCurveZeros K f).card = + Fintype.card (AffinePlaneCurvePoint f) := by + rw [← Fintype.card_coe] + exact Fintype.card_congr (affinePlaneCurveZerosEquivAffinePlaneCurvePoint f) + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/PlaneAffineHasseWeilFromEvenError.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/PlaneAffineHasseWeilFromEvenError.lean new file mode 100644 index 0000000000..8dc54a0048 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/PlaneAffineHasseWeilFromEvenError.lean @@ -0,0 +1,303 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionHasseBoundFromEvenConstantExtensions +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneAffineHasseWeilFromZeta +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneConstantField +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneCurveGenusBoundAutomatic + +/-! +# Affine plane Hasse bounds from the even-extension error + +For a separating absolutely irreducible plane curve, exact constants and the +bidegree genus bound are already formalized. This file composes those facts +with the automatic zeta package and the two-sided affine/normalization +comparison. The sole remaining premise is therefore the even constant-field +extension error used by the spectral argument. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +open Filter Asymptotics +open BGS.CorvajaZannier + +noncomputable section + +/-- For a separating absolutely irreducible plane curve, the even-extension +error estimate implies the affine Hasse--Weil bound with coefficient `8`. + +The exact constant-field theorem, divisor index one, standard zeta +rationality, trace formula, numerator-degree budget, and intrinsic genus bound +are all discharged in the proof. -/ +theorem abs_affinePlaneCurveZeros_card_sub_card_le_eight_mul_bidegree_of_evenError + {K : Type*} [Field K] [Fintype K] [DecidableEq K] + {f : MvPolynomial (Fin 2) K} {firstDegree secondDegree : ℕ} + (hfirst : 0 < firstDegree) + (hsecond : 0 < secondDegree) + (hdegree : BGS.External.HasBidegreeAtMost + f firstDegree secondDegree) + (habsolute : Irreducible + (MvPolynomial.map (algebraMap K (AlgebraicClosure K)) f)) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) : + let hf : Irreducible f := + irreducible_of_irreducible_map_algebraicClosure habsolute + letI := planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let L := PlaneCurveFunctionField f + let ratAlg : Algebra (RatFunc K) L := + planeCurveFirstCoordinateRatFuncAlgebra f hx + letI : Algebra (RatFunc K) L := ratAlg + letI : SMul (RatFunc K) L := ratAlg.toSMul + letI : Module (RatFunc K) L := ratAlg.toModule + letI : FiniteDimensional (RatFunc K) L := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + letI : Algebra.IsSeparable (RatFunc K) L := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + letI : DecidableEq (RatFunc K) := Classical.decEq _ + ((fun n : ℕ ↦ + (finiteExtensionClosedPlaceExtensionCount K L (2 * n) : ℂ) - + (Nat.card K : ℂ) ^ (2 * n) - 1) =O[atTop] + fun n : ℕ ↦ (Nat.card K : ℝ) ^ n) → + |((BGS.External.affinePlaneCurveZeros K f).card : ℝ) - + (Fintype.card K : ℝ)| ≤ + 8 * Real.sqrt (Fintype.card K : ℝ) * + (firstDegree : ℝ) * (secondDegree : ℝ) := by + classical + let hf : Irreducible f := + irreducible_of_irreducible_map_algebraicClosure habsolute + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let L := PlaneCurveFunctionField f + let canonicalAlg : Algebra K L := inferInstance + let ratAlg : Algebra (RatFunc K) L := + planeCurveFirstCoordinateRatFuncAlgebra f hx + let : Algebra (RatFunc K) L := ratAlg + let : SMul (RatFunc K) L := ratAlg.toSMul + let : Module (RatFunc K) L := ratAlg.toModule + let : FiniteDimensional (RatFunc K) L := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : Algebra.IsSeparable (RatFunc K) L := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : DecidableEq (RatFunc K) := Classical.decEq _ + let inducedAlg : Algebra K L := bridgeBaseConstantAlgebra K L + have hinducedAlg : inducedAlg = canonicalAlg := by + apply Algebra.algebra_ext + intro c + change (@ratFuncSpecialization K L _ _ canonicalAlg + (planeCurveFunction f 0) hx) (RatFunc.C c) = + @algebraMap K L _ _ canonicalAlg c + have h := DFunLike.congr_fun + (@ratFuncSpecialization_comp_polynomial_algebraMap + K L _ _ canonicalAlg (planeCurveFunction f 0) hx) + (Polynomial.C c) + simpa using h + let : Algebra K L := inducedAlg + dsimp only + intro herror + let budget := (firstDegree - 1) * (secondDegree - 1) + have hExactCanonical : + @algebraicClosure K L _ _ canonicalAlg = + (⊥ : @IntermediateField K L _ _ canonicalAlg) := by + simpa only [L] using + planeCurveFunctionField_algebraicClosure_eq_bot + f habsolute hpartialSecond + have hExact : algebraicClosure K L = + (⊥ : IntermediateField K L) := by + change @algebraicClosure K L _ _ inducedAlg = + (⊥ : @IntermediateField K L _ _ inducedAlg) + rw [hinducedAlg] + exact hExactCanonical + have hgenusActualCanonical : + @FunctionField.genus K L _ _ canonicalAlg ≤ + planeCurveBidegreeGenusBudget f := by + simpa only [L] using + planeCurve_genus_le_bidegreeGenusBudget + habsolute hpartialFirst hpartialSecond + have hfirstDegree : MvPolynomial.degreeOf 0 f ≤ firstDegree := + degreeOf_first_le_of_hasBidegreeAtMost hdegree + have hsecondDegree : MvPolynomial.degreeOf 1 f ≤ secondDegree := + degreeOf_second_le_of_hasBidegreeAtMost hdegree + have hbudget : planeCurveBidegreeGenusBudget f ≤ budget := by + dsimp only [planeCurveBidegreeGenusBudget, budget] + exact Nat.mul_le_mul + (Nat.sub_le_sub_right hfirstDegree 1) + (Nat.sub_le_sub_right hsecondDegree 1) + have hgenusCanonical : + @FunctionField.genus K L _ _ canonicalAlg ≤ budget := + hgenusActualCanonical.trans hbudget + have hgenus : FunctionField.genus K L ≤ budget := by + change @FunctionField.genus K L _ _ inducedAlg ≤ budget + rw [hinducedAlg] + exact hgenusCanonical + have hhasse := + finiteExtensionClosedPlaceHasseBound_of_exactConstants_and_evenError + K L budget hExact hgenus herror + rw [finiteExtensionClosedPlaceExtensionCount_one_eq_rationalPlaceCount K L] + at hhasse + have hnormalization : + |(separatingPlaneCurveRationalPlaceCount f hf hpartialSecond : ℝ) - + (Fintype.card K : ℝ) - 1| ≤ + (2 * (budget : ℝ) + 1) * Real.sqrt (Fintype.card K : ℝ) := by + change + |(@finiteExtensionRationalPlaceCount K _ _ L _ ratAlg + (Classical.decEq (RatFunc K)) : ℝ) - + (Fintype.card K : ℝ) - 1| ≤ + (2 * (budget : ℝ) + 1) * Real.sqrt (Fintype.card K : ℝ) + simpa only [Fintype.card_eq_nat_card] using hhasse + rw [affinePlaneCurveZeros_card_eq_affinePlaneCurvePoint_card] + exact + abs_affinePlaneCurvePoint_card_sub_card_le_eight_mul_bidegree_of_rationalPlaceHasse + hdegree hf hpartialFirst hpartialSecond hfirst hsecond + (show 2 * budget + 1 ≤ + 2 * ((firstDegree - 1) * (secondDegree - 1)) + 1 by rfl) + (by simpa using hnormalization) + +/-- For a separating absolutely irreducible plane curve, a two-sided +constant-extension estimate along one fixed positive divisible-even +subsequence implies the affine Hasse--Weil bound with coefficient `8`. + +This is the plane-curve endpoint used by the selected Lorenzini route. No +estimate at extension degrees outside the subsequence `2 * δ * n` is needed. -/ +theorem + abs_affinePlaneCurveZeros_card_sub_card_le_eight_mul_bidegree_of_divisibleEvenError + {K : Type*} [Field K] [Fintype K] [DecidableEq K] + {f : MvPolynomial (Fin 2) K} {firstDegree secondDegree δ : ℕ} + (hfirst : 0 < firstDegree) + (hsecond : 0 < secondDegree) + (hdegree : BGS.External.HasBidegreeAtMost + f firstDegree secondDegree) + (habsolute : Irreducible + (MvPolynomial.map (algebraMap K (AlgebraicClosure K)) f)) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (hδ : 0 < δ) : + let hf : Irreducible f := + irreducible_of_irreducible_map_algebraicClosure habsolute + letI := planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let L := PlaneCurveFunctionField f + let ratAlg : Algebra (RatFunc K) L := + planeCurveFirstCoordinateRatFuncAlgebra f hx + letI : Algebra (RatFunc K) L := ratAlg + letI : SMul (RatFunc K) L := ratAlg.toSMul + letI : Module (RatFunc K) L := ratAlg.toModule + letI : FiniteDimensional (RatFunc K) L := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + letI : Algebra.IsSeparable (RatFunc K) L := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + letI : DecidableEq (RatFunc K) := Classical.decEq _ + ((fun n : ℕ ↦ + (finiteExtensionClosedPlaceExtensionCount K L (2 * δ * n) : ℂ) - + (Nat.card K : ℂ) ^ (2 * δ * n) - 1) =O[atTop] + fun n : ℕ ↦ ((Nat.card K : ℝ) ^ δ) ^ n) → + |((BGS.External.affinePlaneCurveZeros K f).card : ℝ) - + (Fintype.card K : ℝ)| ≤ + 8 * Real.sqrt (Fintype.card K : ℝ) * + (firstDegree : ℝ) * (secondDegree : ℝ) := by + classical + let hf : Irreducible f := + irreducible_of_irreducible_map_algebraicClosure habsolute + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let L := PlaneCurveFunctionField f + let canonicalAlg : Algebra K L := inferInstance + let ratAlg : Algebra (RatFunc K) L := + planeCurveFirstCoordinateRatFuncAlgebra f hx + let : Algebra (RatFunc K) L := ratAlg + let : SMul (RatFunc K) L := ratAlg.toSMul + let : Module (RatFunc K) L := ratAlg.toModule + let : FiniteDimensional (RatFunc K) L := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : Algebra.IsSeparable (RatFunc K) L := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : DecidableEq (RatFunc K) := Classical.decEq _ + let inducedAlg : Algebra K L := bridgeBaseConstantAlgebra K L + have hinducedAlg : inducedAlg = canonicalAlg := by + apply Algebra.algebra_ext + intro c + change (@ratFuncSpecialization K L _ _ canonicalAlg + (planeCurveFunction f 0) hx) (RatFunc.C c) = + @algebraMap K L _ _ canonicalAlg c + have h := DFunLike.congr_fun + (@ratFuncSpecialization_comp_polynomial_algebraMap + K L _ _ canonicalAlg (planeCurveFunction f 0) hx) + (Polynomial.C c) + simpa using h + let : Algebra K L := inducedAlg + dsimp only + intro herror + let budget := (firstDegree - 1) * (secondDegree - 1) + have hExactCanonical : + @algebraicClosure K L _ _ canonicalAlg = + (⊥ : @IntermediateField K L _ _ canonicalAlg) := by + simpa only [L] using + planeCurveFunctionField_algebraicClosure_eq_bot + f habsolute hpartialSecond + have hExact : algebraicClosure K L = + (⊥ : IntermediateField K L) := by + change @algebraicClosure K L _ _ inducedAlg = + (⊥ : @IntermediateField K L _ _ inducedAlg) + rw [hinducedAlg] + exact hExactCanonical + have hgenusActualCanonical : + @FunctionField.genus K L _ _ canonicalAlg ≤ + planeCurveBidegreeGenusBudget f := by + simpa only [L] using + planeCurve_genus_le_bidegreeGenusBudget + habsolute hpartialFirst hpartialSecond + have hfirstDegree : MvPolynomial.degreeOf 0 f ≤ firstDegree := + degreeOf_first_le_of_hasBidegreeAtMost hdegree + have hsecondDegree : MvPolynomial.degreeOf 1 f ≤ secondDegree := + degreeOf_second_le_of_hasBidegreeAtMost hdegree + have hbudget : planeCurveBidegreeGenusBudget f ≤ budget := by + dsimp only [planeCurveBidegreeGenusBudget, budget] + exact Nat.mul_le_mul + (Nat.sub_le_sub_right hfirstDegree 1) + (Nat.sub_le_sub_right hsecondDegree 1) + have hgenusCanonical : + @FunctionField.genus K L _ _ canonicalAlg ≤ budget := + hgenusActualCanonical.trans hbudget + have hgenus : FunctionField.genus K L ≤ budget := by + change @FunctionField.genus K L _ _ inducedAlg ≤ budget + rw [hinducedAlg] + exact hgenusCanonical + have hhasse := + finiteExtensionClosedPlaceHasseBound_of_exactConstants_and_divisibleEvenError + K L budget δ hExact hgenus hδ herror + rw [finiteExtensionClosedPlaceExtensionCount_one_eq_rationalPlaceCount K L] + at hhasse + have hnormalization : + |(separatingPlaneCurveRationalPlaceCount f hf hpartialSecond : ℝ) - + (Fintype.card K : ℝ) - 1| ≤ + (2 * (budget : ℝ) + 1) * Real.sqrt (Fintype.card K : ℝ) := by + change + |(@finiteExtensionRationalPlaceCount K _ _ L _ ratAlg + (Classical.decEq (RatFunc K)) : ℝ) - + (Fintype.card K : ℝ) - 1| ≤ + (2 * (budget : ℝ) + 1) * Real.sqrt (Fintype.card K : ℝ) + simpa only [Fintype.card_eq_nat_card] using hhasse + rw [affinePlaneCurveZeros_card_eq_affinePlaneCurvePoint_card] + exact + abs_affinePlaneCurvePoint_card_sub_card_le_eight_mul_bidegree_of_rationalPlaceHasse + hdegree hf hpartialFirst hpartialSecond hfirst hsecond + (show 2 * budget + 1 ≤ + 2 * ((firstDegree - 1) * (secondDegree - 1)) + 1 by rfl) + (by simpa using hnormalization) + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/PlaneAffineHasseWeilFromZeta.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/PlaneAffineHasseWeilFromZeta.lean new file mode 100644 index 0000000000..396f550668 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/PlaneAffineHasseWeilFromZeta.lean @@ -0,0 +1,402 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionStandardZetaRationality +public import LeanPool.MarkoffModP.BGS.HasseWeil.FormalZetaHasseBound +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneAffineCountTransfer +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneAffineFiberBound +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneAffineRationalPlaceComparison +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneRationalPlaceAffineComparison +public import Mathlib.Tactic + +/-! +# Affine plane Hasse bounds from the standard zeta package + +This module composes the two-sided affine/normalization comparison with the +formal zeta Hasse bound. In the separating-coordinate case it gives the +external affine-plane estimate with the explicit universal coefficient `8`. + +The final theorem retains only the standard zeta numerator package and its +even-extension square-root estimate. Constructing those data, and removing +the separating-coordinate restriction without losing the original bidegree +scale, remain separate upstream tasks. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +noncomputable section + +open BGS.CorvajaZannier +open Filter Asymptotics + + +section ClosedPlaceLevelOne + +variable (K : Type*) [Field K] [Fintype K] [DecidableEq K] + [DecidableEq (RatFunc K)] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +/-- At extension level one, the closed-place point count is exactly the +number of degree-one places. -/ +theorem finiteExtensionClosedPlaceExtensionCount_one_eq_rationalPlaceCount : + finiteExtensionClosedPlaceExtensionCount K L 1 = + finiteExtensionRationalPlaceCount K L := by + classical + let := finiteExtensionPlaceDegreeLEFintype K L 1 + rw [finiteExtensionClosedPlaceExtensionCount] + have hdegree : ∀ P : {P : FiniteExtensionPlace K L // + finiteExtensionPlaceDegree K L P ≤ 1}, + finiteExtensionPlaceDegree K L P.1 = 1 := by + intro P + have hpos := finiteExtensionPlaceDegree_pos K L P.1 + omega + simp_rw [hdegree] + simp only [dvd_refl, ↓reduceIte, Finset.sum_const, Finset.card_univ, + nsmul_eq_mul, mul_one] + rw [finiteExtensionRationalPlaceCount_eq_natCard_subtype] + let e : {P : FiniteExtensionPlace K L // + finiteExtensionPlaceDegree K L P ≤ 1} ≃ + {P : FiniteExtensionPlace K L // + finiteExtensionPlaceDegree K L P = 1} := + { toFun := fun P => ⟨P.1, hdegree P⟩ + invFun := fun P => ⟨P.1, P.2.le⟩ + left_inv := by intro P; cases P; rfl + right_inv := by intro P; cases P; rfl } + calc + ↑(Fintype.card {P : FiniteExtensionPlace K L // + finiteExtensionPlaceDegree K L P ≤ 1}) = + Nat.card {P : FiniteExtensionPlace K L // + finiteExtensionPlaceDegree K L P ≤ 1} := by + rw [Nat.card_eq_fintype_card] + _ = Nat.card {P : FiniteExtensionPlace K L // + finiteExtensionPlaceDegree K L P = 1} := Nat.card_congr e + +end ClosedPlaceLevelOne + +section FunctionFieldZeta + +variable (K : Type*) [Field K] [Fintype K] [DecidableEq K] + [DecidableEq (RatFunc K)] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +local instance affineHasseZetaConstantAlgebra : Algebra K L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K (RatFunc K))) + +local instance affineHasseZetaConstantTower : IsScalarTower K (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + +/-- Exact constants, divisor index one, a genus budget, and the even-extension +square-root estimate give the corresponding rational-place Hasse bound. -/ +theorem abs_finiteExtensionRationalPlaceCount_sub_card_sub_one_le_of_index_one_and_evenError_isBigO + (budget : ℕ) + (hconstants : algebraicClosure K L = + (⊥ : IntermediateField K L)) + (hindex : finiteExtensionDivisorDegreeIndex K L = 1) + (hgenus : FunctionField.genus K L ≤ budget) + (herror : + (fun n : ℕ ↦ + (finiteExtensionClosedPlaceExtensionCount K L (2 * n) : ℂ) - + (Fintype.card K : ℂ) ^ (2 * n) - 1) =O[atTop] + fun n : ℕ ↦ (Fintype.card K : ℝ) ^ n) : + |(finiteExtensionRationalPlaceCount K L : ℝ) - + (Fintype.card K : ℝ) - 1| ≤ + ((2 * budget + 1 : ℕ) : ℝ) * + Real.sqrt (Fintype.card K : ℝ) := by + obtain ⟨P, hPzero, _hPone, hPdegree, hPform, _hPtrace⟩ := + exists_finiteExtensionClosedPlaceZeta_trace_with_degree_budget + K L budget hconstants hindex hgenus + have herror' : + (fun n : ℕ ↦ + (finiteExtensionClosedPlaceExtensionCount K L (2 * n) : ℂ) - + (Nat.card K : ℂ) ^ (2 * n) - 1) =O[atTop] + fun n : ℕ ↦ (Nat.card K : ℝ) ^ n := by + simpa only [Fintype.card_eq_nat_card] using herror + have hhasse := + abs_pointCount_sub_card_sub_one_le_of_formalPointCountZeta_rational_and_evenError_isBigO + (Nat.card K) (finiteExtensionClosedPlaceExtensionCount K L) + P hPzero hPform herror' + rw [finiteExtensionClosedPlaceExtensionCount_one_eq_rationalPlaceCount K L] + at hhasse + simpa only [Fintype.card_eq_nat_card] using hhasse.trans (by + have hdegreeReal : (P.natDegree : ℝ) ≤ (2 * budget + 1 : ℕ) := by + exact_mod_cast hPdegree + exact mul_le_mul_of_nonneg_right hdegreeReal (Real.sqrt_nonneg _)) + +end FunctionFieldZeta + +/-- The rational-place count of a separating plane model, with all +projection-dependent instances packaged into a stable natural number. -/ +def separatingPlaneCurveRationalPlaceCount + {K : Type*} [Field K] [Fintype K] [DecidableEq K] + (f : MvPolynomial (Fin 2) K) (hf : Irreducible f) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) : ℕ := + letI := planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + letI := planeCurveFirstCoordinateRatFuncAlgebra f hx + letI : Algebra (Polynomial K) (PlaneCurveFunctionField f) := + RingHom.toAlgebra + ((algebraMap (RatFunc K) (PlaneCurveFunctionField f)).comp + (algebraMap (Polynomial K) (RatFunc K))) + letI : IsScalarTower (Polynomial K) (RatFunc K) + (PlaneCurveFunctionField f) := IsScalarTower.of_algebraMap_eq' rfl + letI : FiniteDimensional (RatFunc K) (PlaneCurveFunctionField f) := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + letI : Algebra.IsSeparable (RatFunc K) (PlaneCurveFunctionField f) := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + letI : DecidableEq (RatFunc K) := Classical.decEq _ + finiteExtensionRationalPlaceCount K (PlaneCurveFunctionField f) + +section AffineTransfer + +variable {K : Type*} [Field K] [Fintype K] [DecidableEq K] + +/-- A rational-place Hasse estimate with the standard bidegree numerator +budget transfers to the affine plane count with universal coefficient `8`. + +The large-`secondDegree` branch uses the elementary first-coordinate fiber +bound. In the small branch the new reverse comparison and the existing +forward critical-locus comparison give a common error bounded by four +square-root bidegree units; the zeta term costs three and the affine/projective +constant costs one. -/ +theorem abs_affinePlaneCurvePoint_card_sub_card_le_eight_mul_bidegree_of_rationalPlaceHasse + {f : MvPolynomial (Fin 2) K} + {firstDegree secondDegree zetaDegree : ℕ} + (hdegree : BGS.External.HasBidegreeAtMost + f firstDegree secondDegree) + (hf : Irreducible f) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (hfirst : 0 < firstDegree) + (hsecond : 0 < secondDegree) + (hzetaDegree : zetaDegree ≤ + 2 * ((firstDegree - 1) * (secondDegree - 1)) + 1) + (hnormalization : + |(separatingPlaneCurveRationalPlaceCount + f hf hpartialSecond : ℝ) - + (Fintype.card K : ℝ) - 1| ≤ + (zetaDegree : ℝ) * Real.sqrt (Fintype.card K : ℝ)) : + |(Fintype.card (AffinePlaneCurvePoint f) : ℝ) - + (Fintype.card K : ℝ)| ≤ + 8 * Real.sqrt (Fintype.card K : ℝ) * + (firstDegree : ℝ) * (secondDegree : ℝ) := by + classical + by_cases hlarge : Real.sqrt (Fintype.card K : ℝ) ≤ secondDegree + · have hcount := affinePlaneCurvePoint_card_le_card_mul_firstDegree + hdegree hf hpartialFirst + exact (abs_pointCount_sub_card_le_two_mul_sqrt_of_fiber_bound + (Fintype.card (AffinePlaneCurvePoint f)) (Fintype.card K) + firstDegree secondDegree hfirst hcount hlarge).trans (by + have hscale : 0 ≤ Real.sqrt (Fintype.card K : ℝ) * + (firstDegree : ℝ) * (secondDegree : ℝ) := by positivity + nlinarith) + · have hsecondSmall : (secondDegree : ℝ) ≤ + Real.sqrt (Fintype.card K : ℝ) := (lt_of_not_ge hlarge).le + let error := + (firstDegree + (2 * secondDegree - 1) * firstDegree) * + secondDegree + secondDegree + have hcritical := affineSecondCoordinateCriticalPoints_card_le + hdegree hf hpartialSecond + have hupperRaw : Fintype.card (AffinePlaneCurvePoint f) ≤ + separatingPlaneCurveRationalPlaceCount f hf hpartialSecond + + (affineSecondCoordinateCriticalPoints K f).card := by + simpa only [separatingPlaneCurveRationalPlaceCount] using + affinePlaneCurvePoint_card_le_rationalPlaceCount_add_critical + hf hpartialFirst hpartialSecond + have hupper : Fintype.card (AffinePlaneCurvePoint f) ≤ + separatingPlaneCurveRationalPlaceCount f hf hpartialSecond + + error := by + apply hupperRaw.trans + apply Nat.add_le_add_left + dsimp only [error] + calc + (affineSecondCoordinateCriticalPoints K f).card ≤ + ((2 * secondDegree - 1) * firstDegree) * secondDegree := hcritical + _ ≤ (firstDegree + (2 * secondDegree - 1) * firstDegree) * + secondDegree := Nat.mul_le_mul_right secondDegree + (Nat.le_add_left _ _) + _ ≤ (firstDegree + (2 * secondDegree - 1) * firstDegree) * + secondDegree + secondDegree := Nat.le_add_right _ _ + have hlower : + separatingPlaneCurveRationalPlaceCount f hf hpartialSecond ≤ + Fintype.card (AffinePlaneCurvePoint f) + error := by + simpa only [separatingPlaneCurveRationalPlaceCount, error, + Nat.add_assoc] using + finiteExtensionRationalPlaceCount_le_affine_add_exceptional + hdegree hf hpartialSecond + have htransfer := abs_affine_sub_card_le_of_two_sided_count_comparison + (Fintype.card (AffinePlaneCurvePoint f)) + (separatingPlaneCurveRationalPlaceCount f hf hpartialSecond) + (Fintype.card K) error hupper hlower + ((zetaDegree : ℝ) * Real.sqrt (Fintype.card K : ℝ)) hnormalization + apply htransfer.trans + have hzeta := zetaDegree_mul_sqrt_le_three_mul_bidegree + zetaDegree (Fintype.card K) firstDegree secondDegree + hfirst hsecond hzetaDegree + have hfield : 1 ≤ Fintype.card K := + (Fintype.one_lt_card : 1 < Fintype.card K).le + have hone := one_le_sqrt_mul_bidegree + (Fintype.card K) firstDegree secondDegree hfield hfirst hsecond + have herror : (error : ℝ) ≤ + 4 * Real.sqrt (Fintype.card K : ℝ) * + (firstDegree : ℝ) * (secondDegree : ℝ) := by + dsimp only [error] + push_cast + have hfirstReal : (1 : ℝ) ≤ firstDegree := by exact_mod_cast hfirst + have hsecondReal : (1 : ℝ) ≤ secondDegree := by exact_mod_cast hsecond + have hsqrt : (1 : ℝ) ≤ Real.sqrt (Fintype.card K : ℝ) := + Real.one_le_sqrt.mpr (by exact_mod_cast hfield) + have hsub : ((2 * secondDegree - 1 : ℕ) : ℝ) ≤ + 2 * (secondDegree : ℝ) := by + exact_mod_cast Nat.sub_le (2 * secondDegree) 1 + have hterm1 : (firstDegree : ℝ) * secondDegree ≤ + Real.sqrt (Fintype.card K : ℝ) * firstDegree * secondDegree := by + have hxle : (firstDegree : ℝ) ≤ + Real.sqrt (Fintype.card K : ℝ) * firstDegree := by + simpa only [one_mul] using + mul_le_mul_of_nonneg_right hsqrt + (by positivity : (0 : ℝ) ≤ firstDegree) + exact mul_le_mul_of_nonneg_right hxle (by positivity) + have hterm2 : 2 * (firstDegree : ℝ) * secondDegree * secondDegree ≤ + 2 * Real.sqrt (Fintype.card K : ℝ) * firstDegree * secondDegree := by + have hmul := mul_le_mul_of_nonneg_left hsecondSmall + (show (0 : ℝ) ≤ 2 * firstDegree * secondDegree by positivity) + nlinarith + have hterm3 : (secondDegree : ℝ) ≤ + Real.sqrt (Fintype.card K : ℝ) * firstDegree * secondDegree := by + have honeProduct : (1 : ℝ) ≤ + Real.sqrt (Fintype.card K : ℝ) * firstDegree := + one_le_mul_of_one_le_of_one_le hsqrt hfirstReal + simpa only [one_mul] using + mul_le_mul_of_nonneg_right honeProduct + (show (0 : ℝ) ≤ secondDegree by positivity) + calc + ((firstDegree : ℝ) + ↑(2 * secondDegree - 1) * firstDegree) * + secondDegree + secondDegree ≤ + (firstDegree + 2 * secondDegree * firstDegree) * + secondDegree + secondDegree := by gcongr + _ = (firstDegree : ℝ) * secondDegree + + 2 * firstDegree * secondDegree * secondDegree + secondDegree := by + ring + _ ≤ Real.sqrt (Fintype.card K : ℝ) * firstDegree * secondDegree + + 2 * Real.sqrt (Fintype.card K : ℝ) * firstDegree * secondDegree + + Real.sqrt (Fintype.card K : ℝ) * firstDegree * secondDegree := by + exact add_le_add (add_le_add hterm1 hterm2) hterm3 + _ = 4 * Real.sqrt (Fintype.card K : ℝ) * firstDegree * secondDegree := by + ring + nlinarith + +end AffineTransfer + +section PlaneZetaComposition + +/-- Standard zeta rationality and the even-extension square-root estimate +imply the exact affine-plane shape required by +`GeneralBivariateAffineHasseWeilTheorem`, with coefficient `8`, whenever both +coordinate projections are separating. + +The conclusion is stated using the external finite-set presentation. Thus +the remaining gap to the unrestricted external proposition is explicit: the +two partial-derivative hypotheses and the upstream zeta package. -/ +theorem abs_affinePlaneCurveZeros_card_sub_card_le_eight_mul_bidegree_of_standardZeta + {K : Type*} [Field K] [Fintype K] [DecidableEq K] + {f : MvPolynomial (Fin 2) K} {firstDegree secondDegree : ℕ} + (hfirst : 0 < firstDegree) + (hsecond : 0 < secondDegree) + (hdegree : BGS.External.HasBidegreeAtMost + f firstDegree secondDegree) + (habsolute : Irreducible + (MvPolynomial.map (algebraMap K (AlgebraicClosure K)) f)) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (P : Polynomial ℂ) + (hPzero : P.coeff 0 = 1) + (hPdegree : P.natDegree ≤ + 2 * ((firstDegree - 1) * (secondDegree - 1)) + 1) : + let hf : Irreducible f := + irreducible_of_irreducible_map_algebraicClosure habsolute + letI := planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let L := PlaneCurveFunctionField f + let ratAlg : Algebra (RatFunc K) L := + planeCurveFirstCoordinateRatFuncAlgebra f hx + letI : Algebra (RatFunc K) L := ratAlg + letI : SMul (RatFunc K) L := ratAlg.toSMul + letI : Module (RatFunc K) L := ratAlg.toModule + letI : FiniteDimensional (RatFunc K) L := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + letI : Algebra.IsSeparable (RatFunc K) L := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + letI : DecidableEq (RatFunc K) := Classical.decEq _ + HasCurveZetaRationalForm + (formalPointCountZeta + (finiteExtensionClosedPlaceExtensionCount K L)) + (Nat.card K) P → + ((fun n : ℕ ↦ + (finiteExtensionClosedPlaceExtensionCount K L (2 * n) : ℂ) - + (Nat.card K : ℂ) ^ (2 * n) - 1) =O[atTop] + fun n : ℕ ↦ (Nat.card K : ℝ) ^ n) → + |((BGS.External.affinePlaneCurveZeros K f).card : ℝ) - + (Fintype.card K : ℝ)| ≤ + 8 * Real.sqrt (Fintype.card K : ℝ) * + (firstDegree : ℝ) * (secondDegree : ℝ) := by + classical + let hf : Irreducible f := + irreducible_of_irreducible_map_algebraicClosure habsolute + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let L := PlaneCurveFunctionField f + let ratAlg : Algebra (RatFunc K) L := + planeCurveFirstCoordinateRatFuncAlgebra f hx + let : Algebra (RatFunc K) L := ratAlg + let : SMul (RatFunc K) L := ratAlg.toSMul + let : Module (RatFunc K) L := ratAlg.toModule + let : FiniteDimensional (RatFunc K) L := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : Algebra.IsSeparable (RatFunc K) L := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : DecidableEq (RatFunc K) := Classical.decEq _ + dsimp only + intro hPform herror + have hhasse := + abs_pointCount_sub_card_sub_one_le_of_formalPointCountZeta_rational_and_evenError_isBigO + (Nat.card K) (finiteExtensionClosedPlaceExtensionCount K L) + P hPzero hPform herror + rw [finiteExtensionClosedPlaceExtensionCount_one_eq_rationalPlaceCount K L] + at hhasse + have hnormalization : + |(separatingPlaneCurveRationalPlaceCount f hf hpartialSecond : ℝ) - + (Fintype.card K : ℝ) - 1| ≤ + (P.natDegree : ℝ) * Real.sqrt (Fintype.card K : ℝ) := by + change + |(@finiteExtensionRationalPlaceCount K _ _ L _ ratAlg + (Classical.decEq (RatFunc K)) : ℝ) - + (Fintype.card K : ℝ) - 1| ≤ + (P.natDegree : ℝ) * Real.sqrt (Fintype.card K : ℝ) + simpa only [Fintype.card_eq_nat_card] using hhasse + rw [affinePlaneCurveZeros_card_eq_affinePlaneCurvePoint_card] + exact + abs_affinePlaneCurvePoint_card_sub_card_le_eight_mul_bidegree_of_rationalPlaceHasse + hdegree hf hpartialFirst hpartialSecond hfirst hsecond hPdegree + hnormalization + +end PlaneZetaComposition + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/PlaneAffineRationalPlaceComparison.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/PlaneAffineRationalPlaceComparison.lean new file mode 100644 index 0000000000..96c0383ddb --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/PlaneAffineRationalPlaceComparison.lean @@ -0,0 +1,301 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneRegularPointCount +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneSmoothPointNormalization +public import LeanPool.MarkoffModP.BGS.HasseWeil.RationalPlace +public import Mathlib.Tactic + +/-! +# Affine plane points and rational normalization places + +For an irreducible plane curve with both coordinates separating, every affine +point that is regular in the second-coordinate direction determines a +degree-one finite place of the function field. Distinct regular affine points +give distinct places. Consequently the regular affine locus injects into the +rational finite places, and adding the explicit critical locus compares all +affine rational points with the full rational-place count. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +open BGS.CorvajaZannier + +noncomputable section + + +variable {K : Type*} [Field K] [Fintype K] [DecidableEq K] +variable {f : MvPolynomial (Fin 2) K} + +/-- Send a second-coordinate regular affine point to its selected degree-one +finite normalization place. -/ +def affineSecondCoordinateRegularPointToRationalFinitePlace + (hf : Irreducible f) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (z : AffineSecondCoordinateRegularPoint f) : + letI := planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + letI := planeCurveFirstCoordinateRatFuncAlgebra f hx + letI : Algebra (Polynomial K) (PlaneCurveFunctionField f) := + RingHom.toAlgebra + ((algebraMap (RatFunc K) (PlaneCurveFunctionField f)).comp + (algebraMap (Polynomial K) (RatFunc K))) + letI : IsScalarTower (Polynomial K) (RatFunc K) + (PlaneCurveFunctionField f) := + IsScalarTower.of_algebraMap_eq' rfl + letI : FiniteDimensional (RatFunc K) (PlaneCurveFunctionField f) := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + letI : Algebra.IsSeparable (RatFunc K) (PlaneCurveFunctionField f) := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + letI : DecidableEq (RatFunc K) := Classical.decEq _ + FiniteExtensionRationalFinitePlace K (PlaneCurveFunctionField f) := by + letI : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + letI : Algebra (RatFunc K) (PlaneCurveFunctionField f) := + planeCurveFirstCoordinateRatFuncAlgebra f hx + letI : Algebra (Polynomial K) (PlaneCurveFunctionField f) := + RingHom.toAlgebra + ((algebraMap (RatFunc K) (PlaneCurveFunctionField f)).comp + (algebraMap (Polynomial K) (RatFunc K))) + letI : IsScalarTower (Polynomial K) (RatFunc K) + (PlaneCurveFunctionField f) := + IsScalarTower.of_algebraMap_eq' rfl + letI : FiniteDimensional (RatFunc K) (PlaneCurveFunctionField f) := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + letI : Algebra.IsSeparable (RatFunc K) (PlaneCurveFunctionField f) := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + letI : DecidableEq (RatFunc K) := Classical.decEq _ + exact ⟨affinePointExhaustiveFinitePlace + hf hpartialFirst hpartialSecond z.1, + affinePointExhaustiveFinitePlace_degree_eq_one_of_partialY + K hf hpartialFirst hpartialSecond z.1 z.2⟩ + +/-- Distinct second-coordinate regular affine points determine distinct +degree-one finite normalization places. -/ +theorem affineSecondCoordinateRegularPointToRationalFinitePlace_injective + (hf : Irreducible f) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) : + letI := planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + letI := planeCurveFirstCoordinateRatFuncAlgebra f hx + letI : Algebra (Polynomial K) (PlaneCurveFunctionField f) := + RingHom.toAlgebra + ((algebraMap (RatFunc K) (PlaneCurveFunctionField f)).comp + (algebraMap (Polynomial K) (RatFunc K))) + letI : IsScalarTower (Polynomial K) (RatFunc K) + (PlaneCurveFunctionField f) := + IsScalarTower.of_algebraMap_eq' rfl + letI : FiniteDimensional (RatFunc K) (PlaneCurveFunctionField f) := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + letI : Algebra.IsSeparable (RatFunc K) (PlaneCurveFunctionField f) := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + letI : DecidableEq (RatFunc K) := Classical.decEq _ + Function.Injective + (affineSecondCoordinateRegularPointToRationalFinitePlace + hf hpartialFirst hpartialSecond) := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let : Algebra (RatFunc K) (PlaneCurveFunctionField f) := + planeCurveFirstCoordinateRatFuncAlgebra f hx + let : Algebra (Polynomial K) (PlaneCurveFunctionField f) := + RingHom.toAlgebra + ((algebraMap (RatFunc K) (PlaneCurveFunctionField f)).comp + (algebraMap (Polynomial K) (RatFunc K))) + let : IsScalarTower (Polynomial K) (RatFunc K) + (PlaneCurveFunctionField f) := + IsScalarTower.of_algebraMap_eq' rfl + let : FiniteDimensional (RatFunc K) (PlaneCurveFunctionField f) := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : Algebra.IsSeparable (RatFunc K) (PlaneCurveFunctionField f) := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : DecidableEq (RatFunc K) := Classical.decEq _ + dsimp only + intro z w hzw + apply Subtype.ext + apply affinePointExhaustiveFinitePlace_injective + hf hpartialFirst hpartialSecond + exact congrArg Subtype.val hzw + +/-- The regular affine locus has cardinality at most the number of degree-one +finite places. -/ +theorem affineSecondCoordinateRegularPoint_card_le_rationalFinitePlace + (hf : Irreducible f) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) : + letI := planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + letI := planeCurveFirstCoordinateRatFuncAlgebra f hx + letI : Algebra (Polynomial K) (PlaneCurveFunctionField f) := + RingHom.toAlgebra + ((algebraMap (RatFunc K) (PlaneCurveFunctionField f)).comp + (algebraMap (Polynomial K) (RatFunc K))) + letI : IsScalarTower (Polynomial K) (RatFunc K) + (PlaneCurveFunctionField f) := + IsScalarTower.of_algebraMap_eq' rfl + letI : FiniteDimensional (RatFunc K) (PlaneCurveFunctionField f) := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + letI : Algebra.IsSeparable (RatFunc K) (PlaneCurveFunctionField f) := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + letI : DecidableEq (RatFunc K) := Classical.decEq _ + Fintype.card (AffineSecondCoordinateRegularPoint f) ≤ + Nat.card (FiniteExtensionRationalFinitePlace K + (PlaneCurveFunctionField f)) := by + classical + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let : Algebra (RatFunc K) (PlaneCurveFunctionField f) := + planeCurveFirstCoordinateRatFuncAlgebra f hx + let : Algebra (Polynomial K) (PlaneCurveFunctionField f) := + RingHom.toAlgebra + ((algebraMap (RatFunc K) (PlaneCurveFunctionField f)).comp + (algebraMap (Polynomial K) (RatFunc K))) + let : IsScalarTower (Polynomial K) (RatFunc K) + (PlaneCurveFunctionField f) := + IsScalarTower.of_algebraMap_eq' rfl + let : FiniteDimensional (RatFunc K) (PlaneCurveFunctionField f) := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : Algebra.IsSeparable (RatFunc K) (PlaneCurveFunctionField f) := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : DecidableEq (RatFunc K) := Classical.decEq _ + dsimp only + let toPlace := affineSecondCoordinateRegularPointToRationalFinitePlace + hf hpartialFirst hpartialSecond + have hcard := Nat.card_le_card_of_injective toPlace + (affineSecondCoordinateRegularPointToRationalFinitePlace_injective + hf hpartialFirst hpartialSecond) + simpa only [Nat.card_eq_fintype_card] using hcard + +/-- The regular affine locus has cardinality at most the total rational-place +count, which also includes places above infinity. -/ +theorem affineSecondCoordinateRegularPoint_card_le_rationalPlaceCount + (hf : Irreducible f) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) : + letI := planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + letI := planeCurveFirstCoordinateRatFuncAlgebra f hx + letI : Algebra (Polynomial K) (PlaneCurveFunctionField f) := + RingHom.toAlgebra + ((algebraMap (RatFunc K) (PlaneCurveFunctionField f)).comp + (algebraMap (Polynomial K) (RatFunc K))) + letI : IsScalarTower (Polynomial K) (RatFunc K) + (PlaneCurveFunctionField f) := + IsScalarTower.of_algebraMap_eq' rfl + letI : FiniteDimensional (RatFunc K) (PlaneCurveFunctionField f) := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + letI : Algebra.IsSeparable (RatFunc K) (PlaneCurveFunctionField f) := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + letI : DecidableEq (RatFunc K) := Classical.decEq _ + Fintype.card (AffineSecondCoordinateRegularPoint f) ≤ + finiteExtensionRationalPlaceCount K (PlaneCurveFunctionField f) := by + classical + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let : Algebra (RatFunc K) (PlaneCurveFunctionField f) := + planeCurveFirstCoordinateRatFuncAlgebra f hx + let : Algebra (Polynomial K) (PlaneCurveFunctionField f) := + RingHom.toAlgebra + ((algebraMap (RatFunc K) (PlaneCurveFunctionField f)).comp + (algebraMap (Polynomial K) (RatFunc K))) + let : IsScalarTower (Polynomial K) (RatFunc K) + (PlaneCurveFunctionField f) := + IsScalarTower.of_algebraMap_eq' rfl + let : FiniteDimensional (RatFunc K) (PlaneCurveFunctionField f) := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : Algebra.IsSeparable (RatFunc K) (PlaneCurveFunctionField f) := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : DecidableEq (RatFunc K) := Classical.decEq _ + dsimp only + calc + Fintype.card (AffineSecondCoordinateRegularPoint f) ≤ + Nat.card (FiniteExtensionRationalFinitePlace K + (PlaneCurveFunctionField f)) := + affineSecondCoordinateRegularPoint_card_le_rationalFinitePlace + hf hpartialFirst hpartialSecond + _ ≤ Nat.card (FiniteExtensionRationalPlace K + (PlaneCurveFunctionField f)) := + Nat.card_le_card_of_injective + (fun Q : FiniteExtensionRationalFinitePlace K + (PlaneCurveFunctionField f) => + (Sum.inl Q : FiniteExtensionRationalPlace K + (PlaneCurveFunctionField f))) + Sum.inl_injective + _ = finiteExtensionRationalPlaceCount K + (PlaneCurveFunctionField f) := rfl + +/-- The first affine-normalization comparison: all affine rational points are +bounded by the rational places of the normalization plus the explicit +second-coordinate critical locus. -/ +theorem affinePlaneCurvePoint_card_le_rationalPlaceCount_add_critical + (hf : Irreducible f) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) : + letI := planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + letI := planeCurveFirstCoordinateRatFuncAlgebra f hx + letI : Algebra (Polynomial K) (PlaneCurveFunctionField f) := + RingHom.toAlgebra + ((algebraMap (RatFunc K) (PlaneCurveFunctionField f)).comp + (algebraMap (Polynomial K) (RatFunc K))) + letI : IsScalarTower (Polynomial K) (RatFunc K) + (PlaneCurveFunctionField f) := + IsScalarTower.of_algebraMap_eq' rfl + letI : FiniteDimensional (RatFunc K) (PlaneCurveFunctionField f) := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + letI : Algebra.IsSeparable (RatFunc K) (PlaneCurveFunctionField f) := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + letI : DecidableEq (RatFunc K) := Classical.decEq _ + Fintype.card (AffinePlaneCurvePoint f) ≤ + finiteExtensionRationalPlaceCount K (PlaneCurveFunctionField f) + + (affineSecondCoordinateCriticalPoints K f).card := by + classical + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let : Algebra (RatFunc K) (PlaneCurveFunctionField f) := + planeCurveFirstCoordinateRatFuncAlgebra f hx + let : Algebra (Polynomial K) (PlaneCurveFunctionField f) := + RingHom.toAlgebra + ((algebraMap (RatFunc K) (PlaneCurveFunctionField f)).comp + (algebraMap (Polynomial K) (RatFunc K))) + let : IsScalarTower (Polynomial K) (RatFunc K) + (PlaneCurveFunctionField f) := + IsScalarTower.of_algebraMap_eq' rfl + let : FiniteDimensional (RatFunc K) (PlaneCurveFunctionField f) := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : Algebra.IsSeparable (RatFunc K) (PlaneCurveFunctionField f) := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : DecidableEq (RatFunc K) := Classical.decEq _ + dsimp only + rw [affinePlaneCurvePoint_card_eq_regular_add_critical f] + exact Nat.add_le_add_right + (affineSecondCoordinateRegularPoint_card_le_rationalPlaceCount + hf hpartialFirst hpartialSecond) + (affineSecondCoordinateCriticalPoints K f).card + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/PlaneConstantField.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/PlaneConstantField.lean new file mode 100644 index 0000000000..da10416f8b --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/PlaneConstantField.lean @@ -0,0 +1,391 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PoweredImageBaseChange +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveBidegreeBridge +public import Mathlib.FieldTheory.RatFunc.Luroth + +/-! +# Constants in an absolutely irreducible plane-curve function field + +This file develops the constant-field step needed by the function-field +Bombieri--Stepanov proof of Hasse--Weil. The key algebraic point is that, +after enlarging the constants inside the original function field, the +base-changed plane equation is still the primitive cleared minimal relation +of the second coordinate over the first-coordinate rational subfield. + +No geometric Hasse--Weil statement is assumed here. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +open BGS.CorvajaZannier +open Polynomial + +noncomputable section + +/-- The iterated-polynomial presentation evaluates at the same ordered pair +as the original bivariate polynomial. -/ +theorem evalBivariate_planeCurveToBivariate + {K L : Type*} [Field K] [Field L] [Algebra K L] + (f : MvPolynomial (Fin 2) K) (x y : L) : + evalBivariate y x (planeCurveToBivariate K f) = + MvPolynomial.eval₂ (algebraMap K L) ![x, y] f := by + let lhs : MvPolynomial (Fin 2) K →+* L := + (Polynomial.eval₂RingHom + (Polynomial.eval₂RingHom (algebraMap K L) y) x).comp + (planeCurveToBivariate K).toRingEquiv.toRingHom + let rhs : MvPolynomial (Fin 2) K →+* L := + MvPolynomial.eval₂Hom (algebraMap K L) ![x, y] + have hhom : lhs = rhs := by + apply MvPolynomial.ringHom_ext + · intro c + simp [lhs, rhs] + · intro i + fin_cases i <;> simp [lhs, rhs] + change lhs f = rhs f + rw [hhom] + +/-- Swap the iterated presentation so that the second affine coordinate is +the outer polynomial variable. -/ +def planeCurveSecondOuterRelation + (K : Type*) [Field K] (f : MvPolynomial (Fin 2) K) : + Polynomial (Polynomial K) := + transposeBivariate (planeCurveToBivariate K f) + +theorem evalBivariate_planeCurveSecondOuterRelation + {K L : Type*} [Field K] [Field L] [Algebra K L] + (f : MvPolynomial (Fin 2) K) (x y : L) : + evalBivariate x y (planeCurveSecondOuterRelation K f) = + MvPolynomial.eval₂ (algebraMap K L) ![x, y] f := by + rw [planeCurveSecondOuterRelation, evalBivariate_transposeBivariate] + exact evalBivariate_planeCurveToBivariate f x y + +/-- Irreducibility is preserved by the two variable-presentation +equivalences. -/ +theorem planeCurveSecondOuterRelation_irreducible + {K : Type*} [Field K] {f : MvPolynomial (Fin 2) K} + (hf : Irreducible f) : + Irreducible (planeCurveSecondOuterRelation K f) := by + have hfirst : Irreducible (planeCurveToBivariate K f) := + hf.map (planeCurveToBivariate K).toMulEquiv + rw [planeCurveSecondOuterRelation, transposeBivariate_eq_bivariateSwap] + exact hfirst.map (Polynomial.Bivariate.swap (R := K)).toMulEquiv + +/-- The outer degree in the swapped presentation is exactly the degree in +the second affine coordinate. -/ +theorem planeCurveSecondOuterRelation_natDegree + (K : Type*) [Field K] (f : MvPolynomial (Fin 2) K) : + (planeCurveSecondOuterRelation K f).natDegree = + MvPolynomial.degreeOf 1 f := by + rw [planeCurveSecondOuterRelation, + transposeBivariate_planeCurveToBivariate, + bivariateEquiv_symm_natDegree_eq_degreeOf_one] + +/-- Over any enlarged constant field inside the ambient function field, an +irreducible plane equation is associated to the primitive cleared minimal +relation of the second coordinate. -/ +theorem primitiveClearedMinpolyRelation_associated_planeRelation + {K L : Type*} [Field K] [Field L] [Algebra K L] + (f : MvPolynomial (Fin 2) K) (hf : Irreducible f) + (x y : L) (hx : Transcendental K x) + (hy : IsIntegral (IntermediateField.adjoin K {x}) y) + (hzero : MvPolynomial.eval₂ (algebraMap K L) ![x, y] f = 0) : + Associated (primitiveClearedMinpolyRelation x hx y) + (planeCurveSecondOuterRelation K f) := by + have hdvd : primitiveClearedMinpolyRelation x hx y ∣ + planeCurveSecondOuterRelation K f := by + apply primitiveClearedMinpolyRelation_dvd_of_evalBivariate_eq_zero + x hx y hy + simpa [evalBivariate_planeCurveSecondOuterRelation] using hzero + exact (primitiveClearedMinpolyRelation_irreducible x hx y hy).associated_of_dvd + (planeCurveSecondOuterRelation_irreducible hf) hdvd + +/-- Consequently the minimal-polynomial degree over `K(x)` is the second +coordinate degree of the irreducible plane relation. -/ +theorem minpoly_natDegree_eq_planeRelation_secondDegree + {K L : Type*} [Field K] [Field L] [Algebra K L] + (f : MvPolynomial (Fin 2) K) (hf : Irreducible f) + (x y : L) (hx : Transcendental K x) + (hy : IsIntegral (IntermediateField.adjoin K {x}) y) + (hzero : MvPolynomial.eval₂ (algebraMap K L) ![x, y] f = 0) : + (minpoly (IntermediateField.adjoin K {x}) y).natDegree = + MvPolynomial.degreeOf 1 f := by + have hassociated := + primitiveClearedMinpolyRelation_associated_planeRelation + f hf x y hx hy hzero + calc + (minpoly (IntermediateField.adjoin K {x}) y).natDegree = + (primitiveClearedMinpolyRelation x hx y).natDegree := + (primitiveClearedMinpolyRelation_natDegree x hx y hy).symm + _ = (planeCurveSecondOuterRelation K f).natDegree := by + apply Nat.le_antisymm + · exact Polynomial.natDegree_le_of_dvd hassociated.dvd + (planeCurveSecondOuterRelation_irreducible hf).ne_zero + · exact Polynomial.natDegree_le_of_dvd hassociated.symm.dvd + (primitiveClearedMinpolyRelation_ne_zero x hx y) + _ = MvPolynomial.degreeOf 1 f := + planeCurveSecondOuterRelation_natDegree K f + +/-- A rational function field has no constants algebraic over its coefficient +field beyond the coefficient field itself. Lüroth's theorem makes this a +short argument: any nontrivial intermediate field has a transcendental +generator, whereas every element of the relative algebraic closure is +algebraic. -/ +theorem ratFunc_algebraicClosure_eq_bot (K : Type*) [Field K] : + algebraicClosure K (RatFunc K) = ⊥ := by + by_contra hne + let E : IntermediateField K (RatFunc K) := + algebraicClosure K (RatFunc K) + have hmem : RatFunc.Luroth.generator E ∈ E := + RatFunc.Luroth.generator_mem + have halgebraic : IsAlgebraic K (RatFunc.Luroth.generator E) := + mem_algebraicClosure_iff.mp hmem + exact (RatFunc.Luroth.transcendental_generator hne) halgebraic + +/-- The field generated by one transcendental element has the same exact +constant field as a rational function field. -/ +theorem adjoin_transcendental_algebraicClosure_eq_bot + {K L : Type*} [Field K] [Field L] [Algebra K L] + (x : L) (hx : Transcendental K x) : + algebraicClosure K (IntermediateField.adjoin K {x}) = ⊥ := by + let e : RatFunc K ≃ₐ[K] IntermediateField.adjoin K {x} := + RatFunc.algEquivOfTranscendental x hx + have hmap := algebraicClosure.map_eq_of_algEquiv e + rw [ratFunc_algebraicClosure_eq_bot] at hmap + simpa only [IntermediateField.map_bot] using hmap.symm + +private theorem finiteDimensional_finrank_of_adjoin_eq_top + {A L : Type*} [Field A] [Field L] [Algebra A L] + (y : L) (hy : IsIntegral A y) (htop : IntermediateField.adjoin A {y} = ⊤) : + FiniteDimensional A L ∧ Module.finrank A L = (minpoly A y).natDegree := by + let : FiniteDimensional A (IntermediateField.adjoin A {y}) := + IntermediateField.adjoin.finiteDimensional hy + let : FiniteDimensional A (⊤ : IntermediateField A L) := by + rw [← htop] + infer_instance + let : FiniteDimensional A L := + IntermediateField.topEquiv.toLinearEquiv.finiteDimensional + refine ⟨inferInstance, ?_⟩ + calc + Module.finrank A L = Module.finrank A (⊤ : IntermediateField A L) := by + rw [IntermediateField.finrank_top'] + _ = Module.finrank A (IntermediateField.adjoin A {y}) := by rw [htop] + _ = (minpoly A y).natDegree := IntermediateField.adjoin.finrank hy + +private theorem algebraMap_surjective_of_equal_finrank + {F A L : Type*} [Field F] [Field A] [Field L] + [Algebra F A] [Algebra A L] [Algebra F L] [IsScalarTower F A L] + [FiniteDimensional F L] [FiniteDimensional A L] + (degree : ℕ) (hdegree : 0 < degree) + (hA : Module.finrank A L = degree) (hF : Module.finrank F L = degree) : + Function.Surjective (algebraMap F A) := by + let : FiniteDimensional F A := + FiniteDimensional.of_injective (IsScalarTower.toAlgHom F A L).toLinearMap + (RingHom.injective _) + have hmul := Module.finrank_mul_finrank F A L + have hfinrank : Module.finrank F A = 1 := by + rw [hA, hF] at hmul + nlinarith + exact (Algebra.finrank_eq_one_iff_bijective_algebraMap.mp hfinrank).2 + +/-- **Exact constant field of an absolutely irreducible plane curve.** + +If the defining equation remains irreducible over an algebraic closure and +the second coordinate is separating, then the only elements of its function +field algebraic over `K` are the elements of `K` itself. + +The proof compares the degree over `K(x)` with the degree after adjoining the +relative algebraic closure `E` to the constants. Absolute irreducibility and +the cleared-minimal-polynomial relation show that both degrees are exactly +`degreeOf 1 f`. The tower formula therefore forces `E(x) = K(x)`. Finally, +the rational-function constant-field theorem above forces every element of +`E` back into `K`. -/ +theorem planeCurveFunctionField_algebraicClosure_eq_bot + {K : Type*} [Field K] + (f : MvPolynomial (Fin 2) K) + (habsolute : Irreducible + (MvPolynomial.map (algebraMap K (AlgebraicClosure K)) f)) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) : + let hf : Irreducible f := + irreducible_of_irreducible_map_algebraicClosure habsolute + let _ := planeCurveCoordinateRing_isDomain hf + algebraicClosure K (PlaneCurveFunctionField f) = ⊥ := by + intro hf domain + let L := PlaneCurveFunctionField f + let E : IntermediateField K L := algebraicClosure K L + let x : L := planeCurveFunction f 0 + let y : L := planeCurveFunction f 1 + let F : IntermediateField K L := IntermediateField.adjoin K {x} + let A : IntermediateField E L := IntermediateField.adjoin E {x} + have hdegree : 0 < MvPolynomial.degreeOf 1 f := + degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond + have hxK : Transcendental K x := + firstCoordinate_transcendental hf hdegree + have hxE : Transcendental E x := hxK.algebraicClosure + let fE : MvPolynomial (Fin 2) E := + MvPolynomial.map (algebraMap K E) f + have hfE : Irreducible fE := + irreducible_map_of_irreducible_map_algebraicClosure + (algebraMap K E) f habsolute + have hdegreeE : MvPolynomial.degreeOf 1 fE = + MvPolynomial.degreeOf 1 f := + degreeOf_map_eq_of_injective (algebraMap K E) + (algebraMap K E).injective 1 f + have hzeroE : + MvPolynomial.eval₂ (algebraMap E L) ![x, y] fE = 0 := by + simp only [fE, MvPolynomial.eval₂_map] + change MvPolynomial.eval₂ + ((algebraMap E L).comp (algebraMap K E)) ![x, y] f = 0 + have hcomp : (algebraMap E L).comp (algebraMap K E) = + algebraMap K L := by + ext c + exact IsScalarTower.algebraMap_apply K E L c + rw [hcomp] + have hcoordinates : ![x, y] = planeCurveFunction f := by + funext i + fin_cases i <;> rfl + rw [hcoordinates] + exact eval₂_planeCurveFunction_eq_zero f + have hFA : F ≤ A.restrictScalars K := by + apply IntermediateField.adjoin_le_iff.mpr + intro z hz + rw [Set.mem_singleton_iff] at hz + subst z + exact IntermediateField.subset_adjoin E {x} (Set.mem_singleton x) + let : Algebra F A := (IntermediateField.inclusion hFA).toAlgebra + let _ : SMul F A := Algebra.toSMul + let _ : Module F A := Algebra.toModule + let _ : SMul A L := Algebra.toSMul + let _ : Module A L := Algebra.toModule + let _ : SMul F L := Algebra.toSMul + let _ : Module F L := Algebra.toModule + let : IsScalarTower F A L := + IsScalarTower.of_algebraMap_eq' (R := F) (S := A) (A := L) rfl + have hpoly : polynomialOverFirstCoordinate f ≠ 0 := + polynomialOverFirstCoordinate_ne_zero_of_irreducible hf hdegree + have hyF : IsAlgebraic F y := by + exact secondCoordinate_isAlgebraic_over_first f hpoly + have hyAalg : IsAlgebraic A y := + hyF.extendScalars (algebraMap F A).injective + have hyA : IsIntegral A y := isAlgebraic_iff_isIntegral.mp hyAalg + have hminA : (minpoly A y).natDegree = MvPolynomial.degreeOf 1 f := by + calc + (minpoly A y).natDegree = MvPolynomial.degreeOf 1 fE := + minpoly_natDegree_eq_planeRelation_secondDegree + fE hfE x y hxE hyA hzeroE + _ = MvPolynomial.degreeOf 1 f := hdegreeE + have hpairK : IntermediateField.adjoin K {x, y} = ⊤ := by + rw [← range_planeCurveFunction f] + exact adjoin_planeCurveFunctions_eq_top + have hpairE : IntermediateField.adjoin E {x, y} = ⊤ := by + apply top_unique + intro z _hz + have hzK : z ∈ IntermediateField.adjoin K {x, y} := by + rw [hpairK] + trivial + have hle : IntermediateField.adjoin K {x, y} ≤ + (IntermediateField.adjoin E {x, y}).restrictScalars K := by + apply IntermediateField.adjoin_le_iff.mpr + intro u hu + exact IntermediateField.subset_adjoin E {x, y} hu + exact hle hzK + have htopA : IntermediateField.adjoin A {y} = ⊤ := by + apply IntermediateField.restrictScalars_injective E + rw [IntermediateField.restrictScalars_top] + change (IntermediateField.adjoin + (IntermediateField.adjoin E {x}) {y}).restrictScalars E = ⊤ + rw [IntermediateField.adjoin_adjoin_left] + simpa only [Set.singleton_union] using hpairE + obtain ⟨finiteDimensionalA, hfinrankA⟩ := + finiteDimensional_finrank_of_adjoin_eq_top y hyA htopA + let : FiniteDimensional A L := finiteDimensionalA + have hfinA : Module.finrank A L = MvPolynomial.degreeOf 1 f := + hfinrankA.trans hminA + let : FiniteDimensional F L := + (finiteSeparable_over_firstCoordinate_of_irreducible + hf hpartialSecond).1 + have hfinF : Module.finrank F L = MvPolynomial.degreeOf 1 f := + finrank_over_firstCoordinate_eq_degreeOf_second_of_irreducible + hf hpartialSecond + have hsurj : Function.Surjective (algebraMap F A) := + algebraMap_surjective_of_equal_finrank (L := L) _ hdegree hfinA hfinF + have hArestrict : A.restrictScalars K = F := by + apply le_antisymm + · intro z hz + let zA : A := ⟨z, hz⟩ + obtain ⟨w, hw⟩ := hsurj zA + have hcoe : (w : L) = z := by + exact congrArg (fun a : A ↦ (a : L)) hw + change z ∈ F + rw [← hcoe] + exact w.property + · exact hFA + apply le_antisymm + · intro z hz + have hzA : z ∈ A := by + exact A.algebraMap_mem ⟨z, hz⟩ + have hzF : z ∈ F := by + have : z ∈ A.restrictScalars K := hzA + rwa [hArestrict] at this + let zF : F := ⟨z, hzF⟩ + have hzAlgL : IsAlgebraic K z := + mem_algebraicClosure_iff.mp hz + have hzAlgF : IsAlgebraic K zF := by + apply (isAlgebraic_algHom_iff + (IsScalarTower.toAlgHom K F L) (RingHom.injective _)).mp + change IsAlgebraic K (zF : L) + simpa [L] using hzAlgL + have hzClosure : zF ∈ algebraicClosure K F := + mem_algebraicClosure_iff.mpr hzAlgF + have hclosure : algebraicClosure K F = ⊥ := + adjoin_transcendental_algebraicClosure_eq_bot x hxK + rw [hclosure, IntermediateField.mem_bot] at hzClosure + rw [IntermediateField.mem_bot] + obtain ⟨c, hc⟩ := hzClosure + refine ⟨c, ?_⟩ + exact congrArg Subtype.val hc + · exact bot_le + +/-- Exact constants persist after an arbitrary extension of the coefficient +field. Absolute irreducibility over `K` supplies absolute irreducibility over +`E`, and injectivity of the coefficient embedding preserves the separating +second partial derivative. -/ +theorem planeCurveBaseChangeFunctionField_algebraicClosure_eq_bot + {K E : Type*} [Field K] [Field E] [Algebra K E] + (f : MvPolynomial (Fin 2) K) + (habsolute : Irreducible + (MvPolynomial.map (algebraMap K (AlgebraicClosure K)) f)) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) : + let fE := MvPolynomial.map (algebraMap K E) f + let hfE := irreducible_map_of_irreducible_map_algebraicClosure + (algebraMap K E) f habsolute + letI := planeCurveCoordinateRing_isDomain hfE + algebraicClosure E (PlaneCurveFunctionField fE) = ⊥ := by + let fE := MvPolynomial.map (algebraMap K E) f + have habsoluteE : Irreducible + (MvPolynomial.map (algebraMap E (AlgebraicClosure E)) fE) := by + have h := irreducible_map_of_irreducible_map_algebraicClosure + ((algebraMap E (AlgebraicClosure E)).comp (algebraMap K E)) + f habsolute + simpa only [fE, MvPolynomial.map_map] using h + have hpartialSecondE : MvPolynomial.pderiv 1 fE ≠ 0 := by + rw [MvPolynomial.pderiv_map] + intro hz + apply hpartialSecond + apply MvPolynomial.map_injective (algebraMap K E) + (algebraMap K E).injective + simpa using hz + exact planeCurveFunctionField_algebraicClosure_eq_bot + fE habsoluteE hpartialSecondE + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/PlaneCoordinatePole.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/PlaneCoordinatePole.lean new file mode 100644 index 0000000000..e72e6c9492 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/PlaneCoordinatePole.lean @@ -0,0 +1,242 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurvePoweredHeightBounds +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionZeroCounting +public import LeanPool.MarkoffModP.BGS.HasseWeil.PoleDivisor +public import Mathlib.Tactic + +/-! +# A controlled pole place for the first plane coordinate + +In the first-coordinate rational-function model of an irreducible plane +curve, the pole divisor of the first coordinate has degree exactly the degree +of the defining polynomial in the second variable. Consequently that pole +divisor has nonempty support, and one can choose a pole place whose (possibly +nontrivial) place degree is bounded by that second-variable degree. + +No rationality assertion is made about the selected place. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +open BGS.CorvajaZannier +open scoped nonZeroDivisors Polynomial BigOperators + +noncomputable section + +variable {K : Type*} [Field K] [Fintype K] [DecidableEq K] + [DecidableEq (RatFunc K)] + +omit [Fintype K] in +/-- In the first-coordinate `RatFunc` model, the pole height of the first +coordinate is the degree of the plane equation in the second variable. -/ +theorem finiteExtensionHeight_planeCurveFirstCoordinate + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) : + letI := planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + letI := planeCurveFirstCoordinateRatFuncAlgebra f hx + letI := finiteDimensional_planeCurveFunctionField_over_ratFunc + hf hpartialSecond + letI := separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + finiteExtensionHeight K (PlaneCurveFunctionField f) + (planeCurveFunction f 0) = + MvPolynomial.degreeOf 1 f := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let L := PlaneCurveFunctionField f + let x : L := planeCurveFunction f 0 + let : Algebra (RatFunc K) L := + planeCurveFirstCoordinateRatFuncAlgebra f hx + let : FiniteDimensional (RatFunc K) L := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : Algebra.IsSeparable (RatFunc K) L := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + have hx0 : x ≠ 0 := by + change planeCurveFunction f 0 ≠ 0 + intro hzero + apply hx + rw [hzero] + exact isAlgebraic_zero + calc + finiteExtensionHeight K L x = + finiteExtensionPositiveDegree K L x := + (finiteExtensionPositiveDegree_eq_height K L x hx0).symm + _ = MvPolynomial.degreeOf 1 f := by + have hpositive := + finiteExtensionPositiveDegree_planeCurveFirstCoordinate_pow + hf hpartialSecond 1 (by omega) + simpa only [x, pow_one, one_mul] using hpositive + +omit [Fintype K] in +/-- Equivalently, the effective pole divisor of the first coordinate has +degree equal to the degree of the plane equation in the second variable. -/ +theorem finiteExtensionDivisorDegree_planeCurveFirstCoordinate_poleDivisor + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) : + letI := planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + letI := planeCurveFirstCoordinateRatFuncAlgebra f hx + letI := finiteDimensional_planeCurveFunctionField_over_ratFunc + hf hpartialSecond + letI := separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + finiteExtensionDivisorDegree K (PlaneCurveFunctionField f) + (finiteExtensionPoleDivisor K (PlaneCurveFunctionField f) + (planeCurveFunction f 0)) = + (MvPolynomial.degreeOf 1 f : ℤ) := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let L := PlaneCurveFunctionField f + let x : L := planeCurveFunction f 0 + let : Algebra (RatFunc K) L := + planeCurveFirstCoordinateRatFuncAlgebra f hx + let : FiniteDimensional (RatFunc K) L := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : Algebra.IsSeparable (RatFunc K) L := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + change finiteExtensionDivisorDegree K L + (finiteExtensionPoleDivisor K L x) = + (MvPolynomial.degreeOf 1 f : ℤ) + rw [finiteExtensionDivisorDegree_poleDivisor, + finiteExtensionHeight_planeCurveFirstCoordinate hf hpartialSecond] + +omit [Fintype K] in +/-- A positive coefficient of an effective divisor contributes at least the +degree of its place to the total divisor degree. -/ +theorem finiteExtensionPlaceDegree_le_divisorDegree_of_effective_of_pos + (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + (D : FiniteExtensionDivisor K L) + (hD : ∀ v, 0 ≤ D v) {P : FiniteExtensionPlace K L} + (hP : 0 < D P) : + (finiteExtensionPlaceDegree K L P : ℤ) ≤ + finiteExtensionDivisorDegree K L D := by + classical + rw [finiteExtensionDivisorDegree, Finsupp.sum] + have hPmem : P ∈ D.support := + Finsupp.mem_support_iff.mpr hP.ne' + calc + (finiteExtensionPlaceDegree K L P : ℤ) ≤ + D P * (finiteExtensionPlaceDegree K L P : ℤ) := by + have hcoefficient : (1 : ℤ) ≤ D P := by omega + simpa only [one_mul] using + mul_le_mul_of_nonneg_right hcoefficient + (show 0 ≤ (finiteExtensionPlaceDegree K L P : ℤ) by positivity) + _ ≤ ∑ v ∈ D.support, + D v * (finiteExtensionPlaceDegree K L v : ℤ) := by + exact Finset.single_le_sum + (fun v _hv => mul_nonneg (hD v) (by positivity)) hPmem + +omit [Fintype K] [DecidableEq K] in +/-- The first-coordinate pole divisor has nonempty support. -/ +theorem planeCurveFirstCoordinate_poleDivisor_support_nonempty + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) : + letI := planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + letI := planeCurveFirstCoordinateRatFuncAlgebra f hx + letI := finiteDimensional_planeCurveFunctionField_over_ratFunc + hf hpartialSecond + letI := separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + (finiteExtensionPoleDivisor K (PlaneCurveFunctionField f) + (planeCurveFunction f 0)).support.Nonempty := by + classical + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let L := PlaneCurveFunctionField f + let x : L := planeCurveFunction f 0 + let : Algebra (RatFunc K) L := + planeCurveFirstCoordinateRatFuncAlgebra f hx + let : FiniteDimensional (RatFunc K) L := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : Algebra.IsSeparable (RatFunc K) L := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + change (finiteExtensionPoleDivisor K L x).support.Nonempty + apply Finsupp.support_nonempty_iff.mpr + intro hzero + have hdegree := + finiteExtensionDivisorDegree_planeCurveFirstCoordinate_poleDivisor + hf hpartialSecond + change finiteExtensionDivisorDegree K L + (finiteExtensionPoleDivisor K L x) = + (MvPolynomial.degreeOf 1 f : ℤ) at hdegree + rw [hzero] at hdegree + simp only [finiteExtensionDivisorDegree, Finsupp.sum_zero_index] at hdegree + have hpositive : 0 < MvPolynomial.degreeOf 1 f := + degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond + omega + +omit [Fintype K] in +/-- There is a pole place for the first coordinate. Its coefficient in the +pole divisor is positive, and its (not necessarily one) place degree lies +between one and the degree of the plane equation in the second variable. -/ +theorem exists_planeCurveFirstCoordinate_polePlace + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) : + letI := planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + letI := planeCurveFirstCoordinateRatFuncAlgebra f hx + letI := finiteDimensional_planeCurveFunctionField_over_ratFunc + hf hpartialSecond + letI := separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + ∃ P : FiniteExtensionPlace K (PlaneCurveFunctionField f), + 0 < finiteExtensionPoleDivisor K (PlaneCurveFunctionField f) + (planeCurveFunction f 0) P ∧ + 0 < finiteExtensionPlaceDegree K (PlaneCurveFunctionField f) P ∧ + finiteExtensionPlaceDegree K (PlaneCurveFunctionField f) P ≤ + MvPolynomial.degreeOf 1 f := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let L := PlaneCurveFunctionField f + let x : L := planeCurveFunction f 0 + let : Algebra (RatFunc K) L := + planeCurveFirstCoordinateRatFuncAlgebra f hx + let : FiniteDimensional (RatFunc K) L := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : Algebra.IsSeparable (RatFunc K) L := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + obtain ⟨P, hPsupport⟩ := + planeCurveFirstCoordinate_poleDivisor_support_nonempty + hf hpartialSecond + have hPcoefficient : + 0 < finiteExtensionPoleDivisor K L x P := by + exact lt_of_le_of_ne + (finiteExtensionPoleDivisor_effective K L x P) + (Finsupp.mem_support_iff.mp hPsupport).symm + have hPdegreePositive : 0 < finiteExtensionPlaceDegree K L P := + finiteExtensionPlaceDegree_pos K L P + have hPdegreeCast : + (finiteExtensionPlaceDegree K L P : ℤ) ≤ + (MvPolynomial.degreeOf 1 f : ℤ) := by + rw [← finiteExtensionDivisorDegree_planeCurveFirstCoordinate_poleDivisor + hf hpartialSecond] + exact finiteExtensionPlaceDegree_le_divisorDegree_of_effective_of_pos + (K := K) L (finiteExtensionPoleDivisor K L x) + (finiteExtensionPoleDivisor_effective K L x) hPcoefficient + refine ⟨P, hPcoefficient, hPdegreePositive, ?_⟩ + exact_mod_cast hPdegreeCast + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/PlaneCoordinatePoleAtInfinity.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/PlaneCoordinatePoleAtInfinity.lean new file mode 100644 index 0000000000..f9261210c5 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/PlaneCoordinatePoleAtInfinity.lean @@ -0,0 +1,352 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneCoordinatePole + +/-! +# The first plane coordinate only has poles above infinity + +The first-coordinate rational-function model sends `RatFunc.X` to the first +plane coordinate. At a finite place, `Polynomial.X` lies in the finite +integral closure, so its order is nonnegative. Thus the effective pole +divisor of the first coordinate vanishes at every finite place. + +Combining this support statement with the previously constructed controlled +pole place shows that the selected pole may be taken above the rational- +function place at infinity, without changing its place-degree bound. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +open BGS.CorvajaZannier +open IsDedekindDomain +open scoped nonZeroDivisors Polynomial BigOperators + +noncomputable section + +attribute [local instance] FractionRing.liftAlgebra + FractionRing.isScalarTower_liftAlgebra + +variable (K : Type*) [Field K] [Fintype K] [DecidableEq K] + [DecidableEq (RatFunc K)] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +local instance (priority := 10) coordinatePolePolynomialAlgebra : + Algebra K[X] L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K[X] (RatFunc K))) + +local instance coordinatePolePolynomialScalarTower : + IsScalarTower K[X] (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + +local instance coordinatePoleFiniteIntegralClosureModuleFinite : + Module.Finite K[X] (RatFuncFiniteIntegralClosure K L) := + Module.IsNoetherian.finite K[X] (RatFuncFiniteIntegralClosure K L) + +local instance coordinatePoleFiniteIntegralClosureIsIntegral : + Algebra.IsIntegral K[X] (RatFuncFiniteIntegralClosure K L) := + IsIntegralClosure.isIntegral_algebra K[X] L + +local instance coordinatePolePolynomialTorsionFreeTop : + Module.IsTorsionFree K[X] L := + Module.IsTorsionFree.trans_faithfulSMul K[X] (RatFunc K) L + +local instance coordinatePoleFiniteIntegralClosureIsTorsionFree : + Module.IsTorsionFree K[X] (RatFuncFiniteIntegralClosure K L) := + IsIntegralClosure.isTorsionFree K[X] L + +local instance coordinatePoleInfinityIntegralClosureModuleFinite : + Module.Finite (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.finite (RatFuncInfinityIntegers K) (RatFunc K) L + (RatFuncInfinityIntegralClosure K L) + +local instance coordinatePoleInfinityIntegralClosureIsIntegral : + Algebra.IsIntegral (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.isIntegral_algebra (RatFuncInfinityIntegers K) L + +local instance coordinatePoleInfinityBaseTorsionFreeTop : + Module.IsTorsionFree (RatFuncInfinityIntegers K) L := + Module.IsTorsionFree.trans_faithfulSMul + (RatFuncInfinityIntegers K) (RatFunc K) L + +local instance coordinatePoleInfinityIntegralClosureIsTorsionFree : + Module.IsTorsionFree (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.isTorsionFree (RatFuncInfinityIntegers K) L + +local instance coordinatePoleInfinityIntegralClosureIsDedekindDomain : + IsDedekindDomain (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.isDedekindDomain + (RatFuncInfinityIntegers K) (RatFunc K) L + (RatFuncInfinityIntegralClosure K L) + +local instance coordinatePoleInfinityIntegralClosureIsFractionRing : + IsFractionRing (RatFuncInfinityIntegralClosure K L) L := + IsIntegralClosure.isFractionRing_of_finite_extension + (RatFuncInfinityIntegers K) (RatFunc K) L + (RatFuncInfinityIntegralClosure K L) + +omit [Fintype K] [DecidableEq K] in +private theorem principalDivisor_algebraMap_X_inl_nonnegative + (q : FiniteExtensionFinitePlace K L) : + 0 ≤ finiteExtensionPrincipalDivisor K L + (algebraMap (RatFunc K) L RatFunc.X) (.inl q) := by + let S := RatFuncFiniteIntegralClosure K L + let e := ratFuncFiniteIntegralClosureFractionRingEquiv K L + let s : S := algebraMap K[X] S Polynomial.X + have hs : s ≠ 0 := by + have hinj : Function.Injective (algebraMap K[X] S) := + FunctionField.ringOfIntegers.algebraMap_injective K L + dsimp only [s] + exact (map_ne_zero_iff (algebraMap K[X] S) hinj).2 Polynomial.X_ne_zero + have hrepr : + e.symm (algebraMap (RatFunc K) L RatFunc.X) = + algebraMap S (FractionRing S) s := by + apply e.injective + rw [e.apply_symm_apply, e.commutes] + rfl + rw [finiteExtensionPrincipalDivisor_inl, hrepr] + exact finitePlaceOrder_algebraMap_nonnegative q s hs + +omit [Fintype K] [DecidableEq K] in +/-- At every place above the rational-function place at infinity, the image +of `RatFunc.X` has strictly negative order. This is stronger than merely +knowing that some infinity place is a pole: it makes the pole divisor of the +first coordinate cofinal among divisors supported at infinity. -/ +theorem finiteExtensionPrincipalDivisor_algebraMap_X_inr_negative + (P : FiniteExtensionInfinityPlace K L) : + finiteExtensionPrincipalDivisor K L + (algebraMap (RatFunc K) L RatFunc.X) (.inr P) < 0 := by + let q := primeOverHeightOne (ratFuncInfinityPlace K) P + let pi := ratFuncInfinityUniformizer K + have hpiBase : pi ∈ (ratFuncInfinityPlace K).asIdeal := by + rw [ratFuncInfinityPlace_span_uniformizer] + exact Ideal.mem_span_singleton_self pi + have hpiP : algebraMap (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) pi ∈ P.1 := by + have hover : (ratFuncInfinityPlace K).asIdeal = Ideal.comap + (algebraMap (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L)) P.1 := by + exact Ideal.over_def P.1 (ratFuncInfinityPlace K).asIdeal + exact Ideal.mem_comap.mp (hover ▸ hpiBase) + have hpiLt : q.valuation L + (algebraMap (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) pi) < 1 := + (q.valuation_lt_one_iff_mem + (algebraMap (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) pi)).mpr hpiP + have hpiImage : algebraMap + (RatFuncInfinityIntegralClosure K L) L + (algebraMap (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) pi) = + (algebraMap (RatFunc K) L RatFunc.X)⁻¹ := by + change algebraMap (RatFunc K) L (1 / RatFunc.X) = + (algebraMap (RatFunc K) L RatFunc.X)⁻¹ + simp + have hxinverse : q.valuation L + (algebraMap (RatFunc K) L RatFunc.X)⁻¹ < 1 := by + rw [← hpiImage] + exact hpiLt + have hX0 : algebraMap (RatFunc K) L RatFunc.X ≠ 0 := by + simpa using (algebraMap (RatFunc K) L).injective.ne RatFunc.X_ne_zero + have hXgt : 1 < q.valuation L + (algebraMap (RatFunc K) L RatFunc.X) := + ((q.valuation L).one_lt_val_iff hX0).mpr hxinverse + have horder := valuation_eq_exp_neg_finitePlaceOrder q + (algebraMap (RatFunc K) L RatFunc.X) hX0 + rw [horder, ← WithZero.exp_zero, WithZero.exp_lt_exp] at hXgt + have hnegative : finitePlaceOrder q + (algebraMap (RatFunc K) L RatFunc.X) < 0 := by + omega + have hord := fractionRingAlgEquiv_finitePlaceOrder_eq + (L := L) q + ((ratFuncInfinityIntegralClosureFractionRingEquiv K L).symm + (algebraMap (RatFunc K) L RatFunc.X)) + have hord' : finitePlaceOrder q + (algebraMap (RatFunc K) L RatFunc.X) = + finitePlaceOrder q + ((ratFuncInfinityIntegralClosureFractionRingEquiv K L).symm + (algebraMap (RatFunc K) L RatFunc.X)) := by + simpa [ratFuncInfinityIntegralClosureFractionRingEquiv] using hord + rw [finiteExtensionPrincipalDivisor_inr, ← hord'] + exact hnegative + +variable {K} + +omit [Fintype K] [DecidableEq K] in +/-- The first plane coordinate has nonnegative principal-divisor order at +every finite place in its rational-function model. -/ +theorem finiteExtensionPrincipalDivisor_planeCurveFirstCoordinate_inl_nonnegative + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) : + letI := planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + letI := planeCurveFirstCoordinateRatFuncAlgebra f hx + letI := finiteDimensional_planeCurveFunctionField_over_ratFunc + hf hpartialSecond + letI := separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + ∀ q : FiniteExtensionFinitePlace K (PlaneCurveFunctionField f), + 0 ≤ finiteExtensionPrincipalDivisor K (PlaneCurveFunctionField f) + (planeCurveFunction f 0) (.inl q) := by + classical + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let L := PlaneCurveFunctionField f + let x : L := planeCurveFunction f 0 + let : Algebra (RatFunc K) L := + planeCurveFirstCoordinateRatFuncAlgebra f hx + let : FiniteDimensional (RatFunc K) L := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : Algebra.IsSeparable (RatFunc K) L := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + change ∀ q : FiniteExtensionFinitePlace K L, + 0 ≤ finiteExtensionPrincipalDivisor K L x (.inl q) + intro q + dsimp only [x] + rw [← planeCurveFirstCoordinateRatFuncAlgebra_X f hx] + exact principalDivisor_algebraMap_X_inl_nonnegative K L q + +omit [Fintype K] [DecidableEq K] in +/-- Consequently, the pole divisor of the first plane coordinate vanishes at +every finite place. -/ +theorem finiteExtensionPoleDivisor_planeCurveFirstCoordinate_inl_eq_zero + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) : + letI := planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + letI := planeCurveFirstCoordinateRatFuncAlgebra f hx + letI := finiteDimensional_planeCurveFunctionField_over_ratFunc + hf hpartialSecond + letI := separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + ∀ q : FiniteExtensionFinitePlace K (PlaneCurveFunctionField f), + finiteExtensionPoleDivisor K (PlaneCurveFunctionField f) + (planeCurveFunction f 0) (.inl q) = 0 := by + classical + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let L := PlaneCurveFunctionField f + let x : L := planeCurveFunction f 0 + let : Algebra (RatFunc K) L := + planeCurveFirstCoordinateRatFuncAlgebra f hx + let : FiniteDimensional (RatFunc K) L := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : Algebra.IsSeparable (RatFunc K) L := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + change ∀ q : FiniteExtensionFinitePlace K L, + finiteExtensionPoleDivisor K L x (.inl q) = 0 + intro q + rw [finiteExtensionPoleDivisor_apply] + rw [ite_eq_right (not_lt_of_ge + (finiteExtensionPrincipalDivisor_planeCurveFirstCoordinate_inl_nonnegative + hf hpartialSecond q))] + +omit [Fintype K] [DecidableEq K] in +/-- Every place above infinity occurs with positive coefficient in the pole +divisor of the first plane coordinate. -/ +theorem finiteExtensionPoleDivisor_planeCurveFirstCoordinate_inr_positive + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) : + letI := planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + letI := planeCurveFirstCoordinateRatFuncAlgebra f hx + letI := finiteDimensional_planeCurveFunctionField_over_ratFunc + hf hpartialSecond + letI := separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + ∀ P : FiniteExtensionInfinityPlace K (PlaneCurveFunctionField f), + 0 < finiteExtensionPoleDivisor K (PlaneCurveFunctionField f) + (planeCurveFunction f 0) (.inr P) := by + classical + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let L := PlaneCurveFunctionField f + let x : L := planeCurveFunction f 0 + let : Algebra (RatFunc K) L := + planeCurveFirstCoordinateRatFuncAlgebra f hx + let : FiniteDimensional (RatFunc K) L := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : Algebra.IsSeparable (RatFunc K) L := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + change ∀ P : FiniteExtensionInfinityPlace K L, + 0 < finiteExtensionPoleDivisor K L x (.inr P) + intro P + have hnegative : finiteExtensionPrincipalDivisor K L x (.inr P) < 0 := by + have hmapX : algebraMap (RatFunc K) L RatFunc.X = x := by + dsimp only [x] + exact planeCurveFirstCoordinateRatFuncAlgebra_X f hx + rw [← hmapX] + exact finiteExtensionPrincipalDivisor_algebraMap_X_inr_negative K L P + rw [finiteExtensionPoleDivisor_apply, ite_eq_left hnegative] + omega + +omit [Fintype K] in +/-- The controlled pole place for the first plane coordinate lies above the +rational-function place at infinity. Its positive pole coefficient and +place-degree bound are the same as in `exists_planeCurveFirstCoordinate_polePlace`. -/ +theorem exists_planeCurveFirstCoordinate_infinityPolePlace + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) : + letI := planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + letI := planeCurveFirstCoordinateRatFuncAlgebra f hx + letI := finiteDimensional_planeCurveFunctionField_over_ratFunc + hf hpartialSecond + letI := separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + ∃ P : FiniteExtensionInfinityPlace K (PlaneCurveFunctionField f), + 0 < finiteExtensionPoleDivisor K (PlaneCurveFunctionField f) + (planeCurveFunction f 0) (.inr P) ∧ + 0 < finiteExtensionPlaceDegree K (PlaneCurveFunctionField f) (.inr P) ∧ + finiteExtensionPlaceDegree K (PlaneCurveFunctionField f) (.inr P) ≤ + MvPolynomial.degreeOf 1 f := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let L := PlaneCurveFunctionField f + let x : L := planeCurveFunction f 0 + let : Algebra (RatFunc K) L := + planeCurveFirstCoordinateRatFuncAlgebra f hx + let : FiniteDimensional (RatFunc K) L := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : Algebra.IsSeparable (RatFunc K) L := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + change ∃ P : FiniteExtensionInfinityPlace K L, + 0 < finiteExtensionPoleDivisor K L x (.inr P) ∧ + 0 < finiteExtensionPlaceDegree K L (.inr P) ∧ + finiteExtensionPlaceDegree K L (.inr P) ≤ MvPolynomial.degreeOf 1 f + obtain ⟨P, hPpole, hPdegreePositive, hPdegreeBound⟩ := + exists_planeCurveFirstCoordinate_polePlace hf hpartialSecond + cases P with + | inl q => + have hzero := + finiteExtensionPoleDivisor_planeCurveFirstCoordinate_inl_eq_zero + hf hpartialSecond q + rw [hzero] at hPpole + omega + | inr P => + exact ⟨P, hPpole, hPdegreePositive, hPdegreeBound⟩ + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/PlaneCoordinateShear.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/PlaneCoordinateShear.lean new file mode 100644 index 0000000000..3938df2e92 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/PlaneCoordinateShear.lean @@ -0,0 +1,483 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.External.GeneralCurveTheorems +public import Mathlib.Algebra.MvPolynomial.Monad +public import Mathlib.Algebra.MvPolynomial.PDeriv +public import Mathlib.RingTheory.MvPolynomial.Expand + +/-! +# A separating coordinate shear for affine plane curves + +This file formalizes the invertible linear change of variables +`(x, y) ↦ (x, x + y)`. If the first partial derivative of `f` vanishes but +the second does not, the transformed equation has both partial derivatives +nonzero. The shear preserves affine point counts and geometric +irreducibility, including after extension to an algebraic closure. + +The case in which both partial derivatives vanish is deliberately not hidden +here: over a finite field it requires the separate characteristic-`p` +argument that an absolutely irreducible nonconstant polynomial cannot be a +polynomial in `x^p` and `y^p`. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +open MvPolynomial + +noncomputable section + +section VanishingPartials + +variable {R σ : Type*} [Field R] + +/-- Divide every exponent of a multivariate monomial by `p`. On the +support of a polynomial whose partial derivatives vanish in characteristic +`p`, this is an exact inverse to multiplication of exponents by `p`. -/ +def divideExponents (p : ℕ) (m : σ →₀ ℕ) : σ →₀ ℕ := + m.mapRange (fun n => n / p) (Nat.zero_div p) + +variable (p : ℕ) [CharP R p] + +/-- In characteristic `p`, every exponent occurring in a variable with +vanishing partial derivative is divisible by `p`. -/ +theorem dvd_exponent_of_pderiv_eq_zero + {f : MvPolynomial σ R} {i : σ} + (hderiv : pderiv i f = 0) {m : σ →₀ ℕ} (hm : m ∈ f.support) : + p ∣ m i := by + by_contra hnot + have hi : m i ≠ 0 := by + intro hi + apply hnot + simp [hi] + let n : σ →₀ ℕ := m - Finsupp.single i 1 + have hn : n + Finsupp.single i 1 = m := by + exact Finsupp.sub_add_single_one_cancel hi + have hni : n i + 1 = m i := by + simpa [n] using congrArg (fun v : σ →₀ ℕ => v i) hn + have hcoeff : f.coeff m ≠ 0 := by + simpa [mem_support_iff] using hm + have hcast : (m i : R) ≠ 0 := by + exact (CharP.cast_eq_zero_iff R p (m i)).not.mpr hnot + have hz := congrArg (fun g : MvPolynomial σ R ↦ g.coeff n) hderiv + rw [coeff_pderiv] at hz + simp only [AddMonoidAlgebra.coeff_zero] at hz + rw [hn] at hz + have hfactor : ((n i : R) + 1) = (m i : R) := by + simpa only [Nat.cast_add, Nat.cast_one] using + congrArg (fun a : ℕ => (a : R)) hni + rw [hfactor] at hz + exact (mul_ne_zero hcoeff hcast) hz + +theorem smul_divideExponents_eq + {f : MvPolynomial σ R} + (hderiv : ∀ i, pderiv i f = 0) + {m : σ →₀ ℕ} (hm : m ∈ f.support) : + p • divideExponents p m = m := by + ext i + simp only [Finsupp.smul_apply, nsmul_eq_mul, divideExponents, + Finsupp.mapRange_apply] + exact Nat.mul_div_cancel' (dvd_exponent_of_pderiv_eq_zero p (hderiv i) hm) + +variable [Fact p.Prime] [PerfectRing R p] + +/-- Over a perfect field of positive characteristic, a multivariate +polynomial with every partial derivative zero is a `p`-th power. -/ +theorem exists_pow_eq_of_forall_pderiv_eq_zero + (f : MvPolynomial σ R) (hderiv : ∀ i, pderiv i f = 0) : + ∃ g : MvPolynomial σ R, g ^ p = f := by + let g : MvPolynomial σ R := + ∑ m ∈ f.support, + monomial (divideExponents p m) + ((frobeniusEquiv R p).symm (f.coeff m)) + refine ⟨g, ?_⟩ + rw [← map_frobenius_expand p] + calc + map (frobenius R p) (expand p g) = + ∑ m ∈ f.support, monomial m (f.coeff m) := by + simp only [g, map_sum, map_monomial, expand_monomial] + apply Finset.sum_congr rfl + intro m hm + rw [smul_divideExponents_eq p hderiv hm] + simp + _ = f := f.as_sum.symm + +/-- Hence a polynomial with every partial derivative zero cannot be +irreducible over a perfect field of characteristic `p`. -/ +theorem not_irreducible_of_forall_pderiv_eq_zero + (p : ℕ) [Fact p.Prime] [CharP R p] [PerfectRing R p] + (f : MvPolynomial σ R) (hderiv : ∀ i, pderiv i f = 0) : + ¬ Irreducible f := by + obtain ⟨g, rfl⟩ := exists_pow_eq_of_forall_pderiv_eq_zero p f hderiv + exact not_irreducible_pow (Fact.out : p.Prime).ne_one + +end VanishingPartials + +variable (R : Type*) [CommRing R] + +/-- The substitution `(x, y) ↦ (x, x + y)`. -/ +def planeYShearSubstitution : Fin 2 → MvPolynomial (Fin 2) R := + ![X 0, X 0 + X 1] + +/-- The inverse substitution `(x, y) ↦ (x, y - x)`. -/ +def planeYUnShearSubstitution : Fin 2 → MvPolynomial (Fin 2) R := + ![X 0, X 1 - X 0] + +@[simp] theorem planeYShearSubstitution_zero : + planeYShearSubstitution R 0 = X 0 := rfl + +@[simp] theorem planeYShearSubstitution_one : + planeYShearSubstitution R 1 = X 0 + X 1 := rfl + +def planeYShearHom : MvPolynomial (Fin 2) R →ₐ[R] MvPolynomial (Fin 2) R := + bind₁ (planeYShearSubstitution R) + +def planeYUnShearHom : MvPolynomial (Fin 2) R →ₐ[R] MvPolynomial (Fin 2) R := + bind₁ (planeYUnShearSubstitution R) + +theorem planeYShearHom_comp_planeYUnShearHom : + (planeYShearHom R).comp (planeYUnShearHom R) = AlgHom.id R _ := by + ext i + fin_cases i <;> simp [planeYShearHom, planeYUnShearHom, + planeYShearSubstitution, planeYUnShearSubstitution] + +theorem planeYUnShearHom_comp_planeYShearHom : + (planeYUnShearHom R).comp (planeYShearHom R) = AlgHom.id R _ := by + ext i + fin_cases i <;> simp [planeYShearHom, planeYUnShearHom, + planeYShearSubstitution, planeYUnShearSubstitution] + +/-- The polynomial automorphism induced by `(x, y) ↦ (x, x + y)`. -/ +def planeYShearAlgEquiv : + MvPolynomial (Fin 2) R ≃ₐ[R] MvPolynomial (Fin 2) R := + AlgEquiv.ofAlgHom (planeYShearHom R) (planeYUnShearHom R) + (planeYShearHom_comp_planeYUnShearHom R) + (planeYUnShearHom_comp_planeYShearHom R) + +@[simp] theorem planeYShearAlgEquiv_apply (f : MvPolynomial (Fin 2) R) : + planeYShearAlgEquiv R f = bind₁ (planeYShearSubstitution R) f := rfl + +/-- The corresponding bijection of affine points. -/ +def planeYShearPointEquiv : R × R ≃ R × R where + toFun z := (z.1, z.1 + z.2) + invFun z := (z.1, z.2 - z.1) + left_inv := by rintro ⟨x, y⟩; simp + right_inv := by rintro ⟨x, y⟩; simp + +@[simp] theorem eval_planeYShearAlgEquiv + (f : MvPolynomial (Fin 2) R) (z : R × R) : + eval ![z.1, z.2] (planeYShearAlgEquiv R f) = + eval ![(planeYShearPointEquiv R z).1, (planeYShearPointEquiv R z).2] f := by + change aeval ![z.1, z.2] (bind₁ (planeYShearSubstitution R) f) = + aeval ![z.1, z.1 + z.2] f + rw [aeval_bind₁] + congr 1 + ext i + fin_cases i <;> simp [planeYShearSubstitution] + +theorem planeYShearAlgEquiv_irreducible_iff + (f : MvPolynomial (Fin 2) R) : + Irreducible (planeYShearAlgEquiv R f) ↔ Irreducible f := by + constructor + · intro h + have h' : Irreducible + ((planeYShearAlgEquiv R).symm (planeYShearAlgEquiv R f)) := + h.map (planeYShearAlgEquiv R).symm.toMulEquiv + simpa only [AlgEquiv.symm_apply_apply] using h' + · intro h + exact h.map (planeYShearAlgEquiv R).toMulEquiv + +/-- Chain rule in the first coordinate for the shear. -/ +theorem pderiv_zero_planeYShearAlgEquiv (f : MvPolynomial (Fin 2) R) : + pderiv 0 (planeYShearAlgEquiv R f) = + planeYShearAlgEquiv R (pderiv 0 f + pderiv 1 f) := by + change pderiv 0 (bind₁ (planeYShearSubstitution R) f) = + bind₁ (planeYShearSubstitution R) (pderiv 0 f + pderiv 1 f) + induction f using MvPolynomial.induction_on with + | C a => simp + | add f g hf hg => simp [hf, hg, map_add]; abel + | mul_X f i hf => + fin_cases i <;> + simp [hf] <;> + ring + +/-- Chain rule in the second coordinate for the shear. -/ +theorem pderiv_one_planeYShearAlgEquiv (f : MvPolynomial (Fin 2) R) : + pderiv 1 (planeYShearAlgEquiv R f) = + planeYShearAlgEquiv R (pderiv 1 f) := by + change pderiv 1 (bind₁ (planeYShearSubstitution R) f) = + bind₁ (planeYShearSubstitution R) (pderiv 1 f) + induction f using MvPolynomial.induction_on with + | C a => simp + | add f g hf hg => simp [hf, hg, map_add] + | mul_X f i hf => + fin_cases i <;> + simp [hf] + +/-- If only the second coordinate is separating, the shear makes both +coordinates separating. -/ +theorem planeYShearAlgEquiv_pderivs_ne_zero_of_zero_ne + (f : MvPolynomial (Fin 2) R) + (hzero : pderiv 0 f = 0) (hne : pderiv 1 f ≠ 0) : + pderiv 0 (planeYShearAlgEquiv R f) ≠ 0 ∧ + pderiv 1 (planeYShearAlgEquiv R f) ≠ 0 := by + have hs : planeYShearAlgEquiv R (pderiv 1 f) ≠ 0 := by + intro hs + apply hne + apply (planeYShearAlgEquiv R).injective + simpa using hs + rw [pderiv_zero_planeYShearAlgEquiv, + pderiv_one_planeYShearAlgEquiv, hzero, zero_add] + exact ⟨hs, hs⟩ + +/-- The shear commutes with extension of coefficients. -/ +theorem map_planeYShearAlgEquiv {S : Type*} [CommRing S] + (φ : R →+* S) (f : MvPolynomial (Fin 2) R) : + map φ (planeYShearAlgEquiv R f) = planeYShearAlgEquiv S (map φ f) := by + rw [planeYShearAlgEquiv_apply, planeYShearAlgEquiv_apply, map_bind₁] + congr 1 + ext i + fin_cases i <;> simp [planeYShearSubstitution] + +/-- The symmetric substitution `(x, y) ↦ (x + y, y)`. -/ +def planeXShearSubstitution : Fin 2 → MvPolynomial (Fin 2) R := + ![X 0 + X 1, X 1] + +/-- The inverse symmetric substitution `(x, y) ↦ (x - y, y)`. -/ +def planeXUnShearSubstitution : Fin 2 → MvPolynomial (Fin 2) R := + ![X 0 - X 1, X 1] + +@[simp] theorem planeXShearSubstitution_zero : + planeXShearSubstitution R 0 = X 0 + X 1 := rfl + +@[simp] theorem planeXShearSubstitution_one : + planeXShearSubstitution R 1 = X 1 := rfl + +def planeXShearHom : MvPolynomial (Fin 2) R →ₐ[R] MvPolynomial (Fin 2) R := + bind₁ (planeXShearSubstitution R) + +def planeXUnShearHom : MvPolynomial (Fin 2) R →ₐ[R] MvPolynomial (Fin 2) R := + bind₁ (planeXUnShearSubstitution R) + +theorem planeXShearHom_comp_planeXUnShearHom : + (planeXShearHom R).comp (planeXUnShearHom R) = AlgHom.id R _ := by + ext i + fin_cases i <;> simp [planeXShearHom, planeXUnShearHom, + planeXShearSubstitution, planeXUnShearSubstitution] + +theorem planeXUnShearHom_comp_planeXShearHom : + (planeXUnShearHom R).comp (planeXShearHom R) = AlgHom.id R _ := by + ext i + fin_cases i <;> simp [planeXShearHom, planeXUnShearHom, + planeXShearSubstitution, planeXUnShearSubstitution] + +/-- The polynomial automorphism induced by `(x, y) ↦ (x + y, y)`. -/ +def planeXShearAlgEquiv : + MvPolynomial (Fin 2) R ≃ₐ[R] MvPolynomial (Fin 2) R := + AlgEquiv.ofAlgHom (planeXShearHom R) (planeXUnShearHom R) + (planeXShearHom_comp_planeXUnShearHom R) + (planeXUnShearHom_comp_planeXShearHom R) + +@[simp] theorem planeXShearAlgEquiv_apply (f : MvPolynomial (Fin 2) R) : + planeXShearAlgEquiv R f = bind₁ (planeXShearSubstitution R) f := rfl + +/-- The symmetric shear on affine points. -/ +def planeXShearPointEquiv : R × R ≃ R × R where + toFun z := (z.1 + z.2, z.2) + invFun z := (z.1 - z.2, z.2) + left_inv := by rintro ⟨x, y⟩; simp + right_inv := by rintro ⟨x, y⟩; simp + +@[simp] theorem eval_planeXShearAlgEquiv + (f : MvPolynomial (Fin 2) R) (z : R × R) : + eval ![z.1, z.2] (planeXShearAlgEquiv R f) = + eval ![(planeXShearPointEquiv R z).1, (planeXShearPointEquiv R z).2] f := by + change aeval ![z.1, z.2] (bind₁ (planeXShearSubstitution R) f) = + aeval ![z.1 + z.2, z.2] f + rw [aeval_bind₁] + congr 1 + ext i + fin_cases i <;> simp [planeXShearSubstitution] + +theorem planeXShearAlgEquiv_irreducible_iff + (f : MvPolynomial (Fin 2) R) : + Irreducible (planeXShearAlgEquiv R f) ↔ Irreducible f := by + constructor + · intro h + have h' : Irreducible + ((planeXShearAlgEquiv R).symm (planeXShearAlgEquiv R f)) := + h.map (planeXShearAlgEquiv R).symm.toMulEquiv + simpa only [AlgEquiv.symm_apply_apply] using h' + · intro h + exact h.map (planeXShearAlgEquiv R).toMulEquiv + +/-- Chain rule in the first coordinate for the symmetric shear. -/ +theorem pderiv_zero_planeXShearAlgEquiv (f : MvPolynomial (Fin 2) R) : + pderiv 0 (planeXShearAlgEquiv R f) = + planeXShearAlgEquiv R (pderiv 0 f) := by + change pderiv 0 (bind₁ (planeXShearSubstitution R) f) = + bind₁ (planeXShearSubstitution R) (pderiv 0 f) + induction f using MvPolynomial.induction_on with + | C a => simp + | add f g hf hg => simp [hf, hg, map_add] + | mul_X f i hf => + fin_cases i <;> simp [hf] + +/-- Chain rule in the second coordinate for the symmetric shear. -/ +theorem pderiv_one_planeXShearAlgEquiv (f : MvPolynomial (Fin 2) R) : + pderiv 1 (planeXShearAlgEquiv R f) = + planeXShearAlgEquiv R (pderiv 0 f + pderiv 1 f) := by + change pderiv 1 (bind₁ (planeXShearSubstitution R) f) = + bind₁ (planeXShearSubstitution R) (pderiv 0 f + pderiv 1 f) + induction f using MvPolynomial.induction_on with + | C a => simp + | add f g hf hg => simp [hf, hg, map_add]; abel + | mul_X f i hf => + fin_cases i <;> simp [hf] <;> ring + +/-- If only the first coordinate is separating, the symmetric shear makes +both coordinates separating. -/ +theorem planeXShearAlgEquiv_pderivs_ne_zero_of_ne_zero + (f : MvPolynomial (Fin 2) R) + (hne : pderiv 0 f ≠ 0) (hzero : pderiv 1 f = 0) : + pderiv 0 (planeXShearAlgEquiv R f) ≠ 0 ∧ + pderiv 1 (planeXShearAlgEquiv R f) ≠ 0 := by + have hs : planeXShearAlgEquiv R (pderiv 0 f) ≠ 0 := by + intro hs + apply hne + apply (planeXShearAlgEquiv R).injective + simpa using hs + rw [pderiv_zero_planeXShearAlgEquiv, + pderiv_one_planeXShearAlgEquiv, hzero, add_zero] + exact ⟨hs, hs⟩ + +/-- The symmetric shear commutes with extension of coefficients. -/ +theorem map_planeXShearAlgEquiv {S : Type*} [CommRing S] + (φ : R →+* S) (f : MvPolynomial (Fin 2) R) : + map φ (planeXShearAlgEquiv R f) = planeXShearAlgEquiv S (map φ f) := by + rw [planeXShearAlgEquiv_apply, planeXShearAlgEquiv_apply, map_bind₁] + congr 1 + ext i + fin_cases i <;> simp [planeXShearSubstitution] + +end + +section AbsoluteIrreducibility + +variable (K : Type*) [Field K] + +/-- Absolute irreducibility is invariant under the coordinate shear. -/ +theorem planeYShearAlgEquiv_absolutelyIrreducible_iff + (f : MvPolynomial (Fin 2) K) : + Irreducible + (map (algebraMap K (AlgebraicClosure K)) (planeYShearAlgEquiv K f)) ↔ + Irreducible (map (algebraMap K (AlgebraicClosure K)) f) := by + rw [map_planeYShearAlgEquiv] + exact planeYShearAlgEquiv_irreducible_iff _ _ + +/-- Absolute irreducibility is invariant under the symmetric shear. -/ +theorem planeXShearAlgEquiv_absolutelyIrreducible_iff + (f : MvPolynomial (Fin 2) K) : + Irreducible + (map (algebraMap K (AlgebraicClosure K)) (planeXShearAlgEquiv K f)) ↔ + Irreducible (map (algebraMap K (AlgebraicClosure K)) f) := by + rw [map_planeXShearAlgEquiv] + exact planeXShearAlgEquiv_irreducible_iff _ _ + +/-- An absolutely irreducible bivariate polynomial over a field of positive +characteristic cannot have both partial derivatives zero. The proof passes +to the algebraic closure, where perfectness turns simultaneous vanishing +into a `p`-th power. -/ +theorem pderiv_zero_ne_zero_or_pderiv_one_ne_zero_of_absolutelyIrreducible + [Finite K] + (f : MvPolynomial (Fin 2) K) + (hirr : Irreducible + (map (algebraMap K (AlgebraicClosure K)) f)) : + pderiv 0 f ≠ 0 ∨ pderiv 1 f ≠ 0 := by + let p := ringChar K + let : Fact p.Prime := ⟨CharP.char_is_prime K p⟩ + by_contra h + rw [not_or] at h + have hzero : pderiv 0 f = 0 := not_ne_iff.mp h.1 + have hone : pderiv 1 f = 0 := not_ne_iff.mp h.2 + have hderivMapped : ∀ i, + pderiv i (map (algebraMap K (AlgebraicClosure K)) f) = 0 := by + intro i + fin_cases i + · rw [pderiv_map] + simpa using congrArg (map (algebraMap K (AlgebraicClosure K))) hzero + · rw [pderiv_map] + simpa using congrArg (map (algebraMap K (AlgebraicClosure K))) hone + exact (not_irreducible_of_forall_pderiv_eq_zero p + (map (algebraMap K (AlgebraicClosure K)) f) hderivMapped) hirr + +/-- For an absolutely irreducible plane polynomial over a finite field, +either both coordinates already separate or one of the two elementary +shears makes both partial derivatives nonzero. -/ +theorem pderivs_ne_zero_or_planeYShear_or_planeXShear_of_absolutelyIrreducible + [Finite K] + (f : MvPolynomial (Fin 2) K) + (hirr : Irreducible + (map (algebraMap K (AlgebraicClosure K)) f)) : + (pderiv 0 f ≠ 0 ∧ pderiv 1 f ≠ 0) ∨ + (pderiv 0 (planeYShearAlgEquiv K f) ≠ 0 ∧ + pderiv 1 (planeYShearAlgEquiv K f) ≠ 0) ∨ + (pderiv 0 (planeXShearAlgEquiv K f) ≠ 0 ∧ + pderiv 1 (planeXShearAlgEquiv K f) ≠ 0) := by + rcases pderiv_zero_ne_zero_or_pderiv_one_ne_zero_of_absolutelyIrreducible + K f hirr with hzero | hone + · by_cases hone' : pderiv 1 f = 0 + · exact Or.inr (Or.inr + (planeXShearAlgEquiv_pderivs_ne_zero_of_ne_zero K f hzero hone')) + · exact Or.inl ⟨hzero, hone'⟩ + · by_cases hzero' : pderiv 0 f = 0 + · exact Or.inr (Or.inl + (planeYShearAlgEquiv_pderivs_ne_zero_of_zero_ne K f hzero' hone)) + · exact Or.inl ⟨hzero', hone⟩ + +end AbsoluteIrreducibility + +section FiniteField + +variable (K : Type*) [Field K] [Fintype K] [DecidableEq K] + +/-- The shear bijects the affine zero sets before and after substitution. -/ +def planeYShearAffineZeroEquiv (f : MvPolynomial (Fin 2) K) : + ↥(BGS.External.affinePlaneCurveZeros K (planeYShearAlgEquiv K f)) ≃ + ↥(BGS.External.affinePlaneCurveZeros K f) := + (planeYShearPointEquiv K).subtypeEquiv fun z => by + simp only [BGS.External.mem_affinePlaneCurveZeros_iff] + exact (eval_planeYShearAlgEquiv K f z).congr_left + +theorem card_affinePlaneCurveZeros_planeYShearAlgEquiv + (f : MvPolynomial (Fin 2) K) : + (BGS.External.affinePlaneCurveZeros K (planeYShearAlgEquiv K f)).card = + (BGS.External.affinePlaneCurveZeros K f).card := by + rw [← Fintype.card_coe, ← Fintype.card_coe] + exact Fintype.card_congr (planeYShearAffineZeroEquiv K f) + +/-- The symmetric shear bijects the affine zero sets. -/ +def planeXShearAffineZeroEquiv (f : MvPolynomial (Fin 2) K) : + ↥(BGS.External.affinePlaneCurveZeros K (planeXShearAlgEquiv K f)) ≃ + ↥(BGS.External.affinePlaneCurveZeros K f) := + (planeXShearPointEquiv K).subtypeEquiv fun z => by + simp only [BGS.External.mem_affinePlaneCurveZeros_iff] + exact (eval_planeXShearAlgEquiv K f z).congr_left + +theorem card_affinePlaneCurveZeros_planeXShearAlgEquiv + (f : MvPolynomial (Fin 2) K) : + (BGS.External.affinePlaneCurveZeros K (planeXShearAlgEquiv K f)).card = + (BGS.External.affinePlaneCurveZeros K f).card := by + rw [← Fintype.card_coe, ← Fintype.card_coe] + exact Fintype.card_congr (planeXShearAffineZeroEquiv K f) + +end FiniteField + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/PlaneCurveGenusBoundAutomatic.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/PlaneCurveGenusBoundAutomatic.lean new file mode 100644 index 0000000000..359114365f --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/PlaneCurveGenusBoundAutomatic.lean @@ -0,0 +1,181 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionGenusBound +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionRiemannRoch +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneConstantField +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneFinitePlaceRiemannLower + +/-! +# Automatic bidegree genus bound for plane curves + +For an absolutely irreducible plane curve with both coordinate projections +separating, the intrinsic genus of its function field is bounded by the bidegree +monomial budget. The proof combines three already formalized ingredients: + +* exactness of the constant field; +* Riemann--Roch for the exhaustive finite-extension divisor model; +* the finite-place bidegree form of Riemann's inequality. + +The finite place needed by the one-point comparison is constructed above the +prime `(X)` of `K[X]`, so it is not an additional hypothesis. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +noncomputable section + +open BGS.CorvajaZannier +open IsDedekindDomain +open scoped Polynomial + +variable (K : Type*) [Field K] [Fintype K] [DecidableEq K] + [DecidableEq (RatFunc K)] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +local instance (priority := 10) automaticGenusPolynomialAlgebra : + Algebra K[X] L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K[X] (RatFunc K))) + +local instance automaticGenusPolynomialTower : + IsScalarTower K[X] (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + +local instance automaticGenusFiniteClosureIntegral : + Algebra.IsIntegral K[X] (RatFuncFiniteIntegralClosure K L) := + IsIntegralClosure.isIntegral_algebra K[X] L + +local instance automaticGenusPolynomialTorsionFree : + Module.IsTorsionFree K[X] L := + Module.IsTorsionFree.trans_faithfulSMul K[X] (RatFunc K) L + +omit [Fintype K] [DecidableEq K] [DecidableEq (RatFunc K)] in +omit [FiniteDimensional (RatFunc K) L] in +/-- A finite separable extension of `K(X)` has an exhaustive finite place. +We select a prime of the finite integral closure lying above `(X)`. -/ +theorem finiteExtensionFinitePlace_nonempty : + Nonempty (FiniteExtensionFinitePlace K L) := by + let p : HeightOneSpectrum K[X] := Polynomial.idealX K + obtain ⟨Q, hQprime, hQcomap⟩ := + Ideal.exists_ideal_over_prime_of_isIntegral_of_isDomain + (S := RatFuncFiniteIntegralClosure K L) p.asIdeal (by + intro x hx + have hxA : algebraMap K[X] (RatFuncFiniteIntegralClosure K L) x = 0 := + (RingHom.mem_ker).mp hx + have hxL : algebraMap K[X] L x = 0 := congrArg Subtype.val hxA + have hx0 : x = 0 := by + exact FaithfulSMul.algebraMap_injective K[X] L (by simpa using hxL) + subst x + exact p.asIdeal.zero_mem) + let P : p.asIdeal.primesOver (RatFuncFiniteIntegralClosure K L) := + ⟨Q, hQprime, ⟨hQcomap.symm⟩⟩ + exact ⟨primeOverHeightOne p P⟩ + +variable {K} + +/-- The function-field genus of an absolutely irreducible plane curve is at +most its bidegree monomial budget + +`(degreeOf 0 f - 1) * (degreeOf 1 f - 1)`. + +This theorem has no Riemann--Roch, constant-field, or place hypothesis: all +three are discharged by the existing formalized theory. -/ +theorem planeCurve_genus_le_bidegreeGenusBudget + {f : MvPolynomial (Fin 2) K} + (habsolute : Irreducible + (MvPolynomial.map (algebraMap K (AlgebraicClosure K)) f)) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) : + let hf : Irreducible f := + irreducible_of_irreducible_map_algebraicClosure habsolute + letI := planeCurveCoordinateRing_isDomain hf + FunctionField.genus K (PlaneCurveFunctionField f) ≤ + planeCurveBidegreeGenusBudget f := by + let hf : Irreducible f := + irreducible_of_irreducible_map_algebraicClosure habsolute + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let L := PlaneCurveFunctionField f + let canonicalAlg : Algebra K L := inferInstance + let : Algebra K L := canonicalAlg + let ratAlg : Algebra (RatFunc K) L := + planeCurveFirstCoordinateRatFuncAlgebra f hx + let : Algebra (RatFunc K) L := ratAlg + let : SMul (RatFunc K) L := ratAlg.toSMul + let : Module (RatFunc K) L := ratAlg.toModule + let : FiniteDimensional (RatFunc K) L := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : Algebra.IsSeparable (RatFunc K) L := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let inducedAlg : Algebra K L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K (RatFunc K))) + have hinducedAlg : inducedAlg = canonicalAlg := by + apply Algebra.algebra_ext + intro c + change (@ratFuncSpecialization K L _ _ canonicalAlg + (planeCurveFunction f 0) hx) (RatFunc.C c) = + @algebraMap K L _ _ canonicalAlg c + have h := DFunLike.congr_fun + (@ratFuncSpecialization_comp_polynomial_algebraMap + K L _ _ canonicalAlg (planeCurveFunction f 0) hx) + (Polynomial.C c) + simpa using h + let : Algebra K L := inducedAlg + let : SMul K L := inducedAlg.toSMul + let : Module K L := inducedAlg.toModule + let : IsScalarTower K (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + let : IsScalarTower K K[X] L := + IsScalarTower.of_algebraMap_eq' rfl + have hconstantsCanonical : + @algebraicClosure K L _ _ canonicalAlg = ⊥ := by + simpa only [L] using + planeCurveFunctionField_algebraicClosure_eq_bot + f habsolute hpartialSecond + have hconstants : algebraicClosure K L = ⊥ := by + change @algebraicClosure K L _ _ inducedAlg = ⊥ + rw [hinducedAlg] + exact hconstantsCanonical + let : FunctionField.IsFullConstantField K L := + (FunctionField.isFullConstantField_iff_algebraicClosure_eq_bot K L).2 + hconstants + let q : FiniteExtensionFinitePlace K L := + Classical.choice (finiteExtensionFinitePlace_nonempty K L) + have hchart : FunctionField.Chart.genus K L ≤ + planeCurveBidegreeGenusBudget f := by + apply genus_le_budget_of_uniformRiemann_onePoint K L + (FunctionField.Chart.genus K L) + (2 * FunctionField.Chart.genus K L) + (planeCurveBidegreeGenusBudget f) (.inl q) + (hasFiniteExtensionUniformEventualRiemannFormula_of_fullConstantField K L) + intro N + simpa only [L] using + planeCurve_finitePlace_riemann_lower + hf hpartialFirst hpartialSecond q N + have hintrinsic : FunctionField.genus K L ≤ + planeCurveBidegreeGenusBudget f := by + rw [FunctionField.genus_eq_genusChart K L] + exact hchart + change @FunctionField.genus K L _ _ canonicalAlg ≤ + planeCurveBidegreeGenusBudget f + change @FunctionField.genus K L _ _ inducedAlg ≤ + planeCurveBidegreeGenusBudget f at hintrinsic + rw [hinducedAlg] at hintrinsic + exact hintrinsic + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/PlaneCurveGenusBoundFromCotrace.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/PlaneCurveGenusBoundFromCotrace.lean new file mode 100644 index 0000000000..90b19ce6cb --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/PlaneCurveGenusBoundFromCotrace.lean @@ -0,0 +1,159 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionCanonicalDifferentLocalMaximality +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneConstantField + +/-! +# Plane-curve genus bound from direct cotrace canonicality + +For an absolutely irreducible plane curve whose second coordinate is +separating, the local cotrace maximality theorem identifies the explicit +different divisor as canonical. The established bidegree estimate for that +divisor therefore gives the intrinsic genus bound without a separately +assumed Riemann--Hurwitz degree identity. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +noncomputable section + +open BGS.CorvajaZannier +open scoped Polynomial + +variable {K : Type*} [Field K] [Fintype K] [DecidableEq K] + [DecidableEq (RatFunc K)] + +/-- The one-separating-coordinate plane-curve genus bound obtained directly +from cotrace canonicality and the explicit different-degree estimate. -/ +theorem planeCurve_genus_le_bidegreeGenusBudget_of_cotrace + {f : MvPolynomial (Fin 2) K} + (habsolute : Irreducible + (MvPolynomial.map (algebraMap K (AlgebraicClosure K)) f)) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (hcardK : MvPolynomial.degreeOf 1 f < Nat.card K) : + let hf : Irreducible f := + irreducible_of_irreducible_map_algebraicClosure habsolute + letI := planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let L := PlaneCurveFunctionField f + let canonicalAlg : Algebra K L := inferInstance + let ratAlg : Algebra (RatFunc K) L := + planeCurveFirstCoordinateRatFuncAlgebra f hx + letI : Algebra (RatFunc K) L := ratAlg + let polynomialAlg : Algebra K[X] L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K[X] (RatFunc K))) + letI : Algebra K[X] L := polynomialAlg + letI : SMul K[X] L := polynomialAlg.toSMul + letI : Module K[X] L := polynomialAlg.toModule + letI : IsScalarTower K[X] (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + let inducedAlg : Algebra K L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K (RatFunc K))) + letI : Algebra K L := inducedAlg + letI : SMul K L := inducedAlg.toSMul + letI : Module K L := inducedAlg.toModule + letI : IsScalarTower K (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + letI : IsScalarTower K K[X] L := + IsScalarTower.of_algebraMap_eq' rfl + letI : FiniteDimensional (RatFunc K) L := + finiteDimensional_planeCurveFunctionField_over_ratFunc + hf hpartialSecond + letI : Algebra.IsSeparable (RatFunc K) L := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + @FunctionField.genus K L _ _ canonicalAlg ≤ + planeCurveBidegreeGenusBudget f := by + let hf : Irreducible f := + irreducible_of_irreducible_map_algebraicClosure habsolute + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let L := PlaneCurveFunctionField f + let canonicalAlg : Algebra K L := inferInstance + let ratAlg : Algebra (RatFunc K) L := + planeCurveFirstCoordinateRatFuncAlgebra f hx + let : Algebra (RatFunc K) L := ratAlg + let : SMul (RatFunc K) L := ratAlg.toSMul + let : Module (RatFunc K) L := ratAlg.toModule + let polynomialAlg : Algebra K[X] L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K[X] (RatFunc K))) + let : Algebra K[X] L := polynomialAlg + let : SMul K[X] L := polynomialAlg.toSMul + let : Module K[X] L := polynomialAlg.toModule + let : IsScalarTower K[X] (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + let : FiniteDimensional (RatFunc K) L := + finiteDimensional_planeCurveFunctionField_over_ratFunc + hf hpartialSecond + let : Algebra.IsSeparable (RatFunc K) L := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let inducedAlg : Algebra K L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K (RatFunc K))) + have hinducedAlg : inducedAlg = canonicalAlg := by + apply Algebra.algebra_ext + intro c + change (@ratFuncSpecialization K L _ _ canonicalAlg + (planeCurveFunction f 0) hx) (RatFunc.C c) = + @algebraMap K L _ _ canonicalAlg c + have h := DFunLike.congr_fun + (@ratFuncSpecialization_comp_polynomial_algebraMap + K L _ _ canonicalAlg (planeCurveFunction f 0) hx) + (Polynomial.C c) + simpa using h + let : Algebra K L := inducedAlg + let : SMul K L := inducedAlg.toSMul + let : Module K L := inducedAlg.toModule + let : IsScalarTower K (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + let : IsScalarTower K K[X] L := + IsScalarTower.of_algebraMap_eq' rfl + have hconstantsCanonical : + @algebraicClosure K L _ _ canonicalAlg = ⊥ := by + simpa only [L] using + planeCurveFunctionField_algebraicClosure_eq_bot + f habsolute hpartialSecond + have hconstants : algebraicClosure K L = ⊥ := by + change @algebraicClosure K L _ _ inducedAlg = ⊥ + rw [hinducedAlg] + exact hconstantsCanonical + let : FunctionField.IsFullConstantField K L := + (FunctionField.isFullConstantField_iff_algebraicClosure_eq_bot K L).2 + hconstants + have hcardK' : MvPolynomial.degreeOf 1 f < Fintype.card K := by + simpa only [Nat.card_eq_fintype_card] using hcardK + have hdegreeLe : + finiteExtensionDivisorDegree K L + (finiteExtensionCanonicalDifferentDivisor K L + (finiteExtensionFiniteDifferentIdeal_ne_bot K L)) ≤ + 2 * (planeCurveBidegreeGenusBudget f : ℤ) - 2 := by + simpa only [L] using + planeCurve_canonicalDifferentDivisor_degree_le_two_genusBudget_sub_two + hf hpartialSecond hcardK' + have hgenus : FunctionField.genus K L ≤ + planeCurveBidegreeGenusBudget f := + finiteExtension_genus_le_budget_of_cotrace + K L (planeCurveBidegreeGenusBudget f) hdegreeLe + change @FunctionField.genus K L _ _ canonicalAlg ≤ + planeCurveBidegreeGenusBudget f + change @FunctionField.genus K L _ _ inducedAlg ≤ + planeCurveBidegreeGenusBudget f at hgenus + rw [hinducedAlg] at hgenus + exact hgenus + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/PlaneCurveGenusBoundFromCotraceDegree.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/PlaneCurveGenusBoundFromCotraceDegree.lean new file mode 100644 index 0000000000..37145ae49b --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/PlaneCurveGenusBoundFromCotraceDegree.lean @@ -0,0 +1,174 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionCanonicalDifferentCotraceCanonicality +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionCanonicalDifferentGenusBound +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneConstantField + +/-! +# Plane-curve genus bound from the cotrace divisor + +For an absolutely irreducible plane curve with the second coordinate +separating, the cotrace construction and the explicit bidegree estimate reduce +the intrinsic genus bound to the Riemann--Hurwitz degree identity for the +canonical-different divisor. The identity remains a visible premise here. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +noncomputable section + +open BGS.CorvajaZannier +open scoped Polynomial + +variable {K : Type*} [Field K] [Fintype K] [DecidableEq K] + [DecidableEq (RatFunc K)] + +/-- The one-separating-coordinate plane-curve genus bound, conditional only +on the displayed Riemann--Hurwitz degree identity for the cotrace divisor. + +Absolute irreducibility supplies the exact constant field, while +`planeCurve_canonicalDifferentDivisor_degree_le_two_genusBudget_sub_two` +supplies the required degree upper bound. -/ +theorem planeCurve_genus_le_bidegreeGenusBudget_of_cotrace_degree_eq + {f : MvPolynomial (Fin 2) K} + (habsolute : Irreducible + (MvPolynomial.map (algebraMap K (AlgebraicClosure K)) f)) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (hcardK : MvPolynomial.degreeOf 1 f < Fintype.card K) : + let hf : Irreducible f := + irreducible_of_irreducible_map_algebraicClosure habsolute + letI := planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let L := PlaneCurveFunctionField f + let canonicalAlg : Algebra K L := inferInstance + let ratAlg : Algebra (RatFunc K) L := + planeCurveFirstCoordinateRatFuncAlgebra f hx + letI : Algebra (RatFunc K) L := ratAlg + let polynomialAlg : Algebra K[X] L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K[X] (RatFunc K))) + letI : Algebra K[X] L := polynomialAlg + letI : SMul K[X] L := polynomialAlg.toSMul + letI : Module K[X] L := polynomialAlg.toModule + letI : IsScalarTower K[X] (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + let inducedAlg : Algebra K L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K (RatFunc K))) + letI : Algebra K L := inducedAlg + letI : SMul K L := inducedAlg.toSMul + letI : Module K L := inducedAlg.toModule + letI : IsScalarTower K (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + letI : IsScalarTower K K[X] L := + IsScalarTower.of_algebraMap_eq' rfl + letI : FiniteDimensional (RatFunc K) L := + finiteDimensional_planeCurveFunctionField_over_ratFunc + hf hpartialSecond + letI : Algebra.IsSeparable (RatFunc K) L := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + finiteExtensionDivisorDegree K L + (finiteExtensionCanonicalDifferentDivisor K L + (finiteExtensionFiniteDifferentIdeal_ne_bot K L)) = + 2 * (FunctionField.genus K L : ℤ) - 2 → + @FunctionField.genus K L _ _ canonicalAlg ≤ + planeCurveBidegreeGenusBudget f := by + let hf : Irreducible f := + irreducible_of_irreducible_map_algebraicClosure habsolute + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let L := PlaneCurveFunctionField f + let canonicalAlg : Algebra K L := inferInstance + let ratAlg : Algebra (RatFunc K) L := + planeCurveFirstCoordinateRatFuncAlgebra f hx + let : Algebra (RatFunc K) L := ratAlg + let : SMul (RatFunc K) L := ratAlg.toSMul + let : Module (RatFunc K) L := ratAlg.toModule + let polynomialAlg : Algebra K[X] L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K[X] (RatFunc K))) + let : Algebra K[X] L := polynomialAlg + let : SMul K[X] L := polynomialAlg.toSMul + let : Module K[X] L := polynomialAlg.toModule + let : IsScalarTower K[X] (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + let : FiniteDimensional (RatFunc K) L := + finiteDimensional_planeCurveFunctionField_over_ratFunc + hf hpartialSecond + let : Algebra.IsSeparable (RatFunc K) L := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let inducedAlg : Algebra K L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K (RatFunc K))) + have hinducedAlg : inducedAlg = canonicalAlg := by + apply Algebra.algebra_ext + intro c + change (@ratFuncSpecialization K L _ _ canonicalAlg + (planeCurveFunction f 0) hx) (RatFunc.C c) = + @algebraMap K L _ _ canonicalAlg c + have h := DFunLike.congr_fun + (@ratFuncSpecialization_comp_polynomial_algebraMap + K L _ _ canonicalAlg (planeCurveFunction f 0) hx) + (Polynomial.C c) + simpa using h + let : Algebra K L := inducedAlg + let : SMul K L := inducedAlg.toSMul + let : Module K L := inducedAlg.toModule + let : IsScalarTower K (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + let : IsScalarTower K K[X] L := + IsScalarTower.of_algebraMap_eq' rfl + dsimp only + intro hdegreeEq + have hconstantsCanonical : + @algebraicClosure K L _ _ canonicalAlg = ⊥ := by + simpa only [L] using + planeCurveFunctionField_algebraicClosure_eq_bot + f habsolute hpartialSecond + have hconstants : algebraicClosure K L = ⊥ := by + change @algebraicClosure K L _ _ inducedAlg = ⊥ + rw [hinducedAlg] + exact hconstantsCanonical + let : FunctionField.IsFullConstantField K L := + (FunctionField.isFullConstantField_iff_algebraicClosure_eq_bot K L).2 + hconstants + have hdegreeEqChart : + finiteExtensionDivisorDegree K L + (finiteExtensionCanonicalDifferentDivisor K L + (finiteExtensionFiniteDifferentIdeal_ne_bot K L)) = + 2 * (FunctionField.Chart.genus K L : ℤ) - 2 := by + rw [← FunctionField.genus_eq_genusChart K L] + exact hdegreeEq + have hdegreeLe : + finiteExtensionDivisorDegree K L + (finiteExtensionCanonicalDifferentDivisor K L + (finiteExtensionFiniteDifferentIdeal_ne_bot K L)) ≤ + 2 * (planeCurveBidegreeGenusBudget f : ℤ) - 2 := by + simpa only [L] using + planeCurve_canonicalDifferentDivisor_degree_le_two_genusBudget_sub_two + hf hpartialSecond hcardK + have hgenus : FunctionField.genus K L ≤ + planeCurveBidegreeGenusBudget f := + finiteExtension_genus_le_budget_of_cotrace_and_degree_eq + K L (planeCurveBidegreeGenusBudget f) hdegreeEqChart hdegreeLe + change @FunctionField.genus K L _ _ canonicalAlg ≤ + planeCurveBidegreeGenusBudget f + change @FunctionField.genus K L _ _ inducedAlg ≤ + planeCurveBidegreeGenusBudget f at hgenus + rw [hinducedAlg] at hgenus + exact hgenus + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/PlaneFinitePlaceRiemannLower.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/PlaneFinitePlaceRiemannLower.lean new file mode 100644 index 0000000000..f7221be7fd --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/PlaneFinitePlaceRiemannLower.lean @@ -0,0 +1,458 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.FinitePlaceApproximation +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionLocalPoleQuotient +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneInfinityRiemannLower +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionPrincipalParts +public import Mathlib.Tactic + +/-! +# Riemann's inequality at finite plane-curve places + +Weak approximation lifts a basis of the principal parts at one finite place +to global functions regular at every other finite place. A common effective +divisor above infinity absorbs the remaining poles. The resulting +principal-part map is surjective, so rank-nullity contributes exactly +`N * degree(q)` new dimensions over the infinity-supported Riemann space. + +The infinity-supported bidegree Riemann inequality and the effective-divisor +increment upper bound then cancel the auxiliary infinity divisor. This gives +Riemann's inequality for `L(N q)` at every finite exhaustive place. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +open BGS.CorvajaZannier +open IsDedekindDomain +open scoped nonZeroDivisors Polynomial BigOperators + +noncomputable section + + +variable (K : Type*) [Field K] [Fintype K] [DecidableEq K] + [DecidableEq (RatFunc K)] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +local instance finiteRiemannConstantAlgebra : Algebra K L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K (RatFunc K))) + +local instance finiteRiemannConstantTower : IsScalarTower K (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + +local instance (priority := 10) finiteRiemannPolynomialAlgebra : Algebra K[X] L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K[X] (RatFunc K))) + +local instance finiteRiemannPolynomialTower : IsScalarTower K[X] (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + +local instance finiteRiemannClosureIntegral : + Algebra.IsIntegral K[X] (RatFuncFiniteIntegralClosure K L) := + IsIntegralClosure.isIntegral_algebra K[X] L + +local instance finiteRiemannClosureModuleFinite : + Module.Finite K[X] (RatFuncFiniteIntegralClosure K L) := + Module.IsNoetherian.finite K[X] (RatFuncFiniteIntegralClosure K L) + +local instance finiteRiemannPolynomialTorsionFree : + Module.IsTorsionFree K[X] L := + Module.IsTorsionFree.trans_faithfulSMul K[X] (RatFunc K) L + +local instance finiteRiemannClosureTorsionFree : + Module.IsTorsionFree K[X] (RatFuncFiniteIntegralClosure K L) := + IsIntegralClosure.isTorsionFree K[X] L + +local instance finiteRiemannClosureDedekind : + IsDedekindDomain (RatFuncFiniteIntegralClosure K L) := + IsIntegralClosure.isDedekindDomain K[X] (RatFunc K) L + (RatFuncFiniteIntegralClosure K L) + +local instance finiteRiemannClosureFractionRing : + IsFractionRing (RatFuncFiniteIntegralClosure K L) L := + IsIntegralClosure.isFractionRing_of_finite_extension + K[X] (RatFunc K) L (RatFuncFiniteIntegralClosure K L) + +theorem mem_finiteExtensionLocalPoleSpace_zero_of_valuation_le_one + (q : FiniteExtensionFinitePlace K L) (x : L) + (hx : q.valuation L x ≤ 1) : + x ∈ finiteExtensionLocalPoleSpace K L (.inl q) 0 := by + rw [mem_finiteExtensionLocalPoleSpace_iff] + by_cases hx0 : x = 0 + · exact Or.inl hx0 + · refine Or.inr ⟨hx0, ?_⟩ + rw [finiteExtensionPrincipalDivisor_inl_eq_finitePlaceOrder] + rw [valuation_eq_exp_neg_finitePlaceOrder q x hx0, ← WithZero.exp_zero, + WithZero.exp_le_exp] at hx + omega + +theorem exists_global_finitePrincipalPart_representative + (q : FiniteExtensionFinitePlace K L) (N : ℕ) + (p : finiteExtensionLocalPoleSpace K L (.inl q) N ⧸ + relativeSubmodule + (finiteExtensionLocalPoleSpace K L (.inl q) 0) + (finiteExtensionLocalPoleSpace K L (.inl q) N)) : + ∃ z : finiteExtensionLocalPoleSpace K L (.inl q) N, + Submodule.Quotient.mk z = p ∧ + ∀ q' : FiniteExtensionFinitePlace K L, q' ≠ q → + (z : L) ∈ finiteExtensionLocalPoleSpace K L (.inl q') 0 := by + classical + obtain ⟨x, hxmk⟩ := + (Submodule.Quotient.mk_surjective + (relativeSubmodule + (finiteExtensionLocalPoleSpace K L (.inl q) 0) + (finiteExtensionLocalPoleSpace K L (.inl q) N))) p + let selected : Finset (Ideal (RatFuncFiniteIntegralClosure K L)) := + {q.asIdeal} + let target : Ideal (RatFuncFiniteIntegralClosure K L) → L := fun Q => + if Q = q.asIdeal then (x : L) else 0 + obtain ⟨z, happrox, hregular⟩ := + exists_fraction_approximating_at_finitePlaces_regular_elsewhere + selected (by + intro P hP + simp only [selected, Finset.mem_singleton] at hP + subst P + exact (Ideal.prime_iff_isPrime q.ne_bot).mpr q.isPrime) target + (fun _ => 0) + have hzsub : z - (x : L) ∈ + finiteExtensionLocalPoleSpace K L (.inl q) 0 := by + apply mem_finiteExtensionLocalPoleSpace_zero_of_valuation_le_one K L + have h := happrox q (by simp [selected]) + simpa only [target, ite_eq_left rfl, CharP.cast_eq_zero, neg_zero, + WithZero.exp_zero] using h + have hzMem : z ∈ finiteExtensionLocalPoleSpace K L (.inl q) N := by + have hxMem : (x : L) ∈ finiteExtensionLocalPoleSpace K L (.inl q) N := x.2 + have hzeroLe := finiteExtensionLocalPoleSpace_mono K L (.inl q) + (Nat.zero_le N) + have hsubMem := hzeroLe hzsub + have hadd := (finiteExtensionLocalPoleSpace K L (.inl q) N).add_mem + hxMem hsubMem + rw [show (x : L) + (z - (x : L)) = z by abel] at hadd + exact hadd + refine ⟨⟨z, hzMem⟩, ?_, ?_⟩ + · rw [← hxmk] + rw [Submodule.Quotient.eq] + change z - (x : L) ∈ + finiteExtensionLocalPoleSpace K L (.inl q) 0 + exact hzsub + · intro q' hq' + apply mem_finiteExtensionLocalPoleSpace_zero_of_valuation_le_one K L + apply hregular q' + simp only [selected, Finset.mem_singleton] + intro hideal + apply hq' + exact HeightOneSpectrum.ext hideal + +/-- The part of an exhaustive divisor supported at infinity. -/ +def finiteExtensionDivisorInfinityPart + (D : FiniteExtensionDivisor K L) : FiniteExtensionDivisor K L := by + classical + exact Finsupp.filter (fun v => match v with + | .inl _ => False + | .inr _ => True) D + +omit [Fintype K] [DecidableEq K] [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] in +@[simp] +theorem finiteExtensionDivisorInfinityPart_inl + (D : FiniteExtensionDivisor K L) + (q : FiniteExtensionFinitePlace K L) : + finiteExtensionDivisorInfinityPart K L D (.inl q) = 0 := by + simp [finiteExtensionDivisorInfinityPart] + +omit [Fintype K] [DecidableEq K] [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] in +@[simp] +theorem finiteExtensionDivisorInfinityPart_inr + (D : FiniteExtensionDivisor K L) + (P : FiniteExtensionInfinityPlace K L) : + finiteExtensionDivisorInfinityPart K L D (.inr P) = D (.inr P) := by + simp [finiteExtensionDivisorInfinityPart] + +theorem exists_infinityDivisor_finitePlacePrincipalParts_rank + (q : FiniteExtensionFinitePlace K L) (N : ℕ) (hN : 0 < N) : + ∃ E : FiniteExtensionDivisor K L, + (∀ v, 0 ≤ E v) ∧ + (∀ q' : FiniteExtensionFinitePlace K L, E (.inl q') = 0) ∧ + Module.finrank K (finiteExtensionRiemannSpace K L E) + + N * finiteExtensionPlaceDegree K L (.inl q) ≤ + Module.finrank K (finiteExtensionRiemannSpace K L + (Finsupp.single (.inl q) (N : ℤ) + E)) := by + classical + let A := finiteExtensionLocalPoleSpace K L (.inl q) N + let A0 := finiteExtensionLocalPoleSpace K L (.inl q) 0 + let PP := A ⧸ relativeSubmodule A0 A + have hPPfinrank : Module.finrank K PP = + N * finiteExtensionPlaceDegree K L (.inl q) := by + simpa only [A, A0, PP] using + finiteExtensionLocalPoleSpace_inl_cumulative_finrank K L q N + let : Module.Finite K PP := by + apply Module.finite_of_finrank_pos + rw [hPPfinrank] + exact Nat.mul_pos hN (finiteExtensionPlaceDegree_pos K L (.inl q)) + let b := Module.finBasis K PP + have hzExists (i : Fin (Module.finrank K PP)) := + exists_global_finitePrincipalPart_representative K L q N (b i) + let z : Fin (Module.finrank K PP) → A := fun i => + Classical.choose (hzExists i) + have hzmk (i : Fin (Module.finrank K PP)) : + Submodule.Quotient.mk (z i) = b i := + (Classical.choose_spec (hzExists i)).1 + have hzregular (i : Fin (Module.finrank K PP)) + (q' : FiniteExtensionFinitePlace K L) (hq' : q' ≠ q) : + (z i : L) ∈ finiteExtensionLocalPoleSpace K L (.inl q') 0 := + (Classical.choose_spec (hzExists i)).2 q' hq' + have hzNe (i : Fin (Module.finrank K PP)) : (z i : L) ≠ 0 := by + intro hzero + have hzSubtype : z i = 0 := Subtype.ext hzero + have hmk := hzmk i + rw [hzSubtype] at hmk + exact b.linearIndependent.ne_zero i (by simpa using hmk.symm) + let H : FiniteExtensionDivisor K L := + ∑ i, finiteExtensionPoleDivisor K L (z i : L) + have hH : (0 : FiniteExtensionDivisor K L) ≤ H := by + dsimp only [H] + apply Finset.sum_nonneg + intro i _ v + exact finiteExtensionPoleDivisor_effective K L (z i : L) v + have hPoleLeH (i : Fin (Module.finrank K PP)) : + finiteExtensionPoleDivisor K L (z i : L) ≤ H := by + dsimp only [H] + calc + finiteExtensionPoleDivisor K L (z i : L) ≤ + finiteExtensionPoleDivisor K L (z i : L) + + ∑ j ∈ Finset.univ.erase i, + finiteExtensionPoleDivisor K L (z j : L) := + le_add_of_nonneg_right (Finset.sum_nonneg fun j _ v => + finiteExtensionPoleDivisor_effective K L (z j : L) v) + _ = ∑ j, finiteExtensionPoleDivisor K L (z j : L) := by + rw [add_comm, Finset.sum_erase_add _ _ (Finset.mem_univ i)] + let E : FiniteExtensionDivisor K L := + finiteExtensionDivisorInfinityPart K L H + have hE : ∀ v, 0 ≤ E v := by + intro v + rcases v with q' | P + · simp [E] + · simp only [E, finiteExtensionDivisorInfinityPart_inr, H] + exact hH (.inr P) + have hEfinite : ∀ q' : FiniteExtensionFinitePlace K L, + E (.inl q') = 0 := by + intro q' + simp [E] + let D : FiniteExtensionDivisor K L := + Finsupp.single (.inl q) (N : ℤ) + E + have hD : ∀ v, 0 ≤ D v := by + intro v + exact add_nonneg (by + by_cases hv : v = (.inl q : FiniteExtensionPlace K L) + · subst v + simp + · simp [Finsupp.single_eq_of_ne hv]) (hE v) + have hzPoleLe (i : Fin (Module.finrank K PP)) : + finiteExtensionPoleDivisor K L (z i : L) ≤ D := by + intro v + rcases v with q' | P + · by_cases hq' : q' = q + · subst q' + have hzOrder : -(N : ℤ) ≤ + finiteExtensionPrincipalDivisor K L (z i : L) (.inl q) := by + have hzmem := (z i).2 + rw [mem_finiteExtensionLocalPoleSpace_iff] at hzmem + rcases hzmem with hzero | ⟨_, horder⟩ + · exact (hzNe i hzero).elim + · exact horder + rw [finiteExtensionPoleDivisor_apply] + by_cases hneg : + finiteExtensionPrincipalDivisor K L (z i : L) (.inl q) < 0 + · rw [ite_eq_left hneg] + simp only [D, Finsupp.add_apply, Finsupp.single_eq_same, + hEfinite q, add_zero] + omega + · rw [ite_eq_right hneg] + exact hD (.inl q) + · have hzreg := hzregular i q' hq' + rw [mem_finiteExtensionLocalPoleSpace_iff] at hzreg + have hzOrder : 0 ≤ + finiteExtensionPrincipalDivisor K L (z i : L) (.inl q') := by + rcases hzreg with hzero | ⟨_, horder⟩ + · exact (hzNe i hzero).elim + · simpa using horder + rw [finiteExtensionPoleDivisor_apply, ite_eq_right (not_lt_of_ge hzOrder)] + exact hD (.inl q') + · simp only [D, Finsupp.add_apply, + Finsupp.single_eq_of_ne (by simp : + (Sum.inr P : FiniteExtensionPlace K L) ≠ Sum.inl q), + zero_add, E, finiteExtensionDivisorInfinityPart_inr, H] + exact hPoleLeH i (.inr P) + have hzD (i : Fin (Module.finrank K PP)) : + (z i : L) ∈ finiteExtensionRiemannSpace K L D := by + apply finiteExtensionRiemannSpace_mono K L (hzPoleLe i) + exact mem_finiteExtensionRiemannSpace_poleDivisor K L + (z i : L) (hzNe i) + have hDq : D (.inl q) = N := by + simp [D, hEfinite] + have hlocal (x : finiteExtensionRiemannSpace K L D) : + (x : L) ∈ A := by + have hx := finiteExtensionRiemannSpace_le_localPoleSpace K L D hD + (.inl q) x.2 + simpa only [A, hDq, Int.toNat_natCast] using hx + let toLocal : finiteExtensionRiemannSpace K L D →ₗ[K] A := + LinearMap.codRestrict A + (finiteExtensionRiemannSpace K L D).subtype hlocal + let φ : finiteExtensionRiemannSpace K L D →ₗ[K] PP := + (relativeSubmodule A0 A).mkQ.comp toLocal + have hφz (i : Fin (Module.finrank K PP)) : + φ ⟨(z i : L), hzD i⟩ = b i := by + change Submodule.Quotient.mk (z i) = b i + exact hzmk i + have hφsurj : Function.Surjective φ := by + intro p + let w : finiteExtensionRiemannSpace K L D := + ∑ i, (b.repr p) i • ⟨(z i : L), hzD i⟩ + refine ⟨w, ?_⟩ + simp only [w, map_sum, map_smul, hφz] + exact b.sum_repr p + have hED : E ≤ D := by + intro v + exact le_add_of_nonneg_left (by + by_cases hv : v = (.inl q : FiniteExtensionPlace K L) + · subst v + simp + · simp [Finsupp.single_eq_of_ne hv]) + let incl : finiteExtensionRiemannSpace K L E →ₗ[K] + finiteExtensionRiemannSpace K L D := + Submodule.inclusion (finiteExtensionRiemannSpace_mono K L hED) + have hinclKer (x : finiteExtensionRiemannSpace K L E) : incl x ∈ φ.ker := by + rw [LinearMap.mem_ker] + change Submodule.Quotient.mk (toLocal (incl x)) = 0 + rw [Submodule.Quotient.mk_eq_zero] + change (x : L) ∈ A0 + have hx := finiteExtensionRiemannSpace_le_localPoleSpace K L E hE + (.inl q) x.2 + simpa only [A0, hEfinite q, Int.toNat_zero] using hx + let inclKer : finiteExtensionRiemannSpace K L E →ₗ[K] φ.ker := + LinearMap.codRestrict φ.ker incl hinclKer + have hinclKerInjective : Function.Injective inclKer := by + intro x y hxy + apply Subtype.ext + exact congrArg (fun w : φ.ker => ((w : finiteExtensionRiemannSpace K L D) : L)) hxy + let : Module.Finite K (finiteExtensionRiemannSpace K L D) := + finiteExtensionRiemannSpace_effective_moduleFinite K L D hD + have hkerLower : Module.finrank K (finiteExtensionRiemannSpace K L E) ≤ + Module.finrank K φ.ker := + inclKer.finrank_le_finrank_of_injective hinclKerInjective + have hrank := φ.finrank_range_add_finrank_ker + have hrange : Module.finrank K φ.range = Module.finrank K PP := by + rw [LinearMap.range_eq_top.mpr hφsurj] + simp + refine ⟨E, hE, hEfinite, ?_⟩ + change Module.finrank K (finiteExtensionRiemannSpace K L E) + + N * finiteExtensionPlaceDegree K L (.inl q) ≤ + Module.finrank K (finiteExtensionRiemannSpace K L D) + rw [← hPPfinrank, ← hrange] + omega + +end + +noncomputable section + +variable (K : Type*) [Field K] [Fintype K] [DecidableEq K] + [DecidableEq (RatFunc K)] + +variable {K} + +/-- Bidegree Riemann inequality at an arbitrary finite exhaustive place of +an irreducible plane curve. -/ +theorem planeCurve_finitePlace_riemann_lower + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) : + letI := planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + letI := planeCurveFirstCoordinateRatFuncAlgebra f hx + letI := finiteDimensional_planeCurveFunctionField_over_ratFunc + hf hpartialSecond + letI := separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + ∀ (q : FiniteExtensionFinitePlace K (PlaneCurveFunctionField f)) (N : ℕ), + N * finiteExtensionPlaceDegree K (PlaneCurveFunctionField f) (.inl q) + 1 ≤ + Module.finrank K (finiteExtensionOnePointRiemannSpace K + (PlaneCurveFunctionField f) (.inl q) N) + + planeCurveBidegreeGenusBudget f := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let L := PlaneCurveFunctionField f + let g := planeCurveBidegreeGenusBudget f + let : Algebra (RatFunc K) L := + planeCurveFirstCoordinateRatFuncAlgebra f hx + let : FiniteDimensional (RatFunc K) L := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : Algebra.IsSeparable (RatFunc K) L := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let constantAlg : Algebra K L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K (RatFunc K))) + let : Algebra K L := constantAlg + let : SMul K L := constantAlg.toSMul + let : Module K L := constantAlg.toModule + let : IsScalarTower K (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + dsimp only + intro q N + by_cases hN : N = 0 + · subst N + have hzero := planeCurve_infinitySupported_riemann_lower + hf hpartialFirst hpartialSecond + (0 : FiniteExtensionDivisor K L) (by simp) (by simp) + have hdegreezero : + finiteExtensionDivisorDegree K L (0 : FiniteExtensionDivisor K L) = 0 := by + simp [finiteExtensionDivisorDegree] + rw [hdegreezero] at hzero + simp only [Int.toNat_zero, zero_add] at hzero + simp only [zero_mul, zero_add] + change 1 ≤ Module.finrank K + (finiteExtensionRiemannSpace K L (Finsupp.single (.inl q) 0)) + g + rw [Finsupp.single_zero] + simpa only [L, g] using hzero + · have hNpos : 0 < N := Nat.pos_of_ne_zero hN + obtain ⟨E, hE, hEfinite, hrank⟩ := + exists_infinityDivisor_finitePlacePrincipalParts_rank K L q N hNpos + have hinfinity : + (finiteExtensionDivisorDegree K L E).toNat + 1 ≤ + Module.finrank K (finiteExtensionRiemannSpace K L E) + g := by + simpa only [L, g] using + (planeCurve_infinitySupported_riemann_lower + hf hpartialFirst hpartialSecond E hE hEfinite) + let Dq : FiniteExtensionDivisor K L := + Finsupp.single (.inl q) (N : ℤ) + have hDq : ∀ v, 0 ≤ Dq v := by + intro v + by_cases hv : v = (.inl q : FiniteExtensionPlace K L) + · subst v + simp [Dq] + · simp [Dq, Finsupp.single_eq_of_ne hv] + let : Module.Finite K (finiteExtensionRiemannSpace K L Dq) := + finiteExtensionRiemannSpace_effective_moduleFinite K L Dq hDq + have hstrip := finiteExtensionRiemannSpace_add_effective + K L Dq E hDq hE + change N * finiteExtensionPlaceDegree K L (.inl q) + 1 ≤ + Module.finrank K (finiteExtensionRiemannSpace K L Dq) + g + have hDqEq : Dq = Finsupp.single (.inl q) (N : ℤ) := rfl + rw [← hDqEq] at hrank + omega + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/PlaneFrobeniusDeflation.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/PlaneFrobeniusDeflation.lean new file mode 100644 index 0000000000..502f387a3f --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/PlaneFrobeniusDeflation.lean @@ -0,0 +1,421 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneCoordinateShear +public import Mathlib.Algebra.MvPolynomial.Equiv +public import Mathlib.Algebra.Polynomial.Expand +public import Mathlib.Tactic + +/-! +# Frobenius deflation for affine plane curves + +If the first partial derivative vanishes in characteristic `p`, every first +coordinate exponent is divisible by `p`. This module contracts those +exponents, proves that substitution `X₀ ↦ X₀^p` reconstructs the original +polynomial, and records the exact invariants needed by the affine +Hasse--Weil reduction: absolute irreducibility, the other partial derivative, +the supplied bidegree bound, and the finite-field affine point count. + +Unlike a coordinate shear, this operation does not enlarge the other +coordinate degree, and it strictly lowers the actual first coordinate degree +whenever that degree is positive. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +open MvPolynomial + +noncomputable section + +variable (R : Type*) [CommRing R] + +/-- Substitute `X₀^p` for `X₀`, leaving `X₁` unchanged. -/ +def planeFirstInflateSubstitution (p : ℕ) : + Fin 2 → MvPolynomial (Fin 2) R := + ![X 0 ^ p, X 1] + +/-- The one-coordinate Frobenius expansion homomorphism. -/ +def planeFirstInflateHom (p : ℕ) : + MvPolynomial (Fin 2) R →ₐ[R] MvPolynomial (Fin 2) R := + bind₁ (planeFirstInflateSubstitution R p) + +@[simp] theorem planeFirstInflateHom_C (p : ℕ) (r : R) : + planeFirstInflateHom R p (C r) = C r := by + simp [planeFirstInflateHom] + +@[simp] theorem planeFirstInflateHom_X_zero (p : ℕ) : + planeFirstInflateHom R p (X 0) = X 0 ^ p := by + simp [planeFirstInflateHom, planeFirstInflateSubstitution] + +@[simp] theorem planeFirstInflateHom_X_one (p : ℕ) : + planeFirstInflateHom R p (X 1) = X 1 := by + simp [planeFirstInflateHom, planeFirstInflateSubstitution] + +theorem finSuccEquiv_planeFirstInflateHom (p : ℕ) + (f : MvPolynomial (Fin 2) R) : + MvPolynomial.finSuccEquiv R 1 (planeFirstInflateHom R p f) = + Polynomial.expand (MvPolynomial (Fin 1) R) p + (MvPolynomial.finSuccEquiv R 1 f) := by + let lhs : MvPolynomial (Fin 2) R →ₐ[R] + Polynomial (MvPolynomial (Fin 1) R) := + (MvPolynomial.finSuccEquiv R 1).toAlgHom.comp + (planeFirstInflateHom R p) + let rhs : MvPolynomial (Fin 2) R →ₐ[R] + Polynomial (MvPolynomial (Fin 1) R) := + ((Polynomial.expand (MvPolynomial (Fin 1) R) p).restrictScalars R).comp + (MvPolynomial.finSuccEquiv R 1).toAlgHom + change lhs f = rhs f + apply DFunLike.congr_fun + apply MvPolynomial.algHom_ext + exact Fin.forall_fin_two.2 ⟨ + by simp [lhs, rhs, planeFirstInflateHom, + planeFirstInflateSubstitution, MvPolynomial.finSuccEquiv_apply], + by + have hcases : + Fin.cases + (Polynomial.X : Polynomial (MvPolynomial (Fin 1) R)) + (fun k : Fin 1 => Polynomial.C + (X k : MvPolynomial (Fin 1) R)) + (1 : Fin 2) = + Polynomial.C (X (0 : Fin 1) : MvPolynomial (Fin 1) R) := by + exact @Fin.cases_succ 1 + (fun _ => Polynomial (MvPolynomial (Fin 1) R)) + Polynomial.X + (fun k : Fin 1 => Polynomial.C + (X k : MvPolynomial (Fin 1) R)) 0 + simp [lhs, rhs, planeFirstInflateHom, + planeFirstInflateSubstitution, MvPolynomial.finSuccEquiv_apply, + hcases]⟩ + +/-- Divide the exponents of `X₀` by `p`, discarding coefficients whose +exponents are not divisible by `p`. -/ +def planeFirstDeflate (p : ℕ) (f : MvPolynomial (Fin 2) R) : + MvPolynomial (Fin 2) R := + (MvPolynomial.finSuccEquiv R 1).symm + (Polynomial.contract p (MvPolynomial.finSuccEquiv R 1 f)) + +theorem derivative_finSuccEquiv_eq_finSuccEquiv_pderiv_zero + (f : MvPolynomial (Fin 2) R) : + Polynomial.derivative (MvPolynomial.finSuccEquiv R 1 f) = + MvPolynomial.finSuccEquiv R 1 (pderiv 0 f) := by + ext n m + rw [Polynomial.coeff_derivative, mul_comm] + rw [← Nat.cast_succ, ← nsmul_eq_mul, coeff_smul, + MvPolynomial.finSuccEquiv_coeff_coeff, + MvPolynomial.finSuccEquiv_coeff_coeff, + coeff_pderiv, nsmul_eq_mul, mul_comm] + congr 1 + · apply congrArg f.coeff + apply Finsupp.ext + intro i + refine Fin.cases ?_ (fun j => ?_) i <;> simp + · simp + +variable {R} + +theorem planeFirstInflateHom_planeFirstDeflate + [IsDomain R] (p : ℕ) [CharP R p] (hp : p ≠ 0) + (f : MvPolynomial (Fin 2) R) (hderiv : pderiv 0 f = 0) : + planeFirstInflateHom R p (planeFirstDeflate R p f) = f := by + apply (MvPolynomial.finSuccEquiv R 1).injective + rw [finSuccEquiv_planeFirstInflateHom, planeFirstDeflate, + AlgEquiv.apply_symm_apply] + apply Polynomial.expand_contract p + · rw [derivative_finSuccEquiv_eq_finSuccEquiv_pderiv_zero, hderiv, map_zero] + · exact hp + +theorem planeFirstInflateHom_injective (p : ℕ) (hp : 0 < p) : + Function.Injective (planeFirstInflateHom R p) := by + intro f g hfg + apply (MvPolynomial.finSuccEquiv R 1).injective + have hfg' := congrArg (MvPolynomial.finSuccEquiv R 1) hfg + rw [finSuccEquiv_planeFirstInflateHom, + finSuccEquiv_planeFirstInflateHom] at hfg' + exact Polynomial.expand_injective hp hfg' + +theorem irreducible_of_planeFirstInflateHom_irreducible + [IsDomain R] (p : ℕ) (hp : p ≠ 0) {f : MvPolynomial (Fin 2) R} + (hf : Irreducible (planeFirstInflateHom R p f)) : + Irreducible f := by + have hpoly : Irreducible + (Polynomial.expand (MvPolynomial (Fin 1) R) p + (MvPolynomial.finSuccEquiv R 1 f)) := by + rw [← finSuccEquiv_planeFirstInflateHom] + exact hf.map (MvPolynomial.finSuccEquiv R 1).toMulEquiv + have hbase : Irreducible (MvPolynomial.finSuccEquiv R 1 f) := + Polynomial.of_irreducible_expand hp hpoly + simpa using hbase.map (MvPolynomial.finSuccEquiv R 1).symm.toMulEquiv + +theorem eval_planeFirstInflateHom + (p : ℕ) (f : MvPolynomial (Fin 2) R) (x y : R) : + eval ![x, y] (planeFirstInflateHom R p f) = + eval ![x ^ p, y] f := by + change aeval ![x, y] (bind₁ (planeFirstInflateSubstitution R p) f) = _ + rw [aeval_bind₁] + apply congrArg (fun z : Fin 2 → R => aeval z f) + funext i + fin_cases i <;> simp [planeFirstInflateSubstitution] + +theorem pderiv_one_planeFirstInflateHom + (p : ℕ) (f : MvPolynomial (Fin 2) R) : + pderiv 1 (planeFirstInflateHom R p f) = + planeFirstInflateHom R p (pderiv 1 f) := by + induction f using MvPolynomial.induction_on with + | C r => simp + | add f g hf hg => simp [map_add, hf, hg] + | mul_X f i hf => + fin_cases i <;> simp [map_mul, hf] + +theorem map_planeFirstInflateHom + {S : Type*} [CommRing S] (p : ℕ) (φ : R →+* S) + (f : MvPolynomial (Fin 2) R) : + map φ (planeFirstInflateHom R p f) = + planeFirstInflateHom S p (map φ f) := by + change map φ (bind₁ (planeFirstInflateSubstitution R p) f) = _ + rw [map_bind₁] + congr 1 + ext i + fin_cases i <;> simp [planeFirstInflateSubstitution] + +/-- Multiply only the first exponent of a plane monomial by `p`. -/ +def scaleFirstExponent (p : ℕ) (m : Fin 2 →₀ ℕ) : Fin 2 →₀ ℕ := + m.tail.cons (m 0 * p) + +@[simp] theorem scaleFirstExponent_zero (p : ℕ) (m : Fin 2 →₀ ℕ) : + scaleFirstExponent p m 0 = m 0 * p := by + simp [scaleFirstExponent] + +@[simp] theorem scaleFirstExponent_one (p : ℕ) (m : Fin 2 →₀ ℕ) : + scaleFirstExponent p m 1 = m 1 := by + change m.tail 0 = m 1 + rw [Finsupp.tail_apply] + rfl + +theorem scaleFirstExponent_mem_support_planeFirstInflateHom + (p : ℕ) (hp : 0 < p) {f : MvPolynomial (Fin 2) R} + {m : Fin 2 →₀ ℕ} (hm : m ∈ f.support) : + scaleFirstExponent p m ∈ (planeFirstInflateHom R p f).support := by + change m.tail.cons (m 0 * p) ∈ (planeFirstInflateHom R p f).support + rw [← MvPolynomial.mem_support_coeff_finSuccEquiv, + finSuccEquiv_planeFirstInflateHom, + Polynomial.coeff_expand_mul hp, + MvPolynomial.mem_support_coeff_finSuccEquiv] + simpa using hm + +/-- A bidegree bound for a one-coordinate inflation descends to the +unexpanded polynomial without loss. -/ +theorem hasBidegreeAtMost_of_planeFirstInflateHom + (p : ℕ) (hp : 0 < p) {f : MvPolynomial (Fin 2) R} + {firstDegree secondDegree : ℕ} + (hdegree : BGS.External.HasBidegreeAtMost + (planeFirstInflateHom R p f) firstDegree secondDegree) : + BGS.External.HasBidegreeAtMost f firstDegree secondDegree := by + intro m hm + have hs := hdegree (scaleFirstExponent p m) + (scaleFirstExponent_mem_support_planeFirstInflateHom p hp hm) + exact ⟨(Nat.le_mul_of_pos_right (m 0) hp).trans (by simpa using hs.1), + by simpa using hs.2⟩ + +theorem degreeOf_zero_planeFirstInflateHom + (p : ℕ) (f : MvPolynomial (Fin 2) R) : + degreeOf 0 (planeFirstInflateHom R p f) = degreeOf 0 f * p := by + rw [← MvPolynomial.natDegree_finSuccEquiv, + finSuccEquiv_planeFirstInflateHom, + Polynomial.natDegree_expand, + MvPolynomial.natDegree_finSuccEquiv] + +theorem absolutelyIrreducible_of_planeFirstInflateHom_eq + {K : Type*} [Field K] (p : ℕ) (hp : p ≠ 0) + {f g : MvPolynomial (Fin 2) K} + (hfg : planeFirstInflateHom K p g = f) + (hf : Irreducible + (map (algebraMap K (AlgebraicClosure K)) f)) : + Irreducible (map (algebraMap K (AlgebraicClosure K)) g) := by + apply irreducible_of_planeFirstInflateHom_irreducible p hp + rw [← map_planeFirstInflateHom, hfg] + exact hf + +theorem pderiv_one_ne_zero_of_planeFirstInflateHom_eq + {K : Type*} [Field K] (p : ℕ) + {f g : MvPolynomial (Fin 2) K} + (hfg : planeFirstInflateHom K p g = f) + (hf : pderiv 1 f ≠ 0) : + pderiv 1 g ≠ 0 := by + intro hg + apply hf + rw [← hfg, pderiv_one_planeFirstInflateHom, hg, map_zero] + +theorem degreeOf_zero_lt_of_planeFirstInflateHom_eq + {K : Type*} [Field K] (p : ℕ) (hp : 1 < p) + {f g : MvPolynomial (Fin 2) K} + (hfg : planeFirstInflateHom K p g = f) + (hfpos : 0 < degreeOf 0 f) : + degreeOf 0 g < degreeOf 0 f := by + have hdegree := degreeOf_zero_planeFirstInflateHom p g + rw [hfg] at hdegree + have hgpos : 0 < degreeOf 0 g := by + by_contra hg + rw [Nat.not_lt, Nat.le_zero] at hg + rw [hg, zero_mul] at hdegree + omega + calc + degreeOf 0 g < degreeOf 0 g * p := + (Nat.lt_mul_iff_one_lt_right hgpos).2 hp + _ = degreeOf 0 f := hdegree.symm + +section FiniteField + +variable (K : Type*) [Field K] [Fintype K] [DecidableEq K] +variable (p : ℕ) [Fact p.Prime] [CharP K p] + +/-- Frobenius in the first coordinate, identity in the second. -/ +def planeFirstFrobeniusPointEquiv : K × K ≃ K × K := + (frobeniusEquiv K p).toEquiv.prodCongr (Equiv.refl K) + +omit [DecidableEq K] in +@[simp] theorem planeFirstFrobeniusPointEquiv_apply (z : K × K) : + planeFirstFrobeniusPointEquiv K p z = (z.1 ^ p, z.2) := by + rcases z with ⟨x, y⟩ + rfl + +/-- Frobenius bijects the affine zero set of an inflation with the affine +zero set of the unexpanded polynomial. -/ +def planeFirstInflateAffineZeroEquiv (f : MvPolynomial (Fin 2) K) : + {z // z ∈ BGS.External.affinePlaneCurveZeros K + (planeFirstInflateHom K p f)} ≃ + {z // z ∈ BGS.External.affinePlaneCurveZeros K f} := + (planeFirstFrobeniusPointEquiv K p).subtypeEquiv fun z => by + simp only [BGS.External.mem_affinePlaneCurveZeros_iff, + planeFirstFrobeniusPointEquiv_apply] + exact (eval_planeFirstInflateHom p f z.1 z.2).congr_left + +theorem card_affinePlaneCurveZeros_planeFirstInflateHom + (f : MvPolynomial (Fin 2) K) : + (BGS.External.affinePlaneCurveZeros K + (planeFirstInflateHom K p f)).card = + (BGS.External.affinePlaneCurveZeros K f).card := by + rw [← Fintype.card_coe, ← Fintype.card_coe] + exact Fintype.card_congr (planeFirstInflateAffineZeroEquiv K p f) + +theorem card_affinePlaneCurveZeros_eq_of_planeFirstInflateHom_eq + {f g : MvPolynomial (Fin 2) K} + (hfg : planeFirstInflateHom K p g = f) : + (BGS.External.affinePlaneCurveZeros K g).card = + (BGS.External.affinePlaneCurveZeros K f).card := by + rw [← hfg, card_affinePlaneCurveZeros_planeFirstInflateHom] + +end FiniteField + +/-- One strict Frobenius-deflation step in the first coordinate. The +second partial derivative is retained, absolute irreducibility and the +affine point count descend, and no supplied bidegree bound is enlarged. -/ +theorem exists_planeFirstFrobeniusDeflationStep + (K : Type*) [Field K] [Fintype K] [DecidableEq K] + (f : MvPolynomial (Fin 2) K) (firstDegree secondDegree : ℕ) + (hdegree : BGS.External.HasBidegreeAtMost + f firstDegree secondDegree) + (habsolute : Irreducible + (map (algebraMap K (AlgebraicClosure K)) f)) + (hpartialFirst : pderiv 0 f = 0) + (hpartialSecond : pderiv 1 f ≠ 0) + (hfirstDegree : 0 < degreeOf 0 f) : + ∃ g : MvPolynomial (Fin 2) K, + planeFirstInflateHom K (ringChar K) g = f ∧ + BGS.External.HasBidegreeAtMost g firstDegree secondDegree ∧ + Irreducible (map (algebraMap K (AlgebraicClosure K)) g) ∧ + pderiv 1 g ≠ 0 ∧ + degreeOf 0 g < degreeOf 0 f ∧ + (BGS.External.affinePlaneCurveZeros K g).card = + (BGS.External.affinePlaneCurveZeros K f).card := by + let p := ringChar K + let : Fact p.Prime := ⟨CharP.char_is_prime K p⟩ + let g := planeFirstDeflate K p f + have hfg : planeFirstInflateHom K p g = f := + planeFirstInflateHom_planeFirstDeflate p + ((Fact.out : p.Prime).ne_zero) f hpartialFirst + refine ⟨g, hfg, ?_, ?_, ?_, ?_, ?_⟩ + · apply hasBidegreeAtMost_of_planeFirstInflateHom p + (Fact.out : p.Prime).pos + simpa [hfg] using hdegree + · exact absolutelyIrreducible_of_planeFirstInflateHom_eq + p (Fact.out : p.Prime).ne_zero hfg habsolute + · exact pderiv_one_ne_zero_of_planeFirstInflateHom_eq + p hfg hpartialSecond + · exact degreeOf_zero_lt_of_planeFirstInflateHom_eq + p (Fact.out : p.Prime).one_lt hfg hfirstDegree + · exact card_affinePlaneCurveZeros_eq_of_planeFirstInflateHom_eq + K p hfg + +/-- Iterating the strict first-coordinate step terminates. Unless the +original polynomial has actual first degree zero, it produces a polynomial +with both coordinate partials nonzero, without increasing the supplied +bidegree bounds or changing the affine point count. -/ +theorem exists_planeFirstSeparatingDeflation_or_degreeOf_zero + (K : Type*) [Field K] [Fintype K] [DecidableEq K] + (f : MvPolynomial (Fin 2) K) (firstDegree secondDegree : ℕ) + (hdegree : BGS.External.HasBidegreeAtMost + f firstDegree secondDegree) + (habsolute : Irreducible + (map (algebraMap K (AlgebraicClosure K)) f)) + (hpartialSecond : pderiv 1 f ≠ 0) : + degreeOf 0 f = 0 ∨ + ∃ g : MvPolynomial (Fin 2) K, + BGS.External.HasBidegreeAtMost g firstDegree secondDegree ∧ + Irreducible (map (algebraMap K (AlgebraicClosure K)) g) ∧ + pderiv 0 g ≠ 0 ∧ + pderiv 1 g ≠ 0 ∧ + (BGS.External.affinePlaneCurveZeros K g).card = + (BGS.External.affinePlaneCurveZeros K f).card := by + let P : ℕ → Prop := fun n => + ∀ f : MvPolynomial (Fin 2) K, + degreeOf 0 f = n → + BGS.External.HasBidegreeAtMost f firstDegree secondDegree → + Irreducible (map (algebraMap K (AlgebraicClosure K)) f) → + pderiv 1 f ≠ 0 → + degreeOf 0 f = 0 ∨ + ∃ g : MvPolynomial (Fin 2) K, + BGS.External.HasBidegreeAtMost g firstDegree secondDegree ∧ + Irreducible (map (algebraMap K (AlgebraicClosure K)) g) ∧ + pderiv 0 g ≠ 0 ∧ + pderiv 1 g ≠ 0 ∧ + (BGS.External.affinePlaneCurveZeros K g).card = + (BGS.External.affinePlaneCurveZeros K f).card + have hP : ∀ n, P n := by + intro n + induction n using Nat.strong_induction_on with + | h n ih => + intro f hfn hdegree habsolute hpartialSecond + by_cases hdegreeZero : degreeOf 0 f = 0 + · exact Or.inl hdegreeZero + by_cases hpartialFirst : pderiv 0 f = 0 + · obtain ⟨g, hfg, hgdegree, hgabsolute, hgpartialSecond, + hglt, hgcard⟩ := + exists_planeFirstFrobeniusDeflationStep K f + firstDegree secondDegree hdegree habsolute hpartialFirst + hpartialSecond (Nat.pos_of_ne_zero hdegreeZero) + have hgn : degreeOf 0 g < n := by + simpa [← hfn] using hglt + have hgout := ih (degreeOf 0 g) hgn g rfl hgdegree + hgabsolute hgpartialSecond + rcases hgout with hgzero | ⟨u, hudegree, huabsolute, + hupartialFirst, hupartialSecond, hucard⟩ + · have hdegInflate := + degreeOf_zero_planeFirstInflateHom (ringChar K) g + rw [hfg, hgzero, zero_mul] at hdegInflate + exact (hdegreeZero hdegInflate).elim + · exact Or.inr ⟨u, hudegree, huabsolute, hupartialFirst, + hupartialSecond, hucard.trans hgcard⟩ + · exact Or.inr ⟨f, hdegree, habsolute, hpartialFirst, + hpartialSecond, rfl⟩ + exact hP (degreeOf 0 f) f rfl hdegree habsolute hpartialSecond + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/PlaneFrobeniusDegenerate.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/PlaneFrobeniusDegenerate.lean new file mode 100644 index 0000000000..d62e5ff0e7 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/PlaneFrobeniusDegenerate.lean @@ -0,0 +1,223 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneFrobeniusDeflation + +/-! +# The zero-coordinate-degree case of Frobenius reduction + +An absolutely irreducible plane polynomial with zero degree in one +coordinate is a univariate polynomial in the other coordinate. After +extension to an algebraic closure, irreducibility forces that univariate +polynomial to have degree one. Consequently it has one rational root over +the original field and its affine plane zero set has exactly one point above +each value of the absent coordinate. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +open MvPolynomial + +noncomputable section + +variable {R : Type*} [CommRing R] + +theorem natDegree_uniqueAlgEquiv_fin_one + (q : MvPolynomial (Fin 1) R) : + (MvPolynomial.uniqueAlgEquiv R (Fin 1) q).natDegree = + degreeOf 0 q := by + apply le_antisymm + · rw [Polynomial.natDegree_le_iff_coeff_eq_zero] + intro n hn + rw [MvPolynomial.coeff_uniqueAlgEquiv] + by_contra hcoeff + have hm : Finsupp.single (0 : Fin 1) n ∈ q.support := + MvPolynomial.mem_support_iff.mpr hcoeff + have hle := monomial_le_degreeOf (0 : Fin 1) hm + have : n < n := by simpa using hle.trans_lt hn + exact this.false + · rw [MvPolynomial.degreeOf_le_iff] + intro m hm + apply Polynomial.le_natDegree_of_ne_zero + rw [MvPolynomial.coeff_uniqueAlgEquiv] + change q.coeff (Finsupp.single (0 : Fin 1) (m 0)) ≠ 0 + have hmEq : Finsupp.single (0 : Fin 1) (m 0) = m := by + simpa using (Finsupp.unique_single m).symm + rw [hmEq] + exact MvPolynomial.mem_support_iff.mp hm + +def secondPolynomialOfFirstDegreeZero + (f : MvPolynomial (Fin 2) R) : Polynomial R := + MvPolynomial.uniqueAlgEquiv R (Fin 1) + ((MvPolynomial.finSuccEquiv R 1 f).coeff 0) + +theorem finSuccEquiv_eq_C_coeff_zero_of_degreeOf_zero + {f : MvPolynomial (Fin 2) R} (hdegree : degreeOf 0 f = 0) : + MvPolynomial.finSuccEquiv R 1 f = + Polynomial.C ((MvPolynomial.finSuccEquiv R 1 f).coeff 0) := by + apply Polynomial.eq_C_of_natDegree_eq_zero + simpa [MvPolynomial.natDegree_finSuccEquiv] using hdegree + +theorem degreeOf_one_eq_natDegree_secondPolynomialOfFirstDegreeZero + {f : MvPolynomial (Fin 2) R} (hdegree : degreeOf 0 f = 0) : + degreeOf 1 f = (secondPolynomialOfFirstDegreeZero f).natDegree := by + let q := (MvPolynomial.finSuccEquiv R 1 f).coeff 0 + have hC := finSuccEquiv_eq_C_coeff_zero_of_degreeOf_zero hdegree + have hqle : degreeOf 0 q ≤ degreeOf 1 f := by + exact MvPolynomial.degreeOf_coeff_finSuccEquiv f 0 0 + have hfle : degreeOf 1 f ≤ degreeOf 0 q := by + rw [MvPolynomial.degreeOf_le_iff] + intro m hm + have htail : m.tail ∈ + ((MvPolynomial.finSuccEquiv R 1 f).coeff (m 0)).support := by + rw [MvPolynomial.mem_support_coeff_finSuccEquiv] + simpa using hm + have hmzero : m 0 = 0 := by + by_contra hmzero + have hz : (MvPolynomial.finSuccEquiv R 1 f).coeff (m 0) = 0 := by + rw [hC] + rw [Polynomial.coeff_C, ite_eq_right hmzero] + rw [hz] at htail + simpa using htail + have htailq : m.tail ∈ q.support := by + rw [hmzero] at htail + exact htail + have hle := monomial_le_degreeOf (0 : Fin 1) htailq + change m 1 ≤ degreeOf 0 q + simpa [Finsupp.tail_apply] using hle + rw [secondPolynomialOfFirstDegreeZero, + natDegree_uniqueAlgEquiv_fin_one] + exact le_antisymm hfle hqle + +theorem degreeOf_map_eq_of_injective_local + {S : Type*} [CommRing S] (φ : R →+* S) + (hφ : Function.Injective φ) (i : Fin 2) + (f : MvPolynomial (Fin 2) R) : + degreeOf i (map φ f) = degreeOf i f := by + rw [MvPolynomial.degreeOf_eq_sup, MvPolynomial.degreeOf_eq_sup, + MvPolynomial.support_map_of_injective f hφ] + +theorem degreeOf_one_eq_one_of_absolutelyIrreducible_degreeOf_zero + {K : Type*} [Field K] {f : MvPolynomial (Fin 2) K} + (habsolute : Irreducible + (map (algebraMap K (AlgebraicClosure K)) f)) + (hdegree : degreeOf 0 f = 0) : + degreeOf 1 f = 1 := by + let F := AlgebraicClosure K + let φ : K →+* F := algebraMap K F + let fF : MvPolynomial (Fin 2) F := map φ f + have hdegreeMap (i : Fin 2) : degreeOf i fF = degreeOf i f := + degreeOf_map_eq_of_injective_local φ (RingHom.injective φ) i f + have hdegreeZeroF : degreeOf 0 fF = 0 := by + rw [hdegreeMap] + exact hdegree + let qF : MvPolynomial (Fin 1) F := + (MvPolynomial.finSuccEquiv F 1 fF).coeff 0 + have hC : MvPolynomial.finSuccEquiv F 1 fF = Polynomial.C qF := by + simpa [qF] using + (finSuccEquiv_eq_C_coeff_zero_of_degreeOf_zero hdegreeZeroF) + have hfinIrr : Irreducible (MvPolynomial.finSuccEquiv F 1 fF) := + habsolute.map (MvPolynomial.finSuccEquiv F 1).toMulEquiv + have hCIrr : Irreducible (Polynomial.C qF) := by + rw [← hC] + exact hfinIrr + let : IsLocalHom + (Polynomial.C : MvPolynomial (Fin 1) F →+* + Polynomial (MvPolynomial (Fin 1) F)) := + ⟨fun _ hunit => Polynomial.isUnit_C.mp hunit⟩ + have hqIrr : Irreducible qF := hCIrr.of_map + have hpolyIrr : Irreducible + (MvPolynomial.uniqueAlgEquiv F (Fin 1) qF) := + hqIrr.map (MvPolynomial.uniqueAlgEquiv F (Fin 1)).toMulEquiv + have hpolyDegree : + (MvPolynomial.uniqueAlgEquiv F (Fin 1) qF).natDegree = 1 := + Polynomial.natDegree_eq_of_degree_eq_some + (IsAlgClosed.degree_eq_one_of_irreducible F hpolyIrr) + have hdegreeOneF : degreeOf 1 fF = 1 := by + rw [degreeOf_one_eq_natDegree_secondPolynomialOfFirstDegreeZero + hdegreeZeroF] + simpa [secondPolynomialOfFirstDegreeZero, qF] using hpolyDegree + rw [hdegreeMap] at hdegreeOneF + exact hdegreeOneF + +theorem eval_eq_secondPolynomialOfFirstDegreeZero + {f : MvPolynomial (Fin 2) R} (hdegree : degreeOf 0 f = 0) + (x y : R) : + eval ![x, y] f = (secondPolynomialOfFirstDegreeZero f).eval y := by + let q := (MvPolynomial.finSuccEquiv R 1 f).coeff 0 + have hC := finSuccEquiv_eq_C_coeff_zero_of_degreeOf_zero hdegree + calc + eval ![x, y] f = + Polynomial.eval x + (Polynomial.map (eval ![y]) + (MvPolynomial.finSuccEquiv R 1 f)) := by + simpa using + (MvPolynomial.eval_eq_eval_mv_eval' (R := R) ![y] x f) + _ = eval ![y] q := by + rw [hC] + simp [q] + _ = (secondPolynomialOfFirstDegreeZero f).eval y := by + symm + simpa [secondPolynomialOfFirstDegreeZero, q] using + (MvPolynomial.eval₂_uniqueAlgEquiv + (R := R) (σ := Fin 1) + (f := q) (φ := RingHom.id R) (a := ![y])) + +theorem card_affinePlaneCurveZeros_eq_card_of_degreeOf_zero + (K : Type*) [Field K] [Fintype K] [DecidableEq K] + {f : MvPolynomial (Fin 2) K} + (habsolute : Irreducible + (map (algebraMap K (AlgebraicClosure K)) f)) + (hdegree : degreeOf 0 f = 0) : + (BGS.External.affinePlaneCurveZeros K f).card = Fintype.card K := by + let q := secondPolynomialOfFirstDegreeZero f + have hdegreeOne := + degreeOf_one_eq_one_of_absolutelyIrreducible_degreeOf_zero + habsolute hdegree + have hqnat : q.natDegree = 1 := by + rw [← degreeOf_one_eq_natDegree_secondPolynomialOfFirstDegreeZero + hdegree] + exact hdegreeOne + have hqdegree : q.degree = 1 := + (Polynomial.degree_eq_iff_natDegree_eq_of_pos Nat.zero_lt_one).2 hqnat + let r : K := -((q.coeff 1)⁻¹ * q.coeff 0) + have hqne : q ≠ 0 := by + intro hq + rw [hq, Polynomial.degree_zero] at hqdegree + exact WithBot.bot_ne_coe hqdegree + have hzero (y : K) : q.eval y = 0 ↔ y = r := by + change q.IsRoot y ↔ y = r + rw [← Polynomial.mem_roots hqne, + Polynomial.roots_degree_eq_one hqdegree] + simp [r] + let e : {z // z ∈ BGS.External.affinePlaneCurveZeros K f} ≃ K := + { toFun := fun z => z.1.1 + invFun := fun x => ⟨(x, r), by + rw [BGS.External.mem_affinePlaneCurveZeros_iff, + eval_eq_secondPolynomialOfFirstDegreeZero hdegree] + exact (hzero r).2 rfl⟩ + left_inv := by + intro z + apply Subtype.ext + apply Prod.ext + · rfl + · have hz := BGS.External.mem_affinePlaneCurveZeros_iff.mp z.2 + rw [eval_eq_secondPolynomialOfFirstDegreeZero hdegree] at hz + exact ((hzero z.1.2).1 hz).symm + right_inv := by intro x; rfl } + calc + (BGS.External.affinePlaneCurveZeros K f).card = + Fintype.card {z // z ∈ BGS.External.affinePlaneCurveZeros K f} := + (Fintype.card_coe _).symm + _ = Fintype.card K := Fintype.card_congr e + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/PlaneFrobeniusReduction.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/PlaneFrobeniusReduction.lean new file mode 100644 index 0000000000..880bbbcdde --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/PlaneFrobeniusReduction.lean @@ -0,0 +1,236 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneFrobeniusDegenerate + +/-! +# Closed Frobenius reduction for affine plane curves + +This module conjugates first-coordinate deflation by the coordinate swap and +thereby handles either inseparable coordinate. An absolutely irreducible +plane equation over a finite field either has an absent coordinate, in which +case its affine point count is exactly the field cardinality, or it admits a +same-count equation with both coordinate partial derivatives nonzero and no +larger supplied bidegree bounds. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +open MvPolynomial + +noncomputable section + +variable (R : Type*) [CommRing R] + +/-- Swap the two variables of a plane polynomial. -/ +def planeSwapAlgEquiv : + MvPolynomial (Fin 2) R ≃ₐ[R] MvPolynomial (Fin 2) R := + MvPolynomial.renameEquiv R (Equiv.swap (0 : Fin 2) 1) + +@[simp] theorem planeSwapAlgEquiv_apply (f : MvPolynomial (Fin 2) R) : + planeSwapAlgEquiv R f = + MvPolynomial.rename (Equiv.swap (0 : Fin 2) 1) f := rfl + +theorem pderiv_zero_planeSwapAlgEquiv + (f : MvPolynomial (Fin 2) R) : + pderiv 0 (planeSwapAlgEquiv R f) = + planeSwapAlgEquiv R (pderiv 1 f) := by + simpa [planeSwapAlgEquiv] using + (MvPolynomial.pderiv_rename + (Equiv.swap (0 : Fin 2) 1).injective (1 : Fin 2) f) + +theorem pderiv_one_planeSwapAlgEquiv + (f : MvPolynomial (Fin 2) R) : + pderiv 1 (planeSwapAlgEquiv R f) = + planeSwapAlgEquiv R (pderiv 0 f) := by + simpa [planeSwapAlgEquiv] using + (MvPolynomial.pderiv_rename + (Equiv.swap (0 : Fin 2) 1).injective (0 : Fin 2) f) + +theorem pderiv_zero_planeSwapAlgEquiv_ne_zero + {f : MvPolynomial (Fin 2) R} (hf : pderiv 1 f ≠ 0) : + pderiv 0 (planeSwapAlgEquiv R f) ≠ 0 := by + rw [pderiv_zero_planeSwapAlgEquiv] + exact (planeSwapAlgEquiv R).injective.ne hf + +theorem pderiv_one_planeSwapAlgEquiv_ne_zero + {f : MvPolynomial (Fin 2) R} (hf : pderiv 0 f ≠ 0) : + pderiv 1 (planeSwapAlgEquiv R f) ≠ 0 := by + rw [pderiv_one_planeSwapAlgEquiv] + exact (planeSwapAlgEquiv R).injective.ne hf + +theorem degreeOf_zero_planeSwapAlgEquiv + (f : MvPolynomial (Fin 2) R) : + degreeOf 0 (planeSwapAlgEquiv R f) = degreeOf 1 f := by + simpa [planeSwapAlgEquiv] using + (MvPolynomial.degreeOf_rename_of_injective + (Equiv.swap (0 : Fin 2) 1).injective (1 : Fin 2) (p := f)) + +theorem hasBidegreeAtMost_planeSwapAlgEquiv + {f : MvPolynomial (Fin 2) R} {firstDegree secondDegree : ℕ} + (hdegree : BGS.External.HasBidegreeAtMost + f firstDegree secondDegree) : + BGS.External.HasBidegreeAtMost + (planeSwapAlgEquiv R f) secondDegree firstDegree := by + classical + intro m hm + rw [planeSwapAlgEquiv_apply, + MvPolynomial.support_rename_of_injective + (Equiv.swap (0 : Fin 2) 1).injective] at hm + obtain ⟨n, hn, rfl⟩ := Finset.mem_image.mp hm + have hd := hdegree n hn + have hzero : + Finsupp.mapDomain (Equiv.swap (0 : Fin 2) 1) n 0 = n 1 := by + simp + have hone : + Finsupp.mapDomain (Equiv.swap (0 : Fin 2) 1) n 1 = n 0 := by + simp + simpa [hzero, hone] using And.intro hd.2 hd.1 + +theorem map_planeSwapAlgEquiv + {S : Type*} [CommRing S] (φ : R →+* S) + (f : MvPolynomial (Fin 2) R) : + map φ (planeSwapAlgEquiv R f) = + planeSwapAlgEquiv S (map φ f) := by + simp [planeSwapAlgEquiv, MvPolynomial.map_rename] + +theorem absolutelyIrreducible_planeSwapAlgEquiv + {K : Type*} [Field K] {f : MvPolynomial (Fin 2) K} + (hf : Irreducible + (map (algebraMap K (AlgebraicClosure K)) f)) : + Irreducible + (map (algebraMap K (AlgebraicClosure K)) + (planeSwapAlgEquiv K f)) := by + rw [map_planeSwapAlgEquiv] + exact hf.map (planeSwapAlgEquiv (AlgebraicClosure K)).toMulEquiv + +theorem eval_planeSwapAlgEquiv + (f : MvPolynomial (Fin 2) R) (x y : R) : + eval ![y, x] (planeSwapAlgEquiv R f) = eval ![x, y] f := by + simp [planeSwapAlgEquiv, MvPolynomial.eval_rename] + +section FiniteField + +variable (K : Type*) [Field K] [Fintype K] [DecidableEq K] + +def planeSwapAffineZeroEquiv (f : MvPolynomial (Fin 2) K) : + {z // z ∈ BGS.External.affinePlaneCurveZeros K + (planeSwapAlgEquiv K f)} ≃ + {z // z ∈ BGS.External.affinePlaneCurveZeros K f} := + (Equiv.prodComm K K).subtypeEquiv fun z => by + simp only [BGS.External.mem_affinePlaneCurveZeros_iff] + exact (eval_planeSwapAlgEquiv K f z.2 z.1).congr_left + +theorem card_affinePlaneCurveZeros_planeSwapAlgEquiv + (f : MvPolynomial (Fin 2) K) : + (BGS.External.affinePlaneCurveZeros K + (planeSwapAlgEquiv K f)).card = + (BGS.External.affinePlaneCurveZeros K f).card := by + rw [← Fintype.card_coe, ← Fintype.card_coe] + exact Fintype.card_congr (planeSwapAffineZeroEquiv K f) + +end FiniteField + +/-- Frobenius deflation in whichever coordinate is inseparable. The only +alternative to a same-count separating equation is the exact univariate +point count. -/ +theorem separatingFrobeniusDeflation_or_exactPointCount + (K : Type*) [Field K] [Fintype K] [DecidableEq K] + (f : MvPolynomial (Fin 2) K) (firstDegree secondDegree : ℕ) + (hdegree : BGS.External.HasBidegreeAtMost + f firstDegree secondDegree) + (habsolute : Irreducible + (map (algebraMap K (AlgebraicClosure K)) f)) : + (BGS.External.affinePlaneCurveZeros K f).card = Fintype.card K ∨ + ∃ g : MvPolynomial (Fin 2) K, + BGS.External.HasBidegreeAtMost g firstDegree secondDegree ∧ + Irreducible (map (algebraMap K (AlgebraicClosure K)) g) ∧ + pderiv 0 g ≠ 0 ∧ pderiv 1 g ≠ 0 ∧ + (BGS.External.affinePlaneCurveZeros K g).card = + (BGS.External.affinePlaneCurveZeros K f).card := by + by_cases hpartialSecond : pderiv 1 f ≠ 0 + · rcases exists_planeFirstSeparatingDeflation_or_degreeOf_zero + K f firstDegree secondDegree hdegree habsolute hpartialSecond with + hdegreeZero | ⟨g, hgdegree, hgabsolute, hgpartialFirst, + hgpartialSecond, hgcard⟩ + · exact Or.inl + (card_affinePlaneCurveZeros_eq_card_of_degreeOf_zero + K habsolute hdegreeZero) + · exact Or.inr ⟨g, hgdegree, hgabsolute, hgpartialFirst, + hgpartialSecond, hgcard⟩ + · have hpartialFirst : pderiv 0 f ≠ 0 := by + rcases + pderiv_zero_ne_zero_or_pderiv_one_ne_zero_of_absolutelyIrreducible + K f habsolute with h | h + · exact h + · exact (hpartialSecond h).elim + let fSwap := planeSwapAlgEquiv K f + have hdegreeSwap : BGS.External.HasBidegreeAtMost + fSwap secondDegree firstDegree := + hasBidegreeAtMost_planeSwapAlgEquiv K hdegree + have habsoluteSwap : Irreducible + (map (algebraMap K (AlgebraicClosure K)) fSwap) := + absolutelyIrreducible_planeSwapAlgEquiv habsolute + have hpartialSecondSwap : pderiv 1 fSwap ≠ 0 := + pderiv_one_planeSwapAlgEquiv_ne_zero K hpartialFirst + rcases exists_planeFirstSeparatingDeflation_or_degreeOf_zero + K fSwap secondDegree firstDegree hdegreeSwap habsoluteSwap + hpartialSecondSwap with hdegreeZero | ⟨g, hgdegree, + hgabsolute, hgpartialFirst, hgpartialSecond, hgcard⟩ + · left + rw [← card_affinePlaneCurveZeros_planeSwapAlgEquiv K f] + exact card_affinePlaneCurveZeros_eq_card_of_degreeOf_zero + K habsoluteSwap hdegreeZero + · right + refine ⟨planeSwapAlgEquiv K g, + hasBidegreeAtMost_planeSwapAlgEquiv K hgdegree, + absolutelyIrreducible_planeSwapAlgEquiv hgabsolute, + pderiv_zero_planeSwapAlgEquiv_ne_zero K hgpartialSecond, + pderiv_one_planeSwapAlgEquiv_ne_zero K hgpartialFirst, ?_⟩ + rw [card_affinePlaneCurveZeros_planeSwapAlgEquiv, hgcard, + card_affinePlaneCurveZeros_planeSwapAlgEquiv] + +/-- Any coefficient-`8` affine Hasse bound proved for separating equations +extends to every absolutely irreducible plane equation. This theorem is the +composition boundary between Frobenius reduction and the zeta/spectral +argument. -/ +theorem abs_affinePlaneCurveZeros_card_sub_card_le_of_separating_case + (K : Type*) [Field K] [Fintype K] [DecidableEq K] + (f : MvPolynomial (Fin 2) K) (firstDegree secondDegree : ℕ) + (hdegree : BGS.External.HasBidegreeAtMost + f firstDegree secondDegree) + (habsolute : Irreducible + (map (algebraMap K (AlgebraicClosure K)) f)) + (hseparating : + ∀ g : MvPolynomial (Fin 2) K, + BGS.External.HasBidegreeAtMost g firstDegree secondDegree → + Irreducible (map (algebraMap K (AlgebraicClosure K)) g) → + pderiv 0 g ≠ 0 → pderiv 1 g ≠ 0 → + |((BGS.External.affinePlaneCurveZeros K g).card : ℝ) - + (Fintype.card K : ℝ)| ≤ + 8 * Real.sqrt (Fintype.card K : ℝ) * + (firstDegree : ℝ) * (secondDegree : ℝ)) : + |((BGS.External.affinePlaneCurveZeros K f).card : ℝ) - + (Fintype.card K : ℝ)| ≤ + 8 * Real.sqrt (Fintype.card K : ℝ) * + (firstDegree : ℝ) * (secondDegree : ℝ) := by + rcases separatingFrobeniusDeflation_or_exactPointCount + K f firstDegree secondDegree hdegree habsolute with + hcard | ⟨g, hgdegree, hgabsolute, hgpartialFirst, + hgpartialSecond, hgcard⟩ + · rw [hcard] + simp only [sub_self, abs_zero] + positivity + · rw [← hgcard] + exact hseparating g hgdegree hgabsolute hgpartialFirst hgpartialSecond + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/PlaneInfinityRiemannLower.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/PlaneInfinityRiemannLower.lean new file mode 100644 index 0000000000..8ed73f366a --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/PlaneInfinityRiemannLower.lean @@ -0,0 +1,232 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneOnePointRiemannLower +public import Mathlib.Tactic + +/-! +# Riemann's inequality for divisors supported above infinity + +The first coordinate of a plane curve has a pole at every branch above the +rational-function place at infinity. Its pole divisor is therefore cofinal +among effective divisors supported on those branches. A sufficiently large +rectangular monomial pole budget dominates any such divisor. + +The monomial budget already satisfies the bidegree form of Riemann's +inequality. Removing the effective difference costs at most its divisor +degree, so the same inequality descends to the original infinity-supported +divisor. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +open BGS.CorvajaZannier +open scoped nonZeroDivisors Polynomial BigOperators + +noncomputable section + +variable (K : Type*) [Field K] [Fintype K] [DecidableEq K] + [DecidableEq (RatFunc K)] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +omit [Fintype K] [DecidableEq K] [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] in +/-- An effective divisor supported above infinity is dominated by a natural +multiple of any effective divisor that is positive at every infinity +place. -/ +theorem exists_nsmul_ge_of_effective_supportedAtInfinity + (E H : FiniteExtensionDivisor K L) + (hE : ∀ v, 0 ≤ E v) + (hEfinite : ∀ q : FiniteExtensionFinitePlace K L, E (.inl q) = 0) + (hH : ∀ v, 0 ≤ H v) + (hHinfinity : ∀ P : FiniteExtensionInfinityPlace K L, 0 < H (.inr P)) : + ∃ n : ℕ, E ≤ n • H := by + classical + let n : ℕ := ∑ v ∈ E.support, (E v).toNat + refine ⟨n, ?_⟩ + intro v + rcases v with q | P + · rw [hEfinite q] + exact nsmul_nonneg (hH (.inl q)) n + · have hEPnonneg : 0 ≤ E (.inr P) := hE (.inr P) + by_cases hEPzero : E (.inr P) = 0 + · rw [hEPzero] + exact nsmul_nonneg (hH (.inr P)) n + · have hmem : (.inr P : FiniteExtensionPlace K L) ∈ E.support := + Finsupp.mem_support_iff.mpr hEPzero + have htermNonneg : ∀ v ∈ E.support, 0 ≤ (E v).toNat := by + intro v hv + positivity + have hcoeff : (E (.inr P)).toNat ≤ n := by + dsimp only [n] + exact Finset.single_le_sum htermNonneg hmem + have hcoeffInt : E (.inr P) ≤ (n : ℤ) := by + rw [← Int.toNat_of_nonneg hEPnonneg] + exact_mod_cast hcoeff + have hHone : (1 : ℤ) ≤ H (.inr P) := by + exact hHinfinity P + simp only [Finsupp.nsmul_apply, nsmul_eq_mul] + nlinarith + +variable {K} + +/-- Bidegree Riemann inequality for every effective divisor supported on the +infinity branches of an absolutely irreducible plane curve. -/ +theorem planeCurve_infinitySupported_riemann_lower + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) : + letI := planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + letI := planeCurveFirstCoordinateRatFuncAlgebra f hx + letI := finiteDimensional_planeCurveFunctionField_over_ratFunc + hf hpartialSecond + letI := separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + ∀ (E : FiniteExtensionDivisor K (PlaneCurveFunctionField f)), + (∀ v, 0 ≤ E v) → + (∀ q : FiniteExtensionFinitePlace K + (PlaneCurveFunctionField f), E (.inl q) = 0) → + (finiteExtensionDivisorDegree K (PlaneCurveFunctionField f) E).toNat + 1 ≤ + Module.finrank K + (finiteExtensionRiemannSpace K (PlaneCurveFunctionField f) E) + + planeCurveBidegreeGenusBudget f := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let L := PlaneCurveFunctionField f + let x : L := planeCurveFunction f 0 + let y : L := planeCurveFunction f 1 + let a := MvPolynomial.degreeOf 0 f + let b := MvPolynomial.degreeOf 1 f + let g := planeCurveBidegreeGenusBudget f + let : Algebra (RatFunc K) L := + planeCurveFirstCoordinateRatFuncAlgebra f hx + let : FiniteDimensional (RatFunc K) L := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : Algebra.IsSeparable (RatFunc K) L := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let constantAlg : Algebra K L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K (RatFunc K))) + let : Algebra K L := constantAlg + let : SMul K L := constantAlg.toSMul + let : Module K L := constantAlg.toModule + let : IsScalarTower K (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + dsimp only + intro E hE hEfinite + let H := finiteExtensionPoleDivisor K L x + have hH : ∀ v, 0 ≤ H v := + finiteExtensionPoleDivisor_effective K L x + have hHinfinity : ∀ P : FiniteExtensionInfinityPlace K L, + 0 < H (.inr P) := by + simpa only [H, L, x] using + finiteExtensionPoleDivisor_planeCurveFirstCoordinate_inr_positive + hf hpartialSecond + obtain ⟨n, hEH⟩ := + exists_nsmul_ge_of_effective_supportedAtInfinity + K L E H hE hEfinite hH hHinfinity + let D : FiniteExtensionDivisor K L := + planeMonomialPoleBudget K L x y n b + have hD : ∀ v, 0 ≤ D v := by + intro v + dsimp only [D, planeMonomialPoleBudget] + simp only [Finsupp.add_apply, Finsupp.nsmul_apply] + exact add_nonneg + (nsmul_nonneg (finiteExtensionPoleDivisor_effective K L x v) n) + (nsmul_nonneg (finiteExtensionPoleDivisor_effective K L y v) (b - 1)) + have hED : E ≤ D := by + intro v + have hleft := hEH v + dsimp only [H] at hleft + dsimp only [D, planeMonomialPoleBudget] + exact hleft.trans (le_add_of_nonneg_right + (nsmul_nonneg (finiteExtensionPoleDivisor_effective K L y v) (b - 1))) + let A : FiniteExtensionDivisor K L := D - E + have hA : ∀ v, 0 ≤ A v := by + intro v + dsimp only [A] + exact sub_nonneg.mpr (hED v) + have hsplit : E + A = D := by + dsimp only [A] + abel + let : Module.Finite K (finiteExtensionRiemannSpace K L E) := + finiteExtensionRiemannSpace_effective_moduleFinite K L E hE + have hstrip := + finiteExtensionRiemannSpace_add_effective K L E A hE hA + rw [hsplit] at hstrip + have hmono : (n + 1) * b ≤ + Module.finrank K (finiteExtensionRiemannSpace K L D) := by + simpa only [D, L, x, y, b] using + planeCurveMonomialPoleBudget_finrank_lower + hf hpartialFirst hpartialSecond n + have hxHeight : finiteExtensionHeight K L x = b := by + simpa only [L, x, b] using + finiteExtensionHeight_planeCurveFirstCoordinate hf hpartialSecond + have hyHeight : finiteExtensionHeight K L y ≤ a := by + simpa only [L, y, a] using + planeCurveSecondCoordinate_height_le_degreeOf_first + hf hpartialFirst hpartialSecond + have hDdegree : finiteExtensionDivisorDegree K L D ≤ + (n * b + (b - 1) * a : ℕ) := by + dsimp only [D, planeMonomialPoleBudget] + rw [finiteExtensionDivisorDegree_pow_mul_pow_budget, hxHeight] + have hyCast : (finiteExtensionHeight K L y : ℤ) ≤ (a : ℤ) := by + exact_mod_cast hyHeight + calc + (n : ℤ) * (b : ℤ) + ((b - 1 : ℕ) : ℤ) * + (finiteExtensionHeight K L y : ℤ) ≤ + (n : ℤ) * (b : ℤ) + ((b - 1 : ℕ) : ℤ) * (a : ℤ) := by + gcongr + _ = (n * b + (b - 1) * a : ℕ) := by + push_cast + ring + have hDdegreeNonnegative : 0 ≤ finiteExtensionDivisorDegree K L D := + finiteExtensionDivisorDegree_nonnegative_of_effective K L D hD + have hDdegreeNat : (finiteExtensionDivisorDegree K L D).toNat ≤ + n * b + (b - 1) * a := by + have hcast : (((finiteExtensionDivisorDegree K L D).toNat : ℕ) : ℤ) = + finiteExtensionDivisorDegree K L D := + Int.toNat_of_nonneg hDdegreeNonnegative + exact_mod_cast (hcast ▸ hDdegree) + have haPos : 0 < a := degreeOf_first_pos_of_pderiv_ne_zero hpartialFirst + have hbPos : 0 < b := degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond + have hgenusIdentity : + n * b + (b - 1) * a + 1 = (n + 1) * b + g := by + dsimp only [g, planeCurveBidegreeGenusBudget, a, b] + nlinarith [Nat.sub_add_cancel (Nat.one_le_iff_ne_zero.mpr haPos.ne'), + Nat.sub_add_cancel (Nat.one_le_iff_ne_zero.mpr hbPos.ne')] + have hDriemann : (finiteExtensionDivisorDegree K L D).toNat + 1 ≤ + Module.finrank K (finiteExtensionRiemannSpace K L D) + g := by + omega + have hEdegreeNonnegative : 0 ≤ finiteExtensionDivisorDegree K L E := + finiteExtensionDivisorDegree_nonnegative_of_effective K L E hE + have hAdegreeNonnegative : 0 ≤ finiteExtensionDivisorDegree K L A := + finiteExtensionDivisorDegree_nonnegative_of_effective K L A hA + have hdegreeSplit : + (finiteExtensionDivisorDegree K L D).toNat = + (finiteExtensionDivisorDegree K L E).toNat + + (finiteExtensionDivisorDegree K L A).toNat := by + have hdegree : finiteExtensionDivisorDegree K L D = + finiteExtensionDivisorDegree K L E + + finiteExtensionDivisorDegree K L A := by + rw [← hsplit, finiteExtensionDivisorDegree_add] + rw [hdegree, Int.toNat_add hEdegreeNonnegative hAdegreeNonnegative] + change (finiteExtensionDivisorDegree K L E).toNat + 1 ≤ + Module.finrank K (finiteExtensionRiemannSpace K L E) + g + omega + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/PlaneMonomialSpace.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/PlaneMonomialSpace.lean new file mode 100644 index 0000000000..feac01abd0 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/PlaneMonomialSpace.lean @@ -0,0 +1,500 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveAuxiliaryIndependence +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PoweredImageCurve +public import LeanPool.MarkoffModP.BGS.HasseWeil.PoleDivisor +public import Mathlib.Algebra.Polynomial.Basis +public import Mathlib.LinearAlgebra.Dimension.Constructions +public import Mathlib.RingTheory.AlgebraTower +public import Mathlib.RingTheory.Finiteness.Basic + +/-! +# Plane monomial spaces for the Stepanov construction + +This file packages the finite rectangular spaces spanned by the monomials +`x ^ i * y ^ j`. It proves their dimension from linear independence, gives +a plane-curve independence criterion from the degree in one coordinate, and +records the mixed-radix exponent map occurring when an ordinary grid is +multiplied by a grid in the powered coordinates. + +The final tower lemma is the algebraic form needed by Stepanov: if the +ordinary (digit) grid is independent over a subfield containing `x ^ s` and +`y ^ s`, and the powered grid is independent over the constant field, then +the twisted products + +`x ^ (i + s * i') * y ^ (j + s * j')` + +are independent over the constant field. No Frobenius endomorphism is +introduced or assumed. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +open BGS.CorvajaZannier + +noncomputable section + +/-- The rectangular family of plane monomials with `i < a` and `j < b`. -/ +def planeMonomialGrid + {L : Type*} [Monoid L] + (x y : L) (a b : ℕ) : Fin a × Fin b → L := + fun ij ↦ x ^ (ij.1 : ℕ) * y ^ (ij.2 : ℕ) + +/-- The finite `K`-subspace spanned by a rectangular plane-monomial grid. -/ +def planeMonomialSpace + (K : Type*) {L : Type*} [Field K] [CommRing L] [Algebra K L] + (x y : L) (a b : ℕ) : Submodule K L := + Submodule.span K (Set.range (planeMonomialGrid x y a b)) + +theorem planeMonomialGrid_mem_space + {K L : Type*} [Field K] [CommRing L] [Algebra K L] + (x y : L) (a b : ℕ) (ij : Fin a × Fin b) : + planeMonomialGrid x y a b ij ∈ planeMonomialSpace K x y a b := + Submodule.subset_span (Set.mem_range_self ij) + +/-- A rectangular monomial space is finite, independently of any +linear-independence hypothesis. -/ +theorem moduleFinite_planeMonomialSpace + (K : Type*) {L : Type*} [Field K] [CommRing L] [Algebra K L] + (x y : L) (a b : ℕ) : + Module.Finite K (planeMonomialSpace K x y a b) := by + exact Module.Finite.span_of_finite K + (Set.finite_range (planeMonomialGrid x y a b)) + +/-- Linear independence identifies the finrank of a rectangular monomial +space with the number of grid points. -/ +theorem finrank_planeMonomialSpace_eq_mul + {K L : Type*} [Field K] [CommRing L] [Algebra K L] + (x y : L) (a b : ℕ) + (hLI : LinearIndependent K (planeMonomialGrid x y a b)) : + Module.finrank K (planeMonomialSpace K x y a b) = a * b := by + change Module.finrank K + (Submodule.span K (Set.range (planeMonomialGrid x y a b))) = a * b + rw [finrank_span_eq_card hLI, Fintype.card_prod, + Fintype.card_fin, Fintype.card_fin] + +/-- Finite initial segments of the powers of a transcendental element are +linearly independent. -/ +theorem linearIndependent_fin_powers_of_transcendental + {K A : Type*} [Field K] [CommRing A] [Algebra K A] + (z : A) (hz : Transcendental K z) (n : ℕ) : + LinearIndependent K (fun i : Fin n ↦ z ^ (i : ℕ)) := by + have hpolynomial : LinearIndependent K + (fun i : Fin n ↦ (Polynomial.X : Polynomial K) ^ (i : ℕ)) := by + simpa only [Polynomial.coe_basisMonomials, + Polynomial.monomial_one_right_eq_X_pow, Function.comp_def] using + (Polynomial.basisMonomials K).linearIndependent.comp + (fun i : Fin n ↦ (i : ℕ)) Fin.val_injective + have heval : LinearMap.ker (Polynomial.aeval z).toLinearMap = ⊥ := + LinearMap.ker_eq_bot_of_injective + ((transcendental_iff_injective.mp hz)) + have hmapped := + hpolynomial.map' (Polynomial.aeval z).toLinearMap heval + change LinearIndependent K + (fun i : Fin n ↦ (Polynomial.aeval z) + ((Polynomial.X : Polynomial K) ^ (i : ℕ))) at hmapped + simpa only [Polynomial.aeval_X_pow] using hmapped + +/-- A tower criterion for a rectangular monomial grid. Powers of the +transcendental lower coordinate supply one independent family, and powers of +the upper element below its minimal-polynomial degree supply the other. -/ +theorem planeMonomialGrid_linearIndependent_of_transcendental_minpoly + {K F L : Type*} [Field K] [Field F] [Field L] + [Algebra K F] [Algebra F L] [Algebra K L] [IsScalarTower K F L] + (x : F) (y : L) (a b : ℕ) + (hx : Transcendental K x) + (hb : b ≤ (minpoly F y).natDegree) : + LinearIndependent K + (planeMonomialGrid (algebraMap F L x) y a b) := by + have hxPowers : LinearIndependent K (fun i : Fin a ↦ x ^ (i : ℕ)) := + linearIndependent_fin_powers_of_transcendental x hx a + have hyPowers : LinearIndependent F (fun j : Fin b ↦ y ^ (j : ℕ)) := by + simpa only [Function.comp_def, Fin.val_castLE] using + (linearIndependent_pow y).comp (Fin.castLE hb) + (Fin.castLE_injective hb) + change LinearIndependent K + (fun ij : Fin a × Fin b ↦ + (algebraMap F L x) ^ (ij.1 : ℕ) * y ^ (ij.2 : ℕ)) + simpa only [Algebra.smul_def, map_pow] using + (linearIndependent_smul hxPowers hyPowers) + +/-- The grid part of the Corvaja--Zannier auxiliary family is a linearly +independent rectangular monomial family. -/ +theorem planeMonomialGrid_linearIndependent_of_auxiliaryFamily + {C L : Type*} [Field C] [Field L] [Algebra C L] + (u v : L) (h k : ℕ) + (haux : LinearIndependent C (auxiliaryFamily u v h k)) : + LinearIndependent C (planeMonomialGrid u v (k + 1) h) := by + change LinearIndependent C + (fun rs : Fin (k + 1) × Fin h ↦ + u ^ (rs.1 : ℕ) * v ^ (rs.2 : ℕ)) + simpa only [Function.comp_def, auxiliaryFamily] using + haux.comp (fun rs : Fin (k + 1) × Fin h ↦ Sum.inr rs) + Sum.inr_injective + +/-- On an irreducible plane curve, monomials with arbitrary first exponent +and second exponent below the second-coordinate degree are independent. -/ +theorem planeCurve_monomialGrid_linearIndependent + {K : Type*} [Field K] + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (a b : ℕ) (hb : b ≤ MvPolynomial.degreeOf 1 f) : + letI := planeCurveCoordinateRing_isDomain hf + LinearIndependent K + (planeMonomialGrid (planeCurveFunction f 0) + (planeCurveFunction f 1) a b) := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let xF : FirstCoordinateSubfield f := firstCoordinateInSubfield f + have hxL : Transcendental K (planeCurveFunction f 0) := + firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + have hxF : Transcendental K xF := by + apply (transcendental_algebraMap_iff + (algebraMap (FirstCoordinateSubfield f) + (PlaneCurveFunctionField f)).injective).mp + change Transcendental K + (algebraMap (FirstCoordinateSubfield f) + (PlaneCurveFunctionField f) xF) + simpa only [xF, firstCoordinateInSubfield, + IntermediateField.algebraMap_apply] using hxL + have hminpoly : + (minpoly (FirstCoordinateSubfield f) + (planeCurveFunction f 1)).natDegree = + MvPolynomial.degreeOf 1 f := + natDegree_minpoly_secondCoordinate_eq_degreeOf_second + hf hpartialSecond + have hb' : b ≤ (minpoly (FirstCoordinateSubfield f) + (planeCurveFunction f 1)).natDegree := by + rw [hminpoly] + exact hb + simpa only [xF, firstCoordinateInSubfield, + IntermediateField.algebraMap_apply] using + planeMonomialGrid_linearIndependent_of_transcendental_minpoly + xF (planeCurveFunction f 1) a b hxF hb' + +/-- The bidegree criterion gives the exact dimension of the corresponding +plane-curve monomial space. -/ +theorem finrank_planeCurve_monomialSpace_eq_mul + {K : Type*} [Field K] + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (a b : ℕ) (hb : b ≤ MvPolynomial.degreeOf 1 f) : + letI := planeCurveCoordinateRing_isDomain hf + Module.finrank K + (planeMonomialSpace K (planeCurveFunction f 0) + (planeCurveFunction f 1) a b) = a * b := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + exact finrank_planeMonomialSpace_eq_mul + (planeCurveFunction f 0) (planeCurveFunction f 1) a b + (planeCurve_monomialGrid_linearIndependent + hf hpartialSecond a b hb) + +/-- The mixed-radix exponent attached to a low digit and a high digit. -/ +def digitExponent {a a' : ℕ} (s : ℕ) (ii' : Fin a × Fin a') : ℕ := + (ii'.1 : ℕ) + s * (ii'.2 : ℕ) + +/-- Low digits bounded by the radix make the mixed-radix exponent map +injective. -/ +theorem digitExponent_injective + {s a a' : ℕ} (ha : a ≤ s) : + Function.Injective (digitExponent (a := a) (a' := a') s) := by + rintro ⟨i, i'⟩ ⟨k, k'⟩ heq + have hi : (i : ℕ) < s := i.isLt.trans_le ha + have hk : (k : ℕ) < s := k.isLt.trans_le ha + have hs : 0 < s := by omega + have hlow : (i : ℕ) = (k : ℕ) := by + have hmod := congrArg (fun n : ℕ ↦ n % s) heq + change ((i : ℕ) + s * (i' : ℕ)) % s = + ((k : ℕ) + s * (k' : ℕ)) % s at hmod + rw [Nat.add_mul_mod_self_left, Nat.add_mul_mod_self_left, + Nat.mod_eq_of_lt hi, Nat.mod_eq_of_lt hk] at hmod + exact hmod + have hhigh : (i' : ℕ) = (k' : ℕ) := by + have hmul : s * (i' : ℕ) = s * (k' : ℕ) := by + apply Nat.add_left_cancel (n := (i : ℕ)) + simpa only [digitExponent, hlow] using heq + exact Nat.mul_left_cancel hs hmul + exact Prod.ext (Fin.ext hlow) (Fin.ext hhigh) + +/-- The pair of mixed-radix exponents used by the twisted monomial grid. -/ +def twistedExponentGrid + (s a b a' b' : ℕ) : + (Fin a × Fin b) × (Fin a' × Fin b') → ℕ × ℕ := + fun z ↦ + ((z.1.1 : ℕ) + s * (z.2.1 : ℕ), + (z.1.2 : ℕ) + s * (z.2.2 : ℕ)) + +/-- Digit bounds in both coordinates make the exponent-pair map injective. -/ +theorem twistedExponentGrid_injective + {s a b a' b' : ℕ} (ha : a ≤ s) (hb : b ≤ s) : + Function.Injective (twistedExponentGrid s a b a' b') := by + rintro ⟨⟨i, j⟩, ⟨i', j'⟩⟩ ⟨⟨k, l⟩, ⟨k', l'⟩⟩ heq + have hfirst : (i, i') = (k, k') := + digitExponent_injective ha (congrArg Prod.fst heq) + have hsecond : (j, j') = (l, l') := + digitExponent_injective hb (congrArg Prod.snd heq) + cases hfirst + cases hsecond + rfl + +/-- The products of an ordinary monomial grid and its `s`-powered copy. -/ +def twistedPlaneMonomialGrid + {L : Type*} [Monoid L] + (x y : L) (s a b a' b' : ℕ) : + (Fin a × Fin b) × (Fin a' × Fin b') → L := + fun z ↦ + x ^ ((z.1.1 : ℕ) + s * (z.2.1 : ℕ)) * + y ^ ((z.1.2 : ℕ) + s * (z.2.2 : ℕ)) + +/-- Send a pair of low and high digits to the encompassing rectangular +grid. -/ +def twistedGridToGrid + (s a b a' b' : ℕ) : + (Fin a × Fin b) × (Fin a' × Fin b') → + Fin (a + s * a') × Fin (b + s * b') := + fun z ↦ + (⟨(z.1.1 : ℕ) + s * (z.2.1 : ℕ), + Nat.add_lt_add_of_lt_of_le z.1.1.isLt + (Nat.mul_le_mul_left s z.2.1.isLt.le)⟩, + ⟨(z.1.2 : ℕ) + s * (z.2.2 : ℕ), + Nat.add_lt_add_of_lt_of_le z.1.2.isLt + (Nat.mul_le_mul_left s z.2.2.isLt.le)⟩) + +theorem twistedGridToGrid_injective + {s a b a' b' : ℕ} (ha : a ≤ s) (hb : b ≤ s) : + Function.Injective (twistedGridToGrid s a b a' b') := by + intro z w hzw + apply twistedExponentGrid_injective ha hb + exact congrArg (fun q ↦ ((q.1 : ℕ), (q.2 : ℕ))) hzw + +/-- Direct bidegree criterion for the twisted family. The digit bounds make +the exponent encoding injective, while the final second-exponent range stays +below the curve's second-coordinate degree. -/ +theorem planeCurve_twistedMonomialGrid_linearIndependent + {K : Type*} [Field K] + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (s a b a' b' : ℕ) + (ha : a ≤ s) (hb : b ≤ s) + (hdegree : b + s * b' ≤ MvPolynomial.degreeOf 1 f) : + letI := planeCurveCoordinateRing_isDomain hf + LinearIndependent K + (twistedPlaneMonomialGrid (planeCurveFunction f 0) + (planeCurveFunction f 1) s a b a' b') := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + have hgrid := planeCurve_monomialGrid_linearIndependent + hf hpartialSecond (a + s * a') (b + s * b') hdegree + have hsubfamily := hgrid.comp (twistedGridToGrid s a b a' b') + (twistedGridToGrid_injective ha hb) + change LinearIndependent K + (fun z : (Fin a × Fin b) × (Fin a' × Fin b') ↦ + (planeCurveFunction f 0) ^ + ((z.1.1 : ℕ) + s * (z.2.1 : ℕ)) * + (planeCurveFunction f 1) ^ + ((z.1.2 : ℕ) + s * (z.2.2 : ℕ))) + simpa only [Function.comp_def, planeMonomialGrid, + twistedGridToGrid] using hsubfamily + +/-- In particular, under the direct bidegree criterion the twisted grid is +an injective family of functions. -/ +theorem planeCurve_twistedMonomialGrid_injective + {K : Type*} [Field K] + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (s a b a' b' : ℕ) + (ha : a ≤ s) (hb : b ≤ s) + (hdegree : b + s * b' ≤ MvPolynomial.degreeOf 1 f) : + letI := planeCurveCoordinateRing_isDomain hf + Function.Injective + (twistedPlaneMonomialGrid (planeCurveFunction f 0) + (planeCurveFunction f 1) s a b a' b') := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + exact (planeCurve_twistedMonomialGrid_linearIndependent + hf hpartialSecond s a b a' b' ha hb hdegree).injective + +/-- Tower composition for Stepanov's twisted grid. The ordinary grid is +independent over `F`; the powered grid, regarded inside `F`, is independent +over `K`. Multiplication combines the two independent families. -/ +theorem twistedPlaneMonomialGrid_linearIndependent_of_subfield + {K L : Type*} [Field K] [Field L] [Algebra K L] + (F : Subfield L) [Algebra K F] [IsScalarTower K F L] + (x y : L) (s a b a' b' : ℕ) + (hxs : x ^ s ∈ F) (hys : y ^ s ∈ F) + (hdigit : LinearIndependent F (planeMonomialGrid x y a b)) + (hpowered : LinearIndependent K + (planeMonomialGrid (⟨x ^ s, hxs⟩ : F) + (⟨y ^ s, hys⟩ : F) a' b')) : + LinearIndependent K + (twistedPlaneMonomialGrid x y s a b a' b') := by + have hproduct := linearIndependent_smul hpowered hdigit + have hreindexed := hproduct.comp + (fun z : (Fin a × Fin b) × (Fin a' × Fin b') ↦ (z.2, z.1)) + (Equiv.prodComm (Fin a × Fin b) (Fin a' × Fin b')).injective + have hcoeX : F.subtype (⟨x ^ s, hxs⟩ : F) = x ^ s := rfl + have hcoeY : F.subtype (⟨y ^ s, hys⟩ : F) = y ^ s := rfl + change LinearIndependent K + (fun z : (Fin a × Fin b) × (Fin a' × Fin b') ↦ + x ^ ((z.1.1 : ℕ) + s * (z.2.1 : ℕ)) * + y ^ ((z.1.2 : ℕ) + s * (z.2.2 : ℕ))) + simpa only [Function.comp_def, planeMonomialGrid, + Algebra.smul_def, map_mul, map_pow, + Subfield.algebraMap_ofSubfield, RingHom.coe_coe, + hcoeX, hcoeY, Subtype.coe_mk, pow_mul, pow_add, + mul_assoc, mul_left_comm, mul_comm] using hreindexed + +/-- The powered-image relation supplies the bidegree needed for a monomial +grid in the powered coordinates. -/ +theorem planeCurve_poweredMonomialGrid_linearIndependent + {K : Type*} [Field K] + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (m : ℕ) (hm : 0 < m) (n a b : ℕ) + (hb : b ≤ + (poweredCoordinateImageRelation hf hpartialSecond m hm n).natDegree) : + letI := planeCurveCoordinateRing_isDomain hf + LinearIndependent K + (planeMonomialGrid ((planeCurveFunction f 0) ^ m) + ((planeCurveFunction f 1) ^ n) a b) := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let xm : FirstPoweredCoordinateSubfield f m := + ⟨(planeCurveFunction f 0) ^ m, + IntermediateField.mem_adjoin_simple_self K + ((planeCurveFunction f 0) ^ m)⟩ + let : FiniteDimensional (FirstPoweredCoordinateSubfield f m) + (PlaneCurveFunctionField f) := + finiteDimensional_over_firstPoweredCoordinate hf hpartialSecond m hm + have hxmL : Transcendental K ((planeCurveFunction f 0) ^ m) := + firstPoweredCoordinate_transcendental hf hpartialSecond m hm + have hxm : Transcendental K xm := by + apply (transcendental_algebraMap_iff + (algebraMap (FirstPoweredCoordinateSubfield f m) + (PlaneCurveFunctionField f)).injective).mp + change Transcendental K + (algebraMap (FirstPoweredCoordinateSubfield f m) + (PlaneCurveFunctionField f) xm) + simpa only [xm, IntermediateField.algebraMap_apply] using hxmL + have hynIntegral : IsIntegral (FirstPoweredCoordinateSubfield f m) + ((planeCurveFunction f 1) ^ n) := + IsIntegral.of_finite (FirstPoweredCoordinateSubfield f m) _ + have hminpoly : + (minpoly (FirstPoweredCoordinateSubfield f m) + ((planeCurveFunction f 1) ^ n)).natDegree = + (poweredCoordinateImageRelation hf hpartialSecond m hm n).natDegree := by + calc + (minpoly (FirstPoweredCoordinateSubfield f m) + ((planeCurveFunction f 1) ^ n)).natDegree = + Module.finrank (FirstPoweredCoordinateSubfield f m) + (PoweredImageOverFirst f m n) := + (IntermediateField.adjoin.finrank hynIntegral).symm + _ = (poweredCoordinateImageRelation + hf hpartialSecond m hm n).natDegree := + (poweredCoordinateImageRelation_natDegree_eq_finrank + hf hpartialSecond m hm n).symm + have hb' : b ≤ (minpoly (FirstPoweredCoordinateSubfield f m) + ((planeCurveFunction f 1) ^ n)).natDegree := by + rw [hminpoly] + exact hb + simpa only [xm, IntermediateField.algebraMap_apply] using + planeMonomialGrid_linearIndependent_of_transcendental_minpoly + xm ((planeCurveFunction f 1) ^ n) a b hxm hb' + +section PoleBudget + +variable (K : Type*) [Field K] [Fintype K] [DecidableEq K] + [DecidableEq (RatFunc K)] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +local instance planeMonomialSpaceConstantAlgebra : Algebra K L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K (RatFunc K))) + +local instance planeMonomialSpaceConstantTower : + IsScalarTower K (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + +/-- Every monomial with `x`-exponent at most `n` and `y`-exponent below `b` +lies in the Riemann space with pole budget +`n · pole(x) + (b - 1) · pole(y)`. -/ +theorem planeMonomialSpace_le_poleDivisorBudget + (x y : L) (hx : x ≠ 0) (hy : y ≠ 0) (n b : ℕ) : + planeMonomialSpace K x y (n + 1) b ≤ + finiteExtensionRiemannSpace K L + (n • finiteExtensionPoleDivisor K L x + + (b - 1) • finiteExtensionPoleDivisor K L y) := by + apply Submodule.span_le.mpr + rintro z ⟨ij, rfl⟩ + apply finiteExtensionRiemannSpace_mono K L + (D := (ij.1 : ℕ) • finiteExtensionPoleDivisor K L x + + (ij.2 : ℕ) • finiteExtensionPoleDivisor K L y) + · exact add_le_add + (nsmul_le_nsmul_left + (finiteExtensionPoleDivisor_effective K L x) + (by omega)) + (nsmul_le_nsmul_left + (finiteExtensionPoleDivisor_effective K L y) + (by omega)) + · exact pow_mul_pow_mem_poleDivisor_budget + K L x y hx hy (ij.1 : ℕ) (ij.2 : ℕ) + +/-- Pole-budget containment is already useful before finite-dimensionality of +the ambient Riemann space has been established: it gives monotonicity of the +corresponding module ranks. -/ +theorem rank_planeMonomialSpace_le_rank_poleDivisorBudget + (x y : L) (hx : x ≠ 0) (hy : y ≠ 0) (n b : ℕ) : + Module.rank K (planeMonomialSpace K x y (n + 1) b) ≤ + Module.rank K + (finiteExtensionRiemannSpace K L + (n • finiteExtensionPoleDivisor K L x + + (b - 1) • finiteExtensionPoleDivisor K L y)) := + Submodule.rank_mono + (planeMonomialSpace_le_poleDivisorBudget K L x y hx hy n b) + +/-- Once finite-dimensionality of the ambient Riemann space is available, +the same containment yields the numerical lower bound `(n + 1) * b`. -/ +theorem add_one_mul_le_finrank_poleDivisorBudget + (x y : L) (hx : x ≠ 0) (hy : y ≠ 0) (n b : ℕ) + (hLI : LinearIndependent K (planeMonomialGrid x y (n + 1) b)) + (hfinite : Module.Finite K + (finiteExtensionRiemannSpace K L + (n • finiteExtensionPoleDivisor K L x + + (b - 1) • finiteExtensionPoleDivisor K L y))) : + (n + 1) * b ≤ Module.finrank K + (finiteExtensionRiemannSpace K L + (n • finiteExtensionPoleDivisor K L x + + (b - 1) • finiteExtensionPoleDivisor K L y)) := by + let : Module.Finite K + (finiteExtensionRiemannSpace K L + (n • finiteExtensionPoleDivisor K L x + + (b - 1) • finiteExtensionPoleDivisor K L y)) := hfinite + calc + (n + 1) * b = Module.finrank K + (planeMonomialSpace K x y (n + 1) b) := + (finrank_planeMonomialSpace_eq_mul x y (n + 1) b hLI).symm + _ ≤ Module.finrank K + (finiteExtensionRiemannSpace K L + (n • finiteExtensionPoleDivisor K L x + + (b - 1) • finiteExtensionPoleDivisor K L y)) := + Submodule.finrank_mono + (planeMonomialSpace_le_poleDivisorBudget + K L x y hx hy n b) + +end PoleBudget + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/PlaneOnePointRiemannLower.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/PlaneOnePointRiemannLower.lean new file mode 100644 index 0000000000..f678c56639 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/PlaneOnePointRiemannLower.lean @@ -0,0 +1,676 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneMonomialSpace +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneCoordinatePoleAtInfinity +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneConstantField +public import LeanPool.MarkoffModP.BGS.HasseWeil.RiemannSpaceEffectiveIncrement +public import LeanPool.MarkoffModP.BGS.HasseWeil.OnePointStrictLevels + +/-! +# One-point Riemann-space lower bounds for plane curves + +For an absolutely irreducible affine plane equation `f`, choose an infinity +place `P` where the first coordinate has a pole. The rectangular monomial +grid + +`{x^i y^j | 0 ≤ i ≤ n, 0 ≤ j < degreeOf 1 f}` + +lies in the Riemann space of a controlled effective pole divisor. Removing +all components away from `P` and comparing divisor degrees gives the coarse +one-point estimate + +`m * degree(P) + 1 ≤ finrank L(m P) + + (degreeOf 0 f - 1) * (degreeOf 1 f - 1)` + +along an explicit arithmetic progression of pole levels `m`. The final +theorem combines this estimate with the one-place increment bound and the +exact constant field to force at least `m - g` strict levels in the one-point +Riemann filtration, where `g` is the displayed bidegree budget. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +open BGS.CorvajaZannier +open scoped nonZeroDivisors Polynomial BigOperators + +noncomputable section + +variable (K : Type*) [Field K] [Fintype K] [DecidableEq K] + [DecidableEq (RatFunc K)] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +/-- The effective pole divisor containing the rectangular monomial grid +`x^i y^j` with `i ≤ n` and `j < b`. -/ +def planeMonomialPoleBudget (x y : L) (n b : ℕ) : + FiniteExtensionDivisor K L := + n • finiteExtensionPoleDivisor K L x + + (b - 1) • finiteExtensionPoleDivisor K L y + +/-- The coefficient of the monomial pole budget at a selected place. -/ +def planeMonomialPoleLevel (x y : L) (n b : ℕ) + (P : FiniteExtensionPlace K L) : ℕ := + (planeMonomialPoleBudget K L x y n b P).toNat + +omit [Fintype K] [DecidableEq K] in +/-- The selected pole level is an explicit arithmetic progression in `n`. -/ +theorem planeMonomialPoleLevel_eq (x y : L) (n b : ℕ) + (P : FiniteExtensionPlace K L) : + planeMonomialPoleLevel K L x y n b P = + n * (finiteExtensionPoleDivisor K L x P).toNat + + (b - 1) * (finiteExtensionPoleDivisor K L y P).toNat := by + have hx := finiteExtensionPoleDivisor_effective K L x P + have hy := finiteExtensionPoleDivisor_effective K L y P + simp only [planeMonomialPoleLevel, planeMonomialPoleBudget, + Finsupp.add_apply, Finsupp.nsmul_apply, nsmul_eq_mul] + rw [Int.toNat_add + (mul_nonneg (Int.natCast_nonneg n) hx) + (mul_nonneg (Int.natCast_nonneg (b - 1)) hy), + Int.toNat_mul (Int.natCast_nonneg n) hx, + Int.toNat_mul (Int.natCast_nonneg (b - 1)) hy] + simp + +/-- The coarse bidegree genus budget used by the monomial argument. It is an +upper-bound budget and does not assert that the affine plane model is smooth. -/ +def planeCurveBidegreeGenusBudget + {K : Type*} [CommSemiring K] (f : MvPolynomial (Fin 2) K) : ℕ := + (MvPolynomial.degreeOf 0 f - 1) * (MvPolynomial.degreeOf 1 f - 1) + +variable {K} + +theorem planeCurveSecondCoordinate_height_le_degreeOf_first + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) : + letI := planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + letI := planeCurveFirstCoordinateRatFuncAlgebra f hx + letI := finiteDimensional_planeCurveFunctionField_over_ratFunc + hf hpartialSecond + letI := separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + finiteExtensionHeight K (PlaneCurveFunctionField f) + (planeCurveFunction f 1) ≤ MvPolynomial.degreeOf 0 f := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let L := PlaneCurveFunctionField f + let y : L := planeCurveFunction f 1 + have hyTrans : Transcendental K y := + secondCoordinate_transcendental hf + (degreeOf_first_pos_of_pderiv_ne_zero hpartialFirst) + have hy0 : y ≠ 0 := by + intro hy + apply hyTrans + rw [hy] + exact isAlgebraic_zero + let : Algebra (RatFunc K) L := + planeCurveFirstCoordinateRatFuncAlgebra f hx + let : FiniteDimensional (RatFunc K) L := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : Algebra.IsSeparable (RatFunc K) L := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + change finiteExtensionHeight K L y ≤ MvPolynomial.degreeOf 0 f + rw [← finiteExtensionPositiveDegree_eq_height K L y hy0] + exact finiteExtensionPositiveDegree_planeCurveSecondCoordinate_le_degreeOf_first + hf hpartialFirst hpartialSecond + +omit [Fintype K] [DecidableEq K] [DecidableEq (RatFunc K)] in +private theorem planeCurve_monomialGrid_linearIndependent_firstRatFunc + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (a b : ℕ) (hb : b ≤ MvPolynomial.degreeOf 1 f) : + letI := planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + letI := planeCurveFirstCoordinateRatFuncAlgebra f hx + letI := finiteDimensional_planeCurveFunctionField_over_ratFunc + hf hpartialSecond + letI := separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let constantAlg : Algebra K (PlaneCurveFunctionField f) := + RingHom.toAlgebra + ((algebraMap (RatFunc K) (PlaneCurveFunctionField f)).comp + (algebraMap K (RatFunc K))) + letI : Algebra K (PlaneCurveFunctionField f) := constantAlg + letI : SMul K (PlaneCurveFunctionField f) := constantAlg.toSMul + letI : Module K (PlaneCurveFunctionField f) := constantAlg.toModule + LinearIndependent K + (planeMonomialGrid (planeCurveFunction f 0) + (planeCurveFunction f 1) a b) := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let L := PlaneCurveFunctionField f + let y : L := planeCurveFunction f 1 + let : Algebra (RatFunc K) L := + planeCurveFirstCoordinateRatFuncAlgebra f hx + let : FiniteDimensional (RatFunc K) L := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : Algebra.IsSeparable (RatFunc K) L := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let constantAlg : Algebra K L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K (RatFunc K))) + let : Algebra K L := constantAlg + let : SMul K L := constantAlg.toSMul + let : Module K L := constantAlg.toModule + let : IsScalarTower K (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + let F : Polynomial (RatFunc K) := + (planeCurvePolynomialInSecondCoordinate f).map + (algebraMap (Polynomial K) (RatFunc K)) + have hFirreducible : Irreducible F := + planeCurvePolynomialInSecondCoordinate_ratFunc_irreducible + hf hpartialSecond + have hFroot : Polynomial.aeval y F = 0 := by + simpa only [L, y] using + aeval_planeCurvePolynomialInSecondCoordinate_ratFunc_eq_zero + hf hpartialSecond + have heq := minpoly.eq_of_irreducible hFirreducible hFroot + have hminDegree : (minpoly (RatFunc K) y).natDegree = + MvPolynomial.degreeOf 1 f := by + calc + (minpoly (RatFunc K) y).natDegree = + (F * Polynomial.C F.leadingCoeff⁻¹).natDegree := by rw [heq] + _ = F.natDegree := Polynomial.natDegree_mul_C + (inv_ne_zero (Polynomial.leadingCoeff_ne_zero.mpr + hFirreducible.ne_zero)) + _ = MvPolynomial.degreeOf 1 f := by + change ((planeCurvePolynomialInSecondCoordinate f).map + (algebraMap (Polynomial K) (RatFunc K))).natDegree = _ + rw [Polynomial.natDegree_map_eq_of_injective + (IsFractionRing.injective (Polynomial K) (RatFunc K)), + planeCurvePolynomialInSecondCoordinate_natDegree] + have hb' : b ≤ (minpoly (RatFunc K) y).natDegree := by + rw [hminDegree] + exact hb + have hLI := + planeMonomialGrid_linearIndependent_of_transcendental_minpoly + (RatFunc.X : RatFunc K) y a b RatFunc.transcendental_X hb' + rw [planeCurveFirstCoordinateRatFuncAlgebra_X f hx] at hLI + simpa only [L, y] using hLI + +theorem planeCurveMonomialPoleBudget_finrank_lower + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (n : ℕ) : + letI := planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + letI := planeCurveFirstCoordinateRatFuncAlgebra f hx + letI := finiteDimensional_planeCurveFunctionField_over_ratFunc + hf hpartialSecond + letI := separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + (n + 1) * MvPolynomial.degreeOf 1 f ≤ + Module.finrank K (finiteExtensionRiemannSpace K + (PlaneCurveFunctionField f) + (planeMonomialPoleBudget K (PlaneCurveFunctionField f) + (planeCurveFunction f 0) (planeCurveFunction f 1) n + (MvPolynomial.degreeOf 1 f))) := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let L := PlaneCurveFunctionField f + let x : L := planeCurveFunction f 0 + let y : L := planeCurveFunction f 1 + let b := MvPolynomial.degreeOf 1 f + have hx0 : x ≠ 0 := by + intro h + apply hx + change IsAlgebraic K x + rw [h] + exact isAlgebraic_zero + have hyTrans : Transcendental K y := + secondCoordinate_transcendental hf + (degreeOf_first_pos_of_pderiv_ne_zero hpartialFirst) + have hy0 : y ≠ 0 := by + intro h + apply hyTrans + rw [h] + exact isAlgebraic_zero + let : Algebra (RatFunc K) L := + planeCurveFirstCoordinateRatFuncAlgebra f hx + let : FiniteDimensional (RatFunc K) L := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : Algebra.IsSeparable (RatFunc K) L := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let constantAlg : Algebra K L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K (RatFunc K))) + let : Algebra K L := constantAlg + let : SMul K L := constantAlg.toSMul + let : Module K L := constantAlg.toModule + let : IsScalarTower K (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + have hD : ∀ v, 0 ≤ + (n • finiteExtensionPoleDivisor K L x + + (b - 1) • finiteExtensionPoleDivisor K L y) v := by + intro v + simp only [Finsupp.add_apply, Finsupp.nsmul_apply] + exact add_nonneg + (nsmul_nonneg (finiteExtensionPoleDivisor_effective K L x v) n) + (nsmul_nonneg (finiteExtensionPoleDivisor_effective K L y v) (b - 1)) + have hfinite : Module.Finite K (finiteExtensionRiemannSpace K L + (n • finiteExtensionPoleDivisor K L x + + (b - 1) • finiteExtensionPoleDivisor K L y)) := + finiteExtensionRiemannSpace_effective_moduleFinite K L + (n • finiteExtensionPoleDivisor K L x + + (b - 1) • finiteExtensionPoleDivisor K L y) hD + change (n + 1) * b ≤ Module.finrank K + (finiteExtensionRiemannSpace K L + (n • finiteExtensionPoleDivisor K L x + + (b - 1) • finiteExtensionPoleDivisor K L y)) + apply add_one_mul_le_finrank_poleDivisorBudget + K L x y hx0 hy0 n b + · simpa only [L, x, y, b] using + planeCurve_monomialGrid_linearIndependent_firstRatFunc + hf hpartialSecond (n + 1) b le_rfl + · exact hfinite + +private theorem exists_planeCurve_onePointRiemannSpace_progression_lower_bound_irreducible + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) : + letI := planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + letI := planeCurveFirstCoordinateRatFuncAlgebra f hx + letI := finiteDimensional_planeCurveFunctionField_over_ratFunc + hf hpartialSecond + letI := separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + ∃ P : FiniteExtensionInfinityPlace K (PlaneCurveFunctionField f), + let Q : FiniteExtensionPlace K (PlaneCurveFunctionField f) := .inr P + 0 < finiteExtensionPoleDivisor K (PlaneCurveFunctionField f) + (planeCurveFunction f 0) Q ∧ + 0 < finiteExtensionPlaceDegree K (PlaneCurveFunctionField f) Q ∧ + finiteExtensionPlaceDegree K (PlaneCurveFunctionField f) Q ≤ + MvPolynomial.degreeOf 1 f ∧ + ∀ n : ℕ, + let m := planeMonomialPoleLevel K (PlaneCurveFunctionField f) + (planeCurveFunction f 0) (planeCurveFunction f 1) n + (MvPolynomial.degreeOf 1 f) Q + m = n * (finiteExtensionPoleDivisor K (PlaneCurveFunctionField f) + (planeCurveFunction f 0) Q).toNat + + (MvPolynomial.degreeOf 1 f - 1) * + (finiteExtensionPoleDivisor K (PlaneCurveFunctionField f) + (planeCurveFunction f 1) Q).toNat ∧ + Module.Finite K (finiteExtensionOnePointRiemannSpace K + (PlaneCurveFunctionField f) Q m) ∧ + m * finiteExtensionPlaceDegree K (PlaneCurveFunctionField f) Q + 1 ≤ + Module.finrank K (finiteExtensionOnePointRiemannSpace K + (PlaneCurveFunctionField f) Q m) + + planeCurveBidegreeGenusBudget f := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let L := PlaneCurveFunctionField f + let x : L := planeCurveFunction f 0 + let y : L := planeCurveFunction f 1 + let a := MvPolynomial.degreeOf 0 f + let b := MvPolynomial.degreeOf 1 f + let g := planeCurveBidegreeGenusBudget f + let : Algebra (RatFunc K) L := + planeCurveFirstCoordinateRatFuncAlgebra f hx + let : FiniteDimensional (RatFunc K) L := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : Algebra.IsSeparable (RatFunc K) L := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let constantAlg : Algebra K L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K (RatFunc K))) + let : Algebra K L := constantAlg + let : SMul K L := constantAlg.toSMul + let : Module K L := constantAlg.toModule + let : IsScalarTower K (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + obtain ⟨P, hPpole, hPdegreePositive, hPdegreeBound⟩ := + exists_planeCurveFirstCoordinate_infinityPolePlace hf hpartialSecond + let Q : FiniteExtensionPlace K L := .inr P + refine ⟨P, hPpole, hPdegreePositive, hPdegreeBound, ?_⟩ + intro n + let D : FiniteExtensionDivisor K L := + planeMonomialPoleBudget K L x y n b + let m := (D Q).toNat + have hD : ∀ v, 0 ≤ D v := by + intro v + dsimp only [D] + simp only [planeMonomialPoleBudget, Finsupp.add_apply, + Finsupp.nsmul_apply] + exact add_nonneg + (nsmul_nonneg (finiteExtensionPoleDivisor_effective K L x v) n) + (nsmul_nonneg (finiteExtensionPoleDivisor_effective K L y v) (b - 1)) + have hm : m = n * (finiteExtensionPoleDivisor K L x Q).toNat + + (b - 1) * (finiteExtensionPoleDivisor K L y Q).toNat := by + simpa only [m, D, planeMonomialPoleLevel] using + planeMonomialPoleLevel_eq K L x y n b Q + have hmCast : (m : ℤ) = D Q := by + exact Int.toNat_of_nonneg (hD Q) + have hfiniteOne : Module.Finite K + (finiteExtensionOnePointRiemannSpace K L Q m) := by + change Module.Finite K (finiteExtensionRiemannSpace K L + (Finsupp.single Q (m : ℤ))) + apply finiteExtensionRiemannSpace_effective_moduleFinite K L + intro v + by_cases hv : v = Q + · subst v + simp + · simp [Finsupp.single_eq_of_ne hv] + let : Module.Finite K + (finiteExtensionOnePointRiemannSpace K L Q m) := hfiniteOne + have hfullLower : (n + 1) * b ≤ + Module.finrank K (finiteExtensionRiemannSpace K L D) := by + simpa only [D, L, x, y, b] using + planeCurveMonomialPoleBudget_finrank_lower + hf hpartialFirst hpartialSecond n + have hsplit : Module.finrank K (finiteExtensionRiemannSpace K L D) ≤ + Module.finrank K (finiteExtensionOnePointRiemannSpace K L Q m) + + (finiteExtensionDivisorDegree K L + (finiteExtensionDivisorAway K L D Q)).toNat := by + exact finiteExtensionRiemannSpace_finrank_le_onePoint_add_degreeAway + K L D hD Q + have hxHeight : finiteExtensionHeight K L x = b := by + simpa only [L, x, b] using + finiteExtensionHeight_planeCurveFirstCoordinate hf hpartialSecond + have hyHeight : finiteExtensionHeight K L y ≤ a := by + simpa only [L, y, a] using + planeCurveSecondCoordinate_height_le_degreeOf_first + hf hpartialFirst hpartialSecond + have hDdegree : finiteExtensionDivisorDegree K L D ≤ + (n * b + (b - 1) * a : ℕ) := by + dsimp only [D, planeMonomialPoleBudget] + rw [finiteExtensionDivisorDegree_pow_mul_pow_budget, hxHeight] + have hyCast : (finiteExtensionHeight K L y : ℤ) ≤ (a : ℤ) := by + exact_mod_cast hyHeight + calc + (n : ℤ) * (b : ℤ) + ((b - 1 : ℕ) : ℤ) * + (finiteExtensionHeight K L y : ℤ) ≤ + (n : ℤ) * (b : ℤ) + ((b - 1 : ℕ) : ℤ) * (a : ℤ) := by + gcongr + _ = (n * b + (b - 1) * a : ℕ) := by push_cast; ring + have hAwayEffective : ∀ v, 0 ≤ finiteExtensionDivisorAway K L D Q v := + finiteExtensionDivisorAway_effective K L D Q hD + have hAwayDegreeNonnegative : 0 ≤ finiteExtensionDivisorDegree K L + (finiteExtensionDivisorAway K L D Q) := + finiteExtensionDivisorDegree_nonnegative_of_effective K L + (finiteExtensionDivisorAway K L D Q) hAwayEffective + have hAwayPlusSelected : + (finiteExtensionDivisorDegree K L + (finiteExtensionDivisorAway K L D Q)).toNat + + m * finiteExtensionPlaceDegree K L Q ≤ + n * b + (b - 1) * a := by + have hcast : + (((finiteExtensionDivisorDegree K L + (finiteExtensionDivisorAway K L D Q)).toNat + + m * finiteExtensionPlaceDegree K L Q : ℕ) : ℤ) ≤ + ((n * b + (b - 1) * a : ℕ) : ℤ) := by + push_cast + rw [Int.toNat_of_nonneg hAwayDegreeNonnegative, hmCast] + calc + finiteExtensionDivisorDegree K L + (finiteExtensionDivisorAway K L D Q) + + D Q * (finiteExtensionPlaceDegree K L Q : ℤ) = + finiteExtensionDivisorDegree K L D := by + rw [finiteExtensionDivisorDegree_away] + ring + _ ≤ ((n * b + (b - 1) * a : ℕ) : ℤ) := hDdegree + exact_mod_cast hcast + have haPos : 0 < a := degreeOf_first_pos_of_pderiv_ne_zero hpartialFirst + have hbPos : 0 < b := degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond + have hgenusIdentity : + n * b + (b - 1) * a + 1 = (n + 1) * b + g := by + dsimp only [g, planeCurveBidegreeGenusBudget, a, b] + have haEq : MvPolynomial.degreeOf 0 f - 1 + 1 = + MvPolynomial.degreeOf 0 f := by omega + have hbEq : MvPolynomial.degreeOf 1 f - 1 + 1 = + MvPolynomial.degreeOf 1 f := by omega + nlinarith + refine ⟨hm, hfiniteOne, ?_⟩ + change m * finiteExtensionPlaceDegree K L Q + 1 ≤ + Module.finrank K (finiteExtensionOnePointRiemannSpace K L Q m) + g + have hdim := hfullLower.trans hsplit + omega + +/-- An absolutely irreducible plane curve admits a controlled infinity place +and an explicit arithmetic progression of one-point pole levels satisfying +the coarse Riemann lower bound + +`m * degree(P) + 1 ≤ finrank L(m P) + g`, + +where `g = (degreeOf 0 f - 1) * (degreeOf 1 f - 1)`. The first-partial +hypothesis supplies the second-coordinate height bound used by the monomial +budget; the second-partial hypothesis makes the first coordinate separating. -/ +theorem exists_planeCurve_onePointRiemannSpace_progression_lower_bound + {f : MvPolynomial (Fin 2) K} + (habsolute : Irreducible + (MvPolynomial.map (algebraMap K (AlgebraicClosure K)) f)) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) : + let hf : Irreducible f := + irreducible_of_irreducible_map_algebraicClosure habsolute + letI := planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + letI := planeCurveFirstCoordinateRatFuncAlgebra f hx + letI := finiteDimensional_planeCurveFunctionField_over_ratFunc + hf hpartialSecond + letI := separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + ∃ P : FiniteExtensionInfinityPlace K (PlaneCurveFunctionField f), + let Q : FiniteExtensionPlace K (PlaneCurveFunctionField f) := .inr P + 0 < finiteExtensionPoleDivisor K (PlaneCurveFunctionField f) + (planeCurveFunction f 0) Q ∧ + 0 < finiteExtensionPlaceDegree K (PlaneCurveFunctionField f) Q ∧ + finiteExtensionPlaceDegree K (PlaneCurveFunctionField f) Q ≤ + MvPolynomial.degreeOf 1 f ∧ + ∀ n : ℕ, + let m := planeMonomialPoleLevel K (PlaneCurveFunctionField f) + (planeCurveFunction f 0) (planeCurveFunction f 1) n + (MvPolynomial.degreeOf 1 f) Q + m = n * (finiteExtensionPoleDivisor K (PlaneCurveFunctionField f) + (planeCurveFunction f 0) Q).toNat + + (MvPolynomial.degreeOf 1 f - 1) * + (finiteExtensionPoleDivisor K (PlaneCurveFunctionField f) + (planeCurveFunction f 1) Q).toNat ∧ + Module.Finite K (finiteExtensionOnePointRiemannSpace K + (PlaneCurveFunctionField f) Q m) ∧ + m * finiteExtensionPlaceDegree K (PlaneCurveFunctionField f) Q + 1 ≤ + Module.finrank K (finiteExtensionOnePointRiemannSpace K + (PlaneCurveFunctionField f) Q m) + + planeCurveBidegreeGenusBudget f := by + let hf : Irreducible f := + irreducible_of_irreducible_map_algebraicClosure habsolute + exact exists_planeCurve_onePointRiemannSpace_progression_lower_bound_irreducible + hf hpartialFirst hpartialSecond + +/-- Along the progression from +`exists_planeCurve_onePointRiemannSpace_progression_lower_bound`, every level +`m ≥ g` contains at least `m - g` strict inclusions in the one-point Riemann +filtration. Exact constants give the initial dimension one, while adding the +selected place raises dimension by at most its residue degree. -/ +theorem exists_planeCurve_onePointRiemannSpace_progression_strictLevels_lower_bound + {f : MvPolynomial (Fin 2) K} + (habsolute : Irreducible + (MvPolynomial.map (algebraMap K (AlgebraicClosure K)) f)) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) : + let hf : Irreducible f := + irreducible_of_irreducible_map_algebraicClosure habsolute + letI := planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + letI := planeCurveFirstCoordinateRatFuncAlgebra f hx + letI := finiteDimensional_planeCurveFunctionField_over_ratFunc + hf hpartialSecond + letI := separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let constantAlg : Algebra K (PlaneCurveFunctionField f) := + RingHom.toAlgebra + ((algebraMap (RatFunc K) (PlaneCurveFunctionField f)).comp + (algebraMap K (RatFunc K))) + letI : Algebra K (PlaneCurveFunctionField f) := constantAlg + letI : SMul K (PlaneCurveFunctionField f) := constantAlg.toSMul + letI : Module K (PlaneCurveFunctionField f) := constantAlg.toModule + ∃ P : FiniteExtensionInfinityPlace K (PlaneCurveFunctionField f), + let Q : FiniteExtensionPlace K (PlaneCurveFunctionField f) := .inr P + 0 < finiteExtensionPoleDivisor K (PlaneCurveFunctionField f) + (planeCurveFunction f 0) Q ∧ + 0 < finiteExtensionPlaceDegree K (PlaneCurveFunctionField f) Q ∧ + finiteExtensionPlaceDegree K (PlaneCurveFunctionField f) Q ≤ + MvPolynomial.degreeOf 1 f ∧ + ∀ n : ℕ, + let m := planeMonomialPoleLevel K (PlaneCurveFunctionField f) + (planeCurveFunction f 0) (planeCurveFunction f 1) n + (MvPolynomial.degreeOf 1 f) Q + planeCurveBidegreeGenusBudget f ≤ m → + m - planeCurveBidegreeGenusBudget f ≤ + (strictFiltrationLevels + (fun k => finiteExtensionOnePointRiemannSpace K + (PlaneCurveFunctionField f) Q k) m).card := by + let hf : Irreducible f := + irreducible_of_irreducible_map_algebraicClosure habsolute + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let L := PlaneCurveFunctionField f + let x : L := planeCurveFunction f 0 + let y : L := planeCurveFunction f 1 + let b := MvPolynomial.degreeOf 1 f + let g := planeCurveBidegreeGenusBudget f + let : Algebra (RatFunc K) L := + planeCurveFirstCoordinateRatFuncAlgebra f hx + let : FiniteDimensional (RatFunc K) L := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : Algebra.IsSeparable (RatFunc K) L := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let canonicalAlg : Algebra K L := inferInstance + let constantAlg : Algebra K L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K (RatFunc K))) + have hconstantAlg : constantAlg = canonicalAlg := by + apply Algebra.algebra_ext + intro c + change (@ratFuncSpecialization K L _ _ canonicalAlg x hx) (RatFunc.C c) = + @algebraMap K L _ _ canonicalAlg c + have h := DFunLike.congr_fun + (@ratFuncSpecialization_comp_polynomial_algebraMap + K L _ _ canonicalAlg x hx) + (Polynomial.C c) + simpa using h + let : Algebra K L := constantAlg + let : SMul K L := constantAlg.toSMul + let : Module K L := constantAlg.toModule + let : IsScalarTower K (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + obtain ⟨P, hPpole, hPdegreePositive, hPdegreeBound, hprogress⟩ := + exists_planeCurve_onePointRiemannSpace_progression_lower_bound + habsolute hpartialFirst hpartialSecond + let Q : FiniteExtensionPlace K L := .inr P + refine ⟨P, hPpole, hPdegreePositive, hPdegreeBound, ?_⟩ + have hconstantsCanonical : + @algebraicClosure K L _ _ canonicalAlg = ⊥ := by + simpa only [L] using + planeCurveFunctionField_algebraicClosure_eq_bot + f habsolute hpartialSecond + have hconstants : + @algebraicClosure K L _ _ constantAlg = ⊥ := by + rw [hconstantAlg] + exact hconstantsCanonical + have hzeroFinrank : Module.finrank K + (finiteExtensionOnePointRiemannSpace K L Q 0) = 1 := by + change Module.finrank K (finiteExtensionRiemannSpace K L + (Finsupp.single Q (0 : ℤ))) = 1 + have hzeroDivisor : Finsupp.single Q (0 : ℤ) = + (0 : FiniteExtensionDivisor K L) := by + ext v + by_cases hv : v = Q <;> simp [hv] + rw [hzeroDivisor] + exact finiteExtensionRiemannSpace_zero_finrank K L hconstants + have hnested : ∀ k, + finiteExtensionOnePointRiemannSpace K L Q k ≤ + finiteExtensionOnePointRiemannSpace K L Q (k + 1) := by + intro k + exact finiteExtensionOnePointRiemannSpace_mono K L Q (by omega) + have hjump : ∀ k, Module.finrank K + (finiteExtensionOnePointRiemannSpace K L Q (k + 1)) ≤ + Module.finrank K (finiteExtensionOnePointRiemannSpace K L Q k) + + finiteExtensionPlaceDegree K L Q := by + intro k + let Dk : FiniteExtensionDivisor K L := Finsupp.single Q (k : ℤ) + have hDk : ∀ v, 0 ≤ Dk v := by + intro v + by_cases hv : v = Q + · subst v + simp [Dk] + · simp [Dk, Finsupp.single_eq_of_ne hv] + have hfiniteK : Module.Finite K + (finiteExtensionRiemannSpace K L Dk) := + finiteExtensionRiemannSpace_effective_moduleFinite K L Dk hDk + let : Module.Finite K + (finiteExtensionRiemannSpace K L Dk) := hfiniteK + have hstep := finiteExtensionRiemannSpace_place_increment K L Dk hDk Q + have hdivisor : Dk + Finsupp.single Q 1 = + Finsupp.single Q ((k + 1 : ℕ) : ℤ) := by + ext v + by_cases hv : v = Q + · subst v + simp only [Dk, Finsupp.add_apply, Finsupp.single_eq_same] + push_cast + ring + · simp [Dk, Finsupp.single_eq_of_ne hv] + change Module.finrank K (finiteExtensionRiemannSpace K L + (Finsupp.single Q ((k + 1 : ℕ) : ℤ))) ≤ + Module.finrank K (finiteExtensionRiemannSpace K L + (Finsupp.single Q (k : ℤ))) + finiteExtensionPlaceDegree K L Q + rw [← hdivisor] + exact hstep.2 + intro n + let m := planeMonomialPoleLevel K L x y n b Q + change g ≤ m → m - g ≤ + (strictFiltrationLevels + (fun k => finiteExtensionOnePointRiemannSpace K L Q k) m).card + intro hgm + obtain ⟨_hm, _hfinite, hlowerRaw⟩ := hprogress n + have hlower : m * finiteExtensionPlaceDegree K L Q + 1 ≤ + Module.finrank K (finiteExtensionOnePointRiemannSpace K L Q m) + g := by + simpa only [m, L, x, y, b, Q, g] using hlowerRaw + have hdegreeGenus : g ≤ finiteExtensionPlaceDegree K L Q * g := + Nat.le_mul_of_pos_left g hPdegreePositive + have hscaled : 1 + finiteExtensionPlaceDegree K L Q * (m - g) ≤ + Module.finrank K (finiteExtensionOnePointRiemannSpace K L Q m) := by + have hmDecomp : m = (m - g) + g := + (Nat.sub_add_cancel hgm).symm + have hmulDecomp : finiteExtensionPlaceDegree K L Q * m = + finiteExtensionPlaceDegree K L Q * (m - g) + + finiteExtensionPlaceDegree K L Q * g := by + calc + finiteExtensionPlaceDegree K L Q * m = + finiteExtensionPlaceDegree K L Q * ((m - g) + g) := + congrArg (fun t => finiteExtensionPlaceDegree K L Q * t) hmDecomp + _ = finiteExtensionPlaceDegree K L Q * (m - g) + + finiteExtensionPlaceDegree K L Q * g := by + rw [Nat.mul_add] + rw [Nat.mul_comm m (finiteExtensionPlaceDegree K L Q)] at hlower + omega + apply le_card_strictFiltrationLevels_of_initial_add_mul_le_finrank + (fun k => finiteExtensionOnePointRiemannSpace K L Q k) + hPdegreePositive hnested hjump + rw [hzeroFinrank] + exact hscaled + +end + + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/PlaneRationalPlaceAffineComparison.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/PlaneRationalPlaceAffineComparison.lean new file mode 100644 index 0000000000..3ce823b49b --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/PlaneRationalPlaceAffineComparison.lean @@ -0,0 +1,1731 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneAffineRationalPlaceComparison +public import LeanPool.MarkoffModP.BGS.HasseWeil.OnePointLeadingCoefficient +public import LeanPool.MarkoffModP.BGS.HasseWeil.RatFuncParameterPole +public import LeanPool.MarkoffModP.BGS.HasseWeil.GeneralSquareFieldStepanovCount +public import Mathlib.Algebra.Polynomial.RingDivision +public import Mathlib.LinearAlgebra.Dimension.Localization +public import Mathlib.RingTheory.RamificationInertia.Basic + +/-! +# Rational normalization places and affine exceptional fibers + +This file begins the reverse comparison from degree-one normalization places +to affine rational points. It supplies the two finite-place counting APIs +needed independently of the remaining local-center argument: + +* degree-one finite places of `K(X)` are canonically equivalent to `K`; +* rational finite places whose base coordinate is a zero of a polynomial `R` + are bounded by `#Z(R)` times the function-field degree. + +For a plane equation, the exceptional base polynomial is the product of the +second-coordinate leading coefficient and the derivative resultant. The +leading-coefficient factor is necessary: the derivative resultant alone need +not detect degree drop after specialization, especially in positive +characteristic. +-/ + +@[expose] public section + +open scoped Polynomial BigOperators + +namespace BGS.HasseWeil + +noncomputable section + +open BGS.CorvajaZannier Polynomial + +variable (K : Type*) [Field K] [DecidableEq K] + +/-- The normalized prime polynomial corresponding to the affine coordinate `a`. -/ +def linearNormalizedPrime (a : K) : NormalizedPrimePolynomial K := + ⟨Polynomial.X - Polynomial.C a, Polynomial.prime_X_sub_C a, + (Polynomial.monic_X_sub_C a).normalize_eq_self⟩ + +/-- Degree-one finite places of `K(X)` are exactly the linear primes +`X - a`, hence are canonically parametrized by `a : K`. -/ +def ratFuncRationalFinitePlaceEquiv : RatFuncRationalFinitePlace K ≃ K where + toFun P := -((finitePlaceNormalizedPrime P.1 : K[X]).coeff 0) + invFun a := ⟨normalizedPrimeFinitePlace (K := K) (linearNormalizedPrime K a), by + simp [ratFuncFinitePlaceDegree, linearNormalizedPrime]⟩ + left_inv P := by + apply Subtype.ext + let r := finitePlaceNormalizedPrime P.1 + have hrNatDegree : (r : K[X]).natDegree = 1 := by + simpa [r, ratFuncFinitePlaceDegree] using P.2 + have hrDegree : (r : K[X]).degree = 1 := by + simpa [hrNatDegree] using + (Polynomial.degree_eq_natDegree r.property.1.ne_zero) + have hrMonic : (r : K[X]).Monic := by + rw [← r.property.2] + exact Polynomial.monic_normalize r.property.1.ne_zero + have hr : (r : K[X]) = + Polynomial.X - Polynomial.C (-((r : K[X]).coeff 0)) := by + simpa [hrMonic.leadingCoeff] using + (Polynomial.eq_X_add_C_of_degree_eq_one hrDegree) + symm + calc + P.1 = normalizedPrimeFinitePlace (K := K) r := + (normalizedPrimeFinitePlace_finitePlaceNormalizedPrime P.1).symm + _ = normalizedPrimeFinitePlace (K := K) + (linearNormalizedPrime K (-((r : K[X]).coeff 0))) := by + congr 1 + exact Subtype.ext hr + right_inv a := by + simp [linearNormalizedPrime] + +end + + +noncomputable section + +open BGS.CorvajaZannier Polynomial + +variable {K : Type*} [Field K] + +/-- The base polynomial containing both the critical fibers and the fibers +where the second-coordinate degree drops. -/ +noncomputable def secondCoordinateAffineExceptionalPolynomial + (f : MvPolynomial (Fin 2) K) : Polynomial K := + (planeCurvePolynomialInSecondCoordinate f).leadingCoeff * + secondCoordinateCriticalResultant f + +theorem secondCoordinateAffineExceptionalPolynomial_ne_zero + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) : + secondCoordinateAffineExceptionalPolynomial f ≠ 0 := by + have hF0 : planeCurvePolynomialInSecondCoordinate f ≠ 0 := by + intro hzero + have hdegree : (planeCurvePolynomialInSecondCoordinate f).natDegree = 0 := by + rw [hzero, Polynomial.natDegree_zero] + have hpos : 0 < (planeCurvePolynomialInSecondCoordinate f).natDegree := by + simpa using degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond + omega + exact mul_ne_zero (Polynomial.leadingCoeff_ne_zero.mpr hF0) + (secondCoordinateCriticalResultant_ne_zero hf hpartialSecond) + +theorem secondCoordinateAffineExceptionalPolynomial_natDegree_le + {f : MvPolynomial (Fin 2) K} {firstDegree secondDegree : ℕ} + (hdegree : BGS.External.HasBidegreeAtMost f firstDegree secondDegree) : + (secondCoordinateAffineExceptionalPolynomial f).natDegree ≤ + firstDegree + (2 * secondDegree - 1) * firstDegree := by + calc + (secondCoordinateAffineExceptionalPolynomial f).natDegree ≤ + (planeCurvePolynomialInSecondCoordinate f).leadingCoeff.natDegree + + (secondCoordinateCriticalResultant f).natDegree := + Polynomial.natDegree_mul_le + _ ≤ firstDegree + (2 * secondDegree - 1) * firstDegree := by + exact Nat.add_le_add + (planeCurvePolynomialInSecondCoordinate_coeff_natDegree_le hdegree _) + (secondCoordinateCriticalResultant_natDegree_le hdegree) + +theorem secondCoordinateAffineExceptionalBase_card_le + [Fintype K] [DecidableEq K] + {f : MvPolynomial (Fin 2) K} {firstDegree secondDegree : ℕ} + (hdegree : BGS.External.HasBidegreeAtMost f firstDegree secondDegree) + (hf : Irreducible f) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) : + Fintype.card {a : K // + (secondCoordinateAffineExceptionalPolynomial f).eval a = 0} ≤ + firstDegree + (2 * secondDegree - 1) * firstDegree := by + exact (polynomialEvalZeroSubtype_card_le_natDegree + (secondCoordinateAffineExceptionalPolynomial f) + (secondCoordinateAffineExceptionalPolynomial_ne_zero hf hpartialSecond)).trans + (secondCoordinateAffineExceptionalPolynomial_natDegree_le hdegree) + +end + + +noncomputable section + +open BGS.CorvajaZannier IsDedekindDomain + +variable (K : Type*) [Field K] [DecidableEq K] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + [DecidableEq (RatFunc K)] + +local instance rationalComparisonConstantAlgebra : Algebra K L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K (RatFunc K))) + +local instance rationalComparisonConstantScalarTower : + IsScalarTower K (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + +local instance (priority := 10) rationalComparisonPolynomialAlgebra : + Algebra K[X] L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K[X] (RatFunc K))) + +local instance rationalComparisonPolynomialScalarTower : + IsScalarTower K[X] (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + +local instance rationalComparisonFiniteClosureModuleFinite : + Module.Finite K[X] (RatFuncFiniteIntegralClosure K L) := + Module.IsNoetherian.finite K[X] (RatFuncFiniteIntegralClosure K L) + +local instance rationalComparisonPolynomialTorsionFreeTop : + Module.IsTorsionFree K[X] L := + Module.IsTorsionFree.trans_faithfulSMul K[X] (RatFunc K) L + +local instance rationalComparisonFiniteClosureTorsionFree : + Module.IsTorsionFree K[X] (RatFuncFiniteIntegralClosure K L) := + IsIntegralClosure.isTorsionFree K[X] L + +local instance rationalComparisonFiniteClosureNoZeroSMulDivisors : + NoZeroSMulDivisors K[X] (RatFuncFiniteIntegralClosure K L) where + eq_zero_or_eq_zero_of_smul_eq_zero h := smul_eq_zero.mp h + +local instance rationalComparisonFiniteClosureDedekind : + IsDedekindDomain (RatFuncFiniteIntegralClosure K L) := + IsIntegralClosure.isDedekindDomain K[X] (RatFunc K) L + (RatFuncFiniteIntegralClosure K L) + +local instance rationalComparisonFiniteClosureFractionRing : + IsFractionRing (RatFuncFiniteIntegralClosure K L) L := + IsIntegralClosure.isFractionRing_of_finite_extension K[X] (RatFunc K) L + (RatFuncFiniteIntegralClosure K L) + +local instance rationalComparisonFiniteClosureConstantAlgebra : + Algebra K (RatFuncFiniteIntegralClosure K L) := + RingHom.toAlgebra ((algebraMap K[X] + (RatFuncFiniteIntegralClosure K L)).comp (algebraMap K K[X])) + +local instance rationalComparisonFiniteClosureConstantTower : + IsScalarTower K K[X] (RatFuncFiniteIntegralClosure K L) := + IsScalarTower.of_algebraMap_eq' rfl + +local instance rationalComparisonFiniteClosureConstantTowerToField : + IsScalarTower K (RatFuncFiniteIntegralClosure K L) L := by + apply IsScalarTower.of_algebraMap_eq' + ext c + rw [IsScalarTower.algebraMap_apply K (RatFunc K) L] + rfl + +/-- At a rational finite place, a nonconstant regular function has a unique +constant residue representative, expressed by positive order of the +difference. -/ +theorem exists_constant_sub_finitePlaceOrder_pos_of_nonnegative + (q : FiniteExtensionRationalFinitePlace K L) (z : L) + (hz : z ≠ 0) + (hnotConstant : ∀ c : K, z ≠ algebraMap K L c) + (hregular : 0 ≤ finitePlaceOrder q.1 z) : + ∃ c : K, 0 < finitePlaceOrder q.1 (z - algebraMap K L c) := by + by_cases hpos : 0 < finitePlaceOrder q.1 z + · exact ⟨0, by simpa using hpos⟩ + have hzero : finitePlaceOrder q.1 z = 0 := + le_antisymm (not_lt.mp hpos) hregular + have horders : + finiteExtensionPrincipalDivisor K L z (.inl q.1) = + finiteExtensionPrincipalDivisor K L 1 (.inl q.1) := by + rw [finiteExtensionPrincipalDivisor_inl_eq_finitePlaceOrder, hzero, + finiteExtensionPrincipalDivisor_one] + rfl + obtain ⟨c, hc⟩ := + exists_constant_finiteExtensionPlaceOrder_sub_mul_eq_zero_or_lt + K L (.inl q.1) q.2 z 1 hz one_ne_zero horders + refine ⟨c, ?_⟩ + rcases hc with hconstant | hstrict + · exact (hnotConstant c (by simpa using sub_eq_zero.mp hconstant)).elim + · rw [finiteExtensionPrincipalDivisor_inl_eq_finitePlaceOrder, hzero] at hstrict + simpa only [mul_one, + finiteExtensionPrincipalDivisor_inl_eq_finitePlaceOrder] using hstrict + +omit [DecidableEq K] [DecidableEq (RatFunc K)] in +/-- Nonnegative finite-place order is equivalent to regularity in the +canonical valuation subring; this direction is the one needed below. -/ +theorem mem_valuationSubringAtPrime_of_finitePlaceOrder_nonnegative + (q : HeightOneSpectrum (RatFuncFiniteIntegralClosure K L)) + (z : L) (hz : z ≠ 0) (hregular : 0 ≤ finitePlaceOrder q z) : + z ∈ IsDedekindDomain.HeightOneSpectrum.valuationSubringAtPrime L q := by + rw [IsDedekindDomain.HeightOneSpectrum.valuationSubringAtPrime_eq_valuationSubring] + change q.valuation L z ≤ 1 + rw [valuation_eq_exp_neg_finitePlaceOrder q z hz, ← WithZero.exp_zero] + exact WithZero.exp_le_exp.mpr (by omega) + +omit [DecidableEq (RatFunc K)] in +/-- The full lying-over fiber above a rational finite base place has at most +the extension degree many primes. -/ +theorem rationalBasePlace_primesOver_card_le_finrank + (P : RatFuncRationalFinitePlace K) : + Fintype.card + (P.1.asIdeal.primesOver (RatFuncFiniteIntegralClosure K L)) ≤ + Module.finrank (RatFunc K) L := by + let : Fintype + (P.1.asIdeal.primesOver (RatFuncFiniteIntegralClosure K L)) := + Set.Finite.fintype (IsDedekindDomain.primesOver_finite P.1.asIdeal + (RatFuncFiniteIntegralClosure K L)) + calc + Fintype.card (P.1.asIdeal.primesOver (RatFuncFiniteIntegralClosure K L)) = + ∑ _Q : P.1.asIdeal.primesOver (RatFuncFiniteIntegralClosure K L), 1 := by + simp + _ ≤ ∑ Q : P.1.asIdeal.primesOver (RatFuncFiniteIntegralClosure K L), + Q.1.ramificationIdx K[X] * Q.1.inertiaDeg K[X] := by + apply Finset.sum_le_sum + intro Q _ + exact Nat.one_le_of_lt (Nat.mul_pos + (Ideal.ramificationIdx_pos Q.1 K[X]) (Ideal.inertiaDeg_pos Q.1 K[X])) + _ = Module.finrank K[X] (RatFuncFiniteIntegralClosure K L) := + Ideal.sum_ramification_inertia_eq_finrank P.1.asIdeal + (RatFuncFiniteIntegralClosure K L) + _ = Module.finrank (RatFunc K) L := + (IsFractionRing.finrank_eq K[X] (RatFunc K) + (RatFuncFiniteIntegralClosure K L) L).symm + +/-- The first-coordinate value of the rational base place below a rational +finite extension place. -/ +def rationalFinitePlaceBaseCoordinate + (Q : FiniteExtensionRationalFinitePlace K L) : K := + ratFuncRationalFinitePlaceEquiv K + (rationalFinitePlaceToBaseFiber K L Q).1 + +/-- Rational finite places whose base coordinate is a zero of `R`. -/ +abbrev RationalFinitePlaceOverPolynomialZeros (R : Polynomial K) := + {Q : FiniteExtensionRationalFinitePlace K L // + R.eval (rationalFinitePlaceBaseCoordinate K L Q) = 0} + +/-- A base polynomial with `r` rational roots accounts for at most +`r * [L : K(X)]` rational finite places. -/ +theorem rationalFinitePlaceOverPolynomialZeros_card_le + [Fintype K] (R : Polynomial K) : + Nat.card (RationalFinitePlaceOverPolynomialZeros K L R) ≤ + Fintype.card {a : K // R.eval a = 0} * + Module.finrank (RatFunc K) L := by + let baseZero := {P : RatFuncRationalFinitePlace K // + R.eval (ratFuncRationalFinitePlaceEquiv K P) = 0} + let : Fintype (RationalFinitePlaceOverPolynomialZeros K L R) := + Fintype.ofFinite _ + let : Fintype baseZero := Fintype.ofFinite baseZero + let (P : baseZero) : + Fintype (P.1.1.asIdeal.primesOver + (RatFuncFiniteIntegralClosure K L)) := + Set.Finite.fintype (IsDedekindDomain.primesOver_finite P.1.1.asIdeal + (RatFuncFiniteIntegralClosure K L)) + let embedding : RationalFinitePlaceOverPolynomialZeros K L R → + Sigma (fun P : baseZero => P.1.1.asIdeal.primesOver + (RatFuncFiniteIntegralClosure K L)) := fun Q => + ⟨⟨(rationalFinitePlaceToBaseFiber K L Q.1).1, Q.2⟩, + (rationalFinitePlaceToBaseFiber K L Q.1).2⟩ + have embedding_injective : Function.Injective embedding := by + intro Q S hQS + apply Subtype.ext + apply Subtype.ext + apply HeightOneSpectrum.ext + have hIdeals := congrArg + (fun z : Sigma (fun P : baseZero => P.1.1.asIdeal.primesOver + (RatFuncFiniteIntegralClosure K L)) => z.2.1) hQS + simpa [embedding, rationalFinitePlaceToBaseFiber] using hIdeals + let baseEquiv : baseZero ≃ {a : K // R.eval a = 0} := + Equiv.subtypeEquiv (ratFuncRationalFinitePlaceEquiv K) (by + intro P + rfl) + calc + Nat.card (RationalFinitePlaceOverPolynomialZeros K L R) = + Fintype.card (RationalFinitePlaceOverPolynomialZeros K L R) := + Nat.card_eq_fintype_card + _ ≤ Fintype.card (Sigma (fun P : baseZero => + P.1.1.asIdeal.primesOver (RatFuncFiniteIntegralClosure K L))) := + Fintype.card_le_of_injective embedding embedding_injective + _ = ∑ P : baseZero, Fintype.card + (P.1.1.asIdeal.primesOver (RatFuncFiniteIntegralClosure K L)) := + Fintype.card_sigma + _ ≤ ∑ _P : baseZero, Module.finrank (RatFunc K) L := by + exact Finset.sum_le_sum fun P _ => + rationalBasePlace_primesOver_card_le_finrank K L P.1 + _ = Fintype.card baseZero * Module.finrank (RatFunc K) L := by + simp + _ = Fintype.card {a : K // R.eval a = 0} * + Module.finrank (RatFunc K) L := by + rw [Fintype.card_congr baseEquiv] + +/-- Rational finite places whose base coordinate avoids the zero locus of +`R`. -/ +abbrev RationalFinitePlaceAwayFromPolynomialZeros (R : Polynomial K) := + {Q : FiniteExtensionRationalFinitePlace K L // + R.eval (rationalFinitePlaceBaseCoordinate K L Q) ≠ 0} + +/-- Rational finite places split as the places away from `R = 0` and the +places over `R = 0`. -/ +theorem rationalFinitePlace_card_eq_away_add_overPolynomialZeros + [Finite K] (R : Polynomial K) : + Nat.card (FiniteExtensionRationalFinitePlace K L) = + Nat.card (RationalFinitePlaceAwayFromPolynomialZeros K L R) + + Nat.card (RationalFinitePlaceOverPolynomialZeros K L R) := by + classical + calc + Nat.card (FiniteExtensionRationalFinitePlace K L) = + Nat.card + (RationalFinitePlaceOverPolynomialZeros K L R ⊕ + RationalFinitePlaceAwayFromPolynomialZeros K L R) := + Nat.card_congr + (Equiv.sumCompl (fun Q : FiniteExtensionRationalFinitePlace K L => + R.eval (rationalFinitePlaceBaseCoordinate K L Q) = 0)).symm + _ = Nat.card (RationalFinitePlaceOverPolynomialZeros K L R) + + Nat.card (RationalFinitePlaceAwayFromPolynomialZeros K L R) := + Nat.card_sum + _ = Nat.card (RationalFinitePlaceAwayFromPolynomialZeros K L R) + + Nat.card (RationalFinitePlaceOverPolynomialZeros K L R) := + Nat.add_comm _ _ + +/-- Abstract reverse counting principle. An injective center map from the +rational finite places away from `R = 0` into a finite type `A`, together with +the bad-fiber and infinity estimates, bounds every rational place. -/ +theorem finiteExtensionRationalPlaceCount_le_natCard_add_polynomialZeros_of_away_injective + [Fintype K] (R : Polynomial K) (A : Type*) [Finite A] + (center : RationalFinitePlaceAwayFromPolynomialZeros K L R → A) + (hcenter : Function.Injective center) : + finiteExtensionRationalPlaceCount K L ≤ + Nat.card A + + Fintype.card {a : K // R.eval a = 0} * + Module.finrank (RatFunc K) L + + Module.finrank (RatFunc K) L := by + classical + have hgood : + Nat.card (RationalFinitePlaceAwayFromPolynomialZeros K L R) ≤ + Nat.card A := + Nat.card_le_card_of_injective center hcenter + have hbad := rationalFinitePlaceOverPolynomialZeros_card_le K L R + have hinfinity := rationalInfinityPlace_card_le_finrank K L + rw [finiteExtensionRationalPlaceCount, Nat.card_sum, + rationalFinitePlace_card_eq_away_add_overPolynomialZeros + (K := K) (L := L) R] + omega + +/-- A base polynomial that does not vanish at the rational base coordinate +of a rational finite extension place becomes a unit in that place's +valuation subring. -/ +theorem rationalFinitePlacePolynomial_isUnit_of_eval_baseCoordinate_ne_zero + (Q : FiniteExtensionRationalFinitePlace K L) (R : Polynomial K) + (hR : R.eval (rationalFinitePlaceBaseCoordinate K L Q) ≠ 0) : + let V := IsDedekindDomain.HeightOneSpectrum.valuationSubringAtPrime L Q.1 + letI : Algebra K[X] V := RingHom.toAlgebra + ((algebraMap (RatFuncFiniteIntegralClosure K L) V).comp + (algebraMap K[X] (RatFuncFiniteIntegralClosure K L))) + IsUnit (algebraMap K[X] V R) := by + let B := RatFuncFiniteIntegralClosure K L + let V := IsDedekindDomain.HeightOneSpectrum.valuationSubringAtPrime L Q.1 + let : Algebra K[X] V := RingHom.toAlgebra + ((algebraMap (RatFuncFiniteIntegralClosure K L) V).comp + (algebraMap K[X] (RatFuncFiniteIntegralClosure K L))) + dsimp only + by_contra hunit + have hmax : algebraMap K[X] V R ∈ IsLocalRing.maximalIdeal V := by + rw [IsLocalRing.mem_maximalIdeal, mem_nonunits_iff] + exact hunit + have hqB : algebraMap K[X] B R ∈ Q.1.asIdeal := by + rw [← IsLocalization.AtPrime.under_maximalIdeal V Q.1.asIdeal] + exact hmax + have hbase : R ∈ + (IsDedekindDomain.HeightOneSpectrum.under K[X] Q.1).asIdeal := hqB + let P : RatFuncRationalFinitePlace K := + (rationalFinitePlaceToBaseFiber K L Q).1 + let a : K := ratFuncRationalFinitePlaceEquiv K P + have hP : P = (ratFuncRationalFinitePlaceEquiv K).symm a := by + exact (Equiv.symm_apply_apply (ratFuncRationalFinitePlaceEquiv K) P).symm + have hspan : R ∈ Ideal.span {Polynomial.X - Polynomial.C a} := by + change R ∈ P.1.asIdeal at hbase + rw [hP] at hbase + exact hbase + have heval : R.eval a = 0 := by + have hker : R ∈ RingHom.ker (Polynomial.evalRingHom a) := by + rw [Polynomial.ker_evalRingHom] + exact hspan + simpa [RingHom.mem_ker] using hker + exact hR heval + +/-- The residue of the rational-function parameter at a rational finite +extension place is its recorded base coordinate. -/ +theorem rationalFinitePlaceBaseCoordinate_residue + (Q : FiniteExtensionRationalFinitePlace K L) : + let B := RatFuncFiniteIntegralClosure K L + let V := HeightOneSpectrum.valuationSubringAtPrime L Q.1 + letI : Algebra K[X] V := RingHom.toAlgebra + ((algebraMap B V).comp (algebraMap K[X] B)) + letI : Algebra K V := RingHom.toAlgebra + ((algebraMap B V).comp (algebraMap K B)) + letI : IsScalarTower K K[X] V := IsScalarTower.of_algebraMap_eq' rfl + let m := IsLocalRing.maximalIdeal V + algebraMap K m.ResidueField (rationalFinitePlaceBaseCoordinate K L Q) = + algebraMap V m.ResidueField (algebraMap K[X] V Polynomial.X) := by + let B := RatFuncFiniteIntegralClosure K L + let V := HeightOneSpectrum.valuationSubringAtPrime L Q.1 + let : Algebra K[X] V := RingHom.toAlgebra + ((algebraMap B V).comp (algebraMap K[X] B)) + let : Algebra K V := RingHom.toAlgebra + ((algebraMap B V).comp (algebraMap K B)) + let : IsScalarTower K K[X] V := IsScalarTower.of_algebraMap_eq' rfl + let m := IsLocalRing.maximalIdeal V + dsimp only + let P : RatFuncRationalFinitePlace K := + (rationalFinitePlaceToBaseFiber K L Q).1 + let a : K := ratFuncRationalFinitePlaceEquiv K P + have hP : P = (ratFuncRationalFinitePlaceEquiv K).symm a := by + exact (Equiv.symm_apply_apply (ratFuncRationalFinitePlaceEquiv K) P).symm + have hlinear : Polynomial.X - Polynomial.C a ∈ + (HeightOneSpectrum.under K[X] Q.1).asIdeal := by + change Polynomial.X - Polynomial.C a ∈ P.1.asIdeal + rw [hP] + exact Ideal.mem_span_singleton_self (Polynomial.X - Polynomial.C a) + have hB : algebraMap K[X] B (Polynomial.X - Polynomial.C a) ∈ + Q.1.asIdeal := hlinear + have hV : algebraMap B V + (algebraMap K[X] B (Polynomial.X - Polynomial.C a)) ∈ m := by + rw [← IsLocalization.AtPrime.under_maximalIdeal V Q.1.asIdeal] at hB + exact hB + have hzero : algebraMap V m.ResidueField + (algebraMap K[X] V (Polynomial.X - Polynomial.C a)) = 0 := by + apply Ideal.algebraMap_residueField_eq_zero.mpr + change algebraMap B V + (algebraMap K[X] B (Polynomial.X - Polynomial.C a)) ∈ m + exact hV + have ha : a = rationalFinitePlaceBaseCoordinate K L Q := rfl + rw [← ha] + have htower : ∀ c : K, algebraMap K V c = + algebraMap K[X] V (Polynomial.C c) := by + intro c + exact (IsScalarTower.algebraMap_apply K K[X] V c).symm + simp only [map_sub] at hzero + rw [← htower a, + ← IsScalarTower.algebraMap_apply K V m.ResidueField a] at hzero + exact (sub_eq_zero.mp hzero).symm + +end + + +noncomputable section + +open BGS.CorvajaZannier IsDedekindDomain Polynomial + + +variable {K : Type*} [Field K] [Fintype K] [DecidableEq K] +variable {f : MvPolynomial (Fin 2) K} + +private theorem mem_valuationSubring_of_polynomial_root + {A E : Type*} [CommRing A] [Field E] (V : ValuationSubring E) + [Algebra A V] [Algebra A E] [IsScalarTower A V E] + (F : A[X]) (x : E) + (hinjective : Function.Injective (algebraMap A E)) + (hlcUnit : IsUnit (algebraMap A V F.leadingCoeff)) + (hroot : Polynomial.aeval x F = 0) : x ∈ V := by + let G : V[X] := F.map (algebraMap A V) + have hmap : Function.Injective (algebraMap A V) := by + intro p q hpq + apply hinjective + have h := congrArg (algebraMap V E) hpq + simpa only [IsScalarTower.algebraMap_apply A V E] using h + have hGUnit : IsUnit G.leadingCoeff := by + rw [Polynomial.leadingCoeff_map_of_injective hmap F] + exact hlcUnit + have hGRoot : Polynomial.aeval x G = 0 := by + rw [Polynomial.aeval_def, Polynomial.eval₂_map, ← IsScalarTower.algebraMap_eq A V E] + exact hroot + let H : V[X] := hGUnit.unit⁻¹ • G + have hHMonic : H.Monic := Polynomial.monic_of_isUnit_leadingCoeff_inv_smul hGUnit + have hHRoot : Polynomial.aeval x H = 0 := by + change Polynomial.aeval x (hGUnit.unit⁻¹ • G) = 0 + rw [Units.smul_def, map_smul, hGRoot, smul_zero] + have hintegral : IsIntegral V x := ⟨H, hHMonic, hHRoot⟩ + obtain ⟨y, hy⟩ := IsIntegrallyClosed.isIntegral_iff.mp hintegral + exact hy ▸ y.2 + +omit [Fintype K] in +/-- Away from the leading-coefficient zero locus, the second plane +coordinate is regular in the valuation subring of a rational finite place. +The proof makes the specialized leading coefficient a unit, obtains a monic +equation over the valuation ring, and uses its integral closedness. -/ +theorem planeCurveSecondCoordinate_mem_valuationSubringAtPrime_of_affineExceptional_ne_zero + (hf : Irreducible f) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) : + let := planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let := planeCurveFirstCoordinateRatFuncAlgebra f hx + let : Algebra (Polynomial K) (PlaneCurveFunctionField f) := + RingHom.toAlgebra + ((algebraMap (RatFunc K) (PlaneCurveFunctionField f)).comp + (algebraMap (Polynomial K) (RatFunc K))) + let : IsScalarTower (Polynomial K) (RatFunc K) + (PlaneCurveFunctionField f) := + IsScalarTower.of_algebraMap_eq' rfl + let : FiniteDimensional (RatFunc K) (PlaneCurveFunctionField f) := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : Algebra.IsSeparable (RatFunc K) (PlaneCurveFunctionField f) := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : DecidableEq (RatFunc K) := Classical.decEq _ + ∀ Q : FiniteExtensionRationalFinitePlace K (PlaneCurveFunctionField f), + (secondCoordinateAffineExceptionalPolynomial f).eval + (rationalFinitePlaceBaseCoordinate K (PlaneCurveFunctionField f) Q) ≠ 0 → + planeCurveFunction f 1 ∈ + IsDedekindDomain.HeightOneSpectrum.valuationSubringAtPrime + (PlaneCurveFunctionField f) Q.1 := by + intro model1 hx model3 model4 model5 model6 model7 model8 + classical + let E := PlaneCurveFunctionField f + let : Field E := inferInstance + let : SMul (RatFunc K) E := Algebra.toSMul + let : Module (RatFunc K) E := Algebra.toModule + let : SMul K[X] E := Algebra.toSMul + let : Module K[X] E := Algebra.toModule + let B := RatFuncFiniteIntegralClosure K E + let : CommRing B := inferInstance + let : SMul K[X] B := Algebra.toSMul + let : Module K[X] B := Algebra.toModule + let : Module.Finite K[X] B := + Module.IsNoetherian.finite K[X] B + let : Module.IsTorsionFree K[X] E := + Module.IsTorsionFree.trans_faithfulSMul K[X] (RatFunc K) E + let : Module.IsTorsionFree K[X] B := + IsIntegralClosure.isTorsionFree K[X] E + let : NoZeroSMulDivisors K[X] B := + { eq_zero_or_eq_zero_of_smul_eq_zero := fun h => smul_eq_zero.mp h } + let : IsDedekindDomain B := + IsIntegralClosure.isDedekindDomain K[X] (RatFunc K) E B + let : IsFractionRing B E := + IsIntegralClosure.isFractionRing_of_finite_extension K[X] + (RatFunc K) E B + intro Q hgood + let V := IsDedekindDomain.HeightOneSpectrum.valuationSubringAtPrime E Q.1 + let : Algebra V E := Algebra.ofSubsemiring V + let : SMul V E := Algebra.toSMul + let : Module V E := Algebra.toModule + let : Algebra K[X] V := RingHom.toAlgebra + ((algebraMap B V).comp (algebraMap K[X] B)) + let : IsScalarTower K[X] V E := + IsScalarTower.of_algebraMap_eq' rfl + let F : K[X][X] := planeCurvePolynomialInSecondCoordinate f + have hlcEval : F.leadingCoeff.eval + (rationalFinitePlaceBaseCoordinate K E Q) ≠ 0 := by + change ((planeCurvePolynomialInSecondCoordinate f).leadingCoeff * + secondCoordinateCriticalResultant f).eval + (rationalFinitePlaceBaseCoordinate K E Q) ≠ 0 at hgood + rw [Polynomial.eval_mul] at hgood + exact (mul_ne_zero_iff.mp hgood).1 + have hlcUnit : IsUnit (algebraMap K[X] V F.leadingCoeff) := + rationalFinitePlacePolynomial_isUnit_of_eval_baseCoordinate_ne_zero + K E Q F.leadingCoeff hlcEval + apply mem_valuationSubring_of_polynomial_root V F (planeCurveFunction f 1) + (Module.isTorsionFree_iff_algebraMap_injective.mp + (show Module.IsTorsionFree K[X] E from inferInstance)) hlcUnit + have hroot := aeval_planeCurvePolynomialInSecondCoordinate_ratFunc_eq_zero hf hpartialSecond + dsimp only at hroot + rw [Polynomial.aeval_def, Polynomial.eval₂_map, + ← IsScalarTower.algebraMap_eq K[X] (RatFunc K) E] at hroot + exact hroot + +private theorem eval_pair_eq_zero_of_residue + {K E : Type*} [Field K] [Field E] [Algebra K E] + (V : ValuationSubring E) [Algebra K V] [IsScalarTower K V E] + (m : Ideal V) [m.IsMaximal] (f : MvPolynomial (Fin 2) K) + (xv yv : V) (a b : K) + (ha : algebraMap K m.ResidueField a = algebraMap V m.ResidueField xv) + (hb : algebraMap K m.ResidueField b = algebraMap V m.ResidueField yv) + (hroot : MvPolynomial.eval₂ (algebraMap K E) ![(xv : E), (yv : E)] f = 0) : + MvPolynomial.eval ![a, b] f = 0 := by + let evalV : MvPolynomial (Fin 2) K →+* V := + MvPolynomial.eval₂Hom (algebraMap K V) ![xv, yv] + have hfV : evalV f = 0 := by + apply Subtype.ext + change algebraMap V E (MvPolynomial.eval₂ (algebraMap K V) ![xv, yv] f) = 0 + rw [MvPolynomial.eval₂_comp_left, ← IsScalarTower.algebraMap_eq K V E] + have hcoordinates : (algebraMap V E) ∘ ![xv, yv] = ![(xv : E), (yv : E)] := by + funext i + fin_cases i <;> rfl + rw [hcoordinates] + exact hroot + let evalK : MvPolynomial (Fin 2) K →+* K := + MvPolynomial.eval₂Hom (RingHom.id K) ![a, b] + have hcomp : (algebraMap K m.ResidueField).comp evalK = + (algebraMap V m.ResidueField).comp evalV := by + apply MvPolynomial.ringHom_ext + · intro c + simp only [RingHom.comp_apply, evalK, evalV, + MvPolynomial.coe_eval₂Hom, MvPolynomial.eval₂_C] + exact (IsScalarTower.algebraMap_apply K V m.ResidueField c).symm + · intro i + fin_cases i + · simpa [evalK, evalV] using ha + · simpa [evalK, evalV] using hb + change evalK f = 0 + apply (algebraMap K m.ResidueField).injective + calc + algebraMap K m.ResidueField (evalK f) = algebraMap V m.ResidueField (evalV f) := + DFunLike.congr_fun hcomp f + _ = algebraMap K m.ResidueField 0 := by rw [hfV, map_zero, map_zero] + +/-- The affine residue center of a rational finite normalization place away +from the leading-coefficient/discriminant locus. Both plane coordinates are +regular there, and the degree-one residue field identifies their residue +classes with unique constants in `K`. -/ +noncomputable def planeCurveGoodRationalFinitePlaceCenter + (hf : Irreducible f) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) : + let := planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let := planeCurveFirstCoordinateRatFuncAlgebra f hx + let : Algebra (Polynomial K) (PlaneCurveFunctionField f) := + RingHom.toAlgebra + ((algebraMap (RatFunc K) (PlaneCurveFunctionField f)).comp + (algebraMap (Polynomial K) (RatFunc K))) + let : IsScalarTower (Polynomial K) (RatFunc K) + (PlaneCurveFunctionField f) := + IsScalarTower.of_algebraMap_eq' rfl + let : FiniteDimensional (RatFunc K) (PlaneCurveFunctionField f) := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : Algebra.IsSeparable (RatFunc K) (PlaneCurveFunctionField f) := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : DecidableEq (RatFunc K) := Classical.decEq _ + RationalFinitePlaceAwayFromPolynomialZeros K + (PlaneCurveFunctionField f) + (secondCoordinateAffineExceptionalPolynomial f) → + AffinePlaneCurvePoint f := by + intro model1 hx model3 model4 model5 model6 model7 model8 + classical + let E := PlaneCurveFunctionField f + letI : Field E := inferInstance + letI : AddCommMonoid E := inferInstance + let : SMul (RatFunc K) E := Algebra.toSMul + let : Module (RatFunc K) E := Algebra.toModule + let : SMul K[X] E := Algebra.toSMul + let : Module K[X] E := Algebra.toModule + let B := RatFuncFiniteIntegralClosure K E + letI : CommRing B := inferInstance + letI : AddCommMonoid B := inferInstance + let : SMul K[X] B := Algebra.toSMul + let : Module K[X] B := Algebra.toModule + let : Module.Finite K[X] B := Module.IsNoetherian.finite K[X] B + let : Module.IsTorsionFree K[X] E := + Module.IsTorsionFree.trans_faithfulSMul K[X] (RatFunc K) E + let : Module.IsTorsionFree K[X] B := + IsIntegralClosure.isTorsionFree K[X] E + let : NoZeroSMulDivisors K[X] B := + { eq_zero_or_eq_zero_of_smul_eq_zero := fun h => smul_eq_zero.mp h } + let : IsDedekindDomain B := + IsIntegralClosure.isDedekindDomain K[X] (RatFunc K) E B + let : IsFractionRing B E := + IsIntegralClosure.isFractionRing_of_finite_extension K[X] + (RatFunc K) E B + let : Algebra K B := RingHom.toAlgebra + ((algebraMap K[X] B).comp (algebraMap K K[X])) + letI : SMul K B := Algebra.toSMul + letI : Module K B := Algebra.toModule + letI : SMul K E := Algebra.toSMul + letI : Module K E := Algebra.toModule + let : IsScalarTower K K[X] B := IsScalarTower.of_algebraMap_eq' rfl + let : IsScalarTower K (RatFunc K) E := + IsScalarTower.of_algebraMap_eq' (by + ext c + have h := congrArg + (fun g : Polynomial K →+* E => g (Polynomial.C c)) + (ratFuncSpecialization_comp_polynomial_algebraMap + (planeCurveFunction f 0) hx) + simpa [E, planeCurveFirstCoordinateRatFuncAlgebra] using h.symm) + let : IsScalarTower K K[X] E := + IsScalarTower.of_algebraMap_eq' (by + ext c + rw [IsScalarTower.algebraMap_apply K (RatFunc K) E, + IsScalarTower.algebraMap_apply K K[X] (RatFunc K)] + rfl) + let : IsScalarTower K B E := IsScalarTower.of_algebraMap_eq' (by + ext c + rw [IsScalarTower.algebraMap_apply K K[X] E] + rfl) + intro Q + let V := HeightOneSpectrum.valuationSubringAtPrime E Q.1.1 + letI : Algebra B V := inferInstance + letI : SMul B V := Algebra.toSMul + letI : Module B V := Algebra.toModule + let : Algebra V E := Algebra.ofSubsemiring V + let : SMul V E := Algebra.toSMul + let : Module V E := Algebra.toModule + let : Algebra K[X] V := RingHom.toAlgebra + ((algebraMap B V).comp (algebraMap K[X] B)) + let : IsScalarTower K[X] V E := IsScalarTower.of_algebraMap_eq' rfl + let : Algebra K V := RingHom.toAlgebra + ((algebraMap B V).comp (algebraMap K B)) + letI : SMul K V := Algebra.toSMul + letI : Module K V := Algebra.toModule + let : IsScalarTower K B V := IsScalarTower.of_algebraMap_eq' rfl + let : IsScalarTower K V E := IsScalarTower.of_algebraMap_eq' (by + ext c + rw [IsScalarTower.algebraMap_apply K B E] + rfl) + let m := IsLocalRing.maximalIdeal V + have hglobalResidue : Function.Surjective + (algebraMap K Q.1.1.asIdeal.ResidueField) := + finiteExtensionFinitePlace_constantResidue_surjective_of_degree_one + K E Q.1.1 Q.1.2 + have hresidue : Function.Surjective + (algebraMap K m.ResidueField) := + localizationAtPrime_constantResidue_surjective + (C := K) (R := B) (S := V) Q.1.1 hglobalResidue + let xv : V := algebraMap K[X] V Polynomial.X + have hxv : (xv : E) = planeCurveFunction f 0 := by + rw [show (xv : E) = algebraMap K[X] E Polynomial.X by + exact IsScalarTower.algebraMap_apply K[X] V E Polynomial.X] + have h := congrArg + (fun g : Polynomial K →+* E => g Polynomial.X) + (ratFuncSpecialization_comp_polynomial_algebraMap + (planeCurveFunction f 0) hx) + change ratFuncSpecialization (planeCurveFunction f 0) hx + (algebraMap K[X] (RatFunc K) Polynomial.X) = planeCurveFunction f 0 + simpa using h + have hymem : planeCurveFunction f 1 ∈ V := + planeCurveSecondCoordinate_mem_valuationSubringAtPrime_of_affineExceptional_ne_zero + hf hpartialSecond Q.1 Q.2 + let yv : V := ⟨planeCurveFunction f 1, hymem⟩ + let a : K := rationalFinitePlaceBaseCoordinate K E Q.1 + have ha : algebraMap K m.ResidueField a = + algebraMap V m.ResidueField xv := by + exact rationalFinitePlaceBaseCoordinate_residue K E Q.1 + let b : K := Classical.choose + (hresidue (algebraMap V m.ResidueField yv)) + have hb : algebraMap K m.ResidueField b = + algebraMap V m.ResidueField yv := Classical.choose_spec + (hresidue (algebraMap V m.ResidueField yv)) + exact ⟨(a, b), by + apply eval_pair_eq_zero_of_residue V m f xv yv a b ha hb + rw [hxv] + change MvPolynomial.eval₂ (algebraMap K E) + ![planeCurveFunction f 0, planeCurveFunction f 1] f = 0 + have hcoordinates : planeCurveFunction f = + ![planeCurveFunction f 0, planeCurveFunction f 1] := by + funext i + fin_cases i <;> rfl + rw [← hcoordinates] + exact eval₂_planeCurveFunction_eq_zero f⟩ + +omit [Fintype K] in +/-- The first coordinate of the affine residue center is the base coordinate +of the rational finite place. -/ +theorem planeCurveGoodRationalFinitePlaceCenter_firstCoordinate + (hf : Irreducible f) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) : + letI := planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + letI := planeCurveFirstCoordinateRatFuncAlgebra f hx + letI : Algebra (Polynomial K) (PlaneCurveFunctionField f) := + RingHom.toAlgebra + ((algebraMap (RatFunc K) (PlaneCurveFunctionField f)).comp + (algebraMap (Polynomial K) (RatFunc K))) + letI : IsScalarTower (Polynomial K) (RatFunc K) + (PlaneCurveFunctionField f) := + IsScalarTower.of_algebraMap_eq' rfl + letI : FiniteDimensional (RatFunc K) (PlaneCurveFunctionField f) := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + letI : Algebra.IsSeparable (RatFunc K) (PlaneCurveFunctionField f) := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + letI : DecidableEq (RatFunc K) := Classical.decEq _ + ∀ Q : RationalFinitePlaceAwayFromPolynomialZeros K + (PlaneCurveFunctionField f) + (secondCoordinateAffineExceptionalPolynomial f), + (planeCurveGoodRationalFinitePlaceCenter hf hpartialSecond Q).1.1 = + rationalFinitePlaceBaseCoordinate K (PlaneCurveFunctionField f) Q.1 := by + classical + dsimp only + intro Q + rfl + +omit [Fintype K] in +/-- The second coordinate of the affine center represents the residue class +of the second plane coordinate in the local residue field. -/ +theorem planeCurveGoodRationalFinitePlaceCenter_secondCoordinate_residue + (hf : Irreducible f) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) : + let := planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let := planeCurveFirstCoordinateRatFuncAlgebra f hx + let : Algebra (Polynomial K) (PlaneCurveFunctionField f) := + RingHom.toAlgebra + ((algebraMap (RatFunc K) (PlaneCurveFunctionField f)).comp + (algebraMap (Polynomial K) (RatFunc K))) + let : IsScalarTower (Polynomial K) (RatFunc K) + (PlaneCurveFunctionField f) := IsScalarTower.of_algebraMap_eq' rfl + let : FiniteDimensional (RatFunc K) (PlaneCurveFunctionField f) := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : Algebra.IsSeparable (RatFunc K) (PlaneCurveFunctionField f) := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : DecidableEq (RatFunc K) := Classical.decEq _ + ∀ Q : RationalFinitePlaceAwayFromPolynomialZeros K + (PlaneCurveFunctionField f) + (secondCoordinateAffineExceptionalPolynomial f), + let E := PlaneCurveFunctionField f + let B := RatFuncFiniteIntegralClosure K E + let V := HeightOneSpectrum.valuationSubringAtPrime E Q.1.1 + letI : Algebra K[X] V := RingHom.toAlgebra + ((algebraMap B V).comp (algebraMap K[X] B)) + letI : Algebra K B := RingHom.toAlgebra + ((algebraMap K[X] B).comp (algebraMap K K[X])) + letI : Algebra K V := RingHom.toAlgebra + ((algebraMap B V).comp (algebraMap K B)) + let m := IsLocalRing.maximalIdeal V + algebraMap K m.ResidueField + (planeCurveGoodRationalFinitePlaceCenter hf hpartialSecond Q).1.2 = + algebraMap V m.ResidueField + (⟨planeCurveFunction f 1, + planeCurveSecondCoordinate_mem_valuationSubringAtPrime_of_affineExceptional_ne_zero + hf hpartialSecond Q.1 Q.2⟩ : V) := by + intro model1 hx model3 model4 model5 model6 model7 model8 + classical + let E := PlaneCurveFunctionField f + let : Field E := inferInstance + let : AddCommMonoid E := inferInstance + let : SMul (RatFunc K) E := Algebra.toSMul + let : Module (RatFunc K) E := Algebra.toModule + let : SMul K[X] E := Algebra.toSMul + let : Module K[X] E := Algebra.toModule + let B := RatFuncFiniteIntegralClosure K E + let : CommRing B := inferInstance + let : AddCommMonoid B := inferInstance + let : SMul K[X] B := Algebra.toSMul + let : Module K[X] B := Algebra.toModule + let : Module.Finite K[X] B := Module.IsNoetherian.finite K[X] B + let : Module.IsTorsionFree K[X] E := + Module.IsTorsionFree.trans_faithfulSMul K[X] (RatFunc K) E + let : Module.IsTorsionFree K[X] B := + IsIntegralClosure.isTorsionFree K[X] E + let : NoZeroSMulDivisors K[X] B := + { eq_zero_or_eq_zero_of_smul_eq_zero := fun h => smul_eq_zero.mp h } + let : IsDedekindDomain B := + IsIntegralClosure.isDedekindDomain K[X] (RatFunc K) E B + let : IsFractionRing B E := + IsIntegralClosure.isFractionRing_of_finite_extension K[X] (RatFunc K) E B + let : Algebra K B := RingHom.toAlgebra + ((algebraMap K[X] B).comp (algebraMap K K[X])) + let : SMul K B := Algebra.toSMul + let : Module K B := Algebra.toModule + let : SMul K E := Algebra.toSMul + let : Module K E := Algebra.toModule + let : IsScalarTower K K[X] B := IsScalarTower.of_algebraMap_eq' rfl + let : IsScalarTower K (RatFunc K) E := + IsScalarTower.of_algebraMap_eq' (by + ext c + have h := congrArg + (fun g : Polynomial K →+* E => g (Polynomial.C c)) + (ratFuncSpecialization_comp_polynomial_algebraMap + (planeCurveFunction f 0) hx) + simpa [E, planeCurveFirstCoordinateRatFuncAlgebra] using h.symm) + let : IsScalarTower K K[X] E := + IsScalarTower.of_algebraMap_eq' (by + ext c + rw [IsScalarTower.algebraMap_apply K (RatFunc K) E, + IsScalarTower.algebraMap_apply K K[X] (RatFunc K)] + rfl) + let : IsScalarTower K B E := IsScalarTower.of_algebraMap_eq' (by + ext c + rw [IsScalarTower.algebraMap_apply K K[X] E] + rfl) + dsimp only + intro Q + let V := HeightOneSpectrum.valuationSubringAtPrime E Q.1.1 + let : Algebra B V := inferInstance + let : SMul B V := Algebra.toSMul + let : Module B V := Algebra.toModule + let : Algebra V E := Algebra.ofSubsemiring V + let : SMul V E := Algebra.toSMul + let : Module V E := Algebra.toModule + let : Algebra K[X] V := RingHom.toAlgebra + ((algebraMap B V).comp (algebraMap K[X] B)) + let : IsScalarTower K[X] V E := IsScalarTower.of_algebraMap_eq' rfl + let : Algebra K V := RingHom.toAlgebra + ((algebraMap B V).comp (algebraMap K B)) + let : SMul K V := Algebra.toSMul + let : Module K V := Algebra.toModule + let : IsScalarTower K B V := IsScalarTower.of_algebraMap_eq' rfl + let : IsScalarTower K V E := IsScalarTower.of_algebraMap_eq' (by + ext c + rw [IsScalarTower.algebraMap_apply K B E] + rfl) + let m := IsLocalRing.maximalIdeal V + have hglobalResidue : Function.Surjective + (algebraMap K Q.1.1.asIdeal.ResidueField) := + finiteExtensionFinitePlace_constantResidue_surjective_of_degree_one + K E Q.1.1 Q.1.2 + have hresidue : Function.Surjective (algebraMap K m.ResidueField) := + localizationAtPrime_constantResidue_surjective + (C := K) (R := B) (S := V) Q.1.1 hglobalResidue + let yv : V := ⟨planeCurveFunction f 1, + planeCurveSecondCoordinate_mem_valuationSubringAtPrime_of_affineExceptional_ne_zero + hf hpartialSecond Q.1 Q.2⟩ + change algebraMap K m.ResidueField + (Classical.choose (hresidue (algebraMap V m.ResidueField yv))) = + algebraMap V m.ResidueField yv + exact Classical.choose_spec + (hresidue (algebraMap V m.ResidueField yv)) + +omit [Fintype K] in +private theorem exists_centered_coordinate_hom + {K E : Type*} [Field K] [Field E] [Algebra K E] + (f : MvPolynomial (Fin 2) K) (V : ValuationSubring E) + [Algebra K V] [IsScalarTower K V E] + (ι : PlaneCurveCoordinateRing f →ₐ[K] E) (xv yv : V) + (hι : ∀ j, ι (planeCurveCoordinate f j) = algebraMap V E (![xv, yv] j)) + (hroot : MvPolynomial.eval₂ (algebraMap K E) ![(xv : E), (yv : E)] f = 0) + (z : AffinePlaneCurvePoint f) + (hfirst : algebraMap K (IsLocalRing.maximalIdeal V).ResidueField z.1.1 = + algebraMap V (IsLocalRing.maximalIdeal V).ResidueField xv) + (hsecond : algebraMap K (IsLocalRing.maximalIdeal V).ResidueField z.1.2 = + algebraMap V (IsLocalRing.maximalIdeal V).ResidueField yv) : + ∃ φ : PlaneCurveCoordinateRing f →+* V, + (∀ r, ((φ r : V) : E) = ι r) ∧ + Ideal.comap φ (IsLocalRing.maximalIdeal V) = + (affinePlaneCurvePointMaximalIdeal f z).asIdeal := by + let A := PlaneCurveCoordinateRing f + let m := IsLocalRing.maximalIdeal V + let evalV : MvPolynomial (Fin 2) K →+* V := + MvPolynomial.eval₂Hom (algebraMap K V) ![xv, yv] + have hfV : evalV f = 0 := by + apply Subtype.ext + simp only [evalV, MvPolynomial.coe_eval₂Hom] + change algebraMap V E + (MvPolynomial.eval₂ (algebraMap K V) ![xv, yv] f) = 0 + rw [MvPolynomial.eval₂_comp_left, + ← IsScalarTower.algebraMap_eq K V E] + have hcoordinatesE : (algebraMap V E) ∘ ![xv, yv] = + ![(xv : E), (yv : E)] := by + funext i + fin_cases i <;> rfl + rw [hcoordinatesE] + exact hroot + let φ : A →+* V := Ideal.Quotient.lift (Ideal.span {f}) evalV (by + intro g hg + obtain ⟨c, rfl⟩ := Ideal.mem_span_singleton.mp hg + rw [map_mul, hfV, zero_mul]) + have hφE : ∀ r : A, ((φ r : V) : E) = ι r := by + intro r + suffices (algebraMap V E).comp φ = ι.toRingHom by + exact DFunLike.congr_fun this r + apply Ideal.Quotient.ringHom_ext + apply MvPolynomial.ringHom_ext + · intro c + simp only [RingHom.comp_apply, φ, Ideal.Quotient.lift_mk, evalV, + MvPolynomial.coe_eval₂Hom, MvPolynomial.eval₂_C] + change algebraMap V E (algebraMap K V c) = ι (algebraMap K A c) + rw [ι.commutes, IsScalarTower.algebraMap_apply K V E] + · intro i + simp only [RingHom.comp_apply, φ, Ideal.Quotient.lift_mk, evalV, + MvPolynomial.coe_eval₂Hom, MvPolynomial.eval₂_X] + change algebraMap V E (![xv, yv] i) = ι (planeCurveCoordinate f i) + exact (hι i).symm + have hrescomp : (algebraMap V m.ResidueField).comp φ = + (algebraMap K m.ResidueField).comp (planeCurvePointEval f z) := by + apply Ideal.Quotient.ringHom_ext + apply MvPolynomial.ringHom_ext + · intro c + simp only [RingHom.comp_apply, φ, Ideal.Quotient.lift_mk, evalV, + MvPolynomial.coe_eval₂Hom, MvPolynomial.eval₂_C, + planeCurvePointEval, Ideal.Quotient.lift_mk] + exact (IsScalarTower.algebraMap_apply K V m.ResidueField c).symm + · intro i + fin_cases i + · simpa [φ, evalV, planeCurvePointEval] using hfirst.symm + · simpa [φ, evalV, planeCurvePointEval] using hsecond.symm + refine ⟨φ, hφE, ?_⟩ + apply Ideal.ext + intro r + change φ r ∈ m ↔ planeCurvePointEval f z r = 0 + rw [← Ideal.algebraMap_residueField_eq_zero] + have hr := DFunLike.congr_fun hrescomp r + simp only [RingHom.comp_apply] at hr + rw [hr] + constructor + · intro h + apply (algebraMap K m.ResidueField).injective + simpa using h + · intro h + simp [h] + + +omit [Fintype K] in +/-- A good rational finite place admits a coordinate-ring map into its +valuation ring. The map is the canonical inclusion in the function field, +and the inverse image of the local maximal ideal is exactly the maximal ideal +of its affine residue center. -/ +theorem exists_planeCurveGoodRationalFinitePlace_centeredCoordinateRingHom + (hf : Irreducible f) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) : + let := planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let := planeCurveFirstCoordinateRatFuncAlgebra f hx + let : Algebra (Polynomial K) (PlaneCurveFunctionField f) := + RingHom.toAlgebra + ((algebraMap (RatFunc K) (PlaneCurveFunctionField f)).comp + (algebraMap (Polynomial K) (RatFunc K))) + let : IsScalarTower (Polynomial K) (RatFunc K) + (PlaneCurveFunctionField f) := IsScalarTower.of_algebraMap_eq' rfl + let : FiniteDimensional (RatFunc K) (PlaneCurveFunctionField f) := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : Algebra.IsSeparable (RatFunc K) (PlaneCurveFunctionField f) := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : DecidableEq (RatFunc K) := Classical.decEq _ + ∀ Q : RationalFinitePlaceAwayFromPolynomialZeros K + (PlaneCurveFunctionField f) + (secondCoordinateAffineExceptionalPolynomial f), + let A := PlaneCurveCoordinateRing f + let E := PlaneCurveFunctionField f + let V := HeightOneSpectrum.valuationSubringAtPrime E Q.1.1 + ∃ φ : A →+* V, + (∀ r : A, ((φ r : V) : E) = algebraMap A E r) ∧ + Ideal.comap φ (IsLocalRing.maximalIdeal V) = + (affinePlaneCurvePointMaximalIdeal f + (planeCurveGoodRationalFinitePlaceCenter + hf hpartialSecond Q)).asIdeal := by + intro model1 hx model3 model4 model5 model6 model7 model8 + classical + let A := PlaneCurveCoordinateRing f + let E := PlaneCurveFunctionField f + let : Field E := inferInstance + let : AddCommMonoid E := inferInstance + let : SMul (RatFunc K) E := Algebra.toSMul + let : Module (RatFunc K) E := Algebra.toModule + let : SMul K[X] E := Algebra.toSMul + let : Module K[X] E := Algebra.toModule + let B := RatFuncFiniteIntegralClosure K E + let : CommRing B := inferInstance + let : AddCommMonoid B := inferInstance + let : SMul K[X] B := Algebra.toSMul + let : Module K[X] B := Algebra.toModule + let : Module.Finite K[X] B := Module.IsNoetherian.finite K[X] B + let : Module.IsTorsionFree K[X] E := + Module.IsTorsionFree.trans_faithfulSMul K[X] (RatFunc K) E + let : Module.IsTorsionFree K[X] B := + IsIntegralClosure.isTorsionFree K[X] E + let : NoZeroSMulDivisors K[X] B := + { eq_zero_or_eq_zero_of_smul_eq_zero := fun h => smul_eq_zero.mp h } + let : IsDedekindDomain B := + IsIntegralClosure.isDedekindDomain K[X] (RatFunc K) E B + let : IsFractionRing B E := + IsIntegralClosure.isFractionRing_of_finite_extension K[X] (RatFunc K) E B + let : Algebra K B := RingHom.toAlgebra + ((algebraMap K[X] B).comp (algebraMap K K[X])) + let : SMul K B := Algebra.toSMul + let : Module K B := Algebra.toModule + let : SMul K E := Algebra.toSMul + let : Module K E := Algebra.toModule + let : IsScalarTower K K[X] B := IsScalarTower.of_algebraMap_eq' rfl + let : IsScalarTower K (RatFunc K) E := + IsScalarTower.of_algebraMap_eq' (by + ext c + have h := congrArg + (fun g : Polynomial K →+* E => g (Polynomial.C c)) + (ratFuncSpecialization_comp_polynomial_algebraMap + (planeCurveFunction f 0) hx) + simpa [E, planeCurveFirstCoordinateRatFuncAlgebra] using h.symm) + let : IsScalarTower K K[X] E := + IsScalarTower.of_algebraMap_eq' (by + ext c + rw [IsScalarTower.algebraMap_apply K (RatFunc K) E, + IsScalarTower.algebraMap_apply K K[X] (RatFunc K)] + rfl) + let : IsScalarTower K B E := IsScalarTower.of_algebraMap_eq' (by + ext c + rw [IsScalarTower.algebraMap_apply K K[X] E] + rfl) + dsimp only + intro Q + let V := HeightOneSpectrum.valuationSubringAtPrime E Q.1.1 + let : Algebra B V := inferInstance + let : SMul B V := Algebra.toSMul + let : Module B V := Algebra.toModule + let : Algebra V E := Algebra.ofSubsemiring V + let : SMul V E := Algebra.toSMul + let : Module V E := Algebra.toModule + let : Algebra K[X] V := RingHom.toAlgebra + ((algebraMap B V).comp (algebraMap K[X] B)) + let : IsScalarTower K[X] V E := IsScalarTower.of_algebraMap_eq' rfl + let : Algebra K V := RingHom.toAlgebra + ((algebraMap B V).comp (algebraMap K B)) + let : SMul K V := Algebra.toSMul + let : Module K V := Algebra.toModule + let : IsScalarTower K B V := IsScalarTower.of_algebraMap_eq' rfl + let : IsScalarTower K V E := IsScalarTower.of_algebraMap_eq' (by + ext c + rw [IsScalarTower.algebraMap_apply K B E] + rfl) + let m := IsLocalRing.maximalIdeal V + let xv : V := algebraMap K[X] V Polynomial.X + have hxv : (xv : E) = planeCurveFunction f 0 := by + rw [show (xv : E) = algebraMap K[X] E Polynomial.X by + exact IsScalarTower.algebraMap_apply K[X] V E Polynomial.X] + have h := congrArg + (fun g : Polynomial K →+* E => g Polynomial.X) + (ratFuncSpecialization_comp_polynomial_algebraMap + (planeCurveFunction f 0) hx) + change ratFuncSpecialization (planeCurveFunction f 0) hx + (algebraMap K[X] (RatFunc K) Polynomial.X) = planeCurveFunction f 0 + simpa using h + have hymem : planeCurveFunction f 1 ∈ V := + planeCurveSecondCoordinate_mem_valuationSubringAtPrime_of_affineExceptional_ne_zero + hf hpartialSecond Q.1 Q.2 + let yv : V := ⟨planeCurveFunction f 1, hymem⟩ + let z := planeCurveGoodRationalFinitePlaceCenter hf hpartialSecond Q + have hfirst : algebraMap K m.ResidueField z.1.1 = + algebraMap V m.ResidueField xv := by + rw [planeCurveGoodRationalFinitePlaceCenter_firstCoordinate + hf hpartialSecond Q] + exact rationalFinitePlaceBaseCoordinate_residue K E Q.1 + have hsecond : algebraMap K m.ResidueField z.1.2 = + algebraMap V m.ResidueField yv := by + exact planeCurveGoodRationalFinitePlaceCenter_secondCoordinate_residue + hf hpartialSecond Q + apply exists_centered_coordinate_hom f V (IsScalarTower.toAlgHom K A E) xv yv _ _ z + hfirst hsecond + · intro i + fin_cases i + · exact hxv.symm + · rfl + · rw [hxv] + change MvPolynomial.eval₂ (algebraMap K E) + ![planeCurveFunction f 0, planeCurveFunction f 1] f = 0 + have hcoordinates : planeCurveFunction f = + ![planeCurveFunction f 0, planeCurveFunction f 1] := by + funext i + fin_cases i <;> rfl + rw [← hcoordinates] + exact eval₂_planeCurveFunction_eq_zero f + + +omit [Fintype K] in +/-- Avoiding the derivative resultant forces the affine residue center to lie +in the partial-`Y` smooth locus. -/ +theorem planeCurveGoodRationalFinitePlaceCenter_partialY_ne_zero + (hf : Irreducible f) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) : + letI := planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + letI := planeCurveFirstCoordinateRatFuncAlgebra f hx + letI : Algebra (Polynomial K) (PlaneCurveFunctionField f) := + RingHom.toAlgebra + ((algebraMap (RatFunc K) (PlaneCurveFunctionField f)).comp + (algebraMap (Polynomial K) (RatFunc K))) + letI : IsScalarTower (Polynomial K) (RatFunc K) + (PlaneCurveFunctionField f) := + IsScalarTower.of_algebraMap_eq' rfl + letI : FiniteDimensional (RatFunc K) (PlaneCurveFunctionField f) := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + letI : Algebra.IsSeparable (RatFunc K) (PlaneCurveFunctionField f) := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + letI : DecidableEq (RatFunc K) := Classical.decEq _ + ∀ Q : RationalFinitePlaceAwayFromPolynomialZeros K + (PlaneCurveFunctionField f) + (secondCoordinateAffineExceptionalPolynomial f), + MvPolynomial.eval + ![(planeCurveGoodRationalFinitePlaceCenter hf hpartialSecond Q).1.1, + (planeCurveGoodRationalFinitePlaceCenter hf hpartialSecond Q).1.2] + (MvPolynomial.pderiv 1 f) ≠ 0 := by + classical + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let : Algebra (RatFunc K) (PlaneCurveFunctionField f) := + planeCurveFirstCoordinateRatFuncAlgebra f hx + let : Algebra (Polynomial K) (PlaneCurveFunctionField f) := + RingHom.toAlgebra + ((algebraMap (RatFunc K) (PlaneCurveFunctionField f)).comp + (algebraMap (Polynomial K) (RatFunc K))) + let : IsScalarTower (Polynomial K) (RatFunc K) + (PlaneCurveFunctionField f) := + IsScalarTower.of_algebraMap_eq' rfl + let : FiniteDimensional (RatFunc K) (PlaneCurveFunctionField f) := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : Algebra.IsSeparable (RatFunc K) (PlaneCurveFunctionField f) := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : DecidableEq (RatFunc K) := Classical.decEq _ + dsimp only + intro Q hzero + let z := planeCurveGoodRationalFinitePlaceCenter hf hpartialSecond Q + have hresultant : (secondCoordinateCriticalResultant f).eval z.1.1 = 0 := + secondCoordinateCriticalResultant_eval_eq_zero_of_common_zero + hpartialSecond z.1.1 z.1.2 z.2 (by simpa [z] using hzero) + have hgood := Q.2 + change ((planeCurvePolynomialInSecondCoordinate f).leadingCoeff * + secondCoordinateCriticalResultant f).eval + (rationalFinitePlaceBaseCoordinate K (PlaneCurveFunctionField f) Q.1) ≠ 0 + at hgood + rw [Polynomial.eval_mul] at hgood + have hresultantBase : (secondCoordinateCriticalResultant f).eval + (rationalFinitePlaceBaseCoordinate K (PlaneCurveFunctionField f) Q.1) ≠ 0 := + (mul_ne_zero_iff.mp hgood).2 + apply hresultantBase + rw [← planeCurveGoodRationalFinitePlaceCenter_firstCoordinate + hf hpartialSecond Q] + exact hresultant + +omit [Fintype K] in +private theorem valuationSubring_eq_dominating_of_centered_hom + {A E : Type*} [CommRing A] [IsDomain A] [Field E] + [Algebra A E] [IsFractionRing A E] (m : MaximalSpectrum A) + [IsDiscreteValuationRing (Localization.AtPrime m.asIdeal)] + (V : ValuationSubring E) (φ : A →+* V) + (hφE : ∀ r, ((φ r : V) : E) = algebraMap A E r) + (hcenter : Ideal.comap φ (IsLocalRing.maximalIdeal V) = m.asIdeal) + (hV : V ≠ ⊤) (r0 : A) (hr0mem : r0 ∈ m.asIdeal) + (hr0map : algebraMap A E r0 ≠ 0) : + V = dominatingValuationSubring (A := A) (L := E) m := by + let D := dominatingValuationSubring (A := A) (L := E) m + let Wsub : Subalgebra A E := + Localization.subalgebra.ofField E m.asIdeal.primeCompl + m.asIdeal.primeCompl_le_nonZeroDivisors + let : IsDiscreteValuationRing Wsub := + IsDiscreteValuationRing.RingEquivClass.isDiscreteValuationRing + (IsLocalization.algEquiv m.asIdeal.primeCompl + (Localization.AtPrime m.asIdeal) Wsub).toRingEquiv + let W : ValuationSubring E := + ValuationSubring.ofSubring Wsub.toSubring fun x => by + simpa [IsLocalization.IsInteger] using + ValuationRing.isInteger_or_isInteger Wsub x + let : Algebra A W := Wsub.algebra' + let : IsLocalization m.asIdeal.primeCompl W := + Localization.subalgebra.isLocalization_ofField E + m.asIdeal.primeCompl m.asIdeal.primeCompl_le_nonZeroDivisors + let eW : Wsub ≃+* W := + { toFun := fun x => ⟨x.1, x.2⟩ + invFun := fun x => ⟨x.1, x.2⟩ + left_inv := fun x => Subtype.ext rfl + right_inv := fun x => Subtype.ext rfl + map_add' := fun _ _ => rfl + map_mul' := fun _ _ => rfl } + let : IsDiscreteValuationRing W := + IsDiscreteValuationRing.RingEquivClass.isDiscreteValuationRing eW + have hWV : W ≤ V := by + intro x hx + change x ∈ Wsub at hx + rcases hx with ⟨a, s, hs, rfl⟩ + have haV : algebraMap A E a ∈ V := by + rw [← hφE a] + exact (φ a).property + have hsV : algebraMap A E s ∈ V := by + rw [← hφE s] + exact (φ s).property + let sv : V := φ s + have hsvNot : sv ∉ IsLocalRing.maximalIdeal V := by + intro hsv + apply hs + rw [← hcenter] + exact hsv + have hsvUnit : IsUnit sv := by + by_contra hunit + apply hsvNot + rw [IsLocalRing.mem_maximalIdeal, mem_nonunits_iff] + exact hunit + have hinvV : (algebraMap A E s)⁻¹ ∈ V := by + have h := Submonoid.inv_mem_of_isUnit (S := V) hsvUnit + rwa [hφE s] at h + exact V.toSubring.mul_mem haV hinvV + have hWVeq : W = V := + ValuationSubring.eq_of_le_of_ne_top W hWV hV + have hWD : W ≤ D := by + intro x hx + change x ∈ Wsub at hx + rcases hx with ⟨a, s, hs, rfl⟩ + have haD : algebraMap A E a ∈ D := + range_le_dominatingValuationSubring m ⟨a, rfl⟩ + have hsD : algebraMap A E s ∈ D := + range_le_dominatingValuationSubring m ⟨s, rfl⟩ + let sd : D := ⟨algebraMap A E s, hsD⟩ + have hsdNot : sd ∉ IsLocalRing.maximalIdeal D := by + intro hsd + apply hs + rw [pointIdeal_eq_comap_dominatingValuationSubring_maximalIdeal + (A := A) (L := E)] + exact hsd + have hsdUnit : IsUnit sd := by + by_contra hunit + apply hsdNot + rw [IsLocalRing.mem_maximalIdeal, mem_nonunits_iff] + exact hunit + have hinvD : (algebraMap A E s)⁻¹ ∈ D := + Submonoid.inv_mem_of_isUnit (S := D) hsdUnit + exact D.toSubring.mul_mem haD hinvD + have hrNonunits : algebraMap A E r0 ∈ D.nonunits := + algebraMap_mem_dominatingValuationSubring_nonunits_of_mem + (A := A) (L := E) m r0 hr0mem + have hD : D ≠ ⊤ := by + intro htop + have hnontrivial : D.valuation.IsNontrivial := + (Valuation.isNontrivial_iff_exists_lt_one D.valuation).2 + ⟨algebraMap A E r0, hr0map, hrNonunits⟩ + exact ((ValuationSubring.eq_top_iff D).mp htop) hnontrivial + have hWDeq : W = D := + ValuationSubring.eq_of_le_of_ne_top W hWD hD + exact hWVeq.symm.trans hWDeq + +/-- At a good rational finite place, the normalization valuation ring is +the unique valuation ring dominating its smooth affine residue center. -/ +theorem planeCurveGoodRationalFinitePlace_valuationSubring_eq_dominating + (hf : Irreducible f) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) : + let := planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let := planeCurveFirstCoordinateRatFuncAlgebra f hx + let : Algebra (Polynomial K) (PlaneCurveFunctionField f) := + RingHom.toAlgebra + ((algebraMap (RatFunc K) (PlaneCurveFunctionField f)).comp + (algebraMap (Polynomial K) (RatFunc K))) + let : IsScalarTower (Polynomial K) (RatFunc K) + (PlaneCurveFunctionField f) := IsScalarTower.of_algebraMap_eq' rfl + let : FiniteDimensional (RatFunc K) (PlaneCurveFunctionField f) := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : Algebra.IsSeparable (RatFunc K) (PlaneCurveFunctionField f) := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : DecidableEq (RatFunc K) := Classical.decEq _ + ∀ Q : RationalFinitePlaceAwayFromPolynomialZeros K + (PlaneCurveFunctionField f) + (secondCoordinateAffineExceptionalPolynomial f), + HeightOneSpectrum.valuationSubringAtPrime + (PlaneCurveFunctionField f) Q.1.1 = + dominatingValuationSubring + (affinePlaneCurvePointMaximalIdeal f + (planeCurveGoodRationalFinitePlaceCenter hf hpartialSecond Q)) := by + intro model1 hx model3 model4 model5 model6 model7 model8 + classical + let A := PlaneCurveCoordinateRing f + let E := PlaneCurveFunctionField f + let : Field E := inferInstance + let : AddCommMonoid E := inferInstance + let : SMul (RatFunc K) E := Algebra.toSMul + let : Module (RatFunc K) E := Algebra.toModule + let : SMul K[X] E := Algebra.toSMul + let : Module K[X] E := Algebra.toModule + let B := RatFuncFiniteIntegralClosure K E + let : CommRing B := inferInstance + let : AddCommMonoid B := inferInstance + let : SMul K[X] B := Algebra.toSMul + let : Module K[X] B := Algebra.toModule + let : Module.Finite K[X] B := Module.IsNoetherian.finite K[X] B + let : Module.IsTorsionFree K[X] E := + Module.IsTorsionFree.trans_faithfulSMul K[X] (RatFunc K) E + let : Module.IsTorsionFree K[X] B := + IsIntegralClosure.isTorsionFree K[X] E + let : NoZeroSMulDivisors K[X] B := + { eq_zero_or_eq_zero_of_smul_eq_zero := fun h => smul_eq_zero.mp h } + let : IsDedekindDomain B := + IsIntegralClosure.isDedekindDomain K[X] (RatFunc K) E B + let : IsFractionRing B E := + IsIntegralClosure.isFractionRing_of_finite_extension K[X] (RatFunc K) E B + intro Q + let z := planeCurveGoodRationalFinitePlaceCenter hf hpartialSecond Q + let m := affinePlaneCurvePointMaximalIdeal f z + let V := HeightOneSpectrum.valuationSubringAtPrime E Q.1.1 + let : Algebra B V := inferInstance + let : SMul B V := Algebra.toSMul + let : Module B V := Algebra.toModule + let : Algebra V E := Algebra.ofSubsemiring V + let : SMul V E := Algebra.toSMul + let : Module V E := Algebra.toModule + let D := dominatingValuationSubring (A := A) (L := E) m + obtain ⟨φ, hφE, hcenter⟩ := + exists_planeCurveGoodRationalFinitePlace_centeredCoordinateRingHom + hf hpartialSecond Q + let eCenter := affinePlaneCurvePoint_residueAlgEquiv K z + let : Finite m.asIdeal.ResidueField := + Finite.of_injective eCenter eCenter.injective + let r0 : A := planeCurveCoordinate f 0 - algebraMap K A z.1.1 + have hr0mem : r0 ∈ m.asIdeal := + firstCoordinate_sub_mem_affinePlaneCurvePointMaximalIdeal z + have hr0mapEq : algebraMap A E r0 = + planeCurveFunction f 0 - algebraMap K E z.1.1 := by + simp only [r0, map_sub] + rfl + have hr0map : algebraMap A E r0 ≠ 0 := by + rw [hr0mapEq] + exact firstCoordinate_sub_affinePoint_ne_zero hf hpartialSecond z + have hr0 : r0 ≠ 0 := by + intro hzero + apply hr0map + rw [hzero, map_zero] + have hm0 : m.asIdeal ≠ ⊥ := by + intro hm + apply hr0 + simpa [hm] using hr0mem + have hsmooth : planeCurvePartialY f ∉ m.asIdeal := by + change planeCurvePointEval f z (planeCurvePartialY f) ≠ 0 + change MvPolynomial.eval ![z.1.1, z.1.2] + (MvPolynomial.pderiv 1 f) ≠ 0 + exact planeCurveGoodRationalFinitePlaceCenter_partialY_ne_zero + hf hpartialSecond Q + let : IsDiscreteValuationRing (Localization.AtPrime m.asIdeal) := + planeCurveClosedPoint_localization_isDiscreteValuationRing + K hf m hm0 hsmooth + have hV : V ≠ ⊤ := by + change HeightOneSpectrum.valuationSubringAtPrime E Q.1.1 ≠ ⊤ + rw [HeightOneSpectrum.valuationSubringAtPrime_eq_valuationSubring] + simp only [ne_eq, Valuation.valuationSubring_eq_top_iff, not_not] + infer_instance + exact valuationSubring_eq_dominating_of_centered_hom m V φ hφE hcenter hV + r0 hr0mem hr0map + +/-- The residue-center map is injective on the good rational finite +places: smoothness makes the local DVR, hence the dominating valuation ring, +unique. -/ +theorem planeCurveGoodRationalFinitePlaceCenter_injective + (hf : Irreducible f) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) : + letI := planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + letI := planeCurveFirstCoordinateRatFuncAlgebra f hx + letI : Algebra (Polynomial K) (PlaneCurveFunctionField f) := + RingHom.toAlgebra + ((algebraMap (RatFunc K) (PlaneCurveFunctionField f)).comp + (algebraMap (Polynomial K) (RatFunc K))) + letI : IsScalarTower (Polynomial K) (RatFunc K) + (PlaneCurveFunctionField f) := IsScalarTower.of_algebraMap_eq' rfl + letI : FiniteDimensional (RatFunc K) (PlaneCurveFunctionField f) := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + letI : Algebra.IsSeparable (RatFunc K) (PlaneCurveFunctionField f) := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + letI : DecidableEq (RatFunc K) := Classical.decEq _ + Function.Injective + (planeCurveGoodRationalFinitePlaceCenter hf hpartialSecond) := by + classical + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let E := PlaneCurveFunctionField f + let : Algebra (RatFunc K) E := + planeCurveFirstCoordinateRatFuncAlgebra f hx + let : Algebra K[X] E := RingHom.toAlgebra + ((algebraMap (RatFunc K) E).comp (algebraMap K[X] (RatFunc K))) + let : IsScalarTower K[X] (RatFunc K) E := + IsScalarTower.of_algebraMap_eq' rfl + let : FiniteDimensional (RatFunc K) E := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : Algebra.IsSeparable (RatFunc K) E := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : DecidableEq (RatFunc K) := Classical.decEq _ + dsimp only + intro Q R hcenter + apply Subtype.ext + apply Subtype.ext + apply HeightOneSpectrum.eq_of_valuation_isEquiv_valuation (K := E) + rw [Valuation.isEquiv_iff_valuationSubring, + ← HeightOneSpectrum.valuationSubringAtPrime_eq_valuationSubring, + ← HeightOneSpectrum.valuationSubringAtPrime_eq_valuationSubring] + calc + HeightOneSpectrum.valuationSubringAtPrime E Q.1.1 = + dominatingValuationSubring + (affinePlaneCurvePointMaximalIdeal f + (planeCurveGoodRationalFinitePlaceCenter hf hpartialSecond Q)) := + planeCurveGoodRationalFinitePlace_valuationSubring_eq_dominating + hf hpartialSecond Q + _ = dominatingValuationSubring + (affinePlaneCurvePointMaximalIdeal f + (planeCurveGoodRationalFinitePlaceCenter hf hpartialSecond R)) := by + rw [hcenter] + _ = HeightOneSpectrum.valuationSubringAtPrime E R.1.1 := + (planeCurveGoodRationalFinitePlace_valuationSubring_eq_dominating + hf hpartialSecond R).symm + +/-- Plane-curve specialization of the bad-fiber estimate. Rational finite +places over a base fiber where either the second-coordinate leading +coefficient vanishes or the second-coordinate derivative has a common root +are controlled only by the bidegree. -/ +theorem planeCurveExceptionalRationalFinitePlace_card_le + {firstDegree secondDegree : ℕ} + (hdegree : BGS.External.HasBidegreeAtMost f firstDegree secondDegree) + (hf : Irreducible f) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) : + letI := planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + letI := planeCurveFirstCoordinateRatFuncAlgebra f hx + letI : Algebra (Polynomial K) (PlaneCurveFunctionField f) := + RingHom.toAlgebra + ((algebraMap (RatFunc K) (PlaneCurveFunctionField f)).comp + (algebraMap (Polynomial K) (RatFunc K))) + letI : IsScalarTower (Polynomial K) (RatFunc K) + (PlaneCurveFunctionField f) := + IsScalarTower.of_algebraMap_eq' rfl + letI : FiniteDimensional (RatFunc K) (PlaneCurveFunctionField f) := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + letI : Algebra.IsSeparable (RatFunc K) (PlaneCurveFunctionField f) := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + letI : DecidableEq (RatFunc K) := Classical.decEq _ + Nat.card (RationalFinitePlaceOverPolynomialZeros K + (PlaneCurveFunctionField f) + (secondCoordinateAffineExceptionalPolynomial f)) ≤ + (firstDegree + (2 * secondDegree - 1) * firstDegree) * + secondDegree := by + classical + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let : Algebra (RatFunc K) (PlaneCurveFunctionField f) := + planeCurveFirstCoordinateRatFuncAlgebra f hx + let : Algebra (Polynomial K) (PlaneCurveFunctionField f) := + RingHom.toAlgebra + ((algebraMap (RatFunc K) (PlaneCurveFunctionField f)).comp + (algebraMap (Polynomial K) (RatFunc K))) + let : IsScalarTower (Polynomial K) (RatFunc K) + (PlaneCurveFunctionField f) := + IsScalarTower.of_algebraMap_eq' rfl + let : FiniteDimensional (RatFunc K) (PlaneCurveFunctionField f) := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : Algebra.IsSeparable (RatFunc K) (PlaneCurveFunctionField f) := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : DecidableEq (RatFunc K) := Classical.decEq _ + dsimp only + calc + Nat.card (RationalFinitePlaceOverPolynomialZeros K + (PlaneCurveFunctionField f) + (secondCoordinateAffineExceptionalPolynomial f)) ≤ + Fintype.card {a : K // + (secondCoordinateAffineExceptionalPolynomial f).eval a = 0} * + Module.finrank (RatFunc K) (PlaneCurveFunctionField f) := + rationalFinitePlaceOverPolynomialZeros_card_le K + (PlaneCurveFunctionField f) + (secondCoordinateAffineExceptionalPolynomial f) + _ ≤ (firstDegree + (2 * secondDegree - 1) * firstDegree) * + secondDegree := by + apply Nat.mul_le_mul + · exact secondCoordinateAffineExceptionalBase_card_le + hdegree hf hpartialSecond + · rw [finrank_planeCurveFunctionField_over_ratFunc_eq_degreeOf_second + hf hpartialSecond] + exact degreeOf_second_le_of_hasBidegreeAtMost hdegree + +/-- Conditional reverse affine-normalization comparison. Once the geometric +center construction is supplied as an injection from rational finite places +away from the leading-coefficient/discriminant locus, the total rational +place count is bounded by affine points, the exceptional finite fibers, and +the places at infinity. -/ +theorem finiteExtensionRationalPlaceCount_le_affine_add_exceptional_of_away_injective + {firstDegree secondDegree : ℕ} + (hdegree : BGS.External.HasBidegreeAtMost f firstDegree secondDegree) + (hf : Irreducible f) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) : + letI := planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + letI := planeCurveFirstCoordinateRatFuncAlgebra f hx + letI : Algebra (Polynomial K) (PlaneCurveFunctionField f) := + RingHom.toAlgebra + ((algebraMap (RatFunc K) (PlaneCurveFunctionField f)).comp + (algebraMap (Polynomial K) (RatFunc K))) + letI : IsScalarTower (Polynomial K) (RatFunc K) + (PlaneCurveFunctionField f) := + IsScalarTower.of_algebraMap_eq' rfl + letI : FiniteDimensional (RatFunc K) (PlaneCurveFunctionField f) := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + letI : Algebra.IsSeparable (RatFunc K) (PlaneCurveFunctionField f) := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + letI : DecidableEq (RatFunc K) := Classical.decEq _ + ∀ (center : RationalFinitePlaceAwayFromPolynomialZeros K + (PlaneCurveFunctionField f) + (secondCoordinateAffineExceptionalPolynomial f) → + AffinePlaneCurvePoint f), + Function.Injective center → + finiteExtensionRationalPlaceCount K (PlaneCurveFunctionField f) ≤ + Fintype.card (AffinePlaneCurvePoint f) + + (firstDegree + (2 * secondDegree - 1) * firstDegree) * + secondDegree + secondDegree := by + classical + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let : Algebra (RatFunc K) (PlaneCurveFunctionField f) := + planeCurveFirstCoordinateRatFuncAlgebra f hx + let : Algebra (Polynomial K) (PlaneCurveFunctionField f) := + RingHom.toAlgebra + ((algebraMap (RatFunc K) (PlaneCurveFunctionField f)).comp + (algebraMap (Polynomial K) (RatFunc K))) + let : IsScalarTower (Polynomial K) (RatFunc K) + (PlaneCurveFunctionField f) := + IsScalarTower.of_algebraMap_eq' rfl + let : FiniteDimensional (RatFunc K) (PlaneCurveFunctionField f) := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : Algebra.IsSeparable (RatFunc K) (PlaneCurveFunctionField f) := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : DecidableEq (RatFunc K) := Classical.decEq _ + dsimp only + intro center hcenter + have hgeneric := + finiteExtensionRationalPlaceCount_le_natCard_add_polynomialZeros_of_away_injective + (K := K) (L := PlaneCurveFunctionField f) + (secondCoordinateAffineExceptionalPolynomial f) + (AffinePlaneCurvePoint f) center hcenter + have hroots := secondCoordinateAffineExceptionalBase_card_le + hdegree hf hpartialSecond + have hrank : Module.finrank (RatFunc K) (PlaneCurveFunctionField f) ≤ + secondDegree := by + rw [finrank_planeCurveFunctionField_over_ratFunc_eq_degreeOf_second + hf hpartialSecond] + exact degreeOf_second_le_of_hasBidegreeAtMost hdegree + rw [Nat.card_eq_fintype_card] at hgeneric + nlinarith + +/-- Unconditional reverse affine-normalization comparison. Good rational +finite places inject into affine rational points, exceptional finite fibers +are controlled by the leading-coefficient/resultant polynomial, and infinity +contributes at most the second-coordinate degree. -/ +theorem finiteExtensionRationalPlaceCount_le_affine_add_exceptional + {firstDegree secondDegree : ℕ} + (hdegree : BGS.External.HasBidegreeAtMost f firstDegree secondDegree) + (hf : Irreducible f) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) : + letI := planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + letI := planeCurveFirstCoordinateRatFuncAlgebra f hx + letI : Algebra (Polynomial K) (PlaneCurveFunctionField f) := + RingHom.toAlgebra + ((algebraMap (RatFunc K) (PlaneCurveFunctionField f)).comp + (algebraMap (Polynomial K) (RatFunc K))) + letI : IsScalarTower (Polynomial K) (RatFunc K) + (PlaneCurveFunctionField f) := IsScalarTower.of_algebraMap_eq' rfl + letI : FiniteDimensional (RatFunc K) (PlaneCurveFunctionField f) := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + letI : Algebra.IsSeparable (RatFunc K) (PlaneCurveFunctionField f) := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + letI : DecidableEq (RatFunc K) := Classical.decEq _ + finiteExtensionRationalPlaceCount K (PlaneCurveFunctionField f) ≤ + Fintype.card (AffinePlaneCurvePoint f) + + (firstDegree + (2 * secondDegree - 1) * firstDegree) * + secondDegree + secondDegree := by + classical + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let : Algebra (RatFunc K) (PlaneCurveFunctionField f) := + planeCurveFirstCoordinateRatFuncAlgebra f hx + let : Algebra (Polynomial K) (PlaneCurveFunctionField f) := + RingHom.toAlgebra + ((algebraMap (RatFunc K) (PlaneCurveFunctionField f)).comp + (algebraMap (Polynomial K) (RatFunc K))) + let : IsScalarTower (Polynomial K) (RatFunc K) + (PlaneCurveFunctionField f) := IsScalarTower.of_algebraMap_eq' rfl + let : FiniteDimensional (RatFunc K) (PlaneCurveFunctionField f) := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : Algebra.IsSeparable (RatFunc K) (PlaneCurveFunctionField f) := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : DecidableEq (RatFunc K) := Classical.decEq _ + dsimp only + exact finiteExtensionRationalPlaceCount_le_affine_add_exceptional_of_away_injective + hdegree hf hpartialSecond + (planeCurveGoodRationalFinitePlaceCenter hf hpartialSecond) + (planeCurveGoodRationalFinitePlaceCenter_injective hf hpartialSecond) + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/PlaneRegularPointCount.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/PlaneRegularPointCount.lean new file mode 100644 index 0000000000..2fdde5e4f1 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/PlaneRegularPointCount.lean @@ -0,0 +1,118 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.AffinePointPlace +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneSingularPointBound +public import Mathlib.Tactic + +/-! +# Regular affine points in the second-coordinate direction + +The Stepanov argument is applied only at affine points where the second +partial derivative is nonzero. At those points the affine local ring agrees +with the normalization local ring, so the selected normalization place has +residue degree one. The complementary critical points are kept explicit and +are bounded by `affineSecondCoordinateCriticalPoints_card_le`. + +This file contains only the finite-set bookkeeping. The local normalization +statement and the Stepanov zero count are proved in separate modules. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +open BGS.CorvajaZannier + +noncomputable section + +variable {K : Type*} [Field K] [Fintype K] [DecidableEq K] + +/-- Affine points where differentiation in the second coordinate is regular. -/ +abbrev AffineSecondCoordinateRegularPoint + (f : MvPolynomial (Fin 2) K) := + {z : AffinePlaneCurvePoint f // + MvPolynomial.eval ![z.1.1, z.1.2] (MvPolynomial.pderiv 1 f) ≠ 0} + +/-- The complement of the regular-point subtype is the finite critical locus. -/ +def affineSecondCoordinateNonregularEquivCritical + (f : MvPolynomial (Fin 2) K) : + {z : AffinePlaneCurvePoint f // + ¬ MvPolynomial.eval ![z.1.1, z.1.2] + (MvPolynomial.pderiv 1 f) ≠ 0} ≃ + {z : K × K // z ∈ affineSecondCoordinateCriticalPoints K f} where + toFun z := ⟨z.1.1, by + rw [mem_affineSecondCoordinateCriticalPoints_iff] + exact ⟨z.1.2, not_ne_iff.mp z.2⟩⟩ + invFun z := ⟨⟨z.1, (mem_affineSecondCoordinateCriticalPoints_iff.mp z.2).1⟩, + not_ne_iff.mpr + (mem_affineSecondCoordinateCriticalPoints_iff.mp z.2).2⟩ + left_inv z := by + apply Subtype.ext + apply Subtype.ext + rfl + right_inv z := by + apply Subtype.ext + rfl + +/-- Every affine point is either regular in the second-coordinate direction +or belongs to the explicitly defined critical locus. -/ +theorem affinePlaneCurvePoint_card_eq_regular_add_critical + (f : MvPolynomial (Fin 2) K) : + Fintype.card (AffinePlaneCurvePoint f) = + Fintype.card (AffineSecondCoordinateRegularPoint f) + + (affineSecondCoordinateCriticalPoints K f).card := by + classical + let regular : AffinePlaneCurvePoint f → Prop := fun z => + MvPolynomial.eval ![z.1.1, z.1.2] + (MvPolynomial.pderiv 1 f) ≠ 0 + have hcompl : + Fintype.card {z : AffinePlaneCurvePoint f // ¬ regular z} = + (affineSecondCoordinateCriticalPoints K f).card := by + calc + Fintype.card {z : AffinePlaneCurvePoint f // ¬ regular z} = + Fintype.card + {z : K × K // z ∈ affineSecondCoordinateCriticalPoints K f} := + Fintype.card_congr + (affineSecondCoordinateNonregularEquivCritical f) + _ = (affineSecondCoordinateCriticalPoints K f).card := by + exact Fintype.card_coe _ + have hregularLe : + Fintype.card {z : AffinePlaneCurvePoint f // regular z} ≤ + Fintype.card (AffinePlaneCurvePoint f) := + Fintype.card_subtype_le regular + have hpartition := Fintype.card_subtype_compl regular + change Fintype.card (AffinePlaneCurvePoint f) = + Fintype.card {z : AffinePlaneCurvePoint f // regular z} + + (affineSecondCoordinateCriticalPoints K f).card + rw [← hcompl, hpartition] + omega + +/-- Removing one chosen regular point lowers the regular-point cardinality by +exactly one. This is the form needed when that point supplies the unique +allowed pole of the Stepanov auxiliary. -/ +theorem regularPoint_card_eq_punctured_add_one + {f : MvPolynomial (Fin 2) K} + (z₀ : AffineSecondCoordinateRegularPoint f) : + Fintype.card (AffineSecondCoordinateRegularPoint f) = + Fintype.card {z : AffineSecondCoordinateRegularPoint f // z ≠ z₀} + 1 := by + classical + have h := Fintype.card_subtype_compl + (fun z : AffineSecondCoordinateRegularPoint f => z = z₀) + have hpositive : 0 < Fintype.card (AffineSecondCoordinateRegularPoint f) := + Fintype.card_pos_iff.mpr ⟨z₀⟩ + have hpunctured : + Fintype.card {z : AffineSecondCoordinateRegularPoint f // z ≠ z₀} = + Fintype.card (AffineSecondCoordinateRegularPoint f) - 1 := by + simpa only [Fintype.card_subtype_eq] using h + rw [hpunctured] + omega + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/PlaneSingularPointBound.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/PlaneSingularPointBound.lean new file mode 100644 index 0000000000..54d1837c09 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/PlaneSingularPointBound.lean @@ -0,0 +1,326 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveFiniteDifferentBound +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.TorsionBidegreeCount +public import Mathlib.Tactic + +/-! +# A coarse affine singular-point bound for plane curves + +For a bivariate polynomial `f`, write it as a polynomial `F` in the second +coordinate with coefficients in the first-coordinate polynomial ring. We +eliminate the second coordinate from `F` and `F.derivative` by their ordinary +resultant, with the two degree parameters fixed before specialization. + +Fixing those parameters is essential: specializing the first coordinate can +lower the degree, so neither a default resultant whose parameters are chosen +after specialization nor a specialized discriminant is the correct object. +The fixed resultant nevertheless vanishes at the first coordinate of every +common zero of `f` and its second partial derivative. Irreducibility and a +nonzero second partial derivative make the resultant nonzero, and elementary +root and fiber counts then bound all affine singular points by +`((2 * secondDegree - 1) * firstDegree) * secondDegree`. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +noncomputable section + +open Polynomial + +variable {K : Type*} [Field K] + +theorem planeCurvePolynomialInSecondCoordinate_derivative + (f : MvPolynomial (Fin 2) K) : + (BGS.CorvajaZannier.planeCurvePolynomialInSecondCoordinate f).derivative = + BGS.CorvajaZannier.planeCurvePolynomialInSecondCoordinate + (MvPolynomial.pderiv 1 f) := by + rw [BGS.CorvajaZannier.planeCurvePolynomialInSecondCoordinate_eq_bivariateEquiv, + BGS.CorvajaZannier.planeCurvePolynomialInSecondCoordinate_eq_bivariateEquiv] + apply (Polynomial.Bivariate.equivMvPolynomial K).injective + simpa using + (Polynomial.Bivariate.pderiv_one_equivMvPolynomial + ((Polynomial.Bivariate.equivMvPolynomial K).symm f)).symm + +/-- The first-coordinate eliminant of the equation and its derivative in the +second coordinate. -/ +noncomputable def secondCoordinateCriticalResultant + (f : MvPolynomial (Fin 2) K) : Polynomial K := + let F := BGS.CorvajaZannier.planeCurvePolynomialInSecondCoordinate f + Polynomial.resultant F F.derivative F.natDegree F.derivative.natDegree + +theorem secondCoordinateCriticalResultant_natDegree_le + {f : MvPolynomial (Fin 2) K} {firstDegree secondDegree : ℕ} + (hdegree : BGS.External.HasBidegreeAtMost f firstDegree secondDegree) : + (secondCoordinateCriticalResultant f).natDegree ≤ + (2 * secondDegree - 1) * firstDegree := by + let F : Polynomial (Polynomial K) := + BGS.CorvajaZannier.planeCurvePolynomialInSecondCoordinate f + have hFDegree : F.natDegree ≤ secondDegree := by + simpa [F] using + (BGS.CorvajaZannier.degreeOf_second_le_of_hasBidegreeAtMost hdegree) + have hderivDegree : F.derivative.natDegree ≤ secondDegree - 1 := + (Polynomial.natDegree_derivative_le F).trans + (Nat.sub_le_sub_right hFDegree 1) + have hFcoeff : ∀ i, (F.coeff i).natDegree ≤ firstDegree := by + intro i + simpa [F] using + BGS.CorvajaZannier.planeCurvePolynomialInSecondCoordinate_coeff_natDegree_le + hdegree i + have hderivCoeff : ∀ i, (F.derivative.coeff i).natDegree ≤ firstDegree := by + intro i + rw [Polynomial.coeff_derivative] + calc + (F.coeff (i + 1) * (i + 1)).natDegree ≤ + (F.coeff (i + 1)).natDegree + + ((i + 1 : Polynomial K)).natDegree := + Polynomial.natDegree_mul_le + _ ≤ firstDegree + 0 := + Nat.add_le_add (hFcoeff (i + 1)) (by + simp) + _ = firstDegree := Nat.add_zero _ + have hresultant := + BGS.CorvajaZannier.natDegree_resultant_le_of_degree_le + F F.derivative secondDegree (secondDegree - 1) + firstDegree firstDegree hFDegree hderivDegree hFcoeff hderivCoeff + change (Polynomial.resultant F F.derivative).natDegree ≤ _ + calc + (Polynomial.resultant F F.derivative).natDegree ≤ + secondDegree * firstDegree + + (secondDegree - 1) * firstDegree := hresultant + _ = (2 * secondDegree - 1) * firstDegree := by + rw [← Nat.add_mul] + congr 1 + omega + +theorem secondCoordinateCriticalResultant_eval_eq_zero_of_common_zero + {f : MvPolynomial (Fin 2) K} + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) (x y : K) + (hfxy : MvPolynomial.eval ![x, y] f = 0) + (hderivxy : MvPolynomial.eval ![x, y] + (MvPolynomial.pderiv 1 f) = 0) : + (secondCoordinateCriticalResultant f).eval x = 0 := by + let F : Polynomial (Polynomial K) := + BGS.CorvajaZannier.planeCurvePolynomialInSecondCoordinate f + let ev : Polynomial K →+* K := Polynomial.evalRingHom x + have hFxy : (F.map ev).eval y = 0 := by + change (BGS.CorvajaZannier.secondCoordinateSpecialization f x).eval y = 0 + simpa using hfxy + have hderivFxy : (F.derivative.map ev).eval y = 0 := by + rw [show F.derivative = + BGS.CorvajaZannier.planeCurvePolynomialInSecondCoordinate + (MvPolynomial.pderiv 1 f) by + simpa [F] using planeCurvePolynomialInSecondCoordinate_derivative f] + change (BGS.CorvajaZannier.secondCoordinateSpecialization + (MvPolynomial.pderiv 1 f) x).eval y = 0 + simpa using hderivxy + have hFdegree : 0 < F.natDegree := by + simpa [F] using + BGS.CorvajaZannier.degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond + have hspecialized : + Polynomial.resultant (F.map ev) (F.derivative.map ev) + F.natDegree F.derivative.natDegree = 0 := by + exact BGS.CorvajaZannier.resultant_eq_zero_of_common_root + (F.map ev) (F.derivative.map ev) F.natDegree F.derivative.natDegree + Polynomial.natDegree_map_le Polynomial.natDegree_map_le + (Or.inl hFdegree.ne') y hFxy hderivFxy + rw [Polynomial.resultant_map_map] at hspecialized + simpa [secondCoordinateCriticalResultant, F, ev] using hspecialized + +theorem secondCoordinateCriticalResultant_ne_zero + {f : MvPolynomial (Fin 2) K} (hf : Irreducible f) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) : + secondCoordinateCriticalResultant f ≠ 0 := by + let F : Polynomial (Polynomial K) := + BGS.CorvajaZannier.planeCurvePolynomialInSecondCoordinate f + let ι : Polynomial K →+* RatFunc K := algebraMap (Polynomial K) (RatFunc K) + have hFderivative : F.derivative ≠ 0 := by + rw [show F.derivative = + BGS.CorvajaZannier.planeCurvePolynomialInSecondCoordinate + (MvPolynomial.pderiv 1 f) by + simpa [F] using planeCurvePolynomialInSecondCoordinate_derivative f] + intro hzero + apply hpartialSecond + apply BGS.CorvajaZannier.planeCurvePolynomialInSecondCoordinate.injective + simpa using hzero + have hFmapIrreducible : Irreducible (F.map ι) := by + simpa [F, ι] using + BGS.CorvajaZannier.planeCurvePolynomialInSecondCoordinate_ratFunc_irreducible + hf hpartialSecond + have hFmapDerivative : (F.map ι).derivative ≠ 0 := by + simpa only [Polynomial.derivative_map] using + (by simpa only [Polynomial.map_zero] using + (Polynomial.map_injective ι + (IsFractionRing.injective (Polynomial K) (RatFunc K))).ne hFderivative) + have hseparable : (F.map ι).Separable := + (Polynomial.separable_iff_derivative_ne_zero hFmapIrreducible).2 + hFmapDerivative + have hmapResultantDefault : + Polynomial.resultant (F.map ι) (F.derivative.map ι) ≠ 0 := by + change IsCoprime (F.map ι) (F.map ι).derivative at hseparable + exact Polynomial.resultant_ne_zero _ _ (by + simpa only [Polynomial.derivative_map] using hseparable) + have hmapFdegree : (F.map ι).natDegree = F.natDegree := + by simpa [ι] using + (Polynomial.natDegree_map_eq_of_injective + (IsFractionRing.injective (Polynomial K) (RatFunc K)) F) + have hmapDdegree : (F.derivative.map ι).natDegree = F.derivative.natDegree := + by simpa [ι] using + (Polynomial.natDegree_map_eq_of_injective + (IsFractionRing.injective (Polynomial K) (RatFunc K)) F.derivative) + have hmapResultant : + Polynomial.resultant (F.map ι) (F.derivative.map ι) + F.natDegree F.derivative.natDegree ≠ 0 := by + simpa only [hmapFdegree, hmapDdegree] using hmapResultantDefault + intro hzero + apply hmapResultant + rw [Polynomial.resultant_map_map] + simpa [secondCoordinateCriticalResultant, F, ι] using congrArg ι hzero + +/-- Affine points where the curve equation and its second-coordinate +derivative vanish. This set contains every affine singular point. -/ +noncomputable def affineSecondCoordinateCriticalPoints + (K : Type*) [Field K] [Fintype K] [DecidableEq K] + (f : MvPolynomial (Fin 2) K) : Finset (K × K) := by + classical + exact Finset.univ.filter fun z => + MvPolynomial.eval ![z.1, z.2] f = 0 ∧ + MvPolynomial.eval ![z.1, z.2] (MvPolynomial.pderiv 1 f) = 0 + +@[simp] +theorem mem_affineSecondCoordinateCriticalPoints_iff + {K : Type*} [Field K] [Fintype K] [DecidableEq K] + {f : MvPolynomial (Fin 2) K} {z : K × K} : + z ∈ affineSecondCoordinateCriticalPoints K f ↔ + MvPolynomial.eval ![z.1, z.2] f = 0 ∧ + MvPolynomial.eval ![z.1, z.2] (MvPolynomial.pderiv 1 f) = 0 := by + classical + simp [affineSecondCoordinateCriticalPoints] + +/-- Affine singular points: the equation and both coordinate partial +derivatives vanish. -/ +noncomputable def affinePlaneCurveSingularPoints + (K : Type*) [Field K] [Fintype K] [DecidableEq K] + (f : MvPolynomial (Fin 2) K) : Finset (K × K) := by + classical + exact Finset.univ.filter fun z => + MvPolynomial.eval ![z.1, z.2] f = 0 ∧ + MvPolynomial.eval ![z.1, z.2] (MvPolynomial.pderiv 0 f) = 0 ∧ + MvPolynomial.eval ![z.1, z.2] (MvPolynomial.pderiv 1 f) = 0 + +@[simp] +theorem mem_affinePlaneCurveSingularPoints_iff + {K : Type*} [Field K] [Fintype K] [DecidableEq K] + {f : MvPolynomial (Fin 2) K} {z : K × K} : + z ∈ affinePlaneCurveSingularPoints K f ↔ + MvPolynomial.eval ![z.1, z.2] f = 0 ∧ + MvPolynomial.eval ![z.1, z.2] (MvPolynomial.pderiv 0 f) = 0 ∧ + MvPolynomial.eval ![z.1, z.2] (MvPolynomial.pderiv 1 f) = 0 := by + classical + simp [affinePlaneCurveSingularPoints] + +theorem polynomialEvalZeroSubtype_card_le_natDegree + {K : Type*} [Field K] [Fintype K] [DecidableEq K] + (P : Polynomial K) (hP : P ≠ 0) : + Fintype.card {x : K // P.eval x = 0} ≤ P.natDegree := by + classical + let rootEmbedding : {x : K // P.eval x = 0} ↪ P.roots.toFinset := + { toFun := fun x => ⟨x, by + rw [Multiset.mem_toFinset, Polynomial.mem_roots hP] + exact x.2⟩ + inj' := by + intro x y hxy + apply Subtype.ext + exact congrArg (fun z : P.roots.toFinset => (z : K)) hxy } + calc + Fintype.card {x : K // P.eval x = 0} ≤ P.roots.toFinset.card := by + simpa only [Fintype.card_coe] using + Fintype.card_le_of_injective rootEmbedding rootEmbedding.injective + _ ≤ P.roots.card := Multiset.toFinset_card_le _ + _ ≤ P.natDegree := Polynomial.card_roots' P + +theorem affineSecondCoordinateCriticalPoints_card_le + {K : Type*} [Field K] [Fintype K] [DecidableEq K] + {f : MvPolynomial (Fin 2) K} {firstDegree secondDegree : ℕ} + (hdegree : BGS.External.HasBidegreeAtMost f firstDegree secondDegree) + (hf : Irreducible f) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) : + (affineSecondCoordinateCriticalPoints K f).card ≤ + ((2 * secondDegree - 1) * firstDegree) * secondDegree := by + classical + let S := affineSecondCoordinateCriticalPoints K f + let R := secondCoordinateCriticalResultant f + let X := {x : K // R.eval x = 0} + let Y := fun x : X => + {y : K // + (BGS.CorvajaZannier.secondCoordinateSpecialization f x.1).eval y = 0} + let embedding : {z // z ∈ S} ↪ Sigma Y := + { toFun := fun z => + ⟨⟨z.1.1, by + have hz := mem_affineSecondCoordinateCriticalPoints_iff.mp z.2 + exact secondCoordinateCriticalResultant_eval_eq_zero_of_common_zero + hpartialSecond z.1.1 z.1.2 hz.1 hz.2⟩, + ⟨z.1.2, by + rw [BGS.CorvajaZannier.secondCoordinateSpecialization_eval] + exact (mem_affineSecondCoordinateCriticalPoints_iff.mp z.2).1⟩⟩ + inj' := by + intro z w hzw + apply Subtype.ext + apply Prod.ext + · exact congrArg (fun q : Sigma Y => (q.1 : K)) hzw + · exact congrArg (fun q : Sigma Y => (q.2.1 : K)) hzw } + have hsecond : 0 < MvPolynomial.degreeOf 1 f := + BGS.CorvajaZannier.degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond + have hFiber (x : X) : Fintype.card (Y x) ≤ secondDegree := by + exact (polynomialEvalZeroSubtype_card_le_natDegree + (BGS.CorvajaZannier.secondCoordinateSpecialization f x.1) + (BGS.CorvajaZannier.secondCoordinateSpecialization_ne_zero_of_irreducible + hf hsecond x.1)).trans + (BGS.CorvajaZannier.secondCoordinateSpecialization_natDegree_le + hdegree x.1) + have hRne : R ≠ 0 := by + simpa [R] using secondCoordinateCriticalResultant_ne_zero hf hpartialSecond + have hBase : Fintype.card X ≤ R.natDegree := by + exact polynomialEvalZeroSubtype_card_le_natDegree R hRne + have hRdegree : R.natDegree ≤ (2 * secondDegree - 1) * firstDegree := by + simpa [R] using secondCoordinateCriticalResultant_natDegree_le hdegree + calc + S.card = Fintype.card {z // z ∈ S} := by simp + _ ≤ Fintype.card (Sigma Y) := + Fintype.card_le_of_injective embedding embedding.injective + _ = ∑ x, Fintype.card (Y x) := Fintype.card_sigma + _ ≤ ∑ _x : X, secondDegree := by + exact Finset.sum_le_sum fun x _ => hFiber x + _ = Fintype.card X * secondDegree := by simp + _ ≤ R.natDegree * secondDegree := Nat.mul_le_mul_right _ hBase + _ ≤ ((2 * secondDegree - 1) * firstDegree) * secondDegree := + Nat.mul_le_mul_right _ hRdegree + +/-- A coarse bidegree bound for the number of affine singular points of an +irreducible separating plane curve. -/ +theorem affinePlaneCurveSingularPoints_card_le + {K : Type*} [Field K] [Fintype K] [DecidableEq K] + {f : MvPolynomial (Fin 2) K} {firstDegree secondDegree : ℕ} + (hdegree : BGS.External.HasBidegreeAtMost f firstDegree secondDegree) + (hf : Irreducible f) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) : + (affinePlaneCurveSingularPoints K f).card ≤ + ((2 * secondDegree - 1) * firstDegree) * secondDegree := by + apply (Finset.card_le_card ?_).trans + (affineSecondCoordinateCriticalPoints_card_le hdegree hf hpartialSecond) + intro z hz + rw [mem_affineSecondCoordinateCriticalPoints_iff] + have hz' := mem_affinePlaneCurveSingularPoints_iff.mp hz + exact ⟨hz'.1, hz'.2.2⟩ + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/PlaneSmoothPointNormalization.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/PlaneSmoothPointNormalization.lean new file mode 100644 index 0000000000..41ceeb6ce2 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/PlaneSmoothPointNormalization.lean @@ -0,0 +1,1016 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.SquareExtensionAffinePlaces +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveAuxiliaryFinitePlaceCases +public import Mathlib.RingTheory.DiscreteValuationRing.TFAE +public import Mathlib.RingTheory.Smooth.StandardSmoothCotangent +public import Mathlib.RingTheory.Localization.LocalizationLocalization +public import Mathlib.LinearAlgebra.TensorProduct.Basis +public import Mathlib.RingTheory.Etale.Field +public import Mathlib.Tactic + +/-! +# Smooth affine centres and normalization residue fields + +For a closed affine centre coming from the quadratic constant-field +extension, its residue field embeds into that quadratic extension. Hence +every residue satisfies the square-Frobenius identity required by the +Stepanov vanishing argument. + +At a smooth centre, the local Jacobian criterion identifies the affine local +ring as a discrete valuation ring. Its valuation subring inside the function +field is therefore the selected dominating normalization valuation. Thus the +affine centre and its selected normalization prime have canonically equivalent +residue fields; in particular, the selected place has degree at most two and +satisfies square Frobenius. + +The file also records that nonvanishing of the second partial derivative at +a quadratic-extension point is exactly non-membership of that derivative in +the corresponding affine maximal ideal. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +open BGS.CorvajaZannier +open IsDedekindDomain +open Module +open scoped Polynomial + +noncomputable section + +variable {K : Type*} [Field K] + +/-! ## The smooth partial-`Y` chart -/ + +/-- The singleton relation family presenting the affine plane curve. -/ +def planeCurveRelationFamily (f : MvPolynomial (Fin 2) K) (_ : Unit) := f + +/-- The singleton-relation presentation is the usual plane-curve coordinate +ring. -/ +def planeCurvePresentationEquiv (f : MvPolynomial (Fin 2) K) : + (MvPolynomial (Fin 2) K ⧸ + Ideal.span (Set.range (planeCurveRelationFamily f))) ≃ₐ[K] + PlaneCurveCoordinateRing f := + Ideal.quotientEquivAlgOfEq K (by + congr 1 + ext g + simp [planeCurveRelationFamily, eq_comm]) + +/-- The plane curve as a one-equation pre-submersive presentation, with the +second coordinate chosen as the Jacobian direction. -/ +def planeCurveYPreSubmersivePresentation (f : MvPolynomial (Fin 2) K) : + Algebra.PreSubmersivePresentation K (PlaneCurveCoordinateRing f) (Fin 2) Unit := + (Algebra.PreSubmersivePresentation.naive + (v := planeCurveRelationFamily f) + (fun _ => 1) (fun _ _ _ => Subsingleton.elim _ _)).ofAlgEquiv + (planeCurvePresentationEquiv f) + +noncomputable instance planeCurveFinitePresentation (f : MvPolynomial (Fin 2) K) : + Algebra.FinitePresentation K (PlaneCurveCoordinateRing f) := + Algebra.Presentation.finitePresentation_of_isFinite + (planeCurveYPreSubmersivePresentation f).toPresentation + +/-- The class of the second partial derivative in the plane-curve coordinate +ring. -/ +def planeCurvePartialY (f : MvPolynomial (Fin 2) K) : + PlaneCurveCoordinateRing f := + planeCurveQuotientMap f (MvPolynomial.pderiv 1 f) + +/-- The Jacobian of the chosen one-equation presentation is the second +partial derivative. -/ +theorem planeCurveYPreSubmersivePresentation_jacobian + (f : MvPolynomial (Fin 2) K) : + (planeCurveYPreSubmersivePresentation f).jacobian = planeCurvePartialY f := by + let P := Algebra.PreSubmersivePresentation.naive + (v := planeCurveRelationFamily f) + (fun _ => 1) (fun _ _ _ => Subsingleton.elim _ _) + let E := planeCurvePresentationEquiv f + change (P.ofAlgEquiv E).jacobian = planeCurvePartialY f + rw [Algebra.PreSubmersivePresentation.jacobian_ofAlgEquiv, + Algebra.PreSubmersivePresentation.jacobian_eq_jacobiMatrix_det, + Matrix.det_unique] + erw [Algebra.PreSubmersivePresentation.jacobiMatrix_naive] + change E (Ideal.Quotient.mk _ (MvPolynomial.pderiv 1 f)) = + Ideal.Quotient.mk _ (MvPolynomial.pderiv 1 f) + exact Ideal.quotientEquivAlgOfEq_mk K _ _ + +/-- The principal smooth chart on which the second partial derivative is +inverted. -/ +abbrev PlaneCurvePartialYLocalization (f : MvPolynomial (Fin 2) K) := + Localization.Away (planeCurvePartialY f) + +def planeCurvePartialYLocalizationPreSubmersivePresentation + (f : MvPolynomial (Fin 2) K) : + Algebra.PreSubmersivePresentation + (PlaneCurveCoordinateRing f) (PlaneCurvePartialYLocalization f) Unit Unit := + Algebra.PreSubmersivePresentation.localizationAway + (PlaneCurvePartialYLocalization f) (planeCurvePartialY f) + +def planeCurvePartialYCompositePresentation (f : MvPolynomial (Fin 2) K) : + Algebra.PreSubmersivePresentation K (PlaneCurvePartialYLocalization f) + (Unit ⊕ Fin 2) (Unit ⊕ Unit) := + (planeCurvePartialYLocalizationPreSubmersivePresentation f).comp + (planeCurveYPreSubmersivePresentation f) + +theorem planeCurvePartialYCompositePresentation_jacobian_isUnit + (f : MvPolynomial (Fin 2) K) : + IsUnit (planeCurvePartialYCompositePresentation f).jacobian := by + let A := PlaneCurveCoordinateRing f + let Ad := PlaneCurvePartialYLocalization f + let P₀ := planeCurveYPreSubmersivePresentation f + let Q := planeCurvePartialYLocalizationPreSubmersivePresentation f + have hP₀ : IsUnit (algebraMap A Ad P₀.jacobian) := by + rw [show P₀.jacobian = planeCurvePartialY f by + exact planeCurveYPreSubmersivePresentation_jacobian f] + exact IsLocalization.Away.algebraMap_isUnit + (S := Ad) (planeCurvePartialY f) + have hQ : IsUnit Q.jacobian := by + rw [show Q.jacobian = algebraMap A Ad (planeCurvePartialY f) by + exact Algebra.PreSubmersivePresentation.localizationAway_jacobian _] + exact IsLocalization.Away.algebraMap_isUnit + (S := Ad) (planeCurvePartialY f) + change IsUnit (Q.comp P₀).jacobian + rw [Algebra.PreSubmersivePresentation.comp_jacobian_eq_jacobian_smul_jacobian, + Algebra.smul_def] + exact hP₀.mul hQ + +/-- A submersive presentation of the partial-`Y` smooth chart. -/ +def planeCurvePartialYSubmersivePresentation (f : MvPolynomial (Fin 2) K) : + Algebra.SubmersivePresentation K (PlaneCurvePartialYLocalization f) + (Unit ⊕ Fin 2) (Unit ⊕ Unit) where + toPreSubmersivePresentation := planeCurvePartialYCompositePresentation f + jacobian_isUnit := planeCurvePartialYCompositePresentation_jacobian_isUnit f + +theorem planeCurvePartialYLocalization_isStandardSmooth + (f : MvPolynomial (Fin 2) K) : + Algebra.IsStandardSmooth K (PlaneCurvePartialYLocalization f) := + (planeCurvePartialYSubmersivePresentation f).isStandardSmooth + +theorem planeCurvePartialYSubmersivePresentation_dimension + (f : MvPolynomial (Fin 2) K) : + (planeCurvePartialYSubmersivePresentation f).dimension = 1 := by + simp [Algebra.Presentation.dimension] + +variable (K : Type*) [Field K] [Fintype K] [DecidableEq K] +variable (p : ℕ) [Fact p.Prime] [CharP K p] + +omit [DecidableEq K] in +/-- The residue field of every closed affine centre obtained from the +quadratic constant-field extension satisfies square Frobenius. -/ +theorem squareExtensionClosedPoint_residue_squareFrobenius + (f : MvPolynomial (Fin 2) K) + (m : SquareExtensionClosedPoint K p f) : + ∀ z : m.1.asIdeal.ResidueField, + z ^ (Fintype.card K) ^ 2 = z := by + obtain ⟨w, hw⟩ := m.2 + let wf : SquareExtensionClosedPointFiber K p f m := + ⟨w, Subtype.ext hw⟩ + let ι := squareExtensionFiberResidueAlgHom K p f m wf + let : Fintype (SquareExtension K p) := Fintype.ofFinite _ + have hcard : Fintype.card (SquareExtension K p) = + (Fintype.card K) ^ 2 := by + rw [Fintype.card_eq_nat_card, FiniteField.natCard_extension K p 2, + Nat.card_eq_fintype_card] + intro z + apply ι.injective + rw [map_pow, ← hcard, FiniteField.pow_card] + +omit [DecidableEq K] in +/-- The second partial derivative is nonzero at a quadratic-extension point +exactly in the direction needed for the local Jacobian criterion: its class +does not belong to the point's affine maximal ideal. -/ +theorem squareExtensionPoint_pderiv_not_mem_maximalIdeal + (f : MvPolynomial (Fin 2) K) + (z : SquareExtensionAffinePoint K p f) + (hregular : MvPolynomial.eval ![z.1.1, z.1.2] + (MvPolynomial.map (algebraMap K (SquareExtension K p)) + (MvPolynomial.pderiv 1 f)) ≠ 0) : + planeCurveQuotientMap f (MvPolynomial.pderiv 1 f) ∉ + (squareExtensionPointMaximalIdeal K p f z).asIdeal := by + rw [squareExtensionPointMaximalIdeal_asIdeal, RingHom.mem_ker] + change MvPolynomial.eval₂ (algebraMap K (SquareExtension K p)) + ![z.1.1, z.1.2] (MvPolynomial.pderiv 1 f) ≠ 0 + rw [MvPolynomial.eval₂_eq_eval_map] + exact hregular + +/-! ## Smooth closed points are discrete valuation rings -/ + +omit [DecidableEq K] in +/-- A closed point on the partial-`Y` smooth locus is not the generic point. -/ +theorem squareExtensionClosedPoint_asIdeal_ne_bot_of_partialY + {f : MvPolynomial (Fin 2) K} + (hf : Irreducible f) + (m : SquareExtensionClosedPoint K p f) + (hsmooth : planeCurvePartialY f ∉ m.1.asIdeal) : + letI := planeCurveCoordinateRing_isDomain hf + m.1.asIdeal ≠ ⊥ := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let A := PlaneCurveCoordinateRing f + obtain ⟨z, hz⟩ := m.2 + let r : A := planeCurveCoordinate f 0 ^ (Nat.card K) ^ 2 - + planeCurveCoordinate f 0 + have hr : r ∈ m.1.asIdeal := by + rw [← hz] + change planeCurveCoordinate f 0 ^ (Nat.card K) ^ 2 - + planeCurveCoordinate f 0 ∈ + (squareExtensionPointMaximalIdeal K p f z).asIdeal + exact squareExtensionFrobeniusElement_mem_pointMaximalIdeal K p f z + intro hm + have hrzero : r = 0 := by simpa [hm] using hr + have hpartial : MvPolynomial.pderiv 1 f ≠ 0 := by + intro hzero + apply hsmooth + simp [planeCurvePartialY, hzero] + have hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartial) + let g : Polynomial K := + Polynomial.X ^ (Nat.card K) ^ 2 - Polynomial.X + have hg0 : g ≠ 0 := by + exact FiniteField.X_pow_card_pow_sub_X_ne_zero K (by omega) + Finite.one_lt_card + apply hg0 + apply (transcendental_iff.mp hx) g + simpa [g, r, planeCurveFunction] using congrArg + (algebraMap A (PlaneCurveFunctionField f)) hrzero + +omit [DecidableEq K] in +/-- A finite-residue closed point on the partial-`Y` smooth locus has a +discrete valuation local ring. -/ +theorem planeCurveClosedPoint_localization_isDiscreteValuationRing + {f : MvPolynomial (Fin 2) K} + (hf : Irreducible f) + (m : MaximalSpectrum (PlaneCurveCoordinateRing f)) + [Finite m.asIdeal.ResidueField] + (hm0 : m.asIdeal ≠ ⊥) + (hsmooth : planeCurvePartialY f ∉ m.asIdeal) : + letI := planeCurveCoordinateRing_isDomain hf + IsDiscreteValuationRing (Localization.AtPrime m.asIdeal) := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let A := PlaneCurveCoordinateRing f + let d : A := planeCurvePartialY f + let Ad := PlaneCurvePartialYLocalization f + have hd0 : d ≠ 0 := by + intro hd + apply hsmooth + change d ∈ m.asIdeal + rw [hd] + exact m.asIdeal.zero_mem + let : IsDomain Ad := IsLocalization.Away.isDomain Ad hd0 + have hdisj : Disjoint ((Submonoid.powers d : Submonoid A) : Set A) + (m.asIdeal : Set A) := by + rw [Ideal.disjoint_powers_iff_notMem_of_isPrime] + exact hsmooth + let q : Ideal Ad := Ideal.map (algebraMap A Ad) m.asIdeal + let hqPrime : q.IsPrime := + IsLocalization.isPrime_of_isPrime_disjoint + (Submonoid.powers d) Ad m.asIdeal m.isMaximal.isPrime hdisj + have hunder : q.comap (algebraMap A Ad) = m.asIdeal := by + exact IsLocalization.under_map_of_isPrime_disjoint + (Submonoid.powers d) Ad m.isMaximal.isPrime hdisj + let hunderMax : (q.comap (algebraMap A Ad)).IsMaximal := by + rw [hunder] + exact m.isMaximal + let hqMax : q.IsMaximal := by + exact IsLocalization.isMaximal_of_isMaximal_under (Submonoid.powers d) Ad q + let S := Localization.AtPrime q + let : IsLocalRing S := IsLocalization.AtPrime.isLocalRing S q + let : IsDomain S := IsLocalization.isDomain_of_atPrime S q + let : Algebra A S := inferInstance + let : IsScalarTower A Ad S := inferInstance + let hSatPrime : IsLocalization.AtPrime S m.asIdeal := by + have hlocal : IsLocalization.AtPrime S + (q.comap (algebraMap A Ad)) := + IsLocalization.isLocalization_isLocalization_atPrime_isLocalization + (Submonoid.powers d) S q + refine ⟨?_⟩ + simpa only [hunder] using hlocal.toIsLocalizationMap + let : Algebra K S := inferInstance + let : IsScalarTower K A S := inferInstance + let : IsScalarTower K Ad S := inferInstance + let : Algebra.IsStandardSmooth K Ad := + planeCurvePartialYLocalization_isStandardSmooth f + let : Algebra.FormallySmooth K Ad := inferInstance + let : Algebra.FormallySmooth Ad S := + Algebra.FormallySmooth.of_isLocalization q.primeCompl + let : Algebra.FormallySmooth K S := + Algebra.FormallySmooth.comp K Ad S + let P := planeCurvePartialYSubmersivePresentation f + let I := ((Set.range P.map)ᶜ : Set (Unit ⊕ Fin 2)) + let bAd : Basis I Ad Ω[Ad⁄K] := P.basisKaehler + let bS : Basis I S Ω[S⁄K] := + bAd.ofIsLocalizedModule S q.primeCompl + (KaehlerDifferential.map K K Ad S) + let k := IsLocalRing.ResidueField S + let bk : Basis I k (TensorProduct S k (KaehlerDifferential K S)) := + bS.baseChange k + have hcardI : Fintype.card I = P.dimension := by + simp only [I, Fintype.card_compl_set, Algebra.Presentation.dimension, + Nat.card_eq_fintype_card, Set.card_range_of_injective P.map_inj] + have htarget : Module.finrank k + (TensorProduct S k (KaehlerDifferential K S)) = 1 := by + rw [Module.finrank_eq_card_basis bk, hcardI] + exact planeCurvePartialYSubmersivePresentation_dimension f + let eResidue := atPrimeResidueAlgEquiv K A S m.asIdeal + let : Finite k := Finite.of_injective eResidue.symm eResidue.symm.injective + let : Algebra.IsSeparable K k := inferInstance + let : Algebra.FormallyEtale K k := + Algebra.FormallyEtale.of_isSeparable K k + have hraw : Function.Injective + (KaehlerDifferential.kerCotangentToTensor K S k) := by + exact (Algebra.FormallySmooth.kerCotangentToTensor_injective_iff + (R := K) (P := S) (A := k) IsLocalRing.residue_surjective).2 inferInstance + have hker : RingHom.ker (algebraMap S k) = + IsLocalRing.maximalIdeal S := by + simpa [k, IsLocalRing.ResidueField.algebraMap_eq] using + (IsLocalRing.ker_residue (R := S)) + let cotangentEquiv : IsLocalRing.CotangentSpace S ≃ₗ[S] + (RingHom.ker (algebraMap S k)).Cotangent := + Ideal.Cotangent.equivOfEq _ _ hker.symm + let cotangentMapS : IsLocalRing.CotangentSpace S →ₗ[S] + (TensorProduct S k (KaehlerDifferential K S)) := + (KaehlerDifferential.kerCotangentToTensor K S k).comp + cotangentEquiv.toLinearMap + let cotangentMap : IsLocalRing.CotangentSpace S →ₗ[k] + (TensorProduct S k (KaehlerDifferential K S)) := + cotangentMapS.extendScalarsOfSurjective IsLocalRing.residue_surjective + have hcotangentMap : Function.Injective cotangentMap := by + intro x y hxy + apply cotangentEquiv.injective + apply hraw + exact hxy + have hcotangent : Module.finrank k (IsLocalRing.CotangentSpace S) ≤ 1 := by + rw [← htarget] + exact cotangentMap.finrank_le_finrank_of_injective hcotangentMap + have hnotField : ¬ IsField S := + IsLocalization.AtPrime.not_isField A hm0 S + have hprincipal : (IsLocalRing.maximalIdeal S).IsPrincipal := + IsLocalRing.finrank_cotangentSpace_le_one_iff.mp hcotangent + have hSDvr : IsDiscreteValuationRing S := + ((IsDiscreteValuationRing.TFAE S hnotField).out 5 1).mp hprincipal + let : IsDiscreteValuationRing S := hSDvr + exact IsDiscreteValuationRing.RingEquivClass.isDiscreteValuationRing + (IsLocalization.algEquiv m.asIdeal.primeCompl S + (Localization.AtPrime m.asIdeal)).toRingEquiv + +omit [DecidableEq K] in +/-- The local ring at a closed point where the second partial derivative does +not vanish is a discrete valuation ring. This is the local Jacobian boundary +needed to compare the affine curve with its normalization. -/ +theorem squareExtensionClosedPoint_localization_isDiscreteValuationRing + {f : MvPolynomial (Fin 2) K} + (hf : Irreducible f) + (m : SquareExtensionClosedPoint K p f) + (hsmooth : planeCurvePartialY f ∉ m.1.asIdeal) : + letI := planeCurveCoordinateRing_isDomain hf + IsDiscreteValuationRing (Localization.AtPrime m.1.asIdeal) := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let A := PlaneCurveCoordinateRing f + let d : A := planeCurvePartialY f + let Ad := PlaneCurvePartialYLocalization f + have hd0 : d ≠ 0 := by + intro hd + apply hsmooth + change d ∈ m.1.asIdeal + rw [hd] + exact m.1.asIdeal.zero_mem + let : IsDomain Ad := IsLocalization.Away.isDomain Ad hd0 + have hdisj : Disjoint ((Submonoid.powers d : Submonoid A) : Set A) + (m.1.asIdeal : Set A) := by + rw [Ideal.disjoint_powers_iff_notMem_of_isPrime] + exact hsmooth + let q : Ideal Ad := Ideal.map (algebraMap A Ad) m.1.asIdeal + let hqPrime : q.IsPrime := + IsLocalization.isPrime_of_isPrime_disjoint + (Submonoid.powers d) Ad m.1.asIdeal m.1.isMaximal.isPrime hdisj + have hunder : q.comap (algebraMap A Ad) = m.1.asIdeal := by + exact IsLocalization.under_map_of_isPrime_disjoint + (Submonoid.powers d) Ad m.1.isMaximal.isPrime hdisj + let hunderMax : (q.comap (algebraMap A Ad)).IsMaximal := by + rw [hunder] + exact m.1.isMaximal + let hqMax : q.IsMaximal := by + exact IsLocalization.isMaximal_of_isMaximal_under (Submonoid.powers d) Ad q + let S := Localization.AtPrime q + let : IsLocalRing S := IsLocalization.AtPrime.isLocalRing S q + let : IsDomain S := IsLocalization.isDomain_of_atPrime S q + let : Algebra A S := inferInstance + let : IsScalarTower A Ad S := inferInstance + let hSatPrime : IsLocalization.AtPrime S m.1.asIdeal := by + have hlocal : IsLocalization.AtPrime S + (q.comap (algebraMap A Ad)) := + IsLocalization.isLocalization_isLocalization_atPrime_isLocalization + (Submonoid.powers d) S q + refine ⟨?_⟩ + simpa only [hunder] using hlocal.toIsLocalizationMap + let : Algebra K S := inferInstance + let : IsScalarTower K A S := inferInstance + let : IsScalarTower K Ad S := inferInstance + let : Algebra.IsStandardSmooth K Ad := + planeCurvePartialYLocalization_isStandardSmooth f + let : Algebra.FormallySmooth K Ad := inferInstance + let : Algebra.FormallySmooth Ad S := + Algebra.FormallySmooth.of_isLocalization q.primeCompl + let : Algebra.FormallySmooth K S := + Algebra.FormallySmooth.comp K Ad S + let P := planeCurvePartialYSubmersivePresentation f + let I := ((Set.range P.map)ᶜ : Set (Unit ⊕ Fin 2)) + let bAd : Basis I Ad Ω[Ad⁄K] := P.basisKaehler + let bS : Basis I S Ω[S⁄K] := + bAd.ofIsLocalizedModule S q.primeCompl + (KaehlerDifferential.map K K Ad S) + let k := IsLocalRing.ResidueField S + let bk : Basis I k (TensorProduct S k (KaehlerDifferential K S)) := + bS.baseChange k + have hcardI : Fintype.card I = P.dimension := by + simp only [I, Fintype.card_compl_set, Algebra.Presentation.dimension, + Nat.card_eq_fintype_card, Set.card_range_of_injective P.map_inj] + have htarget : Module.finrank k + (TensorProduct S k (KaehlerDifferential K S)) = 1 := by + rw [Module.finrank_eq_card_basis bk, hcardI] + exact planeCurvePartialYSubmersivePresentation_dimension f + obtain ⟨z, hz⟩ := m.2 + let zf : SquareExtensionClosedPointFiber K p f m := + ⟨z, Subtype.ext hz⟩ + let ι := squareExtensionFiberResidueAlgHom K p f m zf + let : Finite m.1.asIdeal.ResidueField := Finite.of_injective ι ι.injective + let eResidue := atPrimeResidueAlgEquiv K A S m.1.asIdeal + let : Finite k := Finite.of_injective eResidue.symm eResidue.symm.injective + let : Algebra.IsSeparable K k := inferInstance + let : Algebra.FormallyEtale K k := + Algebra.FormallyEtale.of_isSeparable K k + have hraw : Function.Injective + (KaehlerDifferential.kerCotangentToTensor K S k) := by + exact (Algebra.FormallySmooth.kerCotangentToTensor_injective_iff + (R := K) (P := S) (A := k) IsLocalRing.residue_surjective).2 inferInstance + have hker : RingHom.ker (algebraMap S k) = + IsLocalRing.maximalIdeal S := by + simpa [k, IsLocalRing.ResidueField.algebraMap_eq] using + (IsLocalRing.ker_residue (R := S)) + let cotangentEquiv : IsLocalRing.CotangentSpace S ≃ₗ[S] + (RingHom.ker (algebraMap S k)).Cotangent := + Ideal.Cotangent.equivOfEq _ _ hker.symm + let cotangentMapS : IsLocalRing.CotangentSpace S →ₗ[S] + (TensorProduct S k (KaehlerDifferential K S)) := + (KaehlerDifferential.kerCotangentToTensor K S k).comp + cotangentEquiv.toLinearMap + let cotangentMap : IsLocalRing.CotangentSpace S →ₗ[k] + (TensorProduct S k (KaehlerDifferential K S)) := + cotangentMapS.extendScalarsOfSurjective IsLocalRing.residue_surjective + have hcotangentMap : Function.Injective cotangentMap := by + intro x y hxy + apply cotangentEquiv.injective + apply hraw + exact hxy + have hcotangent : Module.finrank k (IsLocalRing.CotangentSpace S) ≤ 1 := by + rw [← htarget] + exact cotangentMap.finrank_le_finrank_of_injective hcotangentMap + have hm0 : m.1.asIdeal ≠ ⊥ := + squareExtensionClosedPoint_asIdeal_ne_bot_of_partialY + K p hf m hsmooth + have hnotField : ¬ IsField S := + IsLocalization.AtPrime.not_isField A hm0 S + have hprincipal : (IsLocalRing.maximalIdeal S).IsPrincipal := + IsLocalRing.finrank_cotangentSpace_le_one_iff.mp hcotangent + have hSDvr : IsDiscreteValuationRing S := + ((IsDiscreteValuationRing.TFAE S hnotField).out 5 1).mp hprincipal + let : IsDiscreteValuationRing S := hSDvr + exact IsDiscreteValuationRing.RingEquivClass.isDiscreteValuationRing + (IsLocalization.algEquiv m.1.asIdeal.primeCompl S + (Localization.AtPrime m.1.asIdeal)).toRingEquiv + +section CommonLocalization + +variable {C A B R : Type*} + [Field C] [CommRing A] [CommRing B] [CommRing R] + [Algebra C A] [Algebra C B] [Algebra A R] [Algebra B R] [Algebra C R] + [IsScalarTower C A R] [IsScalarTower C B R] [IsLocalRing R] + (m : Ideal A) [m.IsMaximal] (q : Ideal B) [q.IsMaximal] + [IsLocalization.AtPrime R m] [IsLocalization.AtPrime R q] + +/-- If two maximal ideals have the same local ring, their residue fields are +canonically equivalent over the common coefficient field. -/ +noncomputable def atPrimeResidueAlgEquivOfCommonLocalization : + m.ResidueField ≃ₐ[C] q.ResidueField := + (atPrimeResidueAlgEquiv C A R m).trans + (atPrimeResidueAlgEquiv C B R q).symm + +include R in +/-- Residue-field degree is preserved across a common localization. -/ +theorem finrank_residueField_eq_of_commonLocalization : + Module.finrank C m.ResidueField = Module.finrank C q.ResidueField := + (atPrimeResidueAlgEquivOfCommonLocalization + (C := C) (A := A) (B := B) (R := R) m q).toLinearEquiv.finrank_eq + +end CommonLocalization + +private theorem residue_finrank_eq_of_regular_dominating_valuation + (C A B E : Type*) [Field C] [CommRing A] [IsDomain A] [CommRing B] [Field E] + [Algebra C A] [Algebra C B] [Algebra A E] [IsFractionRing A E] + [Algebra C E] [IsScalarTower C A E] + (m : MaximalSpectrum A) (q : Ideal B) [q.IsMaximal] + (R : ValuationSubring E) [Algebra B R] [Algebra C R] + [IsScalarTower C B R] [IsLocalization.AtPrime R q] + [IsDiscreteValuationRing (Localization.AtPrime m.asIdeal)] + (hm0 : m.asIdeal ≠ ⊥) + (hspec : R = dominatingValuationSubring (A := A) (L := E) m) + (hscalar : ∀ c : C, ((algebraMap C R c : R) : E) = algebraMap C E c) : + Module.finrank C m.asIdeal.ResidueField = Module.finrank C q.ResidueField := by + let Wsub : Subalgebra A E := + Localization.subalgebra.ofField E m.asIdeal.primeCompl + m.asIdeal.primeCompl_le_nonZeroDivisors + let : IsDiscreteValuationRing Wsub := + IsDiscreteValuationRing.RingEquivClass.isDiscreteValuationRing + (IsLocalization.algEquiv m.asIdeal.primeCompl + (Localization.AtPrime m.asIdeal) Wsub).toRingEquiv + let W : ValuationSubring E := + ValuationSubring.ofSubring Wsub.toSubring fun x => by + simpa [IsLocalization.IsInteger] using + ValuationRing.isInteger_or_isInteger Wsub x + let : Algebra A W := Wsub.algebra' + let : IsLocalization m.asIdeal.primeCompl W := + Localization.subalgebra.isLocalization_ofField E + m.asIdeal.primeCompl m.asIdeal.primeCompl_le_nonZeroDivisors + let eW : Wsub ≃+* W := + { toFun := fun x => ⟨x.1, x.2⟩ + invFun := fun x => ⟨x.1, x.2⟩ + left_inv := fun x => Subtype.ext rfl + right_inv := fun x => Subtype.ext rfl + map_add' := fun _ _ => rfl + map_mul' := fun _ _ => rfl } + let : IsDiscreteValuationRing W := + IsDiscreteValuationRing.RingEquivClass.isDiscreteValuationRing eW + let V := dominatingValuationSubring (A := A) (L := E) m + have hWV : W ≤ V := by + intro x hx + change x ∈ Wsub at hx + rcases hx with ⟨a, s, hs, rfl⟩ + have haV : algebraMap A E a ∈ V := + range_le_dominatingValuationSubring m ⟨a, rfl⟩ + have hsV : algebraMap A E s ∈ V := + range_le_dominatingValuationSubring m ⟨s, rfl⟩ + let sv : V := ⟨algebraMap A E s, hsV⟩ + have hsvNot : sv ∉ IsLocalRing.maximalIdeal V := by + intro hsv + apply hs + rw [pointIdeal_eq_comap_dominatingValuationSubring_maximalIdeal + (A := A) (L := E)] + exact hsv + have hsvUnit : IsUnit sv := by + by_contra hunit + apply hsvNot + rw [IsLocalRing.mem_maximalIdeal, mem_nonunits_iff] + exact hunit + have hinvV : (algebraMap A E s)⁻¹ ∈ V := + Submonoid.inv_mem_of_isUnit (S := V) hsvUnit + exact V.toSubring.mul_mem haV hinvV + rw [Submodule.ne_bot_iff] at hm0 + obtain ⟨r, hr, hr0⟩ := hm0 + have hrMap0 : algebraMap A E r ≠ 0 := by + intro hzero + apply hr0 + apply IsFractionRing.injective A E + simpa using hzero + have hrNonunits : algebraMap A E r ∈ V.nonunits := + algebraMap_mem_dominatingValuationSubring_nonunits_of_mem + (A := A) (L := E) m r hr + have hV : V ≠ ⊤ := by + intro htop + have hnontrivial : V.valuation.IsNontrivial := + (Valuation.isNontrivial_iff_exists_lt_one V.valuation).2 + ⟨algebraMap A E r, hrMap0, hrNonunits⟩ + exact ((ValuationSubring.eq_top_iff V).mp htop) hnontrivial + have hWVeq : W = V := + ValuationSubring.eq_of_le_of_ne_top W hWV hV + have hWR : W = R := hWVeq.trans hspec.symm + let eWR : W ≃+* R := + { toFun := fun x => ⟨x.1, by rw [← hWR]; exact x.2⟩ + invFun := fun x => ⟨x.1, by rw [hWR]; exact x.2⟩ + left_inv := fun x => Subtype.ext rfl + right_inv := fun x => Subtype.ext rfl + map_add' := fun _ _ => rfl + map_mul' := fun _ _ => rfl } + let : Algebra A R := + RingHom.toAlgebra (eWR.toRingHom.comp (algebraMap A W)) + let eWRAlg : W ≃ₐ[A] R := + { eWR with commutes' := fun _ => rfl } + let : IsLocalization m.asIdeal.primeCompl R := + IsLocalization.isLocalization_of_algEquiv + m.asIdeal.primeCompl eWRAlg + let : IsScalarTower C A R := + IsScalarTower.of_algebraMap_eq (R := C) (S := A) (A := R) (fun c => by + apply Subtype.ext + change ((algebraMap C R c : R) : E) = algebraMap A E (algebraMap C A c) + rw [hscalar, ← IsScalarTower.algebraMap_apply C A E]) + exact finrank_residueField_eq_of_commonLocalization (C := C) (R := R) m.asIdeal q + +section SquareExtensionCommonLocalization + +variable {f : MvPolynomial (Fin 2) K} +variable {B R : Type*} [CommRing B] [CommRing R] + [Algebra K B] + [Algebra (PlaneCurveCoordinateRing f) R] [Algebra B R] [Algebra K R] + [IsScalarTower K (PlaneCurveCoordinateRing f) R] + [IsScalarTower K B R] [IsLocalRing R] + (m : SquareExtensionClosedPoint K p f) + (q : Ideal B) [q.IsMaximal] + [IsLocalization.AtPrime R m.1.asIdeal] + [IsLocalization.AtPrime R q] + +omit [DecidableEq K] in +include f R m in +/-- A normalization prime sharing its local ring with a +quadratic-extension affine centre has residue degree at most two. -/ +theorem squareExtensionClosedPoint_commonLocalization_residue_finrank_le_two : + Module.finrank K q.ResidueField ≤ 2 := by + rw [← finrank_residueField_eq_of_commonLocalization + (C := K) (A := PlaneCurveCoordinateRing f) (B := B) (R := R) + m.1.asIdeal q] + exact squareExtensionClosedPoint_residueDegree_le_two K p f m + +omit [DecidableEq K] in +include f R m in +/-- A normalization local ring that is also the affine local ring at a +quadratic-extension centre has the square-Frobenius residue identity needed +by Stepanov's method. -/ +theorem squareExtensionClosedPoint_commonLocalization_residue_squareFrobenius : + ∀ z : q.ResidueField, z ^ (Fintype.card K) ^ 2 = z := by + let e := atPrimeResidueAlgEquivOfCommonLocalization + (C := K) (A := PlaneCurveCoordinateRing f) (B := B) (R := R) + m.1.asIdeal q + intro z + apply e.symm.injective + simpa using + (squareExtensionClosedPoint_residue_squareFrobenius K p f m (e.symm z)) + +end SquareExtensionCommonLocalization + +/-! ## The selected normalization place at a smooth centre -/ + +/-- At a partial-`Y` smooth centre, normalization preserves the residue field: +the degree of the selected normalization place is exactly the residue degree +of its affine centre. -/ +theorem squareExtensionClosedPointExhaustiveFinitePlace_placeDegree_eq_residueDegree_of_partialY + {f : MvPolynomial (Fin 2) K} + (hf : Irreducible f) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (m : SquareExtensionClosedPoint K p f) + (hsmooth : planeCurvePartialY f ∉ m.1.asIdeal) : + let := planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let := planeCurveFirstCoordinateRatFuncAlgebra f hx + let : Algebra (Polynomial K) (PlaneCurveFunctionField f) := + RingHom.toAlgebra + ((algebraMap (RatFunc K) (PlaneCurveFunctionField f)).comp + (algebraMap (Polynomial K) (RatFunc K))) + let : IsScalarTower (Polynomial K) (RatFunc K) + (PlaneCurveFunctionField f) := + IsScalarTower.of_algebraMap_eq' rfl + let : FiniteDimensional (RatFunc K) (PlaneCurveFunctionField f) := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : Algebra.IsSeparable (RatFunc K) (PlaneCurveFunctionField f) := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : DecidableEq (RatFunc K) := Classical.decEq _ + finiteExtensionPlaceDegree K (PlaneCurveFunctionField f) + (.inl (squareExtensionClosedPointExhaustiveFinitePlace + K p hf hpartialSecond m)) = + Module.finrank K m.1.asIdeal.ResidueField := by + intro domainModel hx ratFuncModel polynomialModel towerModel finiteModel separableModel + decidableModel + let A := PlaneCurveCoordinateRing f + let E := PlaneCurveFunctionField f + let q : FiniteExtensionFinitePlace K E := + squareExtensionClosedPointExhaustiveFinitePlace + K p hf hpartialSecond m + let B := RatFuncFiniteIntegralClosure K E + let : Algebra K B := + RingHom.toAlgebra + ((algebraMap (Polynomial K) B).comp (algebraMap K (Polynomial K))) + let : IsScalarTower K (Polynomial K) B := + IsScalarTower.of_algebraMap_eq' rfl + let : IsScalarTower K (RatFunc K) E := + IsScalarTower.of_algebraMap_eq' (by + ext c + have h := congrArg + (fun g : Polynomial K →+* E => g (Polynomial.C c)) + (ratFuncSpecialization_comp_polynomial_algebraMap + (planeCurveFunction f 0) hx) + simpa [E, planeCurveFirstCoordinateRatFuncAlgebra] using h.symm) + let : IsScalarTower K (Polynomial K) E := + IsScalarTower.of_algebraMap_eq' (by + ext c + rw [IsScalarTower.algebraMap_apply K (RatFunc K) E, + IsScalarTower.algebraMap_apply K (Polynomial K) (RatFunc K)] + rfl) + let : IsScalarTower K B E := IsScalarTower.of_algebraMap_eq' (by + ext c + rw [IsScalarTower.algebraMap_apply K (Polynomial K) E] + rfl) + let R := IsDedekindDomain.HeightOneSpectrum.valuationSubringAtPrime E q + let : Algebra K R := + RingHom.toAlgebra ((algebraMap B R).comp (algebraMap K B)) + let : IsScalarTower K B R := IsScalarTower.of_algebraMap_eq' rfl + let : IsDiscreteValuationRing (Localization.AtPrime m.1.asIdeal) := + squareExtensionClosedPoint_localization_isDiscreteValuationRing K p hf m hsmooth + have hresidue := residue_finrank_eq_of_regular_dominating_valuation K A B E + m.1 q.asIdeal R + (squareExtensionClosedPoint_asIdeal_ne_bot_of_partialY K p hf m hsmooth) + (squareExtensionClosedPointExhaustiveFinitePlace_spec K p hf hpartialSecond m) + (fun c => by + change algebraMap B E (algebraMap K B c) = algebraMap K E c + exact (IsScalarTower.algebraMap_apply K B E c).symm) + rw [finiteExtensionFinitePlace_degree_eq_finrank_residueField K E q] + exact hresidue.symm + +section FinitePlaceDegree + +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] +variable [DecidableEq (RatFunc K)] + +local instance (priority := 10) planeSmoothPolynomialAlgebra : Algebra K[X] L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K[X] (RatFunc K))) + +local instance planeSmoothPolynomialScalarTower : + IsScalarTower K[X] (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + +local instance planeSmoothFiniteConstantAlgebra : + Algebra K (RatFuncFiniteIntegralClosure K L) := + RingHom.toAlgebra ((algebraMap K[X] + (RatFuncFiniteIntegralClosure K L)).comp (algebraMap K K[X])) + +local instance planeSmoothFiniteConstantTower : + IsScalarTower K K[X] (RatFuncFiniteIntegralClosure K L) := + IsScalarTower.of_algebraMap_eq' rfl + +/-- Any finite function-field place of constant-field degree at most two has +the square-Frobenius residue identity consumed by the Stepanov restriction +map. -/ +theorem finiteExtensionFinitePlace_residue_squareFrobenius_of_degree_le_two + (q : FiniteExtensionFinitePlace K L) + (hdegree : finiteExtensionPlaceDegree K L (.inl q) ≤ 2) : + ∀ z : q.asIdeal.ResidueField, + z ^ (Fintype.card K) ^ 2 = z := by + have hdegree' : Module.finrank K q.asIdeal.ResidueField ≤ 2 := by + rw [finiteExtensionFinitePlace_degree_eq_finrank_residueField K L q] at hdegree + exact hdegree + let : Finite q.asIdeal.ResidueField := + finiteExtensionFinitePlace_residueField_finite (K := K) (L := L) q + let : Fintype q.asIdeal.ResidueField := Fintype.ofFinite _ + let : Module.Finite K q.asIdeal.ResidueField := by + rw [Module.finite_def] + exact ⟨Finset.univ, by simp⟩ + have hpositive : 0 < Module.finrank K q.asIdeal.ResidueField := Module.finrank_pos + have hcard : Fintype.card q.asIdeal.ResidueField = + (Fintype.card K) ^ Module.finrank K q.asIdeal.ResidueField := by + exact Module.card_eq_pow_finrank + intro z + have hdegreeCases : Module.finrank K q.asIdeal.ResidueField = 1 ∨ + Module.finrank K q.asIdeal.ResidueField = 2 := by omega + rcases hdegreeCases with hdegreeOne | hdegreeTwo + · have hz := FiniteField.pow_card_pow 2 z + simpa [hcard, hdegreeOne] using hz + · simpa [hcard, hdegreeTwo] using FiniteField.pow_card z + +end FinitePlaceDegree + +/-- A selected normalization place above a partial-`Y` smooth quadratic +closed point has constant-field degree at most two. -/ +theorem squareExtensionClosedPointExhaustiveFinitePlace_placeDegree_le_two_of_partialY + {f : MvPolynomial (Fin 2) K} + (hf : Irreducible f) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (m : SquareExtensionClosedPoint K p f) + (hsmooth : planeCurvePartialY f ∉ m.1.asIdeal) : + letI := planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + letI := planeCurveFirstCoordinateRatFuncAlgebra f hx + letI : Algebra (Polynomial K) (PlaneCurveFunctionField f) := + RingHom.toAlgebra + ((algebraMap (RatFunc K) (PlaneCurveFunctionField f)).comp + (algebraMap (Polynomial K) (RatFunc K))) + letI : IsScalarTower (Polynomial K) (RatFunc K) + (PlaneCurveFunctionField f) := + IsScalarTower.of_algebraMap_eq' rfl + letI : FiniteDimensional (RatFunc K) (PlaneCurveFunctionField f) := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + letI : Algebra.IsSeparable (RatFunc K) (PlaneCurveFunctionField f) := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + letI : DecidableEq (RatFunc K) := Classical.decEq _ + finiteExtensionPlaceDegree K (PlaneCurveFunctionField f) + (.inl (squareExtensionClosedPointExhaustiveFinitePlace + K p hf hpartialSecond m)) ≤ 2 := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let : Algebra (RatFunc K) (PlaneCurveFunctionField f) := + planeCurveFirstCoordinateRatFuncAlgebra f hx + let : Algebra (Polynomial K) (PlaneCurveFunctionField f) := + RingHom.toAlgebra + ((algebraMap (RatFunc K) (PlaneCurveFunctionField f)).comp + (algebraMap (Polynomial K) (RatFunc K))) + let : IsScalarTower (Polynomial K) (RatFunc K) + (PlaneCurveFunctionField f) := + IsScalarTower.of_algebraMap_eq' rfl + let : FiniteDimensional (RatFunc K) (PlaneCurveFunctionField f) := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : Algebra.IsSeparable (RatFunc K) (PlaneCurveFunctionField f) := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : DecidableEq (RatFunc K) := Classical.decEq _ + rw [squareExtensionClosedPointExhaustiveFinitePlace_placeDegree_eq_residueDegree_of_partialY + K p hf hpartialSecond m hsmooth] + exact squareExtensionClosedPoint_residueDegree_le_two K p f m + +/-- The residue field of the selected normalization place above a +partial-`Y` smooth quadratic closed point satisfies square Frobenius. -/ +theorem squareExtensionClosedPointExhaustiveFinitePlace_residue_squareFrobenius_of_partialY + {f : MvPolynomial (Fin 2) K} + (hf : Irreducible f) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (m : SquareExtensionClosedPoint K p f) + (hsmooth : planeCurvePartialY f ∉ m.1.asIdeal) : + letI := planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + letI := planeCurveFirstCoordinateRatFuncAlgebra f hx + letI : Algebra (Polynomial K) (PlaneCurveFunctionField f) := + RingHom.toAlgebra + ((algebraMap (RatFunc K) (PlaneCurveFunctionField f)).comp + (algebraMap (Polynomial K) (RatFunc K))) + letI : IsScalarTower (Polynomial K) (RatFunc K) + (PlaneCurveFunctionField f) := + IsScalarTower.of_algebraMap_eq' rfl + letI : FiniteDimensional (RatFunc K) (PlaneCurveFunctionField f) := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + letI : Algebra.IsSeparable (RatFunc K) (PlaneCurveFunctionField f) := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + letI : DecidableEq (RatFunc K) := Classical.decEq _ + ∀ z : (squareExtensionClosedPointExhaustiveFinitePlace + K p hf hpartialSecond m).asIdeal.ResidueField, + z ^ (Fintype.card K) ^ 2 = z := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let : Algebra (RatFunc K) (PlaneCurveFunctionField f) := + planeCurveFirstCoordinateRatFuncAlgebra f hx + let : Algebra (Polynomial K) (PlaneCurveFunctionField f) := + RingHom.toAlgebra + ((algebraMap (RatFunc K) (PlaneCurveFunctionField f)).comp + (algebraMap (Polynomial K) (RatFunc K))) + let : IsScalarTower (Polynomial K) (RatFunc K) + (PlaneCurveFunctionField f) := + IsScalarTower.of_algebraMap_eq' rfl + let : FiniteDimensional (RatFunc K) (PlaneCurveFunctionField f) := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : Algebra.IsSeparable (RatFunc K) (PlaneCurveFunctionField f) := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : DecidableEq (RatFunc K) := Classical.decEq _ + let q := squareExtensionClosedPointExhaustiveFinitePlace + K p hf hpartialSecond m + apply finiteExtensionFinitePlace_residue_squareFrobenius_of_degree_le_two + K (PlaneCurveFunctionField f) q + exact squareExtensionClosedPointExhaustiveFinitePlace_placeDegree_le_two_of_partialY + K p hf hpartialSecond m hsmooth + +/-- Evaluation identifies the residue field at a rational affine point with +the ground field. -/ +noncomputable def affinePlaneCurvePoint_residueAlgEquiv + {f : MvPolynomial (Fin 2) K} (z : AffinePlaneCurvePoint f) : + (affinePlaneCurvePointMaximalIdeal f z).asIdeal.ResidueField ≃ₐ[K] K := by + let A := PlaneCurveCoordinateRing f + let m := affinePlaneCurvePointMaximalIdeal f z + let ev : A →ₐ[K] K := + { planeCurvePointEval f z with + commutes' := planeCurvePointEval_algebraMap f z } + let eQuot : (A ⧸ m.asIdeal) ≃ₐ[K] K := by + change (A ⧸ RingHom.ker ev.toRingHom) ≃ₐ[K] K + exact Ideal.quotientKerAlgEquivOfSurjective + (planeCurvePointEval_surjective f z) + let eResidue : (A ⧸ m.asIdeal) ≃ₐ[K] m.asIdeal.ResidueField := + AlgEquiv.ofBijective + (IsScalarTower.toAlgHom K (A ⧸ m.asIdeal) m.asIdeal.ResidueField) + m.asIdeal.bijective_algebraMap_quotient_residueField + exact eResidue.symm.trans eQuot + +/-- The normalization place selected above a rational affine point that is +regular in the second-coordinate direction has degree one over the full +constant field. -/ +theorem affinePointExhaustiveFinitePlace_degree_eq_one_of_partialY + {f : MvPolynomial (Fin 2) K} + (hf : Irreducible f) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (z : AffinePlaneCurvePoint f) + (hregular : MvPolynomial.eval ![z.1.1, z.1.2] + (MvPolynomial.pderiv 1 f) ≠ 0) : + let := planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let := planeCurveFirstCoordinateRatFuncAlgebra f hx + let : Algebra (Polynomial K) (PlaneCurveFunctionField f) := + RingHom.toAlgebra + ((algebraMap (RatFunc K) (PlaneCurveFunctionField f)).comp + (algebraMap (Polynomial K) (RatFunc K))) + let : IsScalarTower (Polynomial K) (RatFunc K) + (PlaneCurveFunctionField f) := + IsScalarTower.of_algebraMap_eq' rfl + let : FiniteDimensional (RatFunc K) (PlaneCurveFunctionField f) := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : Algebra.IsSeparable (RatFunc K) (PlaneCurveFunctionField f) := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : DecidableEq (RatFunc K) := Classical.decEq _ + finiteExtensionPlaceDegree K (PlaneCurveFunctionField f) + (.inl (affinePointExhaustiveFinitePlace + hf hpartialFirst hpartialSecond z)) = 1 := by + intro domainModel hx ratFuncModel polynomialModel towerModel finiteModel separableModel + decidableModel + let A := PlaneCurveCoordinateRing f + let E := PlaneCurveFunctionField f + let m := affinePlaneCurvePointMaximalIdeal f z + let q : FiniteExtensionFinitePlace K E := + affinePointExhaustiveFinitePlace hf hpartialFirst hpartialSecond z + let B := RatFuncFiniteIntegralClosure K E + let : Algebra K B := + RingHom.toAlgebra + ((algebraMap (Polynomial K) B).comp (algebraMap K (Polynomial K))) + let : IsScalarTower K (Polynomial K) B := + IsScalarTower.of_algebraMap_eq' rfl + let : IsScalarTower K (RatFunc K) E := + IsScalarTower.of_algebraMap_eq' (by + ext c + have h := congrArg + (fun g : Polynomial K →+* E => g (Polynomial.C c)) + (ratFuncSpecialization_comp_polynomial_algebraMap + (planeCurveFunction f 0) hx) + simpa [E, planeCurveFirstCoordinateRatFuncAlgebra] using h.symm) + let : IsScalarTower K (Polynomial K) E := + IsScalarTower.of_algebraMap_eq' (by + ext c + rw [IsScalarTower.algebraMap_apply K (RatFunc K) E, + IsScalarTower.algebraMap_apply K (Polynomial K) (RatFunc K)] + rfl) + let : IsScalarTower K B E := IsScalarTower.of_algebraMap_eq' (by + ext c + rw [IsScalarTower.algebraMap_apply K (Polynomial K) E] + rfl) + let R := IsDedekindDomain.HeightOneSpectrum.valuationSubringAtPrime E q + let : Algebra K R := + RingHom.toAlgebra ((algebraMap B R).comp (algebraMap K B)) + let : IsScalarTower K B R := IsScalarTower.of_algebraMap_eq' rfl + let eCenter := affinePlaneCurvePoint_residueAlgEquiv K z + let : Finite m.asIdeal.ResidueField := + Finite.of_injective eCenter eCenter.injective + let r0 : A := planeCurveCoordinate f 0 - algebraMap K A z.1.1 + have hr0mem : r0 ∈ m.asIdeal := + firstCoordinate_sub_mem_affinePlaneCurvePointMaximalIdeal z + have hr0mapEq : algebraMap A E r0 = + planeCurveFunction f 0 - algebraMap K E z.1.1 := by + simp only [r0, map_sub] + rfl + have hr0map : algebraMap A E r0 ≠ 0 := by + rw [hr0mapEq] + exact firstCoordinate_sub_affinePoint_ne_zero hf hpartialSecond z + have hr0 : r0 ≠ 0 := by + intro hzero + apply hr0map + rw [hzero, map_zero] + have hm0 : m.asIdeal ≠ ⊥ := by + intro hm + apply hr0 + simpa [hm] using hr0mem + have hsmooth : planeCurvePartialY f ∉ m.asIdeal := by + change planeCurvePointEval f z (planeCurvePartialY f) ≠ 0 + change MvPolynomial.eval ![z.1.1, z.1.2] + (MvPolynomial.pderiv 1 f) ≠ 0 + exact hregular + let : IsDiscreteValuationRing (Localization.AtPrime m.asIdeal) := + planeCurveClosedPoint_localization_isDiscreteValuationRing + K hf m hm0 hsmooth + have hresidue := residue_finrank_eq_of_regular_dominating_valuation K A B E + m q.asIdeal R hm0 + (affinePointExhaustiveFinitePlace_spec hf hpartialFirst hpartialSecond z).1 + (fun c => by + change algebraMap B E (algebraMap K B c) = algebraMap K E c + exact (IsScalarTower.algebraMap_apply K B E c).symm) + rw [finiteExtensionFinitePlace_degree_eq_finrank_residueField K E q, ← hresidue] + simpa using eCenter.toLinearEquiv.finrank_eq + +end +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/PlaneSquareFieldStepanovCount.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/PlaneSquareFieldStepanovCount.lean new file mode 100644 index 0000000000..9928dca4b0 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/PlaneSquareFieldStepanovCount.lean @@ -0,0 +1,278 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneRegularPointCount +public import LeanPool.MarkoffModP.BGS.HasseWeil.SquareFieldResidue +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneFinitePlaceRiemannLower +public import LeanPool.MarkoffModP.BGS.HasseWeil.SquareFieldStepanovAuxiliary +public import LeanPool.MarkoffModP.BGS.HasseWeil.SquareFieldStepanovZeroCount +public import Mathlib.Tactic + +/-! +# A conditional square-field Stepanov bound for plane curves + +Let `S` be the full finite constant field and let `K` supply a half-Frobenius +scale, with `#S = (#K)^2`. For an irreducible plane curve with both +coordinate partials nonzero, exact constants and the standard large-field +condition produce a one-point Stepanov auxiliary at any degree-one selected +place. + +We choose the pole place above one affine point that is regular in the second +coordinate direction. Every other such point gives a distinct finite place +away from the pole. Assuming these selected regular-point places have degree +one, their residue fields satisfy the quadratic half-Frobenius identity, so +the generic square-field zero count applies. Adding back the pole point and +the explicit second-coordinate critical locus gives the affine point bound. + +The degree-one hypothesis is deliberately explicit. It is precisely the +normalization input that must later be discharged by the local smooth-point +theorem; no degree-one assertion is made for arbitrary singular points. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +open BGS.CorvajaZannier +open scoped Polynomial + +noncomputable section + + +variable (K S : Type*) [Field K] [Fintype K] + [Field S] [Fintype S] [DecidableEq S] [Algebra K S] + [DecidableEq (RatFunc S)] + +/-- Conditional affine plane-curve upper bound from the square-field +Stepanov construction. + +The final summand is the actual finite critical locus, rather than its +bidegree upper bound. This keeps the geometric loss visible at the theorem +boundary. -/ +theorem planeCurve_affinePoint_card_le_of_regularPlace_degree_one + {f : MvPolynomial (Fin 2) S} (hf : Irreducible f) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (hcard : Fintype.card S = (Fintype.card K) ^ 2) + (hlarge : + (planeCurveBidegreeGenusBudget f + 1) * + (planeCurveBidegreeGenusBudget f + 2) ≤ Fintype.card K) : + letI := planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + letI := planeCurveFirstCoordinateRatFuncAlgebra f hx + letI := finiteDimensional_planeCurveFunctionField_over_ratFunc + hf hpartialSecond + letI := separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let constantAlg : Algebra S (PlaneCurveFunctionField f) := + RingHom.toAlgebra + ((algebraMap (RatFunc S) (PlaneCurveFunctionField f)).comp + (algebraMap S (RatFunc S))) + letI : Algebra S (PlaneCurveFunctionField f) := constantAlg + letI : SMul S (PlaneCurveFunctionField f) := constantAlg.toSMul + letI : Module S (PlaneCurveFunctionField f) := constantAlg.toModule + letI : IsScalarTower S (RatFunc S) (PlaneCurveFunctionField f) := + IsScalarTower.of_algebraMap_eq' rfl + algebraicClosure S (PlaneCurveFunctionField f) = ⊥ → + (∀ z : AffineSecondCoordinateRegularPoint f, + finiteExtensionPlaceDegree S (PlaneCurveFunctionField f) + (.inl (affinePointExhaustiveFinitePlace + hf hpartialFirst hpartialSecond z.1)) = 1) → + Fintype.card (AffinePlaneCurvePoint f) ≤ + Fintype.card S + + (2 * planeCurveBidegreeGenusBudget f + 1) * Fintype.card K + + (affineSecondCoordinateCriticalPoints S f).card := by + classical + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let E := PlaneCurveFunctionField f + let : Algebra (RatFunc S) E := + planeCurveFirstCoordinateRatFuncAlgebra f hx + let : FiniteDimensional (RatFunc S) E := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : Algebra.IsSeparable (RatFunc S) E := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let constantAlg : Algebra S E := + RingHom.toAlgebra ((algebraMap (RatFunc S) E).comp + (algebraMap S (RatFunc S))) + let : Algebra S E := constantAlg + let : SMul S E := constantAlg.toSMul + let : Module S E := constantAlg.toModule + let : IsScalarTower S (RatFunc S) E := + IsScalarTower.of_algebraMap_eq' rfl + dsimp only + intro hconstants hregularDegree + let g := planeCurveBidegreeGenusBudget f + let s := Fintype.card K + let ell := stepanovEll s + let m := stepanovM g s + have hs : 0 < s := Fintype.card_pos + have hbudget : ell + s * m + 1 = + Fintype.card S + (2 * g + 1) * s := by + calc + ell + s * m + 1 = (s - 1) + s * (s + 2 * g) + 1 := by + rfl + _ = s + s * (s + 2 * g) := by omega + _ = s ^ 2 + (2 * g + 1) * s := by ring + _ = Fintype.card S + (2 * g + 1) * s := by rw [hcard] + by_cases hregularCard : + Fintype.card (AffineSecondCoordinateRegularPoint f) = 0 + · rw [affinePlaneCurvePoint_card_eq_regular_add_critical f, + hregularCard] + omega + · have hregularNonempty : + Nonempty (AffineSecondCoordinateRegularPoint f) := + Fintype.card_pos_iff.mp (Nat.pos_of_ne_zero hregularCard) + let z0 : AffineSecondCoordinateRegularPoint f := + Classical.choice hregularNonempty + let q0 : FiniteExtensionFinitePlace S E := + affinePointExhaustiveFinitePlace + hf hpartialFirst hpartialSecond z0.1 + let P : FiniteExtensionPlace S E := .inl q0 + have hdegreeP : finiteExtensionPlaceDegree S E P = 1 := by + simpa only [P, q0, E] using hregularDegree z0 + have hriemann : ∀ N, + N + 1 ≤ Module.finrank S + (finiteExtensionOnePointRiemannSpace S E P N) + g := by + intro N + have h := planeCurve_finitePlace_riemann_lower + (K := S) hf hpartialFirst hpartialSecond q0 N + simpa only [E, P, g, hdegreeP, Nat.mul_one] using h + obtain ⟨u, du, v, dv, c, hu, hv, _hc, hsecond, hfirst⟩ := + exists_squareField_onePointStepanovAuxiliary_of_degree_one + K S E P g hconstants hdegreeP hriemann hlarge + let point : + {z : AffineSecondCoordinateRegularPoint f // z ≠ z0} → + AffinePlaneCurvePoint f := fun z => z.1.1 + let place : + {z : AffineSecondCoordinateRegularPoint f // z ≠ z0} → + FiniteExtensionFinitePlace S E := fun z => + affinePointExhaustiveFinitePlace + hf hpartialFirst hpartialSecond (point z) + have hpointInjective : Function.Injective point := by + intro z w hzw + apply Subtype.ext + apply Subtype.ext + exact hzw + have hplaceInjective : Function.Injective place := by + exact (affinePointExhaustiveFinitePlace_injective + hf hpartialFirst hpartialSecond).comp hpointInjective + have haway : ∀ z, + (Sum.inl (place z) : FiniteExtensionPlace S E) ≠ P := by + intro z heq + apply z.2 + apply Subtype.ext + apply affinePointExhaustiveFinitePlace_injective + hf hpartialFirst hpartialSecond + exact Sum.inl.inj heq + have hplaceDegree : ∀ z, + finiteExtensionPlaceDegree S E (.inl (place z)) = 1 := by + intro z + simpa only [place, point, E] using hregularDegree z.1 + have hsquare : ∀ (z : + {z : AffineSecondCoordinateRegularPoint f // z ≠ z0}) + (a : (place z).asIdeal.ResidueField), + a ^ (Fintype.card K) ^ 2 = a := by + intro z + exact finiteExtensionFinitePlace_residue_squareFrobenius_of_degree_one + K S E hcard (place z) (hplaceDegree z) + have hpunctured : + Fintype.card + {z : AffineSecondCoordinateRegularPoint f // z ≠ z0} ≤ + ell + s * m := by + exact Fintype.card_le_of_squareFieldStepanovAuxiliary + K S E P ell m u du v dv c hu hv hdegreeP place + hplaceInjective haway hsquare hsecond hfirst + have hregular := regularPoint_card_eq_punctured_add_one z0 + rw [affinePlaneCurvePoint_card_eq_regular_add_critical f, + hregular] + calc + Fintype.card + {z : AffineSecondCoordinateRegularPoint f // z ≠ z0} + + 1 + (affineSecondCoordinateCriticalPoints S f).card ≤ + (ell + s * m) + 1 + + (affineSecondCoordinateCriticalPoints S f).card := by omega + _ = Fintype.card S + (2 * g + 1) * s + + (affineSecondCoordinateCriticalPoints S f).card := by + rw [hbudget] + +/-- Bidegree specialization of +`planeCurve_affinePoint_card_le_of_regularPlace_degree_one`. + +Only the critical-locus summand is replaced by its explicit resultant bound; +the Stepanov error remains `(2 * genusBudget + 1) * #K`. -/ +theorem planeCurve_affinePoint_card_le_bidegree_of_regularPlace_degree_one + {f : MvPolynomial (Fin 2) S} {firstDegree secondDegree : Nat} + (hdegree : BGS.External.HasBidegreeAtMost + f firstDegree secondDegree) + (hf : Irreducible f) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (hcard : Fintype.card S = (Fintype.card K) ^ 2) + (hlarge : + (planeCurveBidegreeGenusBudget f + 1) * + (planeCurveBidegreeGenusBudget f + 2) ≤ Fintype.card K) : + letI := planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + letI := planeCurveFirstCoordinateRatFuncAlgebra f hx + letI := finiteDimensional_planeCurveFunctionField_over_ratFunc + hf hpartialSecond + letI := separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let constantAlg : Algebra S (PlaneCurveFunctionField f) := + RingHom.toAlgebra + ((algebraMap (RatFunc S) (PlaneCurveFunctionField f)).comp + (algebraMap S (RatFunc S))) + letI : Algebra S (PlaneCurveFunctionField f) := constantAlg + letI : SMul S (PlaneCurveFunctionField f) := constantAlg.toSMul + letI : Module S (PlaneCurveFunctionField f) := constantAlg.toModule + letI : IsScalarTower S (RatFunc S) (PlaneCurveFunctionField f) := + IsScalarTower.of_algebraMap_eq' rfl + algebraicClosure S (PlaneCurveFunctionField f) = ⊥ → + (∀ z : AffineSecondCoordinateRegularPoint f, + finiteExtensionPlaceDegree S (PlaneCurveFunctionField f) + (.inl (affinePointExhaustiveFinitePlace + hf hpartialFirst hpartialSecond z.1)) = 1) → + Fintype.card (AffinePlaneCurvePoint f) ≤ + Fintype.card S + + (2 * planeCurveBidegreeGenusBudget f + 1) * Fintype.card K + + ((2 * secondDegree - 1) * firstDegree) * secondDegree := by + classical + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let E := PlaneCurveFunctionField f + let : Algebra (RatFunc S) E := + planeCurveFirstCoordinateRatFuncAlgebra f hx + let : FiniteDimensional (RatFunc S) E := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : Algebra.IsSeparable (RatFunc S) E := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let constantAlg : Algebra S E := + RingHom.toAlgebra ((algebraMap (RatFunc S) E).comp + (algebraMap S (RatFunc S))) + let : Algebra S E := constantAlg + let : SMul S E := constantAlg.toSMul + let : Module S E := constantAlg.toModule + let : IsScalarTower S (RatFunc S) E := + IsScalarTower.of_algebraMap_eq' rfl + dsimp only + intro hconstants hregularDegree + have hcount := planeCurve_affinePoint_card_le_of_regularPlace_degree_one + K S hf hpartialFirst hpartialSecond hcard hlarge + hconstants hregularDegree + have hcritical := affineSecondCoordinateCriticalPoints_card_le + hdegree hf hpartialSecond + omega + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/PlaneSquareFieldStepanovCountAutomatic.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/PlaneSquareFieldStepanovCountAutomatic.lean new file mode 100644 index 0000000000..f4f4709e19 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/PlaneSquareFieldStepanovCountAutomatic.lean @@ -0,0 +1,165 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneSmoothPointNormalization +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneSquareFieldStepanovCount +public import Mathlib.Tactic + +/-! +# The square-field Stepanov bound on the smooth affine chart + +The smooth-point normalization theorem proves that the selected finite place +above every affine point where the second partial is nonzero has degree one. +This module uses that fact to discharge the sole normalization hypothesis of +the conditional plane square-field Stepanov count. + +Exact constants and the large-field inequality remain explicit mathematical +hypotheses. The resulting error term is honestly `(2 * genusBudget + 1) * +#K`, together with the second-coordinate critical locus; no sharp Hasse--Weil +constant is claimed here. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +open BGS.CorvajaZannier +open scoped Polynomial + +noncomputable section + + +variable (K S : Type*) [Field K] [Fintype K] + [Field S] [Fintype S] [DecidableEq S] [Algebra K S] + [DecidableEq (RatFunc S)] + +/-- Square-field Stepanov bound with the regular-point degree-one condition +discharged by smooth normalization. -/ +theorem planeCurve_affinePoint_card_le_squareField + {f : MvPolynomial (Fin 2) S} (hf : Irreducible f) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (hcard : Fintype.card S = (Fintype.card K) ^ 2) + (hlarge : + (planeCurveBidegreeGenusBudget f + 1) * + (planeCurveBidegreeGenusBudget f + 2) ≤ Fintype.card K) : + letI := planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + letI := planeCurveFirstCoordinateRatFuncAlgebra f hx + letI := finiteDimensional_planeCurveFunctionField_over_ratFunc + hf hpartialSecond + letI := separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let constantAlg : Algebra S (PlaneCurveFunctionField f) := + RingHom.toAlgebra + ((algebraMap (RatFunc S) (PlaneCurveFunctionField f)).comp + (algebraMap S (RatFunc S))) + letI : Algebra S (PlaneCurveFunctionField f) := constantAlg + letI : SMul S (PlaneCurveFunctionField f) := constantAlg.toSMul + letI : Module S (PlaneCurveFunctionField f) := constantAlg.toModule + letI : IsScalarTower S (RatFunc S) (PlaneCurveFunctionField f) := + IsScalarTower.of_algebraMap_eq' rfl + algebraicClosure S (PlaneCurveFunctionField f) = ⊥ → + Fintype.card (AffinePlaneCurvePoint f) ≤ + Fintype.card S + + (2 * planeCurveBidegreeGenusBudget f + 1) * Fintype.card K + + (affineSecondCoordinateCriticalPoints S f).card := by + classical + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let E := PlaneCurveFunctionField f + let : Algebra (RatFunc S) E := + planeCurveFirstCoordinateRatFuncAlgebra f hx + let : FiniteDimensional (RatFunc S) E := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : Algebra.IsSeparable (RatFunc S) E := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let constantAlg : Algebra S E := + RingHom.toAlgebra ((algebraMap (RatFunc S) E).comp + (algebraMap S (RatFunc S))) + let : Algebra S E := constantAlg + let : SMul S E := constantAlg.toSMul + let : Module S E := constantAlg.toModule + let : IsScalarTower S (RatFunc S) E := + IsScalarTower.of_algebraMap_eq' rfl + dsimp only + intro hconstants + apply planeCurve_affinePoint_card_le_of_regularPlace_degree_one + K S hf hpartialFirst hpartialSecond hcard hlarge hconstants + intro z + exact affinePointExhaustiveFinitePlace_degree_eq_one_of_partialY + (K := S) hf hpartialFirst hpartialSecond z.1 z.2 + +/-- Explicit bidegree version of `planeCurve_affinePoint_card_le_squareField`. +The resultant estimate replaces the critical-locus cardinal by +`((2 * secondDegree - 1) * firstDegree) * secondDegree`. -/ +theorem planeCurve_affinePoint_card_le_squareField_bidegree + {f : MvPolynomial (Fin 2) S} {firstDegree secondDegree : Nat} + (hdegree : BGS.External.HasBidegreeAtMost + f firstDegree secondDegree) + (hf : Irreducible f) + (hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (hcard : Fintype.card S = (Fintype.card K) ^ 2) + (hlarge : + (planeCurveBidegreeGenusBudget f + 1) * + (planeCurveBidegreeGenusBudget f + 2) ≤ Fintype.card K) : + letI := planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + letI := planeCurveFirstCoordinateRatFuncAlgebra f hx + letI := finiteDimensional_planeCurveFunctionField_over_ratFunc + hf hpartialSecond + letI := separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let constantAlg : Algebra S (PlaneCurveFunctionField f) := + RingHom.toAlgebra + ((algebraMap (RatFunc S) (PlaneCurveFunctionField f)).comp + (algebraMap S (RatFunc S))) + letI : Algebra S (PlaneCurveFunctionField f) := constantAlg + letI : SMul S (PlaneCurveFunctionField f) := constantAlg.toSMul + letI : Module S (PlaneCurveFunctionField f) := constantAlg.toModule + letI : IsScalarTower S (RatFunc S) (PlaneCurveFunctionField f) := + IsScalarTower.of_algebraMap_eq' rfl + algebraicClosure S (PlaneCurveFunctionField f) = ⊥ → + Fintype.card (AffinePlaneCurvePoint f) ≤ + Fintype.card S + + (2 * planeCurveBidegreeGenusBudget f + 1) * Fintype.card K + + ((2 * secondDegree - 1) * firstDegree) * secondDegree := by + classical + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let E := PlaneCurveFunctionField f + let : Algebra (RatFunc S) E := + planeCurveFirstCoordinateRatFuncAlgebra f hx + let : FiniteDimensional (RatFunc S) E := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : Algebra.IsSeparable (RatFunc S) E := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let constantAlg : Algebra S E := + RingHom.toAlgebra ((algebraMap (RatFunc S) E).comp + (algebraMap S (RatFunc S))) + let : Algebra S E := constantAlg + let : SMul S E := constantAlg.toSMul + let : Module S E := constantAlg.toModule + let : IsScalarTower S (RatFunc S) E := + IsScalarTower.of_algebraMap_eq' rfl + dsimp only + intro hconstants + apply planeCurve_affinePoint_card_le_bidegree_of_regularPlace_degree_one + K S hdegree hf hpartialFirst hpartialSecond hcard hlarge hconstants + intro z + exact affinePointExhaustiveFinitePlace_degree_eq_one_of_partialY + (K := S) hf hpartialFirst hpartialSecond z.1 z.2 + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/PlaneStepanovAuxiliary.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/PlaneStepanovAuxiliary.lean new file mode 100644 index 0000000000..6c9c1799c9 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/PlaneStepanovAuxiliary.lean @@ -0,0 +1,353 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneOnePointRiemannLower +public import LeanPool.MarkoffModP.BGS.HasseWeil.OnePointSectionSelection +public import LeanPool.MarkoffModP.BGS.HasseWeil.StepanovRestrictionMaps +public import LeanPool.MarkoffModP.BGS.HasseWeil.StepanovParameters + +/-! +# The degree-one plane Stepanov auxiliary + +This file assembles the one-point ingredients of the Bombieri--Stepanov +construction for an absolutely irreducible bivariate plane curve. + +The plane monomial theorem initially gives the coarse Riemann lower bound +only along an explicit arithmetic progression of pole levels. Since the +progression has positive step, every level lies below a later progression +level. The one-place increment estimate therefore transports the lower +bound back to every level. Exact constants then force enough strict levels +to select the two section families prescribed by `stepanovEll` and +`stepanovM`. + +At a degree-one selected place, the target Riemann space has dimension at +most its pole budget plus one. The existing numerical parameter inequality +then gives a nonzero coefficient grid killed by the second Frobenius +restriction and detected by the first. + +The degree-one hypothesis is deliberately an implication in the final +theorem. This module does **not** assert that the controlled infinity place +has degree one, and it does not count square-extension points. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +open BGS.CorvajaZannier +open scoped Polynomial + +noncomputable section + + +variable (K : Type*) [Field K] [Fintype K] [DecidableEq K] + [DecidableEq (RatFunc K)] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +local instance planeStepanovConstantAlgebra : Algebra K L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K (RatFunc K))) + +local instance planeStepanovConstantTower : + IsScalarTower K (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + +/-- The data furnished by strict-level section selection at pole budget +`N`: nonzero sections with distinct exact pole orders, bounded digits, and +linear independence. -/ +def onePointSectionFamilySpec + {α : Type*} (P : FiniteExtensionPlace K L) (N : ℕ) + (f : α → L) (d : α → ℕ) : Prop := + (∀ i, f i ∈ finiteExtensionOnePointRiemannSpace K L P N) ∧ + (∀ i, f i ≠ 0) ∧ + (∀ i, finiteExtensionPrincipalDivisor K L (f i) P = -(d i : ℤ)) ∧ + Function.Injective d ∧ + (∀ i, d i ≤ N) ∧ + LinearIndependent K f + +/-- A coefficient grid is a Stepanov auxiliary when it is nonzero, is killed +by the swapped restriction, and gives a nonzero function under the first +restriction. -/ +def onePointStepanovAuxiliarySpec + {α β : Type*} (f : α → L) (g : β → L) (s : ℕ) + (c : α × β →₀ K) : Prop := + c ≠ 0 ∧ + onePointStepanovSecondRestrictionMap K L f g s c = 0 ∧ + onePointStepanovFirstRestrictionMap K L f g s c ≠ 0 + +private theorem finiteExtensionOnePointRiemannSpace_finrank_le_add_gap + (P : FiniteExtensionPlace K L) {N M : ℕ} (hNM : N ≤ M) : + Module.finrank K (finiteExtensionOnePointRiemannSpace K L P M) ≤ + Module.finrank K (finiteExtensionOnePointRiemannSpace K L P N) + + (M - N) * finiteExtensionPlaceDegree K L P := by + let D : FiniteExtensionDivisor K L := Finsupp.single P (N : ℤ) + have hD : ∀ v, 0 ≤ D v := by + intro v + by_cases hv : v = P + · subst v + simp [D] + · simp [D, Finsupp.single_eq_of_ne hv] + let : Module.Finite K (finiteExtensionRiemannSpace K L D) := + finiteExtensionRiemannSpace_effective_moduleFinite K L D hD + have hinc := finiteExtensionRiemannSpace_natPlace_increment + K L D hD P (M - N) + have hdivisor : D + Finsupp.single P ((M - N : ℕ) : ℤ) = + Finsupp.single P (M : ℤ) := by + ext v + by_cases hv : v = P + · subst v + simp only [D, Finsupp.add_apply, Finsupp.single_eq_same] + omega + · simp [D, Finsupp.single_eq_of_ne hv] + rw [hdivisor] at hinc + exact hinc.2 + +private theorem finiteExtensionOnePointRiemannSpace_finrank_upper_degree_one + (P : FiniteExtensionPlace K L) + (hconstants : algebraicClosure K L = ⊥) + (hdegree : finiteExtensionPlaceDegree K L P = 1) : + ∀ N, Module.finrank K + (finiteExtensionOnePointRiemannSpace K L P N) ≤ N + 1 := by + intro N + induction N with + | zero => + simpa using + (finiteExtensionOnePointRiemannSpace_zero_finrank K L P hconstants).le + | succ N ih => + have hstep := finiteExtensionOnePointRiemannSpace_finrank_succ_le + K L P N + rw [hdegree] at hstep + omega + +/-- **Conditional degree-one Stepanov auxiliary for a plane curve.** + +For an absolutely irreducible bivariate plane equation with both coordinate +partials nonzero, this theorem chooses the controlled infinity place from +the plane monomial argument and retains its positive pole coefficient and +degree bound. If that selected place has degree one, then for + +`g = (degreeOf 0 F - 1) * (degreeOf 1 F - 1)`, +`s = #K`, `ell = s - 1`, and `m = s + 2g`, + +it produces two strict-level section families and a nonzero coefficient grid +whose second Stepanov restriction vanishes while its first restriction is a +nonzero function. + +The implication on the degree-one equality is essential: no existence of a +degree-one place is claimed here. -/ +theorem exists_planeCurve_onePointStepanovAuxiliary_of_degree_one + {F : MvPolynomial (Fin 2) K} + (habsolute : Irreducible + (MvPolynomial.map (algebraMap K (AlgebraicClosure K)) F)) + (hpartialFirst : MvPolynomial.pderiv 0 F ≠ 0) + (hpartialSecond : MvPolynomial.pderiv 1 F ≠ 0) + (hlarge : + let genusBudget := planeCurveBidegreeGenusBudget F + (genusBudget + 1) * (genusBudget + 2) ≤ Fintype.card K) : + let hF : Irreducible F := + irreducible_of_irreducible_map_algebraicClosure habsolute + letI := planeCurveCoordinateRing_isDomain hF + let hx := firstCoordinate_transcendental hF + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + letI := planeCurveFirstCoordinateRatFuncAlgebra F hx + letI := finiteDimensional_planeCurveFunctionField_over_ratFunc + hF hpartialSecond + letI := separable_planeCurveFunctionField_over_ratFunc hF hpartialSecond + ∃ P : FiniteExtensionInfinityPlace K (PlaneCurveFunctionField F), + let Q : FiniteExtensionPlace K (PlaneCurveFunctionField F) := .inr P + let genusBudget := planeCurveBidegreeGenusBudget F + let s := Fintype.card K + let ell := stepanovEll s + let m := stepanovM genusBudget s + 0 < finiteExtensionPoleDivisor K (PlaneCurveFunctionField F) + (planeCurveFunction F 0) Q ∧ + 0 < finiteExtensionPlaceDegree K (PlaneCurveFunctionField F) Q ∧ + finiteExtensionPlaceDegree K (PlaneCurveFunctionField F) Q ≤ + MvPolynomial.degreeOf 1 F ∧ + (finiteExtensionPlaceDegree K (PlaneCurveFunctionField F) Q = 1 → + ∃ (u : Option (Fin (ell - genusBudget)) → + PlaneCurveFunctionField F) + (du : Option (Fin (ell - genusBudget)) → ℕ) + (v : Option (Fin (m - genusBudget)) → + PlaneCurveFunctionField F) + (dv : Option (Fin (m - genusBudget)) → ℕ) + (c : (Option (Fin (ell - genusBudget)) × + Option (Fin (m - genusBudget))) →₀ K), + onePointSectionFamilySpec K (PlaneCurveFunctionField F) + Q ell u du ∧ + onePointSectionFamilySpec K (PlaneCurveFunctionField F) + Q m v dv ∧ + onePointStepanovAuxiliarySpec K (PlaneCurveFunctionField F) + u v s c) := by + let hF : Irreducible F := + irreducible_of_irreducible_map_algebraicClosure habsolute + let : IsDomain (PlaneCurveCoordinateRing F) := + planeCurveCoordinateRing_isDomain hF + let hx := firstCoordinate_transcendental hF + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let L := PlaneCurveFunctionField F + let x : L := planeCurveFunction F 0 + let y : L := planeCurveFunction F 1 + let b := MvPolynomial.degreeOf 1 F + let genusBudget := planeCurveBidegreeGenusBudget F + let s := Fintype.card K + let ell := stepanovEll s + let m := stepanovM genusBudget s + let canonicalAlg : Algebra K L := inferInstance + let : Algebra K L := canonicalAlg + let ratAlg : Algebra (RatFunc K) L := + planeCurveFirstCoordinateRatFuncAlgebra F hx + let : Algebra (RatFunc K) L := ratAlg + let : SMul (RatFunc K) L := ratAlg.toSMul + let : Module (RatFunc K) L := ratAlg.toModule + let : FiniteDimensional (RatFunc K) L := + finiteDimensional_planeCurveFunctionField_over_ratFunc hF hpartialSecond + let : Algebra.IsSeparable (RatFunc K) L := + separable_planeCurveFunctionField_over_ratFunc hF hpartialSecond + let inducedAlg : Algebra K L := planeStepanovConstantAlgebra K L + have hinducedAlg : inducedAlg = canonicalAlg := by + apply Algebra.algebra_ext + intro c + change (@ratFuncSpecialization K L _ _ canonicalAlg x hx) (RatFunc.C c) = + @algebraMap K L _ _ canonicalAlg c + have h := DFunLike.congr_fun + (@ratFuncSpecialization_comp_polynomial_algebraMap + K L _ _ canonicalAlg x hx) + (Polynomial.C c) + simpa using h + let : Algebra K L := inducedAlg + let : SMul K L := inducedAlg.toSMul + let : Module K L := inducedAlg.toModule + let : IsScalarTower K (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + have hconstantsCanonical : + @algebraicClosure K L _ _ canonicalAlg = ⊥ := by + simpa only [L] using + planeCurveFunctionField_algebraicClosure_eq_bot + F habsolute hpartialSecond + have hconstants : algebraicClosure K L = ⊥ := by + change @algebraicClosure K L _ _ inducedAlg = ⊥ + rw [hinducedAlg] + exact hconstantsCanonical + obtain ⟨P, hPpole, hPdegreePositive, hPdegreeBound, hprogress⟩ := + exists_planeCurve_onePointRiemannSpace_progression_lower_bound + habsolute hpartialFirst hpartialSecond + let Q : FiniteExtensionPlace K L := .inr P + refine ⟨P, hPpole, hPdegreePositive, hPdegreeBound, ?_⟩ + intro hPdegree + have hcoarse : ∀ N, + N * finiteExtensionPlaceDegree K L Q + 1 ≤ + Module.finrank K (finiteExtensionOnePointRiemannSpace K L Q N) + + genusBudget := by + intro N + let M := planeMonomialPoleLevel K L x y N b Q + obtain ⟨hMformula, _hMfinite, hMlowerRaw⟩ := hprogress N + have hMformula' : M = + N * (finiteExtensionPoleDivisor K L x Q).toNat + + (b - 1) * (finiteExtensionPoleDivisor K L y Q).toNat := by + simpa only [M, L, x, y, b, Q] using hMformula + have hPoleNat : 0 < (finiteExtensionPoleDivisor K L x Q).toNat := by + have hPole : 0 < finiteExtensionPoleDivisor K L x Q := by + simpa only [L, x, Q] using hPpole + omega + have hNM : N ≤ M := by + rw [hMformula'] + have hbase : N ≤ + N * (finiteExtensionPoleDivisor K L x Q).toNat := + Nat.le_mul_of_pos_right N hPoleNat + omega + have hgap := finiteExtensionOnePointRiemannSpace_finrank_le_add_gap + K L Q hNM + have hMlower : M * finiteExtensionPlaceDegree K L Q + 1 ≤ + Module.finrank K (finiteExtensionOnePointRiemannSpace K L Q M) + + genusBudget := by + simpa only [M, L, x, y, b, Q, genusBudget] using hMlowerRaw + have hMdecomp : M = N + (M - N) := by omega + have hmul : M * finiteExtensionPlaceDegree K L Q = + N * finiteExtensionPlaceDegree K L Q + + (M - N) * finiteExtensionPlaceDegree K L Q := by + calc + M * finiteExtensionPlaceDegree K L Q = + (N + (M - N)) * finiteExtensionPlaceDegree K L Q := by + rw [← hMdecomp] + _ = N * finiteExtensionPlaceDegree K L Q + + (M - N) * finiteExtensionPlaceDegree K L Q := by + rw [Nat.add_mul] + omega + have hstrict : ∀ N, genusBudget ≤ N → + N - genusBudget ≤ + (strictFiltrationLevels + (fun r => finiteExtensionOnePointRiemannSpace K L Q r) N).card := by + intro N hgenusN + apply le_card_onePointStrictLevels_of_finrank_lower + K L Q N (N - genusBudget) hconstants + have hN := hcoarse N + rw [hPdegree] at hN ⊢ + omega + have hlarge' : (genusBudget + 1) * (genusBudget + 2) ≤ s := by + simpa only [genusBudget, s] using hlarge + have hsPositive : 0 < s := Fintype.card_pos + have hgenusLtS : genusBudget < s := by + nlinarith + have hgenusEll : genusBudget ≤ ell := by + simp only [ell, stepanovEll] + omega + have hgenusM : genusBudget ≤ m := by + simp only [m, stepanovM] + omega + have hellLt : ell < s := stepanovEll_lt hlarge' + have hellStrict := hstrict ell hgenusEll + have hmStrict := hstrict m hgenusM + obtain ⟨u, du, huMem, huNe, huOrder, hduInjective, + hduLe, huLI⟩ := + exists_onePointSectionsWithConstant_of_le_card_strictLevels + K L Q ell (ell - genusBudget) hellStrict + obtain ⟨v, dv, hvMem, hvNe, hvOrder, hdvInjective, + hdvLe, hvLI⟩ := + exists_onePointSectionsWithConstant_of_le_card_strictLevels + K L Q m (m - genusBudget) hmStrict + have hgridLI : LinearIndependent K + (fun ij : Option (Fin (ell - genusBudget)) × + Option (Fin (m - genusBudget)) => u ij.1 * (v ij.2) ^ s) := by + exact onePointStepanovGrid_linearIndependent K L Q u v du dv s + huNe hvNe huOrder hvOrder hduInjective hdvInjective + (fun i => (hduLe i).trans_lt hellLt) + have hupper : Module.finrank K + (finiteExtensionOnePointRiemannSpace K L Q (s * ell + m)) ≤ + s * ell + m + 1 := + finiteExtensionOnePointRiemannSpace_finrank_upper_degree_one + K L Q hconstants hPdegree (s * ell + m) + have hellCard : ell - genusBudget + 1 = ell + 1 - genusBudget := by + omega + have hmCard : m - genusBudget + 1 = m + 1 - genusBudget := by + omega + have hnumeric : s * ell + m + 1 < + Fintype.card (Option (Fin (ell - genusBudget))) * + Fintype.card (Option (Fin (m - genusBudget))) := by + have hdim := stepanov_dimension_inequality hlarge' + simpa only [Fintype.card_option, Fintype.card_fin, hellCard, hmCard, + Nat.mul_comm s ell] using hdim + obtain ⟨c, hcNe, hsecond, hfirst⟩ := + exists_onePointStepanovAuxiliary_of_target_finrank_upper + K L Q u v ell m s (s * ell + m + 1) + huMem hvMem hgridLI hupper hnumeric + have hsecondRaw : + onePointStepanovSecondRestrictionMap K L u v s c = 0 := by + have h := congrArg Subtype.val hsecond + simpa only [onePointStepanovSecondCodRestrictionMap_coe, + Submodule.coe_zero] using h + refine ⟨u, du, v, dv, c, ?_, ?_, ?_⟩ + · exact ⟨huMem, huNe, huOrder, hduInjective, hduLe, huLI⟩ + · exact ⟨hvMem, hvNe, hvOrder, hdvInjective, hdvLe, hvLI⟩ + · exact ⟨hcNe, hsecondRaw, hfirst⟩ + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/PoleDivisor.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/PoleDivisor.lean new file mode 100644 index 0000000000..85f8c85181 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/PoleDivisor.lean @@ -0,0 +1,163 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionRiemannSpace + +/-! +# Pole divisors in the exhaustive finite-extension place model + +The existing Corvaja--Zannier infrastructure records principal divisors and +their total pole height. The Stepanov argument also needs the actual +effective pole divisor. This file defines it by retaining the negative +coefficients of the principal divisor and changing their signs, proves that +it makes the original function a section, and identifies its divisor degree +with the existing height. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +open BGS.CorvajaZannier +open scoped nonZeroDivisors Polynomial + +noncomputable section + +variable (K : Type*) [Field K] [Fintype K] [DecidableEq K] + [DecidableEq (RatFunc K)] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +local instance poleDivisorConstantAlgebra : Algebra K L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K (RatFunc K))) + +local instance poleDivisorConstantTower : + IsScalarTower K (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + +/-- The effective negative part of the principal divisor of `x`. -/ +def finiteExtensionPoleDivisor (x : L) : FiniteExtensionDivisor K L := + by + classical + let D := finiteExtensionPrincipalDivisor K L x + exact -(D.filter (fun v => D v < 0)) + +omit [Fintype K] [DecidableEq K] in +@[simp] +theorem finiteExtensionPoleDivisor_apply (x : L) + (v : FiniteExtensionPlace K L) : + finiteExtensionPoleDivisor K L x v = + if finiteExtensionPrincipalDivisor K L x v < 0 then + -finiteExtensionPrincipalDivisor K L x v else 0 := by + simp only [finiteExtensionPoleDivisor, Finsupp.neg_apply, + Finsupp.filter_apply] + split <;> simp_all + +omit [Fintype K] [DecidableEq K] in +/-- A pole divisor is effective. -/ +theorem finiteExtensionPoleDivisor_effective (x : L) : + ∀ v, 0 ≤ finiteExtensionPoleDivisor K L x v := by + intro v + rw [finiteExtensionPoleDivisor_apply] + split <;> omega + +omit [Fintype K] [DecidableEq K] in +/-- Adding the pole divisor to the principal divisor is effective. -/ +theorem finiteExtensionPrincipal_add_poleDivisor_effective (x : L) : + ∀ v, 0 ≤ finiteExtensionPrincipalDivisor K L x v + + finiteExtensionPoleDivisor K L x v := by + intro v + rw [finiteExtensionPoleDivisor_apply] + split <;> omega + +/-- Every nonzero function is a section of its pole divisor. -/ +theorem mem_finiteExtensionRiemannSpace_poleDivisor + (x : L) (hx : x ≠ 0) : + x ∈ finiteExtensionRiemannSpace K L + (finiteExtensionPoleDivisor K L x) := by + rw [mem_finiteExtensionRiemannSpace] + exact Or.inr ⟨hx, + finiteExtensionPrincipal_add_poleDivisor_effective K L x⟩ + +omit [Fintype K] in +/-- The degree of the pole divisor is the previously defined pole height. -/ +theorem finiteExtensionDivisorDegree_poleDivisor + (x : L) : + finiteExtensionDivisorDegree K L + (finiteExtensionPoleDivisor K L x) = + (finiteExtensionHeight K L x : ℤ) := by + classical + let D := finiteExtensionPrincipalDivisor K L x + have hnegative := finiteExtensionHeight_negativeSum K L x + change -((finiteExtensionHeight K L x : ℕ) : ℤ) = + ∑ v ∈ D.support.filter (fun v => D v < 0), + D v * (finiteExtensionPlaceDegree K L v : ℤ) at hnegative + rw [finiteExtensionDivisorDegree, Finsupp.sum, + finiteExtensionPoleDivisor] + simp only [Finsupp.support_neg, Finsupp.support_filter, + Finsupp.neg_apply, Finsupp.filter_apply] + calc + ∑ a ∈ D.support.filter (fun v => D v < 0), + -(if D a < 0 then D a else 0) * + (finiteExtensionPlaceDegree K L a : ℤ) = + -∑ a ∈ D.support.filter (fun v => D v < 0), + D a * (finiteExtensionPlaceDegree K L a : ℤ) := by + rw [← Finset.sum_neg_distrib] + apply Finset.sum_congr rfl + intro a ha + rw [ite_eq_left (Finset.mem_filter.mp ha).2] + ring + _ = (finiteExtensionHeight K L x : ℤ) := by omega + +omit [Fintype K] [FiniteDimensional (RatFunc K) L] [Algebra.IsSeparable (RatFunc K) L] in +/-- Divisor degree commutes with natural scaling. -/ +theorem finiteExtensionDivisorDegree_nsmul + (n : ℕ) (D : FiniteExtensionDivisor K L) : + finiteExtensionDivisorDegree K L (n • D) = + (n : ℤ) * finiteExtensionDivisorDegree K L D := by + induction n with + | zero => simp [finiteExtensionDivisorDegree] + | succ n ih => + rw [succ_nsmul, finiteExtensionDivisorDegree_add, ih] + push_cast + ring + +/-- A coordinate monomial is a section of the sum of the correspondingly +scaled pole divisors. -/ +theorem pow_mul_pow_mem_poleDivisor_budget + (x y : L) (hx : x ≠ 0) (hy : y ≠ 0) (i j : ℕ) : + x ^ i * y ^ j ∈ finiteExtensionRiemannSpace K L + (i • finiteExtensionPoleDivisor K L x + + j • finiteExtensionPoleDivisor K L y) := by + exact finiteExtensionRiemannSpace_mul_mem K L + (finiteExtensionRiemannSpace_pow_mem K L + (mem_finiteExtensionRiemannSpace_poleDivisor K L x hx) i) + (finiteExtensionRiemannSpace_pow_mem K L + (mem_finiteExtensionRiemannSpace_poleDivisor K L y hy) j) + +omit [Fintype K] in +/-- The degree of the monomial pole budget is the corresponding linear +combination of the two coordinate heights. -/ +theorem finiteExtensionDivisorDegree_pow_mul_pow_budget + (x y : L) (i j : ℕ) : + finiteExtensionDivisorDegree K L + (i • finiteExtensionPoleDivisor K L x + + j • finiteExtensionPoleDivisor K L y) = + (i : ℤ) * finiteExtensionHeight K L x + + (j : ℤ) * finiteExtensionHeight K L y := by + rw [finiteExtensionDivisorDegree_add, + finiteExtensionDivisorDegree_nsmul, + finiteExtensionDivisorDegree_nsmul, + finiteExtensionDivisorDegree_poleDivisor, + finiteExtensionDivisorDegree_poleDivisor] + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/PolynomialSpectral.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/PolynomialSpectral.lean new file mode 100644 index 0000000000..ec97e8defd --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/PolynomialSpectral.lean @@ -0,0 +1,168 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.ZetaExtensionTrace +public import Mathlib.Analysis.Complex.Polynomial.Basic + +/-! +# Spectral parameters from a zeta numerator + +This file records the elementary factorization needed after rationality of a +curve zeta function has produced a numerator polynomial. A complex +polynomial whose constant coefficient is one is uniquely the product of the +factors `1 - alpha * X`, where the parameters `alpha` are the inverses of its +roots, counted with multiplicity. + +The substantive arithmetic input remains the construction of the zeta +numerator and its logarithmic-derivative point-count identity. No spectral +norm estimate is used here. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +open Polynomial +open scoped BigOperators Polynomial + +noncomputable section + +/-- The reciprocal root parameter attached to the `i`-th root of `P`, with +roots enumerated by the canonical sorted list underlying their multiset. -/ +def reciprocalRootParameter (P : Polynomial ℂ) (i : Fin P.natDegree) : ℂ := + ((P.roots.toList.get + (Fin.cast (by simp [IsAlgClosed.card_roots_eq_natDegree]) i))⁻¹) + +/-- Summing powers of the indexed reciprocal-root family agrees with the +multiset power sum, including root multiplicities. -/ +theorem sum_reciprocalRootParameter_pow + (P : Polynomial ℂ) (m : ℕ) : + ∑ i, reciprocalRootParameter P i ^ m = + (P.roots.map fun r => r⁻¹ ^ m).sum := by + unfold reciprocalRootParameter + have hlen : P.natDegree = P.roots.toList.length := + ((Multiset.length_toList P.roots).trans + IsAlgClosed.card_roots_eq_natDegree).symm + let e : Fin P.natDegree ≃ Fin P.roots.toList.length := + Fin.castOrderIso hlen + calc + ∑ i, (P.roots.toList.get (Fin.cast hlen i))⁻¹ ^ m = + ∑ j : Fin P.roots.toList.length, + (P.roots.toList.get j)⁻¹ ^ m := by + apply Fintype.sum_equiv e + intro i + rfl + _ = (P.roots.map fun r => r⁻¹ ^ m).sum := by + simpa [Multiset.sum_coe] using + (Fin.sum_univ_fun_getElem P.roots.toList (fun r => r⁻¹ ^ m)) + +/-- A complex polynomial normalized by `P(0) = 1` factors into reciprocal +linear factors, with one factor for every root counted with multiplicity. -/ +theorem polynomial_eq_prod_one_sub_C_mul_X_of_coeff_zero_eq_one + (P : Polynomial ℂ) (hP0 : P.coeff 0 = 1) : + P = (P.roots.map fun r => 1 - C r⁻¹ * X).prod := by + have hP : P ≠ 0 := by + intro h + rw [h, coeff_zero] at hP0 + norm_num at hP0 + have hsplits : P.Splits := IsAlgClosed.splits P + have hroot0 (r : ℂ) (hr : r ∈ P.roots) : r ≠ 0 := by + intro hr0 + subst r + have hEval : P.eval 0 = 0 := (mem_roots hP).mp hr + rw [← coeff_zero_eq_eval_zero, hP0] at hEval + norm_num at hEval + let R : Polynomial ℂ := (P.roots.map fun r => X - C r).prod + let c : ℂ := (P.roots.map fun r => -r⁻¹).prod + have hfactor (r : ℂ) (hr : r ∈ P.roots) : + 1 - C r⁻¹ * X = C (-r⁻¹) * (X - C r) := by + rw [mul_sub, ← C_mul] + simp [hroot0 r hr] + ring + have hQ : (P.roots.map fun r => 1 - C r⁻¹ * X).prod = C c * R := by + dsimp [R, c] + have hmap : + P.roots.map (fun r => 1 - C r⁻¹ * X) = + P.roots.map (fun r => C (-r⁻¹) * (X - C r)) := by + apply Multiset.map_congr rfl + intro r hr + exact hfactor r hr + rw [hmap, Multiset.prod_map_mul] + have hCprod : + (P.roots.map fun r => C (-r⁻¹)).prod = + C (P.roots.map fun r => -r⁻¹).prod := by + simpa only [Multiset.map_map, Function.comp_apply] using + (map_multiset_prod C (P.roots.map fun r => -r⁻¹)).symm + rw [hCprod] + have hPprod : P = C P.leadingCoeff * R := by + simpa only [R] using hsplits.eq_prod_roots + have hR0eq : R.coeff 0 = (P.roots.map fun r => -r).prod := by + dsimp [R] + simp [coeff_zero_eq_eval_zero, eval_multiset_prod] + have hR0 : R.coeff 0 ≠ 0 := by + rw [hR0eq] + apply Multiset.prod_ne_zero + intro hzero + obtain ⟨z, hz, hneg⟩ := Multiset.mem_map.mp hzero + exact hroot0 z hz (neg_eq_zero.mp hneg) + have hc : c * R.coeff 0 = 1 := by + rw [hR0eq] + dsimp [c] + rw [← Multiset.prod_map_mul] + apply Multiset.prod_eq_one + intro z hz + obtain ⟨r, hr, rfl⟩ := Multiset.mem_map.mp hz + simp [hroot0 r hr] + have hlc : P.leadingCoeff * R.coeff 0 = 1 := by + have hcoeff := congrArg (fun Q : Polynomial ℂ => Q.coeff 0) hPprod + simpa [hP0] using hcoeff.symm + have hscalar : P.leadingCoeff = c := by + apply mul_right_cancel₀ hR0 + rw [hlc, hc] + calc + P = C P.leadingCoeff * R := hPprod + _ = C c * R := by rw [hscalar] + _ = (P.roots.map fun r => 1 - C r⁻¹ * X).prod := hQ.symm + +/-- The reciprocal-root factorization with the parameters indexed by +`Fin P.natDegree`, ready for the finite power sums used in the spectral +point-count formula. -/ +theorem polynomial_eq_prod_reciprocalRootParameter + (P : Polynomial ℂ) (hP0 : P.coeff 0 = 1) : + P = ∏ i, (1 - C (reciprocalRootParameter P i) * X) := by + have hlen : P.natDegree = P.roots.toList.length := + ((Multiset.length_toList P.roots).trans + IsAlgClosed.card_roots_eq_natDegree).symm + let e : Fin P.natDegree ≃ Fin P.roots.toList.length := + Fin.castOrderIso hlen + calc + P = (P.roots.map fun r => 1 - C r⁻¹ * X).prod := + polynomial_eq_prod_one_sub_C_mul_X_of_coeff_zero_eq_one P hP0 + _ = + (P.roots.toList.map fun r => 1 - C r⁻¹ * X).prod := by + let f : ℂ → Polynomial ℂ := fun r => 1 - C r⁻¹ * X + have hs := congrArg (fun s : Multiset ℂ => (s.map f).prod) + (Multiset.coe_toList P.roots) + simpa only [f, Multiset.map_coe, Multiset.prod_coe] using hs.symm + _ = ∏ j : Fin P.roots.toList.length, + (1 - C (P.roots.toList.get j)⁻¹ * X) := by + simpa using + (Fin.prod_univ_fun_getElem P.roots.toList + (fun r => 1 - C r⁻¹ * X)).symm + _ = ∏ i : Fin P.natDegree, + (1 - C (P.roots.toList.get (Fin.cast hlen i))⁻¹ * X) := by + symm + apply Fintype.prod_equiv e + intro i + rfl + _ = ∏ i, (1 - C (reciprocalRootParameter P i) * X) := by + rfl + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/PolynomialTensorCancel.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/PolynomialTensorCancel.lean new file mode 100644 index 0000000000..cfef0de24b --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/PolynomialTensorCancel.lean @@ -0,0 +1,393 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import Mathlib.Algebra.Polynomial.AlgebraMap +public import Mathlib.RingTheory.PolynomialAlgebra +public import Mathlib.RingTheory.TensorProduct.Maps + +/-! +# Cancelling a polynomial ring in a tensor product + +If the `C[X]`-algebra structure on `A` extends its `C`-algebra structure, then +base change from `C[X]` to `S[X]` is canonically the same as base change from +`C` to `S`. This file constructs the resulting explicit `S`-algebra +equivalence + +`S[X] ⊗[C[X]] A ≃ₐ[S] S ⊗[C] A` + +and records its values on pure tensors in both directions. +-/ + +@[expose] public section + +open scoped Polynomial TensorProduct + +namespace BGS.HasseWeil + +noncomputable section + +variable (C S A : Type*) + [CommRing C] [CommRing S] [CommRing A] + [Algebra C S] [Algebra C A] [Algebra C[X] A] + [IsScalarTower C C[X] A] + +private noncomputable def coefficientPolynomialAlgHom : + C[X] →ₐ[C] S[X] := + Polynomial.mapAlgHom (Algebra.ofId C S) + +local instance coefficientPolynomialAlgebra : Algebra C[X] S[X] := + Polynomial.algebra C S + +local instance coefficientPolynomialTower : IsScalarTower C C[X] S[X] := + IsScalarTower.of_algebraMap_eq' (by + apply RingHom.ext + intro c + simp [Polynomial.algebraMap_def]) + + +/-- The image of the polynomial variable in the constant tensor product. -/ +noncomputable def polynomialTensorCancelEvaluationPoint : + TensorProduct C S A := + Algebra.TensorProduct.includeRight (algebraMap C[X] A Polynomial.X) + +/-- Evaluate base polynomials in the constant tensor product. -/ +noncomputable def constantTensorPolynomialAlgHom : + C[X] →ₐ[C] (TensorProduct C S A) := + Polynomial.aeval (polynomialTensorCancelEvaluationPoint C S A) + +/-- The `C[X]`-algebra structure on `S ⊗[C] A` obtained by evaluating `X` +at `1 ⊗ algebraMap C[X] A X`. -/ +@[reducible] +noncomputable def polynomialTensorCancelTargetPolynomialAlgebra : + Algebra C[X] (TensorProduct C S A) := + (constantTensorPolynomialAlgHom C S A).toAlgebra + +local instance constantTensorPolynomialAlgebra : + Algebra C[X] ((TensorProduct C S A)) := + polynomialTensorCancelTargetPolynomialAlgebra C S A + +/-- The `S[X]`-algebra structure on `S ⊗[C] A` obtained by evaluating `X` +at `1 ⊗ algebraMap C[X] A X`. -/ +@[reducible] +noncomputable def polynomialTensorCancelTargetPolynomialExtensionAlgebra : + Algebra S[X] (TensorProduct C S A) := + (Polynomial.aeval + (polynomialTensorCancelEvaluationPoint C S A)).toAlgebra + +local instance constantTensorPolynomialExtensionAlgebra : + Algebra S[X] ((TensorProduct C S A)) := + polynomialTensorCancelTargetPolynomialExtensionAlgebra C S A + +local instance constantTensorPolynomialTower : + IsScalarTower C C[X] ((TensorProduct C S A)) := + IsScalarTower.of_algebraMap_eq' (by + apply RingHom.ext + intro c + change (algebraMap C S c ⊗ₜ[C] (1 : A)) = + constantTensorPolynomialAlgHom C S A (Polynomial.C c) + simp [constantTensorPolynomialAlgHom]) + +private theorem includeRight_algebraMap_polynomial (p : C[X]) : + (Algebra.TensorProduct.includeRight : + A →ₐ[C] (TensorProduct C S A)) (algebraMap C[X] A p) = + constantTensorPolynomialAlgHom C S A p := by + have h : + (Algebra.TensorProduct.includeRight : + A →ₐ[C] (TensorProduct C S A)).comp + (IsScalarTower.toAlgHom C C[X] A) = + constantTensorPolynomialAlgHom C S A := by + ext + simp [constantTensorPolynomialAlgHom, + polynomialTensorCancelEvaluationPoint] + simpa [Polynomial.algebraMap_def, coefficientPolynomialAlgHom] using + DFunLike.congr_fun h p + +/-- Include the algebra factor in the constant tensor product over the polynomial base. -/ +noncomputable def rightFactorToConstantTensor : + A →ₐ[C[X]] (TensorProduct C S A) where + __ := (Algebra.TensorProduct.includeRight : + A →ₐ[C] (TensorProduct C S A)).toRingHom + commutes' := by exact includeRight_algebraMap_polynomial C S A + +/-- Evaluate coefficient polynomials in the constant tensor product. -/ +noncomputable def leftFactorToConstantTensorOverS : + S[X] →ₐ[S] (TensorProduct C S A) := + Polynomial.aeval (polynomialTensorCancelEvaluationPoint C S A) + +omit [IsScalarTower C C[X] A] in +private theorem leftFactorToConstantTensor_compatible (p : C[X]) : + leftFactorToConstantTensorOverS C S A (algebraMap C[X] S[X] p) = + constantTensorPolynomialAlgHom C S A p := by + have h : + ((leftFactorToConstantTensorOverS C S A).restrictScalars C).comp + (coefficientPolynomialAlgHom C S) = + constantTensorPolynomialAlgHom C S A := by + ext + simp [leftFactorToConstantTensorOverS, + constantTensorPolynomialAlgHom, + polynomialTensorCancelEvaluationPoint, coefficientPolynomialAlgHom] + exact DFunLike.congr_fun h p + +/-- Evaluate coefficient polynomials as an algebra map over the polynomial base. -/ +noncomputable def leftFactorToConstantTensor : + S[X] →ₐ[C[X]] (TensorProduct C S A) where + __ := (leftFactorToConstantTensorOverS C S A).toRingHom + commutes' := by exact leftFactorToConstantTensor_compatible C S A + +/-- Cancel polynomial base change as an algebra homomorphism over the base polynomial ring. -/ +noncomputable def polynomialTensorToConstantTensorOverPolynomial : + (TensorProduct C[X] S[X] A) →ₐ[C[X]] (TensorProduct C S A) := + Algebra.TensorProduct.lift + (leftFactorToConstantTensor C S A) + (rightFactorToConstantTensor C S A) + (fun _ _ ↦ Commute.all _ _) + +/-- Cancel polynomial base change as an algebra homomorphism over the coefficient ring. -/ +noncomputable def polynomialTensorToConstantTensor : + (TensorProduct C[X] S[X] A) →ₐ[S] (TensorProduct C S A) where + __ := (polynomialTensorToConstantTensorOverPolynomial C S A).toRingHom + commutes' s := by + change polynomialTensorToConstantTensorOverPolynomial C S A + ((Algebra.TensorProduct.includeLeft : + S[X] →ₐ[S] (TensorProduct C[X] S[X] A)) (Polynomial.C s)) = + algebraMap S ((TensorProduct C S A)) s + simp [polynomialTensorToConstantTensorOverPolynomial, + leftFactorToConstantTensor, leftFactorToConstantTensorOverS] + +/-- Include coefficient scalars in the polynomial tensor product. -/ +noncomputable def constantsToPolynomialTensor : + S →ₐ[S] (TensorProduct C[X] S[X] A) := + (Algebra.TensorProduct.includeLeft : + S[X] →ₐ[S] (TensorProduct C[X] S[X] A)).comp Polynomial.CAlgHom + +/-- Include the algebra factor in the polynomial tensor product over the constant base. -/ +noncomputable def rightFactorToPolynomialTensor : + A →ₐ[C] (TensorProduct C[X] S[X] A) := + (Algebra.TensorProduct.includeRight : + A →ₐ[C[X]] (TensorProduct C[X] S[X] A)).restrictScalars C + +/-- Extend constant tensors to the polynomial tensor product. -/ +noncomputable def constantTensorToPolynomialTensor : + (TensorProduct C S A) →ₐ[S] (TensorProduct C[X] S[X] A) := + Algebra.TensorProduct.lift + (constantsToPolynomialTensor C S A) + (rightFactorToPolynomialTensor C S A) + (fun _ _ ↦ Commute.all _ _) + +private theorem constantTensorToPolynomialTensor_comp_leftFactor : + (constantTensorToPolynomialTensor C S A).comp + (leftFactorToConstantTensorOverS C S A) = + (Algebra.TensorProduct.includeLeft : + S[X] →ₐ[S] (TensorProduct C[X] S[X] A)) := by + ext + simp [constantTensorToPolynomialTensor, + leftFactorToConstantTensorOverS, + polynomialTensorCancelEvaluationPoint, rightFactorToPolynomialTensor] + +private theorem constantTensorToPolynomialTensor_commutes_polynomial + (p : C[X]) : + constantTensorToPolynomialTensor C S A + (algebraMap C[X] ((TensorProduct C S A)) p) = + algebraMap C[X] ((TensorProduct C[X] S[X] A)) p := by + rw [show algebraMap C[X] ((TensorProduct C S A)) p = + leftFactorToConstantTensorOverS C S A + (algebraMap C[X] S[X] p) by + exact (leftFactorToConstantTensor_compatible C S A p).symm] + have hp := AlgHom.congr_fun + (constantTensorToPolynomialTensor_comp_leftFactor C S A) + (algebraMap C[X] S[X] p) + change constantTensorToPolynomialTensor C S A + (leftFactorToConstantTensorOverS C S A + (algebraMap C[X] S[X] p)) = + Algebra.TensorProduct.includeLeft (algebraMap C[X] S[X] p) at hp + rw [hp] + rfl + +/-- Extend constant tensors as an algebra homomorphism over the base polynomial ring. -/ +noncomputable def constantTensorToPolynomialTensorOverPolynomial : + (TensorProduct C S A) →ₐ[C[X]] (TensorProduct C[X] S[X] A) where + __ := (constantTensorToPolynomialTensor C S A).toRingHom + commutes' := by exact constantTensorToPolynomialTensor_commutes_polynomial C S A + +/-- Cancel polynomial tensors over the coefficient polynomial ring. -/ +noncomputable def polynomialTensorToConstantTensorOverCoefficientPolynomial : + (TensorProduct C[X] S[X] A) →ₐ[S[X]] (TensorProduct C S A) where + __ := (polynomialTensorToConstantTensor C S A).toRingHom + commutes' p := by + change polynomialTensorToConstantTensor C S A + ((Algebra.TensorProduct.includeLeft : + S[X] →ₐ[S[X]] (TensorProduct C[X] S[X] A)) p) = + leftFactorToConstantTensorOverS C S A p + simp [polynomialTensorToConstantTensor, + polynomialTensorToConstantTensorOverPolynomial, + leftFactorToConstantTensor] + +/-- Extend constant tensors over the coefficient polynomial ring. -/ +noncomputable def constantTensorToPolynomialTensorOverCoefficientPolynomial : + (TensorProduct C S A) →ₐ[S[X]] (TensorProduct C[X] S[X] A) where + __ := (constantTensorToPolynomialTensor C S A).toRingHom + commutes' p := by + have hp := AlgHom.congr_fun + (constantTensorToPolynomialTensor_comp_leftFactor C S A) p + change constantTensorToPolynomialTensor C S A + (leftFactorToConstantTensorOverS C S A p) = + (Algebra.TensorProduct.includeLeft : + S[X] →ₐ[S[X]] (TensorProduct C[X] S[X] A)) p + exact hp + +private theorem constantTensorToPolynomialTensor_leftInverse : + (constantTensorToPolynomialTensor C S A).comp + (polynomialTensorToConstantTensor C S A) = + AlgHom.id S ((TensorProduct C[X] S[X] A)) := by + apply AlgHom.ext + intro z + induction z using TensorProduct.inductionOn with + | add x y hx hy => simp only [map_add, hx, hy] + | tmul p a => + change constantTensorToPolynomialTensor C S A + (leftFactorToConstantTensorOverS C S A p * + rightFactorToConstantTensor C S A a) = + p ⊗ₜ[C[X]] a + rw [map_mul] + have hp := AlgHom.congr_fun + (constantTensorToPolynomialTensor_comp_leftFactor C S A) p + change constantTensorToPolynomialTensor C S A + (leftFactorToConstantTensorOverS C S A p) = + Algebra.TensorProduct.includeLeft p at hp + rw [hp] + simp [constantTensorToPolynomialTensor, + rightFactorToConstantTensor, rightFactorToPolynomialTensor] + +private theorem constantTensorToPolynomialTensor_rightInverse : + (polynomialTensorToConstantTensor C S A).comp + (constantTensorToPolynomialTensor C S A) = + AlgHom.id S ((TensorProduct C S A)) := by + apply Algebra.TensorProduct.ext + · apply AlgHom.ext + intro s + simpa [constantTensorToPolynomialTensor, constantsToPolynomialTensor] using + (polynomialTensorToConstantTensor C S A).commutes s + · apply AlgHom.ext + intro a + simp [constantTensorToPolynomialTensor, + polynomialTensorToConstantTensor, + polynomialTensorToConstantTensorOverPolynomial, + rightFactorToConstantTensor, rightFactorToPolynomialTensor] + +private theorem constantTensorToPolynomialTensorOverPolynomial_leftInverse : + (constantTensorToPolynomialTensorOverPolynomial C S A).comp + (polynomialTensorToConstantTensorOverPolynomial C S A) = + AlgHom.id C[X] ((TensorProduct C[X] S[X] A)) := by + apply AlgHom.ext + intro z + exact DFunLike.congr_fun + (constantTensorToPolynomialTensor_leftInverse C S A) z + +private theorem constantTensorToPolynomialTensorOverPolynomial_rightInverse : + (polynomialTensorToConstantTensorOverPolynomial C S A).comp + (constantTensorToPolynomialTensorOverPolynomial C S A) = + AlgHom.id C[X] ((TensorProduct C S A)) := by + apply AlgHom.ext + intro z + exact DFunLike.congr_fun + (constantTensorToPolynomialTensor_rightInverse C S A) z + +private theorem + constantTensorToPolynomialTensorOverCoefficientPolynomial_leftInverse : + (constantTensorToPolynomialTensorOverCoefficientPolynomial C S A).comp + (polynomialTensorToConstantTensorOverCoefficientPolynomial C S A) = + AlgHom.id S[X] ((TensorProduct C[X] S[X] A)) := by + apply AlgHom.ext + intro z + exact DFunLike.congr_fun + (constantTensorToPolynomialTensor_leftInverse C S A) z + +private theorem + constantTensorToPolynomialTensorOverCoefficientPolynomial_rightInverse : + (polynomialTensorToConstantTensorOverCoefficientPolynomial C S A).comp + (constantTensorToPolynomialTensorOverCoefficientPolynomial C S A) = + AlgHom.id S[X] ((TensorProduct C S A)) := by + apply AlgHom.ext + intro z + exact DFunLike.congr_fun + (constantTensorToPolynomialTensor_rightInverse C S A) z + +/-- Polynomial tensor cancellation as a `C[X]`-algebra equivalence, where the +target uses `polynomialTensorCancelTargetPolynomialAlgebra`. -/ +noncomputable def polynomialTensorCancelOverPolynomial : + TensorProduct C[X] S[X] A ≃ₐ[C[X]] TensorProduct C S A := + AlgEquiv.ofAlgHom + (polynomialTensorToConstantTensorOverPolynomial C S A) + (constantTensorToPolynomialTensorOverPolynomial C S A) + (by exact constantTensorToPolynomialTensorOverPolynomial_rightInverse C S A) + (by exact constantTensorToPolynomialTensorOverPolynomial_leftInverse C S A) + +/-- Polynomial tensor cancellation as an `S[X]`-algebra equivalence, where +the target uses `polynomialTensorCancelTargetPolynomialExtensionAlgebra`. -/ +noncomputable def polynomialTensorCancelOverCoefficientPolynomial : + TensorProduct C[X] S[X] A ≃ₐ[S[X]] TensorProduct C S A := + AlgEquiv.ofAlgHom + (polynomialTensorToConstantTensorOverCoefficientPolynomial C S A) + (constantTensorToPolynomialTensorOverCoefficientPolynomial C S A) + (by exact constantTensorToPolynomialTensorOverCoefficientPolynomial_rightInverse C S A) + (by exact constantTensorToPolynomialTensorOverCoefficientPolynomial_leftInverse C S A) + +/-- Cancelling the polynomial base change in a tensor product. -/ +noncomputable def polynomialTensorCancel : + TensorProduct C[X] S[X] A ≃ₐ[S] TensorProduct C S A := + AlgEquiv.ofAlgHom + (polynomialTensorToConstantTensor C S A) + (constantTensorToPolynomialTensor C S A) + (by exact constantTensorToPolynomialTensor_rightInverse C S A) + (by exact constantTensorToPolynomialTensor_leftInverse C S A) + +@[simp] +theorem polynomialTensorCancelOverPolynomial_apply + (z : TensorProduct C[X] S[X] A) : + polynomialTensorCancelOverPolynomial C S A z = + polynomialTensorCancel C S A z := by + rfl + +@[simp] +theorem polynomialTensorCancelOverPolynomial_symm_apply + (z : TensorProduct C S A) : + (polynomialTensorCancelOverPolynomial C S A).symm z = + (polynomialTensorCancel C S A).symm z := by + rfl + +@[simp] +theorem polynomialTensorCancelOverCoefficientPolynomial_apply + (z : TensorProduct C[X] S[X] A) : + polynomialTensorCancelOverCoefficientPolynomial C S A z = + polynomialTensorCancel C S A z := by + rfl + +@[simp] +theorem polynomialTensorCancelOverCoefficientPolynomial_symm_apply + (z : TensorProduct C S A) : + (polynomialTensorCancelOverCoefficientPolynomial C S A).symm z = + (polynomialTensorCancel C S A).symm z := by + rfl + +@[simp] +theorem polynomialTensorCancel_tmul (p : S[X]) (a : A) : + polynomialTensorCancel C S A (p ⊗ₜ[C[X]] a) = + Polynomial.aeval (polynomialTensorCancelEvaluationPoint C S A) p * + (1 ⊗ₜ[C] a) := by + rfl + +@[simp] +theorem polynomialTensorCancel_symm_tmul (s : S) (a : A) : + (polynomialTensorCancel C S A).symm (s ⊗ₜ[C] a) = + Polynomial.C s ⊗ₜ[C[X]] a := by + simp [polynomialTensorCancel, constantTensorToPolynomialTensor, + constantsToPolynomialTensor, rightFactorToPolynomialTensor] + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/PowerSum.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/PowerSum.lean new file mode 100644 index 0000000000..efa8349d4e --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/PowerSum.lean @@ -0,0 +1,163 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import Mathlib.Algebra.Order.Ring.Star +public import Mathlib.Algebra.Polynomial.Eval.Defs +public import Mathlib.Analysis.CStarAlgebra.Classes +public import Mathlib.Analysis.SpecificLimits.Normed +public import Mathlib.Tactic + +/-! +# Growth of finite weighted power sums + +This file formalizes the elementary power-sum lemma used in the +Corvaja--Zannier passage from even-extension point-count estimates to bounds +on Frobenius parameters. + +For a finite set `s` of distinct complex numbers and nonzero weights, an +`O(ρ ^ n)` bound on the weighted power sum forces every member of `s` to +have norm at most `ρ`. The proof uses an isolation polynomial: applying a +polynomial that vanishes at all the other members of `s` expresses the chosen +geometric progression as a fixed linear combination of shifted power sums. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +open Filter Asymptotics +open scoped BigOperators + +noncomputable section + +/-- The finite power sum with base set `s` and coefficient function `weight`. -/ +def weightedPowerSum (s : Finset ℂ) (weight : ℂ → ℂ) (n : ℕ) : ℂ := + ∑ z ∈ s, weight z * z ^ n + +/-- The polynomial that vanishes at every member of `s` other than `z`. -/ +private def isolatePolynomial (s : Finset ℂ) (z : ℂ) : Polynomial ℂ := + ∏ w ∈ s.erase z, (Polynomial.X - Polynomial.C w) + +private lemma isolatePolynomial_eval_self_ne_zero {s : Finset ℂ} {z : ℂ} : + (isolatePolynomial s z).eval z ≠ 0 := by + classical + rw [isolatePolynomial, Polynomial.eval_prod] + simp only [Polynomial.eval_sub, Polynomial.eval_X, Polynomial.eval_C] + exact Finset.prod_ne_zero_iff.mpr fun w hw ↦ + sub_ne_zero.mpr (Ne.symm (Finset.ne_of_mem_erase hw)) + +private lemma isolatePolynomial_eval_eq_zero_of_mem_of_ne + {s : Finset ℂ} {z w : ℂ} (hw : w ∈ s) (hwz : w ≠ z) : + (isolatePolynomial s z).eval w = 0 := by + classical + rw [isolatePolynomial, Polynomial.eval_prod] + exact Finset.prod_eq_zero (Finset.mem_erase.mpr ⟨hwz, hw⟩) (by simp) + +private lemma isolatePolynomial_sum_weightedPowerSum + {s : Finset ℂ} {weight : ℂ → ℂ} {z : ℂ} (hz : z ∈ s) (n : ℕ) : + (isolatePolynomial s z).sum + (fun k a ↦ a * weightedPowerSum s weight (n + k)) = + weight z * z ^ n * (isolatePolynomial s z).eval z := by + classical + rw [Polynomial.sum_def] + simp_rw [weightedPowerSum, Finset.mul_sum] + rw [Finset.sum_comm] + calc + _ = ∑ x ∈ s, weight x * x ^ n * + ∑ k ∈ (isolatePolynomial s z).support, + (isolatePolynomial s z).coeff k * x ^ k := by + apply Finset.sum_congr rfl + intro x hx + rw [Finset.mul_sum] + apply Finset.sum_congr rfl + intro k hk + rw [pow_add] + ring + _ = ∑ x ∈ s, weight x * x ^ n * (isolatePolynomial s z).eval x := by + apply Finset.sum_congr rfl + intro x hx + rw [Polynomial.eval_eq_sum, Polynomial.sum_def] + _ = weight z * z ^ n * (isolatePolynomial s z).eval z := by + rw [Finset.sum_eq_single z] + · intro x hx hne + rw [isolatePolynomial_eval_eq_zero_of_mem_of_ne hx hne, mul_zero] + · exact fun hnot ↦ (hnot hz).elim + +/-- A single complex geometric progression can be `O(ρ ^ n)` only when its +base has norm at most the nonnegative real number `ρ`. -/ +theorem norm_le_of_pow_isBigO {z : ℂ} {ρ : ℝ} (hρ : 0 ≤ ρ) + (h : (fun n : ℕ ↦ z ^ n) =O[atTop] fun n : ℕ ↦ ρ ^ n) : + ‖z‖ ≤ ρ := by + by_contra hz + have hlt : ρ < ‖z‖ := lt_of_not_ge hz + have hsmall : (fun n : ℕ ↦ ρ ^ n) =o[atTop] fun n : ℕ ↦ ‖z‖ ^ n := + isLittleO_pow_pow_of_lt_left hρ hlt + have hself : (fun n : ℕ ↦ z ^ n) =o[atTop] fun n : ℕ ↦ ‖z‖ ^ n := + h.trans_isLittleO hsmall + have hhalf := hself.def' (by norm_num : (0 : ℝ) < 1 / 2) + rcases hhalf.bound.exists with ⟨n, hn⟩ + have hzpos : 0 < ‖z‖ := by linarith + have hpos : 0 < ‖z‖ ^ n := pow_pos hzpos n + have hle : ‖z‖ ^ n ≤ (1 / 2 : ℝ) * ‖z‖ ^ n := by + simpa [norm_pow, Real.norm_eq_abs, + abs_of_nonneg (pow_nonneg (norm_nonneg z) n)] using hn + nlinarith + +/-- If a finite weighted power sum is `O(ρ ^ n)` and every coefficient is +nonzero, then each base occurring in the sum has norm at most `ρ`. + +Distinctness is encoded by `s` being a `Finset`. No nonzero assumption on the +bases is needed: zero bases satisfy the conclusion automatically. -/ +theorem norm_le_of_mem_of_weightedPowerSum_isBigO + {s : Finset ℂ} {weight : ℂ → ℂ} {ρ : ℝ} + (hρ : 0 ≤ ρ) + (hweight : ∀ z ∈ s, weight z ≠ 0) + (hO : weightedPowerSum s weight =O[atTop] fun n : ℕ ↦ ρ ^ n) + {z : ℂ} (hz : z ∈ s) : + ‖z‖ ≤ ρ := by + classical + have hshift (k : ℕ) : + (fun n : ℕ ↦ weightedPowerSum s weight (n + k)) =O[atTop] + fun n : ℕ ↦ ρ ^ n := by + have hcomp := hO.comp_tendsto (tendsto_add_atTop_nat k) + change (fun n : ℕ ↦ weightedPowerSum s weight (n + k)) =O[atTop] + (fun n : ℕ ↦ ρ ^ (n + k)) at hcomp + refine hcomp.trans ?_ + simpa only [pow_add, mul_comm] using + (isBigO_refl (fun n : ℕ ↦ ρ ^ n) atTop).const_mul_left (ρ ^ k) + have hfiltered : + (fun n : ℕ ↦ (isolatePolynomial s z).sum + (fun k a ↦ a * weightedPowerSum s weight (n + k))) =O[atTop] + fun n : ℕ ↦ ρ ^ n := by + convert! (IsBigO.sum (s := (isolatePolynomial s z).support) fun k hk ↦ + (hshift k).const_mul_left ((isolatePolynomial s z).coeff k)) using 1 + funext n + simp only [Polynomial.sum_def, Finset.sum_apply] + have hisolated : + (fun n : ℕ ↦ weight z * z ^ n * (isolatePolynomial s z).eval z) =O[atTop] + fun n : ℕ ↦ ρ ^ n := by + simpa only [isolatePolynomial_sum_weightedPowerSum hz] using hfiltered + have hcoefficient : weight z * (isolatePolynomial s z).eval z ≠ 0 := + mul_ne_zero (hweight z hz) isolatePolynomial_eval_self_ne_zero + have hpower : (fun n : ℕ ↦ z ^ n) =O[atTop] fun n : ℕ ↦ ρ ^ n := by + apply (isBigO_const_mul_left_iff hcoefficient).mp + exact hisolated.congr_left fun n ↦ by ring + exact norm_le_of_pow_isBigO hρ hpower + +/-- Simultaneous form of `norm_le_of_mem_of_weightedPowerSum_isBigO`. -/ +theorem weightedPowerSum_base_norm_le + {s : Finset ℂ} {weight : ℂ → ℂ} {ρ : ℝ} + (hρ : 0 ≤ ρ) + (hweight : ∀ z ∈ s, weight z ≠ 0) + (hO : weightedPowerSum s weight =O[atTop] fun n : ℕ ↦ ρ ^ n) : + ∀ z ∈ s, ‖z‖ ≤ ρ := + fun _z hz ↦ norm_le_of_mem_of_weightedPowerSum_isBigO hρ hweight hO hz + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/RatFuncCanonicalInfinityDivisor.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/RatFuncCanonicalInfinityDivisor.lean new file mode 100644 index 0000000000..a6b71a512d --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/RatFuncCanonicalInfinityDivisor.lean @@ -0,0 +1,160 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import Mathlib.RingTheory.RamificationInertia.Basic +public import Mathlib.LinearAlgebra.Dimension.Localization +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionRiemannRoch + +/-! +# The canonical divisor `-2∞` on the rational function field + +This module constructs an actual infinity place of the identity extension +`K(X) / K(X)`, proves that its residue degree is one, and identifies the +divisor supported there with coefficient `-2` as canonical. The proof uses +the in-repository Riemann--Roch theorem and the proved genus-zero theorem for +`RatFunc K`; it does not assume a base canonical divisor. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +open BGS.CorvajaZannier +open scoped Polynomial + +noncomputable section + +variable (K : Type*) [Field K] [Fintype K] [DecidableEq K] + [DecidableEq (RatFunc K)] + +local instance ratFuncIdentityInfinityClosureModuleFinite : + Module.Finite (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K (RatFunc K)) := + IsIntegralClosure.finite (RatFuncInfinityIntegers K) (RatFunc K) + (RatFunc K) (RatFuncInfinityIntegralClosure K (RatFunc K)) + +local instance ratFuncIdentityInfinityClosureIsIntegral : + Algebra.IsIntegral (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K (RatFunc K)) := + IsIntegralClosure.isIntegral_algebra (RatFuncInfinityIntegers K) (RatFunc K) + +local instance ratFuncIdentityInfinityClosureIsTorsionFree : + Module.IsTorsionFree (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K (RatFunc K)) := + IsIntegralClosure.isTorsionFree (RatFuncInfinityIntegers K) (RatFunc K) + +local instance ratFuncIdentityInfinityClosureNoZeroSMulDivisors : + NoZeroSMulDivisors (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K (RatFunc K)) where + eq_zero_or_eq_zero_of_smul_eq_zero h := smul_eq_zero.mp h + +local instance ratFuncIdentityInfinityClosureIsDedekind : + IsDedekindDomain (RatFuncInfinityIntegralClosure K (RatFunc K)) := + IsIntegralClosure.isDedekindDomain (RatFuncInfinityIntegers K) + (RatFunc K) (RatFunc K) + (RatFuncInfinityIntegralClosure K (RatFunc K)) + +local instance ratFuncIdentityInfinityClosureIsFractionRing : + IsFractionRing (RatFuncInfinityIntegralClosure K (RatFunc K)) (RatFunc K) := + IsIntegralClosure.isFractionRing_of_finite_extension + (RatFuncInfinityIntegers K) (RatFunc K) (RatFunc K) + (RatFuncInfinityIntegralClosure K (RatFunc K)) + +/-- A place above infinity in the identity extension `K(X) / K(X)`. -/ +noncomputable def ratFuncIdentityInfinityPlace : + FiniteExtensionInfinityPlace K (RatFunc K) := + Classical.choice inferInstance + +private theorem inertiaDegree_le_fractionField_finrank + (R S K L : Type*) [CommRing R] [IsDomain R] [CommRing S] + [Field K] [Field L] [Algebra R S] [Module.Finite R S] [Module.Flat R S] + [Algebra R K] [Algebra S L] [Algebra R L] [Algebra K L] + [IsScalarTower R K L] [IsScalarTower R S L] + [IsFractionRing R K] [IsFractionRing S L] + (p : Ideal R) [p.IsPrime] [Finite (p.primesOver S)] + (q : Ideal S) [q.IsPrime] [q.LiesOver p] : + q.inertiaDeg R ≤ Module.finrank K L := by + let : Fintype (p.primesOver S) := Fintype.ofFinite _ + let Q : p.primesOver S := ⟨q, inferInstance, inferInstance⟩ + calc + q.inertiaDeg R ≤ q.ramificationIdx R * q.inertiaDeg R := + Nat.le_mul_of_pos_left _ (Ideal.ramificationIdx_pos q R) + _ ≤ ∑ Q : p.primesOver S, Q.1.ramificationIdx R * Q.1.inertiaDeg R := + Finset.single_le_sum + (f := fun Q : p.primesOver S => Q.1.ramificationIdx R * Q.1.inertiaDeg R) + (fun _ _ => Nat.zero_le _) (Finset.mem_univ Q) + _ = Module.finrank R S := Ideal.sum_ramification_inertia_eq_finrank p S + _ = Module.finrank K L := (IsFractionRing.finrank_eq R K S L).symm + +omit [Fintype K] in +/-- The chosen identity-extension infinity place has residue degree one. -/ +theorem ratFuncIdentityInfinityPlace_degree_eq_one : + finiteExtensionPlaceDegree K (RatFunc K) + (.inr (ratFuncIdentityInfinityPlace K)) = 1 := by + let P := ratFuncIdentityInfinityPlace K + change P.1.inertiaDeg (RatFuncInfinityIntegers K) = 1 + have hpos : 0 < P.1.inertiaDeg (RatFuncInfinityIntegers K) := + Ideal.inertiaDeg_pos P.1 (RatFuncInfinityIntegers K) + let : P.1.IsPrime := P.2.1 + let : P.1.LiesOver (ratFuncInfinityPlace K).asIdeal := P.2.2 + let : Fintype (FiniteExtensionInfinityPlace K (RatFunc K)) := + Set.Finite.fintype (IsDedekindDomain.primesOver_finite + (ratFuncInfinityPlace K).asIdeal (RatFuncInfinityIntegralClosure K (RatFunc K))) + have hle := inertiaDegree_le_fractionField_finrank + (RatFuncInfinityIntegers K) (RatFuncInfinityIntegralClosure K (RatFunc K)) + (RatFunc K) (RatFunc K) (ratFuncInfinityPlace K).asIdeal P.1 + rw [Module.finrank_self] at hle + omega + +/-- The chosen infinity place in the Riemann--Roch two-chart place model. -/ +noncomputable def ratFuncInfinityChartPlace : + FunctionField.Chart.PlaceA K (RatFunc K) := + finiteExtensionPlaceEquivChart K (RatFunc K) + (.inr (ratFuncIdentityInfinityPlace K)) + +/-- The explicit divisor `-2∞` on `K(X)`. -/ +noncomputable def ratFuncCanonicalInfinityDivisor : + FunctionField.Chart.DivisorA K (RatFunc K) := + Finsupp.single (ratFuncInfinityChartPlace K) (-2) + +omit [Fintype K] [DecidableEq K] in +/-- The explicit divisor `-2∞` has degree `-2`. -/ +theorem ratFuncCanonicalInfinityDivisor_degree : + FunctionField.Chart.deg K (RatFunc K) + (ratFuncCanonicalInfinityDivisor K) = -2 := by + classical + rw [ratFuncCanonicalInfinityDivisor, FunctionField.Chart.deg_single] + have hdegree := finiteExtensionPlaceDegree_eq_chart K (RatFunc K) + (.inr (ratFuncIdentityInfinityPlace K)) + rw [ratFuncIdentityInfinityPlace_degree_eq_one K] at hdegree + change (1 : ℕ) = FunctionField.Chart.placeDegree K (RatFunc K) + (ratFuncInfinityChartPlace K) at hdegree + rw [← hdegree] + norm_num + +omit [Fintype K] [DecidableEq K] in +/-- The explicit divisor `-2∞` is canonical on `K(X)`. -/ +theorem ratFuncCanonicalInfinityDivisor_isCanonical : + FunctionField.Chart.IsCanonical K (RatFunc K) + (ratFuncCanonicalInfinityDivisor K) := by + classical + rw [FunctionField.chart_isCanonical_iff_degree_ell] + constructor + · rw [ratFuncCanonicalInfinityDivisor_degree, + FunctionField.Chart.genus_ratFunc] + norm_num + · have hnegative : FunctionField.Chart.deg K (RatFunc K) + (ratFuncCanonicalInfinityDivisor K) < 0 := by + rw [ratFuncCanonicalInfinityDivisor_degree] + norm_num + rw [FunctionField.Chart.RRspace_neg_deg_ell K (RatFunc K) hnegative, + FunctionField.Chart.genus_ratFunc] + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/RatFuncConstantExtension.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/RatFuncConstantExtension.lean new file mode 100644 index 0000000000..3e33ce2926 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/RatFuncConstantExtension.lean @@ -0,0 +1,312 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import Mathlib.Algebra.Polynomial.Module.TensorProduct +public import Mathlib.FieldTheory.RatFunc.Basic +public import Mathlib.LinearAlgebra.Dimension.Localization +public import Mathlib.LinearAlgebra.FiniteDimensional.Basic +public import Mathlib.RingTheory.DedekindDomain.Instances +public import Mathlib.RingTheory.Localization.LocalizationLocalization +public import Mathlib.RingTheory.TensorProduct.Finite + +/-! +# Constant extensions of rational function fields + +For a finite field extension `S / K`, this file constructs the coefficient +embedding `K(X) → S(X)` and proves that `S(X)` is a finite-dimensional +`K(X)`-vector space of dimension `[S : K]`. + +The construction is explicit. We first localize `S[X]` at the images of the +nonzero polynomials in `K[X]`, prove that this localization is a field, and +identify it with `S(X)`. This is the rational-function-field base-change +input needed for the later constant extension of a general function field. +-/ + +@[expose] public section + +open scoped Polynomial nonZeroDivisors + +namespace BGS.HasseWeil + +noncomputable section + +variable (K S : Type*) [Field K] [Field S] [Algebra K S] + +local instance polynomialCoefficientAlgebra : Algebra K[X] S[X] := + (Polynomial.mapRingHom (algebraMap K S)).toAlgebra + +local instance polynomialCoefficientFaithfulSMul : FaithfulSMul K[X] S[X] where + eq_of_smul_eq_smul h := by + have hinj : Function.Injective (algebraMap K[X] S[X]) := by + change Function.Injective (Polynomial.map (algebraMap K S)) + exact Polynomial.map_injective (algebraMap K S) (algebraMap K S).injective + exact hinj (by simpa only [Algebra.smul_def, mul_one] using h 1) + +/-- The coefficient extension on polynomial rings. -/ +noncomputable def ratFuncCoefficientPolynomialAlgHom : K[X] →ₐ[K] S[X] := + Polynomial.mapAlgHom (Algebra.ofId K S) + +theorem ratFuncCoefficientPolynomialAlgHom_injective : + Function.Injective (ratFuncCoefficientPolynomialAlgHom K S) := by + change Function.Injective (Polynomial.map (algebraMap K S)) + exact Polynomial.map_injective (algebraMap K S) (algebraMap K S).injective + +private theorem ratFuncCoefficientPolynomialAlgHom_nonZeroDivisors : + K[X]⁰ ≤ S[X]⁰.comap (ratFuncCoefficientPolynomialAlgHom K S) := + nonZeroDivisors_le_comap_nonZeroDivisors_of_injective _ + (ratFuncCoefficientPolynomialAlgHom_injective K S) + +/-- The canonical coefficient extension `K(X) → S(X)`. -/ +noncomputable def ratFuncCoefficientAlgHom : RatFunc K →ₐ[K] RatFunc S := + RatFunc.mapAlgHom (ratFuncCoefficientPolynomialAlgHom K S) + (by exact ratFuncCoefficientPolynomialAlgHom_nonZeroDivisors K S) + +theorem ratFuncCoefficientAlgHom_injective : + Function.Injective (ratFuncCoefficientAlgHom K S) := + RatFunc.map_injective (ratFuncCoefficientPolynomialAlgHom K S) + (by exact ratFuncCoefficientPolynomialAlgHom_nonZeroDivisors K S) + (ratFuncCoefficientPolynomialAlgHom_injective K S) + +theorem ratFuncCoefficientAlgHom_algebraMap (p : K[X]) : + ratFuncCoefficientAlgHom K S (algebraMap K[X] (RatFunc K) p) = + algebraMap S[X] (RatFunc S) (algebraMap K[X] S[X] p) := by + change RatFunc.map (ratFuncCoefficientPolynomialAlgHom K S) + (by exact ratFuncCoefficientPolynomialAlgHom_nonZeroDivisors K S) + (algebraMap K[X] (RatFunc K) p) = _ + rw [show algebraMap K[X] (RatFunc K) p = + algebraMap K[X] (RatFunc K) p / algebraMap K[X] (RatFunc K) 1 by simp] + rw [RatFunc.map_apply_div] + simp only [map_one, div_one] + congr 1 + +/-- The algebra structure on `S(X)` induced by coefficient extension. -/ +@[reducible] noncomputable def ratFuncCoefficientAlgebra : + Algebra (RatFunc K) (RatFunc S) := + (ratFuncCoefficientAlgHom K S).toAlgebra + +local instance ratFuncCoefficientAlgebraInstance : + Algebra (RatFunc K) (RatFunc S) := + ratFuncCoefficientAlgebra K S + +/-- Localize `S[X]` by the images of all nonzero polynomials in `K[X]`. -/ +abbrev RatFuncConstantLocalization := + Localization (Submonoid.map (algebraMap K[X] S[X]) K[X]⁰) + +local instance ratFuncConstantLocalizationIsDomain : + IsDomain (RatFuncConstantLocalization K S) := + IsLocalization.isDomain_localization + (by + simpa only [Algebra.algebraMapSubmonoid] using + algebraMapSubmonoid_le_nonZeroDivisors_of_faithfulSMul S[X] le_rfl) + +noncomputable local instance ratFuncConstantLocalizationAlgebra : + Algebra (RatFunc K) (RatFuncConstantLocalization K S) := + (IsLocalization.map (RatFuncConstantLocalization K S) + (algebraMap K[X] S[X]) (Submonoid.le_comap_map K[X]⁰)).toAlgebra + +local instance ratFuncConstantLocalizationScalarTower : + IsScalarTower K[X] (RatFunc K) (RatFuncConstantLocalization K S) := + let hmap : K[X]⁰ ≤ Submonoid.comap (algebraMap K[X] S[X]) + (Submonoid.map (algebraMap K[X] S[X]) K[X]⁰) := + Submonoid.le_comap_map K[X]⁰ + IsScalarTower.of_algebraMap_eq' (by + rw [IsScalarTower.algebraMap_eq K[X] S[X] + (RatFuncConstantLocalization K S)] + exact (IsLocalization.map_comp hmap).symm) + +private noncomputable def polynomialModuleEquivPolynomial : + PolynomialModule K S ≃ₗ[K[X]] S[X] where + toEquiv := (PolynomialModule.equivPolynomial (R := K)).toEquiv + map_add' := (PolynomialModule.equivPolynomial (R := K)).map_add + map_smul' p x := by + ext n + change (p • x).coeff n = + ((algebraMap K[X] S[X] p) * + (PolynomialModule.equivPolynomial (R := K) x)).coeff n + rw [PolynomialModule.smul_apply, Polynomial.coeff_mul] + apply Finset.sum_congr rfl + intro ij hij + simp [Algebra.smul_def, PolynomialModule.equivPolynomial] + +local instance polynomialCoefficientModuleFinite [FiniteDimensional K S] : + Module.Finite K[X] S[X] := by + let : Module.Finite K[X] (TensorProduct K K[X] S) := + Module.Finite.base_change K K[X] S + exact Module.Finite.equiv + ((PolynomialModule.polynomialTensorProductLEquivPolynomialModule K S).trans + (polynomialModuleEquivPolynomial K S)) + +local instance ratFuncConstantLocalizationIsLocalization : + IsLocalization (Algebra.algebraMapSubmonoid S[X] K[X]⁰) + (RatFuncConstantLocalization K S) := by + change IsLocalization (Submonoid.map (algebraMap K[X] S[X]) K[X]⁰) + (RatFuncConstantLocalization K S) + infer_instance + +local instance ratFuncConstantLocalizationFinite [FiniteDimensional K S] : + Module.Finite (RatFunc K) (RatFuncConstantLocalization K S) := + Module.Finite.of_isLocalization K[X] S[X] K[X]⁰ + +noncomputable local instance ratFuncConstantLocalizationField + [FiniteDimensional K S] : Field (RatFuncConstantLocalization K S) := + (IsField.of_isDomain_of_finite (RatFunc K) + (RatFuncConstantLocalization K S)).toField + +private theorem ratFuncConstantLocalizationSubmonoid_le : + Submonoid.map (algebraMap K[X] S[X]) K[X]⁰ ≤ S[X]⁰ := by + simpa only [Algebra.algebraMapSubmonoid] using + algebraMapSubmonoid_le_nonZeroDivisors_of_faithfulSMul S[X] le_rfl + +/-- Map the localization at nonzero base polynomials into the rational function field. -/ +noncomputable def ratFuncConstantLocalizationToRatFunc + [FiniteDimensional K S] : + RatFuncConstantLocalization K S →+* RatFunc S := + IsLocalization.map + (M := Submonoid.map (algebraMap K[X] S[X]) K[X]⁰) + (T := S[X]⁰) (RatFunc S) (RingHom.id S[X]) (by + change Submonoid.map (algebraMap K[X] S[X]) K[X]⁰ ≤ S[X]⁰ + exact ratFuncConstantLocalizationSubmonoid_le K S) + +private theorem ratFuncConstantLocalizationToRatFunc_algebraMap + [FiniteDimensional K S] (p : S[X]) : + ratFuncConstantLocalizationToRatFunc K S + (algebraMap S[X] (RatFuncConstantLocalization K S) p) = + algebraMap S[X] (RatFunc S) p := by + let hM : Submonoid.map (algebraMap K[X] S[X]) K[X]⁰ ≤ + S[X]⁰.comap (RingHom.id S[X]) := by + change Submonoid.map (algebraMap K[X] S[X]) K[X]⁰ ≤ S[X]⁰ + exact ratFuncConstantLocalizationSubmonoid_le K S + have h := congrArg (fun f : S[X] →+* RatFunc S => f p) + (IsLocalization.map_comp + (Q := RatFunc S) + (S := RatFuncConstantLocalization K S) hM) + change (IsLocalization.map (RatFunc S) (RingHom.id S[X]) hM) + (algebraMap S[X] (RatFuncConstantLocalization K S) p) = + algebraMap S[X] (RatFunc S) p + simpa only [RingHom.comp_apply, RingHom.id_apply] using h + +/-- Embed rational functions into the constant-extension localization. -/ +noncomputable def ratFuncToConstantLocalization + [FiniteDimensional K S] : + RatFunc S →+* RatFuncConstantLocalization K S := + IsFractionRing.lift (IsLocalization.injective + (RatFuncConstantLocalization K S) + (show Submonoid.map (algebraMap K[X] S[X]) K[X]⁰ ≤ S[X]⁰ from by + exact ratFuncConstantLocalizationSubmonoid_le K S)) + +private theorem ratFuncToConstantLocalization_algebraMap + [FiniteDimensional K S] (p : S[X]) : + ratFuncToConstantLocalization K S (algebraMap S[X] (RatFunc S) p) = + algebraMap S[X] (RatFuncConstantLocalization K S) p := by + exact IsFractionRing.lift_algebraMap _ p + +/-- The localization of `S[X]` at nonzero `K[X]` is the full rational +function field `S(X)` when `S / K` is finite. -/ +noncomputable def ratFuncConstantLocalizationRingEquiv + [FiniteDimensional K S] : + RatFuncConstantLocalization K S ≃+* RatFunc S where + toFun := ratFuncConstantLocalizationToRatFunc K S + invFun := ratFuncToConstantLocalization K S + map_add' := map_add _ + map_mul' := map_mul _ + left_inv x := by + have hcomp : + (ratFuncToConstantLocalization K S).comp + (ratFuncConstantLocalizationToRatFunc K S) = + RingHom.id (RatFuncConstantLocalization K S) := by + apply IsLocalization.ringHom_ext + (Submonoid.map (algebraMap K[X] S[X]) K[X]⁰) + apply RingHom.ext + intro p + simp only [RingHom.comp_apply, + ratFuncConstantLocalizationToRatFunc_algebraMap, + ratFuncToConstantLocalization_algebraMap, RingHom.id_apply] + exact congrArg + (fun f : RatFuncConstantLocalization K S →+* + RatFuncConstantLocalization K S => f x) hcomp + right_inv x := by + have hcomp : + (ratFuncConstantLocalizationToRatFunc K S).comp + (ratFuncToConstantLocalization K S) = + RingHom.id (RatFunc S) := by + apply IsFractionRing.ringHom_ext (A := S[X]) + intro p + simp only [RingHom.comp_apply, + ratFuncConstantLocalizationToRatFunc_algebraMap, + ratFuncToConstantLocalization_algebraMap, RingHom.id_apply] + exact congrArg (fun f : RatFunc S →+* RatFunc S => f x) hcomp + +theorem ratFuncConstantLocalizationRingEquiv_algebraMap + [FiniteDimensional K S] (r : RatFunc K) : + ratFuncConstantLocalizationRingEquiv K S + (algebraMap (RatFunc K) (RatFuncConstantLocalization K S) r) = + algebraMap (RatFunc K) (RatFunc S) r := by + have hcomp : + (ratFuncConstantLocalizationRingEquiv K S).toRingHom.comp + (algebraMap (RatFunc K) (RatFuncConstantLocalization K S)) = + algebraMap (RatFunc K) (RatFunc S) := by + apply IsFractionRing.ringHom_ext (A := K[X]) + intro p + simp only [RingHom.comp_apply] + rw [← IsScalarTower.algebraMap_apply K[X] (RatFunc K) + (RatFuncConstantLocalization K S)] + rw [IsScalarTower.algebraMap_apply K[X] S[X] + (RatFuncConstantLocalization K S)] + change ratFuncConstantLocalizationToRatFunc K S + (algebraMap S[X] (RatFuncConstantLocalization K S) + (algebraMap K[X] S[X] p)) = + ratFuncCoefficientAlgHom K S (algebraMap K[X] (RatFunc K) p) + rw [ratFuncConstantLocalizationToRatFunc_algebraMap] + exact (ratFuncCoefficientAlgHom_algebraMap K S p).symm + exact congrArg (fun f : RatFunc K →+* RatFunc S => f r) hcomp + +/-- The localization equivalence, now linear over the canonical coefficient +embedding `K(X) → S(X)`. -/ +noncomputable def ratFuncConstantLocalizationLinearEquiv + [FiniteDimensional K S] : + RatFuncConstantLocalization K S ≃ₗ[RatFunc K] RatFunc S where + toEquiv := (ratFuncConstantLocalizationRingEquiv K S).toEquiv + map_add' := map_add (ratFuncConstantLocalizationRingEquiv K S) + map_smul' r x := by + change ratFuncConstantLocalizationRingEquiv K S + (algebraMap (RatFunc K) (RatFuncConstantLocalization K S) r * x) = + algebraMap (RatFunc K) (RatFunc S) r * + ratFuncConstantLocalizationRingEquiv K S x + rw [map_mul, ratFuncConstantLocalizationRingEquiv_algebraMap] + +/-- A finite coefficient extension induces a finite extension of rational +function fields. -/ +theorem ratFuncCoefficient_moduleFinite [FiniteDimensional K S] : + Module.Finite (RatFunc K) (RatFunc S) := + Module.Finite.equiv (ratFuncConstantLocalizationLinearEquiv K S) + +/-- Constant extension preserves the extension degree of rational function +fields: `[S(X) : K(X)] = [S : K]`. -/ +theorem ratFuncCoefficient_finrank [FiniteDimensional K S] : + Module.finrank (RatFunc K) (RatFunc S) = Module.finrank K S := by + let ePoly := + (PolynomialModule.polynomialTensorProductLEquivPolynomialModule K S).trans + (polynomialModuleEquivPolynomial K S) + calc + Module.finrank (RatFunc K) (RatFunc S) = + Module.finrank (RatFunc K) (RatFuncConstantLocalization K S) := + (ratFuncConstantLocalizationLinearEquiv K S).finrank_eq.symm + _ = Module.finrank K[X] (RatFuncConstantLocalization K S) := by + simpa only [Module.finrank] using congrArg Cardinal.toNat + (IsLocalization.rank_eq + (N := RatFuncConstantLocalization K S) (RatFunc K) K[X]⁰ le_rfl) + _ = Module.finrank K[X] S[X] := by + exact IsLocalizedModule.finrank_eq K[X]⁰ + (IsScalarTower.toAlgHom K[X] S[X] + (RatFuncConstantLocalization K S)).toLinearMap le_rfl + _ = Module.finrank K[X] (TensorProduct K K[X] S) := ePoly.finrank_eq.symm + _ = Module.finrank K S := Module.finrank_baseChange + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/RatFuncExactConstantExtension.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/RatFuncExactConstantExtension.lean new file mode 100644 index 0000000000..de9b09dd63 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/RatFuncExactConstantExtension.lean @@ -0,0 +1,479 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExactConstantExtensionAutomorphism +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteFieldConstantExtensionNormalization +public import LeanPool.MarkoffModP.BGS.HasseWeil.FinitePlaceNormalizationTransport +public import LeanPool.MarkoffModP.BGS.HasseWeil.PolynomialTensorCancel +public import LeanPool.MarkoffModP.BGS.HasseWeil.RatFuncConstantExtension +public import Mathlib.FieldTheory.RatFunc.AsPolynomial +public import Mathlib.RingTheory.Flat.Stability + +/-! +# The rational-function field in an exact constant extension + +Let `C` be the exact constant field of a function field `N / C(X)`, and let +`S / C` be a finite Galois extension. The tensor product `S ⊗[C] N` is then +a field. This file constructs its canonical `S(X)`-algebra structure and +proves that it is compatible with both copies of `C(X)`. + +For finite Galois `N / C(X)`, the tensor product is finite and separable over +`S(X)`. The final equivalence identifies the polynomial normalization after +constant extension with the normalization used by the project's finite-place +model. +-/ + +@[expose] public section + +open scoped Polynomial TensorProduct nonZeroDivisors + +namespace BGS.HasseWeil + +open BGS.CorvajaZannier + +noncomputable section + + +variable (C S N : Type*) [Field C] [Field S] [Field N] + [Algebra (RatFunc C) N] [Algebra C S] + [FiniteDimensional C S] [IsGalois C S] + +local instance constantAlgebra : Algebra C N := + RingHom.toAlgebra ((algebraMap (RatFunc C) N).comp + (algebraMap C (RatFunc C))) + +-- Save these instances before installing the competing `C[X]`-algebra on `N`. +@[reducible] private noncomputable def canonicalRatFuncPolynomialAlgebra : + Algebra C[X] (RatFunc C) := inferInstance + +private theorem canonicalRatFuncFractionRing : + letI := canonicalRatFuncPolynomialAlgebra C + IsFractionRing C[X] (RatFunc C) := by + let := canonicalRatFuncPolynomialAlgebra C + infer_instance + +local instance polynomialAlgebra : Algebra C[X] N := + RingHom.toAlgebra ((algebraMap (RatFunc C) N).comp + (algebraMap C[X] (RatFunc C))) + +local instance ratFuncCoefficientPolynomialAlgebra : Algebra C[X] S[X] := + Polynomial.algebra C S + +local instance coefficientPolynomialModule : Module C[X] S[X] := + Algebra.toModule + +local instance coefficientPolynomialFlat : Module.Flat C[X] S[X] := by + let : Module.Flat C[X] (TensorProduct C C[X] S) := inferInstance + exact Module.Flat.of_linearEquiv + (Algebra.IsPushout.equiv C C[X] S S[X]).symm.toLinearEquiv + +local instance constantPolynomialTower : IsScalarTower C C[X] N := + IsScalarTower.of_algebraMap_eq' (by + ext c + change algebraMap (RatFunc C) N (algebraMap C (RatFunc C) c) = + algebraMap (RatFunc C) N + (algebraMap C[X] (RatFunc C) (Polynomial.C c)) + congr 1) + +private theorem polynomialAlgebraMap_injective : + Function.Injective (algebraMap C[X] N) := by + change Function.Injective + ((algebraMap (RatFunc C) N).comp (algebraMap C[X] (RatFunc C))) + exact (algebraMap (RatFunc C) N).injective.comp + (RatFunc.algebraMap_injective C) + +local instance targetPolynomialAlgebra : + Algebra S[X] (ExactConstantExtension C N S) := + polynomialTensorCancelTargetPolynomialExtensionAlgebra C S N + +omit [FiniteDimensional C S] in +private theorem targetPolynomialAlgebraMap_injective : + Function.Injective + (algebraMap S[X] (ExactConstantExtension C N S)) := by + intro p q hpq + let e := polynomialTensorCancelOverCoefficientPolynomial C S N + have hleft : + (Algebra.TensorProduct.includeLeft : + S[X] →ₐ[S[X]] TensorProduct C[X] S[X] N) p = + (Algebra.TensorProduct.includeLeft : + S[X] →ₐ[S[X]] TensorProduct C[X] S[X] N) q := by + apply e.injective + calc + e (Algebra.TensorProduct.includeLeft p) = + algebraMap S[X] (ExactConstantExtension C N S) p := e.commutes p + _ = algebraMap S[X] (ExactConstantExtension C N S) q := hpq + _ = e (Algebra.TensorProduct.includeLeft q) := (e.commutes q).symm + exact Algebra.TensorProduct.includeLeft_injective + (polynomialAlgebraMap_injective C N) hleft + +omit [FiniteDimensional C S] [IsGalois C S] in +private theorem targetEvaluation_coefficientPolynomial (p : C[X]) : + Polynomial.aeval (polynomialTensorCancelEvaluationPoint C S N) + (algebraMap C[X] S[X] p) = + (1 : S) ⊗ₜ[C] (algebraMap C[X] N p) := by + let e := polynomialTensorCancelOverCoefficientPolynomial C S N + have hsource : + (algebraMap C[X] S[X] p) ⊗ₜ[C[X]] (1 : N) = + (1 : S[X]) ⊗ₜ[C[X]] (algebraMap C[X] N p) := by + exact Algebra.TensorProduct.tmul_one_eq_one_tmul p + calc + Polynomial.aeval (polynomialTensorCancelEvaluationPoint C S N) + (algebraMap C[X] S[X] p) = + e ((algebraMap C[X] S[X] p) ⊗ₜ[C[X]] (1 : N)) := by + exact (e.commutes (algebraMap C[X] S[X] p)).symm + _ = e ((1 : S[X]) ⊗ₜ[C[X]] (algebraMap C[X] N p)) := + congrArg e hsource + _ = (1 : S) ⊗ₜ[C] (algebraMap C[X] N p) := by + rw [polynomialTensorCancelOverCoefficientPolynomial_apply, + polynomialTensorCancel_tmul] + simp + +section Exact + +variable (hExact : algebraicClosure C N = + (⊥ : IntermediateField C N)) + +/-- The canonical copy of `S(X)` inside the exact constant extension, +obtained by extending the evaluated `S[X]`-algebra map. -/ +noncomputable def ratFuncToExactConstantExtension : + RatFunc S →ₐ[S] ExactConstantExtension C N S := by + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + exact RatFunc.liftAlgHom + (Polynomial.aeval + (polynomialTensorCancelEvaluationPoint C S N)) + (by + apply nonZeroDivisors_le_comap_nonZeroDivisors_of_injective + exact targetPolynomialAlgebraMap_injective C S N) + +theorem ratFuncToExactConstantExtension_injective : + Function.Injective + (ratFuncToExactConstantExtension C S N hExact) := by + let : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + let hpoly := targetPolynomialAlgebraMap_injective C S N + exact RatFunc.liftAlgHom_injective + (Polynomial.aeval + (polynomialTensorCancelEvaluationPoint C S N)) hpoly + +theorem ratFuncToExactConstantExtension_algebraMap (p : S[X]) : + ratFuncToExactConstantExtension C S N hExact + (algebraMap S[X] (RatFunc S) p) = + Polynomial.aeval + (polynomialTensorCancelEvaluationPoint C S N) p := by + let : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + change RatFunc.liftAlgHom _ _ (algebraMap S[X] (RatFunc S) p) = _ + exact RatFunc.liftRingHom_algebraMap _ _ p + +theorem ratFuncToExactConstantExtension_X : + ratFuncToExactConstantExtension C S N hExact RatFunc.X = + polynomialTensorCancelEvaluationPoint C S N := by + let : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + calc + ratFuncToExactConstantExtension C S N hExact RatFunc.X = + ratFuncToExactConstantExtension C S N hExact + (algebraMap S[X] (RatFunc S) Polynomial.X) := by + apply congrArg (ratFuncToExactConstantExtension C S N hExact) + exact (RatFunc.algebraMap_X (K := S)).symm + _ = Polynomial.aeval + (polynomialTensorCancelEvaluationPoint C S N) Polynomial.X := + ratFuncToExactConstantExtension_algebraMap C S N hExact Polynomial.X + _ = polynomialTensorCancelEvaluationPoint C S N := by + exact Polynomial.aeval_X _ + +/-- The algebra structure induced by the canonical copy of `S(X)`. -/ +@[reducible] noncomputable def ratFuncExactConstantExtensionAlgebra : + Algebra (RatFunc S) (ExactConstantExtension C N S) := + (ratFuncToExactConstantExtension C S N hExact).toAlgebra + +/-- The copy of `C(X)` obtained through coefficient extension to `S(X)` +agrees with the copy coming from the right tensor factor `N`. -/ +theorem rationalBase_algebraMap_eq : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) (RatFunc S) := + ratFuncCoefficientAlgebra C S + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + letI : Algebra (RatFunc S) (ExactConstantExtension C N S) := + ratFuncExactConstantExtensionAlgebra C S N hExact + algebraMap (RatFunc C) (ExactConstantExtension C N S) = + (algebraMap (RatFunc S) (ExactConstantExtension C N S)).comp + (algebraMap (RatFunc C) (RatFunc S)) := by + let : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + let : Algebra C[X] (RatFunc C) := canonicalRatFuncPolynomialAlgebra C + let : IsFractionRing C[X] (RatFunc C) := canonicalRatFuncFractionRing C + let : Algebra (RatFunc C) (RatFunc S) := + ratFuncCoefficientAlgebra C S + let : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : Algebra (RatFunc S) (ExactConstantExtension C N S) := + ratFuncExactConstantExtensionAlgebra C S N hExact + apply IsFractionRing.ringHom_ext (A := C[X]) + intro p + change + (1 : S) ⊗ₜ[C] + algebraMap (RatFunc C) N (algebraMap C[X] (RatFunc C) p) = + ratFuncToExactConstantExtension C S N hExact + (ratFuncCoefficientAlgHom C S + (algebraMap C[X] (RatFunc C) p)) + rw [ratFuncCoefficientAlgHom_algebraMap] + change + (1 : S) ⊗ₜ[C] + algebraMap (RatFunc C) N (algebraMap C[X] (RatFunc C) p) = + ratFuncToExactConstantExtension C S N hExact + (RatFunc.mk (algebraMap C[X] S[X] p) 1) + rw [RatFunc.mk_eq_localization_mk _ one_ne_zero] + change _ = RatFunc.liftAlgHom _ _ + (RatFunc.ofFractionRing + (Localization.mk (algebraMap C[X] S[X] p) (1 : S[X]⁰))) + rw [RatFunc.liftAlgHom_apply_ofFractionRing_mk] + have hone : + Polynomial.aeval (polynomialTensorCancelEvaluationPoint C S N) + ((1 : S[X]⁰) : S[X]) = 1 := by + exact map_one _ + rw [hone, div_one] + change (1 : S) ⊗ₜ[C] (algebraMap C[X] N p) = _ + exact (targetEvaluation_coefficientPolynomial C S N p).symm + +/-- The rational-function coefficient extension and the exact constant +extension form a scalar tower. -/ +theorem rationalBase_scalarTower : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) (RatFunc S) := + ratFuncCoefficientAlgebra C S + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + letI : Algebra (RatFunc S) (ExactConstantExtension C N S) := + ratFuncExactConstantExtensionAlgebra C S N hExact + letI : SMul (RatFunc C) (RatFunc S) := Algebra.toSMul + letI : SMul (RatFunc C) (ExactConstantExtension C N S) := Algebra.toSMul + letI : SMul (RatFunc S) (ExactConstantExtension C N S) := Algebra.toSMul + letI : Module (RatFunc S) (ExactConstantExtension C N S) := + Algebra.toModule + IsScalarTower (RatFunc C) (RatFunc S) + (ExactConstantExtension C N S) := by + let : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) (RatFunc S) := + ratFuncCoefficientAlgebra C S + let : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : Algebra (RatFunc S) (ExactConstantExtension C N S) := + ratFuncExactConstantExtensionAlgebra C S N hExact + let : SMul (RatFunc C) (RatFunc S) := Algebra.toSMul + let : SMul (RatFunc C) (ExactConstantExtension C N S) := Algebra.toSMul + let : SMul (RatFunc S) (ExactConstantExtension C N S) := Algebra.toSMul + let : Module (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toModule + let : Module (RatFunc S) (ExactConstantExtension C N S) := + Algebra.toModule + exact IsScalarTower.of_algebraMap_eq' + (rationalBase_algebraMap_eq C S N hExact) + +section FiniteTop + +variable [FiniteDimensional (RatFunc C) N] + +/-- If `N / C(X)` is finite, then the exact constant extension is finite over +the enlarged rational function field `S(X)`. -/ +theorem finiteDimensional_over_extendedRatFunc : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) (RatFunc S) := + ratFuncCoefficientAlgebra C S + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + letI : Algebra (RatFunc S) (ExactConstantExtension C N S) := + ratFuncExactConstantExtensionAlgebra C S N hExact + letI : SMul (RatFunc C) (RatFunc S) := Algebra.toSMul + letI : SMul (RatFunc C) (ExactConstantExtension C N S) := Algebra.toSMul + letI : SMul (RatFunc S) (ExactConstantExtension C N S) := Algebra.toSMul + letI : Module (RatFunc S) (ExactConstantExtension C N S) := + Algebra.toModule + FiniteDimensional (RatFunc S) (ExactConstantExtension C N S) := by + let : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + let : Algebra (RatFunc C) (RatFunc S) := + ratFuncCoefficientAlgebra C S + let : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : Algebra (RatFunc S) (ExactConstantExtension C N S) := + ratFuncExactConstantExtensionAlgebra C S N hExact + let : SMul (RatFunc C) (RatFunc S) := Algebra.toSMul + let : SMul (RatFunc C) (ExactConstantExtension C N S) := Algebra.toSMul + let : SMul (RatFunc S) (ExactConstantExtension C N S) := Algebra.toSMul + let : Module (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toModule + let : Module (RatFunc S) (ExactConstantExtension C N S) := + Algebra.toModule + let : IsScalarTower (RatFunc C) (RatFunc S) + (ExactConstantExtension C N S) := + rationalBase_scalarTower C S N hExact + let : Algebra N (ExactConstantExtension C N S) := + exactConstantExtensionAlgebra C N S + let : SMul N (ExactConstantExtension C N S) := Algebra.toSMul + let : Module N (ExactConstantExtension C N S) := Algebra.toModule + let : IsScalarTower (RatFunc C) N (ExactConstantExtension C N S) := + exactConstantExtensionBaseTower C (RatFunc C) N S + let e := exactConstantExtensionLinearEquiv C N S + let : Module.Finite N (N ⊗[C] S) := + Module.Finite.base_change C N S + let : Module.Finite N (ExactConstantExtension C N S) := + Module.Finite.equiv e + let : Module.Finite (RatFunc C) (ExactConstantExtension C N S) := + Module.Finite.trans N (ExactConstantExtension C N S) + exact Module.Finite.of_restrictScalars_finite + (RatFunc C) (RatFunc S) (ExactConstantExtension C N S) + +section SeparableTop + +variable [Algebra.IsSeparable (RatFunc C) N] + +include hExact + +omit [FiniteDimensional (RatFunc C) N] in +/-- For a finite separable `N / C(X)`, the exact constant extension remains +separable over the original rational function field `C(X)`. -/ +theorem isSeparable_exactConstantExtension_over_baseRatFunc : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + Algebra.IsSeparable (RatFunc C) (ExactConstantExtension C N S) := by + let : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + let : IsScalarTower C (RatFunc C) N := + IsScalarTower.of_algebraMap_eq' rfl + let : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : SMul (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toSMul + let : Module (RatFunc C) (ExactConstantExtension C N S) := + Algebra.toModule + let : Algebra N (ExactConstantExtension C N S) := + exactConstantExtensionAlgebra C N S + let : SMul N (ExactConstantExtension C N S) := Algebra.toSMul + let : Module N (ExactConstantExtension C N S) := Algebra.toModule + let : IsScalarTower (RatFunc C) N + (ExactConstantExtension C N S) := + exactConstantExtensionBaseTower C (RatFunc C) N S + let : IsGalois N (ExactConstantExtension C N S) := + exactConstantExtension_isGalois C N N S hExact + exact Algebra.IsSeparable.trans + (RatFunc C) N (ExactConstantExtension C N S) + +omit [FiniteDimensional (RatFunc C) N] in +/-- For a finite separable `N / C(X)`, the exact constant extension is separable +over the enlarged rational function field `S(X)`. -/ +theorem isSeparable_over_extendedRatFunc : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc C) (RatFunc S) := + ratFuncCoefficientAlgebra C S + letI : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + letI : Algebra (RatFunc S) (ExactConstantExtension C N S) := + ratFuncExactConstantExtensionAlgebra C S N hExact + letI : SMul (RatFunc C) (RatFunc S) := Algebra.toSMul + letI : SMul (RatFunc C) (ExactConstantExtension C N S) := Algebra.toSMul + letI : SMul (RatFunc S) (ExactConstantExtension C N S) := Algebra.toSMul + Algebra.IsSeparable (RatFunc S) (ExactConstantExtension C N S) := by + let : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + let : IsScalarTower C (RatFunc C) N := + IsScalarTower.of_algebraMap_eq' rfl + let : Algebra (RatFunc C) (RatFunc S) := + ratFuncCoefficientAlgebra C S + let : Algebra (RatFunc C) (ExactConstantExtension C N S) := + exactConstantExtensionBaseAlgebra C (RatFunc C) N S + let : Algebra (RatFunc S) (ExactConstantExtension C N S) := + ratFuncExactConstantExtensionAlgebra C S N hExact + let : SMul (RatFunc C) (RatFunc S) := Algebra.toSMul + let : SMul (RatFunc C) (ExactConstantExtension C N S) := Algebra.toSMul + let : SMul (RatFunc S) (ExactConstantExtension C N S) := Algebra.toSMul + let : IsScalarTower (RatFunc C) (RatFunc S) + (ExactConstantExtension C N S) := + rationalBase_scalarTower C S N hExact + let : Algebra N (ExactConstantExtension C N S) := + exactConstantExtensionAlgebra C N S + let : SMul N (ExactConstantExtension C N S) := Algebra.toSMul + let : Module N (ExactConstantExtension C N S) := Algebra.toModule + let : IsScalarTower (RatFunc C) N + (ExactConstantExtension C N S) := + exactConstantExtensionBaseTower C (RatFunc C) N S + let : IsGalois N (ExactConstantExtension C N S) := + exactConstantExtension_isGalois C N N S hExact + let : Algebra.IsSeparable (RatFunc C) (ExactConstantExtension C N S) := + isSeparable_exactConstantExtension_over_baseRatFunc C S N hExact + exact Algebra.isSeparable_tower_top_of_isSeparable + (RatFunc C) (RatFunc S) (ExactConstantExtension C N S) + +end SeparableTop + +end FiniteTop + +/-- The constant field, its rational function field, and the exact constant +extension form a scalar tower. -/ +theorem scalarTower_constant_ratFunc_exactConstantExtension : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc S) (ExactConstantExtension C N S) := + ratFuncExactConstantExtensionAlgebra C S N hExact + letI : SMul (RatFunc S) (ExactConstantExtension C N S) := + Algebra.toSMul + IsScalarTower S (RatFunc S) (ExactConstantExtension C N S) := by + let : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + let : Algebra (RatFunc S) (ExactConstantExtension C N S) := + ratFuncExactConstantExtensionAlgebra C S N hExact + let : SMul (RatFunc S) (ExactConstantExtension C N S) := + Algebra.toSMul + apply IsScalarTower.of_algebraMap_eq' + ext s + exact (ratFuncToExactConstantExtension C S N hExact).commutes s |>.symm + +section Normalization + +variable [Fintype C] [Finite S] + +/-- The polynomial normalization obtained after extending the constants is +the normalization used by the rational-function finite-place model. -/ +noncomputable def exactConstantExtensionNormalizationAlgEquiv : + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc S) (ExactConstantExtension C N S) := + ratFuncExactConstantExtensionAlgebra C S N hExact + letI : Algebra S[X] (S ⊗[C] integralClosure C[X] N) := + constantExtensionNormalizationTensorPolynomialAlgebra C S N + S ⊗[C] integralClosure C[X] N ≃ₐ[S[X]] + RatFuncFiniteIntegralClosure S (ExactConstantExtension C N S) := by + letI : Field (ExactConstantExtension C N S) := + exactConstantExtensionField C N S hExact + letI : Algebra (RatFunc S) (ExactConstantExtension C N S) := + ratFuncExactConstantExtensionAlgebra C S N hExact + letI : Algebra S[X] (S ⊗[C] integralClosure C[X] N) := + constantExtensionNormalizationTensorPolynomialAlgebra C S N + exact normalizationAlgEquivRatFuncFiniteOfAlgebraMap + S (ExactConstantExtension C N S) + (S ⊗[C] integralClosure C[X] N) + (constantExtensionTensorPolynomialAlgebra C S N) + (finiteFieldConstantExtensionIntegralClosurePolynomialAlgEquiv C S N) + (ratFuncToExactConstantExtension_algebraMap C S N hExact) + +end Normalization + +end Exact + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/RatFuncInfinityLocalization.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/RatFuncInfinityLocalization.lean new file mode 100644 index 0000000000..08da39146e --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/RatFuncInfinityLocalization.lean @@ -0,0 +1,459 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.InfinityInertiaDegree +public import Mathlib.Algebra.Polynomial.Reverse +public import Mathlib.RingTheory.Localization.AtPrime.Basic +public import Mathlib.RingTheory.Localization.Integral + +/-! +# The infinity valuation ring as a reciprocal localization + +Writing `Y = X⁻¹`, a rational function is regular at infinity exactly when +it belongs to the local ring `K[Y]_(Y)`. This file proves that statement for +the repository's valuation-ring model `RatFuncInfinityIntegers K`. + +The proof is explicit: a function of nonpositive integer degree is written +using the reversed numerator and denominator. This localization model is +the bridge needed to transport polynomial normalization under finite constant +extension to places above infinity. +-/ + +@[expose] public section + +open scoped Polynomial nonZeroDivisors + +open IsDedekindDomain Multiplicative WithZero + +namespace BGS.HasseWeil + +noncomputable section + +open BGS.CorvajaZannier + +variable (K : Type*) [Field K] [DecidableEq K] [DecidableEq (RatFunc K)] + +local instance : Algebra K (RatFuncInfinityIntegers K) := + (ratFuncInfinityConstantRingHom K).toAlgebra + +/-- Evaluate a polynomial in the reciprocal coordinate `X⁻¹`. -/ +noncomputable def reciprocalPolynomialRingHom : + K[X] →+* RatFuncInfinityIntegers K := + Polynomial.eval₂RingHom (ratFuncInfinityConstantRingHom K) + (ratFuncInfinityUniformizer K) + +/-- The polynomial algebra structure on the infinity valuation ring in the +reciprocal coordinate. Its variable is the uniformizer `X⁻¹`. -/ +@[reducible] +noncomputable def ratFuncInfinityReciprocalPolynomialAlgebra : + Algebra K[X] (RatFuncInfinityIntegers K) := + (reciprocalPolynomialRingHom K).toAlgebra + +local instance reciprocalPolynomialAlgebra : + Algebra K[X] (RatFuncInfinityIntegers K) := + ratFuncInfinityReciprocalPolynomialAlgebra K + +local instance reciprocalSpanXPrime : + (Ideal.span ({Polynomial.X} : Set K[X])).IsPrime := + (Ideal.span_singleton_prime Polynomial.X_ne_zero).mpr Polynomial.prime_X + +@[simp] theorem reciprocalPolynomialRingHom_X : + reciprocalPolynomialRingHom K Polynomial.X = + ratFuncInfinityUniformizer K := by + simp [reciprocalPolynomialRingHom] + +@[simp] theorem reciprocalPolynomialRingHom_C (c : K) : + reciprocalPolynomialRingHom K (Polynomial.C c) = + algebraMap K (RatFuncInfinityIntegers K) c := by + unfold reciprocalPolynomialRingHom + change Polynomial.eval₂ (ratFuncInfinityConstantRingHom K) + (ratFuncInfinityUniformizer K) (Polynomial.C c) = _ + rw [Polynomial.eval₂_C] + rfl + +@[simp] theorem reciprocalPolynomialAlgebraMap_eq (p : K[X]) : + algebraMap K[X] (RatFuncInfinityIntegers K) p = + reciprocalPolynomialRingHom K p := rfl + +@[simp] theorem reciprocalPolynomialRingHom_coe (p : K[X]) : + ((reciprocalPolynomialRingHom K p : + RatFuncInfinityIntegers K) : RatFunc K) = + Polynomial.eval₂ RatFunc.C (1 / RatFunc.X) p := by + induction p using Polynomial.induction_on' with + | add p q hp hq => + rw [map_add, Polynomial.eval₂_add] + change ((reciprocalPolynomialRingHom K p : + RatFuncInfinityIntegers K) : RatFunc K) + + ((reciprocalPolynomialRingHom K q : + RatFuncInfinityIntegers K) : RatFunc K) = _ + rw [hp, hq] + | monomial n c => + simp [reciprocalPolynomialRingHom, ratFuncInfinityUniformizer, + ratFuncInfinityConstantRingHom] + +theorem reciprocalPolynomialRingHom_isUnit_of_coeff_zero_ne_zero + (p : K[X]) (hp : p.coeff 0 ≠ 0) : + IsUnit (reciprocalPolynomialRingHom K p) := by + by_contra hunit + have hmap : reciprocalPolynomialRingHom K p ∈ + (ratFuncInfinityPlace K).asIdeal := by + change reciprocalPolynomialRingHom K p ∈ + IsLocalRing.maximalIdeal (RatFuncInfinityIntegers K) + rw [IsLocalRing.mem_maximalIdeal] + exact hunit + obtain ⟨r, hr⟩ := (Polynomial.X_dvd_sub_C (p := p)) + have hdiff : reciprocalPolynomialRingHom K + (p - Polynomial.C (p.coeff 0)) ∈ + (ratFuncInfinityPlace K).asIdeal := by + rw [hr, map_mul, reciprocalPolynomialRingHom_X] + rw [ratFuncInfinityPlace_span_uniformizer] + rw [mul_comm] + exact Ideal.mul_mem_left _ _ (Ideal.mem_span_singleton_self _) + have hconst : reciprocalPolynomialRingHom K + (Polynomial.C (p.coeff 0)) ∈ (ratFuncInfinityPlace K).asIdeal := by + have := (ratFuncInfinityPlace K).asIdeal.sub_mem hmap hdiff + simpa only [map_sub, sub_sub_cancel] using this + have hunit : IsUnit (reciprocalPolynomialRingHom K + (Polynomial.C (p.coeff 0))) := by + rw [reciprocalPolynomialRingHom_C] + exact (isUnit_iff_ne_zero.mpr hp).map + (algebraMap K (RatFuncInfinityIntegers K)) + change reciprocalPolynomialRingHom K (Polynomial.C (p.coeff 0)) ∈ + IsLocalRing.maximalIdeal (RatFuncInfinityIntegers K) at hconst + rw [IsLocalRing.mem_maximalIdeal] at hconst + exact hconst hunit + +theorem reciprocalPolynomialRingHom_injective : + Function.Injective (reciprocalPolynomialRingHom K) := by + intro p q hpq + apply sub_eq_zero.mp + have heval : Polynomial.eval₂ RatFunc.C (1 / RatFunc.X) (p - q) = 0 := by + have hzero : reciprocalPolynomialRingHom K (p - q) = 0 := by + rw [map_sub, hpq, sub_self] + have hzeroVal : + ((reciprocalPolynomialRingHom K (p - q) : + RatFuncInfinityIntegers K) : RatFunc K) = 0 := by + simpa using congrArg Subtype.val hzero + rw [reciprocalPolynomialRingHom_coe] at hzeroVal + exact hzeroVal + have htrans : Transcendental K ((RatFunc.X : RatFunc K)⁻¹) := by + rw [Transcendental, IsAlgebraic.inv_iff] + exact RatFunc.transcendental_X + rw [one_div] at heval + exact (transcendental_iff.mp htrans (p - q)) (by + simpa [Polynomial.aeval_def] using heval) + +omit [DecidableEq K] [DecidableEq (RatFunc K)] in +@[simp] theorem polynomialEvalRatFuncX_eq_algebraMap (p : K[X]) : + Polynomial.eval₂ RatFunc.C RatFunc.X p = + algebraMap K[X] (RatFunc K) p := by + induction p using Polynomial.induction_on' with + | add p q hp hq => simp [hp, hq] + | monomial n c => simp + +omit [DecidableEq K] [DecidableEq (RatFunc K)] in +theorem eval_reciprocal_reverse_mul_X_pow (p : K[X]) : + Polynomial.eval₂ RatFunc.C (1 / RatFunc.X) p.reverse * + RatFunc.X ^ p.natDegree = + algebraMap K[X] (RatFunc K) p := by + let : Invertible (RatFunc.X : RatFunc K) := + invertibleOfNonzero RatFunc.X_ne_zero + simpa [invOf_eq_inv, one_div] using + (Polynomial.eval₂_reverse_mul_pow RatFunc.C + (RatFunc.X : RatFunc K) p) + +theorem reciprocalPolynomialRingHom_surj + (z : RatFuncInfinityIntegers K) : + ∃ x : K[X] × (Ideal.span ({Polynomial.X} : Set K[X])).primeCompl, + z * algebraMap K[X] (RatFuncInfinityIntegers K) x.2 = + algebraMap K[X] (RatFuncInfinityIntegers K) x.1 := by + let f : RatFunc K := z + by_cases hf : f = 0 + · refine ⟨⟨0, ⟨1, ?_⟩⟩, ?_⟩ + · simp + · apply Subtype.ext + change f * _ = _ + simp [hf] + have hdegree : f.intDegree ≤ 0 := by + have hz := z.property + change RatFunc.inftyValuation K f ≤ 1 at hz + rw [RatFunc.inftyValuation_apply, + RatFunc.inftyValuation_of_nonzero K hf, + ← WithZero.exp_zero, WithZero.exp_le_exp] at hz + exact hz + have hnd : f.num.natDegree ≤ f.denom.natDegree := by + rw [RatFunc.intDegree] at hdegree + omega + let a : K[X] := f.num.reverse * + Polynomial.X ^ (f.denom.natDegree - f.num.natDegree) + let b : K[X] := f.denom.reverse + have hbcoeff : b.coeff 0 ≠ 0 := by + change f.denom.reverse.coeff 0 ≠ 0 + rw [Polynomial.coeff_zero_reverse] + exact Polynomial.leadingCoeff_ne_zero.mpr f.denom_ne_zero + have hb : b ∈ (Ideal.span ({Polynomial.X} : Set K[X])).primeCompl := by + change b ∉ Ideal.span ({Polynomial.X} : Set K[X]) + intro hspan + rw [Ideal.mem_span_singleton, Polynomial.X_dvd_iff] at hspan + exact hbcoeff hspan + refine ⟨⟨a, ⟨b, hb⟩⟩, ?_⟩ + apply Subtype.ext + change f * + ((algebraMap K[X] (RatFuncInfinityIntegers K) b : + RatFuncInfinityIntegers K) : RatFunc K) = + ((algebraMap K[X] (RatFuncInfinityIntegers K) a : + RatFuncInfinityIntegers K) : RatFunc K) + rw [reciprocalPolynomialAlgebraMap_eq, + reciprocalPolynomialAlgebraMap_eq, + reciprocalPolynomialRingHom_coe, + reciprocalPolynomialRingHom_coe] + apply (mul_right_cancel₀ (pow_ne_zero f.denom.natDegree + RatFunc.X_ne_zero)) + rw [mul_assoc] + have hden := eval_reciprocal_reverse_mul_X_pow K f.denom + have hnum := eval_reciprocal_reverse_mul_X_pow K f.num + change f * (Polynomial.eval₂ RatFunc.C (1 / RatFunc.X) b * + RatFunc.X ^ f.denom.natDegree) = + Polynomial.eval₂ RatFunc.C (1 / RatFunc.X) a * + RatFunc.X ^ f.denom.natDegree + rw [show Polynomial.eval₂ RatFunc.C (1 / RatFunc.X) b * + RatFunc.X ^ f.denom.natDegree = + algebraMap K[X] (RatFunc K) f.denom by exact hden] + have hleft : f * algebraMap K[X] (RatFunc K) f.denom = + algebraMap K[X] (RatFunc K) f.num := by + calc + f * algebraMap K[X] (RatFunc K) f.denom = + (algebraMap K[X] (RatFunc K) f.num / + algebraMap K[X] (RatFunc K) f.denom) * + algebraMap K[X] (RatFunc K) f.denom := by + congr 1 + exact (RatFunc.num_div_denom f).symm + _ = algebraMap K[X] (RatFunc K) f.num := + div_mul_cancel₀ _ + (RatFunc.algebraMap_ne_zero f.denom_ne_zero) + rw [hleft, ← hnum] + change Polynomial.eval₂ RatFunc.C (1 / RatFunc.X) f.num.reverse * + RatFunc.X ^ f.num.natDegree = + Polynomial.eval₂ RatFunc.C (1 / RatFunc.X) a * + RatFunc.X ^ f.denom.natDegree + rw [show Polynomial.eval₂ RatFunc.C (1 / RatFunc.X) a = + Polynomial.eval₂ RatFunc.C (1 / RatFunc.X) f.num.reverse * + (1 / RatFunc.X) ^ + (f.denom.natDegree - f.num.natDegree) by + simp [a]] + rw [mul_assoc] + congr 1 + rw [one_div, inv_pow] + rw [show RatFunc.X ^ f.denom.natDegree = + RatFunc.X ^ (f.denom.natDegree - f.num.natDegree) * + RatFunc.X ^ f.num.natDegree by + exact (pow_sub_mul_pow RatFunc.X hnd).symm] + rw [← mul_assoc, inv_mul_cancel₀] + · simp + · exact pow_ne_zero _ RatFunc.X_ne_zero + +/-- The infinity valuation ring is the localization of the reciprocal +polynomial coordinate ring at the origin. -/ +theorem ratFuncInfinityIntegers_isLocalization_reciprocal : + IsLocalization + (Ideal.span ({Polynomial.X} : Set K[X])).primeCompl + (RatFuncInfinityIntegers K) := by + rw [isLocalization_iff] + constructor + · intro y + apply reciprocalPolynomialRingHom_isUnit_of_coeff_zero_ne_zero K + intro hy0 + apply y.2 + change (y : K[X]) ∈ Ideal.span ({Polynomial.X} : Set K[X]) + rw [Ideal.mem_span_singleton, Polynomial.X_dvd_iff] + exact hy0 + constructor + · exact reciprocalPolynomialRingHom_surj K + · intro x y hxy + refine ⟨1, ?_⟩ + simp only [Submonoid.coe_one, one_mul] + exact reciprocalPolynomialRingHom_injective K hxy + +local instance ratFuncInfinityIntegersReciprocalLocalization : + IsLocalization + (Ideal.span ({Polynomial.X} : Set K[X])).primeCompl + (RatFuncInfinityIntegers K) := + ratFuncInfinityIntegers_isLocalization_reciprocal K + +/-- Canonical localization model for the infinity valuation ring, with the +polynomial variable corresponding to `X⁻¹`. -/ +noncomputable def reciprocalPolynomialAtOriginAlgEquivInfinityIntegers : + Localization.AtPrime (Ideal.span ({Polynomial.X} : Set K[X])) ≃ₐ[K[X]] + RatFuncInfinityIntegers K := + IsLocalization.algEquiv + (Ideal.span ({Polynomial.X} : Set K[X])).primeCompl + (Localization.AtPrime (Ideal.span ({Polynomial.X} : Set K[X]))) + (RatFuncInfinityIntegers K) + +section Extension + +variable (N : Type*) [Field N] [Algebra (RatFunc K) N] + +local instance infinityLocalizationConstantAlgebra : + Algebra K (RatFuncInfinityIntegers K) := + (ratFuncInfinityConstantRingHom K).toAlgebra + +local instance infinityLocalizationReciprocalPolynomialAlgebra : + Algebra K[X] (RatFuncInfinityIntegers K) := + ratFuncInfinityReciprocalPolynomialAlgebra K + +local instance infinityLocalizationSpanXPrime : + (Ideal.span ({Polynomial.X} : Set K[X])).IsPrime := + (Ideal.span_singleton_prime Polynomial.X_ne_zero).mpr Polynomial.prime_X + +/-- Reciprocal polynomial structure on an extension of `K(X)`. The variable +acts as the image of `X⁻¹`. -/ +@[reducible] +noncomputable def ratFuncExtensionReciprocalPolynomialAlgebra : + Algebra K[X] N := + RingHom.toAlgebra + ((algebraMap (RatFuncInfinityIntegers K) N).comp + (reciprocalPolynomialRingHom K)) + +local instance infinityLocalizationExtensionPolynomialAlgebra : + Algebra K[X] N := + ratFuncExtensionReciprocalPolynomialAlgebra K N + +local instance infinityLocalizationPolynomialTower : + IsScalarTower K[X] (RatFuncInfinityIntegers K) N := + IsScalarTower.of_algebraMap_eq' rfl + +local instance infinityLocalizationBase : + IsLocalization + (Ideal.span ({Polynomial.X} : Set K[X])).primeCompl + (RatFuncInfinityIntegers K) := + ratFuncInfinityIntegers_isLocalization_reciprocal K + +private theorem extensionReciprocalPolynomialAlgMap_injective : + Function.Injective (algebraMap K[X] N) := by + intro p q hpq + apply reciprocalPolynomialRingHom_injective K + apply Subtype.ext + apply (algebraMap (RatFunc K) N).injective + exact hpq + +local instance infinityLocalizationExtensionPolynomialFaithful : + FaithfulSMul K[X] N := by + rw [faithfulSMul_iff_algebraMap_injective] + exact extensionReciprocalPolynomialAlgMap_injective K N + +private theorem extensionReciprocalPrimeCompl_maps_nonzero : + (0 : N) ∉ Algebra.algebraMapSubmonoid N + (Ideal.span ({Polynomial.X} : Set K[X])).primeCompl := by + intro h0 + have hle := algebraMapSubmonoid_le_nonZeroDivisors_of_faithfulSMul + N (Ideal.span ({Polynomial.X} : Set K[X])).primeCompl_le_nonZeroDivisors + exact (nonZeroDivisors.ne_zero (hle h0)) rfl + +private theorem fieldSelf_isLocalization (M : Submonoid N) + (hM : (0 : N) ∉ M) : IsLocalization M N := by + rw [isLocalization_iff] + constructor + · intro y + exact isUnit_iff_ne_zero.mpr (fun hy ↦ hM (hy ▸ y.2)) + constructor + · intro z + exact ⟨⟨z, 1⟩, by simp⟩ + · intro x y hxy + exact ⟨1, by simpa using hxy⟩ + +local instance infinityLocalizationExtensionSelf : + IsLocalization + (Algebra.algebraMapSubmonoid N + (Ideal.span ({Polynomial.X} : Set K[X])).primeCompl) N := + fieldSelf_isLocalization N _ + (extensionReciprocalPrimeCompl_maps_nonzero K N) + +local instance reciprocalPolynomialInfinityIntegralClosureAlgebra : + Algebra K[X] (RatFuncInfinityIntegralClosure K N) := + RingHom.toAlgebra + ((algebraMap (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K N)).comp + (algebraMap K[X] (RatFuncInfinityIntegers K))) + +local instance reciprocalPolynomialInfinityIntegralClosureTower : + IsScalarTower K[X] (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K N) := + IsScalarTower.of_algebraMap_eq' rfl + +/-- Inclusion of the reciprocal affine normalization into its localization +at infinity. -/ +noncomputable def reciprocalIntegralClosureToInfinityAlgHom : + integralClosure K[X] N →ₐ[K[X]] RatFuncInfinityIntegralClosure K N := + { toFun := fun x ↦ ⟨x.1, x.2.tower_top⟩ + map_one' := rfl + map_mul' := fun _ _ ↦ rfl + map_zero' := rfl + map_add' := fun _ _ ↦ rfl + commutes' := fun _ ↦ rfl } + +/-- Algebra structure on the infinity normalization induced by localizing the +reciprocal affine normalization. -/ +@[reducible] +noncomputable def ratFuncInfinityReciprocalIntegralClosureAlgebra : + Algebra (integralClosure K[X] N) + (RatFuncInfinityIntegralClosure K N) := + (reciprocalIntegralClosureToInfinityAlgHom K N).toAlgebra + +local instance reciprocalIntegralClosureInfinityAlgebra : + Algebra (integralClosure K[X] N) + (RatFuncInfinityIntegralClosure K N) := + ratFuncInfinityReciprocalIntegralClosureAlgebra K N + +local instance reciprocalIntegralClosureInfinityAmbientTower : + IsScalarTower (integralClosure K[X] N) + (RatFuncInfinityIntegralClosure K N) N := + ⟨fun r s x ↦ by + simp only [Algebra.smul_def, map_mul] + change (r : N) * (s : N) * x = (r : N) * ((s : N) * x) + ring⟩ + +local instance reciprocalPolynomialIntegralClosuresTower : + IsScalarTower K[X] (integralClosure K[X] N) + (RatFuncInfinityIntegralClosure K N) := + IsScalarTower.of_algebraMap_eq fun p ↦ by + apply Subtype.ext + change algebraMap K[X] N p = algebraMap K[X] N p + rfl + +/-- The infinity integral closure is the localization of the reciprocal +affine normalization away from the origin. -/ +theorem ratFuncInfinityIntegralClosure_isLocalization_reciprocal : + IsLocalization + (Algebra.algebraMapSubmonoid (integralClosure K[X] N) + (Ideal.span ({Polynomial.X} : Set K[X])).primeCompl) + (RatFuncInfinityIntegralClosure K N) := by + let : IsScalarTower K[X] (integralClosure K[X] N) + (RatFuncInfinityIntegralClosure K N) := + reciprocalPolynomialIntegralClosuresTower K N + exact @IsLocalization.integralClosure + K[X] _ N _ (ratFuncExtensionReciprocalPolynomialAlgebra K N) + (RatFuncInfinityIntegers K) N _ _ + (ratFuncInfinityReciprocalPolynomialAlgebra K) + (inferInstance : Algebra N N) + (inferInstance : Algebra (RatFuncInfinityIntegers K) N) + (ratFuncExtensionReciprocalPolynomialAlgebra K N) + (inferInstance : IsScalarTower K[X] N N) + (infinityLocalizationPolynomialTower K N) + (Ideal.span ({Polynomial.X} : Set K[X])).primeCompl + (infinityLocalizationBase K) + (infinityLocalizationExtensionSelf K N) + (ratFuncInfinityReciprocalIntegralClosureAlgebra K N) + (reciprocalIntegralClosureInfinityAmbientTower K N) + (reciprocalPolynomialIntegralClosuresTower K N) + +end Extension + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/RatFuncParameterPole.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/RatFuncParameterPole.lean new file mode 100644 index 0000000000..741587fbca --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/RatFuncParameterPole.lean @@ -0,0 +1,317 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.DedekindRamifiedDerivationScaling +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionCanonicalDifferentDivisor +public import LeanPool.MarkoffModP.BGS.HasseWeil.PoleDivisor +public import Mathlib.Tactic + +/-! +# The rational parameter's pole divisor in a finite extension + +For a finite separable extension `L / K(X)`, the image of `RatFunc.X` is +integral at every finite place. At a place `P` above infinity its order is +exactly `-e(P)`, because `X⁻¹` is the uniformizer of the base infinity place. +Consequently its complete pole divisor is supported exactly above infinity, +with coefficient `e(P)`, and its height is `[L : K(X)]` by the +ramification--inertia degree formula. + +These statements do not require the constant field `K` to be finite. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +open BGS.CorvajaZannier +open IsDedekindDomain +open scoped nonZeroDivisors Polynomial BigOperators + +noncomputable section + +attribute [local instance] FractionRing.liftAlgebra + FractionRing.isScalarTower_liftAlgebra + +variable (K : Type*) [Field K] [DecidableEq K] + [DecidableEq (RatFunc K)] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +local instance (priority := 10) ratFuncParameterPolynomialAlgebra : + Algebra K[X] L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K[X] (RatFunc K))) + +local instance ratFuncParameterPolynomialScalarTower : + IsScalarTower K[X] (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + +local instance ratFuncParameterFiniteIntegralClosureModuleFinite : + Module.Finite K[X] (RatFuncFiniteIntegralClosure K L) := + Module.IsNoetherian.finite K[X] (RatFuncFiniteIntegralClosure K L) + +local instance ratFuncParameterFiniteIntegralClosureIsIntegral : + Algebra.IsIntegral K[X] (RatFuncFiniteIntegralClosure K L) := + IsIntegralClosure.isIntegral_algebra K[X] L + +local instance ratFuncParameterPolynomialTorsionFreeTop : + Module.IsTorsionFree K[X] L := + Module.IsTorsionFree.trans_faithfulSMul K[X] (RatFunc K) L + +local instance ratFuncParameterFiniteIntegralClosureIsTorsionFree : + Module.IsTorsionFree K[X] (RatFuncFiniteIntegralClosure K L) := + IsIntegralClosure.isTorsionFree K[X] L + +local instance ratFuncParameterInfinityIntegralClosureModuleFinite : + Module.Finite (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.finite (RatFuncInfinityIntegers K) (RatFunc K) L + (RatFuncInfinityIntegralClosure K L) + +local instance ratFuncParameterInfinityIntegralClosureIsIntegral : + Algebra.IsIntegral (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.isIntegral_algebra (RatFuncInfinityIntegers K) L + +local instance ratFuncParameterInfinityBaseTorsionFreeTop : + Module.IsTorsionFree (RatFuncInfinityIntegers K) L := + Module.IsTorsionFree.trans_faithfulSMul + (RatFuncInfinityIntegers K) (RatFunc K) L + +local instance ratFuncParameterInfinityIntegralClosureIsTorsionFree : + Module.IsTorsionFree (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.isTorsionFree (RatFuncInfinityIntegers K) L + +local instance ratFuncParameterInfinityIntegralClosureIsDedekindDomain : + IsDedekindDomain (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.isDedekindDomain + (RatFuncInfinityIntegers K) (RatFunc K) L + (RatFuncInfinityIntegralClosure K L) + +local instance ratFuncParameterInfinityIntegralClosureIsFractionRing : + IsFractionRing (RatFuncInfinityIntegralClosure K L) L := + IsIntegralClosure.isFractionRing_of_finite_extension + (RatFuncInfinityIntegers K) (RatFunc K) L + (RatFuncInfinityIntegralClosure K L) + +local instance ratFuncParameterInfinityPlaceFintype : + Fintype (FiniteExtensionInfinityPlace K L) := + Set.Finite.fintype + (IsDedekindDomain.primesOver_finite + (ratFuncInfinityPlace K).asIdeal + (RatFuncInfinityIntegralClosure K L)) + +omit [DecidableEq K] in +/-- The rational parameter `X` is integral at every finite place. -/ +theorem finiteExtensionPrincipalDivisor_ratFuncX_inl_nonnegative + (q : FiniteExtensionFinitePlace K L) : + 0 ≤ finiteExtensionPrincipalDivisor K L + (algebraMap (RatFunc K) L RatFunc.X) (.inl q) := by + classical + let S := RatFuncFiniteIntegralClosure K L + let e := ratFuncFiniteIntegralClosureFractionRingEquiv K L + let s : S := algebraMap K[X] S Polynomial.X + have hs : s ≠ 0 := by + have hinj : Function.Injective (algebraMap K[X] S) := + FunctionField.ringOfIntegers.algebraMap_injective K L + dsimp only [s] + exact (map_ne_zero_iff (algebraMap K[X] S) hinj).2 Polynomial.X_ne_zero + have hrepr : + e.symm (algebraMap (RatFunc K) L RatFunc.X) = + algebraMap S (FractionRing S) s := by + apply e.injective + rw [e.apply_symm_apply, e.commutes] + rfl + rw [finiteExtensionPrincipalDivisor_inl, hrepr] + exact finitePlaceOrder_algebraMap_nonnegative q s hs + +omit [DecidableEq K] in +private theorem finiteExtensionPrincipalDivisor_inr_eq_order + (x : L) (P : FiniteExtensionInfinityPlace K L) : + finiteExtensionPrincipalDivisor K L x (.inr P) = + finitePlaceOrder (primeOverHeightOne (ratFuncInfinityPlace K) P) x := by + classical + rw [finiteExtensionPrincipalDivisor_inr] + symm + simpa [ratFuncInfinityIntegralClosureFractionRingEquiv] using + fractionRingAlgEquiv_finitePlaceOrder_eq + (R := RatFuncInfinityIntegralClosure K L) (L := L) + (primeOverHeightOne (ratFuncInfinityPlace K) P) + ((ratFuncInfinityIntegralClosureFractionRingEquiv K L).symm x) + +omit [DecidableEq K] in +/-- At a place `P` above infinity, the rational parameter has order exactly +the negative ramification index. -/ +theorem finiteExtensionPrincipalDivisor_ratFuncX_inr_eq_neg_ramificationIdx + (P : FiniteExtensionInfinityPlace K L) : + finiteExtensionPrincipalDivisor K L + (algebraMap (RatFunc K) L RatFunc.X) (.inr P) = + -(P.1.ramificationIdx (RatFuncInfinityIntegers K) : ℤ) := by + classical + let q := primeOverHeightOne (ratFuncInfinityPlace K) P + let pi := ratFuncInfinityUniformizer K + let : q.asIdeal.LiesOver (ratFuncInfinityPlace K).asIdeal := by + simpa [q] using + (Ideal.primesOver.liesOver (ratFuncInfinityPlace K).asIdeal P) + have hpi0 : pi ≠ 0 := by + dsimp only [pi] + intro hzero + exact (ratFuncInfinityUniformizer_isUniformizer K).ne_zero + (congrArg Subtype.val hzero) + have hpiOrder : finitePlaceOrder q + (algebraMap (RatFuncInfinityIntegralClosure K L) L + (algebraMap (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) pi)) = + (P.1.ramificationIdx (RatFuncInfinityIntegers K) : ℤ) := by + exact finitePlaceOrder_algebraMap_uniformizer_eq_ramificationIdx + (ratFuncInfinityPlace K) q pi hpi0 + (ratFuncInfinityPlace_span_uniformizer K) + have hpiImage : algebraMap + (RatFuncInfinityIntegralClosure K L) L + (algebraMap (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) pi) = + (algebraMap (RatFunc K) L RatFunc.X)⁻¹ := by + change algebraMap (RatFunc K) L (1 / RatFunc.X) = + (algebraMap (RatFunc K) L RatFunc.X)⁻¹ + simp + have hX0 : algebraMap (RatFunc K) L RatFunc.X ≠ 0 := by + simpa using (algebraMap (RatFunc K) L).injective.ne RatFunc.X_ne_zero + have hinv := finitePlaceOrder_inv_eq_neg' q + (algebraMap (RatFunc K) L RatFunc.X) hX0 + rw [← hpiImage, hpiOrder] at hinv + rw [finiteExtensionPrincipalDivisor_inr_eq_order K L] + change finitePlaceOrder q (algebraMap (RatFunc K) L RatFunc.X) = _ + omega + +omit [DecidableEq K] in +/-- The pole divisor of the rational parameter vanishes at finite places. -/ +theorem finiteExtensionPoleDivisor_ratFuncX_inl_eq_zero + (q : FiniteExtensionFinitePlace K L) : + finiteExtensionPoleDivisor K L + (algebraMap (RatFunc K) L RatFunc.X) (.inl q) = 0 := by + classical + simp only [finiteExtensionPoleDivisor, Finsupp.neg_apply, + Finsupp.filter_apply] + rw [ite_eq_right (not_lt_of_ge + (finiteExtensionPrincipalDivisor_ratFuncX_inl_nonnegative K L q))] + simp + +omit [DecidableEq K] in +/-- Above infinity, the pole coefficient of the rational parameter is exactly +the ramification index. -/ +theorem finiteExtensionPoleDivisor_ratFuncX_inr_eq_ramificationIdx + (P : FiniteExtensionInfinityPlace K L) : + finiteExtensionPoleDivisor K L + (algebraMap (RatFunc K) L RatFunc.X) (.inr P) = + (P.1.ramificationIdx (RatFuncInfinityIntegers K) : ℤ) := by + classical + have he : 0 < P.1.ramificationIdx (RatFuncInfinityIntegers K) := + P.1.ramificationIdx_pos (RatFuncInfinityIntegers K) + simp only [finiteExtensionPoleDivisor, Finsupp.neg_apply, + Finsupp.filter_apply, + finiteExtensionPrincipalDivisor_ratFuncX_inr_eq_neg_ramificationIdx, + neg_lt_zero] + rw [ite_eq_left (by exact_mod_cast he)] + simp + +omit [DecidableEq K] in +/-- Pointwise description of the complete pole divisor of the rational +parameter: it is zero at finite places and has coefficient `e(P)` at every +place above infinity. -/ +theorem finiteExtensionPoleDivisor_ratFuncX_apply + (v : FiniteExtensionPlace K L) : + finiteExtensionPoleDivisor K L + (algebraMap (RatFunc K) L RatFunc.X) v = + match v with + | .inl _ => 0 + | .inr P => (P.1.ramificationIdx + (RatFuncInfinityIntegers K) : ℤ) := by + classical + cases v with + | inl q => exact finiteExtensionPoleDivisor_ratFuncX_inl_eq_zero K L q + | inr P => + exact finiteExtensionPoleDivisor_ratFuncX_inr_eq_ramificationIdx K L P + +omit [DecidableEq K] in +/-- The support of the pole divisor of the rational parameter consists +exactly of the places above infinity. -/ +theorem finiteExtensionPoleDivisor_ratFuncX_support : + (finiteExtensionPoleDivisor K L + (algebraMap (RatFunc K) L RatFunc.X)).support = + Finset.univ.map + (Function.Embedding.inr : + FiniteExtensionInfinityPlace K L ↪ FiniteExtensionPlace K L) := by + classical + ext v + cases v with + | inl q => + rw [Finsupp.mem_support_iff, finiteExtensionPoleDivisor_ratFuncX_inl_eq_zero] + simp + | inr P => + have he : 0 < P.1.ramificationIdx (RatFuncInfinityIntegers K) := + P.1.ramificationIdx_pos (RatFuncInfinityIntegers K) + rw [Finsupp.mem_support_iff, finiteExtensionPoleDivisor_ratFuncX_inr_eq_ramificationIdx] + simp [Nat.ne_of_gt he] + +omit [DecidableEq K] in +/-- The negative support of the principal divisor of the rational parameter +consists exactly of the places above infinity. -/ +theorem finiteExtensionPrincipalDivisor_ratFuncX_negativeSupport : + (finiteExtensionPrincipalDivisor K L + (algebraMap (RatFunc K) L RatFunc.X)).support.filter + (fun v => finiteExtensionPrincipalDivisor K L + (algebraMap (RatFunc K) L RatFunc.X) v < 0) = + Finset.univ.map + (Function.Embedding.inr : + FiniteExtensionInfinityPlace K L ↪ FiniteExtensionPlace K L) := by + classical + ext v + cases v with + | inl q => + constructor + · intro hv + have hneg := (Finset.mem_filter.mp hv).2 + exact (not_lt_of_ge + (finiteExtensionPrincipalDivisor_ratFuncX_inl_nonnegative K L q) + hneg).elim + · intro hv + simp at hv + | inr P => + have he : 0 < P.1.ramificationIdx (RatFuncInfinityIntegers K) := + P.1.ramificationIdx_pos (RatFuncInfinityIntegers K) + constructor + · intro _ + simp + · intro _ + apply Finset.mem_filter.mpr + constructor + · apply Finsupp.mem_support_iff.mpr + rw [finiteExtensionPrincipalDivisor_ratFuncX_inr_eq_neg_ramificationIdx] + exact neg_ne_zero.mpr (Int.natCast_ne_zero.mpr (Nat.ne_of_gt he)) + · rw [finiteExtensionPrincipalDivisor_ratFuncX_inr_eq_neg_ramificationIdx] + exact neg_lt_zero.mpr (Int.natCast_pos.mpr he) + +/-- The height of the rational parameter in a finite separable extension is +the extension degree. -/ +theorem finiteExtensionHeight_ratFuncX_eq_finrank : + finiteExtensionHeight K L (algebraMap (RatFunc K) L RatFunc.X) = + Module.finrank (RatFunc K) L := by + rw [finiteExtensionHeight, + finiteExtensionPrincipalDivisor_ratFuncX_negativeSupport K L] + rw [Finset.sum_map] + simp only [Function.Embedding.inr_apply, + finiteExtensionPrincipalDivisor_ratFuncX_inr_eq_neg_ramificationIdx, + neg_neg, Int.toNat_natCast, finiteExtensionPlaceDegree] + simpa only using + finiteExtensionInfinity_sum_ramification_inertia_eq_finrank K L + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/RationalPlace.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/RationalPlace.lean new file mode 100644 index 0000000000..2551852fc9 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/RationalPlace.lean @@ -0,0 +1,230 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.FiniteExtensionPrincipalDivisor +public import Mathlib.RingTheory.Polynomial.DegreeLT + +/-! +# Degree-one places of a finite function field + +This file defines the actual degree-one place type used by the fixed-field +argument and proves that it is finite over a finite constant field. The proof +does not assume a point-count bound: finite degree-one places inject into the +finite family of linear base primes together with their finite lying-over +fibers, while the places above infinity already form a finite lying-over +fiber. +-/ + +@[expose] public section + +open scoped Polynomial + +namespace BGS.HasseWeil + +noncomputable section + +open BGS.CorvajaZannier +open IsDedekindDomain + +variable (K : Type*) [Field K] [DecidableEq K] + +/-- Degree-one finite places of the rational function field `K(t)`. -/ +abbrev RatFuncRationalFinitePlace := + {P : HeightOneSpectrum K[X] // ratFuncFinitePlaceDegree P = 1} + +/-- Embed a degree-one rational-function-field place into the finite +coefficient space of polynomials of degree less than two. -/ +def ratFuncRationalFinitePlaceToDegreeLT : + RatFuncRationalFinitePlace K → Polynomial.degreeLT K 2 := fun P => by + let r := finitePlaceNormalizedPrime P.1 + refine ⟨(r : K[X]), Polynomial.mem_degreeLT.mpr ?_⟩ + have hr0 : (r : K[X]) ≠ 0 := r.property.1.ne_zero + have hrDegree : (r : K[X]).natDegree = 1 := by + simpa only [ratFuncFinitePlaceDegree] using P.2 + rw [Polynomial.degree_eq_natDegree hr0, hrDegree] + exact WithBot.coe_lt_coe.mpr (by omega) + +theorem ratFuncRationalFinitePlaceToDegreeLT_injective : + Function.Injective (ratFuncRationalFinitePlaceToDegreeLT K) := by + intro P Q hPQ + apply Subtype.ext + have hr : finitePlaceNormalizedPrime P.1 = finitePlaceNormalizedPrime Q.1 := by + apply Subtype.ext + exact congrArg + (fun r : Polynomial.degreeLT K 2 => (r.1 : K[X])) hPQ + simpa only [normalizedPrimeFinitePlace_finitePlaceNormalizedPrime] using + congrArg (normalizedPrimeFinitePlace (K := K)) hr + +/-- There are finitely many degree-one finite places of `K(t)` when `K` is +finite. -/ +noncomputable instance ratFuncRationalFinitePlace_finite [Finite K] : + Finite (RatFuncRationalFinitePlace K) := by + let : Finite (Fin 2 → K) := Pi.finite + let : Finite (Polynomial.degreeLT K 2) := + Finite.of_equiv (Fin 2 → K) (Polynomial.degreeLTEquiv K 2).toEquiv.symm + exact Finite.of_injective (ratFuncRationalFinitePlaceToDegreeLT K) + (ratFuncRationalFinitePlaceToDegreeLT_injective K) + +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + [DecidableEq (RatFunc K)] + +local instance (priority := 10) rationalPlacePolynomialAlgebra : Algebra K[X] L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K[X] (RatFunc K))) + +local instance rationalPlacePolynomialScalarTower : + IsScalarTower K[X] (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + +local instance rationalPlaceFiniteClosureModuleFinite : + Module.Finite K[X] (RatFuncFiniteIntegralClosure K L) := + Module.IsNoetherian.finite K[X] (RatFuncFiniteIntegralClosure K L) + +local instance rationalPlaceFiniteClosureIntegral : + Algebra.IsIntegral K[X] (RatFuncFiniteIntegralClosure K L) := + IsIntegralClosure.isIntegral_algebra K[X] L + +local instance rationalPlacePolynomialTorsionFreeTop : + Module.IsTorsionFree K[X] L := + Module.IsTorsionFree.trans_faithfulSMul K[X] (RatFunc K) L + +local instance rationalPlaceFiniteClosureTorsionFree : + Module.IsTorsionFree K[X] (RatFuncFiniteIntegralClosure K L) := + IsIntegralClosure.isTorsionFree K[X] L + +local instance rationalPlaceFiniteClosureDedekind : + IsDedekindDomain (RatFuncFiniteIntegralClosure K L) := + IsIntegralClosure.isDedekindDomain K[X] (RatFunc K) L + (RatFuncFiniteIntegralClosure K L) + +local instance rationalPlaceInfinityClosureModuleFinite : + Module.Finite (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.finite (RatFuncInfinityIntegers K) (RatFunc K) L + (RatFuncInfinityIntegralClosure K L) + +local instance rationalPlaceInfinityClosureIntegral : + Algebra.IsIntegral (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.isIntegral_algebra (RatFuncInfinityIntegers K) L + +local instance rationalPlaceInfinityClosureTorsionFree : + Module.IsTorsionFree (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.isTorsionFree (RatFuncInfinityIntegers K) L + +local instance rationalPlaceInfinityClosureDedekind : + IsDedekindDomain (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.isDedekindDomain (RatFuncInfinityIntegers K) + (RatFunc K) L (RatFuncInfinityIntegralClosure K L) + +/-- Degree-one finite places of a finite extension of `K(t)`. -/ +abbrev FiniteExtensionRationalFinitePlace := + {Q : FiniteExtensionFinitePlace K L // + finiteExtensionPlaceDegree K L (.inl Q) = 1} + +/-- Degree-one places above infinity of a finite extension of `K(t)`. -/ +abbrev FiniteExtensionRationalInfinityPlace := + {Q : FiniteExtensionInfinityPlace K L // + finiteExtensionPlaceDegree K L (.inr Q) = 1} + +/-- The exhaustive type of degree-one places of a finite extension of +`K(t)`, split into the finite and above-infinity parts. -/ +abbrev FiniteExtensionRationalPlace := + FiniteExtensionRationalFinitePlace K L ⊕ + FiniteExtensionRationalInfinityPlace K L + +/-- The split rational-place type is exactly the subtype of exhaustive places +whose place degree is one. -/ +def finiteExtensionRationalPlaceEquivSubtype : + FiniteExtensionRationalPlace K L ≃ + {P : FiniteExtensionPlace K L // + finiteExtensionPlaceDegree K L P = 1} where + toFun + | .inl P => ⟨.inl P.1, P.2⟩ + | .inr P => ⟨.inr P.1, P.2⟩ + invFun + | ⟨.inl Q, hQ⟩ => .inl ⟨Q, hQ⟩ + | ⟨.inr Q, hQ⟩ => .inr ⟨Q, hQ⟩ + left_inv P := by cases P <;> rfl + right_inv P := by rcases P with ⟨P, hP⟩; cases P <;> rfl + +/-- The number of degree-one places of the finite function field. -/ +def finiteExtensionRationalPlaceCount : ℕ := + Nat.card (FiniteExtensionRationalPlace K L) + +omit [FiniteDimensional (RatFunc K) L] [Algebra.IsSeparable (RatFunc K) L] in +theorem finiteExtensionRationalPlaceCount_eq_natCard_subtype : + finiteExtensionRationalPlaceCount K L = + Nat.card {P : FiniteExtensionPlace K L // + finiteExtensionPlaceDegree K L P = 1} := + Nat.card_congr (finiteExtensionRationalPlaceEquivSubtype K L) + +omit [FiniteDimensional (RatFunc K) L] [Algebra.IsSeparable (RatFunc K) L] in +private theorem rationalFinitePlace_baseDegree_eq_one + (Q : FiniteExtensionRationalFinitePlace K L) : + ratFuncFinitePlaceDegree (HeightOneSpectrum.under K[X] Q.1) = 1 := by + have hprod : + Q.1.asIdeal.inertiaDeg K[X] * + ratFuncFinitePlaceDegree (HeightOneSpectrum.under K[X] Q.1) = 1 := by + simpa only [finiteExtensionPlaceDegree] using Q.2 + exact Nat.eq_one_of_dvd_one ⟨Q.1.asIdeal.inertiaDeg K[X], by + simpa only [Nat.mul_comm] using hprod.symm⟩ + +/-- A rational finite place determines a rational base place together with a +prime in its finite lying-over fiber. -/ +def rationalFinitePlaceToBaseFiber + (Q : FiniteExtensionRationalFinitePlace K L) : + Σ P : RatFuncRationalFinitePlace K, + P.1.asIdeal.primesOver (RatFuncFiniteIntegralClosure K L) := + ⟨⟨HeightOneSpectrum.under K[X] Q.1, + by exact rationalFinitePlace_baseDegree_eq_one K L Q⟩, + ⟨Q.1.asIdeal, Q.1.isPrime, ⟨rfl⟩⟩⟩ + +omit [FiniteDimensional (RatFunc K) L] [Algebra.IsSeparable (RatFunc K) L] in +theorem rationalFinitePlaceToBaseFiber_injective : + Function.Injective (rationalFinitePlaceToBaseFiber K L) := by + intro Q R hQR + apply Subtype.ext + apply HeightOneSpectrum.ext + have hIdeals := congrArg + (fun z : Σ P : RatFuncRationalFinitePlace K, + P.1.asIdeal.primesOver (RatFuncFiniteIntegralClosure K L) => z.2.1) hQR + simpa only [rationalFinitePlaceToBaseFiber] using hIdeals + +/-- The degree-one finite places of a finite function field are finite over a +finite constant field. -/ +noncomputable instance finiteExtensionRationalFinitePlace_finite [Finite K] : + Finite (FiniteExtensionRationalFinitePlace K L) := by + let : Fintype (RatFuncRationalFinitePlace K) := Fintype.ofFinite _ + let (P : RatFuncRationalFinitePlace K) : + Fintype (P.1.asIdeal.primesOver (RatFuncFiniteIntegralClosure K L)) := + Set.Finite.fintype (IsDedekindDomain.primesOver_finite P.1.asIdeal + (RatFuncFiniteIntegralClosure K L)) + exact Finite.of_injective (rationalFinitePlaceToBaseFiber K L) + (rationalFinitePlaceToBaseFiber_injective K L) + +/-- The degree-one places above infinity are finite. -/ +noncomputable instance finiteExtensionRationalInfinityPlace_finite : + Finite (FiniteExtensionRationalInfinityPlace K L) := by + let : Fintype (FiniteExtensionInfinityPlace K L) := + Set.Finite.fintype (IsDedekindDomain.primesOver_finite + (ratFuncInfinityPlace K).asIdeal + (RatFuncInfinityIntegralClosure K L)) + infer_instance + +/-- The exhaustive degree-one place type is finite over a finite constant +field. -/ +noncomputable instance finiteExtensionRationalPlace_finite [Finite K] : + Finite (FiniteExtensionRationalPlace K L) := inferInstance + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/RationalPlaceTower.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/RationalPlaceTower.lean new file mode 100644 index 0000000000..058536ac26 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/RationalPlaceTower.lean @@ -0,0 +1,100 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionPlaceTower +public import LeanPool.MarkoffModP.BGS.HasseWeil.RationalPlace + +/-! +# Restriction of rational places in a function-field tower + +Place degree is multiplicative in a tower. Consequently a degree-one place +of the top field restricts to a degree-one place of every intermediate field, +and its relative residue degree is one. This file packages that consequence +for the repository's exhaustive finite/infinity place type. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +noncomputable section + +open BGS.CorvajaZannier + +variable (K : Type*) [Field K] [DecidableEq K] [DecidableEq (RatFunc K)] +variable (M : Type*) [Field M] [Algebra (RatFunc K) M] + [FiniteDimensional (RatFunc K) M] + [Algebra.IsSeparable (RatFunc K) M] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + [Algebra M L] [IsScalarTower (RatFunc K) M L] + +/-- A degree-one finite place of the top field restricts to a degree-one +finite place of the intermediate field. -/ +def rationalFinitePlaceUnder + (Q : FiniteExtensionRationalFinitePlace K L) : + FiniteExtensionRationalFinitePlace K M := by + refine ⟨finitePlaceUnder K M L Q.1, ?_⟩ + have hmul := + finiteExtensionPlaceDegree_inl_eq_mul_relativeInertiaDeg K M L Q.1 + rw [Q.2] at hmul + exact Nat.eq_one_of_dvd_one + ⟨finitePlaceRelativeInertiaDeg K M L Q.1, hmul⟩ + +/-- A degree-one place above infinity restricts to a degree-one place above +infinity in the intermediate field. -/ +def rationalInfinityPlaceUnder + (Q : FiniteExtensionRationalInfinityPlace K L) : + FiniteExtensionRationalInfinityPlace K M := by + refine ⟨infinityPlaceUnder K M L Q.1, ?_⟩ + have hmul := + finiteExtensionPlaceDegree_inr_eq_mul_relativeInertiaDeg K M L Q.1 + rw [Q.2] at hmul + exact Nat.eq_one_of_dvd_one + ⟨infinityPlaceRelativeInertiaDeg K M L Q.1, hmul⟩ + +/-- Restriction of an exhaustive degree-one place through an intermediate +function field. -/ +def rationalPlaceUnder : + FiniteExtensionRationalPlace K L → + FiniteExtensionRationalPlace K M + | .inl Q => .inl (rationalFinitePlaceUnder K M L Q) + | .inr Q => .inr (rationalInfinityPlaceUnder K M L Q) + +omit [FiniteDimensional (RatFunc K) M] [Algebra.IsSeparable (RatFunc K) M] + [FiniteDimensional (RatFunc K) L] [Algebra.IsSeparable (RatFunc K) L] in +/-- The relative residue degree of a rational finite place is one. -/ +theorem rationalFinitePlace_relativeInertiaDeg_eq_one + (Q : FiniteExtensionRationalFinitePlace K L) : + finitePlaceRelativeInertiaDeg K M L Q.1 = 1 := by + have hmul := + finiteExtensionPlaceDegree_inl_eq_mul_relativeInertiaDeg K M L Q.1 + rw [Q.2] at hmul + exact Nat.eq_one_of_dvd_one + ⟨finiteExtensionPlaceDegree K M + (.inl (finitePlaceUnder K M L Q.1)), by + simpa only [Nat.mul_comm] using hmul⟩ + +omit [FiniteDimensional (RatFunc K) M] [Algebra.IsSeparable (RatFunc K) M] + [FiniteDimensional (RatFunc K) L] [Algebra.IsSeparable (RatFunc K) L] in +/-- The relative residue degree of a rational place above infinity is one. -/ +theorem rationalInfinityPlace_relativeInertiaDeg_eq_one + (Q : FiniteExtensionRationalInfinityPlace K L) : + infinityPlaceRelativeInertiaDeg K M L Q.1 = 1 := by + have hmul := + finiteExtensionPlaceDegree_inr_eq_mul_relativeInertiaDeg K M L Q.1 + rw [Q.2] at hmul + exact Nat.eq_one_of_dvd_one + ⟨finiteExtensionPlaceDegree K M + (.inr (infinityPlaceUnder K M L Q.1)), by + simpa only [Nat.mul_comm] using hmul⟩ + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/RiemannSpaceConstants.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/RiemannSpaceConstants.lean new file mode 100644 index 0000000000..5a99483daf --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/RiemannSpaceConstants.lean @@ -0,0 +1,153 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.OnePointBase +public import Mathlib.FieldTheory.AlgebraicClosure + +/-! +# The zero-divisor Riemann space and the exact constant field + +The functions regular at every exhaustive place form a finite-dimensional +subalgebra of the function field. Consequently every such function is +algebraic over the constant field. When the relative algebraic closure of +the constants is trivial, this identifies `L(0)` with the image of the +constant field and gives its finrank exactly equal to one. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +open BGS.CorvajaZannier +open scoped Polynomial + +noncomputable section + + +variable (K : Type*) [Field K] [Fintype K] [DecidableEq K] + [DecidableEq (RatFunc K)] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +local instance regularConstantAlgebra : Algebra K L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K (RatFunc K))) + +local instance regularConstantTower : IsScalarTower K (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + +local instance regularInfinityNonempty : Nonempty (FiniteExtensionInfinityPlace K L) := by + let _ : Algebra.IsIntegral (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.isIntegral_algebra (RatFuncInfinityIntegers K) L + let _ : Module.IsTorsionFree (RatFuncInfinityIntegers K) L := + Module.IsTorsionFree.trans_faithfulSMul + (RatFuncInfinityIntegers K) (RatFunc K) L + let _ : Module.IsTorsionFree (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.isTorsionFree (RatFuncInfinityIntegers K) L + exact Ideal.nonempty_primesOver (ratFuncInfinityPlace K).asIdeal + +local instance regularPlaceNonempty : Nonempty (FiniteExtensionPlace K L) := + Nonempty.map Sum.inr (regularInfinityNonempty K L) + +/-- The subalgebra of functions regular at every exhaustive place. -/ +def finiteExtensionRegularSubalgebra : Subalgebra K L where + carrier := finiteExtensionRiemannSpace K L 0 + add_mem' := (finiteExtensionRiemannSpace K L 0).add_mem + zero_mem' := (finiteExtensionRiemannSpace K L 0).zero_mem + mul_mem' := by + intro x y hx hy + simpa using finiteExtensionRiemannSpace_mul_mem K L hx hy + one_mem' := by + simpa using algebraMap_mem_finiteExtensionRiemannSpace_of_effective + K L (D := 0) (by simp) (1 : K) + algebraMap_mem' := by + intro c + exact algebraMap_mem_finiteExtensionRiemannSpace_of_effective + K L (D := 0) (by simp) c + +@[simp] +theorem mem_finiteExtensionRegularSubalgebra {x : L} : + x ∈ finiteExtensionRegularSubalgebra K L ↔ + x ∈ finiteExtensionRiemannSpace K L 0 := Iff.rfl + +/-- The regular subalgebra and the zero-divisor Riemann space have the same +underlying vector space. -/ +def finiteExtensionRegularSubalgebraEquiv : + finiteExtensionRegularSubalgebra K L ≃ₗ[K] + finiteExtensionRiemannSpace K L 0 where + toFun x := ⟨x.1, x.2⟩ + invFun x := ⟨x.1, x.2⟩ + left_inv _ := rfl + right_inv _ := rfl + map_add' _ _ := rfl + map_smul' _ _ := rfl + +/-- The all-place zero-divisor Riemann space is finite-dimensional. -/ +theorem finiteExtensionRiemannSpace_zero_moduleFinite : + Module.Finite K (finiteExtensionRiemannSpace K L 0) := by + let Q : FiniteExtensionInfinityPlace K L := Classical.choice inferInstance + let P : FiniteExtensionPlace K L := .inr Q + have h := finiteExtensionOnePointRiemannSpace_zero_moduleFinite K L P + change Module.Finite K + (finiteExtensionRiemannSpace K L (Finsupp.single P (0 : ℤ))) at h + have hzero : Finsupp.single P (0 : ℤ) = + (0 : FiniteExtensionDivisor K L) := by + ext v + by_cases hv : v = P <;> simp [hv] + rw [hzero] at h + exact h + +/-- The everywhere-regular subalgebra is finite-dimensional. -/ +theorem finiteExtensionRegularSubalgebra_moduleFinite : + Module.Finite K (finiteExtensionRegularSubalgebra K L) := by + let : Module.Finite K (finiteExtensionRiemannSpace K L 0) := + finiteExtensionRiemannSpace_zero_moduleFinite K L + exact Module.Finite.equiv (finiteExtensionRegularSubalgebraEquiv K L).symm + +/-- With exact constants, every everywhere-regular function is a constant. -/ +theorem finiteExtensionRiemannSpace_zero_eq_range + (hconstants : algebraicClosure K L = ⊥) : + finiteExtensionRiemannSpace K L 0 = + LinearMap.range (Algebra.linearMap K L) := by + apply le_antisymm + · intro x hx + let : Module.Finite K (finiteExtensionRegularSubalgebra K L) := + finiteExtensionRegularSubalgebra_moduleFinite K L + let x' : finiteExtensionRegularSubalgebra K L := ⟨x, hx⟩ + have hxAlg' : IsAlgebraic K x' := IsAlgebraic.of_finite K x' + have hxAlg : IsAlgebraic K x := + hxAlg'.algHom (Subalgebra.val (finiteExtensionRegularSubalgebra K L)) + have hxClosure : x ∈ algebraicClosure K L := + mem_algebraicClosure_iff.mpr hxAlg + rw [hconstants] at hxClosure + obtain ⟨c, rfl⟩ := IntermediateField.mem_bot.mp hxClosure + exact ⟨c, rfl⟩ + · rintro x ⟨c, rfl⟩ + exact algebraMap_mem_finiteExtensionRiemannSpace_of_effective + K L (D := 0) (by simp) c + +/-- With exact constants, `L(0)` has dimension one. -/ +theorem finiteExtensionRiemannSpace_zero_finrank + (hconstants : algebraicClosure K L = ⊥) : + Module.finrank K (finiteExtensionRiemannSpace K L 0) = 1 := by + rw [finiteExtensionRiemannSpace_zero_eq_range K L hconstants] + have hinjective : Function.Injective (Algebra.linearMap K L) := + (algebraMap K L).injective + let e : K ≃ₗ[K] LinearMap.range (Algebra.linearMap K L) := + LinearEquiv.ofInjective (Algebra.linearMap K L) hinjective + calc + Module.finrank K (LinearMap.range (Algebra.linearMap K L)) = + Module.finrank K K := e.finrank_eq.symm + _ = 1 := Module.finrank_self K + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/RiemannSpaceEffectiveIncrement.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/RiemannSpaceEffectiveIncrement.lean new file mode 100644 index 0000000000..4a722e8c67 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/RiemannSpaceEffectiveIncrement.lean @@ -0,0 +1,279 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.OnePointDivisorSplit +public import LeanPool.MarkoffModP.BGS.HasseWeil.RiemannSpaceInfinityPlaceIncrement +public import LeanPool.MarkoffModP.BGS.HasseWeil.RiemannSpaceConstants +public import Mathlib.Tactic + +/-! +# Effective increments of exhaustive Riemann spaces + +The local finite- and infinity-place residue maps give the same one-place +dimension bound. This file first packages those two cases as a bound for an +arbitrary exhaustive place, then iterates over the coefficients and support +of an effective divisor. + +The final statements split an effective divisor at one selected place. They +are the linear-algebraic codimension estimates needed to pass from a +many-pole auxiliary space to a one-point Riemann space. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +open BGS.CorvajaZannier +open scoped Polynomial + +noncomputable section + + +variable (K : Type*) [Field K] [Fintype K] [DecidableEq K] + [DecidableEq (RatFunc K)] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +/-- The finite- and infinity-place increment lemmas together cover every +place in the exhaustive place type. -/ +theorem finiteExtensionRiemannSpace_place_increment + (D : FiniteExtensionDivisor K L) + (hD : ∀ v, 0 ≤ D v) + (P : FiniteExtensionPlace K L) + [Module.Finite K (finiteExtensionRiemannSpace K L D)] : + Module.Finite K (finiteExtensionRiemannSpace K L + (D + Finsupp.single P 1)) ∧ + Module.finrank K (finiteExtensionRiemannSpace K L + (D + Finsupp.single P 1)) ≤ + Module.finrank K (finiteExtensionRiemannSpace K L D) + + finiteExtensionPlaceDegree K L P := by + rcases P with q | P + · simpa using + (finiteExtensionRiemannSpace_finitePlace_increment K L D hD q) + · simpa using + (finiteExtensionRiemannSpace_infinityPlace_increment K L D hD P) + +/-- Adding `n` copies of one place raises dimension by at most `n` times the +degree of that place. -/ +theorem finiteExtensionRiemannSpace_natPlace_increment + (D : FiniteExtensionDivisor K L) + (hD : ∀ v, 0 ≤ D v) + (P : FiniteExtensionPlace K L) + (n : ℕ) + [Module.Finite K (finiteExtensionRiemannSpace K L D)] : + Module.Finite K (finiteExtensionRiemannSpace K L + (D + Finsupp.single P (n : ℤ))) ∧ + Module.finrank K (finiteExtensionRiemannSpace K L + (D + Finsupp.single P (n : ℤ))) ≤ + Module.finrank K (finiteExtensionRiemannSpace K L D) + + n * finiteExtensionPlaceDegree K L P := by + induction n with + | zero => + have hdivisor : + D + Finsupp.single P (((0 : ℕ) : ℤ)) = D := by + ext v + simp + rw [hdivisor] + simp only [zero_mul, add_zero] + constructor + · exact inferInstance + · exact le_rfl + | succ n ih => + let E : FiniteExtensionDivisor K L := + D + Finsupp.single P (n : ℤ) + have hE : ∀ v, 0 ≤ E v := by + intro v + by_cases hv : v = P + · subst v + dsimp only [E] + simp only [Finsupp.add_apply, Finsupp.single_eq_same] + exact add_nonneg (hD P) (by positivity) + · simpa [E, Finsupp.single_eq_of_ne hv] using hD v + let : Module.Finite K (finiteExtensionRiemannSpace K L E) := ih.1 + have hstep := finiteExtensionRiemannSpace_place_increment K L E hE P + have hdivisor : + D + Finsupp.single P ((n + 1 : ℕ) : ℤ) = + E + Finsupp.single P 1 := by + ext v + by_cases hv : v = P + · subst v + simp only [E, Finsupp.add_apply, Finsupp.single_eq_same] + push_cast + ring + · simp only [E, Finsupp.add_apply, + Finsupp.single_eq_of_ne hv] + ring + constructor + · rw [hdivisor] + exact hstep.1 + · rw [hdivisor] + calc + Module.finrank K (finiteExtensionRiemannSpace K L + (E + Finsupp.single P 1)) ≤ + Module.finrank K (finiteExtensionRiemannSpace K L E) + + finiteExtensionPlaceDegree K L P := hstep.2 + _ ≤ (Module.finrank K (finiteExtensionRiemannSpace K L D) + + n * finiteExtensionPlaceDegree K L P) + + finiteExtensionPlaceDegree K L P := + Nat.add_le_add_right ih.2 _ + _ = Module.finrank K (finiteExtensionRiemannSpace K L D) + + (n + 1) * finiteExtensionPlaceDegree K L P := by + simp only [Nat.add_mul, one_mul] + omega + +/-- Adding an effective divisor to an effective starting divisor preserves +finite-dimensionality, and its total dimension cost is at most its degree. -/ +theorem finiteExtensionRiemannSpace_add_effective + (D E : FiniteExtensionDivisor K L) + (hD : ∀ v, 0 ≤ D v) + (hE : ∀ v, 0 ≤ E v) + [Module.Finite K (finiteExtensionRiemannSpace K L D)] : + Module.Finite K (finiteExtensionRiemannSpace K L (D + E)) ∧ + Module.finrank K (finiteExtensionRiemannSpace K L (D + E)) ≤ + Module.finrank K (finiteExtensionRiemannSpace K L D) + + (finiteExtensionDivisorDegree K L E).toNat := by + let motive := fun E : FiniteExtensionDivisor K L => + (∀ v, 0 ≤ E v) → + Module.Finite K (finiteExtensionRiemannSpace K L (D + E)) ∧ + Module.finrank K (finiteExtensionRiemannSpace K L (D + E)) ≤ + Module.finrank K (finiteExtensionRiemannSpace K L D) + + (finiteExtensionDivisorDegree K L E).toNat + apply Finsupp.induction E (motive := motive) + · intro _ + rw [add_zero] + constructor + · exact inferInstance + · exact le_rfl + · intro P b E hP hb ih hsingleAdd + have hEP : E P = 0 := Finsupp.notMem_support_iff.mp hP + have hbNonneg : 0 ≤ b := by + have h := hsingleAdd P + simpa [hEP] using h + have hEeffective : ∀ v, 0 ≤ E v := by + intro v + by_cases hv : v = P + · subst v + simp [hEP] + · have h := hsingleAdd v + simpa [Finsupp.single_eq_of_ne hv] using h + have hih := ih hEeffective + let : Module.Finite K + (finiteExtensionRiemannSpace K L (D + E)) := hih.1 + have hDEeffective : ∀ v, 0 ≤ (D + E) v := by + intro v + exact add_nonneg (hD v) (hEeffective v) + have hmultiple := finiteExtensionRiemannSpace_natPlace_increment + K L (D + E) hDEeffective P b.toNat + have hdivisor : + D + (Finsupp.single P b + E) = + (D + E) + Finsupp.single P (b.toNat : ℤ) := by + rw [Int.toNat_of_nonneg hbNonneg] + abel + have hdegreeE : 0 ≤ finiteExtensionDivisorDegree K L E := + finiteExtensionDivisorDegree_nonnegative_of_effective K L E hEeffective + have hdegreeSingle : + 0 ≤ b * (finiteExtensionPlaceDegree K L P : ℤ) := + mul_nonneg hbNonneg (by positivity) + have hdegree : + (finiteExtensionDivisorDegree K L + (Finsupp.single P b + E)).toNat = + b.toNat * finiteExtensionPlaceDegree K L P + + (finiteExtensionDivisorDegree K L E).toNat := by + rw [finiteExtensionDivisorDegree_add, + finiteExtensionDivisorDegree_single, + Int.toNat_add hdegreeSingle hdegreeE, + Int.toNat_mul hbNonneg (by positivity)] + simp + constructor + · rw [hdivisor] + exact hmultiple.1 + · rw [hdivisor] + calc + Module.finrank K (finiteExtensionRiemannSpace K L + ((D + E) + Finsupp.single P (b.toNat : ℤ))) ≤ + Module.finrank K (finiteExtensionRiemannSpace K L (D + E)) + + b.toNat * finiteExtensionPlaceDegree K L P := hmultiple.2 + _ ≤ (Module.finrank K (finiteExtensionRiemannSpace K L D) + + (finiteExtensionDivisorDegree K L E).toNat) + + b.toNat * finiteExtensionPlaceDegree K L P := + Nat.add_le_add_right hih.2 _ + _ = Module.finrank K (finiteExtensionRiemannSpace K L D) + + (finiteExtensionDivisorDegree K L + (Finsupp.single P b + E)).toNat := by omega + exact hE + +/-- Every effective exhaustive divisor has a finite-dimensional Riemann +space. -/ +theorem finiteExtensionRiemannSpace_effective_moduleFinite + (D : FiniteExtensionDivisor K L) + (hD : ∀ v, 0 ≤ D v) : + Module.Finite K (finiteExtensionRiemannSpace K L D) := by + let : Module.Finite K + (finiteExtensionRiemannSpace K L (0 : FiniteExtensionDivisor K L)) := + finiteExtensionRiemannSpace_zero_moduleFinite K L + have h := finiteExtensionRiemannSpace_add_effective K L + (0 : FiniteExtensionDivisor K L) D (by simp) hD + rw [zero_add] at h + exact h.1 + +/-- Splitting an effective divisor at `P`, the discarded poles cost at most +the degree of the away part. -/ +theorem finiteExtensionRiemannSpace_finrank_le_onePoint_add_degreeAway + (D : FiniteExtensionDivisor K L) + (hD : ∀ v, 0 ≤ D v) + (P : FiniteExtensionPlace K L) : + Module.finrank K (finiteExtensionRiemannSpace K L D) ≤ + Module.finrank K + (finiteExtensionOnePointRiemannSpace K L P (D P).toNat) + + (finiteExtensionDivisorDegree K L + (finiteExtensionDivisorAway K L D P)).toNat := by + let A : FiniteExtensionDivisor K L := Finsupp.single P (D P) + let B : FiniteExtensionDivisor K L := finiteExtensionDivisorAway K L D P + have hA : ∀ v, 0 ≤ A v := by + intro v + by_cases hv : v = P + · subst v + simpa [A] using hD P + · simp [A, Finsupp.single_eq_of_ne hv] + have hB : ∀ v, 0 ≤ B v := by + exact finiteExtensionDivisorAway_effective K L D P hD + let : Module.Finite K (finiteExtensionRiemannSpace K L A) := + finiteExtensionRiemannSpace_effective_moduleFinite K L A hA + have hbound := finiteExtensionRiemannSpace_add_effective K L A B hA hB + have hsplit : A + B = D := by + exact single_add_finiteExtensionDivisorAway K L D P + have hcoeff : ((D P).toNat : ℤ) = D P := + Int.toNat_of_nonneg (hD P) + rw [hsplit] at hbound + change Module.finrank K (finiteExtensionRiemannSpace K L D) ≤ + Module.finrank K (finiteExtensionRiemannSpace K L + (Finsupp.single P ((D P).toNat : ℤ))) + + (finiteExtensionDivisorDegree K L + (finiteExtensionDivisorAway K L D P)).toNat + rw [hcoeff] + simpa only [A, B] using hbound.2 + +/-- Rearranged form of the away-degree estimate: the selected one-point +space retains at least the full dimension minus the away degree. -/ +theorem finiteExtensionOnePointRiemannSpace_finrank_lowerBound + (D : FiniteExtensionDivisor K L) + (hD : ∀ v, 0 ≤ D v) + (P : FiniteExtensionPlace K L) : + Module.finrank K (finiteExtensionRiemannSpace K L D) - + (finiteExtensionDivisorDegree K L + (finiteExtensionDivisorAway K L D P)).toNat ≤ + Module.finrank K + (finiteExtensionOnePointRiemannSpace K L P (D P).toNat) := by + have h := finiteExtensionRiemannSpace_finrank_le_onePoint_add_degreeAway + K L D hD P + omega + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/RiemannSpaceFinitePlaceIncrement.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/RiemannSpaceFinitePlaceIncrement.lean new file mode 100644 index 0000000000..91909f3b70 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/RiemannSpaceFinitePlaceIncrement.lean @@ -0,0 +1,406 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.OnePointBase +public import LeanPool.MarkoffModP.BGS.HasseWeil.OnePointLeadingCoefficient +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveAuxiliaryFinitePlaceCases +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveAuxiliaryFinitePlacePrincipalDivisor +public import Mathlib.RingTheory.Finiteness.Finsupp +public import Mathlib.Tactic + +/-! +# Riemann-space increments at finite places + +Use a normalized local lift and its leading residue to bound the dimension increase when one +finite place is added to a divisor. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +open BGS.CorvajaZannier +open scoped nonZeroDivisors Polynomial BigOperators +open IsDedekindDomain + +noncomputable section + + +section LocalLift + +variable {K R L : Type*} [Field K] [CommRing R] + [IsDedekindDomain R] [IsDiscreteValuationRing R] + [Field L] [Algebra K R] [Algebra R L] [Algebra K L] + [IsScalarTower K R L] [IsFractionRing R L] + +variable (T : Submodule K L) (a : L) +variable (hregular : ∀ x : T, ∃ r : R, a * x.1 = algebraMap R L r) + +noncomputable def localNormalizedLift (x : T) : R := + Classical.choose (hregular x) + +omit [IsDedekindDomain R] [IsDiscreteValuationRing R] [Algebra K R] [IsScalarTower K R L] + [IsFractionRing R L] in +theorem localNormalizedLift_spec (x : T) : + a * x.1 = algebraMap R L (localNormalizedLift T a hregular x) := + Classical.choose_spec (hregular x) + +omit [IsDedekindDomain R] [IsDiscreteValuationRing R] [Algebra K R] [IsScalarTower K R L] in +theorem localNormalizedLift_add (x y : T) : + localNormalizedLift T a hregular (x + y) = + localNormalizedLift T a hregular x + localNormalizedLift T a hregular y := by + apply IsFractionRing.injective R L + rw [map_add] + rw [← localNormalizedLift_spec T a hregular] + rw [← localNormalizedLift_spec T a hregular] + rw [← localNormalizedLift_spec T a hregular] + simp only [Submodule.coe_add] + ring + +omit [IsDedekindDomain R] [IsDiscreteValuationRing R] in +theorem localNormalizedLift_smul (c : K) (x : T) : + localNormalizedLift T a hregular (c • x) = + c • localNormalizedLift T a hregular x := by + apply IsFractionRing.injective R L + rw [show algebraMap R L (c • localNormalizedLift T a hregular x) = + c • algebraMap R L (localNormalizedLift T a hregular x) by + exact map_smul (IsScalarTower.toAlgHom K R L) c _] + rw [← localNormalizedLift_spec T a hregular] + rw [← localNormalizedLift_spec T a hregular] + simp only [Submodule.coe_smul] + rw [Algebra.smul_def, Algebra.smul_def] + ring + +noncomputable def localNormalizedLiftLinearMap : T →ₗ[K] R where + toFun := localNormalizedLift T a hregular + map_add' := localNormalizedLift_add T a hregular + map_smul' := localNormalizedLift_smul T a hregular + +noncomputable def localLeadingResidueLinearMap : + T →ₗ[K] IsLocalRing.ResidueField R := + (Ideal.Quotient.mkₐ K (IsLocalRing.maximalIdeal R)).toLinearMap.comp + (localNormalizedLiftLinearMap T a hregular) + +theorem localLeadingResidueLinearMap_eq_zero_iff (x : T) : + localLeadingResidueLinearMap T a hregular x = 0 ↔ + localNormalizedLift T a hregular x ∈ IsLocalRing.maximalIdeal R := by + exact IsLocalRing.residue_eq_zero_iff _ + +theorem mem_heightOneSpectrum_of_one_le_finitePlaceOrder_algebraMap + (v : HeightOneSpectrum R) (r : R) + (horder : (1 : ℤ) ≤ finitePlaceOrder v (algebraMap R L r)) : + r ∈ v.asIdeal := by + by_cases hr : r = 0 + · simp [hr] + · have hrMap : algebraMap R L r ≠ 0 := + by simpa using (IsFractionRing.injective R L).ne hr + have hvaluation := + valuation_eq_exp_neg_finitePlaceOrder v (algebraMap R L r) hrMap + rw [HeightOneSpectrum.valuation_of_algebraMap] at hvaluation + rw [← v.intValuation_lt_one_iff_mem] + rw [hvaluation, ← WithZero.exp_zero, WithZero.exp_lt_exp] + omega + +end LocalLift + +/-- A normalized lift has zero residue exactly when its local order is positive. -/ +theorem localNormalizedLift_mem_maximalIdeal_iff + {K R L : Type*} [Field K] [CommRing R] + [IsDedekindDomain R] [IsDiscreteValuationRing R] + [Field L] [Algebra K R] [Algebra R L] [Algebra K L] + [IsScalarTower K R L] [IsFractionRing R L] + (T : Submodule K L) (a : L) + (hregular : ∀ x : T, ∃ r : R, a * x.1 = algebraMap R L r) (x : T) : + localNormalizedLift T a hregular x ∈ IsLocalRing.maximalIdeal R ↔ + (1 : WithTop ℤ) ≤ finitePlaceOrderTop + (IsDiscreteValuationRing.maximalIdeal R) (a * x.1) := by + rw [localNormalizedLift_spec (R := R) T a hregular x] + let r := localNormalizedLift (R := R) T a hregular x + by_cases hr : r = 0 + · simp only [show localNormalizedLift T a hregular x = 0 from hr, + map_zero, Submodule.zero_mem, true_iff] + simp [finitePlaceOrderTop] + · have hrMap : algebraMap R L r ≠ 0 := + by simpa using (IsFractionRing.injective R L).ne hr + rw [finitePlaceOrderTop_eq_coe _ _ hrMap] + constructor + · intro hmem + exact_mod_cast one_le_finitePlaceOrder_algebraMap_of_mem (R := R) (L := L) + (IsDiscreteValuationRing.maximalIdeal R) r hmem hr + · intro horder + exact mem_heightOneSpectrum_of_one_le_finitePlaceOrder_algebraMap (R := R) (L := L) + (IsDiscreteValuationRing.maximalIdeal R) r (by exact_mod_cast horder) + + +section PlaceDegree + +variable (K : Type*) [Field K] [Fintype K] [DecidableEq K] + [DecidableEq (RatFunc K)] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +local instance upperConstantAlgebra : Algebra K L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K (RatFunc K))) + +local instance upperConstantTower : IsScalarTower K (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + +local instance (priority := 10) upperPolynomialAlgebra : Algebra K[X] L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K[X] (RatFunc K))) + +local instance upperPolynomialTower : IsScalarTower K[X] (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + +local instance upperFiniteClosureConstantAlgebra : + Algebra K (RatFuncFiniteIntegralClosure K L) := + RingHom.toAlgebra + ((algebraMap K[X] (RatFuncFiniteIntegralClosure K L)).comp + (algebraMap K K[X])) + +local instance upperFiniteClosureConstantTower : + IsScalarTower K K[X] (RatFuncFiniteIntegralClosure K L) := + IsScalarTower.of_algebraMap_eq' rfl + +local instance upperFiniteClosureIsIntegral : + Algebra.IsIntegral K[X] (RatFuncFiniteIntegralClosure K L) := + IsIntegralClosure.isIntegral_algebra K[X] L + +local instance upperFiniteClosureModuleFinite : + Module.Finite K[X] (RatFuncFiniteIntegralClosure K L) := + Module.IsNoetherian.finite K[X] (RatFuncFiniteIntegralClosure K L) + +local instance upperPolynomialTorsionFreeTop : Module.IsTorsionFree K[X] L := + Module.IsTorsionFree.trans_faithfulSMul K[X] (RatFunc K) L + +local instance upperFiniteClosureTorsionFree : + Module.IsTorsionFree K[X] (RatFuncFiniteIntegralClosure K L) := + IsIntegralClosure.isTorsionFree K[X] L + +local instance upperFiniteClosureDedekind : + IsDedekindDomain (RatFuncFiniteIntegralClosure K L) := + IsIntegralClosure.isDedekindDomain K[X] (RatFunc K) L + (RatFuncFiniteIntegralClosure K L) + +local instance upperFiniteClosureFractionRing : + IsFractionRing (RatFuncFiniteIntegralClosure K L) L := + IsIntegralClosure.isFractionRing_of_finite_extension + K[X] (RatFunc K) L (RatFuncFiniteIntegralClosure K L) + +/-- Adding one finite place to an effective divisor preserves finite +dimensionality. The dimension jump is at most the degree of that place. -/ +theorem finiteExtensionRiemannSpace_finitePlace_increment + (D : FiniteExtensionDivisor K L) + (hD : ∀ v, 0 ≤ D v) + (q : FiniteExtensionFinitePlace K L) + [Module.Finite K (finiteExtensionRiemannSpace K L D)] : + Module.Finite K (finiteExtensionRiemannSpace K L + (D + Finsupp.single (.inl q) 1)) ∧ + Module.finrank K (finiteExtensionRiemannSpace K L + (D + Finsupp.single (.inl q) 1)) ≤ + Module.finrank K (finiteExtensionRiemannSpace K L D) + + finiteExtensionPlaceDegree K L (.inl q) := by + let A := RatFuncFiniteIntegralClosure K L + let R := FiniteExtensionFinitePlaceLocalRing K L q + let Q : FiniteExtensionPlace K L := .inl q + let S := finiteExtensionRiemannSpace K L D + let T := finiteExtensionRiemannSpace K L (D + Finsupp.single Q 1) + let : Algebra (RatFuncFiniteIntegralClosure K L) + (RatFuncFiniteIntegralClosure K L) := + Algebra.id (RatFuncFiniteIntegralClosure K L) + let upperFiniteClosureLocalAlgebra : + Algebra (RatFuncFiniteIntegralClosure K L) + (FiniteExtensionFinitePlaceLocalRing K L q) := + OreLocalization.instAlgebra + let := upperFiniteClosureLocalAlgebra + let : SMul (RatFuncFiniteIntegralClosure K L) + (FiniteExtensionFinitePlaceLocalRing K L q) := + upperFiniteClosureLocalAlgebra.toSMul + let : Algebra K (FiniteExtensionFinitePlaceLocalRing K L q) := + OreLocalization.instAlgebra + let := finiteExtensionFinitePlaceLocalAlgebra (K := K) (L := L) q + let := finiteExtensionFinitePlaceLocalIsFractionRing (K := K) (L := L) q + let _ : FaithfulSMul R L := + (faithfulSMul_iff_algebraMap_injective R L).mpr (IsFractionRing.injective R L) + let : IsScalarTower K R L := by + apply IsScalarTower.of_algebraMap_eq' + ext c + symm + change finiteExtensionFinitePlaceLocalizationToField + (K := K) (L := L) q (algebraMap K R c) = algebraMap K L c + rw [show algebraMap K R c = + algebraMap A R (algebraMap K A c) by rfl] + rw [show finiteExtensionFinitePlaceLocalizationToField + (K := K) (L := L) q (algebraMap A R (algebraMap K A c)) = + algebraMap A L (algebraMap K A c) by + exact DFunLike.congr_fun + (finiteExtensionFinitePlaceLocalizationToField_comp_algebraMap + (K := K) (L := L) q) (algebraMap K A c)] + rfl + let : IsDiscreteValuationRing R := + IsLocalization.AtPrime.isDiscreteValuationRing_of_dedekind_domain + A q.ne_bot R + obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible R + have hπIdeal : + (IsDiscreteValuationRing.maximalIdeal R).asIdeal = Ideal.span {π} := + (IsDiscreteValuationRing.irreducible_iff_uniformizer π).mp hπ + let πL : L := algebraMap R L π + have hπOrder : + finiteExtensionFinitePlaceLocalOrderTop (K := K) (L := L) q πL = + (1 : WithTop ℤ) := by + change finitePlaceOrderTop + (IsDiscreteValuationRing.maximalIdeal R) πL = (1 : WithTop ℤ) + simpa [πL] using finitePlaceOrderTop_uniformizer_zpow + (L := L) (IsDiscreteValuationRing.maximalIdeal R) + π hπ hπIdeal (1 : ℤ) + let m : ℕ := (D Q).toNat + have hm : (m : ℤ) = D Q := by + exact Int.toNat_of_nonneg (hD Q) + let a : L := πL ^ (m + 1) + have hregular : ∀ x : T, ∃ r : R, + a * x.1 = algebraMap R L r := by + intro x + apply finiteExtensionFinitePlace_exists_local_lift_of_orderTop_nonnegative + (K := K) (L := L) q (a * x.1) + by_cases hx0 : x.1 = 0 + · simp [a, hx0, finiteExtensionFinitePlaceLocalOrderTop] + · have hxmem := (mem_finiteExtensionRiemannSpace (K := K) (L := L)).mp x.2 + rcases hxmem with hxmem | ⟨_, hxorders⟩ + · exact (hx0 hxmem).elim + · have hxQ := hxorders Q + simp only [Finsupp.add_apply, Finsupp.single_eq_same] at hxQ + rw [finiteExtensionFinitePlaceLocalOrderTop_mul, + show a = πL ^ (m + 1) by rfl, + finiteExtensionFinitePlaceLocalOrderTop_pow, + hπOrder, + finiteExtensionFinitePlaceLocalOrderTop_eq_principalDivisor + K L q x.1 hx0] + change (0 : WithTop ℤ) ≤ + (m + 1) • (1 : WithTop ℤ) + + (finiteExtensionFinitePrincipalDivisor K L x.1 q : WithTop ℤ) + rw [show (m + 1) • (1 : WithTop ℤ) = + ((m + 1 : ℕ) : WithTop ℤ) by simp] + exact_mod_cast (show 0 ≤ (m : ℤ) + 1 + + finiteExtensionFinitePrincipalDivisor K L x.1 q by + change 0 ≤ (m : ℤ) + 1 + + finiteExtensionPrincipalDivisor K L x.1 Q + rw [hm] + omega) + have hResidueRank : Module.finrank K (IsLocalRing.ResidueField R) = + finiteExtensionPlaceDegree K L (.inl q) := by + simpa [R] using + (finiteExtensionFinitePlace_degree_eq_finrank_residueField K L q).symm + let f := localLeadingResidueLinearMap (K := K) (R := R) (L := L) + T a hregular + have hST : S ≤ T := by + apply finiteExtensionRiemannSpace_mono + intro v + classical + by_cases hv : v = Q <;> simp [hv] + have hkerPoint (x : T) : f x = 0 ↔ x.1 ∈ S := by + rw [localLeadingResidueLinearMap_eq_zero_iff + (K := K) (R := R) (L := L) T a hregular, + localNormalizedLift_mem_maximalIdeal_iff] + constructor + · intro haxOrder + change (1 : WithTop ℤ) ≤ + finiteExtensionFinitePlaceLocalOrderTop (K := K) (L := L) q (a * x.1) at haxOrder + by_cases hx0 : x.1 = 0 + · simp [hx0] + · have hxQ : + 0 ≤ finiteExtensionPrincipalDivisor K L x.1 Q + D Q := by + rw [finiteExtensionFinitePlaceLocalOrderTop_mul, + show a = πL ^ (m + 1) by rfl, + finiteExtensionFinitePlaceLocalOrderTop_pow, + hπOrder, + finiteExtensionFinitePlaceLocalOrderTop_eq_principalDivisor + K L q x.1 hx0] at haxOrder + rw [show (m + 1) • (1 : WithTop ℤ) = + ((m + 1 : ℕ) : WithTop ℤ) by simp] at haxOrder + have haxOrderInt : 1 ≤ (m : ℤ) + 1 + + finiteExtensionPrincipalDivisor K L x.1 Q := by + exact_mod_cast haxOrder + rw [← hm] + omega + rw [mem_finiteExtensionRiemannSpace] + refine Or.inr ⟨hx0, ?_⟩ + intro v + by_cases hv : v = Q + · simpa [hv] using hxQ + · have hxmem := + (mem_finiteExtensionRiemannSpace (K := K) (L := L)).mp x.2 + rcases hxmem with hxmem | ⟨_, hxorders⟩ + · exact (hx0 hxmem).elim + · have hxv := hxorders v + simp only [Finsupp.add_apply, + Finsupp.single_eq_of_ne hv] at hxv + simpa using hxv + · intro hxS + by_cases hx0 : x.1 = 0 + · simp [hx0, finitePlaceOrderTop] + · have hxmem := + (mem_finiteExtensionRiemannSpace (K := K) (L := L)).mp hxS + rcases hxmem with hxmem | ⟨_, hxorders⟩ + · exact (hx0 hxmem).elim + · have hxQ := hxorders Q + have haxOrder : + (1 : WithTop ℤ) ≤ + finiteExtensionFinitePlaceLocalOrderTop + (K := K) (L := L) q (a * x.1) := by + rw [finiteExtensionFinitePlaceLocalOrderTop_mul, + show a = πL ^ (m + 1) by rfl, + finiteExtensionFinitePlaceLocalOrderTop_pow, + hπOrder, + finiteExtensionFinitePlaceLocalOrderTop_eq_principalDivisor + K L q x.1 hx0] + rw [show (m + 1) • (1 : WithTop ℤ) = + ((m + 1 : ℕ) : WithTop ℤ) by simp] + exact_mod_cast (show 1 ≤ (m : ℤ) + 1 + + finiteExtensionPrincipalDivisor K L x.1 Q by + rw [hm] + omega) + exact haxOrder + have hker : f.ker = Submodule.comap T.subtype S := by + ext x + rw [LinearMap.mem_ker, Submodule.mem_comap] + exact hkerPoint x + let : Finite (IsLocalRing.ResidueField R) := by + simpa [R] using + finiteExtensionFinitePlace_residueField_finite (K := K) (L := L) q + let : Module.Finite K (IsLocalRing.ResidueField R) := + Module.Finite.of_finite + let : Module.Finite K f.range := inferInstance + let : Module.Finite K f.ker := by + rw [hker] + exact Module.Finite.equiv (Submodule.comapSubtypeEquivOfLe hST).symm + let : Module.Finite K (T ⧸ f.ker) := + Module.Finite.equiv f.quotKerEquivRange.symm + let hTFinite : Module.Finite K T := + Module.Finite.of_submodule_quotient f.ker + have hkerRank : Module.finrank K f.ker = Module.finrank K S := by + rw [hker] + exact (Submodule.comapSubtypeEquivOfLe hST).finrank_eq + constructor + · exact hTFinite + · calc + Module.finrank K T = + Module.finrank K f.range + Module.finrank K f.ker := + f.finrank_range_add_finrank_ker.symm + _ ≤ Module.finrank K (IsLocalRing.ResidueField R) + + Module.finrank K S := + Nat.add_le_add f.range.finrank_le (le_of_eq hkerRank) + _ = Module.finrank K S + + finiteExtensionPlaceDegree K L (.inl q) := by + rw [hResidueRank, Nat.add_comm] + +end PlaceDegree + +end +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/RiemannSpaceInfinityPlaceIncrement.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/RiemannSpaceInfinityPlaceIncrement.lean new file mode 100644 index 0000000000..0933e64665 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/RiemannSpaceInfinityPlaceIncrement.lean @@ -0,0 +1,341 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.RiemannSpaceFinitePlaceIncrement + +/-! +# Riemann-space increments at infinity + +Identify the kernel of the leading-residue map and bound the dimension increase by the degree of +an infinite place. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +open BGS.CorvajaZannier +open scoped nonZeroDivisors Polynomial BigOperators +open IsDedekindDomain + +noncomputable section + + +private theorem finite_and_finrank_le_of_residue_map + {k E F : Type*} [Field k] [AddCommGroup E] [Module k E] + [AddCommGroup F] [Module k F] [Module.Finite k F] + (S T : Submodule k E) [Module.Finite k S] (hST : S ≤ T) + (f : T →ₗ[k] F) (hker : f.ker = Submodule.comap T.subtype S) : + Module.Finite k T ∧ Module.finrank k T ≤ Module.finrank k S + Module.finrank k F := by + let : Module.Finite k f.range := inferInstance + let : Module.Finite k f.ker := by + rw [hker] + exact Module.Finite.equiv (Submodule.comapSubtypeEquivOfLe hST).symm + let : Module.Finite k (T ⧸ f.ker) := + Module.Finite.equiv f.quotKerEquivRange.symm + let hTFinite : Module.Finite k T := Module.Finite.of_submodule_quotient f.ker + have hkerRank : Module.finrank k f.ker = Module.finrank k S := by + rw [hker] + exact (Submodule.comapSubtypeEquivOfLe hST).finrank_eq + refine ⟨hTFinite, ?_⟩ + calc + Module.finrank k T = Module.finrank k f.range + Module.finrank k f.ker := + f.finrank_range_add_finrank_ker.symm + _ ≤ Module.finrank k F + Module.finrank k S := + Nat.add_le_add f.range.finrank_le (le_of_eq hkerRank) + _ = Module.finrank k S + Module.finrank k F := Nat.add_comm _ _ + +section InfinityPlace + +variable (K : Type*) [Field K] [Fintype K] [DecidableEq K] + [DecidableEq (RatFunc K)] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +local instance infinityIncrementConstantAlgebra : Algebra K L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K (RatFunc K))) + +local instance infinityIncrementConstantTower : IsScalarTower K (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + +local instance upperInfinityConstantAlgebra : + Algebra K (RatFuncInfinityIntegers K) := + (ratFuncInfinityConstantRingHom K).toAlgebra + +local instance upperInfinityClosureConstantAlgebra : + Algebra K (RatFuncInfinityIntegralClosure K L) := + RingHom.toAlgebra + ((algebraMap (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L)).comp + (algebraMap K (RatFuncInfinityIntegers K))) + +local instance upperInfinityClosureConstantTower : + IsScalarTower K (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) := + IsScalarTower.of_algebraMap_eq' rfl + +local instance upperInfinityClosureModuleFinite : + Module.Finite (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.finite (RatFuncInfinityIntegers K) (RatFunc K) L + (RatFuncInfinityIntegralClosure K L) + +local instance upperInfinityClosureIsIntegral : + Algebra.IsIntegral (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.isIntegral_algebra (RatFuncInfinityIntegers K) L + +local instance upperInfinityBaseTorsionFreeTop : + Module.IsTorsionFree (RatFuncInfinityIntegers K) L := + Module.IsTorsionFree.trans_faithfulSMul + (RatFuncInfinityIntegers K) (RatFunc K) L + +local instance upperInfinityClosureTorsionFree : + Module.IsTorsionFree (RatFuncInfinityIntegers K) + (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.isTorsionFree (RatFuncInfinityIntegers K) L + +local instance upperInfinityClosureDedekind : + IsDedekindDomain (RatFuncInfinityIntegralClosure K L) := + IsIntegralClosure.isDedekindDomain + (RatFuncInfinityIntegers K) (RatFunc K) L + (RatFuncInfinityIntegralClosure K L) + +local instance upperInfinityClosureFractionRing : + IsFractionRing (RatFuncInfinityIntegralClosure K L) L := + IsIntegralClosure.isFractionRing_of_finite_extension + (RatFuncInfinityIntegers K) (RatFunc K) L + (RatFuncInfinityIntegralClosure K L) + +local instance upperInfinityClosureConstantTowerToField : + IsScalarTower K (RatFuncInfinityIntegralClosure K L) L := by + apply IsScalarTower.of_algebraMap_eq' + ext c + simp only [RingHom.comp_apply] + rw [IsScalarTower.algebraMap_apply K (RatFunc K) L] + rfl + +private noncomputable def infinityIncrementResidueFieldAlgEquivOfIdealEq + {I J : Ideal (RatFuncInfinityIntegralClosure K L)} + [I.IsPrime] [J.IsPrime] (h : I = J) : + I.ResidueField ≃ₐ[K] J.ResidueField := by + subst J + exact AlgEquiv.refl + +private noncomputable def infinityIncrementResidueFieldAlgEquiv + (P : FiniteExtensionInfinityPlace K L) : + (primeOverHeightOne (ratFuncInfinityPlace K) P).asIdeal.ResidueField + ≃ₐ[K] P.1.ResidueField := + infinityIncrementResidueFieldAlgEquivOfIdealEq K L + (primeOverHeightOne_asIdeal (ratFuncInfinityPlace K) P) + +/-- Adding one infinity place to an effective divisor preserves finite +dimensionality. The dimension jump is at most the degree of that place. -/ +theorem finiteExtensionRiemannSpace_infinityPlace_increment + (D : FiniteExtensionDivisor K L) + (hD : ∀ v, 0 ≤ D v) + (P : FiniteExtensionInfinityPlace K L) + [Module.Finite K (finiteExtensionRiemannSpace K L D)] : + Module.Finite K (finiteExtensionRiemannSpace K L + (D + Finsupp.single (.inr P) 1)) ∧ + Module.finrank K (finiteExtensionRiemannSpace K L + (D + Finsupp.single (.inr P) 1)) ≤ + Module.finrank K (finiteExtensionRiemannSpace K L D) + + finiteExtensionPlaceDegree K L (.inr P) := by + let A := RatFuncInfinityIntegralClosure K L + let R := FiniteExtensionInfinityPlaceLocalRing K L P + let Q : FiniteExtensionPlace K L := .inr P + let S := finiteExtensionRiemannSpace K L D + let T := finiteExtensionRiemannSpace K L (D + Finsupp.single Q 1) + let : Algebra (RatFuncInfinityIntegralClosure K L) + (RatFuncInfinityIntegralClosure K L) := + Algebra.id (RatFuncInfinityIntegralClosure K L) + let upperInfinityClosureLocalAlgebra : + Algebra (RatFuncInfinityIntegralClosure K L) + (FiniteExtensionInfinityPlaceLocalRing K L P) := + OreLocalization.instAlgebra + let := upperInfinityClosureLocalAlgebra + let : SMul (RatFuncInfinityIntegralClosure K L) + (FiniteExtensionInfinityPlaceLocalRing K L P) := + upperInfinityClosureLocalAlgebra.toSMul + let : Algebra K (FiniteExtensionInfinityPlaceLocalRing K L P) := + OreLocalization.instAlgebra + let := finiteExtensionInfinityPlaceLocalAlgebra (K := K) (L := L) P + let := finiteExtensionInfinityPlaceLocalIsFractionRing (K := K) (L := L) P + let : FaithfulSMul R L := + (faithfulSMul_iff_algebraMap_injective R L).mpr (IsFractionRing.injective R L) + let : IsScalarTower K R L := by + apply IsScalarTower.of_algebraMap_eq' + ext c + symm + change finiteExtensionInfinityPlaceLocalizationToField + (K := K) (L := L) P (algebraMap K R c) = algebraMap K L c + rw [show algebraMap K R c = + algebraMap A R (algebraMap K A c) by rfl] + rw [show finiteExtensionInfinityPlaceLocalizationToField + (K := K) (L := L) P (algebraMap A R (algebraMap K A c)) = + algebraMap A L (algebraMap K A c) by + exact DFunLike.congr_fun + (finiteExtensionInfinityPlaceLocalizationToField_comp_algebraMap + (K := K) (L := L) P) (algebraMap K A c)] + exact (IsScalarTower.algebraMap_apply K A L c).symm + let : IsDiscreteValuationRing R := + IsLocalization.AtPrime.isDiscreteValuationRing_of_dedekind_domain + A (primeOverHeightOne (ratFuncInfinityPlace K) P).ne_bot R + obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible R + have hπIdeal : + (IsDiscreteValuationRing.maximalIdeal R).asIdeal = Ideal.span {π} := + (IsDiscreteValuationRing.irreducible_iff_uniformizer π).mp hπ + let πL : L := algebraMap R L π + have hπOrder : + finiteExtensionInfinityPlaceLocalOrderTop (K := K) (L := L) P πL = + (1 : WithTop ℤ) := by + change finitePlaceOrderTop + (IsDiscreteValuationRing.maximalIdeal R) πL = (1 : WithTop ℤ) + simpa [πL] using finitePlaceOrderTop_uniformizer_zpow + (L := L) (IsDiscreteValuationRing.maximalIdeal R) + π hπ hπIdeal (1 : ℤ) + let m : ℕ := (D Q).toNat + have hm : (m : ℤ) = D Q := by + exact Int.toNat_of_nonneg (hD Q) + let a : L := πL ^ (m + 1) + have hregular : ∀ x : T, ∃ r : R, + a * x.1 = algebraMap R L r := by + intro x + apply finiteExtensionInfinityPlace_exists_local_lift_of_orderTop_nonnegative + (K := K) (L := L) P (a * x.1) + by_cases hx0 : x.1 = 0 + · simp only [hx0, mul_zero, finiteExtensionInfinityPlaceLocalOrderTop] + erw [finitePlaceOrderTop_zero] + exact le_top + · have hxmem := (mem_finiteExtensionRiemannSpace (K := K) (L := L)).mp x.2 + rcases hxmem with hxmem | ⟨_, hxorders⟩ + · exact (hx0 hxmem).elim + · have hxQ := hxorders Q + simp only [Finsupp.add_apply, Finsupp.single_eq_same] at hxQ + rw [finiteExtensionInfinityPlaceLocalOrderTop_mul, + show a = πL ^ (m + 1) by rfl, + finiteExtensionInfinityPlaceLocalOrderTop_pow, + hπOrder, + finiteExtensionInfinityPlaceLocalOrderTop_eq_globalOrder P x.1 hx0, + ← finiteExtensionPrincipalDivisor_inr_eq_infinityPlaceOrder + (K := K) (L := L) x.1 P] + rw [show (m + 1) • (1 : WithTop ℤ) = + ((m + 1 : ℕ) : WithTop ℤ) by simp] + exact_mod_cast (show 0 ≤ (m : ℤ) + 1 + + finiteExtensionPrincipalDivisor K L x.1 Q by + rw [hm] + omega) + have hResidueRank : Module.finrank K (IsLocalRing.ResidueField R) = + finiteExtensionPlaceDegree K L (.inr P) := by + change Module.finrank K + (primeOverHeightOne (ratFuncInfinityPlace K) P).asIdeal.ResidueField = _ + calc + Module.finrank K + (primeOverHeightOne (ratFuncInfinityPlace K) P).asIdeal.ResidueField = + Module.finrank K P.1.ResidueField := + (infinityIncrementResidueFieldAlgEquiv K L P).toLinearEquiv.finrank_eq + _ = finiteExtensionPlaceDegree K L (.inr P) := + (finiteExtensionInfinityPlace_degree_eq_finrank_residueField K L P).symm + let f := localLeadingResidueLinearMap (K := K) (R := R) (L := L) + T a hregular + have hST : S ≤ T := by + apply finiteExtensionRiemannSpace_mono + intro v + classical + by_cases hv : v = Q <;> simp [hv] + have hkerPoint (x : T) : f x = 0 ↔ x.1 ∈ S := by + rw [localLeadingResidueLinearMap_eq_zero_iff + (K := K) (R := R) (L := L) T a hregular, + localNormalizedLift_mem_maximalIdeal_iff] + constructor + · intro haxOrder + change (1 : WithTop ℤ) ≤ + finiteExtensionInfinityPlaceLocalOrderTop (K := K) (L := L) P (a * x.1) at haxOrder + by_cases hx0 : x.1 = 0 + · simp [hx0] + · have hxQ : + 0 ≤ finiteExtensionPrincipalDivisor K L x.1 Q + D Q := by + rw [finiteExtensionInfinityPlaceLocalOrderTop_mul, + show a = πL ^ (m + 1) by rfl, + finiteExtensionInfinityPlaceLocalOrderTop_pow, + hπOrder, + finiteExtensionInfinityPlaceLocalOrderTop_eq_globalOrder P x.1 hx0, + ← finiteExtensionPrincipalDivisor_inr_eq_infinityPlaceOrder + (K := K) (L := L) x.1 P] at haxOrder + rw [show (m + 1) • (1 : WithTop ℤ) = + ((m + 1 : ℕ) : WithTop ℤ) by simp] at haxOrder + have haxOrderInt : 1 ≤ (m : ℤ) + 1 + + finiteExtensionPrincipalDivisor K L x.1 Q := by + exact_mod_cast haxOrder + rw [← hm] + omega + rw [mem_finiteExtensionRiemannSpace] + refine Or.inr ⟨hx0, ?_⟩ + intro v + by_cases hv : v = Q + · simpa [hv] using hxQ + · have hxmem := + (mem_finiteExtensionRiemannSpace (K := K) (L := L)).mp x.2 + rcases hxmem with hxmem | ⟨_, hxorders⟩ + · exact (hx0 hxmem).elim + · have hxv := hxorders v + simp only [Finsupp.add_apply, + Finsupp.single_eq_of_ne hv] at hxv + simpa using hxv + · intro hxS + by_cases hx0 : x.1 = 0 + · simp [hx0, finitePlaceOrderTop] + · have hxmem := + (mem_finiteExtensionRiemannSpace (K := K) (L := L)).mp hxS + rcases hxmem with hxmem | ⟨_, hxorders⟩ + · exact (hx0 hxmem).elim + · have hxQ := hxorders Q + have haxOrder : + (1 : WithTop ℤ) ≤ + finiteExtensionInfinityPlaceLocalOrderTop + (K := K) (L := L) P (a * x.1) := by + rw [finiteExtensionInfinityPlaceLocalOrderTop_mul, + show a = πL ^ (m + 1) by rfl, + finiteExtensionInfinityPlaceLocalOrderTop_pow, + hπOrder, + finiteExtensionInfinityPlaceLocalOrderTop_eq_globalOrder P x.1 hx0, + ← finiteExtensionPrincipalDivisor_inr_eq_infinityPlaceOrder + (K := K) (L := L) x.1 P] + rw [show (m + 1) • (1 : WithTop ℤ) = + ((m + 1 : ℕ) : WithTop ℤ) by simp] + exact_mod_cast (show 1 ≤ (m : ℤ) + 1 + + finiteExtensionPrincipalDivisor K L x.1 Q by + rw [hm] + omega) + exact haxOrder + have hker : f.ker = Submodule.comap T.subtype S := by + ext x + rw [LinearMap.mem_ker, Submodule.mem_comap] + exact hkerPoint x + let : Finite (IsLocalRing.ResidueField R) := by + let : Finite P.1.ResidueField := + finiteExtensionInfinityPlace_residueField_finite (K := K) (L := L) P + change Finite + (primeOverHeightOne (ratFuncInfinityPlace K) P).asIdeal.ResidueField + exact Finite.of_injective + (infinityIncrementResidueFieldAlgEquiv K L P) + (infinityIncrementResidueFieldAlgEquiv K L P).injective + let : Module.Finite K (IsLocalRing.ResidueField R) := + Module.Finite.of_finite + have hbound := finite_and_finrank_le_of_residue_map S T hST f hker + refine ⟨hbound.1, ?_⟩ + rw [← hResidueRank] + exact hbound.2 + +end InfinityPlace + +end +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/SpectralFromAsymptotic.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/SpectralFromAsymptotic.lean new file mode 100644 index 0000000000..416b682b7e --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/SpectralFromAsymptotic.lean @@ -0,0 +1,182 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.PowerSum +public import LeanPool.MarkoffModP.BGS.HasseWeil.ZetaTrace + +/-! +# Spectral bounds from even power-sum asymptotics + +This file formalizes the elementary Corvaja--Zannier/Tao step that turns an +even-extension point-count asymptotic into the Riemann-hypothesis bound for +each Frobenius parameter. + +Repeated squared parameters must first be grouped. Their coefficients are +the positive cardinalities of their fibers, so the weighted power-sum lemma +from `BGS.HasseWeil.PowerSum` applies without an injectivity assumption on the +original family of parameters. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +open Filter Asymptotics +open scoped BigOperators + +noncomputable section + +/-- The finite set of distinct squared values occurring in `alpha`. -/ +def squaredBaseSet {N : ℕ} (alpha : Fin N → ℂ) : Finset ℂ := + Finset.univ.image fun i ↦ alpha i ^ 2 + +/-- The complex-valued multiplicity of a squared value occurring in `alpha`. -/ +def squaredBaseMultiplicity {N : ℕ} (alpha : Fin N → ℂ) (z : ℂ) : ℂ := + ((Finset.univ.filter fun i ↦ alpha i ^ 2 = z).card : ℂ) + +/-- Every squared value in `squaredBaseSet alpha` has positive, hence nonzero, +multiplicity. -/ +lemma squaredBaseMultiplicity_ne_zero_of_mem + {N : ℕ} {alpha : Fin N → ℂ} {z : ℂ} (hz : z ∈ squaredBaseSet alpha) : + squaredBaseMultiplicity alpha z ≠ 0 := by + classical + rw [squaredBaseSet, Finset.mem_image] at hz + rcases hz with ⟨i, hi, rfl⟩ + rw [squaredBaseMultiplicity] + have hmem : i ∈ Finset.univ.filter (fun j : Fin N ↦ alpha j ^ 2 = alpha i ^ 2) := by + exact Finset.mem_filter.mpr ⟨Finset.mem_univ i, rfl⟩ + have hcard : + (Finset.univ.filter (fun j : Fin N ↦ alpha j ^ 2 = alpha i ^ 2)).card ≠ 0 := + Finset.card_ne_zero.mpr ⟨i, hmem⟩ + exact_mod_cast hcard + +/-- Grouping repeated squared values with their multiplicities recovers the +original even power sum. -/ +lemma weightedPowerSum_squaredBaseMultiplicity + {N : ℕ} (alpha : Fin N → ℂ) (n : ℕ) : + weightedPowerSum (squaredBaseSet alpha) (squaredBaseMultiplicity alpha) n = + ∑ i, alpha i ^ (2 * n) := by + classical + rw [weightedPowerSum, squaredBaseSet] + calc + ∑ z ∈ Finset.univ.image (fun i ↦ alpha i ^ 2), + squaredBaseMultiplicity alpha z * z ^ n = + ∑ z ∈ Finset.univ.image (fun i ↦ alpha i ^ 2), + ∑ i ∈ Finset.univ with alpha i ^ 2 = z, (alpha i ^ 2) ^ n := by + apply Finset.sum_congr rfl + intro z hz + rw [squaredBaseMultiplicity] + calc + ((Finset.univ.filter fun i ↦ alpha i ^ 2 = z).card : ℂ) * z ^ n = + ∑ _i ∈ Finset.univ.filter (fun i ↦ alpha i ^ 2 = z), z ^ n := by simp + _ = ∑ i ∈ Finset.univ with alpha i ^ 2 = z, (alpha i ^ 2) ^ n := by + apply Finset.sum_congr rfl + intro i hi + rw [(Finset.mem_filter.mp hi).2] + _ = ∑ i, (alpha i ^ 2) ^ n := + Finset.sum_fiberwise_of_maps_to + (fun i hi ↦ Finset.mem_image.mpr ⟨i, hi, rfl⟩) (fun i ↦ (alpha i ^ 2) ^ n) + _ = ∑ i, alpha i ^ (2 * n) := by + apply Finset.sum_congr rfl + intro i hi + rw [pow_mul] + +/-- An `O(q ^ n)` bound for all even power sums forces every spectral +parameter to have norm at most `sqrt q`. + +The `IsBigO` hypothesis already allows an arbitrary fixed multiplicative +constant. -/ +theorem spectral_norm_le_sqrt_of_evenPowerSum_isBigO + {N : ℕ} {q : ℝ} (alpha : Fin N → ℂ) + (hq : 0 ≤ q) + (hO : (fun n : ℕ ↦ ∑ i, alpha i ^ (2 * n)) =O[atTop] + fun n : ℕ ↦ q ^ n) : + ∀ i, ‖alpha i‖ ≤ Real.sqrt q := by + classical + have hgrouped : + weightedPowerSum (squaredBaseSet alpha) (squaredBaseMultiplicity alpha) =O[atTop] + fun n : ℕ ↦ q ^ n := + hO.congr_left fun n ↦ (weightedPowerSum_squaredBaseMultiplicity alpha n).symm + have hall := weightedPowerSum_base_norm_le hq + (fun z hz ↦ squaredBaseMultiplicity_ne_zero_of_mem hz) hgrouped + intro i + have hmem : alpha i ^ 2 ∈ squaredBaseSet alpha := by + rw [squaredBaseSet] + exact Finset.mem_image.mpr ⟨i, Finset.mem_univ i, rfl⟩ + have hsquare : ‖alpha i ^ 2‖ ≤ q := hall (alpha i ^ 2) hmem + have hnormSquare : ‖alpha i‖ ^ 2 ≤ q := by + simpa only [norm_pow] using hsquare + exact (Real.le_sqrt (norm_nonneg _) hq).2 hnormSquare + +/-- It is enough to control the even power sums along any fixed positive +divisible subsequence. -/ +theorem spectral_norm_le_sqrt_of_divisibleEvenPowerSum_isBigO + {N δ : ℕ} {q : ℝ} (alpha : Fin N → ℂ) + (hq : 0 < q) (hδ : 0 < δ) + (hO : (fun n : ℕ ↦ ∑ i, alpha i ^ (2 * δ * n)) =O[atTop] + fun n : ℕ ↦ (q ^ δ) ^ n) : + ∀ i, ‖alpha i‖ ≤ Real.sqrt q := by + classical + have hO' : + (fun n : ℕ ↦ ∑ i, (alpha i ^ δ) ^ (2 * n)) =O[atTop] + fun n : ℕ ↦ (q ^ δ) ^ n := + hO.congr_left fun n ↦ by + apply Finset.sum_congr rfl + intro i hi + calc + alpha i ^ (2 * δ * n) = alpha i ^ (δ * (2 * n)) := by + congr 1 + ac_rfl + _ = (alpha i ^ δ) ^ (2 * n) := by rw [pow_mul] + have hpowered := spectral_norm_le_sqrt_of_evenPowerSum_isBigO + (fun i ↦ alpha i ^ δ) (pow_nonneg hq.le δ) hO' + intro i + have hsquared : + ‖alpha i ^ δ‖ ^ 2 ≤ (Real.sqrt (q ^ δ)) ^ 2 := + pow_le_pow_left₀ (norm_nonneg _) (hpowered i) 2 + have hpow : (‖alpha i‖ ^ 2) ^ δ ≤ q ^ δ := by + calc + (‖alpha i‖ ^ 2) ^ δ = ‖alpha i‖ ^ (2 * δ) := by rw [pow_mul] + _ = ‖alpha i‖ ^ (δ * 2) := by + congr 1 + ac_rfl + _ = (‖alpha i‖ ^ δ) ^ 2 := by rw [pow_mul] + _ = ‖alpha i ^ δ‖ ^ 2 := by rw [norm_pow] + _ ≤ (Real.sqrt (q ^ δ)) ^ 2 := hsquared + _ = q ^ δ := Real.sq_sqrt (pow_nonneg hq.le δ) + have hnormSquare : ‖alpha i‖ ^ 2 ≤ q := + le_of_pow_le_pow_left₀ hδ.ne' hq.le hpow + exact (Real.le_sqrt (norm_nonneg _) hq.le).2 hnormSquare + +/-- The Hasse point-count inequality obtained from a spectral point-count +formula and the even-power-sum asymptotic. -/ +theorem abs_pointCount_sub_card_sub_one_le_of_evenPowerSum_isBigO + (q g pointCount : ℕ) (alpha : Fin (2 * g) → ℂ) + (hformula : HasPointCountSpectralFormula q g pointCount alpha) + (hO : (fun n : ℕ ↦ ∑ i, alpha i ^ (2 * n)) =O[atTop] + fun n : ℕ ↦ (q : ℝ) ^ n) : + |(pointCount : ℝ) - q - 1| ≤ (2 * g : ℝ) * Real.sqrt q := by + apply abs_pointCount_sub_card_sub_one_le_of_spectralFormula q g pointCount alpha hformula + exact spectral_norm_le_sqrt_of_evenPowerSum_isBigO alpha (by positivity) hO + +/-- The degree-one Hasse bound follows from a power-sum estimate on any fixed +positive divisible-even subsequence. -/ +theorem abs_pointCount_sub_card_sub_one_le_of_divisibleEvenPowerSum_isBigO + (q g pointCount δ : ℕ) (alpha : Fin (2 * g) → ℂ) + (hq : 0 < q) (hδ : 0 < δ) + (hformula : HasPointCountSpectralFormula q g pointCount alpha) + (hO : (fun n : ℕ ↦ ∑ i, alpha i ^ (2 * δ * n)) =O[atTop] + fun n : ℕ ↦ ((q : ℝ) ^ δ) ^ n) : + |(pointCount : ℝ) - q - 1| ≤ (2 * g : ℝ) * Real.sqrt q := by + apply abs_pointCount_sub_card_sub_one_le_of_spectralFormula q g pointCount alpha hformula + exact spectral_norm_le_sqrt_of_divisibleEvenPowerSum_isBigO alpha + (by exact_mod_cast hq) hδ hO + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/SquareExtensionAffinePlaces.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/SquareExtensionAffinePlaces.lean new file mode 100644 index 0000000000..76d867ab56 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/SquareExtensionAffinePlaces.lean @@ -0,0 +1,876 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.AffinePointPlace +public import LeanPool.MarkoffModP.BGS.HasseWeil.ExtensionPointCount +public import LeanPool.MarkoffModP.BGS.HasseWeil.FiniteExtensionZeroCounting +public import LeanPool.MarkoffModP.BGS.HasseWeil.OnePointLeadingCoefficient +public import Mathlib.FieldTheory.Finite.GaloisField +public import Mathlib.Tactic + +/-! +# Quadratic-extension affine points and base-field places + +An affine point over the quadratic constant-field extension does not in +general determine a distinct place of the base function field: its Frobenius +conjugate has the same affine centre. This file therefore passes through the +maximal ideal of the base coordinate ring and keeps the residue-degree +weight. Fibres over a closed affine centre have cardinality at most the +degree of its residue field (and hence at most two). + +The selected normalization place above each closed centre may have larger +residue field at a singular point. This only strengthens the weighted +count. The final estimate bounds all quadratic-extension affine points by +the positive divisor degree, and by the height for a nonzero function. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +open BGS.CorvajaZannier +open IsDedekindDomain +open scoped BigOperators nonZeroDivisors Polynomial + +noncomputable section + +private theorem exists_dominatingPlace_of_nonzero_nonunit + {A P E : Type*} [CommRing A] [IsDomain A] [CommRing P] [Field E] + [Algebra A E] [IsFractionRing A E] [Algebra P E] + [IsDedekindDomain (integralClosure P E)] [IsFractionRing (integralClosure P E) E] + (m : MaximalSpectrum A) + (hbase : ∀ x : P, algebraMap P E x ∈ (algebraMap A E).range) + (b : integralClosure P E) (hb : b ≠ 0) + (hunit : (b : E) ∈ (dominatingValuationSubring (L := E) m).nonunits) : + ∃ q : HeightOneSpectrum (integralClosure P E), + IsDedekindDomain.HeightOneSpectrum.valuationSubringAtPrime E q = + dominatingValuationSubring (L := E) m := by + let V := dominatingValuationSubring (L := E) m + have hV : V ≠ ⊤ := by + intro htop + have hnontrivial : V.valuation.IsNontrivial := + (Valuation.isNontrivial_iff_exists_lt_one V.valuation).2 + ⟨(b : E), Subtype.coe_ne_coe.mpr hb, hunit⟩ + exact ((ValuationSubring.eq_top_iff V).mp htop) hnontrivial + have hbMem : b ∈ dominatingIntegralClosurePrime m hbase := by + change integralClosureToDominatingValuationSubring m hbase b ∈ + IsLocalRing.maximalIdeal V + exact ValuationSubring.coe_mem_nonunits_iff.mp hunit + have hne : dominatingIntegralClosurePrime m hbase ≠ ⊥ := by + intro hbot + apply hb + simpa only [hbot, Ideal.mem_bot] using hbMem + exact ⟨dominatingIntegralClosurePlace m hbase hne, + valuationSubringAt_dominatingIntegralClosurePlace_eq m hbase hne hV⟩ + +private theorem exists_dominatingPlace_of_base_element + {A P E : Type*} [CommRing A] [IsDomain A] [CommRing P] [Field E] + [Algebra A E] [IsFractionRing A E] [Algebra P E] + [IsDedekindDomain (integralClosure P E)] [IsFractionRing (integralClosure P E) E] + (m : MaximalSpectrum A) + (hbase : ∀ x : P, algebraMap P E x ∈ (algebraMap A E).range) + (hinj : Function.Injective (algebraMap P E)) + (p : P) (hp : p ≠ 0) (r : A) (hr : r ∈ m.asIdeal) + (hmap : algebraMap P E p = algebraMap A E r) : + ∃ q : HeightOneSpectrum (integralClosure P E), + IsDedekindDomain.HeightOneSpectrum.valuationSubringAtPrime E q = + dominatingValuationSubring (L := E) m := by + let b := algebraMap P (integralClosure P E) p + have hb : b ≠ 0 := by + intro h + apply hp + apply hinj + have h' := congrArg (algebraMap (integralClosure P E) E) h + simpa only [b, map_zero, ← IsScalarTower.algebraMap_apply] using h' + apply exists_dominatingPlace_of_nonzero_nonunit m hbase b hb + change algebraMap P E p ∈ (dominatingValuationSubring (L := E) m).nonunits + rw [hmap] + exact algebraMap_mem_dominatingValuationSubring_nonunits_of_mem m r hr + +private theorem residue_finrank_le_of_dominating_valuation + {K A E : Type*} [Field K] [CommRing A] [IsDomain A] [Field E] + [Algebra K A] [Algebra K E] [Algebra A E] [IsScalarTower K A E] + [IsFractionRing A E] (m : MaximalSpectrum A) (R : ValuationSubring E) + [Algebra K R] + [Module.Finite K (IsLocalRing.ResidueField R)] + (hscalar : ∀ c : K, (algebraMap K R c : E) = algebraMap K E c) + (hspec : R = dominatingValuationSubring (L := E) m) : + Module.finrank K m.asIdeal.ResidueField ≤ + Module.finrank K (IsLocalRing.ResidueField R) := by + let V := dominatingValuationSubring (A := A) (L := E) m + let eVR : V ≃+* R := + { toFun := fun x => ⟨x.1, by rw [hspec]; exact x.2⟩ + invFun := fun x => ⟨x.1, by + change x.1 ∈ dominatingValuationSubring m + rw [← hspec] + exact x.2⟩ + left_inv := fun x => Subtype.ext rfl + right_inv := fun x => Subtype.ext rfl + map_add' := fun _ _ => rfl + map_mul' := fun _ _ => rfl } + let ψ : A →+* R := + eVR.toRingHom.comp + (coordinateRingToDominatingValuationSubring + (A := A) (L := E) m) + have hcenter : m.asIdeal = + Ideal.comap ψ (IsLocalRing.maximalIdeal R) := by + rw [pointIdeal_eq_comap_dominatingValuationSubring_maximalIdeal + (A := A) (L := E)] + ext a + change coordinateRingToDominatingValuationSubring m a ∈ + IsLocalRing.maximalIdeal V ↔ + eVR (coordinateRingToDominatingValuationSubring m a) ∈ + IsLocalRing.maximalIdeal R + simp only [IsLocalRing.mem_maximalIdeal, mem_nonunits_iff] + exact (not_congr (MulEquiv.isUnit_map (f := eVR.toMulEquiv))).symm + have hψcoe (a : A) : ((ψ a : R) : E) = algebraMap A E a := by + rfl + let θ : A →ₐ[K] IsLocalRing.ResidueField R := + { toRingHom := (IsLocalRing.residue R).comp ψ + commutes' := by + intro c + rw [IsScalarTower.algebraMap_apply K R + (IsLocalRing.ResidueField R)] + apply congrArg (IsLocalRing.residue R) + apply Subtype.ext + rw [hψcoe] + rw [← IsScalarTower.algebraMap_apply K A E] + exact (hscalar c).symm } + have hker : m.asIdeal = RingHom.ker θ := by + ext a + rw [RingHom.mem_ker] + change a ∈ m.asIdeal ↔ IsLocalRing.residue R (ψ a) = 0 + rw [IsLocalRing.residue_eq_zero_iff, hcenter] + rfl + let ι : m.asIdeal.ResidueField →ₐ[K] + IsLocalRing.ResidueField R := by + apply Ideal.ResidueField.liftₐ m.asIdeal θ hker.le + intro a ha + change IsUnit (θ a) + rw [isUnit_iff_ne_zero] + intro hzero + apply ha + rw [hker] + exact hzero + exact LinearMap.finrank_le_finrank_of_injective (f := ι.toLinearMap) ι.injective + +variable (K : Type*) [Field K] [Fintype K] [DecidableEq K] +variable (p : ℕ) [Fact p.Prime] [CharP K p] + +/-- Mathlib's chosen quadratic extension of the finite field `K`. -/ +abbrev SquareExtension := FiniteField.Extension K p 2 + +/-- Affine zeros of the base-changed plane equation over the quadratic +extension. -/ +abbrev SquareExtensionAffinePoint (f : MvPolynomial (Fin 2) K) := + AffineBivariatePoint (extensionPlaneCurvePolynomial K p 2 f) + +/-- Evaluation of the base coordinate ring at a quadratic-extension affine +point. -/ +def squareExtensionPointEval + (f : MvPolynomial (Fin 2) K) + (z : SquareExtensionAffinePoint K p f) : + PlaneCurveCoordinateRing f →ₐ[K] SquareExtension K p where + toRingHom := Ideal.Quotient.lift (Ideal.span {f}) + (MvPolynomial.eval₂Hom + (algebraMap K (SquareExtension K p)) ![z.1.1, z.1.2]) (by + intro g hg + obtain ⟨a, rfl⟩ := Ideal.mem_span_singleton.mp hg + rw [map_mul] + have hfzero : MvPolynomial.eval₂ + (algebraMap K (SquareExtension K p)) ![z.1.1, z.1.2] f = 0 := by + rw [MvPolynomial.eval₂_eq_eval_map] + exact z.2 + change MvPolynomial.eval₂ + (algebraMap K (SquareExtension K p)) ![z.1.1, z.1.2] f * + MvPolynomial.eval₂ + (algebraMap K (SquareExtension K p)) ![z.1.1, z.1.2] a = 0 + rw [hfzero, zero_mul]) + commutes' c := by + change MvPolynomial.eval₂ + (algebraMap K (SquareExtension K p)) ![z.1.1, z.1.2] + (MvPolynomial.C c) = algebraMap K (SquareExtension K p) c + simp + +omit [DecidableEq K] in +@[simp] +theorem squareExtensionPointEval_coordinate + (f : MvPolynomial (Fin 2) K) + (z : SquareExtensionAffinePoint K p f) (i : Fin 2) : + squareExtensionPointEval K p f z (planeCurveCoordinate f i) = + ![z.1.1, z.1.2] i := by + simp [squareExtensionPointEval, planeCurveCoordinate, + planeCurveQuotientMap] + +/-- The base closed affine centre of a quadratic-extension point. The +kernel is maximal because the finite image of the evaluation homomorphism is +a field. -/ +def squareExtensionPointMaximalIdeal + (f : MvPolynomial (Fin 2) K) + (z : SquareExtensionAffinePoint K p f) : + MaximalSpectrum (PlaneCurveCoordinateRing f) := by + let φ := squareExtensionPointEval K p f z + let R := φ.range + let : Finite R := inferInstance + let : IsDomain R := inferInstance + let : Field R := IsField.toField (Finite.isField_of_domain R) + refine ⟨RingHom.ker φ, ?_⟩ + rw [← AlgHom.ker_rangeRestrict φ] + exact RingHom.ker_isMaximal_of_surjective φ.rangeRestrict.toRingHom + φ.rangeRestrict_surjective + +omit [DecidableEq K] in +@[simp] +theorem squareExtensionPointMaximalIdeal_asIdeal + (f : MvPolynomial (Fin 2) K) + (z : SquareExtensionAffinePoint K p f) : + (squareExtensionPointMaximalIdeal K p f z).asIdeal = + RingHom.ker (squareExtensionPointEval K p f z) := by + simp [squareExtensionPointMaximalIdeal] + +/-- Closed affine centres arising from quadratic-extension points. -/ +abbrev SquareExtensionClosedPoint (f : MvPolynomial (Fin 2) K) := + Set.range (squareExtensionPointMaximalIdeal K p f) + +noncomputable instance squareExtensionAffinePointFintype + (f : MvPolynomial (Fin 2) K) : + Fintype (SquareExtensionAffinePoint K p f) := + Fintype.ofFinite _ + +/-- Send a quadratic-extension point to its base closed affine centre. -/ +def squareExtensionClosedPointMap + (f : MvPolynomial (Fin 2) K) + (z : SquareExtensionAffinePoint K p f) : + SquareExtensionClosedPoint K p f := + ⟨squareExtensionPointMaximalIdeal K p f z, ⟨z, rfl⟩⟩ + +omit [DecidableEq K] in +theorem squareExtensionClosedPointMap_surjective + (f : MvPolynomial (Fin 2) K) : + Function.Surjective (squareExtensionClosedPointMap K p f) := by + rintro ⟨m, z, rfl⟩ + exact ⟨z, rfl⟩ + +noncomputable instance squareExtensionClosedPointFintype + (f : MvPolynomial (Fin 2) K) : + Fintype (SquareExtensionClosedPoint K p f) := by + exact Fintype.ofFinite _ + +/-- The fibre of quadratic-extension points above one base closed affine +centre. -/ +abbrev SquareExtensionClosedPointFiber + (f : MvPolynomial (Fin 2) K) + (m : SquareExtensionClosedPoint K p f) := + {z : SquareExtensionAffinePoint K p f // + squareExtensionClosedPointMap K p f z = m} + +noncomputable instance squareExtensionClosedPointFiberFintype + (f : MvPolynomial (Fin 2) K) + (m : SquareExtensionClosedPoint K p f) : + Fintype (SquareExtensionClosedPointFiber K p f m) := + Fintype.ofFinite _ + +/-- A point in a fixed closed-centre fibre gives a `K`-embedding of that +centre's residue field into the quadratic extension. -/ +def squareExtensionFiberResidueAlgHom + (f : MvPolynomial (Fin 2) K) + (m : SquareExtensionClosedPoint K p f) + (z : SquareExtensionClosedPointFiber K p f m) : + m.1.asIdeal.ResidueField →ₐ[K] SquareExtension K p := by + let φ := squareExtensionPointEval K p f z.1 + have hm : squareExtensionPointMaximalIdeal K p f z.1 = m.1 := + congrArg Subtype.val z.2 + have hker : m.1.asIdeal = RingHom.ker φ := by + rw [← hm] + exact squareExtensionPointMaximalIdeal_asIdeal K p f z.1 + apply Ideal.ResidueField.liftₐ m.1.asIdeal φ hker.le + intro a ha + change IsUnit (φ a) + rw [isUnit_iff_ne_zero] + intro hzero + apply ha + rw [hker] + exact hzero + +omit [DecidableEq K] in +theorem squareExtensionFiberResidueAlgHom_injective + (f : MvPolynomial (Fin 2) K) + (m : SquareExtensionClosedPoint K p f) : + Function.Injective + (squareExtensionFiberResidueAlgHom K p f m) := by + intro z w hzw + apply Subtype.ext + apply Subtype.ext + apply Prod.ext + · have h := DFunLike.congr_fun hzw + (algebraMap (PlaneCurveCoordinateRing f) m.1.asIdeal.ResidueField + (planeCurveCoordinate f 0)) + simpa [squareExtensionFiberResidueAlgHom] using h + · have h := DFunLike.congr_fun hzw + (algebraMap (PlaneCurveCoordinateRing f) m.1.asIdeal.ResidueField + (planeCurveCoordinate f 1)) + simpa [squareExtensionFiberResidueAlgHom] using h + +omit [DecidableEq K] in +/-- A closed-centre fibre has cardinality at most the degree of its residue +field over `K`. -/ +theorem squareExtensionClosedPointFiber_card_le_residueDegree + (f : MvPolynomial (Fin 2) K) + (m : SquareExtensionClosedPoint K p f) : + Fintype.card (SquareExtensionClosedPointFiber K p f m) ≤ + Module.finrank K m.1.asIdeal.ResidueField := by + obtain ⟨z, hz⟩ := m.2 + let zf : SquareExtensionClosedPointFiber K p f m := + ⟨z, Subtype.ext hz⟩ + let ι := squareExtensionFiberResidueAlgHom K p f m zf + let : Finite m.1.asIdeal.ResidueField := + Finite.of_injective ι ι.injective + let : Fintype m.1.asIdeal.ResidueField := Fintype.ofFinite _ + let : Module.Finite K m.1.asIdeal.ResidueField := + Module.Finite.of_fg_top (by + rw [Submodule.fg_def] + exact ⟨Set.univ, Set.finite_univ, by simp⟩) + let Φ := squareExtensionFiberResidueAlgHom K p f m + calc + Fintype.card (SquareExtensionClosedPointFiber K p f m) = + Nat.card (SquareExtensionClosedPointFiber K p f m) := + Fintype.card_eq_nat_card + _ ≤ Nat.card + (m.1.asIdeal.ResidueField →ₐ[K] SquareExtension K p) := + Nat.card_le_card_of_injective Φ + (squareExtensionFiberResidueAlgHom_injective K p f m) + _ ≤ Module.finrank K m.1.asIdeal.ResidueField := + card_algHom_le_finrank K m.1.asIdeal.ResidueField + (SquareExtension K p) + +omit [DecidableEq K] in +/-- Every such closed affine centre has degree one or two. -/ +theorem squareExtensionClosedPoint_residueDegree_le_two + (f : MvPolynomial (Fin 2) K) + (m : SquareExtensionClosedPoint K p f) : + Module.finrank K m.1.asIdeal.ResidueField ≤ 2 := by + obtain ⟨z, hz⟩ := m.2 + let zf : SquareExtensionClosedPointFiber K p f m := + ⟨z, Subtype.ext hz⟩ + let ι := squareExtensionFiberResidueAlgHom K p f m zf + have hdvd : Module.finrank K m.1.asIdeal.ResidueField ∣ + Module.finrank K (SquareExtension K p) := + FiniteField.nonempty_algHom_iff_finrank_dvd.mp ⟨ι⟩ + rw [FiniteField.finrank_extension K p 2] at hdvd + exact Nat.le_of_dvd (by omega) hdvd + +/-- The residue field of a maximal ideal is canonically the residue field of +its localization at that ideal, as an algebra over any compatible base +field. -/ +def atPrimeResidueAlgEquiv + (B R : Type*) [CommRing B] [Algebra K B] + [CommRing R] [Algebra B R] [Algebra K R] [IsScalarTower K B R] + [IsLocalRing R] (q : Ideal B) [q.IsMaximal] + [IsLocalization.AtPrime R q] : + q.ResidueField ≃ₐ[K] IsLocalRing.ResidueField R := by + let e₁ : (B ⧸ q) ≃ₐ[K] q.ResidueField := + AlgEquiv.ofBijective + (IsScalarTower.toAlgHom K (B ⧸ q) q.ResidueField) + (Ideal.bijective_algebraMap_quotient_residueField q) + let e : (B ⧸ q) ≃+* IsLocalRing.ResidueField R := + IsLocalization.AtPrime.equivQuotMaximalIdeal q R + let e₂ : (B ⧸ q) ≃ₐ[K] IsLocalRing.ResidueField R := + { e with + commutes' := by + intro c + change (IsLocalization.AtPrime.equivQuotMaximalIdeal q R) + (Ideal.Quotient.mk q (algebraMap K B c)) = + IsLocalRing.residue R (algebraMap K R c) + rw [IsLocalization.AtPrime.equivQuotMaximalIdeal_apply_mk, + IsScalarTower.algebraMap_apply K B R] + rfl } + exact e₁.symm.trans e₂ + +/-! ## A selected normalization place above each closed affine centre -/ + +omit [DecidableEq K] in +/-- The first coordinate satisfies the quadratic-extension Frobenius +polynomial at every quadratic-extension point. -/ +theorem squareExtensionFrobeniusElement_mem_pointMaximalIdeal + (f : MvPolynomial (Fin 2) K) + (z : SquareExtensionAffinePoint K p f) : + planeCurveCoordinate f 0 ^ (Nat.card K) ^ 2 - + planeCurveCoordinate f 0 ∈ + (squareExtensionPointMaximalIdeal K p f z).asIdeal := by + let : Fintype (SquareExtension K p) := Fintype.ofFinite _ + rw [squareExtensionPointMaximalIdeal_asIdeal] + change squareExtensionPointEval K p f z + (planeCurveCoordinate f 0 ^ (Nat.card K) ^ 2 - + planeCurveCoordinate f 0) = 0 + rw [map_sub, map_pow, squareExtensionPointEval_coordinate] + have hcard : Fintype.card (SquareExtension K p) = (Nat.card K) ^ 2 := by + rw [Fintype.card_eq_nat_card] + exact FiniteField.natCard_extension K p 2 + rw [← hcard, FiniteField.pow_card, sub_self] + +private theorem residue_finrank_le_finitePlace_degree + (K E A : Type*) [Field K] [Fintype K] [DecidableEq K] [DecidableEq (RatFunc K)] + [Field E] [Algebra (RatFunc K) E] [FiniteDimensional (RatFunc K) E] + [Algebra.IsSeparable (RatFunc K) E] [Algebra K E] + [IsScalarTower K (RatFunc K) E] + [CommRing A] [IsDomain A] [Algebra K A] [Algebra A E] + [IsScalarTower K A E] [IsFractionRing A E] + [IsDedekindDomain (RatFuncFiniteIntegralClosure K E)] + [IsFractionRing (RatFuncFiniteIntegralClosure K E) E] + (m : MaximalSpectrum A) (q : FiniteExtensionFinitePlace K E) + (hspec : IsDedekindDomain.HeightOneSpectrum.valuationSubringAtPrime E q = + dominatingValuationSubring (L := E) m) : + Module.finrank K m.asIdeal.ResidueField ≤ finiteExtensionPlaceDegree K E (.inl q) := by + let : Algebra (Polynomial K) E := + RingHom.toAlgebra ((algebraMap (RatFunc K) E).comp + (algebraMap (Polynomial K) (RatFunc K))) + let : IsScalarTower (Polynomial K) (RatFunc K) E := IsScalarTower.of_algebraMap_eq' rfl + let B := RatFuncFiniteIntegralClosure K E + let : Algebra K B := + RingHom.toAlgebra + ((algebraMap (Polynomial K) B).comp (algebraMap K (Polynomial K))) + let : IsScalarTower K (Polynomial K) B := + IsScalarTower.of_algebraMap_eq' rfl + let : IsScalarTower K (Polynomial K) E := + IsScalarTower.of_algebraMap_eq' (by + ext c + rw [IsScalarTower.algebraMap_apply K (RatFunc K) E, + IsScalarTower.algebraMap_apply K (Polynomial K) (RatFunc K)] + rfl) + let : IsScalarTower K B E := IsScalarTower.of_algebraMap_eq' (by + ext c + rw [IsScalarTower.algebraMap_apply K (Polynomial K) E] + rfl) + let R := IsDedekindDomain.HeightOneSpectrum.valuationSubringAtPrime E q + let : Algebra K R := + RingHom.toAlgebra ((algebraMap B R).comp (algebraMap K B)) + let : IsScalarTower K B R := IsScalarTower.of_algebraMap_eq' rfl + let e := atPrimeResidueAlgEquiv K B R q.asIdeal + have hplace : finiteExtensionPlaceDegree K E (.inl q) = + Module.finrank K q.asIdeal.ResidueField := + finiteExtensionFinitePlace_degree_eq_finrank_residueField K E q + let : Module.Finite K q.asIdeal.ResidueField := + Module.finite_of_finrank_pos (by + rw [← hplace] + exact finiteExtensionPlaceDegree_pos K E (.inl q)) + let : Module.Finite K (IsLocalRing.ResidueField R) := + Module.Finite.equiv e.toLinearEquiv + have hle : Module.finrank K m.asIdeal.ResidueField ≤ + Module.finrank K (IsLocalRing.ResidueField R) := + residue_finrank_le_of_dominating_valuation m R (fun c => by + change algebraMap B E (algebraMap K B c) = algebraMap K E c + exact (IsScalarTower.algebraMap_apply K B E c).symm) hspec + have heq : Module.finrank K (IsLocalRing.ResidueField R) = + Module.finrank K q.asIdeal.ResidueField := + e.symm.toLinearEquiv.finrank_eq + rw [hplace, ← heq] + exact hle + +omit [DecidableEq K] in +/-- Every base closed affine centre arising from a quadratic-extension point +has an exhaustive finite place above it. -/ +theorem exists_squareExtensionClosedPoint_exhaustiveFinitePlace + {f : MvPolynomial (Fin 2) K} + (hf : Irreducible f) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (m : SquareExtensionClosedPoint K p f) : + let := planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let := planeCurveFirstCoordinateRatFuncAlgebra f hx + let : Algebra (Polynomial K) (PlaneCurveFunctionField f) := + RingHom.toAlgebra + ((algebraMap (RatFunc K) (PlaneCurveFunctionField f)).comp + (algebraMap (Polynomial K) (RatFunc K))) + let : IsScalarTower (Polynomial K) (RatFunc K) + (PlaneCurveFunctionField f) := + IsScalarTower.of_algebraMap_eq' rfl + let : FiniteDimensional (RatFunc K) (PlaneCurveFunctionField f) := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : Algebra.IsSeparable (RatFunc K) (PlaneCurveFunctionField f) := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : IsDedekindDomain + (integralClosure (Polynomial K) (PlaneCurveFunctionField f)) := + integralClosure.isDedekindDomain (Polynomial K) (RatFunc K) + (PlaneCurveFunctionField f) + let : IsFractionRing + (integralClosure (Polynomial K) (PlaneCurveFunctionField f)) + (PlaneCurveFunctionField f) := + integralClosure.isFractionRing_of_finite_extension (RatFunc K) + (PlaneCurveFunctionField f) + ∃ q : HeightOneSpectrum + (integralClosure (Polynomial K) (PlaneCurveFunctionField f)), + IsDedekindDomain.HeightOneSpectrum.valuationSubringAtPrime + (PlaneCurveFunctionField f) q = + dominatingValuationSubring m.1 := by + intro inst hx alg poly tower finite separable dedekind fraction + let A := PlaneCurveCoordinateRing f + let E := PlaneCurveFunctionField f + let B := integralClosure (Polynomial K) E + let hbase : ∀ P : Polynomial K, + algebraMap (Polynomial K) E P ∈ (algebraMap A E).range := + polynomial_algebraMap_mem_planeCurveCoordinateRing_range hf hpartialSecond + let V := dominatingValuationSubring (A := A) (L := E) m.1 + let r : A := planeCurveCoordinate f 0 ^ (Nat.card K) ^ 2 - + planeCurveCoordinate f 0 + let P : Polynomial K := Polynomial.X ^ (Nat.card K) ^ 2 - Polynomial.X + obtain ⟨z, hz⟩ := m.2 + have hm : squareExtensionPointMaximalIdeal K p f z = m.1 := hz + have hr : r ∈ m.1.asIdeal := by + rw [← hm] + exact squareExtensionFrobeniusElement_mem_pointMaximalIdeal K p f z + have hP0 : P ≠ 0 := by + exact FiniteField.X_pow_card_pow_sub_X_ne_zero K (by omega) + Finite.one_lt_card + have hPMap : algebraMap (Polynomial K) E P = + planeCurveFunction f 0 ^ (Nat.card K) ^ 2 - + planeCurveFunction f 0 := by + change ratFuncSpecialization (planeCurveFunction f 0) hx + (algebraMap (Polynomial K) (RatFunc K) P) = _ + have hcomp := congrArg + (fun h : Polynomial K →+* E => h P) + (ratFuncSpecialization_comp_polynomial_algebraMap + (planeCurveFunction f 0) hx) + simpa only [P, RingHom.comp_apply, map_sub, map_pow, + Polynomial.coe_eval₂RingHom, Polynomial.eval₂_X] using hcomp + have hrMap : algebraMap A E r = + planeCurveFunction f 0 ^ (Nat.card K) ^ 2 - + planeCurveFunction f 0 := by + simp only [r, map_sub, map_pow] + rfl + have hinj : Function.Injective (algebraMap (Polynomial K) E) := + (algebraMap (RatFunc K) E).injective.comp (RatFunc.algebraMap_injective K) + exact exists_dominatingPlace_of_base_element m.1 hbase hinj P hP0 r hr + (hPMap.trans hrMap.symm) + +/-- The selected exhaustive finite place above a quadratic-extension closed +affine centre. -/ +def squareExtensionClosedPointExhaustiveFinitePlace + {f : MvPolynomial (Fin 2) K} + (hf : Irreducible f) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (m : SquareExtensionClosedPoint K p f) : + let := planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let := planeCurveFirstCoordinateRatFuncAlgebra f hx + let : Algebra (Polynomial K) (PlaneCurveFunctionField f) := + RingHom.toAlgebra + ((algebraMap (RatFunc K) (PlaneCurveFunctionField f)).comp + (algebraMap (Polynomial K) (RatFunc K))) + let : IsScalarTower (Polynomial K) (RatFunc K) + (PlaneCurveFunctionField f) := + IsScalarTower.of_algebraMap_eq' rfl + let : FiniteDimensional (RatFunc K) (PlaneCurveFunctionField f) := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : Algebra.IsSeparable (RatFunc K) (PlaneCurveFunctionField f) := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + FiniteExtensionFinitePlace K (PlaneCurveFunctionField f) := by + exact Classical.choose + (exists_squareExtensionClosedPoint_exhaustiveFinitePlace + K p hf hpartialSecond m) + +omit [DecidableEq K] in +/-- The selected place has the prescribed dominating valuation subring. -/ +theorem squareExtensionClosedPointExhaustiveFinitePlace_spec + {f : MvPolynomial (Fin 2) K} + (hf : Irreducible f) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (m : SquareExtensionClosedPoint K p f) : + let := planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let := planeCurveFirstCoordinateRatFuncAlgebra f hx + let : Algebra (Polynomial K) (PlaneCurveFunctionField f) := + RingHom.toAlgebra + ((algebraMap (RatFunc K) (PlaneCurveFunctionField f)).comp + (algebraMap (Polynomial K) (RatFunc K))) + let : IsScalarTower (Polynomial K) (RatFunc K) + (PlaneCurveFunctionField f) := + IsScalarTower.of_algebraMap_eq' rfl + let : FiniteDimensional (RatFunc K) (PlaneCurveFunctionField f) := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : Algebra.IsSeparable (RatFunc K) (PlaneCurveFunctionField f) := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + IsDedekindDomain.HeightOneSpectrum.valuationSubringAtPrime + (PlaneCurveFunctionField f) + (squareExtensionClosedPointExhaustiveFinitePlace + K p hf hpartialSecond m) = + dominatingValuationSubring m.1 := by + exact Classical.choose_spec + (exists_squareExtensionClosedPoint_exhaustiveFinitePlace + K p hf hpartialSecond m) + +omit [DecidableEq K] in +/-- Distinct closed affine centres have distinct selected finite places. -/ +theorem squareExtensionClosedPointExhaustiveFinitePlace_injective + {f : MvPolynomial (Fin 2) K} + (hf : Irreducible f) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) : + let := planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let := planeCurveFirstCoordinateRatFuncAlgebra f hx + let : Algebra (Polynomial K) (PlaneCurveFunctionField f) := + RingHom.toAlgebra + ((algebraMap (RatFunc K) (PlaneCurveFunctionField f)).comp + (algebraMap (Polynomial K) (RatFunc K))) + let : IsScalarTower (Polynomial K) (RatFunc K) + (PlaneCurveFunctionField f) := + IsScalarTower.of_algebraMap_eq' rfl + let : FiniteDimensional (RatFunc K) (PlaneCurveFunctionField f) := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : Algebra.IsSeparable (RatFunc K) (PlaneCurveFunctionField f) := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + Function.Injective + (squareExtensionClosedPointExhaustiveFinitePlace + K p hf hpartialSecond) := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let : Algebra (RatFunc K) (PlaneCurveFunctionField f) := + planeCurveFirstCoordinateRatFuncAlgebra f hx + let : Algebra (Polynomial K) (PlaneCurveFunctionField f) := + RingHom.toAlgebra + ((algebraMap (RatFunc K) (PlaneCurveFunctionField f)).comp + (algebraMap (Polynomial K) (RatFunc K))) + let : IsScalarTower (Polynomial K) (RatFunc K) + (PlaneCurveFunctionField f) := + IsScalarTower.of_algebraMap_eq' rfl + let : FiniteDimensional (RatFunc K) (PlaneCurveFunctionField f) := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : Algebra.IsSeparable (RatFunc K) (PlaneCurveFunctionField f) := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + change Function.Injective + (squareExtensionClosedPointExhaustiveFinitePlace + K p hf hpartialSecond) + intro m n hmn + apply Subtype.ext + apply MaximalSpectrum.ext + apply pointIdeal_eq_of_dominatingValuationSubring_eq + (A := PlaneCurveCoordinateRing f) + (L := PlaneCurveFunctionField f) + calc + dominatingValuationSubring m.1 = + IsDedekindDomain.HeightOneSpectrum.valuationSubringAtPrime + (PlaneCurveFunctionField f) + (squareExtensionClosedPointExhaustiveFinitePlace + K p hf hpartialSecond m) := + (squareExtensionClosedPointExhaustiveFinitePlace_spec + K p hf hpartialSecond m).symm + _ = IsDedekindDomain.HeightOneSpectrum.valuationSubringAtPrime + (PlaneCurveFunctionField f) + (squareExtensionClosedPointExhaustiveFinitePlace + K p hf hpartialSecond n) := by rw [hmn] + _ = dominatingValuationSubring n.1 := + squareExtensionClosedPointExhaustiveFinitePlace_spec + K p hf hpartialSecond n + +/-- The residue degree of a closed affine centre is at most the degree of its +selected normalization place. The inequality can be strict at a singular +centre. -/ +theorem squareExtensionClosedPoint_residueDegree_le_placeDegree + {f : MvPolynomial (Fin 2) K} + (hf : Irreducible f) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (m : SquareExtensionClosedPoint K p f) : + let := planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let := planeCurveFirstCoordinateRatFuncAlgebra f hx + let : Algebra (Polynomial K) (PlaneCurveFunctionField f) := + RingHom.toAlgebra + ((algebraMap (RatFunc K) (PlaneCurveFunctionField f)).comp + (algebraMap (Polynomial K) (RatFunc K))) + let : IsScalarTower (Polynomial K) (RatFunc K) + (PlaneCurveFunctionField f) := + IsScalarTower.of_algebraMap_eq' rfl + let : FiniteDimensional (RatFunc K) (PlaneCurveFunctionField f) := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : Algebra.IsSeparable (RatFunc K) (PlaneCurveFunctionField f) := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : DecidableEq (RatFunc K) := Classical.decEq _ + Module.finrank K m.1.asIdeal.ResidueField ≤ + finiteExtensionPlaceDegree K (PlaneCurveFunctionField f) + (.inl (squareExtensionClosedPointExhaustiveFinitePlace + K p hf hpartialSecond m)) := by + intro inst hx alg poly tower finite separable decEq + let E := PlaneCurveFunctionField f + let q : FiniteExtensionFinitePlace K E := + squareExtensionClosedPointExhaustiveFinitePlace + K p hf hpartialSecond m + let : IsScalarTower K (RatFunc K) E := + IsScalarTower.of_algebraMap_eq' (by + ext c + have h := congrArg + (fun g : Polynomial K →+* E => g (Polynomial.C c)) + (ratFuncSpecialization_comp_polynomial_algebraMap + (planeCurveFunction f 0) hx) + simpa [E, planeCurveFirstCoordinateRatFuncAlgebra] using h.symm) + exact residue_finrank_le_finitePlace_degree K E (PlaneCurveCoordinateRing f) m.1 q + (squareExtensionClosedPointExhaustiveFinitePlace_spec K p hf hpartialSecond m) + +/-- Quadratic-extension affine points are bounded by the sum of the degrees +of one selected normalization place above each closed affine centre. The +residue degree is the weight that accounts for Frobenius-conjugate points. -/ +theorem squareExtensionAffinePoint_card_le_selectedPlaceDegreeSum + {f : MvPolynomial (Fin 2) K} + (hf : Irreducible f) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) : + let := planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let := planeCurveFirstCoordinateRatFuncAlgebra f hx + let : Algebra (Polynomial K) (PlaneCurveFunctionField f) := + RingHom.toAlgebra + ((algebraMap (RatFunc K) (PlaneCurveFunctionField f)).comp + (algebraMap (Polynomial K) (RatFunc K))) + let : IsScalarTower (Polynomial K) (RatFunc K) + (PlaneCurveFunctionField f) := + IsScalarTower.of_algebraMap_eq' rfl + let : FiniteDimensional (RatFunc K) (PlaneCurveFunctionField f) := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : Algebra.IsSeparable (RatFunc K) (PlaneCurveFunctionField f) := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : DecidableEq (RatFunc K) := Classical.decEq _ + Fintype.card (SquareExtensionAffinePoint K p f) ≤ + ∑ m : SquareExtensionClosedPoint K p f, + finiteExtensionPlaceDegree K (PlaneCurveFunctionField f) + (.inl (squareExtensionClosedPointExhaustiveFinitePlace + K p hf hpartialSecond m)) := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let : Algebra (RatFunc K) (PlaneCurveFunctionField f) := + planeCurveFirstCoordinateRatFuncAlgebra f hx + let : Algebra (Polynomial K) (PlaneCurveFunctionField f) := + RingHom.toAlgebra + ((algebraMap (RatFunc K) (PlaneCurveFunctionField f)).comp + (algebraMap (Polynomial K) (RatFunc K))) + let : IsScalarTower (Polynomial K) (RatFunc K) + (PlaneCurveFunctionField f) := + IsScalarTower.of_algebraMap_eq' rfl + let : FiniteDimensional (RatFunc K) (PlaneCurveFunctionField f) := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : Algebra.IsSeparable (RatFunc K) (PlaneCurveFunctionField f) := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : DecidableEq (RatFunc K) := Classical.decEq _ + have hcard : + Fintype.card (SquareExtensionAffinePoint K p f) = + ∑ m : SquareExtensionClosedPoint K p f, + Fintype.card (SquareExtensionClosedPointFiber K p f m) := by + rw [← Fintype.card_sigma] + exact Fintype.card_congr + (Equiv.sigmaFiberEquiv (squareExtensionClosedPointMap K p f)).symm + rw [hcard] + apply Finset.sum_le_sum + intro m _hm + exact (squareExtensionClosedPointFiber_card_le_residueDegree K p f m).trans + (squareExtensionClosedPoint_residueDegree_le_placeDegree + K p hf hpartialSecond m) + +/-- If a nonzero function has positive order at one selected normalization +place above every closed affine centre arising over the quadratic extension, +then every such affine point is counted by the function's pole height. -/ +theorem squareExtensionAffinePoint_card_le_finiteExtensionHeight_of_selectedPlace_orders_positive + {f : MvPolynomial (Fin 2) K} + (hf : Irreducible f) + (hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0) + (u : PlaneCurveFunctionField f) (hu : u ≠ 0) : + let := planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let := planeCurveFirstCoordinateRatFuncAlgebra f hx + let : Algebra (Polynomial K) (PlaneCurveFunctionField f) := + RingHom.toAlgebra + ((algebraMap (RatFunc K) (PlaneCurveFunctionField f)).comp + (algebraMap (Polynomial K) (RatFunc K))) + let : IsScalarTower (Polynomial K) (RatFunc K) + (PlaneCurveFunctionField f) := + IsScalarTower.of_algebraMap_eq' rfl + let : FiniteDimensional (RatFunc K) (PlaneCurveFunctionField f) := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : Algebra.IsSeparable (RatFunc K) (PlaneCurveFunctionField f) := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : DecidableEq (RatFunc K) := Classical.decEq _ + (∀ m : SquareExtensionClosedPoint K p f, + 0 < finiteExtensionPrincipalDivisor K (PlaneCurveFunctionField f) u + (.inl (squareExtensionClosedPointExhaustiveFinitePlace + K p hf hpartialSecond m))) → + Fintype.card (SquareExtensionAffinePoint K p f) ≤ + finiteExtensionHeight K (PlaneCurveFunctionField f) u := by + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let : Algebra (RatFunc K) (PlaneCurveFunctionField f) := + planeCurveFirstCoordinateRatFuncAlgebra f hx + let : Algebra (Polynomial K) (PlaneCurveFunctionField f) := + RingHom.toAlgebra + ((algebraMap (RatFunc K) (PlaneCurveFunctionField f)).comp + (algebraMap (Polynomial K) (RatFunc K))) + let : IsScalarTower (Polynomial K) (RatFunc K) + (PlaneCurveFunctionField f) := + IsScalarTower.of_algebraMap_eq' rfl + let : FiniteDimensional (RatFunc K) (PlaneCurveFunctionField f) := + finiteDimensional_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : Algebra.IsSeparable (RatFunc K) (PlaneCurveFunctionField f) := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + let : DecidableEq (RatFunc K) := Classical.decEq _ + change + (∀ m : SquareExtensionClosedPoint K p f, + 0 < finiteExtensionPrincipalDivisor K (PlaneCurveFunctionField f) u + (.inl (squareExtensionClosedPointExhaustiveFinitePlace + K p hf hpartialSecond m))) → + Fintype.card (SquareExtensionAffinePoint K p f) ≤ + finiteExtensionHeight K (PlaneCurveFunctionField f) u + intro hpositive + classical + let place : SquareExtensionClosedPoint K p f → + FiniteExtensionPlace K (PlaneCurveFunctionField f) := fun m => + .inl (squareExtensionClosedPointExhaustiveFinitePlace + K p hf hpartialSecond m) + have hplaceInjective : Function.Injective place := by + intro m n hmn + apply squareExtensionClosedPointExhaustiveFinitePlace_injective + K p hf hpartialSecond + exact Sum.inl_injective hmn + let : DecidableEq (FiniteExtensionPlace K (PlaneCurveFunctionField f)) := + @instDecidableEqSum _ _ (Classical.decEq _) (Classical.decEq _) + let S : Finset (FiniteExtensionPlace K (PlaneCurveFunctionField f)) := + Finset.univ.image place + have hsum : + (∑ m : SquareExtensionClosedPoint K p f, + finiteExtensionPlaceDegree K (PlaneCurveFunctionField f) (place m)) = + ∑ v ∈ S, + finiteExtensionPlaceDegree K (PlaneCurveFunctionField f) v := by + symm + exact Finset.sum_image hplaceInjective.injOn + have hSpositive : + ∀ v ∈ S, + 0 < finiteExtensionPrincipalDivisor K (PlaneCurveFunctionField f) u v := by + intro v hv + rcases Finset.mem_image.mp hv with ⟨m, _hm, rfl⟩ + exact hpositive m + calc + Fintype.card (SquareExtensionAffinePoint K p f) ≤ + ∑ m : SquareExtensionClosedPoint K p f, + finiteExtensionPlaceDegree K (PlaneCurveFunctionField f) (place m) := by + exact squareExtensionAffinePoint_card_le_selectedPlaceDegreeSum + K p hf hpartialSecond + _ = ∑ v ∈ S, + finiteExtensionPlaceDegree K (PlaneCurveFunctionField f) v := hsum + _ ≤ finiteExtensionHeight K (PlaneCurveFunctionField f) u := + sum_placeDegree_le_finiteExtensionHeight_of_orders_positive + K (PlaneCurveFunctionField f) u hu S hSpositive + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/SquareFieldResidue.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/SquareFieldResidue.lean new file mode 100644 index 0000000000..6cfc5e7010 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/SquareFieldResidue.lean @@ -0,0 +1,86 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveAuxiliaryFinitePlaceCases +public import LeanPool.MarkoffModP.BGS.HasseWeil.OnePointLeadingCoefficient +public import Mathlib.Tactic + +/-! +# Degree-one residues over a square constant field + +For a function field over a finite field `S`, a finite place of constant-field +degree one has residue field of cardinality `#S`. If `#S = (#K)^2`, every +residue therefore satisfies the half-Frobenius square identity used by the +semilinear Stepanov restriction. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +open BGS.CorvajaZannier +open scoped Polynomial + +noncomputable section + +variable (K S : Type*) [Field K] [Fintype K] + [Field S] [Fintype S] [DecidableEq S] + [DecidableEq (RatFunc S)] +variable (L : Type*) [Field L] [Algebra (RatFunc S) L] + [FiniteDimensional (RatFunc S) L] + [Algebra.IsSeparable (RatFunc S) L] + +local instance (priority := 10) squareFieldResiduePolynomialAlgebra : + Algebra S[X] L := + RingHom.toAlgebra ((algebraMap (RatFunc S) L).comp + (algebraMap S[X] (RatFunc S))) + +local instance squareFieldResiduePolynomialScalarTower : + IsScalarTower S[X] (RatFunc S) L := + IsScalarTower.of_algebraMap_eq' rfl + +local instance squareFieldResidueFiniteConstantAlgebra : + Algebra S (RatFuncFiniteIntegralClosure S L) := + RingHom.toAlgebra ((algebraMap S[X] + (RatFuncFiniteIntegralClosure S L)).comp (algebraMap S S[X])) + +local instance squareFieldResidueFiniteConstantTower : + IsScalarTower S S[X] (RatFuncFiniteIntegralClosure S L) := + IsScalarTower.of_algebraMap_eq' rfl + +omit [Field K] in +/-- A degree-one finite place over a square constant field has the quadratic +half-Frobenius identity in its residue field. -/ +theorem finiteExtensionFinitePlace_residue_squareFrobenius_of_degree_one + (hcard : Fintype.card S = (Fintype.card K) ^ 2) + (q : FiniteExtensionFinitePlace S L) + (hdegree : finiteExtensionPlaceDegree S L (.inl q) = 1) : + ∀ z : q.asIdeal.ResidueField, + z ^ (Fintype.card K) ^ 2 = z := by + let : Finite q.asIdeal.ResidueField := + finiteExtensionFinitePlace_residueField_finite (K := S) (L := L) q + let : Fintype q.asIdeal.ResidueField := Fintype.ofFinite _ + let : Module.Finite S q.asIdeal.ResidueField := by + rw [Module.finite_def] + exact ⟨Finset.univ, by simp⟩ + have hfinrank : Module.finrank S q.asIdeal.ResidueField = 1 := by + rw [finiteExtensionFinitePlace_degree_eq_finrank_residueField S L q] at hdegree + exact hdegree + have hresidueCard : + Fintype.card q.asIdeal.ResidueField = (Fintype.card K) ^ 2 := by + calc + Fintype.card q.asIdeal.ResidueField = + (Fintype.card S) ^ Module.finrank S q.asIdeal.ResidueField := + Module.card_eq_pow_finrank + _ = (Fintype.card K) ^ 2 := by rw [hfinrank, pow_one, hcard] + intro z + simpa [hresidueCard] using FiniteField.pow_card z + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/SquareFieldStepanovAuxiliary.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/SquareFieldStepanovAuxiliary.lean new file mode 100644 index 0000000000..a9ccf0a03d --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/SquareFieldStepanovAuxiliary.lean @@ -0,0 +1,135 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.OnePointStepanovDegreeTwoAuxiliary +public import LeanPool.MarkoffModP.BGS.HasseWeil.PlaneStepanovAuxiliary +public import LeanPool.MarkoffModP.BGS.HasseWeil.SquareFieldStepanovRestriction +public import Mathlib.Tactic + +/-! +# A sharp one-point Stepanov auxiliary over a square constant field + +The function field is defined over the full square field `S`, so an +`S`-rational normalization point is a place of degree one. The integer +`s = #K`, for a quadratic subfield `K`, is used only as the half-Frobenius +scale. This keeps both the Riemann-space dimension count and the final pole +height sharp. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +open BGS.CorvajaZannier +open scoped Polynomial + +noncomputable section + + +variable (K S : Type*) [Field K] [Fintype K] + [Field S] [Fintype S] [DecidableEq S] [Algebra K S] + [DecidableEq (RatFunc S)] +variable (L : Type*) [Field L] [Algebra (RatFunc S) L] + [FiniteDimensional (RatFunc S) L] + [Algebra.IsSeparable (RatFunc S) L] + +local instance squareFieldAuxiliaryConstantAlgebra : Algebra S L := + RingHom.toAlgebra ((algebraMap (RatFunc S) L).comp + (algebraMap S (RatFunc S))) + +local instance squareFieldAuxiliaryConstantTower : + IsScalarTower S (RatFunc S) L := + IsScalarTower.of_algebraMap_eq' rfl + +/-- Riemann's inequality at a degree-one place, together with the standard +large-square-field condition, produces the semilinear Stepanov auxiliary. +-/ +theorem exists_squareField_onePointStepanovAuxiliary_of_degree_one + (P : FiniteExtensionPlace S L) (g : ℕ) + (hconstants : algebraicClosure S L = ⊥) + (hdegree : finiteExtensionPlaceDegree S L P = 1) + (hriemann : ∀ N, + N + 1 ≤ Module.finrank S + (finiteExtensionOnePointRiemannSpace S L P N) + g) + (hlarge : (g + 1) * (g + 2) ≤ Fintype.card K) : + let s := Fintype.card K + let ell := stepanovEll s + let m := stepanovM g s + ∃ (u : Option (Fin (ell - g)) → L) + (du : Option (Fin (ell - g)) → ℕ) + (v : Option (Fin (m - g)) → L) + (dv : Option (Fin (m - g)) → ℕ) + (c : (Option (Fin (ell - g)) × Option (Fin (m - g))) →₀ S), + onePointSectionFamilySpec S L P ell u du ∧ + onePointSectionFamilySpec S L P m v dv ∧ + c ≠ 0 ∧ + onePointStepanovSecondRestrictionMap S L u v s c = 0 ∧ + squareFieldStepanovFirstRestriction K S L u v c ≠ 0 := by + let s := Fintype.card K + let ell := stepanovEll s + let m := stepanovM g s + have hlarge' : (g + 1) * (g + 2) ≤ s := hlarge + have hs : 0 < s := Fintype.card_pos + have hglt : g < s := by nlinarith + have hgell : g ≤ ell := by + simp only [ell, stepanovEll] + omega + have hgm : g ≤ m := by + simp only [m, stepanovM] + omega + have helllt : ell < s := stepanovEll_lt hlarge' + have hstrict : ∀ N, g ≤ N → + N - g ≤ + (strictFiltrationLevels + (fun r => finiteExtensionOnePointRiemannSpace S L P r) N).card := by + intro N hgN + apply le_card_onePointStrictLevels_of_finrank_lower + S L P N (N - g) hconstants + have hN := hriemann N + rw [hdegree] + omega + obtain ⟨u, du, huMem, huNe, huOrder, hduInjective, + hduLe, huLI⟩ := + exists_onePointSectionsWithConstant_of_le_card_strictLevels + S L P ell (ell - g) (hstrict ell hgell) + obtain ⟨v, dv, hvMem, hvNe, hvOrder, hdvInjective, + hdvLe, hvLI⟩ := + exists_onePointSectionsWithConstant_of_le_card_strictLevels + S L P m (m - g) (hstrict m hgm) + have hgridLI : LinearIndependent S + (fun ij : Option (Fin (ell - g)) × Option (Fin (m - g)) => + u ij.1 * (v ij.2) ^ s) := by + exact onePointStepanovGrid_linearIndependent S L P u v du dv s + huNe hvNe huOrder hvOrder hduInjective hdvInjective + (fun i => (hduLe i).trans_lt helllt) + have hupper : Module.finrank S + (finiteExtensionOnePointRiemannSpace S L P (s * ell + m)) ≤ + s * ell + m + 1 := by + have h := finiteExtensionOnePointRiemannSpace_finrank_upper + S L P hconstants (s * ell + m) + rw [hdegree] at h + simpa using h + have hellCard : ell - g + 1 = ell + 1 - g := by omega + have hmCard : m - g + 1 = m + 1 - g := by omega + have hnumeric : s * ell + m + 1 < + Fintype.card (Option (Fin (ell - g))) * + Fintype.card (Option (Fin (m - g))) := by + have hdim := stepanov_dimension_inequality hlarge' + simpa only [Fintype.card_option, Fintype.card_fin, hellCard, hmCard, + Nat.mul_comm s ell] using hdim + obtain ⟨c, hc, hsecond, hfirst⟩ := + exists_squareFieldStepanovAuxiliary_of_target_finrank_upper + K S L P u v ell m (s * ell + m + 1) + huMem hvMem hgridLI hupper hnumeric + refine ⟨u, du, v, dv, c, ?_, ?_, hc, hsecond, hfirst⟩ + · exact ⟨huMem, huNe, huOrder, hduInjective, hduLe, huLI⟩ + · exact ⟨hvMem, hvNe, hvOrder, hdvInjective, hdvLe, hvLI⟩ + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/SquareFieldStepanovRestriction.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/SquareFieldStepanovRestriction.lean new file mode 100644 index 0000000000..1295b83f91 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/SquareFieldStepanovRestriction.lean @@ -0,0 +1,480 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.StepanovSquareVanishing +public import Mathlib.Tactic + +/-! +# Stepanov restrictions over a square constant field + +Let `S/K` be a quadratic extension of finite fields and put `s = #K`. +The square-field Stepanov argument is linear over the full constant field +`S`, but its two restrictions are related by the `s`-power automorphism. +Consequently the coefficients of the first restriction must be transformed +by that automorphism. This is the semilinear point which is lost if an +`S`-rational point is treated merely as a degree-two place over `K`. + +This file packages the coefficient transform and proves the local residue +identity. It makes no point-count or smoothness assertion. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +open BGS.CorvajaZannier +open IsDedekindDomain +open scoped Polynomial BigOperators + +noncomputable section + + +section Coefficients + +variable (K S : Type*) [Field K] [Fintype K] + [Field S] [Algebra K S] + +/-- Apply the `#K`-power automorphism coefficientwise to a finite grid over +the square constant field. -/ +def squareRootFrobeniusCoefficients {ι : Type*} (c : ι →₀ S) : ι →₀ S := + Finsupp.mapRange (powCardAlgHom K S 1) (map_zero (powCardAlgHom K S 1)) c + +@[simp] +theorem squareRootFrobeniusCoefficients_apply + {ι : Type*} (c : ι →₀ S) (i : ι) : + squareRootFrobeniusCoefficients K S c i = + (c i) ^ Fintype.card K := by + simp [squareRootFrobeniusCoefficients, powCardAlgHom_apply] + +theorem squareRootFrobeniusCoefficients_ne_zero + {ι : Type*} {c : ι →₀ S} (hc : c ≠ 0) : + squareRootFrobeniusCoefficients K S c ≠ 0 := by + intro hzero + apply hc + apply Finsupp.mapRange_injective _ _ (powCardAlgHom K S 1).injective + change squareRootFrobeniusCoefficients K S c = + squareRootFrobeniusCoefficients K S 0 + rw [hzero] + ext i + simp [squareRootFrobeniusCoefficients] + +end Coefficients + +section Restriction + +variable (K S : Type*) [Field K] [Fintype K] + [Field S] [Fintype S] [DecidableEq S] [Algebra K S] + [DecidableEq (RatFunc S)] +variable (L : Type*) [Field L] [Algebra (RatFunc S) L] + [FiniteDimensional (RatFunc S) L] + [Algebra.IsSeparable (RatFunc S) L] + +local instance squareFieldRestrictionConstantAlgebra : Algebra S L := + RingHom.toAlgebra ((algebraMap (RatFunc S) L).comp + (algebraMap S (RatFunc S))) + +local instance squareFieldRestrictionConstantTower : + IsScalarTower S (RatFunc S) L := + IsScalarTower.of_algebraMap_eq' rfl + +/-- The first square-field restriction. The function grid is +`f_i g_j^s`, while the coefficients are transformed by `c ↦ c^s`. -/ +def squareFieldStepanovFirstRestriction + {α β : Type*} (f : α → L) (g : β → L) (c : α × β →₀ S) : L := + onePointStepanovFirstRestrictionMap S L f g (Fintype.card K) + (squareRootFrobeniusCoefficients K S c) + +/-- The transformed first restriction has the same one-point pole budget as +the ordinary first restriction. -/ +theorem squareFieldStepanovFirstRestriction_mem + {α β : Type*} (P : FiniteExtensionPlace S L) + (f : α → L) (g : β → L) (ell m : ℕ) + (hf : ∀ i, f i ∈ finiteExtensionOnePointRiemannSpace S L P ell) + (hg : ∀ j, g j ∈ finiteExtensionOnePointRiemannSpace S L P m) + (c : α × β →₀ S) : + squareFieldStepanovFirstRestriction K S L f g c ∈ + finiteExtensionOnePointRiemannSpace S L P + (ell + Fintype.card K * m) := by + exact onePointStepanovFirstRestrictionMap_mem S L P f g ell m + (Fintype.card K) hf hg (squareRootFrobeniusCoefficients K S c) + +/-- Rank-nullity over the full square constant field produces a coefficient +grid killed by the second restriction. Frobenius injectivity and linear +independence of the first grid make the transformed first restriction +nonzero. -/ +theorem exists_squareFieldStepanovAuxiliary_of_target_finrank_upper + {α β : Type*} [Fintype α] [Fintype β] + (P : FiniteExtensionPlace S L) + (f : α → L) (g : β → L) (ell m targetBound : ℕ) + (hf : ∀ i, f i ∈ finiteExtensionOnePointRiemannSpace S L P ell) + (hg : ∀ j, g j ∈ finiteExtensionOnePointRiemannSpace S L P m) + (hLI : LinearIndependent S + (fun ij : α × β => f ij.1 * (g ij.2) ^ Fintype.card K)) + (hupper : Module.finrank S + (finiteExtensionOnePointRiemannSpace S L P + (Fintype.card K * ell + m)) ≤ targetBound) + (hnumeric : targetBound < Fintype.card α * Fintype.card β) : + ∃ c : α × β →₀ S, + c ≠ 0 ∧ + onePointStepanovSecondRestrictionMap S L f g + (Fintype.card K) c = 0 ∧ + squareFieldStepanovFirstRestriction K S L f g c ≠ 0 := by + obtain ⟨c, hc, hsecond, _hfirst⟩ := + exists_onePointStepanovAuxiliary_of_target_finrank_upper + S L P f g ell m (Fintype.card K) targetBound + hf hg hLI hupper hnumeric + have hcFrob : squareRootFrobeniusCoefficients K S c ≠ 0 := + squareRootFrobeniusCoefficients_ne_zero K S hc + have hinjective : Function.Injective + (onePointStepanovFirstRestrictionMap S L f g (Fintype.card K)) := + onePointStepanovFirstRestrictionMap_injective_of_linearIndependent + S L f g (Fintype.card K) hLI + refine ⟨c, hc, ?_, ?_⟩ + · have h := congrArg Subtype.val hsecond + simpa only [onePointStepanovSecondCodRestrictionMap_coe, + Submodule.coe_zero] using h + · intro hzero + apply hcFrob + apply hinjective + rw [map_zero] + simpa only [squareFieldStepanovFirstRestriction] using hzero + +end Restriction + +section LocalResidue + +variable (K S R : Type*) [Field K] [Fintype K] + [Field S] [Algebra K S] + [CommRing R] [IsLocalRing R] [Algebra S R] + [Algebra K R] + +/-- With Frobenius-transformed coefficients, the residue of the first +restriction is the `#K`-power of the residue of the second restriction. -/ +theorem squareFieldStepanovLocalResidue_first_eq_frobenius_second + {α β : Type*} (F : α → R) (G : β → R) (c : α × β →₀ S) + (hsquare : ∀ z : IsLocalRing.ResidueField R, + z ^ (Fintype.card K) ^ 2 = z) : + stepanovLocalResidueAlgHom S R + (Finsupp.linearCombination S + (fun ij : α × β => + F ij.1 * (G ij.2) ^ Fintype.card K) + (squareRootFrobeniusCoefficients K S c)) = + powCardAlgHom K (IsLocalRing.ResidueField R) 1 + (stepanovLocalResidueAlgHom S R + (Finsupp.linearCombination S + (fun ij : α × β => + (F ij.1) ^ Fintype.card K * G ij.2) c)) := by + classical + let ρ := stepanovLocalResidueAlgHom S R + let φ := powCardAlgHom K (IsLocalRing.ResidueField R) 1 + rw [Finsupp.linearCombination_apply, Finsupp.linearCombination_apply] + simp only [squareRootFrobeniusCoefficients] + have hmap : + (Finsupp.mapRange (powCardAlgHom K S 1) + (map_zero (powCardAlgHom K S 1)) c).sum + (fun ij a => a • (F ij.1 * G ij.2 ^ Fintype.card K)) = + c.sum fun ij a => + (powCardAlgHom K S 1 a) • + (F ij.1 * G ij.2 ^ Fintype.card K) := by + exact Finsupp.sum_mapRange_index (fun ij => + zero_smul S (F ij.1 * G ij.2 ^ Fintype.card K)) + rw [hmap] + change ρ (c.sum fun ij a => + (powCardAlgHom K S 1 a) • + (F ij.1 * G ij.2 ^ Fintype.card K)) = + φ (ρ (c.sum fun ij a => + a • (F ij.1 ^ Fintype.card K * G ij.2))) + simp only [map_finsuppSum, map_smul, map_mul, map_pow] + apply Finsupp.sum_congr + intro ij hij + dsimp only [φ] + simp only [Algebra.smul_def, map_mul, map_pow, + powCardAlgHom_apply, Nat.pow_one] + rw [← pow_mul] + rw [show (ρ (F ij.1)) ^ (Fintype.card K * Fintype.card K) = + ρ (F ij.1) by + simpa only [pow_two] using hsquare (ρ (F ij.1))] + +end LocalResidue + +section LocalOrder + +variable (K S R L : Type*) [Field K] [Fintype K] + [Field S] [Algebra K S] + [CommRing R] [IsDedekindDomain R] [IsDiscreteValuationRing R] + [Algebra S R] [Algebra K R] + [Field L] [Algebra R L] [IsFractionRing R L] + +/-- Local DVR form of the semilinear square-field vanishing step. -/ +theorem squareFieldStepanovLocal_first_eq_zero_or_order_pos + {α β : Type*} (F : α → R) (G : β → R) (c : α × β →₀ S) + (hsquare : ∀ z : IsLocalRing.ResidueField R, + z ^ (Fintype.card K) ^ 2 = z) + (hsecond : + Finsupp.linearCombination S + (fun ij : α × β => + (F ij.1) ^ Fintype.card K * G ij.2) c = 0) : + algebraMap R L + (Finsupp.linearCombination S + (fun ij : α × β => + F ij.1 * (G ij.2) ^ Fintype.card K) + (squareRootFrobeniusCoefficients K S c)) = 0 ∨ + 0 < finitePlaceOrder + (IsDiscreteValuationRing.maximalIdeal R) + (algebraMap R L + (Finsupp.linearCombination S + (fun ij : α × β => + F ij.1 * (G ij.2) ^ Fintype.card K) + (squareRootFrobeniusCoefficients K S c))) := by + let a : R := Finsupp.linearCombination S + (fun ij : α × β => + F ij.1 * (G ij.2) ^ Fintype.card K) + (squareRootFrobeniusCoefficients K S c) + have hresidue : stepanovLocalResidueAlgHom S R a = 0 := by + have h := squareFieldStepanovLocalResidue_first_eq_frobenius_second + K S R F G c hsquare + change stepanovLocalResidueAlgHom S R a = _ at h + rw [hsecond, map_zero, map_zero] at h + exact h + have haMem : a ∈ IsLocalRing.maximalIdeal R := by + apply (IsLocalRing.residue_eq_zero_iff a).mp + exact hresidue + by_cases haMap : algebraMap R L a = 0 + · exact Or.inl haMap + · refine Or.inr ?_ + have ha : a ≠ 0 := by + intro ha0 + apply haMap + rw [ha0, map_zero] + have horder := one_le_finitePlaceOrder_algebraMap_of_mem + (L := L) (IsDiscreteValuationRing.maximalIdeal R) a haMem ha + change 0 < finitePlaceOrder + (IsDiscreteValuationRing.maximalIdeal R) (algebraMap R L a) + omega + +end LocalOrder + +section FiniteExtensionPlace + +variable (K S : Type*) [Field K] [Fintype K] + [Field S] [DecidableEq S] [Algebra K S] + [DecidableEq (RatFunc S)] +variable (L : Type*) [Field L] [Algebra (RatFunc S) L] + [FiniteDimensional (RatFunc S) L] + [Algebra.IsSeparable (RatFunc S) L] + +omit [DecidableEq S] in +/-- Finite-place form of semilinear square-field vanishing. The function +field and its places are over the full constant field `S`; `K` supplies the +half-Frobenius exponent. -/ +theorem squareFieldStepanovFirstRestriction_eq_zero_or_principalDivisor_pos_at_finitePlace + {α β : Type*} + (q : FiniteExtensionFinitePlace S L) + (f : α → L) (g : β → L) (c : α × β →₀ S) + (hfRegular : ∀ i, + 0 ≤ finiteExtensionPrincipalDivisor S L (f i) (.inl q)) + (hgRegular : ∀ j, + 0 ≤ finiteExtensionPrincipalDivisor S L (g j) (.inl q)) + (hsquare : ∀ z : q.asIdeal.ResidueField, + z ^ (Fintype.card K) ^ 2 = z) + (hsecond : onePointStepanovSecondRestrictionMap S L f g + (Fintype.card K) c = 0) : + squareFieldStepanovFirstRestriction K S L f g c = 0 ∨ + 0 < finiteExtensionPrincipalDivisor S L + (squareFieldStepanovFirstRestriction K S L f g c) (.inl q) := by + let A := RatFuncFiniteIntegralClosure S L + let R := FiniteExtensionFinitePlaceLocalRing S L q + let : Algebra S L := + RingHom.toAlgebra ((algebraMap (RatFunc S) L).comp + (algebraMap S (RatFunc S))) + let : IsScalarTower S (RatFunc S) L := + IsScalarTower.of_algebraMap_eq' rfl + let : Algebra S[X] L := + RingHom.toAlgebra ((algebraMap (RatFunc S) L).comp + (algebraMap S[X] (RatFunc S))) + let : IsScalarTower S[X] (RatFunc S) L := + IsScalarTower.of_algebraMap_eq' rfl + let : Algebra S (RatFuncFiniteIntegralClosure S L) := + RingHom.toAlgebra + ((algebraMap S[X] (RatFuncFiniteIntegralClosure S L)).comp + (algebraMap S S[X])) + let : IsScalarTower S S[X] (RatFuncFiniteIntegralClosure S L) := + IsScalarTower.of_algebraMap_eq' rfl + let : Algebra.IsIntegral S[X] (RatFuncFiniteIntegralClosure S L) := + IsIntegralClosure.isIntegral_algebra S[X] L + let : Module.Finite S[X] (RatFuncFiniteIntegralClosure S L) := + Module.IsNoetherian.finite S[X] (RatFuncFiniteIntegralClosure S L) + let : Module.IsTorsionFree S[X] L := + Module.IsTorsionFree.trans_faithfulSMul S[X] (RatFunc S) L + let : Module.IsTorsionFree S[X] + (RatFuncFiniteIntegralClosure S L) := + IsIntegralClosure.isTorsionFree S[X] L + let : IsDedekindDomain (RatFuncFiniteIntegralClosure S L) := + IsIntegralClosure.isDedekindDomain S[X] (RatFunc S) L + (RatFuncFiniteIntegralClosure S L) + let : IsFractionRing (RatFuncFiniteIntegralClosure S L) L := + IsIntegralClosure.isFractionRing_of_finite_extension + S[X] (RatFunc S) L (RatFuncFiniteIntegralClosure S L) + let : Algebra (RatFuncFiniteIntegralClosure S L) + (RatFuncFiniteIntegralClosure S L) := + Algebra.id (RatFuncFiniteIntegralClosure S L) + let localAlgebra : Algebra (RatFuncFiniteIntegralClosure S L) + (FiniteExtensionFinitePlaceLocalRing S L q) := + OreLocalization.instAlgebra + let := localAlgebra + let : SMul (RatFuncFiniteIntegralClosure S L) + (FiniteExtensionFinitePlaceLocalRing S L q) := + localAlgebra.toSMul + let : Algebra S (FiniteExtensionFinitePlaceLocalRing S L q) := + OreLocalization.instAlgebra + let := finiteExtensionFinitePlaceLocalAlgebra (K := S) (L := L) q + let := finiteExtensionFinitePlaceLocalIsFractionRing (K := S) (L := L) q + let : IsScalarTower S R L := by + apply IsScalarTower.of_algebraMap_eq' + ext x + symm + change finiteExtensionFinitePlaceLocalizationToField + (K := S) (L := L) q (algebraMap S R x) = algebraMap S L x + rw [show algebraMap S R x = + algebraMap A R (algebraMap S A x) by rfl] + rw [show finiteExtensionFinitePlaceLocalizationToField + (K := S) (L := L) q (algebraMap A R (algebraMap S A x)) = + algebraMap A L (algebraMap S A x) by + exact DFunLike.congr_fun + (finiteExtensionFinitePlaceLocalizationToField_comp_algebraMap + (K := S) (L := L) q) (algebraMap S A x)] + rfl + let : IsDiscreteValuationRing R := + IsLocalization.AtPrime.isDiscreteValuationRing_of_dedekind_domain + A q.ne_bot R + let : Algebra K R := RingHom.toAlgebra + ((algebraMap S R).comp (algebraMap K S)) + let eResidue : + (RatFuncFiniteIntegralClosure S L ⧸ q.asIdeal) ≃+* + IsLocalRing.ResidueField R := + IsLocalization.AtPrime.equivQuotMaximalIdeal q.asIdeal R + let eQuotientResidue : + (RatFuncFiniteIntegralClosure S L ⧸ q.asIdeal) ≃+* + q.asIdeal.ResidueField := + RingEquiv.ofBijective + (algebraMap + (RatFuncFiniteIntegralClosure S L ⧸ q.asIdeal) + q.asIdeal.ResidueField) + (Ideal.bijective_algebraMap_quotient_residueField q.asIdeal) + have hsquareQuotient : + ∀ z : RatFuncFiniteIntegralClosure S L ⧸ q.asIdeal, + z ^ (Fintype.card K) ^ 2 = z := by + intro z + apply eQuotientResidue.injective + simpa only [map_pow] using hsquare (eQuotientResidue z) + have hsquareLocal : ∀ z : IsLocalRing.ResidueField R, + z ^ (Fintype.card K) ^ 2 = z := by + intro z + have h := congrArg eResidue (hsquareQuotient (eResidue.symm z)) + simpa only [map_pow, RingEquiv.apply_symm_apply] using h + have hfTop (i : α) : + (0 : WithTop ℤ) ≤ + finiteExtensionFinitePlaceLocalOrderTop (K := S) (L := L) q (f i) := by + by_cases hfi : f i = 0 + · simp [hfi, finiteExtensionFinitePlaceLocalOrderTop] + · rw [finiteExtensionFinitePlaceLocalOrderTop_eq_principalDivisor + S L q (f i) hfi] + exact_mod_cast hfRegular i + have hgTop (j : β) : + (0 : WithTop ℤ) ≤ + finiteExtensionFinitePlaceLocalOrderTop (K := S) (L := L) q (g j) := by + by_cases hgj : g j = 0 + · simp [hgj, finiteExtensionFinitePlaceLocalOrderTop] + · rw [finiteExtensionFinitePlaceLocalOrderTop_eq_principalDivisor + S L q (g j) hgj] + exact_mod_cast hgRegular j + let F : α → R := fun i => Classical.choose + (finiteExtensionFinitePlace_exists_local_lift_of_orderTop_nonnegative + (K := S) (L := L) q (f i) (hfTop i)) + let G : β → R := fun j => Classical.choose + (finiteExtensionFinitePlace_exists_local_lift_of_orderTop_nonnegative + (K := S) (L := L) q (g j) (hgTop j)) + have hF (i : α) : f i = algebraMap R L (F i) := by + exact Classical.choose_spec + (finiteExtensionFinitePlace_exists_local_lift_of_orderTop_nonnegative + (K := S) (L := L) q (f i) (hfTop i)) + have hG (j : β) : g j = algebraMap R L (G j) := by + exact Classical.choose_spec + (finiteExtensionFinitePlace_exists_local_lift_of_orderTop_nonnegative + (K := S) (L := L) q (g j) (hgTop j)) + let firstLocal : R := Finsupp.linearCombination S + (fun ij : α × β => + F ij.1 * (G ij.2) ^ Fintype.card K) + (squareRootFrobeniusCoefficients K S c) + let secondLocal : R := Finsupp.linearCombination S + (fun ij : α × β => + (F ij.1) ^ Fintype.card K * G ij.2) c + let ι : R →ₗ[S] L := (IsScalarTower.toAlgHom S R L).toLinearMap + have hfirstMap : + squareFieldStepanovFirstRestriction K S L f g c = + algebraMap R L firstLocal := by + symm + calc + algebraMap R L firstLocal = ι firstLocal := rfl + _ = Finsupp.linearCombination S + (fun ij : α × β => + ι (F ij.1 * (G ij.2) ^ Fintype.card K)) + (squareRootFrobeniusCoefficients K S c) := by + exact Finsupp.apply_linearCombination S ι _ _ + _ = Finsupp.linearCombination S + (fun ij : α × β => + f ij.1 * (g ij.2) ^ Fintype.card K) + (squareRootFrobeniusCoefficients K S c) := by + apply congrArg (fun v => Finsupp.linearCombination S v + (squareRootFrobeniusCoefficients K S c)) + funext ij + change algebraMap R L + (F ij.1 * (G ij.2) ^ Fintype.card K) = _ + rw [map_mul, map_pow, ← hF ij.1, ← hG ij.2] + _ = squareFieldStepanovFirstRestriction K S L f g c := rfl + have hsecondMap : + onePointStepanovSecondRestrictionMap S L f g + (Fintype.card K) c = algebraMap R L secondLocal := by + symm + calc + algebraMap R L secondLocal = ι secondLocal := rfl + _ = Finsupp.linearCombination S + (fun ij : α × β => + ι ((F ij.1) ^ Fintype.card K * G ij.2)) c := by + exact Finsupp.apply_linearCombination S ι _ c + _ = Finsupp.linearCombination S + (fun ij : α × β => + (f ij.1) ^ Fintype.card K * g ij.2) c := by + apply congrArg (fun v => Finsupp.linearCombination S v c) + funext ij + change algebraMap R L + ((F ij.1) ^ Fintype.card K * G ij.2) = _ + rw [map_mul, map_pow, ← hF ij.1, ← hG ij.2] + _ = onePointStepanovSecondRestrictionMap S L f g + (Fintype.card K) c := rfl + have hsecondLocal : secondLocal = 0 := by + apply IsFractionRing.injective R L + rw [map_zero, ← hsecondMap] + exact hsecond + have hlocal := squareFieldStepanovLocal_first_eq_zero_or_order_pos + K S R L F G c hsquareLocal hsecondLocal + rcases hlocal with hzero | hpositive + · exact Or.inl (by rw [hfirstMap]; exact hzero) + · refine Or.inr ?_ + rw [hfirstMap, + finiteExtensionPrincipalDivisor_inl_eq_finitePlaceOrder, + ← finiteExtensionFinitePlaceLocalOrder_eq_globalOrder q] + change 0 < finitePlaceOrder + (IsDiscreteValuationRing.maximalIdeal R) (algebraMap R L firstLocal) + exact hpositive + +end FiniteExtensionPlace + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/SquareFieldStepanovZeroCount.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/SquareFieldStepanovZeroCount.lean new file mode 100644 index 0000000000..7af0a64998 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/SquareFieldStepanovZeroCount.lean @@ -0,0 +1,117 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.OnePointHeight +public import LeanPool.MarkoffModP.BGS.HasseWeil.SquareFieldStepanovAuxiliary +public import Mathlib.Tactic + +/-! +# The square-field Stepanov zero count + +This module turns a semilinear square-field Stepanov auxiliary into the +sharp zero-count estimate. The selected points are represented by an +injective finite family of finite exhaustive places, all away from a +degree-one pole place `P`. + +Membership of the two section families in their one-point Riemann spaces +makes every section regular at each selected place. The square-field local +vanishing theorem then gives positive order of the nonzero first restriction +at every selected place. Its pole budget is `ell + (#K) * m`, so the +degree-one one-point height bound controls the cardinality of the family by +that same number. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +open BGS.CorvajaZannier +open scoped Polynomial + +noncomputable section + +variable (K S : Type*) [Field K] [Fintype K] + [Field S] [Fintype S] [DecidableEq S] [Algebra K S] + [DecidableEq (RatFunc S)] +variable (L : Type*) [Field L] [Algebra (RatFunc S) L] + [FiniteDimensional (RatFunc S) L] + [Algebra.IsSeparable (RatFunc S) L] + +local instance squareFieldZeroCountConstantAlgebra : Algebra S L := + RingHom.toAlgebra ((algebraMap (RatFunc S) L).comp + (algebraMap S (RatFunc S))) + +local instance squareFieldZeroCountConstantTower : + IsScalarTower S (RatFunc S) L := + IsScalarTower.of_algebraMap_eq' rfl + +/-- A square-field Stepanov auxiliary bounds any injective finite family of +finite places away from its degree-one pole place. + +The quadratic Frobenius identity is required only in the residue field of +each selected place. Thus the theorem records exactly the local geometric +input used by the semilinear vanishing step, without imposing a global +residue-degree assertion. -/ +theorem Fintype.card_le_of_squareFieldStepanovAuxiliary + {alpha beta iota : Type*} [Fintype iota] + (P : FiniteExtensionPlace S L) (ell m : Nat) + (f : alpha → L) (df : alpha → Nat) + (g : beta → L) (dg : beta → Nat) + (c : alpha × beta →₀ S) + (hf : onePointSectionFamilySpec S L P ell f df) + (hg : onePointSectionFamilySpec S L P m g dg) + (hdegree : finiteExtensionPlaceDegree S L P = 1) + (place : iota → FiniteExtensionFinitePlace S L) + (hinjective : Function.Injective place) + (haway : ∀ i, + (Sum.inl (place i) : FiniteExtensionPlace S L) ≠ P) + (hsquare : ∀ (i : iota) (z : (place i).asIdeal.ResidueField), + z ^ (Fintype.card K) ^ 2 = z) + (hsecond : onePointStepanovSecondRestrictionMap S L f g + (Fintype.card K) c = 0) + (hfirst : squareFieldStepanovFirstRestriction K S L f g c ≠ 0) : + Fintype.card iota ≤ ell + Fintype.card K * m := by + have hfRegular (i : iota) (a : alpha) : + 0 ≤ finiteExtensionPrincipalDivisor S L (f a) (.inl (place i)) := by + rcases (mem_finiteExtensionOnePointRiemannSpace_iff + S L P ell (f a)).mp (hf.1 a) with hzero | hdescription + · exact (hf.2.1 a hzero).elim + · exact hdescription.2.2 (.inl (place i)) (haway i) + have hgRegular (i : iota) (b : beta) : + 0 ≤ finiteExtensionPrincipalDivisor S L (g b) (.inl (place i)) := by + rcases (mem_finiteExtensionOnePointRiemannSpace_iff + S L P m (g b)).mp (hg.1 b) with hzero | hdescription + · exact (hg.2.1 b hzero).elim + · exact hdescription.2.2 (.inl (place i)) (haway i) + have hpositive (i : iota) : + 0 < finiteExtensionPrincipalDivisor S L + (squareFieldStepanovFirstRestriction K S L f g c) + (.inl (place i)) := by + exact (squareFieldStepanovFirstRestriction_eq_zero_or_principalDivisor_pos_at_finitePlace + K S L (place i) f g c (hfRegular i) (hgRegular i) + (hsquare i) hsecond).resolve_left hfirst + have hplaceInjective : Function.Injective + (fun i => (Sum.inl (place i) : FiniteExtensionPlace S L)) := by + intro i j hij + apply hinjective + exact Sum.inl.inj hij + have hspace : squareFieldStepanovFirstRestriction K S L f g c ∈ + finiteExtensionOnePointRiemannSpace S L P + (ell + Fintype.card K * m) := + squareFieldStepanovFirstRestriction_mem K S L P f g ell m + hf.1 hg.1 c + exact Fintype.card_le_of_onePointRiemannSpace_degree_one + S L P (ell + Fintype.card K * m) + (squareFieldStepanovFirstRestriction K S L f g c) + hfirst hspace hdegree + (fun i => (Sum.inl (place i) : FiniteExtensionPlace S L)) + hplaceInjective hpositive + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/StepanovLinearAlgebra.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/StepanovLinearAlgebra.lean new file mode 100644 index 0000000000..07d92bc382 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/StepanovLinearAlgebra.lean @@ -0,0 +1,139 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.OnePointHeight +public import Mathlib.LinearAlgebra.Dimension.Finite +public import Mathlib.LinearAlgebra.Dimension.Constructions + +/-! +# Linear-algebra core of the Bombieri--Stepanov argument + +This file isolates the rank-nullity step from the geometry. A finite +controlled-degree space `V` has two restriction maps. If the second map has +target dimension smaller than `V`, while the first map is injective, there is +an auxiliary vector which vanishes under the second restriction but remains +nonzero under the first. Once the first restriction is known to lie in a +one-point Riemann space and to vanish at every rational intersection point, +the exhaustive divisor zero count bounds the number of those points. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +open BGS.CorvajaZannier +open scoped nonZeroDivisors Polynomial TensorProduct + +noncomputable section + +variable {k V W₁ W₂ : Type*} [Field k] + [AddCommGroup V] [Module k V] + [AddCommGroup W₁] [Module k W₁] + [AddCommGroup W₂] [Module k W₂] + +/-- Rank-nullity produces an auxiliary vector killed by `second` but not by +the injective map `first`. -/ +theorem exists_auxiliary_of_finrank_lt + [FiniteDimensional k V] [FiniteDimensional k W₂] + (first : V →ₗ[k] W₁) (second : V →ₗ[k] W₂) + (hfirst : Function.Injective first) + (hdim : Module.finrank k W₂ < Module.finrank k V) : + ∃ v : V, v ≠ 0 ∧ second v = 0 ∧ first v ≠ 0 := by + have hnotInjective : ¬ Function.Injective second := by + intro hinjective + have := LinearMap.finrank_le_finrank_of_injective hinjective + omega + rw [Function.not_injective_iff] at hnotInjective + obtain ⟨x, y, heq, hxy⟩ := hnotInjective + refine ⟨x - y, sub_ne_zero.mpr hxy, ?_, ?_⟩ + · simpa using sub_eq_zero.mpr heq + · exact (map_ne_zero_iff first hfirst).mpr (sub_ne_zero.mpr hxy) + +/-- Riemann-space lower bounds and a target upper bound imply the strict +dimension inequality needed by rank-nullity on a tensor product. -/ +theorem tensor_finrank_gt_of_bounds + {A B W : Type*} + [AddCommGroup A] [Module k A] [FiniteDimensional k A] + [AddCommGroup B] [Module k B] [FiniteDimensional k B] + [AddCommGroup W] [Module k W] [FiniteDimensional k W] + {a b targetBound : ℕ} + (hA : a ≤ Module.finrank k A) + (hB : b ≤ Module.finrank k B) + (hW : Module.finrank k W ≤ targetBound) + (hnumeric : targetBound < a * b) : + Module.finrank k W < Module.finrank k (A ⊗[k] B) := by + rw [Module.finrank_tensorProduct] + exact hW.trans_lt (hnumeric.trans_le (Nat.mul_le_mul hA hB)) + +variable (K : Type*) [Field K] [Fintype K] [DecidableEq K] + [DecidableEq (RatFunc K)] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +local instance stepanovLinearAlgebraConstantAlgebra : Algebra K L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K (RatFunc K))) + +local instance stepanovLinearAlgebraConstantTower : + IsScalarTower K (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + +/-- Abstract Stepanov zero-count theorem. + +The hypotheses after rank-nullity are exactly the geometric obligations left +to an application: the first restriction has controlled poles, the selected +places are distinct, and vanishing of the second restriction forces positive +order of the first restriction at each selected place. -/ +theorem card_le_mul_placeDegree_of_stepanov_restrictions + {V W : Type*} [AddCommGroup V] [Module K V] + [AddCommGroup W] [Module K W] + [FiniteDimensional K V] [FiniteDimensional K W] + {ι : Type*} [Fintype ι] + (P : FiniteExtensionPlace K L) (n : ℕ) + (first : V →ₗ[K] L) (second : V →ₗ[K] W) + (hfirst : Function.Injective first) + (hdim : Module.finrank K W < Module.finrank K V) + (hspace : ∀ v, first v ∈ + finiteExtensionOnePointRiemannSpace K L P n) + (place : ι → FiniteExtensionPlace K L) + (hplace : Function.Injective place) + (hvanish : ∀ v, v ≠ 0 → second v = 0 → ∀ i, + 0 < finiteExtensionPrincipalDivisor K L (first v) (place i)) : + Fintype.card ι ≤ n * finiteExtensionPlaceDegree K L P := by + obtain ⟨v, hv, hsecond, hfirstv⟩ := + exists_auxiliary_of_finrank_lt first second hfirst hdim + exact Fintype.card_le_mul_placeDegree_of_onePointRiemannSpace + K L P n (first v) hfirstv (hspace v) place hplace + (hvanish v hv hsecond) + +/-- Degree-one version of the abstract Stepanov zero-count theorem. -/ +theorem card_le_of_stepanov_restrictions_degree_one + {V W : Type*} [AddCommGroup V] [Module K V] + [AddCommGroup W] [Module K W] + [FiniteDimensional K V] [FiniteDimensional K W] + {ι : Type*} [Fintype ι] + (P : FiniteExtensionPlace K L) (n : ℕ) + (first : V →ₗ[K] L) (second : V →ₗ[K] W) + (hfirst : Function.Injective first) + (hdim : Module.finrank K W < Module.finrank K V) + (hspace : ∀ v, first v ∈ + finiteExtensionOnePointRiemannSpace K L P n) + (hdegree : finiteExtensionPlaceDegree K L P = 1) + (place : ι → FiniteExtensionPlace K L) + (hplace : Function.Injective place) + (hvanish : ∀ v, v ≠ 0 → second v = 0 → ∀ i, + 0 < finiteExtensionPrincipalDivisor K L (first v) (place i)) : + Fintype.card ι ≤ n := by + simpa [hdegree] using + card_le_mul_placeDegree_of_stepanov_restrictions + K L P n first second hfirst hdim hspace place hplace hvanish + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/StepanovParameters.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/StepanovParameters.lean new file mode 100644 index 0000000000..7d3a0fb536 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/StepanovParameters.lean @@ -0,0 +1,97 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import Mathlib.Algebra.Order.Ring.Star +public import Mathlib.Data.Int.Star +public import Mathlib.Tactic +public import Mathlib.Tactic.Linarith.Lemmas +public import Mathlib.Tactic.NormNum.Ineq +public import Mathlib.Tactic.Ring.Basic +public import Mathlib.Tactic.Zify + +/-! +# Numerical parameters for the Bombieri--Stepanov argument + +The sharp parameter choice in Tao's exposition uses a floor. The BGS +application only needs a universal bidegree multiple of the square-root +error, so it is cleaner to use + +`ell = s - 1`, `m = s + 2 * g` + +when the square-root field size `s` is at least `(g + 1) * (g + 2)`. +These parameters satisfy the three inequalities needed by the one-point +Riemann-space argument, and give the same `O(g * s)` error term. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +/-- The slightly non-sharp parameters used in the formal Stepanov argument. -/ +def stepanovEll (s : ℕ) : ℕ := s - 1 + +/-- The second tensor-factor parameter used in the formal Stepanov argument. -/ +def stepanovM (g s : ℕ) : ℕ := s + 2 * g + +/-- The first parameter is strictly smaller than the Frobenius scale. -/ +theorem stepanovEll_lt + {g s : ℕ} (hlarge : (g + 1) * (g + 2) ≤ s) : + stepanovEll s < s := by + have hs : 0 < s := by nlinarith + simp only [stepanovEll] + omega + +/-- Both tensor factors are large enough for Riemann's inequality. -/ +theorem stepanov_genus_le_parameters + {g s : ℕ} (hlarge : (g + 1) * (g + 2) ≤ s) : + g ≤ stepanovEll s + 1 ∧ g ≤ stepanovM g s + 1 := by + have hgs : g ≤ s := by nlinarith + constructor + · simp only [stepanovEll] + omega + · simp only [stepanovM] + omega + +/-- The tensor-product dimension lower bound is strictly larger than the +dimension upper bound for the second Frobenius restriction map. -/ +theorem stepanov_dimension_inequality + {g s : ℕ} (hlarge : (g + 1) * (g + 2) ≤ s) : + (stepanovEll s + 1 - g) * (stepanovM g s + 1 - g) > + stepanovEll s * s + stepanovM g s + 1 := by + have hs : 0 < s := by nlinarith + have hgs : g ≤ s := by nlinarith + have hfirst : stepanovEll s + 1 - g = s - g := by + simp only [stepanovEll] + omega + have hsecond : stepanovM g s + 1 - g = s + g + 1 := by + simp only [stepanovM] + omega + rw [hfirst, hsecond] + simp only [stepanovEll, stepanovM] + have hsOne : 1 ≤ s := by omega + have hlargeZ : + (((g + 1) * (g + 2) : ℕ) : ℤ) ≤ (s : ℤ) := by + exact_mod_cast hlarge + have hgoalZ : + (((s - g : ℕ) : ℤ) * ((s + g + 1 : ℕ) : ℤ)) > + (((s - 1 : ℕ) : ℤ) * (s : ℤ) + ((s + 2 * g : ℕ) : ℤ) + 1) := by + rw [Nat.cast_sub hgs, Nat.cast_sub hsOne] + push_cast at hlargeZ ⊢ + nlinarith + exact_mod_cast hgoalZ + +/-- The resulting zero-count bound is at most +`s^2 + (2g+1)s`; this is the weak Hasse--Weil upper bound needed later. -/ +theorem stepanov_zero_bound + {g s : ℕ} (hs : 0 < s) : + stepanovEll s + stepanovM g s * s ≤ + s ^ 2 + (2 * g + 1) * s := by + simp only [stepanovEll, stepanovM] + nlinarith [Nat.sub_add_cancel (Nat.one_le_iff_ne_zero.mpr hs.ne')] + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/StepanovRestrictionMaps.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/StepanovRestrictionMaps.lean new file mode 100644 index 0000000000..b28ecd0985 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/StepanovRestrictionMaps.lean @@ -0,0 +1,328 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.OnePointIncrement +public import LeanPool.MarkoffModP.BGS.HasseWeil.OnePointStepanovGrid +public import LeanPool.MarkoffModP.BGS.HasseWeil.StepanovLinearAlgebra +public import Mathlib.LinearAlgebra.Dimension.Constructions +public import Mathlib.Tactic + +/-! +# Stepanov restriction maps on a finite coefficient grid + +For finite families `f : α → L` and `g : β → L`, the coefficient space is +the free `K`-module `(α × β →₀ K)`. Its two restriction maps evaluate the +same coefficient grid against + +* `f i * (g j) ^ s`, and +* `(f i) ^ s * g j`. + +The maps are defined with `Finsupp.linearCombination`. One-point pole bounds +give codomain restrictions with budgets `ell + s * m` and `s * ell + m`. +The final results expose exactly the injectivity and finrank interfaces used +by `exists_auxiliary_of_finrank_lt`. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +open BGS.CorvajaZannier +open scoped Polynomial BigOperators + +noncomputable section + + +variable (K : Type*) [Field K] [Fintype K] [DecidableEq K] + [DecidableEq (RatFunc K)] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +local instance stepanovRestrictionConstantAlgebra : Algebra K L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K (RatFunc K))) + +local instance stepanovRestrictionConstantTower : + IsScalarTower K (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + +/-- The first Stepanov restriction: evaluate the coefficient grid against +`f i * (g j) ^ s`. -/ +def onePointStepanovFirstRestrictionMap + {α β : Type*} (f : α → L) (g : β → L) (s : ℕ) : + (α × β →₀ K) →ₗ[K] L := + Finsupp.linearCombination K + (fun ij : α × β => f ij.1 * (g ij.2) ^ s) + +/-- The second Stepanov restriction: evaluate the coefficient grid against +`(f i) ^ s * g j`. -/ +def onePointStepanovSecondRestrictionMap + {α β : Type*} (f : α → L) (g : β → L) (s : ℕ) : + (α × β →₀ K) →ₗ[K] L := + Finsupp.linearCombination K + (fun ij : α × β => (f ij.1) ^ s * g ij.2) + +omit [Fintype K] [DecidableEq K] [DecidableEq (RatFunc K)] [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] in +@[simp] +theorem onePointStepanovFirstRestrictionMap_single + {α β : Type*} (f : α → L) (g : β → L) (s : ℕ) + (ij : α × β) (c : K) : + onePointStepanovFirstRestrictionMap K L f g s + (Finsupp.single ij c) = + c • (f ij.1 * (g ij.2) ^ s) := by + simp [onePointStepanovFirstRestrictionMap] + +omit [Fintype K] [DecidableEq K] [DecidableEq (RatFunc K)] [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] in +@[simp] +theorem onePointStepanovSecondRestrictionMap_single + {α β : Type*} (f : α → L) (g : β → L) (s : ℕ) + (ij : α × β) (c : K) : + onePointStepanovSecondRestrictionMap K L f g s + (Finsupp.single ij c) = + c • ((f ij.1) ^ s * g ij.2) := by + simp [onePointStepanovSecondRestrictionMap] + +/-- Powers multiply a one-point pole budget. -/ +theorem finiteExtensionOnePointRiemannSpace_pow_mem + (P : FiniteExtensionPlace K L) {m : ℕ} {x : L} + (hx : x ∈ finiteExtensionOnePointRiemannSpace K L P m) + (s : ℕ) : + x ^ s ∈ finiteExtensionOnePointRiemannSpace K L P (s * m) := by + classical + change x ^ s ∈ finiteExtensionRiemannSpace K L + (Finsupp.single P ((s * m : ℕ) : ℤ)) + have hpow := finiteExtensionRiemannSpace_pow_mem K L hx s + have hdivisor : + s • Finsupp.single P (m : ℤ) = + Finsupp.single P ((s * m : ℕ) : ℤ) := by + ext v + by_cases hv : v = P + · subst v + simp + · simp [Finsupp.single_eq_of_ne hv] + rw [← hdivisor] + exact hpow + +/-- Every basis value of the first restriction has pole budget +`ell + s * m`. -/ +theorem onePointStepanovFirstGrid_mem + {α β : Type*} (P : FiniteExtensionPlace K L) + (f : α → L) (g : β → L) (ell m s : ℕ) + (hf : ∀ i, f i ∈ finiteExtensionOnePointRiemannSpace K L P ell) + (hg : ∀ j, g j ∈ finiteExtensionOnePointRiemannSpace K L P m) + (ij : α × β) : + f ij.1 * (g ij.2) ^ s ∈ + finiteExtensionOnePointRiemannSpace K L P (ell + s * m) := by + exact finiteExtensionOnePointRiemannSpace_mul_mem K L P + (hf ij.1) + (finiteExtensionOnePointRiemannSpace_pow_mem K L P (hg ij.2) s) + +/-- Every basis value of the second restriction has pole budget +`s * ell + m`. -/ +theorem onePointStepanovSecondGrid_mem + {α β : Type*} (P : FiniteExtensionPlace K L) + (f : α → L) (g : β → L) (ell m s : ℕ) + (hf : ∀ i, f i ∈ finiteExtensionOnePointRiemannSpace K L P ell) + (hg : ∀ j, g j ∈ finiteExtensionOnePointRiemannSpace K L P m) + (ij : α × β) : + (f ij.1) ^ s * g ij.2 ∈ + finiteExtensionOnePointRiemannSpace K L P (s * ell + m) := by + exact finiteExtensionOnePointRiemannSpace_mul_mem K L P + (finiteExtensionOnePointRiemannSpace_pow_mem K L P (hf ij.1) s) + (hg ij.2) + +/-- The whole first linear combination has pole budget `ell + s * m`. -/ +theorem onePointStepanovFirstRestrictionMap_mem + {α β : Type*} (P : FiniteExtensionPlace K L) + (f : α → L) (g : β → L) (ell m s : ℕ) + (hf : ∀ i, f i ∈ finiteExtensionOnePointRiemannSpace K L P ell) + (hg : ∀ j, g j ∈ finiteExtensionOnePointRiemannSpace K L P m) + (c : α × β →₀ K) : + onePointStepanovFirstRestrictionMap K L f g s c ∈ + finiteExtensionOnePointRiemannSpace K L P (ell + s * m) := by + rw [onePointStepanovFirstRestrictionMap, + Finsupp.linearCombination_apply, Finsupp.sum] + apply Submodule.sum_mem + intro ij hij + exact (finiteExtensionOnePointRiemannSpace K L P (ell + s * m)).smul_mem + (c ij) (onePointStepanovFirstGrid_mem K L P f g ell m s hf hg ij) + +/-- The whole second linear combination has pole budget `s * ell + m`. -/ +theorem onePointStepanovSecondRestrictionMap_mem + {α β : Type*} (P : FiniteExtensionPlace K L) + (f : α → L) (g : β → L) (ell m s : ℕ) + (hf : ∀ i, f i ∈ finiteExtensionOnePointRiemannSpace K L P ell) + (hg : ∀ j, g j ∈ finiteExtensionOnePointRiemannSpace K L P m) + (c : α × β →₀ K) : + onePointStepanovSecondRestrictionMap K L f g s c ∈ + finiteExtensionOnePointRiemannSpace K L P (s * ell + m) := by + rw [onePointStepanovSecondRestrictionMap, + Finsupp.linearCombination_apply, Finsupp.sum] + apply Submodule.sum_mem + intro ij hij + exact (finiteExtensionOnePointRiemannSpace K L P (s * ell + m)).smul_mem + (c ij) (onePointStepanovSecondGrid_mem K L P f g ell m s hf hg ij) + +/-- The first restriction with its one-point codomain made explicit. -/ +def onePointStepanovFirstCodRestrictionMap + {α β : Type*} (P : FiniteExtensionPlace K L) + (f : α → L) (g : β → L) (ell m s : ℕ) + (hf : ∀ i, f i ∈ finiteExtensionOnePointRiemannSpace K L P ell) + (hg : ∀ j, g j ∈ finiteExtensionOnePointRiemannSpace K L P m) : + (α × β →₀ K) →ₗ[K] + finiteExtensionOnePointRiemannSpace K L P (ell + s * m) := + LinearMap.codRestrict _ + (onePointStepanovFirstRestrictionMap K L f g s) + (onePointStepanovFirstRestrictionMap_mem K L P f g ell m s hf hg) + +/-- The second restriction with its one-point codomain made explicit. -/ +def onePointStepanovSecondCodRestrictionMap + {α β : Type*} (P : FiniteExtensionPlace K L) + (f : α → L) (g : β → L) (ell m s : ℕ) + (hf : ∀ i, f i ∈ finiteExtensionOnePointRiemannSpace K L P ell) + (hg : ∀ j, g j ∈ finiteExtensionOnePointRiemannSpace K L P m) : + (α × β →₀ K) →ₗ[K] + finiteExtensionOnePointRiemannSpace K L P (s * ell + m) := + LinearMap.codRestrict _ + (onePointStepanovSecondRestrictionMap K L f g s) + (onePointStepanovSecondRestrictionMap_mem K L P f g ell m s hf hg) + +@[simp] +theorem onePointStepanovFirstCodRestrictionMap_coe + {α β : Type*} (P : FiniteExtensionPlace K L) + (f : α → L) (g : β → L) (ell m s : ℕ) + (hf : ∀ i, f i ∈ finiteExtensionOnePointRiemannSpace K L P ell) + (hg : ∀ j, g j ∈ finiteExtensionOnePointRiemannSpace K L P m) + (c : α × β →₀ K) : + ((onePointStepanovFirstCodRestrictionMap K L P f g ell m s hf hg c : + finiteExtensionOnePointRiemannSpace K L P (ell + s * m)) : L) = + onePointStepanovFirstRestrictionMap K L f g s c := by + rfl + +@[simp] +theorem onePointStepanovSecondCodRestrictionMap_coe + {α β : Type*} (P : FiniteExtensionPlace K L) + (f : α → L) (g : β → L) (ell m s : ℕ) + (hf : ∀ i, f i ∈ finiteExtensionOnePointRiemannSpace K L P ell) + (hg : ∀ j, g j ∈ finiteExtensionOnePointRiemannSpace K L P m) + (c : α × β →₀ K) : + ((onePointStepanovSecondCodRestrictionMap K L P f g ell m s hf hg c : + finiteExtensionOnePointRiemannSpace K L P (s * ell + m)) : L) = + onePointStepanovSecondRestrictionMap K L f g s c := by + rfl + +omit [Fintype K] [DecidableEq K] [DecidableEq (RatFunc K)] [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] in +/-- Linear independence of the first product grid is exactly injectivity of +the first restriction map. -/ +theorem onePointStepanovFirstRestrictionMap_injective_of_linearIndependent + {α β : Type*} (f : α → L) (g : β → L) (s : ℕ) + (hLI : LinearIndependent K + (fun ij : α × β => f ij.1 * (g ij.2) ^ s)) : + Function.Injective (onePointStepanovFirstRestrictionMap K L f g s) := by + intro c d hcd + apply sub_eq_zero.mp + apply (linearIndependent_iff.mp hLI) + change onePointStepanovFirstRestrictionMap K L f g s (c - d) = 0 + rw [map_sub, hcd, sub_self] + +omit [DecidableEq K] in +/-- The mixed-order Stepanov-grid criterion proves injectivity of the first +restriction. -/ +theorem onePointStepanovFirstRestrictionMap_injective_of_grid + {α β : Type*} [Fintype α] [Fintype β] + (P : FiniteExtensionPlace K L) + (f : α → L) (g : β → L) (d : α → ℕ) (e : β → ℕ) (s : ℕ) + (hf : ∀ i, f i ≠ 0) (hg : ∀ j, g j ≠ 0) + (hfOrder : ∀ i, finiteExtensionPrincipalDivisor K L (f i) P = + -(d i : ℤ)) + (hgOrder : ∀ j, finiteExtensionPrincipalDivisor K L (g j) P = + -(e j : ℤ)) + (hd : Function.Injective d) (he : Function.Injective e) + (hdigit : ∀ i, d i < s) : + Function.Injective (onePointStepanovFirstRestrictionMap K L f g s) := by + apply onePointStepanovFirstRestrictionMap_injective_of_linearIndependent + exact onePointStepanovGrid_linearIndependent K L P f g d e s + hf hg hfOrder hgOrder hd he hdigit + +/-- The first codomain restriction remains injective. -/ +theorem onePointStepanovFirstCodRestrictionMap_injective_of_linearIndependent + {α β : Type*} (P : FiniteExtensionPlace K L) + (f : α → L) (g : β → L) (ell m s : ℕ) + (hf : ∀ i, f i ∈ finiteExtensionOnePointRiemannSpace K L P ell) + (hg : ∀ j, g j ∈ finiteExtensionOnePointRiemannSpace K L P m) + (hLI : LinearIndependent K + (fun ij : α × β => f ij.1 * (g ij.2) ^ s)) : + Function.Injective + (onePointStepanovFirstCodRestrictionMap K L P f g ell m s hf hg) := by + intro c d hcd + apply onePointStepanovFirstRestrictionMap_injective_of_linearIndependent + K L f g s hLI + exact congrArg Subtype.val hcd + +omit [Fintype K] [DecidableEq K] [DecidableEq (RatFunc K)] in +/-- The coefficient space has dimension equal to the cardinality of its +finite product index. -/ +@[simp] +theorem onePointStepanovCoefficientSpace_finrank + {α β : Type*} [Fintype α] [Fintype β] : + Module.finrank K (α × β →₀ K) = + Fintype.card α * Fintype.card β := by + rw [Module.finrank_finsupp_self, Fintype.card_prod] + +/-- A target finrank upper bound and a numerical strict inequality give the +dimension inequality required by rank-nullity. -/ +theorem onePointStepanovTarget_finrank_lt_coefficientSpace + {α β : Type*} [Fintype α] [Fintype β] + (P : FiniteExtensionPlace K L) (n targetBound : ℕ) + (hupper : Module.finrank K + (finiteExtensionOnePointRiemannSpace K L P n) ≤ targetBound) + (hnumeric : targetBound < Fintype.card α * Fintype.card β) : + Module.finrank K (finiteExtensionOnePointRiemannSpace K L P n) < + Module.finrank K (α × β →₀ K) := by + rw [onePointStepanovCoefficientSpace_finrank K] + exact hupper.trans_lt hnumeric + +/-- Concrete rank-nullity interface for the two Stepanov restrictions. + +An upper bound for the second one-point target, strictly below the product +index cardinality, produces a nonzero coefficient grid killed by the second +restriction and detected by the first. -/ +theorem exists_onePointStepanovAuxiliary_of_target_finrank_upper + {α β : Type*} [Fintype α] [Fintype β] + (P : FiniteExtensionPlace K L) + (f : α → L) (g : β → L) (ell m s targetBound : ℕ) + (hf : ∀ i, f i ∈ finiteExtensionOnePointRiemannSpace K L P ell) + (hg : ∀ j, g j ∈ finiteExtensionOnePointRiemannSpace K L P m) + (hLI : LinearIndependent K + (fun ij : α × β => f ij.1 * (g ij.2) ^ s)) + (hupper : Module.finrank K + (finiteExtensionOnePointRiemannSpace K L P (s * ell + m)) ≤ + targetBound) + (hnumeric : targetBound < Fintype.card α * Fintype.card β) : + ∃ c : α × β →₀ K, + c ≠ 0 ∧ + onePointStepanovSecondCodRestrictionMap K L P f g ell m s hf hg c = 0 ∧ + onePointStepanovFirstRestrictionMap K L f g s c ≠ 0 := by + let : Module.Finite K + (finiteExtensionOnePointRiemannSpace K L P (s * ell + m)) := + finiteExtensionOnePointRiemannSpace_moduleFinite K L P _ + apply exists_auxiliary_of_finrank_lt + (onePointStepanovFirstRestrictionMap K L f g s) + (onePointStepanovSecondCodRestrictionMap K L P f g ell m s hf hg) + · exact onePointStepanovFirstRestrictionMap_injective_of_linearIndependent + K L f g s hLI + · exact onePointStepanovTarget_finrank_lt_coefficientSpace + K L P (s * ell + m) targetBound hupper hnumeric + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/StepanovSquareVanishing.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/StepanovSquareVanishing.lean new file mode 100644 index 0000000000..aa3e206581 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/StepanovSquareVanishing.lean @@ -0,0 +1,388 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.FrobeniusRestriction +public import LeanPool.MarkoffModP.BGS.HasseWeil.StepanovRestrictionMaps +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.DedekindLeadingTermCancellation +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveAuxiliaryFinitePlaceCases +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveAuxiliaryFinitePlacePrincipalDivisor +public import Mathlib.Tactic + +/-! +# The quadratic Frobenius vanishing step + +Let `q = #K`. The two Stepanov restrictions use the grids + +* `f i * (g j) ^ q`, and +* `(f i) ^ q * g j`. + +At a place whose residue field satisfies `z ^ (q ^ 2) = z`, the residue of +the first grid is the `q`-Frobenius of the residue of the second grid. +Consequently, if the second restriction vanishes and all grid entries are +regular at the place, the first restriction either vanishes or has positive +order there. + +The square-Frobenius identity is an explicit hypothesis. In particular, +this file does not assert that every normalization place above a quadratic +extension point has residue degree at most two. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +open BGS.CorvajaZannier +open IsDedekindDomain +open scoped Polynomial nonZeroDivisors + +noncomputable section + + +section LocalResidue + +variable (K R : Type*) [Field K] [Fintype K] + [CommRing R] [IsLocalRing R] [Algebra K R] + +/-- The residue map of a local `K`-algebra, bundled as a `K`-algebra map. -/ +def stepanovLocalResidueAlgHom : + R →ₐ[K] IsLocalRing.ResidueField R := + Ideal.Quotient.mkₐ K (IsLocalRing.maximalIdeal R) + +omit [Fintype K] in +@[simp] +theorem stepanovLocalResidueAlgHom_apply (r : R) : + stepanovLocalResidueAlgHom K R r = + algebraMap R (IsLocalRing.ResidueField R) r := by + rfl + +/-- The first Stepanov residue is the `q`-Frobenius of the second residue +when every residue satisfies the quadratic Frobenius identity. -/ +theorem stepanovLocalResidue_first_eq_frobenius_second + {α β : Type*} (F : α → R) (G : β → R) (c : α × β →₀ K) + (hsquare : ∀ z : IsLocalRing.ResidueField R, + z ^ (Fintype.card K) ^ 2 = z) : + stepanovLocalResidueAlgHom K R + (Finsupp.linearCombination K + (fun ij : α × β => + F ij.1 * (G ij.2) ^ Fintype.card K) c) = + powCardAlgHom K (IsLocalRing.ResidueField R) 1 + (stepanovLocalResidueAlgHom K R + (Finsupp.linearCombination K + (fun ij : α × β => + (F ij.1) ^ Fintype.card K * G ij.2) c)) := by + let ρ := stepanovLocalResidueAlgHom K R + let φ := powCardAlgHom K (IsLocalRing.ResidueField R) 1 + have hbasis (ij : α × β) : + ρ (F ij.1 * (G ij.2) ^ Fintype.card K) = + φ (ρ ((F ij.1) ^ Fintype.card K * G ij.2)) := by + dsimp only [ρ, φ] + simp only [map_mul, map_pow, powCardAlgHom_apply, Nat.pow_one] + rw [← pow_mul] + rw [show (stepanovLocalResidueAlgHom K R (F ij.1)) ^ + (Fintype.card K * Fintype.card K) = + stepanovLocalResidueAlgHom K R (F ij.1) by + simpa only [pow_two] using + hsquare (stepanovLocalResidueAlgHom K R (F ij.1))] + calc + ρ (Finsupp.linearCombination K + (fun ij : α × β => + F ij.1 * (G ij.2) ^ Fintype.card K) c) = + Finsupp.linearCombination K + (fun ij : α × β => + ρ (F ij.1 * (G ij.2) ^ Fintype.card K)) c := by + exact Finsupp.apply_linearCombination K ρ.toLinearMap _ c + _ = Finsupp.linearCombination K + (fun ij : α × β => + φ (ρ ((F ij.1) ^ Fintype.card K * G ij.2))) c := by + apply congrArg (fun v => Finsupp.linearCombination K v c) + funext ij + exact hbasis ij + _ = φ (Finsupp.linearCombination K + (fun ij : α × β => + ρ ((F ij.1) ^ Fintype.card K * G ij.2)) c) := by + exact (Finsupp.apply_linearCombination K φ.toLinearMap _ c).symm + _ = φ (ρ (Finsupp.linearCombination K + (fun ij : α × β => + (F ij.1) ^ Fintype.card K * G ij.2) c)) := by + apply congrArg φ + exact (Finsupp.apply_linearCombination K ρ.toLinearMap _ c).symm + +end LocalResidue + +section LocalOrder + +variable (K R L : Type*) [Field K] [Fintype K] + [CommRing R] [IsDedekindDomain R] [IsDiscreteValuationRing R] + [Algebra K R] + [Field L] [Algebra R L] [IsFractionRing R L] + +/-- Local DVR form of square-Frobenius vanishing. If the second local +linear combination is zero, the first is either zero in the fraction field +or has positive order at the maximal ideal. -/ +theorem stepanovLocal_first_eq_zero_or_order_pos + {α β : Type*} (F : α → R) (G : β → R) (c : α × β →₀ K) + (hsquare : ∀ z : IsLocalRing.ResidueField R, + z ^ (Fintype.card K) ^ 2 = z) + (hsecond : + Finsupp.linearCombination K + (fun ij : α × β => + (F ij.1) ^ Fintype.card K * G ij.2) c = 0) : + algebraMap R L + (Finsupp.linearCombination K + (fun ij : α × β => + F ij.1 * (G ij.2) ^ Fintype.card K) c) = 0 ∨ + 0 < finitePlaceOrder + (IsDiscreteValuationRing.maximalIdeal R) + (algebraMap R L + (Finsupp.linearCombination K + (fun ij : α × β => + F ij.1 * (G ij.2) ^ Fintype.card K) c)) := by + let a : R := Finsupp.linearCombination K + (fun ij : α × β => + F ij.1 * (G ij.2) ^ Fintype.card K) c + have hresidue : stepanovLocalResidueAlgHom K R a = 0 := by + have h := stepanovLocalResidue_first_eq_frobenius_second + K R F G c hsquare + change stepanovLocalResidueAlgHom K R a = _ at h + rw [hsecond, map_zero, map_zero] at h + exact h + have haMem : a ∈ IsLocalRing.maximalIdeal R := by + apply (IsLocalRing.residue_eq_zero_iff a).mp + exact hresidue + by_cases haMap : algebraMap R L a = 0 + · exact Or.inl haMap + · refine Or.inr ?_ + have ha : a ≠ 0 := by + intro ha0 + apply haMap + rw [ha0, map_zero] + have horder := one_le_finitePlaceOrder_algebraMap_of_mem + (L := L) (IsDiscreteValuationRing.maximalIdeal R) a haMem ha + change 0 < finitePlaceOrder + (IsDiscreteValuationRing.maximalIdeal R) (algebraMap R L a) + omega + +end LocalOrder + +section FiniteExtensionPlace + +variable (K : Type*) [Field K] [Fintype K] [DecidableEq K] + [DecidableEq (RatFunc K)] +variable (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] + [Algebra.IsSeparable (RatFunc K) L] + +omit [DecidableEq K] in +/-- Finite-place form used after the two Stepanov restriction maps. + +The families are assumed regular at `q`. The residue hypothesis is stated +on the canonical residue field `q.asIdeal.ResidueField`; it is transported +internally to the residue field of the localized DVR. -/ +theorem onePointStepanovFirstRestrictionMap_eq_zero_or_principalDivisor_pos_at_finitePlace + {α β : Type*} + (q : FiniteExtensionFinitePlace K L) + (f : α → L) (g : β → L) (c : α × β →₀ K) + (hfRegular : ∀ i, + 0 ≤ finiteExtensionPrincipalDivisor K L (f i) (.inl q)) + (hgRegular : ∀ j, + 0 ≤ finiteExtensionPrincipalDivisor K L (g j) (.inl q)) + (hsquare : ∀ z : q.asIdeal.ResidueField, + z ^ (Fintype.card K) ^ 2 = z) + (hsecond : onePointStepanovSecondRestrictionMap K L f g + (Fintype.card K) c = 0) : + onePointStepanovFirstRestrictionMap K L f g + (Fintype.card K) c = 0 ∨ + 0 < finiteExtensionPrincipalDivisor K L + (onePointStepanovFirstRestrictionMap K L f g + (Fintype.card K) c) (.inl q) := by + let A := RatFuncFiniteIntegralClosure K L + let R := FiniteExtensionFinitePlaceLocalRing K L q + let : Algebra K L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K (RatFunc K))) + let : IsScalarTower K (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + let : Algebra K[X] L := + RingHom.toAlgebra ((algebraMap (RatFunc K) L).comp + (algebraMap K[X] (RatFunc K))) + let : IsScalarTower K[X] (RatFunc K) L := + IsScalarTower.of_algebraMap_eq' rfl + let : Algebra K (RatFuncFiniteIntegralClosure K L) := + RingHom.toAlgebra + ((algebraMap K[X] (RatFuncFiniteIntegralClosure K L)).comp + (algebraMap K K[X])) + let : IsScalarTower K K[X] (RatFuncFiniteIntegralClosure K L) := + IsScalarTower.of_algebraMap_eq' rfl + let : Algebra.IsIntegral K[X] (RatFuncFiniteIntegralClosure K L) := + IsIntegralClosure.isIntegral_algebra K[X] L + let : Module.Finite K[X] (RatFuncFiniteIntegralClosure K L) := + Module.IsNoetherian.finite K[X] (RatFuncFiniteIntegralClosure K L) + let : Module.IsTorsionFree K[X] L := + Module.IsTorsionFree.trans_faithfulSMul K[X] (RatFunc K) L + let : Module.IsTorsionFree K[X] + (RatFuncFiniteIntegralClosure K L) := + IsIntegralClosure.isTorsionFree K[X] L + let : IsDedekindDomain (RatFuncFiniteIntegralClosure K L) := + IsIntegralClosure.isDedekindDomain K[X] (RatFunc K) L + (RatFuncFiniteIntegralClosure K L) + let : IsFractionRing (RatFuncFiniteIntegralClosure K L) L := + IsIntegralClosure.isFractionRing_of_finite_extension + K[X] (RatFunc K) L (RatFuncFiniteIntegralClosure K L) + let : Algebra (RatFuncFiniteIntegralClosure K L) + (RatFuncFiniteIntegralClosure K L) := + Algebra.id (RatFuncFiniteIntegralClosure K L) + let localAlgebra : Algebra (RatFuncFiniteIntegralClosure K L) + (FiniteExtensionFinitePlaceLocalRing K L q) := + OreLocalization.instAlgebra + let := localAlgebra + let : SMul (RatFuncFiniteIntegralClosure K L) + (FiniteExtensionFinitePlaceLocalRing K L q) := + localAlgebra.toSMul + let : Algebra K (FiniteExtensionFinitePlaceLocalRing K L q) := + OreLocalization.instAlgebra + let := finiteExtensionFinitePlaceLocalAlgebra (K := K) (L := L) q + let := finiteExtensionFinitePlaceLocalIsFractionRing (K := K) (L := L) q + let : IsScalarTower K R L := by + apply IsScalarTower.of_algebraMap_eq' + ext x + symm + change finiteExtensionFinitePlaceLocalizationToField + (K := K) (L := L) q (algebraMap K R x) = algebraMap K L x + rw [show algebraMap K R x = + algebraMap A R (algebraMap K A x) by rfl] + rw [show finiteExtensionFinitePlaceLocalizationToField + (K := K) (L := L) q (algebraMap A R (algebraMap K A x)) = + algebraMap A L (algebraMap K A x) by + exact DFunLike.congr_fun + (finiteExtensionFinitePlaceLocalizationToField_comp_algebraMap + (K := K) (L := L) q) (algebraMap K A x)] + rfl + let : IsDiscreteValuationRing R := + IsLocalization.AtPrime.isDiscreteValuationRing_of_dedekind_domain + A q.ne_bot R + let eResidue : + (RatFuncFiniteIntegralClosure K L ⧸ q.asIdeal) ≃+* + IsLocalRing.ResidueField R := + IsLocalization.AtPrime.equivQuotMaximalIdeal q.asIdeal R + let eQuotientResidue : + (RatFuncFiniteIntegralClosure K L ⧸ q.asIdeal) ≃+* + q.asIdeal.ResidueField := + RingEquiv.ofBijective + (algebraMap + (RatFuncFiniteIntegralClosure K L ⧸ q.asIdeal) + q.asIdeal.ResidueField) + (Ideal.bijective_algebraMap_quotient_residueField q.asIdeal) + have hsquareQuotient : + ∀ z : RatFuncFiniteIntegralClosure K L ⧸ q.asIdeal, + z ^ (Fintype.card K) ^ 2 = z := by + intro z + apply eQuotientResidue.injective + simpa only [map_pow] using hsquare (eQuotientResidue z) + have hsquareLocal : ∀ z : IsLocalRing.ResidueField R, + z ^ (Fintype.card K) ^ 2 = z := by + intro z + have h := congrArg eResidue (hsquareQuotient (eResidue.symm z)) + simpa only [map_pow, RingEquiv.apply_symm_apply] using h + have hfTop (i : α) : + (0 : WithTop ℤ) ≤ + finiteExtensionFinitePlaceLocalOrderTop (K := K) (L := L) q (f i) := by + by_cases hfi : f i = 0 + · simp [hfi, finiteExtensionFinitePlaceLocalOrderTop] + · rw [finiteExtensionFinitePlaceLocalOrderTop_eq_principalDivisor + K L q (f i) hfi] + exact_mod_cast hfRegular i + have hgTop (j : β) : + (0 : WithTop ℤ) ≤ + finiteExtensionFinitePlaceLocalOrderTop (K := K) (L := L) q (g j) := by + by_cases hgj : g j = 0 + · simp [hgj, finiteExtensionFinitePlaceLocalOrderTop] + · rw [finiteExtensionFinitePlaceLocalOrderTop_eq_principalDivisor + K L q (g j) hgj] + exact_mod_cast hgRegular j + let F : α → R := fun i => Classical.choose + (finiteExtensionFinitePlace_exists_local_lift_of_orderTop_nonnegative + (K := K) (L := L) q (f i) (hfTop i)) + let G : β → R := fun j => Classical.choose + (finiteExtensionFinitePlace_exists_local_lift_of_orderTop_nonnegative + (K := K) (L := L) q (g j) (hgTop j)) + have hF (i : α) : f i = algebraMap R L (F i) := by + exact Classical.choose_spec + (finiteExtensionFinitePlace_exists_local_lift_of_orderTop_nonnegative + (K := K) (L := L) q (f i) (hfTop i)) + have hG (j : β) : g j = algebraMap R L (G j) := by + exact Classical.choose_spec + (finiteExtensionFinitePlace_exists_local_lift_of_orderTop_nonnegative + (K := K) (L := L) q (g j) (hgTop j)) + let firstLocal : R := Finsupp.linearCombination K + (fun ij : α × β => + F ij.1 * (G ij.2) ^ Fintype.card K) c + let secondLocal : R := Finsupp.linearCombination K + (fun ij : α × β => + (F ij.1) ^ Fintype.card K * G ij.2) c + let ι : R →ₗ[K] L := (IsScalarTower.toAlgHom K R L).toLinearMap + have hfirstMap : + onePointStepanovFirstRestrictionMap K L f g (Fintype.card K) c = + algebraMap R L firstLocal := by + symm + calc + algebraMap R L firstLocal = ι firstLocal := rfl + _ = Finsupp.linearCombination K + (fun ij : α × β => + ι (F ij.1 * (G ij.2) ^ Fintype.card K)) c := by + exact Finsupp.apply_linearCombination K ι _ c + _ = Finsupp.linearCombination K + (fun ij : α × β => + f ij.1 * (g ij.2) ^ Fintype.card K) c := by + apply congrArg (fun v => Finsupp.linearCombination K v c) + funext ij + change algebraMap R L + (F ij.1 * (G ij.2) ^ Fintype.card K) = _ + rw [map_mul, map_pow, ← hF ij.1, ← hG ij.2] + _ = onePointStepanovFirstRestrictionMap K L f g + (Fintype.card K) c := rfl + have hsecondMap : + onePointStepanovSecondRestrictionMap K L f g (Fintype.card K) c = + algebraMap R L secondLocal := by + symm + calc + algebraMap R L secondLocal = ι secondLocal := rfl + _ = Finsupp.linearCombination K + (fun ij : α × β => + ι ((F ij.1) ^ Fintype.card K * G ij.2)) c := by + exact Finsupp.apply_linearCombination K ι _ c + _ = Finsupp.linearCombination K + (fun ij : α × β => + (f ij.1) ^ Fintype.card K * g ij.2) c := by + apply congrArg (fun v => Finsupp.linearCombination K v c) + funext ij + change algebraMap R L + ((F ij.1) ^ Fintype.card K * G ij.2) = _ + rw [map_mul, map_pow, ← hF ij.1, ← hG ij.2] + _ = onePointStepanovSecondRestrictionMap K L f g + (Fintype.card K) c := rfl + have hsecondLocal : secondLocal = 0 := by + apply IsFractionRing.injective R L + rw [map_zero, ← hsecondMap] + exact hsecond + have hlocal := stepanovLocal_first_eq_zero_or_order_pos + K R L F G c hsquareLocal hsecondLocal + rcases hlocal with hzero | hpositive + · exact Or.inl (by rw [hfirstMap]; exact hzero) + · refine Or.inr ?_ + rw [hfirstMap, + finiteExtensionPrincipalDivisor_inl_eq_finitePlaceOrder, + ← finiteExtensionFinitePlaceLocalOrder_eq_globalOrder q] + change 0 < finitePlaceOrder + (IsDiscreteValuationRing.maximalIdeal R) (algebraMap R L firstLocal) + exact hpositive + +end FiniteExtensionPlace + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/TensorRestriction.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/TensorRestriction.lean new file mode 100644 index 0000000000..c96e172882 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/TensorRestriction.lean @@ -0,0 +1,177 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import Mathlib.LinearAlgebra.Dimension.Constructions +public import Mathlib.LinearAlgebra.Dimension.Finite +public import Mathlib.LinearAlgebra.FiniteDimensional.Defs +public import Mathlib.LinearAlgebra.TensorProduct.Submodule +public import Mathlib.RingTheory.TensorProduct.Finite + +/-! +# Tensor restriction maps + +This file packages the bilinear maps used in the Stepanov restriction step. +For submodules `R`, `S`, and `T` of a commutative `K`-algebra `L`, an algebra +endomorphism `φ` gives the two twisted products +`x * φ y` and `φ x * y`. An explicit containment hypothesis promotes either +product to a linear map from `R ⊗[K] S` into `T`. + +The final lemmas record the finite-generation and finrank consequences that +are needed when such a tensor restriction map is used as a target map in a +rank-nullity argument. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +open scoped TensorProduct + +variable {K L : Type*} [Field K] [CommRing L] [Algebra K L] +variable {R S T : Submodule K L} + +/-- The tensor restriction map induced by the twisted product +`(x, y) ↦ x * φ y`, with codomain restricted by `hmul`. -/ +def tensorRestriction + (φ : L →ₐ[K] L) + (hmul : ∀ x : R, ∀ y : S, (x : L) * φ (y : L) ∈ T) : + R ⊗[K] S →ₗ[K] T := + TensorProduct.lift <| + LinearMap.mk₂ K + (fun x y ↦ ⟨(x : L) * φ (y : L), hmul x y⟩) + (fun x₁ x₂ y ↦ by + apply Subtype.ext + change ((x₁ : L) + (x₂ : L)) * φ (y : L) = + (x₁ : L) * φ (y : L) + (x₂ : L) * φ (y : L) + rw [add_mul]) + (fun c x y ↦ by + apply Subtype.ext + change (c • (x : L)) * φ (y : L) = + c • ((x : L) * φ (y : L)) + rw [smul_mul_assoc]) + (fun x y₁ y₂ ↦ by + apply Subtype.ext + change (x : L) * φ ((y₁ : L) + (y₂ : L)) = + (x : L) * φ (y₁ : L) + (x : L) * φ (y₂ : L) + rw [map_add, mul_add]) + (fun c x y ↦ by + apply Subtype.ext + change (x : L) * φ (c • (y : L)) = + c • ((x : L) * φ (y : L)) + rw [map_smul, mul_smul_comm]) + +@[simp] +theorem tensorRestriction_tmul + (φ : L →ₐ[K] L) + (hmul : ∀ x : R, ∀ y : S, (x : L) * φ (y : L) ∈ T) + (x : R) (y : S) : + tensorRestriction φ hmul (x ⊗ₜ[K] y) = + ⟨(x : L) * φ (y : L), hmul x y⟩ := + rfl + +/-- The swapped tensor restriction map induced by the twisted product +`(x, y) ↦ φ x * y`, with codomain restricted by `hmul`. -/ +def swappedTensorRestriction + (φ : L →ₐ[K] L) + (hmul : ∀ x : R, ∀ y : S, φ (x : L) * (y : L) ∈ T) : + R ⊗[K] S →ₗ[K] T := + TensorProduct.lift <| + LinearMap.mk₂ K + (fun x y ↦ ⟨φ (x : L) * (y : L), hmul x y⟩) + (fun x₁ x₂ y ↦ by + apply Subtype.ext + change φ ((x₁ : L) + (x₂ : L)) * (y : L) = + φ (x₁ : L) * (y : L) + φ (x₂ : L) * (y : L) + rw [map_add, add_mul]) + (fun c x y ↦ by + apply Subtype.ext + change φ (c • (x : L)) * (y : L) = + c • (φ (x : L) * (y : L)) + rw [map_smul, smul_mul_assoc]) + (fun x y₁ y₂ ↦ by + apply Subtype.ext + change φ (x : L) * ((y₁ : L) + (y₂ : L)) = + φ (x : L) * (y₁ : L) + φ (x : L) * (y₂ : L) + rw [mul_add]) + (fun c x y ↦ by + apply Subtype.ext + change φ (x : L) * (c • (y : L)) = + c • (φ (x : L) * (y : L)) + rw [mul_smul_comm]) + +@[simp] +theorem swappedTensorRestriction_tmul + (φ : L →ₐ[K] L) + (hmul : ∀ x : R, ∀ y : S, φ (x : L) * (y : L) ∈ T) + (x : R) (y : S) : + swappedTensorRestriction φ hmul (x ⊗ₜ[K] y) = + ⟨φ (x : L) * (y : L), hmul x y⟩ := + rfl + +/-- A tensor product of finite modules is finite. This named bridge keeps +downstream restriction arguments independent of the tensor-product instance +search details. -/ +theorem moduleFinite_tensorProduct + [Module.Finite K R] [Module.Finite K S] : + Module.Finite K (R ⊗[K] S) := + Module.Finite.tensorProduct K R S + +/-- The range of a linear map out of a tensor product of finite modules is +finite. -/ +theorem moduleFinite_range_tensorProductMap + {U : Type*} [AddCommGroup U] [Module K U] + [Module.Finite K R] [Module.Finite K S] + (f : R ⊗[K] S →ₗ[K] U) : + Module.Finite K (LinearMap.range f) := by + let : Module.Finite K (R ⊗[K] S) := + moduleFinite_tensorProduct + exact Module.Finite.range f + +/-- The range of a linear map out of `R ⊗ S` has finrank at most the product +of the two input finranks. -/ +theorem finrank_range_tensorProductMap_le + {U : Type*} [AddCommGroup U] [Module K U] + [Module.Finite K R] [Module.Finite K S] + (f : R ⊗[K] S →ₗ[K] U) : + Module.finrank K (LinearMap.range f) ≤ + Module.finrank K R * Module.finrank K S := by + let : Module.Finite K (R ⊗[K] S) := + moduleFinite_tensorProduct + calc + Module.finrank K (LinearMap.range f) ≤ + Module.finrank K (R ⊗[K] S) := + LinearMap.finrank_range_le f + _ = Module.finrank K R * Module.finrank K S := + Module.finrank_tensorProduct + +/-- A surjective linear map out of `R ⊗ S` makes its target finite. -/ +theorem moduleFinite_of_surjective_tensorProductMap + {U : Type*} [AddCommGroup U] [Module K U] + [Module.Finite K R] [Module.Finite K S] + (f : R ⊗[K] S →ₗ[K] U) (hf : Function.Surjective f) : + Module.Finite K U := by + let : Module.Finite K (R ⊗[K] S) := + moduleFinite_tensorProduct + exact Module.Finite.of_surjective f hf + +/-- A surjective linear map out of `R ⊗ S` bounds the target finrank by the +product of the two input finranks. -/ +theorem finrank_le_mul_of_surjective_tensorProductMap + {U : Type*} [AddCommGroup U] [Module K U] + [Module.Finite K R] [Module.Finite K S] + (f : R ⊗[K] S →ₗ[K] U) (hf : Function.Surjective f) : + Module.finrank K U ≤ Module.finrank K R * Module.finrank K S := by + let : Module.Finite K (R ⊗[K] S) := + moduleFinite_tensorProduct + calc + Module.finrank K U ≤ Module.finrank K (R ⊗[K] S) := + LinearMap.finrank_le_finrank_of_surjective hf + _ = Module.finrank K R * Module.finrank K S := + Module.finrank_tensorProduct + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/ZetaExtensionTrace.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/ZetaExtensionTrace.lean new file mode 100644 index 0000000000..1921e3bba6 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/ZetaExtensionTrace.lean @@ -0,0 +1,80 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.SpectralFromAsymptotic + +/-! +# Extension point counts and the zeta spectral formula + +This file packages the elementary interface between rationality of a curve's +zeta function and the even-extension estimate produced by the +Bombieri--Stepanov/Galois-averaging argument. The geometric construction of +the zeta function remains a separate preceding stage. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +open Filter Asymptotics +open scoped BigOperators + +noncomputable section + +/-- A compatible spectral formula for every positive extension degree. -/ +def HasExtensionPointCountSpectralFormula + (q g : ℕ) (pointCount : ℕ → ℕ) (alpha : Fin (2 * g) → ℂ) : Prop := + ∀ m, 0 < m → + (pointCount m : ℂ) = (q : ℂ) ^ m + 1 - ∑ i, alpha i ^ m + +/-- The extension formula at degree one is the single spectral formula used +in the final Hasse inequality. -/ +theorem HasExtensionPointCountSpectralFormula.at_one + {q g : ℕ} {pointCount : ℕ → ℕ} {alpha : Fin (2 * g) → ℂ} + (h : HasExtensionPointCountSpectralFormula q g pointCount alpha) : + HasPointCountSpectralFormula q g (pointCount 1) alpha := by + simpa [HasPointCountSpectralFormula] using h 1 (by omega) + +/-- An even-extension point-count error of order `q ^ n` is exactly the +power-sum estimate needed to bound the Frobenius parameters. -/ +theorem evenPowerSum_isBigO_of_extensionPointCountError_isBigO + {q g : ℕ} {pointCount : ℕ → ℕ} {alpha : Fin (2 * g) → ℂ} + (hformula : HasExtensionPointCountSpectralFormula q g pointCount alpha) + (herror : + (fun n : ℕ ↦ + (pointCount (2 * n) : ℂ) - (q : ℂ) ^ (2 * n) - 1) =O[atTop] + fun n : ℕ ↦ (q : ℝ) ^ n) : + (fun n : ℕ ↦ ∑ i, alpha i ^ (2 * n)) =O[atTop] + fun n : ℕ ↦ (q : ℝ) ^ n := by + apply herror.neg_left.congr' + · filter_upwards [eventually_ge_atTop 1] with n hn + have hpositive : 0 < 2 * n := by omega + have h := hformula (2 * n) hpositive + change -((pointCount (2 * n) : ℂ) - (q : ℂ) ^ (2 * n) - 1) = + ∑ i, alpha i ^ (2 * n) + rw [h] + ring + · exact Filter.EventuallyEq.rfl + +/-- The complete analytic last step: a zeta spectral formula together with +the two-sided even-extension asymptotic gives Hasse--Weil at the base field. -/ +theorem abs_pointCount_sub_card_sub_one_le_of_extensionFormula_and_evenError_isBigO + (q g : ℕ) (pointCount : ℕ → ℕ) (alpha : Fin (2 * g) → ℂ) + (hformula : HasExtensionPointCountSpectralFormula q g pointCount alpha) + (herror : + (fun n : ℕ ↦ + (pointCount (2 * n) : ℂ) - (q : ℂ) ^ (2 * n) - 1) =O[atTop] + fun n : ℕ ↦ (q : ℝ) ^ n) : + |(pointCount 1 : ℝ) - q - 1| ≤ (2 * g : ℝ) * Real.sqrt q := by + apply abs_pointCount_sub_card_sub_one_le_of_evenPowerSum_isBigO + q g (pointCount 1) alpha hformula.at_one + exact evenPowerSum_isBigO_of_extensionPointCountError_isBigO hformula herror + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/ZetaNumeratorSpectral.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/ZetaNumeratorSpectral.lean new file mode 100644 index 0000000000..3972a46a90 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/ZetaNumeratorSpectral.lean @@ -0,0 +1,211 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.PolynomialSpectral + +/-! +# From a zeta numerator to a rank-bounded spectral formula + +The zeta numerator of a curve need not be presented with an even degree in +the coarse plane-curve estimates used by this project. This file therefore +states the spectral argument for an arbitrary finite rank. Its final bound +is `rank * sqrt q`. + +`HasZetaNumeratorPointCountFormula` is a transparent property of a concrete +polynomial: its reciprocal-root power sums are the extension point-count +errors. The zeta-function construction must prove that property; it is not +an assumed theorem or a replacement for Hasse--Weil. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +open Filter Asymptotics +open scoped BigOperators + +noncomputable section + +/-- A compatible spectral formula with an arbitrary finite number of +parameters. -/ +def HasExtensionPointCountSpectralFormulaOfRank + (q rank : ℕ) (pointCount : ℕ → ℕ) (alpha : Fin rank → ℂ) : Prop := + ∀ m, 0 < m → + (pointCount m : ℂ) = (q : ℂ) ^ m + 1 - ∑ i, alpha i ^ m + +/-- The logarithmic-derivative point-count identity for a normalized zeta +numerator, written directly as reciprocal-root power sums. -/ +def HasZetaNumeratorPointCountFormula + (q : ℕ) (pointCount : ℕ → ℕ) (P : Polynomial ℂ) : Prop := + P.coeff 0 = 1 ∧ + ∀ m, 0 < m → + (pointCount m : ℂ) = (q : ℂ) ^ m + 1 - + (P.roots.map fun r => r⁻¹ ^ m).sum + +/-- A zeta-numerator point-count identity gives a spectral formula indexed by +the numerator degree. -/ +theorem hasExtensionPointCountSpectralFormulaOfRank_of_zetaNumerator + {q : ℕ} {pointCount : ℕ → ℕ} {P : Polynomial ℂ} + (h : HasZetaNumeratorPointCountFormula q pointCount P) : + HasExtensionPointCountSpectralFormulaOfRank q P.natDegree pointCount + (reciprocalRootParameter P) := by + intro m hm + rw [sum_reciprocalRootParameter_pow] + exact h.2 m hm + +/-- Extension-count error of order `q^n` gives the corresponding even +power-sum estimate, for arbitrary spectral rank. -/ +theorem evenPowerSum_isBigO_of_extensionPointCountError_isBigO_of_rank + {q rank : ℕ} {pointCount : ℕ → ℕ} {alpha : Fin rank → ℂ} + (hformula : + HasExtensionPointCountSpectralFormulaOfRank q rank pointCount alpha) + (herror : + (fun n : ℕ ↦ + (pointCount (2 * n) : ℂ) - (q : ℂ) ^ (2 * n) - 1) =O[atTop] + fun n : ℕ ↦ (q : ℝ) ^ n) : + (fun n : ℕ ↦ ∑ i, alpha i ^ (2 * n)) =O[atTop] + fun n : ℕ ↦ (q : ℝ) ^ n := by + apply herror.neg_left.congr' + · filter_upwards [eventually_ge_atTop 1] with n hn + have hpositive : 0 < 2 * n := by omega + have h := hformula (2 * n) hpositive + change -((pointCount (2 * n) : ℂ) - (q : ℂ) ^ (2 * n) - 1) = + ∑ i, alpha i ^ (2 * n) + rw [h] + ring + · exact Filter.EventuallyEq.rfl + +/-- An extension-count error estimate along any fixed positive +`2 * δ`-divisible subsequence gives the corresponding power-sum estimate, +for arbitrary spectral rank. -/ +theorem divisibleEvenPowerSum_isBigO_of_extensionPointCountError_isBigO_of_rank + {q rank δ : ℕ} {pointCount : ℕ → ℕ} {alpha : Fin rank → ℂ} + (hδ : 0 < δ) + (hformula : + HasExtensionPointCountSpectralFormulaOfRank q rank pointCount alpha) + (herror : + (fun n : ℕ ↦ + (pointCount (2 * δ * n) : ℂ) - (q : ℂ) ^ (2 * δ * n) - 1) =O[atTop] + fun n : ℕ ↦ ((q : ℝ) ^ δ) ^ n) : + (fun n : ℕ ↦ ∑ i, alpha i ^ (2 * δ * n)) =O[atTop] + fun n : ℕ ↦ ((q : ℝ) ^ δ) ^ n := by + apply herror.neg_left.congr' + · filter_upwards [eventually_ge_atTop 1] with n hn + have hpositive : 0 < 2 * δ * n := + Nat.mul_pos (Nat.mul_pos (by omega) hδ) hn + have h := hformula (2 * δ * n) hpositive + change -((pointCount (2 * δ * n) : ℂ) - + (q : ℂ) ^ (2 * δ * n) - 1) = + ∑ i, alpha i ^ (2 * δ * n) + rw [h] + ring + · exact Filter.EventuallyEq.rfl + +/-- The arbitrary-rank analytic Hasse step. -/ +theorem abs_pointCount_sub_card_sub_one_le_of_rank_extensionFormula_and_evenError_isBigO + (q rank : ℕ) (pointCount : ℕ → ℕ) (alpha : Fin rank → ℂ) + (hformula : + HasExtensionPointCountSpectralFormulaOfRank q rank pointCount alpha) + (herror : + (fun n : ℕ ↦ + (pointCount (2 * n) : ℂ) - (q : ℂ) ^ (2 * n) - 1) =O[atTop] + fun n : ℕ ↦ (q : ℝ) ^ n) : + |(pointCount 1 : ℝ) - q - 1| ≤ (rank : ℝ) * Real.sqrt q := by + have hnorm : ∀ i, ‖alpha i‖ ≤ Real.sqrt q := + spectral_norm_le_sqrt_of_evenPowerSum_isBigO alpha (by positivity) + (evenPowerSum_isBigO_of_extensionPointCountError_isBigO_of_rank + hformula herror) + have hone := hformula 1 (by omega) + have herrorOne : + (((pointCount 1 : ℝ) - q - 1 : ℝ) : ℂ) = -(∑ i, alpha i) := by + push_cast + rw [hone] + simp + ring + calc + |(pointCount 1 : ℝ) - q - 1| = + ‖(((pointCount 1 : ℝ) - q - 1 : ℝ) : ℂ)‖ := by + rw [Complex.norm_real, Real.norm_eq_abs] + _ = ‖∑ i, alpha i‖ := by rw [herrorOne, norm_neg] + _ ≤ ∑ i, ‖alpha i‖ := norm_sum_le _ _ + _ ≤ ∑ _i : Fin rank, Real.sqrt q := by + exact Finset.sum_le_sum fun i _ => hnorm i + _ = (rank : ℝ) * Real.sqrt q := by simp + +/-- The arbitrary-rank analytic Hasse step from an estimate available only +along a fixed positive divisible-even subsequence. -/ +theorem + abs_pointCount_sub_card_sub_one_le_of_rank_extensionFormula_and_divisibleEvenError_isBigO + (q rank δ : ℕ) (pointCount : ℕ → ℕ) (alpha : Fin rank → ℂ) + (hq : 0 < q) (hδ : 0 < δ) + (hformula : + HasExtensionPointCountSpectralFormulaOfRank q rank pointCount alpha) + (herror : + (fun n : ℕ ↦ + (pointCount (2 * δ * n) : ℂ) - (q : ℂ) ^ (2 * δ * n) - 1) =O[atTop] + fun n : ℕ ↦ ((q : ℝ) ^ δ) ^ n) : + |(pointCount 1 : ℝ) - q - 1| ≤ (rank : ℝ) * Real.sqrt q := by + have hnorm : ∀ i, ‖alpha i‖ ≤ Real.sqrt q := + spectral_norm_le_sqrt_of_divisibleEvenPowerSum_isBigO alpha + (by exact_mod_cast hq) hδ + (divisibleEvenPowerSum_isBigO_of_extensionPointCountError_isBigO_of_rank + hδ hformula herror) + have hone := hformula 1 (by omega) + have herrorOne : + (((pointCount 1 : ℝ) - q - 1 : ℝ) : ℂ) = -(∑ i, alpha i) := by + push_cast + rw [hone] + simp + ring + calc + |(pointCount 1 : ℝ) - q - 1| = + ‖(((pointCount 1 : ℝ) - q - 1 : ℝ) : ℂ)‖ := by + rw [Complex.norm_real, Real.norm_eq_abs] + _ = ‖∑ i, alpha i‖ := by rw [herrorOne, norm_neg] + _ ≤ ∑ i, ‖alpha i‖ := norm_sum_le _ _ + _ ≤ ∑ _i : Fin rank, Real.sqrt q := by + exact Finset.sum_le_sum fun i _ => hnorm i + _ = (rank : ℝ) * Real.sqrt q := by simp + +/-- A normalized zeta numerator and the even extension estimate imply the +base-field Hasse bound with coefficient equal to the numerator degree. -/ +theorem abs_pointCount_sub_card_sub_one_le_of_zetaNumerator_and_evenError_isBigO + (q : ℕ) (pointCount : ℕ → ℕ) (P : Polynomial ℂ) + (hformula : HasZetaNumeratorPointCountFormula q pointCount P) + (herror : + (fun n : ℕ ↦ + (pointCount (2 * n) : ℂ) - (q : ℂ) ^ (2 * n) - 1) =O[atTop] + fun n : ℕ ↦ (q : ℝ) ^ n) : + |(pointCount 1 : ℝ) - q - 1| ≤ + (P.natDegree : ℝ) * Real.sqrt q := by + exact abs_pointCount_sub_card_sub_one_le_of_rank_extensionFormula_and_evenError_isBigO + q P.natDegree pointCount (reciprocalRootParameter P) + (hasExtensionPointCountSpectralFormulaOfRank_of_zetaNumerator hformula) herror + +/-- A normalized zeta numerator and a square-root error estimate along a +fixed positive divisible-even subsequence imply the base-field Hasse bound, +with coefficient equal to the numerator degree. -/ +theorem + abs_pointCount_sub_card_sub_one_le_of_zetaNumerator_and_divisibleEvenError_isBigO + (q δ : ℕ) (pointCount : ℕ → ℕ) (P : Polynomial ℂ) + (hq : 0 < q) (hδ : 0 < δ) + (hformula : HasZetaNumeratorPointCountFormula q pointCount P) + (herror : + (fun n : ℕ ↦ + (pointCount (2 * δ * n) : ℂ) - (q : ℂ) ^ (2 * δ * n) - 1) =O[atTop] + fun n : ℕ ↦ ((q : ℝ) ^ δ) ^ n) : + |(pointCount 1 : ℝ) - q - 1| ≤ + (P.natDegree : ℝ) * Real.sqrt q := by + exact + abs_pointCount_sub_card_sub_one_le_of_rank_extensionFormula_and_divisibleEvenError_isBigO + q P.natDegree δ pointCount (reciprocalRootParameter P) hq hδ + (hasExtensionPointCountSpectralFormulaOfRank_of_zetaNumerator hformula) herror + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/HasseWeil/ZetaTrace.lean b/LeanPool/MarkoffModP/BGS/HasseWeil/ZetaTrace.lean new file mode 100644 index 0000000000..a6c31065c8 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/HasseWeil/ZetaTrace.lean @@ -0,0 +1,62 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import Mathlib.Analysis.CStarAlgebra.Classes +public import Mathlib.Tactic + +/-! +# From zeta-function spectral data to the Hasse--Weil estimate + +This file isolates the final, elementary inequality in the Hasse--Weil +argument. Once the point-count formula writes the error as a sum of `2g` +Frobenius parameters of norm at most `sqrt q`, the projective point-count +bound follows from the triangle inequality. + +The zeta-function construction and the proof of the spectral bound are kept +separate: they are the substantive preceding stages of the +Corvaja--Zannier/Bombieri argument. +-/ + +@[expose] public section + +namespace BGS.HasseWeil + +open scoped BigOperators + +noncomputable section + +/-- A single point-count formula with `2g` Frobenius parameters. -/ +def HasPointCountSpectralFormula + (q g N : ℕ) (alpha : Fin (2 * g) → ℂ) : Prop := + (N : ℂ) = (q : ℂ) + 1 - ∑ i, alpha i + +/-- The Hasse--Weil inequality is the triangle inequality once every +Frobenius parameter has norm at most `sqrt q`. -/ +theorem abs_pointCount_sub_card_sub_one_le_of_spectralFormula + (q g N : ℕ) (alpha : Fin (2 * g) → ℂ) + (hformula : HasPointCountSpectralFormula q g N alpha) + (hspectral : ∀ i, ‖alpha i‖ ≤ Real.sqrt q) : + |(N : ℝ) - q - 1| ≤ (2 * g : ℝ) * Real.sqrt q := by + have hformula' : + (N : ℂ) = (q : ℂ) + 1 - ∑ i, alpha i := hformula + have herror : + (((N : ℝ) - q - 1 : ℝ) : ℂ) = -(∑ i, alpha i) := by + push_cast + linear_combination hformula' + calc + |(N : ℝ) - q - 1| = ‖(((N : ℝ) - q - 1 : ℝ) : ℂ)‖ := by + rw [Complex.norm_real, Real.norm_eq_abs] + _ = ‖∑ i, alpha i‖ := by rw [herror, norm_neg] + _ ≤ ∑ i, ‖alpha i‖ := norm_sum_le _ _ + _ ≤ ∑ _i : Fin (2 * g), Real.sqrt q := by + exact Finset.sum_le_sum fun i _ => hspectral i + _ = (2 * g : ℝ) * Real.sqrt q := by simp + +end + +end BGS.HasseWeil diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Assembly.lean b/LeanPool/MarkoffModP/BGS/Markoff/Assembly.lean new file mode 100644 index 0000000000..5c8d9fd240 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Assembly.lean @@ -0,0 +1,22 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.Asymptotics +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.DivisibleOrbitTransitivity +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.ElementaryCounts +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.ExceptionalPrimeCount +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.ExplicitPuncturedTransitivity +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.GiantOrbit +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.MiddleGameThenEndgame +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.NormalizationCount +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.NormalizedSmallOrderCount +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.OrbitDivisibility +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.PuncturedSmallOrderCount +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.ReductionSurjectivity +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.TransitivitySurjectivity +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.Unconditional diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Assembly/Asymptotics.lean b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/Asymptotics.lean new file mode 100644 index 0000000000..0d45597c5f --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/Asymptotics.lean @@ -0,0 +1,89 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.PuncturedSmallOrderCount + +/-! +# The elementary asymptotic in the giant-orbit assembly + +The concrete small-order count is `2 * (2 + 2 * B^2)^2`. This file proves that choosing +`B ≤ p^(ε/5)` makes that count at most `p^ε` for all sufficiently large `p`. No dynamical +claim about the cage complement is used here. +-/ + +@[expose] public section + +namespace BGS.Markoff + +open Filter +open scoped Topology + +/-- Once `p^(ε/5)` absorbs the fixed constant, the explicit polynomial bound is at most +`p^ε`. -/ +theorem smallOrderPointBound_le_rpow + {p bound : ℕ} {ε : ℝ} + (hThirtyTwo : (32 : ℝ) ≤ (p : ℝ) ^ (ε / 5)) + (hbound : (bound : ℝ) ≤ (p : ℝ) ^ (ε / 5)) : + ((2 * (2 + 2 * bound ^ 2) ^ 2 : ℕ) : ℝ) ≤ (p : ℝ) ^ ε := by + let x : ℝ := (p : ℝ) ^ (ε / 5) + have hxNonneg : 0 ≤ x := Real.rpow_nonneg (Nat.cast_nonneg p) _ + have hxOne : 1 ≤ x := by + dsimp [x] + linarith [hThirtyTwo] + have hboundNonneg : 0 ≤ (bound : ℝ) := Nat.cast_nonneg bound + have hboundSq : (bound : ℝ) ^ 2 ≤ x ^ 2 := by + exact pow_le_pow_left₀ hboundNonneg hbound 2 + have hxSqOne : 1 ≤ x ^ 2 := by nlinarith + have hInside : 1 + (bound : ℝ) ^ 2 ≤ 2 * x ^ 2 := by linarith + have hPolynomial : + ((2 * (2 + 2 * bound ^ 2) ^ 2 : ℕ) : ℝ) ≤ 32 * x ^ 4 := by + norm_num only [Nat.cast_mul, Nat.cast_add, Nat.cast_ofNat, Nat.cast_pow] + calc + 2 * (2 + 2 * (bound : ℝ) ^ 2) ^ 2 = 8 * (1 + (bound : ℝ) ^ 2) ^ 2 := by ring + _ ≤ 8 * (2 * x ^ 2) ^ 2 := by gcongr + _ = 32 * x ^ 4 := by ring + have hAbsorbConstant : 32 * x ^ 4 ≤ x ^ 5 := by + nlinarith [sq_nonneg (x ^ 2), mul_nonneg hxNonneg (sq_nonneg x)] + calc + ((2 * (2 + 2 * bound ^ 2) ^ 2 : ℕ) : ℝ) ≤ 32 * x ^ 4 := hPolynomial + _ ≤ x ^ 5 := hAbsorbConstant + _ = (p : ℝ) ^ ε := by + dsimp [x] + rw [← Real.rpow_mul_natCast (Nat.cast_nonneg p) (ε / 5) 5] + congr 1 + ring + +/-- The explicit polynomial small-order bound is eventually absorbed by the target real power. -/ +theorem eventually_smallOrderPointBound_le_rpow {ε : ℝ} (hε : 0 < ε) : + ∀ᶠ p : ℕ in atTop, ∀ bound : ℕ, + (bound : ℝ) ≤ (p : ℝ) ^ (ε / 5) → + ((2 * (2 + 2 * bound ^ 2) ^ 2 : ℕ) : ℝ) ≤ (p : ℝ) ^ ε := by + have hExponent : 0 < ε / 5 := div_pos hε (by norm_num) + have hEventuallyThirtyTwo : + ∀ᶠ p : ℕ in atTop, (32 : ℝ) ≤ (p : ℝ) ^ (ε / 5) := + ((tendsto_rpow_atTop hExponent).comp tendsto_natCast_atTop_atTop).eventually + (eventually_ge_atTop 32) + filter_upwards [hEventuallyThirtyTwo] with p hp + exact fun bound hbound ↦ smallOrderPointBound_le_rpow hp hbound + +/-- The counted punctured small-order set satisfies the target bound as soon as its order cutoff +is at most `p^(ε/5)` and the harmless constant has been absorbed. -/ +theorem puncturedSmallOrderSet_card_le_rpow_of_bound + {p : ℕ} [Fact p.Prime] [Invertible (3 : ZMod p)] + (hpTwo : p ≠ 2) {ε : ℝ} (bound : ℕ) + (hThirtyTwo : (32 : ℝ) ≤ (p : ℝ) ^ (ε / 5)) + (hbound : (bound : ℝ) ≤ (p : ℝ) ^ (ε / 5)) : + ((puncturedMarkoffPointsWithSmallFirstTwoRotationOrders p bound).card : ℝ) ≤ + (p : ℝ) ^ ε := by + calc + ((puncturedMarkoffPointsWithSmallFirstTwoRotationOrders p bound).card : ℝ) ≤ + (2 * (2 + 2 * bound ^ 2) ^ 2 : ℕ) := by + exact_mod_cast puncturedMarkoffPointsWithSmallFirstTwoRotationOrders_card_le hpTwo bound + _ ≤ (p : ℝ) ^ ε := smallOrderPointBound_le_rpow hThirtyTwo hbound + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Assembly/CoarseEndgame.lean b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/CoarseEndgame.lean new file mode 100644 index 0000000000..10de14e284 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/CoarseEndgame.lean @@ -0,0 +1,137 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.CoarseSupportTail + +/-! +# Endgame and cage wrappers at the unified coarse support cutoff + +The geometric endgame is unchanged. This module feeds it the simultaneous +tenth-moment estimates proved in `CoarseSupportTail`, so every non-cubic +support condition follows from the single hypothesis `2^756 < p`. +-/ + +@[expose] public section + +namespace BGS.Markoff + +noncomputable section + +/-- Above the unified support cutoff, a large first-coordinate rotation +reaches a maximal split rotation. -/ +theorem exists_coarse_sameComponent_maximalRotation_of_large_firstCoordinate + {p : ℕ} [Fact p.Prime] [Invertible (3 : ZMod p)] + (hp : 2 ^ 756 < p) + (x : NormalizedMarkoffSurface (ZMod p)) + (hlarge : (p : ℝ) ^ (5 / 6 : ℝ) ≤ rotationOrder x.1.u1) : + ∃ y : NormalizedMarkoffSurface (ZMod p), + SameNormalizedComponent x y ∧ rotationOrder y.1.u2 = p - 1 := by + let xf : ↑(normalizedFiber1 x.1.u1) := ⟨x.1, x.property, rfl⟩ + obtain ⟨n, hrotation⟩ := + exists_iterate_point_with_maximal_secondRotation_of_explicitInequalities + p ((by norm_num : 5 ≤ 7).trans (seven_le_of_twoPow756_lt hp)) + x.1.u1 xf + (fun orbitExponent orbitOrder hmul horder ↦ + coarse_endgamePrimitiveTrace_explicitInequality_of_card_sub_one + hp hmul horder (by norm_num)) + (fun orbitExponent orbitOrder hmul horder ↦ + coarse_endgamePrimitiveTrace_explicitInequality_of_card_add_one + hp hmul horder (by norm_num)) + (coarse_four_lt_rpow_five_div_six hp) hlarge + let y := (normalizedRotate1Surface^[n]) x + refine ⟨y, sameNormalizedComponent_iterate_normalizedRotate1Surface x n, ?_⟩ + rw [show y.1 = (normalizedRotate1^[n]) x.1 by + exact coe_iterate_normalizedRotate1Surface x n] + exact hrotation + +/-- First-coordinate form of the coarse large-order-to-cage endgame. -/ +theorem exists_coarse_sameComponent_splitCage_of_large_firstCoordinate + {p : ℕ} [Fact p.Prime] [Invertible (3 : ZMod p)] + (hp : 2 ^ 756 < p) + (x : NormalizedMarkoffSurface (ZMod p)) + (hlarge : (p : ℝ) ^ (5 / 6 : ℝ) ≤ rotationOrder x.1.u1) : + ∃ y : NormalizedMarkoffSurface (ZMod p), + SameNormalizedComponent x y ∧ IsInSplitCage p y := by + obtain ⟨y, hxy, hyOrder⟩ := + exists_coarse_sameComponent_maximalRotation_of_large_firstCoordinate + hp x hlarge + exact ⟨y, hxy, .second, hyOrder⟩ + +/-- If one coordinate rotation is large, the point reaches the split cage. -/ +theorem exists_coarse_sameComponent_splitCage_of_some_largeCoordinate + {p : ℕ} [Fact p.Prime] [Invertible (3 : ZMod p)] + (hp : 2 ^ 756 < p) + (x : NormalizedMarkoffSurface (ZMod p)) + (hlarge : + (p : ℝ) ^ (5 / 6 : ℝ) ≤ rotationOrder x.1.u1 ∨ + (p : ℝ) ^ (5 / 6 : ℝ) ≤ rotationOrder x.1.u2 ∨ + (p : ℝ) ^ (5 / 6 : ℝ) ≤ rotationOrder x.1.u3) : + ∃ y : NormalizedMarkoffSurface (ZMod p), + SameNormalizedComponent x y ∧ IsInSplitCage p y := by + rcases hlarge with hfirst | hsecond | hthird + · exact + exists_coarse_sameComponent_splitCage_of_large_firstCoordinate + hp x hfirst + · let x' := normalizedSwap12Surface x + have hx' : SameNormalizedComponent x x' := + sameNormalizedComponent_swap12Surface x + have hlarge' : + (p : ℝ) ^ (5 / 6 : ℝ) ≤ rotationOrder x'.1.u1 := by + simpa [x', normalizedSwap12, coe_normalizedSwap12Surface] using hsecond + obtain ⟨y, hy, hyOrder⟩ := + exists_coarse_sameComponent_maximalRotation_of_large_firstCoordinate + hp x' hlarge' + exact ⟨y, sameNormalizedComponent_trans hx' hy, .second, hyOrder⟩ + · let x' := normalizedSwap12Surface (normalizedSwap23Surface x) + have hx23 : SameNormalizedComponent x (normalizedSwap23Surface x) := + sameNormalizedComponent_swap23Surface x + have hx12 : SameNormalizedComponent (normalizedSwap23Surface x) x' := + sameNormalizedComponent_swap12Surface (normalizedSwap23Surface x) + have hlarge' : + (p : ℝ) ^ (5 / 6 : ℝ) ≤ rotationOrder x'.1.u1 := by + simpa [x', normalizedSwap12, normalizedSwap23, + coe_normalizedSwap12Surface, coe_normalizedSwap23Surface] using hthird + obtain ⟨y, hy, hyOrder⟩ := + exists_coarse_sameComponent_maximalRotation_of_large_firstCoordinate + hp x' hlarge' + exact ⟨y, sameNormalizedComponent_trans + (sameNormalizedComponent_trans hx23 hx12) hy, .second, hyOrder⟩ + +/-- The selected split cage is connected above the unified support cutoff. -/ +theorem coarse_splitCage_connected + {p : ℕ} [Fact p.Prime] [Invertible (3 : ZMod p)] + (hp : 2 ^ 756 < p) + (x y : NormalizedMarkoffSurface (ZMod p)) + (hx : IsInSplitCage p x) (hy : IsInSplitCage p y) : + SameNormalizedComponent x y := by + exact splitCage_connected_of_explicitInequality p + (seven_le_of_twoPow756_lt hp) + (coarse_cageWitness_explicitInequality hp (by norm_num)) + x y hx hy + +/-- A large-order point lies in the component of any chosen cage base point. -/ +theorem coarse_sameNormalizedComponent_of_largeOrder_to_splitCage + {p : ℕ} [Fact p.Prime] [Invertible (3 : ZMod p)] + (hp : 2 ^ 756 < p) + (base x : NormalizedMarkoffSurface (ZMod p)) + (hbase : IsInSplitCage p base) + (hlarge : + (p : ℝ) ^ (5 / 6 : ℝ) ≤ rotationOrder x.1.u1 ∨ + (p : ℝ) ^ (5 / 6 : ℝ) ≤ rotationOrder x.1.u2 ∨ + (p : ℝ) ^ (5 / 6 : ℝ) ≤ rotationOrder x.1.u3) : + SameNormalizedComponent base x := by + obtain ⟨y, hxy, hy⟩ := + exists_coarse_sameComponent_splitCage_of_some_largeCoordinate + hp x hlarge + exact sameNormalizedComponent_trans + (coarse_splitCage_connected hp base y hbase hy) + (sameNormalizedComponent_symm hxy) + +end + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Assembly/CoarseLinearTail.lean b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/CoarseLinearTail.lean new file mode 100644 index 0000000000..dc6057c627 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/CoarseLinearTail.lean @@ -0,0 +1,165 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.MaximalDivisorLowOrderCount +public import LeanPool.MarkoffModP.BGS.Markoff.PreliminaryNumerics + +/-! +# Coarse automatic linear tail + +The simultaneous tenth-moment bound makes the linear middle-game condition +automatic at a cutoff far below the paper scale. No divisor-table tuning is +used here. +-/ + +@[expose] public section + +namespace BGS.Markoff + +open BGS.NumberTheory + +/-- A tenth-moment estimate and the clean coefficient threshold +`24^15 * 2^687 < p` imply `24*T < p^(1/6)`. + +The exponent choice is exact: +`(24^15 * 2^687)^4 = 24^60 * (2^458)^6`. -/ +theorem twentyFour_mul_lt_rpow_one_div_six_of_tenthMoment + {p T : ℕ} + (hp : 24 ^ 15 * 2 ^ 687 < p) + (hmoment : T ^ 10 ≤ 2 ^ 458 * p) : + ((24 * T : ℕ) : ℝ) < (p : ℝ) ^ (1 / 6 : ℝ) := by + let Q : ℕ := 24 ^ 15 * 2 ^ 687 + have hQ : Q < p := by + simpa [Q] using hp + have hpPos : 0 < p := by + have hQPos : 0 < Q := by positivity + exact hQPos.trans hQ + have h24 : (24 ^ 15) ^ 4 = 24 ^ 60 := by + rw [← pow_mul] + have hTwoLeft : (2 ^ 458) ^ 6 = 2 ^ 2748 := by + rw [← pow_mul] + have hTwoRight : (2 ^ 687) ^ 4 = 2 ^ 2748 := by + rw [← pow_mul] + have hpowNat : (24 * T) ^ 60 < p ^ 10 := by + calc + (24 * T) ^ 60 = 24 ^ 60 * (T ^ 10) ^ 6 := by ring + _ ≤ 24 ^ 60 * (2 ^ 458 * p) ^ 6 := by gcongr + _ = (24 ^ 60 * (2 ^ 458) ^ 6) * p ^ 6 := by + rw [mul_pow] + ring + _ = ((24 ^ 15) ^ 4 * (2 ^ 687) ^ 4) * p ^ 6 := by + rw [h24, hTwoLeft, hTwoRight] + _ = Q ^ 4 * p ^ 6 := by + simp only [Q, mul_pow] + _ < p ^ 4 * p ^ 6 := + Nat.mul_lt_mul_of_pos_right + (pow_lt_pow_left₀ hQ (Nat.zero_le Q) (by norm_num)) + (pow_pos hpPos 6) + _ = p ^ 10 := by ring + have hpNonnegative : (0 : ℝ) ≤ p := by positivity + have hpowReal : ((24 * T : ℕ) : ℝ) ^ 60 < (p : ℝ) ^ 10 := by + exact_mod_cast hpowNat + have hrootPow : + ((p : ℝ) ^ (1 / 6 : ℝ)) ^ 60 = (p : ℝ) ^ 10 := by + calc + ((p : ℝ) ^ (1 / 6 : ℝ)) ^ 60 = + (p : ℝ) ^ ((1 / 6 : ℝ) * 60) := + (Real.rpow_mul_natCast hpNonnegative (1 / 6 : ℝ) 60).symm + _ = (p : ℝ) ^ 10 := by norm_num + apply lt_of_pow_lt_pow_left₀ 60 (Real.rpow_nonneg hpNonnegative _) + rw [hrootPow] + exact hpowReal + +/-- Apply the generic tail estimate to the simultaneous divisor count +`T = τ(p-1) + τ(p+1)`. -/ +theorem preliminary_twentyFour_mul_divisorSum_lt_rpow_one_div_six_of_coarseBound + {p : ℕ} + (hp : 24 ^ 15 * 2 ^ 687 < p) : + ((24 * ((p - 1).divisors.card + (p + 1).divisors.card) : ℕ) : ℝ) < + (p : ℝ) ^ (1 / 6 : ℝ) := by + apply twentyFour_mul_lt_rpow_one_div_six_of_tenthMoment hp + have hpTwo : 2 ≤ p := by + have hcoefficientPos : 0 < 24 ^ 15 * 2 ^ 687 := by positivity + omega + calc + ((p - 1).divisors.card + (p + 1).divisors.card) ^ 10 ≤ + 2 ^ 457 * p := by + simpa [preliminaryDivisorMomentConstant] using + preliminary_divisor_sum_pow_ten_le hpTwo + _ ≤ 2 ^ 458 * p := by + apply Nat.mul_le_mul_right + calc + 2 ^ 457 = 2 ^ 457 * 1 := by simp + _ ≤ 2 ^ 457 * 2 := Nat.mul_le_mul_left _ (by norm_num) + _ = 2 ^ (457 + 1) := (pow_succ 2 457).symm + _ = 2 ^ 458 := by norm_num + +/-- Once `24*T < p^(1/6)`, every `M ≤ T` and every +`d < p^(5/6)` satisfy the linear middle-game inequality. -/ +theorem twentyFour_mul_mul_lt_of_le_of_lt_fiveSixths + {p T M d : ℕ} + (hpPos : 0 < p) + (hT : ((24 * T : ℕ) : ℝ) < (p : ℝ) ^ (1 / 6 : ℝ)) + (hM : M ≤ T) + (hd : (d : ℝ) < (p : ℝ) ^ (5 / 6 : ℝ)) : + 24 * M * d < p := by + have hpRealPos : (0 : ℝ) < p := by exact_mod_cast hpPos + have hLinearPower : + (p : ℝ) ^ (1 / 6 : ℝ) * (p : ℝ) ^ (5 / 6 : ℝ) = + (p : ℝ) := by + rw [← Real.rpow_add hpRealPos] + norm_num + have hMT : 24 * M ≤ 24 * T := + Nat.mul_le_mul_left 24 hM + have hLinearReal : ((24 * M * d : ℕ) : ℝ) < p := by + calc + ((24 * M * d : ℕ) : ℝ) = + ((24 * M : ℕ) : ℝ) * (d : ℝ) := by norm_num + _ ≤ ((24 * T : ℕ) : ℝ) * (d : ℝ) := by + apply mul_le_mul_of_nonneg_right + · exact_mod_cast hMT + · exact Nat.cast_nonneg d + _ ≤ (p : ℝ) ^ (1 / 6 : ℝ) * (d : ℝ) := + mul_le_mul_of_nonneg_right hT.le (Nat.cast_nonneg d) + _ < (p : ℝ) ^ (1 / 6 : ℝ) * (p : ℝ) ^ (5 / 6 : ℝ) := + mul_lt_mul_of_pos_left hd (Real.rpow_pos_of_pos hpRealPos _) + _ = (p : ℝ) := hLinearPower + exact_mod_cast hLinearReal + +/-- Coarse all-divisor specialization: the linear branch is automatic for +any `M` bounded by the simultaneous divisor count. -/ +theorem preliminary_twentyFour_mul_mul_lt_of_coarseBound + {p M d : ℕ} + (hp : 24 ^ 15 * 2 ^ 687 < p) + (hM : + M ≤ (p - 1).divisors.card + (p + 1).divisors.card) + (hd : (d : ℝ) < (p : ℝ) ^ (5 / 6 : ℝ)) : + 24 * M * d < p := by + have hpPos : 0 < p := by + have hcoefficientPos : 0 < 24 ^ 15 * 2 ^ 687 := by positivity + omega + exact + twentyFour_mul_mul_lt_of_le_of_lt_fiveSixths hpPos + (preliminary_twentyFour_mul_divisorSum_lt_rpow_one_div_six_of_coarseBound hp) + hM hd + +/-- In particular, the maximal-divisor coefficient in the Euler-seven +frontier satisfies the linear branch automatically above the coarse tail. -/ +theorem maximalDivisorCountSum_linear_lt_of_coarseBound + {p d : ℕ} + (hp : 24 ^ 15 * 2 ^ 687 < p) + (hd : (d : ℝ) < (p : ℝ) ^ (5 / 6 : ℝ)) : + 24 * maximalDivisorCountSum p (d + 1) * d < p := by + apply preliminary_twentyFour_mul_mul_lt_of_coarseBound hp + · unfold maximalDivisorCountSum + exact Nat.add_le_add + (maximalDivisorsBelow_card_le_card_divisors (p - 1) (d + 1)) + (maximalDivisorsBelow_card_le_card_divisors (p + 1) (d + 1)) + · exact hd + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Assembly/CoarseSupportSurjectivity.lean b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/CoarseSupportSurjectivity.lean new file mode 100644 index 0000000000..5846e66856 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/CoarseSupportSurjectivity.lean @@ -0,0 +1,161 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.EulerSevenCoarseSupportFrontier +public import LeanPool.MarkoffModP.BGS.Markoff.PreliminaryNumerics +public import LeanPool.MarkoffModP.BGS.NumberTheory.JointNeighborDivisorBound + +/-! +# Certificate-free coarse-support surjectivity + +The Euler-seven complement argument reduces the last global obstruction to +`35721 * S^4 < 8 * p`. Taking `S` to be the square of the simultaneous +divisor count and combining this obstruction with the elementary tenth moment +gives an unconditional cutoff without a divisor table. +-/ + +@[expose] public section + +namespace BGS.Markoff + +open BGS.NumberTheory + +/-- The exact open cutoff supplied by the Euler-seven obstruction and the +joint tenth moment for the two neighboring divisor counts. -/ +def coarseSupportStrongApproximationOpenCutoff : ℕ := + 35721 ^ 5 * 2 ^ 1701 * 262145 ^ 4 + +/-- Closed version of `coarseSupportStrongApproximationOpenCutoff`. -/ +def coarseSupportStrongApproximationCutoff : ℕ := + coarseSupportStrongApproximationOpenCutoff + 1 + +private theorem twoPow756_lt_coarseSupportStrongApproximationOpenCutoff : + 2 ^ 756 < coarseSupportStrongApproximationOpenCutoff := by + calc + 2 ^ 756 < 2 ^ 1701 := + Nat.pow_lt_pow_right (by norm_num) (by norm_num) + _ = 1 * 2 ^ 1701 * 1 := by ring + _ ≤ 35721 ^ 5 * 2 ^ 1701 * 262145 ^ 4 := by + gcongr <;> norm_num + +/-- The joint tenth moment rules out the final Euler-seven obstruction above +the exact coarse-support cutoff. -/ +theorem preliminary_35721_mul_divisorSum_pow_eight_lt + {p : ℕ} (hpOdd : Odd p) + (hp : coarseSupportStrongApproximationOpenCutoff < p) : + 35721 * ((p - 1).divisors.card + (p + 1).divisors.card) ^ 8 < 8 * p := by + let T := (p - 1).divisors.card + (p + 1).divisors.card + let D := neighboringDivisorSumMomentConstant + have hpPos : 0 < p := (Nat.zero_le _).trans_lt hp + have hpSupport : 2 ^ 756 < p := + twoPow756_lt_coarseSupportStrongApproximationOpenCutoff.trans hp + have hpLarge : 794039 ≤ p := by + have hsmall : 794039 < 2 ^ 20 := by norm_num + have hpowers : 2 ^ 20 ≤ 2 ^ 756 := + Nat.pow_le_pow_right (by norm_num) (by norm_num) + omega + have hmoment : T ^ 10 ≤ D * p := by + simpa [T, D] using + card_divisors_pred_add_card_divisors_succ_pow_ten_le hpOdd hpLarge + by_contra hnot + have hbad : 8 * p ≤ 35721 * T ^ 8 := by + exact Nat.le_of_not_gt (by simpa [T] using hnot) + have hbadPow : (8 * p) ^ 5 ≤ (35721 * T ^ 8) ^ 5 := + Nat.pow_le_pow_left hbad 5 + have hmomentPow : (T ^ 10) ^ 4 ≤ (D * p) ^ 4 := + Nat.pow_le_pow_left hmoment 4 + have hcombined : + 2 ^ 15 * p ^ 5 ≤ 35721 ^ 5 * D ^ 4 * p ^ 4 := by + calc + 2 ^ 15 * p ^ 5 = (8 * p) ^ 5 := by ring + _ ≤ (35721 * T ^ 8) ^ 5 := hbadPow + _ = 35721 ^ 5 * (T ^ 10) ^ 4 := by ring + _ ≤ 35721 ^ 5 * (D * p) ^ 4 := + Nat.mul_le_mul_left _ hmomentPow + _ = 35721 ^ 5 * D ^ 4 * p ^ 4 := by ring + have hcombined' : + (2 ^ 15 * p) * p ^ 4 ≤ + (35721 ^ 5 * D ^ 4) * p ^ 4 := by + simpa only [show p ^ 5 = p * p ^ 4 by ring, Nat.mul_assoc] using hcombined + have hcancel : 2 ^ 15 * p ≤ 35721 ^ 5 * D ^ 4 := + Nat.le_of_mul_le_mul_right hcombined' (pow_pos hpPos 4) + have hfactor : + 35721 ^ 5 * D ^ 4 = + 2 ^ 15 * coarseSupportStrongApproximationOpenCutoff := by + have hD : D = 2 ^ 429 * 262145 := by + exact neighboringDivisorSumMomentConstant_eq + rw [hD] + rw [mul_pow] + rw [show (2 ^ 429) ^ 4 = 2 ^ 1716 by + rw [show (1716 : ℕ) = 429 * 4 by norm_num, pow_mul]] + rw [show (1716 : ℕ) = 15 + 1701 by norm_num, pow_add] + unfold coarseSupportStrongApproximationOpenCutoff + ring + have hcutoffUpper : p ≤ coarseSupportStrongApproximationOpenCutoff := by + rw [hfactor] at hcancel + have hcancel' : + p * 2 ^ 15 ≤ coarseSupportStrongApproximationOpenCutoff * 2 ^ 15 := by + simpa only [Nat.mul_comm] using hcancel + exact Nat.le_of_mul_le_mul_right hcancel' (pow_pos (by norm_num) 15) + exact (Nat.not_le_of_lt hp) hcutoffUpper + +/-- Every joint maximal-divisor square count is bounded by the square of the +simultaneous all-divisor count. -/ +theorem maximalDivisorCountSum_sq_le_divisorSum_sq + (p d : ℕ) : + maximalDivisorCountSum p (d + 1) ^ 2 ≤ + ((p - 1).divisors.card + (p + 1).divisors.card) ^ 2 := by + apply Nat.pow_le_pow_left + unfold maximalDivisorCountSum + exact Nat.add_le_add + (maximalDivisorsBelow_card_le_card_divisors (p - 1) (d + 1)) + (maximalDivisorsBelow_card_le_card_divisors (p + 1) (d + 1)) + +/-- The exact cutoff dominates the support-only threshold required by the +coarse endgame and cage arguments. -/ +theorem twoPow756_lt_of_coarseSupportOpenCutoff_lt + {p : ℕ} (hp : coarseSupportStrongApproximationOpenCutoff < p) : + 2 ^ 756 < p := by + exact twoPow756_lt_coarseSupportStrongApproximationOpenCutoff.trans hp + +/-- Natural Markoff reduction is surjective above the exact certificate-free +coarse-support cutoff. -/ +theorem markoffReduction_surjective_of_coarseSupportOpenCutoff + (p : ℕ) (hpPrime : p.Prime) + (hp : coarseSupportStrongApproximationOpenCutoff < p) : + Function.Surjective (markoffReduction p) := by + letI : Fact p.Prime := ⟨hpPrime⟩ + have hpThree : 3 < p := by + have hsupport := twoPow756_lt_of_coarseSupportOpenCutoff_lt hp + omega + have hpOdd : Odd p := + hpPrime.odd_of_ne_two (by omega) + letI : Invertible (3 : ZMod p) := + invertibleOfNonzero + (natCast_ne_zero_zmod_of_pos_of_lt (by norm_num) hpThree) + let T := (p - 1).divisors.card + (p + 1).divisors.card + apply markoffReduction_surjective_of_eulerSevenSquareEnvelope_coarseSupport + p (twoPow756_lt_of_coarseSupportOpenCutoff_lt hp) (fun _ ↦ T ^ 2) + · intro d + simpa [T] using maximalDivisorCountSum_sq_le_divisorSum_sq p d + · intro d + calc + 35721 * (T ^ 2) ^ 4 = 35721 * T ^ 8 := by ring + _ < 8 * p := by + simpa [T] using + preliminary_35721_mul_divisorSum_pow_eight_lt hpOdd hp + +/-- Closed-cutoff form used by the public Comparator theorem. -/ +theorem markoffReduction_surjective_of_coarseSupportBound + (p : ℕ) (hpPrime : p.Prime) + (hp : coarseSupportStrongApproximationCutoff ≤ p) : + Function.Surjective (markoffReduction p) := by + apply markoffReduction_surjective_of_coarseSupportOpenCutoff p hpPrime + simpa [coarseSupportStrongApproximationCutoff] using hp + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Assembly/CoarseSupportTail.lean b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/CoarseSupportTail.lean new file mode 100644 index 0000000000..0d61be7635 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/CoarseSupportTail.lean @@ -0,0 +1,415 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.CoarseLinearTail +public import LeanPool.MarkoffModP.BGS.Markoff.ExplicitEndgame + +/-! +# Coarse support tails below the paper scale + +The single clean threshold `2^756 < p`, together with the simultaneous +tenth-moment divisor estimate, discharges the non-cubic middle-game, +primitive-endgame, cage, and split-sign support inequalities. +-/ + +@[expose] public section + + +namespace BGS.Markoff + +open BGS.NumberTheory + +theorem twentyFour_support_margin : + 24 ^ 15 * 2 ^ 687 < 2 ^ 756 := by + have hbase : 24 ^ 5 < 2 ^ 23 := by norm_num + calc + 24 ^ 15 * 2 ^ 687 = (24 ^ 5) ^ 3 * 2 ^ 687 := by ring + _ < (2 ^ 23) ^ 3 * 2 ^ 687 := + Nat.mul_lt_mul_of_pos_right + (pow_lt_pow_left₀ hbase (Nat.zero_le _) (by norm_num)) + (pow_pos (by norm_num) 687) + _ = 2 ^ 756 := by + rw [← pow_mul, ← pow_add] + +theorem sixtyEight_support_margin : + 68 ^ 15 * 2 ^ 1374 < 2 ^ 1512 := by + have hbase : (68 : ℕ) < 2 ^ 7 := by norm_num + have hproduct : (68 : ℕ) ^ 15 * 2 ^ 1374 < (2 ^ 7) ^ 15 * 2 ^ 1374 := by + exact Nat.mul_lt_mul_of_pos_right + (pow_lt_pow_left₀ hbase (Nat.zero_le _) (by norm_num)) + (pow_pos (by norm_num) 1374) + have hpower : ((2 : ℕ) ^ 7) ^ 15 * 2 ^ 1374 = 2 ^ 1479 := by + rw [← pow_mul, ← pow_add] + have hmargin : (2 : ℕ) ^ 1479 < 2 ^ 1512 := + pow_lt_pow_right₀ (by norm_num) (by norm_num) + exact lt_trans (lt_of_lt_of_eq hproduct hpower) hmargin + +theorem cageCoefficient_support_margin : + 100522 ^ 10 * 2 ^ 916 < 2 ^ 2268 := by + have hbase : (100522 : ℕ) < 2 ^ 17 := by norm_num + have hproduct : (100522 : ℕ) ^ 10 * 2 ^ 916 < (2 ^ 17) ^ 10 * 2 ^ 916 := by + exact Nat.mul_lt_mul_of_pos_right + (pow_lt_pow_left₀ hbase (Nat.zero_le _) (by norm_num)) + (pow_pos (by norm_num) 916) + have hpower : ((2 : ℕ) ^ 17) ^ 10 * 2 ^ 916 = 2 ^ 1086 := by + rw [← pow_mul, ← pow_add] + have hmargin : (2 : ℕ) ^ 1086 < 2 ^ 2268 := + pow_lt_pow_right₀ (by norm_num) (by norm_num) + exact lt_trans (lt_of_lt_of_eq hproduct hpower) hmargin + +theorem seven_le_of_twoPow756_lt + {p : ℕ} (hp : 2 ^ 756 < p) : + 7 ≤ p := by + have hseven : 7 < 2 ^ 756 := by + calc + 7 < 2 ^ 3 := by norm_num + _ ≤ 2 ^ 756 := + Nat.pow_le_pow_right (by norm_num) (by norm_num) + omega + +/-- The linear-tail theorem at the unified clean support cutoff. -/ +theorem twentyFour_mul_lt_rpow_one_div_six_of_twoPow756 + {p T : ℕ} + (hp : 2 ^ 756 < p) + (hmoment : T ^ 10 ≤ 2 ^ 458 * p) : + ((24 * T : ℕ) : ℝ) < (p : ℝ) ^ (1 / 6 : ℝ) := + twentyFour_mul_lt_rpow_one_div_six_of_tenthMoment + (twentyFour_support_margin.trans hp) hmoment + +/-- The weighted primitive-endgame divisor term is below `p^(1/3)`. -/ +theorem sixtyEight_mul_square_lt_rpow_one_div_three_of_tenthMoment + {p T : ℕ} + (hpCoefficient : 68 ^ 15 * 2 ^ 1374 < p ^ 2) + (hmoment : T ^ 10 ≤ 2 ^ 458 * p) : + ((68 * T ^ 2 : ℕ) : ℝ) < (p : ℝ) ^ (1 / 3 : ℝ) := by + let Q : ℕ := 68 ^ 15 * 2 ^ 1374 + have hQ : Q < p ^ 2 := by + simpa [Q] using hpCoefficient + have hpPos : 0 < p := by + by_contra hpNot + have hpZero : p = 0 := Nat.eq_zero_of_not_pos hpNot + subst p + simp [Q] at hQ + have h68 : (68 ^ 15) ^ 2 = 68 ^ 30 := by + rw [← pow_mul] + have hTwoLeft : (2 ^ 458) ^ 6 = 2 ^ 2748 := by + rw [← pow_mul] + have hTwoRight : (2 ^ 1374) ^ 2 = 2 ^ 2748 := by + rw [← pow_mul] + have hpowNat : (68 * T ^ 2) ^ 30 < p ^ 10 := by + calc + (68 * T ^ 2) ^ 30 = 68 ^ 30 * (T ^ 10) ^ 6 := by ring + _ ≤ 68 ^ 30 * (2 ^ 458 * p) ^ 6 := by gcongr + _ = (68 ^ 30 * (2 ^ 458) ^ 6) * p ^ 6 := by + rw [mul_pow] + ring + _ = ((68 ^ 15) ^ 2 * (2 ^ 1374) ^ 2) * p ^ 6 := by + rw [h68, hTwoLeft, hTwoRight] + _ = Q ^ 2 * p ^ 6 := by + simp only [Q, mul_pow] + _ < (p ^ 2) ^ 2 * p ^ 6 := + Nat.mul_lt_mul_of_pos_right + (pow_lt_pow_left₀ hQ (Nat.zero_le Q) (by norm_num)) + (pow_pos hpPos 6) + _ = p ^ 10 := by ring + have hpNonnegative : (0 : ℝ) ≤ p := by positivity + have hpowReal : ((68 * T ^ 2 : ℕ) : ℝ) ^ 30 < + (p : ℝ) ^ 10 := by + exact_mod_cast hpowNat + have hrootPow : + ((p : ℝ) ^ (1 / 3 : ℝ)) ^ 30 = (p : ℝ) ^ 10 := by + calc + ((p : ℝ) ^ (1 / 3 : ℝ)) ^ 30 = + (p : ℝ) ^ ((1 / 3 : ℝ) * 30) := + (Real.rpow_mul_natCast hpNonnegative (1 / 3 : ℝ) 30).symm + _ = (p : ℝ) ^ 10 := by norm_num + apply lt_of_pow_lt_pow_left₀ 30 (Real.rpow_nonneg hpNonnegative _) + rw [hrootPow] + exact hpowReal + +theorem preliminary_sixtyEight_mul_divisorSum_sq_lt_rpow_one_div_three_of_twoPow756 + {p : ℕ} (hp : 2 ^ 756 < p) : + ((68 * ((p - 1).divisors.card + (p + 1).divisors.card) ^ 2 : ℕ) : ℝ) < + (p : ℝ) ^ (1 / 3 : ℝ) := by + apply sixtyEight_mul_square_lt_rpow_one_div_three_of_tenthMoment + · calc + 68 ^ 15 * 2 ^ 1374 < 2 ^ 1512 := + sixtyEight_support_margin + _ = (2 ^ 756) ^ 2 := by rw [← pow_mul] + _ < p ^ 2 := + pow_lt_pow_left₀ hp (Nat.zero_le _) (by norm_num) + · have hpTwo : 2 ≤ p := by + have := seven_le_of_twoPow756_lt hp + omega + calc + ((p - 1).divisors.card + (p + 1).divisors.card) ^ 10 ≤ + 2 ^ 457 * p := by + simpa [preliminaryDivisorMomentConstant] using + preliminary_divisor_sum_pow_ten_le hpTwo + _ ≤ 2 ^ 458 * p := by + apply Nat.mul_le_mul_right + calc + 2 ^ 457 = 2 ^ 457 * 1 := by simp + _ ≤ 2 ^ 457 * 2 := Nat.mul_le_mul_left _ (by norm_num) + _ = 2 ^ (457 + 1) := (pow_succ 2 457).symm + _ = 2 ^ 458 := by norm_num + +/-- The cage coefficient times the squared divisor sum is below `sqrt p`. -/ +theorem cageCoefficient_mul_square_lt_sqrt_of_tenthMoment + {p T : ℕ} + (hpCoefficient : 100522 ^ 10 * 2 ^ 916 < p ^ 3) + (hmoment : T ^ 10 ≤ 2 ^ 458 * p) : + ((100522 * T ^ 2 : ℕ) : ℝ) < Real.sqrt (p : ℝ) := by + let Q : ℕ := 100522 ^ 10 * 2 ^ 916 + have hQ : Q < p ^ 3 := by + simpa [Q] using hpCoefficient + have hpPos : 0 < p := by + by_contra hpNot + have hpZero : p = 0 := Nat.eq_zero_of_not_pos hpNot + subst p + simp [Q] at hQ + have hTwo : (2 ^ 458) ^ 2 = 2 ^ 916 := by + rw [← pow_mul] + have hpowNat : (100522 * T ^ 2) ^ 10 < p ^ 5 := by + calc + (100522 * T ^ 2) ^ 10 = + 100522 ^ 10 * (T ^ 10) ^ 2 := by ring + _ ≤ 100522 ^ 10 * (2 ^ 458 * p) ^ 2 := by gcongr + _ = (100522 ^ 10 * (2 ^ 458) ^ 2) * p ^ 2 := by + rw [mul_pow] + ring + _ = Q * p ^ 2 := by rw [hTwo] + _ < p ^ 3 * p ^ 2 := + Nat.mul_lt_mul_of_pos_right hQ (pow_pos hpPos 2) + _ = p ^ 5 := by ring + have hpNonnegative : (0 : ℝ) ≤ p := by positivity + have hpowReal : ((100522 * T ^ 2 : ℕ) : ℝ) ^ 10 < + (p : ℝ) ^ 5 := by + exact_mod_cast hpowNat + have hrootPow : + ((p : ℝ) ^ (1 / 2 : ℝ)) ^ 10 = (p : ℝ) ^ 5 := by + calc + ((p : ℝ) ^ (1 / 2 : ℝ)) ^ 10 = + (p : ℝ) ^ ((1 / 2 : ℝ) * 10) := + (Real.rpow_mul_natCast hpNonnegative (1 / 2 : ℝ) 10).symm + _ = (p : ℝ) ^ 5 := by norm_num + rw [Real.sqrt_eq_rpow] + apply lt_of_pow_lt_pow_left₀ 10 (Real.rpow_nonneg hpNonnegative _) + rw [hrootPow] + exact hpowReal + +theorem preliminary_cageCoefficient_mul_divisorSum_sq_lt_sqrt_of_twoPow756 + {p : ℕ} (hp : 2 ^ 756 < p) : + ((100522 * + ((p - 1).divisors.card + (p + 1).divisors.card) ^ 2 : ℕ) : ℝ) < + Real.sqrt (p : ℝ) := by + apply cageCoefficient_mul_square_lt_sqrt_of_tenthMoment + · calc + 100522 ^ 10 * 2 ^ 916 < 2 ^ 2268 := + cageCoefficient_support_margin + _ = (2 ^ 756) ^ 3 := by rw [← pow_mul] + _ < p ^ 3 := + pow_lt_pow_left₀ hp (Nat.zero_le _) (by norm_num) + · have hpTwo : 2 ≤ p := by + have := seven_le_of_twoPow756_lt hp + omega + calc + ((p - 1).divisors.card + (p + 1).divisors.card) ^ 10 ≤ + 2 ^ 457 * p := by + simpa [preliminaryDivisorMomentConstant] using + preliminary_divisor_sum_pow_ten_le hpTwo + _ ≤ 2 ^ 458 * p := by + apply Nat.mul_le_mul_right + calc + 2 ^ 457 = 2 ^ 457 * 1 := by simp + _ ≤ 2 ^ 457 * 2 := Nat.mul_le_mul_left _ (by norm_num) + _ = 2 ^ (457 + 1) := (pow_succ 2 457).symm + _ = 2 ^ 458 := by norm_num + +/-- Primitive trace inclusion--exclusion above the unified support cutoff. -/ +theorem coarse_endgamePrimitiveTrace_explicitInequality + {p orbitExponent coefficient : ℕ} + (hp : 2 ^ 756 < p) + (horbit : (orbitExponent : ℝ) ≤ + 2 * (p : ℝ) ^ (1 / 6 : ℝ)) + (hcoefficient : coefficient ≤ 34) : + (orbitExponent : ℝ) * ((p - 1).divisors.card : ℝ) ^ 2 * + ((coefficient : ℝ) * Real.sqrt (p : ℝ)) < p := by + let T := (p - 1).divisors.card + (p + 1).divisors.card + have hpRealPos : (0 : ℝ) < p := by + exact_mod_cast (Nat.zero_lt_of_lt hp) + have hdivisor : ((p - 1).divisors.card : ℝ) ≤ (T : ℝ) := by + exact_mod_cast (show (p - 1).divisors.card ≤ T by + dsimp [T] + omega) + have hweighted : (68 : ℝ) * (T : ℝ) ^ 2 < + (p : ℝ) ^ (1 / 3 : ℝ) := by + simpa [T] using + preliminary_sixtyEight_mul_divisorSum_sq_lt_rpow_one_div_three_of_twoPow756 hp + calc + (orbitExponent : ℝ) * ((p - 1).divisors.card : ℝ) ^ 2 * + ((coefficient : ℝ) * Real.sqrt (p : ℝ)) ≤ + (2 * (p : ℝ) ^ (1 / 6 : ℝ)) * (T : ℝ) ^ 2 * + (34 * Real.sqrt (p : ℝ)) := by + gcongr + exact_mod_cast hcoefficient + _ = (68 * (T : ℝ) ^ 2) * + ((p : ℝ) ^ (1 / 6 : ℝ) * Real.sqrt (p : ℝ)) := by ring + _ < (p : ℝ) ^ (1 / 3 : ℝ) * + ((p : ℝ) ^ (1 / 6 : ℝ) * Real.sqrt (p : ℝ)) := by + exact mul_lt_mul_of_pos_right hweighted <| + mul_pos (Real.rpow_pos_of_pos hpRealPos _) (Real.sqrt_pos.2 hpRealPos) + _ = (p : ℝ) := by + rw [Real.sqrt_eq_rpow, ← Real.rpow_add hpRealPos, + ← Real.rpow_add hpRealPos] + norm_num + +theorem coarse_endgamePrimitiveTrace_explicitInequality_of_card_sub_one + {p orbitExponent orbitOrder coefficient : ℕ} + (hp : 2 ^ 756 < p) + (hmul : orbitExponent * orbitOrder = p - 1) + (horder : (p : ℝ) ^ (5 / 6 : ℝ) ≤ orbitOrder) + (hcoefficient : coefficient ≤ 34) : + (orbitExponent : ℝ) * ((p - 1).divisors.card : ℝ) ^ 2 * + ((coefficient : ℝ) * Real.sqrt (p : ℝ)) < p := by + apply coarse_endgamePrimitiveTrace_explicitInequality hp ?_ hcoefficient + have hpNat : 0 < p := Nat.zero_lt_of_lt hp + have horbit := orbitExponent_le_rpow_of_mul_order_eq_card_sub_one + p orbitExponent orbitOrder (δ := (1 / 3 : ℝ)) hpNat hmul (by + convert horder using 1 <;> norm_num) + calc + (orbitExponent : ℝ) ≤ (p : ℝ) ^ (1 / 6 : ℝ) := by + convert horbit using 1 <;> norm_num + _ ≤ 2 * (p : ℝ) ^ (1 / 6 : ℝ) := by + nlinarith [Real.rpow_nonneg (Nat.cast_nonneg p) (1 / 6 : ℝ)] + +theorem coarse_endgamePrimitiveTrace_explicitInequality_of_card_add_one + {p orbitExponent orbitOrder coefficient : ℕ} + (hp : 2 ^ 756 < p) + (hmul : orbitExponent * orbitOrder = p + 1) + (horder : (p : ℝ) ^ (5 / 6 : ℝ) ≤ orbitOrder) + (hcoefficient : coefficient ≤ 34) : + (orbitExponent : ℝ) * ((p - 1).divisors.card : ℝ) ^ 2 * + ((coefficient : ℝ) * Real.sqrt (p : ℝ)) < p := by + apply coarse_endgamePrimitiveTrace_explicitInequality hp ?_ hcoefficient + have hpNat : 0 < p := Nat.zero_lt_of_lt hp + have horbit := orbitExponent_le_two_mul_rpow_of_mul_order_eq_card_add_one + p orbitExponent orbitOrder (δ := (1 / 3 : ℝ)) hpNat hmul (by + convert horder using 1 <;> norm_num) + convert horbit using 1 <;> norm_num + +theorem coarse_four_lt_rpow_five_div_six + {p : ℕ} (hp : 2 ^ 756 < p) : + (4 : ℝ) < (p : ℝ) ^ (5 / 6 : ℝ) := by + have hpPos : 0 < p := Nat.zero_lt_of_lt hp + have hpRealPos : (0 : ℝ) < p := by exact_mod_cast hpPos + have hpSeven : 7 ≤ p := seven_le_of_twoPow756_lt hp + have hpOneNat : 1 < p := by omega + have hpOne : (1 : ℝ) < p := by exact_mod_cast hpOneNat + have hpowNat : 4 ^ 6 < p := by + calc + 4 ^ 6 < 2 ^ 756 := by + calc + 4 ^ 6 = 2 ^ 12 := by norm_num + _ < 2 ^ 756 := + Nat.pow_lt_pow_right (by norm_num) (by norm_num) + _ < p := hp + have hpowReal : (4 : ℝ) ^ 6 < (p : ℝ) := by + exact_mod_cast hpowNat + have hrootPow : + ((p : ℝ) ^ (1 / 6 : ℝ)) ^ 6 = (p : ℝ) := by + calc + ((p : ℝ) ^ (1 / 6 : ℝ)) ^ 6 = + (p : ℝ) ^ ((1 / 6 : ℝ) * 6) := + (Real.rpow_mul_natCast hpRealPos.le (1 / 6 : ℝ) 6).symm + _ = (p : ℝ) := by norm_num + have hfour : (4 : ℝ) < (p : ℝ) ^ (1 / 6 : ℝ) := by + apply lt_of_pow_lt_pow_left₀ 6 (Real.rpow_nonneg hpRealPos.le _) + rw [hrootPow] + exact hpowReal + exact hfour.trans + (Real.rpow_lt_rpow_of_exponent_lt hpOne (by norm_num)) + +/-- Cage connectivity inequality above the unified support cutoff. -/ +theorem coarse_cageWitness_explicitInequality + {p coefficient : ℕ} (hp : 2 ^ 756 < p) + (hcoefficient : coefficient ≤ 100522) : + ((p - 1).divisors.card : ℝ) ^ 2 * + ((coefficient : ℝ) * Real.sqrt (p : ℝ)) < p := by + let T := (p - 1).divisors.card + (p + 1).divisors.card + have hpRealPos : (0 : ℝ) < p := by + exact_mod_cast (Nat.zero_lt_of_lt hp) + have hdivisor : ((p - 1).divisors.card : ℝ) ≤ (T : ℝ) := by + exact_mod_cast (show (p - 1).divisors.card ≤ T by + dsimp [T] + omega) + have hcage : (100522 : ℝ) * (T : ℝ) ^ 2 < + Real.sqrt (p : ℝ) := by + simpa [T] using + preliminary_cageCoefficient_mul_divisorSum_sq_lt_sqrt_of_twoPow756 hp + calc + ((p - 1).divisors.card : ℝ) ^ 2 * + ((coefficient : ℝ) * Real.sqrt (p : ℝ)) ≤ + (T : ℝ) ^ 2 * (100522 * Real.sqrt (p : ℝ)) := by + gcongr + exact_mod_cast hcoefficient + _ = (100522 * (T : ℝ) ^ 2) * Real.sqrt (p : ℝ) := by ring + _ < Real.sqrt (p : ℝ) * Real.sqrt (p : ℝ) := + mul_lt_mul_of_pos_right hcage (Real.sqrt_pos.2 hpRealPos) + _ = (p : ℝ) := Real.mul_self_sqrt hpRealPos.le + +/-- The half-order sign threshold is automatic above `2^756`. -/ +theorem coarse_halfOrderThreshold + {p : ℕ} (hp : 2 ^ 756 < p) : + (p : ℝ) ^ (5 / 6 : ℝ) ≤ (((p - 1) / 2 : ℕ) : ℝ) := by + have hpPos : 0 < p := Nat.zero_lt_of_lt hp + have hpRealPos : (0 : ℝ) < p := by exact_mod_cast hpPos + have hthreePowNat : 3 ^ 6 < p := by + calc + 3 ^ 6 < 2 ^ 756 := by + calc + 3 ^ 6 < 2 ^ 12 := by norm_num + _ < 2 ^ 756 := + Nat.pow_lt_pow_right (by norm_num) (by norm_num) + _ < p := hp + have hthreePowReal : (3 : ℝ) ^ 6 < (p : ℝ) := by + exact_mod_cast hthreePowNat + have hrootPow : + ((p : ℝ) ^ (1 / 6 : ℝ)) ^ 6 = (p : ℝ) := by + calc + ((p : ℝ) ^ (1 / 6 : ℝ)) ^ 6 = + (p : ℝ) ^ ((1 / 6 : ℝ) * 6) := + (Real.rpow_mul_natCast hpRealPos.le (1 / 6 : ℝ) 6).symm + _ = (p : ℝ) := by norm_num + have hthree : (3 : ℝ) < (p : ℝ) ^ (1 / 6 : ℝ) := by + apply lt_of_pow_lt_pow_left₀ 6 (Real.rpow_nonneg hpRealPos.le _) + rw [hrootPow] + exact hthreePowReal + have hproduct : + 3 * (p : ℝ) ^ (5 / 6 : ℝ) < p := by + calc + 3 * (p : ℝ) ^ (5 / 6 : ℝ) < + (p : ℝ) ^ (1 / 6 : ℝ) * (p : ℝ) ^ (5 / 6 : ℝ) := + mul_lt_mul_of_pos_right hthree + (Real.rpow_pos_of_pos hpRealPos _) + _ = (p : ℝ) := by + rw [← Real.rpow_add hpRealPos] + norm_num + have hthird : + (p : ℝ) ^ (5 / 6 : ℝ) < (p : ℝ) / 3 := by + linarith + have hpSeven : 7 ≤ p := seven_le_of_twoPow756_lt hp + have hNat : p ≤ 3 * ((p - 1) / 2) := by omega + have hthirdLe : + (p : ℝ) / 3 ≤ (((p - 1) / 2 : ℕ) : ℝ) := by + have hcast : (p : ℝ) ≤ 3 * (((p - 1) / 2 : ℕ) : ℝ) := by + exact_mod_cast hNat + linarith + exact hthird.le.trans hthirdLe + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Assembly/DivisibleOrbitTransitivity.lean b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/DivisibleOrbitTransitivity.lean new file mode 100644 index 0000000000..ab4540e171 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/DivisibleOrbitTransitivity.lean @@ -0,0 +1,127 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Core.Statements +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.OrbitDivisibility + +/-! +# From a giant divisible orbit to transitivity + +The published version observes that a giant orbit with complement smaller than `p` is the whole +punctured Markoff surface if every orbit cardinality is divisible by `p`. This module proves that +finite-orbit argument and combines it with Chen's component-divisibility theorem, using Martin's +later elementary proof. +-/ + +@[expose] public section + +namespace BGS.Markoff + +/-- If one orbit has complement smaller than `p` and every orbit cardinality is divisible by `p`, +then the action is transitive. -/ +theorem puncturedMarkoffTransitiveAt_of_small_orbitComplement_and_orbitCard_dvd + (p : ℕ) [Fact p.Prime] + (x : PuncturedMarkoffSurface (ZMod p)) + (hsmall : orbitComplementCard x < p) + (hdiv : ∀ y : PuncturedMarkoffSurface (ZMod p), + p ∣ (puncturedGammaOrbit y).ncard) : + PuncturedMarkoffTransitiveAt p Fact.out := by + intro a b + have hxAll : ∀ y : PuncturedMarkoffSurface (ZMod p), + SamePuncturedComponent x y := by + intro y + by_contra hy + have horbitSubset : puncturedGammaOrbit y ⊆ Set.univ \ puncturedGammaOrbit x := by + intro z hz + refine ⟨Set.mem_univ z, ?_⟩ + intro hzx + apply hy + exact samePuncturedComponent_trans hzx (samePuncturedComponent_symm hz) + have horbitPos : 0 < (puncturedGammaOrbit y).ncard := + (Set.ncard_pos (Set.toFinite _)).2 ⟨y, samePuncturedComponent_refl y⟩ + have hpLeOrbit : p ≤ (puncturedGammaOrbit y).ncard := + Nat.le_of_dvd horbitPos (hdiv y) + have horbitLeComplement : + (puncturedGammaOrbit y).ncard ≤ orbitComplementCard x := by + rw [orbitComplementCard] + exact Set.ncard_le_ncard horbitSubset + omega + obtain ⟨ga, hga⟩ := (samePuncturedComponent_iff_exists x a).1 (hxAll a) + obtain ⟨gb, hgb⟩ := (samePuncturedComponent_iff_exists x b).1 (hxAll b) + refine ⟨gb * ga⁻¹, ?_⟩ + calc + (gb * ga⁻¹) • a = gb • (ga⁻¹ • a) := mul_smul _ _ _ + _ = gb • x := by rw [← hga]; simp + _ = b := hgb + +/-- A `p^epsilon` giant-orbit bound with `epsilon < 1` has complement strictly smaller than `p`. -/ +theorem exists_orbitComplementCard_lt_prime_of_hasGiantOrbitAt + (p : ℕ) (hp : p.Prime) (epsilon : ℝ) (hepsilon : epsilon < 1) + (hgiant : HasGiantOrbitAt p hp epsilon) : + letI : Fact p.Prime := ⟨hp⟩ + ∃ x : PuncturedMarkoffSurface (ZMod p), orbitComplementCard x < p := by + let : Fact p.Prime := ⟨hp⟩ + obtain ⟨x, hx⟩ := hgiant + refine ⟨x, ?_⟩ + have hpReal : (1 : ℝ) < (p : ℝ) := by exact_mod_cast hp.one_lt + have hrpow : (p : ℝ) ^ epsilon < (p : ℝ) := by + simpa only [Real.rpow_one] using + Real.rpow_lt_rpow_of_exponent_lt hpReal hepsilon + have hreal : (orbitComplementCard x : ℝ) < (p : ℝ) := hx.trans_lt hrpow + exact_mod_cast hreal + +/-- The published short route from a giant orbit and orbit-cardinality divisibility to +punctured finite-field transitivity at the given prime. -/ +theorem puncturedMarkoffTransitiveAt_of_hasGiantOrbitAt_and_orbitCard_dvd + (p : ℕ) (hp : p.Prime) (epsilon : ℝ) (hepsilon : epsilon < 1) + (hgiant : HasGiantOrbitAt p hp epsilon) + (hdiv : letI : Fact p.Prime := ⟨hp⟩ + ∀ y : PuncturedMarkoffSurface (ZMod p), + p ∣ (puncturedGammaOrbit y).ncard) : + PuncturedMarkoffTransitiveAt p hp := by + let : Fact p.Prime := ⟨hp⟩ + obtain ⟨x, hx⟩ := + exists_orbitComplementCard_lt_prime_of_hasGiantOrbitAt + p hp epsilon hepsilon hgiant + exact puncturedMarkoffTransitiveAt_of_small_orbitComplement_and_orbitCard_dvd p x hx hdiv + +/-- Eventual giant-orbit control with any fixed exponent below one, combined with orbit +divisibility for primes larger than three, gives eventual punctured finite-field transitivity. -/ +theorem eventually_puncturedMarkoffTransitiveAt_of_giantOrbit_and_orbitCard_dvd + (epsilon : ℝ) (hepsilon : epsilon < 1) + (hgiant : ∃ p0 : ℕ, ∀ (p : ℕ) (hp : p.Prime), p0 ≤ p → + HasGiantOrbitAt p hp epsilon) + (hdiv : ∀ (p : ℕ) (hp : p.Prime), 3 < p → + letI : Fact p.Prime := ⟨hp⟩ + ∀ y : PuncturedMarkoffSurface (ZMod p), + p ∣ (puncturedGammaOrbit y).ncard) : + ∃ p0 : ℕ, ∀ (p : ℕ) (hp : p.Prime), p0 ≤ p → + PuncturedMarkoffTransitiveAt p hp := by + obtain ⟨p0, hp0⟩ := hgiant + refine ⟨max p0 4, fun p hp hple => ?_⟩ + have hp0le : p0 ≤ p := (Nat.le_max_left p0 4).trans hple + have hpThree : 3 < p := by omega + exact puncturedMarkoffTransitiveAt_of_hasGiantOrbitAt_and_orbitCard_dvd + p hp epsilon hepsilon (hp0 p hp hp0le) (hdiv p hp hpThree) + +/-- Chen's component-divisibility theorem, through Martin's elementary proof, turns any eventual +giant-orbit estimate with exponent below one into eventual punctured finite-field transitivity. -/ +theorem eventually_puncturedMarkoffTransitiveAt_of_giantOrbit + (epsilon : ℝ) (hepsilon : epsilon < 1) + (hgiant : ∃ p0 : ℕ, ∀ (p : ℕ) (hp : p.Prime), p0 ≤ p → + HasGiantOrbitAt p hp epsilon) : + ∃ p0 : ℕ, ∀ (p : ℕ) (hp : p.Prime), p0 ≤ p → + PuncturedMarkoffTransitiveAt p hp := by + apply eventually_puncturedMarkoffTransitiveAt_of_giantOrbit_and_orbitCard_dvd + epsilon hepsilon hgiant + intro p hp hpThree + let : Fact p.Prime := ⟨hp⟩ + intro y + exact prime_dvd_puncturedGammaOrbit_ncard p hpThree y + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Assembly/ElementaryCounts.lean b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/ElementaryCounts.lean new file mode 100644 index 0000000000..7702761bf9 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/ElementaryCounts.lean @@ -0,0 +1,370 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import Mathlib.Algebra.Polynomial.Degree.IsMonicOfDegree +public import LeanPool.MarkoffModP.BGS.Markoff.Core.Basic +public import Mathlib.GroupTheory.SpecificGroups.Cyclic + +/-! +# Elementary counts for the giant-orbit assembly + +This file isolates the two elementary finite counts omitted from the paper's final assembly: + +* fixing the first two coordinates of a Markoff point leaves at most two choices for the third; +* traces coming from elements of bounded order in a finite cyclic group have a deliberately crude + quadratic cardinality bound. + +The cyclicity hypothesis in the second count is essential: the analogous statement for arbitrary +finite groups is false (an elementary abelian `2`-group can have more than two elements of order +two). The split and norm-one tori to which this count will eventually be applied are cyclic. +-/ + +@[expose] public section + +namespace BGS.Markoff + +open Polynomial + +section ThirdCoordinateFiber + +variable {F : Type*} [Field F] + +/-- The monic quadratic obtained from the Markoff equation after fixing its first two +coordinates. -/ +noncomputable def thirdCoordinatePolynomial (a b : F) : F[X] := + X ^ 2 - C (3 * a * b) * X + C (a ^ 2 + b ^ 2) + +@[simp] +theorem thirdCoordinatePolynomial_eval (a b c : F) : + (thirdCoordinatePolynomial a b).eval c = markoffPolynomial ⟨a, b, c⟩ := by + simp [thirdCoordinatePolynomial, markoffPolynomial] + ring + +theorem thirdCoordinatePolynomial_monic (a b : F) : + (thirdCoordinatePolynomial a b).Monic := by + exact (isMonicOfDegree_sub_add_two (3 * a * b) (a ^ 2 + b ^ 2)).monic + +@[simp] +theorem thirdCoordinatePolynomial_natDegree (a b : F) : + (thirdCoordinatePolynomial a b).natDegree = 2 := by + exact (isMonicOfDegree_sub_add_two (3 * a * b) (a ^ 2 + b ^ 2)).natDegree_eq + +variable [Fintype F] + +/-- The possible third coordinates of Markoff points whose first two coordinates are `a,b`. -/ +noncomputable def thirdCoordinatesOnMarkoffSurface (a b : F) : Finset F := by + classical + exact Finset.univ.filter fun c => IsMarkoff ⟨a, b, c⟩ + +theorem thirdCoordinatesOnMarkoffSurface_card_le_two (a b : F) : + (thirdCoordinatesOnMarkoffSurface a b).card ≤ 2 := by + classical + let f := thirdCoordinatePolynomial a b + have hf : f ≠ 0 := (thirdCoordinatePolynomial_monic a b).ne_zero + have hsubset : thirdCoordinatesOnMarkoffSurface a b ⊆ f.roots.toFinset := by + intro c hc + rw [thirdCoordinatesOnMarkoffSurface, Finset.mem_filter] at hc + rw [Multiset.mem_toFinset, Polynomial.mem_roots hf] + simpa [f, IsMarkoff] using hc.2 + calc + (thirdCoordinatesOnMarkoffSurface a b).card ≤ f.roots.toFinset.card := + Finset.card_mono hsubset + _ ≤ f.roots.card := Multiset.toFinset_card_le _ + _ ≤ f.natDegree := Polynomial.card_roots' f + _ = 2 := thirdCoordinatePolynomial_natDegree a b + +/-- Markoff-surface points, represented in the project's ambient `Point` type, with prescribed +first and second coordinates. -/ +noncomputable def markoffPointsWithFirstTwoCoordinates (a b : F) : Finset (Point F) := by + classical + exact (thirdCoordinatesOnMarkoffSurface a b).image fun c => ⟨a, b, c⟩ + +theorem mem_markoffPointsWithFirstTwoCoordinates_iff {a b : F} {x : Point F} : + x ∈ markoffPointsWithFirstTwoCoordinates a b ↔ + IsMarkoff x ∧ x.x1 = a ∧ x.x2 = b := by + classical + constructor + · intro hx + obtain ⟨c, hc, rfl⟩ := Finset.mem_image.mp hx + rw [thirdCoordinatesOnMarkoffSurface, Finset.mem_filter] at hc + exact ⟨hc.2, rfl, rfl⟩ + · rintro ⟨hmarkoff, hx1, hx2⟩ + have hpoint : (⟨a, b, x.x3⟩ : Point F) = x := by + ext <;> simp [hx1, hx2] + apply Finset.mem_image.mpr + refine ⟨x.x3, ?_, hpoint⟩ + · rw [thirdCoordinatesOnMarkoffSurface, Finset.mem_filter] + refine ⟨Finset.mem_univ _, ?_⟩ + rw [hpoint] + exact hmarkoff + +theorem markoffPointsWithFirstTwoCoordinates_card_le_two (a b : F) : + (markoffPointsWithFirstTwoCoordinates a b).card ≤ 2 := by + classical + exact Finset.card_image_le.trans (thirdCoordinatesOnMarkoffSurface_card_le_two a b) + +end ThirdCoordinateFiber + +section LowOrderTrace + +variable {G T : Type*} [Group G] [Fintype G] [DecidableEq T] + +/-- Elements of a finite group whose multiplicative order is strictly below `bound`. -/ +noncomputable def elementsOfOrderLessThan + (G : Type*) [Group G] [Fintype G] (bound : ℕ) : Finset G := + Finset.univ.filter fun g => orderOf g < bound + +/-- Values of a trace-like map on group elements whose multiplicative order is below `bound`. -/ +noncomputable def boundedOrderTraceSet (trace : G → T) (bound : ℕ) : Finset T := + (elementsOfOrderLessThan G bound).image trace + +theorem elementsOfOrderLessThan_card_le_sum_range [IsCyclic G] (bound : ℕ) : + (elementsOfOrderLessThan G bound).card ≤ ∑ d ∈ Finset.range bound, d := by + classical + rw [elementsOfOrderLessThan] + rw [Finset.card_eq_sum_card_fiberwise + (t := Finset.range bound) (f := orderOf) (by + intro g hg + exact Finset.mem_range.mpr (Finset.mem_filter.mp hg).2)] + apply Finset.sum_le_sum + intro d hd + rw [Finset.mem_range] at hd + have hfiber : + (Finset.univ.filter fun g : G => orderOf g < bound).filter (fun g => orderOf g = d) = + Finset.univ.filter (fun g : G => orderOf g = d) := by + ext g + simp only [Finset.mem_filter, Finset.mem_univ, true_and] + constructor + · exact fun h => h.2 + · intro h + exact ⟨h ▸ hd, h⟩ + rw [hfiber] + by_cases hdvd : d ∣ Fintype.card G + · rw [IsCyclic.card_orderOf_eq_totient hdvd] + exact Nat.totient_le d + · have hempty : Finset.univ.filter (fun g : G => orderOf g = d) = ∅ := by + ext g + simp only [Finset.mem_filter, Finset.mem_univ, true_and, Finset.notMem_empty, + iff_false] + intro horder + apply hdvd + rw [← horder] + exact orderOf_dvd_card + simp [hempty] + +/-- A divisor-sensitive version of the bounded-order count. Only orders dividing the group +cardinality can occur, and each such order contributes fewer than `bound` elements. -/ +theorem elementsOfOrderLessThan_card_le_pred_mul_card_divisors [IsCyclic G] (bound : ℕ) : + (elementsOfOrderLessThan G bound).card ≤ + (bound - 1) * (Fintype.card G).divisors.card := by + classical + have hcard : Fintype.card G ≠ 0 := Fintype.card_ne_zero + rw [elementsOfOrderLessThan] + rw [Finset.card_eq_sum_card_fiberwise + (t := Finset.range bound) (f := orderOf) (by + intro g hg + exact Finset.mem_range.mpr (Finset.mem_filter.mp hg).2)] + calc + (∑ d ∈ Finset.range bound, + ((Finset.univ.filter fun g : G => orderOf g < bound).filter + fun g => orderOf g = d).card) ≤ + ∑ d ∈ Finset.range bound, + if d ∣ Fintype.card G then bound - 1 else 0 := by + apply Finset.sum_le_sum + intro d hd + by_cases hdvd : d ∣ Fintype.card G + · rw [ite_eq_left hdvd] + have hfiber : + (Finset.univ.filter fun g : G => orderOf g < bound).filter + (fun g => orderOf g = d) = + Finset.univ.filter (fun g : G => orderOf g = d) := by + ext g + simp only [Finset.mem_filter, Finset.mem_univ, true_and] + constructor + · exact fun h => h.2 + · intro h + exact ⟨h ▸ Finset.mem_range.mp hd, h⟩ + rw [hfiber, IsCyclic.card_orderOf_eq_totient hdvd] + exact (Nat.totient_le d).trans (Nat.le_sub_one_of_lt (Finset.mem_range.mp hd)) + · rw [ite_eq_right hdvd] + have hempty : Finset.univ.filter (fun g : G => orderOf g = d) = ∅ := by + ext g + simp only [Finset.mem_filter, Finset.mem_univ, true_and, + Finset.notMem_empty, iff_false] + intro horder + apply hdvd + rw [← horder] + exact orderOf_dvd_card + have hfiber : + (Finset.univ.filter fun g : G => orderOf g < bound).filter + (fun g => orderOf g = d) = ∅ := by + apply Finset.eq_empty_iff_forall_notMem.mpr + intro g hg + have hgOrder := (Finset.mem_filter.mp hg).2 + have : g ∈ Finset.univ.filter (fun g : G => orderOf g = d) := by + simp [hgOrder] + rw [hempty] at this + exact (Finset.notMem_empty g) this + simp [hfiber] + _ = (bound - 1) * ((Finset.range bound).filter + fun d => d ∣ Fintype.card G).card := by + rw [← Finset.sum_filter] + simp [mul_comm] + _ ≤ (bound - 1) * (Fintype.card G).divisors.card := by + gcongr + intro d hd + rw [Finset.mem_filter] at hd + exact Nat.mem_divisors.mpr ⟨hd.2, hcard⟩ + +theorem elementsOfOrderLessThan_card_le_bound_mul_card_divisors [IsCyclic G] (bound : ℕ) : + (elementsOfOrderLessThan G bound).card ≤ + bound * (Fintype.card G).divisors.card := by + exact (elementsOfOrderLessThan_card_le_pred_mul_card_divisors bound).trans <| by + gcongr + omega + +theorem boundedOrderTraceSet_card_le_sum_range [IsCyclic G] + (trace : G → T) (bound : ℕ) : + (boundedOrderTraceSet trace bound).card ≤ ∑ d ∈ Finset.range bound, d := by + exact Finset.card_image_le.trans (elementsOfOrderLessThan_card_le_sum_range bound) + +theorem boundedOrderTraceSet_card_le_bound_mul_card_divisors [IsCyclic G] + (trace : G → T) (bound : ℕ) : + (boundedOrderTraceSet trace bound).card ≤ + bound * (Fintype.card G).divisors.card := by + exact Finset.card_image_le.trans + (elementsOfOrderLessThan_card_le_bound_mul_card_divisors bound) + +theorem boundedOrderTraceSet_card_le_pred_mul_card_divisors [IsCyclic G] + (trace : G → T) (bound : ℕ) : + (boundedOrderTraceSet trace bound).card ≤ + (bound - 1) * (Fintype.card G).divisors.card := by + exact Finset.card_image_le.trans + (elementsOfOrderLessThan_card_le_pred_mul_card_divisors bound) + +theorem sum_orders_below_bound_le_bound_sq (bound : ℕ) : + (∑ d ∈ Finset.range bound, d) ≤ bound ^ 2 := by + calc + (∑ d ∈ Finset.range bound, d) ≤ + ∑ _d ∈ Finset.range bound, bound := by + gcongr with d hd + exact Nat.le_of_lt (Finset.mem_range.mp hd) + _ = bound * bound := by simp + _ = bound ^ 2 := by ring + +theorem boundedOrderTraceSet_card_le_bound_sq [IsCyclic G] + (trace : G → T) (bound : ℕ) : + (boundedOrderTraceSet trace bound).card ≤ bound ^ 2 := + (boundedOrderTraceSet_card_le_sum_range trace bound).trans + (sum_orders_below_bound_le_bound_sq bound) + +/-- The union of bounded-order trace values from the split and norm-one tori, together with a +finite set of exceptional (parabolic) trace values. -/ +noncomputable def lowOrderTraceSet + {Gsplit Gnonsplit T : Type*} + [Group Gsplit] [Fintype Gsplit] [Group Gnonsplit] [Fintype Gnonsplit] [DecidableEq T] + (parabolic : Finset T) (splitTrace : Gsplit → T) (nonsplitTrace : Gnonsplit → T) + (bound : ℕ) : Finset T := + parabolic ∪ boundedOrderTraceSet splitTrace bound ∪ boundedOrderTraceSet nonsplitTrace bound + +theorem lowOrderTraceSet_card_le + {Gsplit Gnonsplit T : Type*} + [Group Gsplit] [Fintype Gsplit] [IsCyclic Gsplit] + [Group Gnonsplit] [Fintype Gnonsplit] [IsCyclic Gnonsplit] + [DecidableEq T] + (parabolic : Finset T) (splitTrace : Gsplit → T) (nonsplitTrace : Gnonsplit → T) + (bound : ℕ) : + (lowOrderTraceSet parabolic splitTrace nonsplitTrace bound).card ≤ + parabolic.card + 2 * ∑ d ∈ Finset.range bound, d := by + unfold lowOrderTraceSet + calc + (parabolic ∪ boundedOrderTraceSet splitTrace bound ∪ + boundedOrderTraceSet nonsplitTrace bound).card ≤ + (parabolic ∪ boundedOrderTraceSet splitTrace bound).card + + (boundedOrderTraceSet nonsplitTrace bound).card := + Finset.card_union_le + (parabolic ∪ boundedOrderTraceSet splitTrace bound) + (boundedOrderTraceSet nonsplitTrace bound) + _ ≤ (parabolic.card + (boundedOrderTraceSet splitTrace bound).card) + + (boundedOrderTraceSet nonsplitTrace bound).card := by + gcongr + exact Finset.card_union_le parabolic (boundedOrderTraceSet splitTrace bound) + _ ≤ (parabolic.card + (∑ d ∈ Finset.range bound, d)) + + (∑ d ∈ Finset.range bound, d) := by + gcongr + · exact boundedOrderTraceSet_card_le_sum_range splitTrace bound + · exact boundedOrderTraceSet_card_le_sum_range nonsplitTrace bound + _ = parabolic.card + 2 * ∑ d ∈ Finset.range bound, d := by omega + +theorem lowOrderTraceSet_card_le_parabolic_add_two_mul_bound_sq + {Gsplit Gnonsplit T : Type*} + [Group Gsplit] [Fintype Gsplit] [IsCyclic Gsplit] + [Group Gnonsplit] [Fintype Gnonsplit] [IsCyclic Gnonsplit] + [DecidableEq T] + (parabolic : Finset T) (splitTrace : Gsplit → T) (nonsplitTrace : Gnonsplit → T) + (bound : ℕ) : + (lowOrderTraceSet parabolic splitTrace nonsplitTrace bound).card ≤ + parabolic.card + 2 * bound ^ 2 := by + exact (lowOrderTraceSet_card_le parabolic splitTrace nonsplitTrace bound).trans <| by + gcongr + exact sum_orders_below_bound_le_bound_sq bound + +/-- A divisor-sensitive count for the union of the two bounded-order trace sets. -/ +theorem lowOrderTraceSet_card_le_parabolic_add_pred_mul_divisor_cards + {Gsplit Gnonsplit T : Type*} + [Group Gsplit] [Fintype Gsplit] [IsCyclic Gsplit] + [Group Gnonsplit] [Fintype Gnonsplit] [IsCyclic Gnonsplit] + [DecidableEq T] + (parabolic : Finset T) (splitTrace : Gsplit → T) (nonsplitTrace : Gnonsplit → T) + (bound : ℕ) : + (lowOrderTraceSet parabolic splitTrace nonsplitTrace bound).card ≤ + parabolic.card + (bound - 1) * + ((Fintype.card Gsplit).divisors.card + (Fintype.card Gnonsplit).divisors.card) := by + unfold lowOrderTraceSet + calc + (parabolic ∪ boundedOrderTraceSet splitTrace bound ∪ + boundedOrderTraceSet nonsplitTrace bound).card ≤ + (parabolic ∪ boundedOrderTraceSet splitTrace bound).card + + (boundedOrderTraceSet nonsplitTrace bound).card := + Finset.card_union_le + (parabolic ∪ boundedOrderTraceSet splitTrace bound) + (boundedOrderTraceSet nonsplitTrace bound) + _ ≤ (parabolic.card + (boundedOrderTraceSet splitTrace bound).card) + + (boundedOrderTraceSet nonsplitTrace bound).card := by + gcongr + exact Finset.card_union_le parabolic (boundedOrderTraceSet splitTrace bound) + _ ≤ (parabolic.card + + (bound - 1) * (Fintype.card Gsplit).divisors.card) + + (bound - 1) * (Fintype.card Gnonsplit).divisors.card := by + gcongr + · exact boundedOrderTraceSet_card_le_pred_mul_card_divisors splitTrace bound + · exact boundedOrderTraceSet_card_le_pred_mul_card_divisors nonsplitTrace bound + _ = parabolic.card + (bound - 1) * + ((Fintype.card Gsplit).divisors.card + + (Fintype.card Gnonsplit).divisors.card) := by + rw [Nat.mul_add] + omega + +theorem lowOrderTraceSet_card_le_parabolic_add_bound_mul_divisor_cards + {Gsplit Gnonsplit T : Type*} + [Group Gsplit] [Fintype Gsplit] [IsCyclic Gsplit] + [Group Gnonsplit] [Fintype Gnonsplit] [IsCyclic Gnonsplit] + [DecidableEq T] + (parabolic : Finset T) (splitTrace : Gsplit → T) (nonsplitTrace : Gnonsplit → T) + (bound : ℕ) : + (lowOrderTraceSet parabolic splitTrace nonsplitTrace bound).card ≤ + parabolic.card + bound * + ((Fintype.card Gsplit).divisors.card + (Fintype.card Gnonsplit).divisors.card) := by + exact (lowOrderTraceSet_card_le_parabolic_add_pred_mul_divisor_cards + parabolic splitTrace nonsplitTrace bound).trans <| by + gcongr + omega + +end LowOrderTrace + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Assembly/EulerSevenCoarseSupportFrontier.lean b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/EulerSevenCoarseSupportFrontier.lean new file mode 100644 index 0000000000..7b0824f798 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/EulerSevenCoarseSupportFrontier.lean @@ -0,0 +1,90 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.CoarseEndgame +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.EulerSevenSplitCageCoarseLinearTail + +/-! +# Euler-seven frontier with all support tails discharged + +At `2^756 < p`, the simultaneous tenth-moment estimate now supplies the +linear middle game, primitive endgame, cage connectivity, split-cage base, +and half-order comparison. The only remaining arithmetic certificate is a +square envelope for the joint maximal-divisor count together with its exact +Euler-seven cubic inequality. +-/ + +@[expose] public section + +namespace BGS.Markoff + +open BGS.NumberTheory + +noncomputable section + +/-- Punctured transitivity above the unified support cutoff. All non-cubic +arithmetic and all endgame/cage hypotheses have been discharged. -/ +theorem + puncturedMarkoffTransitiveAt_of_eulerSevenSquareEnvelope_coarseSupport + (p : ℕ) [Fact p.Prime] [Invertible (3 : ZMod p)] + (hpSupport : 2 ^ 756 < p) + (squareEnvelope : ℕ → ℕ) + (hcount : ∀ d : ℕ, + maximalDivisorCountSum p (d + 1) ^ 2 ≤ squareEnvelope d) + (hcubic : ∀ d : ℕ, + 35721 * squareEnvelope d ^ 4 < 8 * p) : + PuncturedMarkoffTransitiveAt p Fact.out := by + have hpSeven : 7 ≤ p := seven_le_of_twoPow756_lt hpSupport + obtain ⟨baseNormalized, hbaseCage⟩ := + exists_normalizedPunctured_splitCagePoint p hpSeven + let base : PuncturedMarkoffSurface (ZMod p) := + (puncturedNormalizationEquiv (ZMod p)).symm baseNormalized + apply + puncturedMarkoffTransitiveAt_of_splitCage_eulerSevenSquareEnvelope_coarseLinearTail + p hpSeven (twentyFour_support_margin.trans hpSupport) + base ?_ (coarse_halfOrderThreshold hpSupport) + squareEnvelope hcount hcubic + · intro z hzLarge + have hcoordinate : + (p : ℝ) ^ (5 / 6 : ℝ) ≤ rotationOrder z.1.u1 ∨ + (p : ℝ) ^ (5 / 6 : ℝ) ≤ rotationOrder z.1.u2 ∨ + (p : ℝ) ^ (5 / 6 : ℝ) ≤ rotationOrder z.1.u3 := by + by_contra hsmall + push Not at hsmall + have hmaxSmall : (maximalCoordinateRotationOrder z.1 : ℝ) < + (p : ℝ) ^ (5 / 6 : ℝ) := by + rw [maximalCoordinateRotationOrder, Nat.cast_max, Nat.cast_max] + exact max_lt hsmall.1 (max_lt hsmall.2.1 hsmall.2.2) + exact (not_lt_of_ge hzLarge) hmaxSmall + have hcomponent := + coarse_sameNormalizedComponent_of_largeOrder_to_splitCage + hpSupport (normalizedSurfaceOfPunctured baseNormalized) + z hbaseCage hcoordinate + simpa [base] using hcomponent + · simpa [base] using hbaseCage + +/-- Natural Markoff reduction is surjective under the same support-closed +Euler-seven square-envelope certificate. -/ +theorem + markoffReduction_surjective_of_eulerSevenSquareEnvelope_coarseSupport + (p : ℕ) [Fact p.Prime] [Invertible (3 : ZMod p)] + (hpSupport : 2 ^ 756 < p) + (squareEnvelope : ℕ → ℕ) + (hcount : ∀ d : ℕ, + maximalDivisorCountSum p (d + 1) ^ 2 ≤ squareEnvelope d) + (hcubic : ∀ d : ℕ, + 35721 * squareEnvelope d ^ 4 < 8 * p) : + Function.Surjective (markoffReduction p) := + (puncturedMarkoffTransitiveAt_iff_markoffReduction_surjective + p Fact.out).mp + (puncturedMarkoffTransitiveAt_of_eulerSevenSquareEnvelope_coarseSupport + p hpSupport squareEnvelope hcount hcubic) + +end + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Assembly/EulerSevenNonparabolicComplementFrontier.lean b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/EulerSevenNonparabolicComplementFrontier.lean new file mode 100644 index 0000000000..bb7c0b0c86 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/EulerSevenNonparabolicComplementFrontier.lean @@ -0,0 +1,256 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.NonparabolicComplementFrontier +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.EulerSevenPairedMaximalDivisorMiddleGame + +/-! +# Euler-seven nonparabolic complement frontier + +This is the complement-maximal argument with the exact paired +Euler-characteristic middle-game condition `189 * M^3 < d`. +-/ + +@[expose] public section + +namespace BGS.Markoff + +open BGS.NumberTheory + +noncomputable section + +private def normalizedPuncturedPointEulerSevenComplement + {R : Type*} [Field R] [Invertible (3 : R)] + (x : PuncturedMarkoffSurface R) : NormalizedMarkoffSurface R := + normalizedSurfaceOfPunctured (puncturedNormalizationEquiv R x) + +private theorem normalizedPuncturedPointEulerSevenComplement_smul + {R : Type*} [Field R] [Invertible (3 : R)] + (g : Gamma R) (z : PuncturedMarkoffSurface R) : + normalizedPuncturedPointEulerSevenComplement (g • z) = + normalizedGammaPerm R g + (normalizedPuncturedPointEulerSevenComplement z) := by + have hzinv : + (normalizationSurfaceEquiv R).symm + (normalizedSurfaceOfPunctured + (puncturedNormalizationEquiv R z)) = z.1 := by + apply Subtype.ext + exact (normalizationEquiv R).symm_apply_apply z.1.1 + unfold normalizedPuncturedPointEulerSevenComplement + rw [normalizedGammaPerm_apply, hzinv] + apply Subtype.ext + rfl + +/-- Complement-maximal frontier with the exact Euler-seven paired +Corvaja--Zannier coefficient. The sign-invariance and factor-four inputs +remain explicit. -/ +theorem + puncturedMarkoffTransitiveAt_of_nonparabolicComplement_eulerSevenPairedMaximalDivisor_frontier + (p : ℕ) [Fact p.Prime] [Invertible (3 : ZMod p)] + (hpThree : 3 < p) + (c : PuncturedMarkoffSurface (ZMod p)) + (hcube : ∀ d : ℕ, 0 < d → + 8 * p ≤ + (d * maximalDivisorCountSum p (d + 1)) ^ 2 → + 189 * maximalDivisorCountSum p (d + 1) ^ 3 < d) + (hlinear : ∀ d : ℕ, + (d : ℝ) < (p : ℝ) ^ (5 / 6 : ℝ) → + 24 * maximalDivisorCountSum p (d + 1) * d < p) + (hlarge : ∀ z : NormalizedMarkoffSurface (ZMod p), + (p : ℝ) ^ (5 / 6 : ℝ) ≤ + maximalCoordinateRotationOrder z.1 → + SameNormalizedComponent + (normalizedSurfaceOfPunctured (puncturedNormalizationEquiv (ZMod p) c)) z) + (hsign : ∀ (s : EvenSign) + (x : PuncturedMarkoffSurface (ZMod p)), + s • x ∈ puncturedComponentComplementFinset p c ↔ + x ∈ puncturedComponentComplementFinset p c) + (hfour : 4 ∣ (puncturedComponentComplementFinset p c).card) : + PuncturedMarkoffTransitiveAt p Fact.out := by + classical + have hpTwo : p ≠ 2 := by omega + let : Fintype (quadraticFiniteField p) := Fintype.ofFinite _ + have hAll : ∀ x : PuncturedMarkoffSurface (ZMod p), + SamePuncturedComponent c x := by + intro x + by_contra hcx + let bad := puncturedComponentComplementFinset p c + have hxBad : x ∈ bad := by + simpa [bad] using hcx + have hbadNonempty : bad.Nonempty := by + refine ⟨(1 : EvenSign) • x, ?_⟩ + exact (by simpa [bad] using (hsign (1 : EvenSign) x).2 hxBad) + let orderMeasure : PuncturedMarkoffSurface (ZMod p) → ℕ := fun w => + maximalCoordinateRotationOrder + (normalizedPuncturedPointEulerSevenComplement w).1 + obtain ⟨z, hzBad, hzMax⟩ := + Finset.exists_max_image bad orderMeasure hbadNonempty + let d := orderMeasure z + have hmax : ∀ w : PuncturedMarkoffSurface (ZMod p), + w ∈ bad → orderMeasure w ≤ d := by + intro w hw + exact hzMax w hw + have hzNotComponent : ¬ SamePuncturedComponent c z := by + simpa [bad] using hzBad + have hdPos : 0 < d := by + have hfirstPos : 0 < + rotationOrder + (normalizedPuncturedPointEulerSevenComplement z).1.u1 := + rotationOrder_pos _ + exact hfirstPos.trans_le <| by + simpa [d, orderMeasure] using + rotationOrder_first_le_maximalCoordinateRotationOrder + (normalizedPuncturedPointEulerSevenComplement z).1 + have hnotBaseZ : ¬ SameNormalizedComponent + (normalizedPuncturedPointEulerSevenComplement c) + (normalizedPuncturedPointEulerSevenComplement z) := by + intro hcz + apply hzNotComponent + exact + (samePuncturedComponent_iff_sameNormalizedComponent c z).2 hcz + have hdUpper : (d : ℝ) < (p : ℝ) ^ (5 / 6 : ℝ) := by + by_contra hd + apply hnotBaseZ + apply hlarge (normalizedPuncturedPointEulerSevenComplement z) + simpa [d, orderMeasure] using le_of_not_gt hd + have hbadSmall : + bad.card ≤ + (puncturedMarkoffPointsWithSmallNonparabolicFirstTwoRotationOrders + p (d + 1)).card := by + apply Finset.card_le_card + intro w hwBad + have hwNotComponent : ¬ SamePuncturedComponent c w := by + simpa [bad] using hwBad + have hwNotBase : ¬ SameNormalizedComponent + (normalizedPuncturedPointEulerSevenComplement c) + (normalizedPuncturedPointEulerSevenComplement w) := by + intro hcw + apply hwNotComponent + exact + (samePuncturedComponent_iff_sameNormalizedComponent c w).2 hcw + have hnonparabolic := + first_two_nonparabolic_of_not_sameComponent_of_endgame_large_connected + hpTwo + (normalizedPuncturedPointEulerSevenComplement c) + (normalizedPuncturedPointEulerSevenComplement w) + hlarge hwNotBase + have hwMax := hmax w hwBad + have hfirst : + rotationOrder + (normalizedPuncturedPointEulerSevenComplement w).1.u1 ≤ d := + (rotationOrder_first_le_maximalCoordinateRotationOrder + (normalizedPuncturedPointEulerSevenComplement w).1).trans hwMax + have hsecond : + rotationOrder + (normalizedPuncturedPointEulerSevenComplement w).1.u2 ≤ d := + (rotationOrder_second_le_maximalCoordinateRotationOrder + (normalizedPuncturedPointEulerSevenComplement w).1).trans hwMax + change w ∈ + puncturedMarkoffPointsWithSmallNonparabolicFirstTwoRotationOrders + p (d + 1) + rw [ + puncturedMarkoffPointsWithSmallNonparabolicFirstTwoRotationOrders, + mem_originalPuncturedFinsetOfNormalized_iff, + mem_normalizedPuncturedMarkoffPointsWithSmallNonparabolicFirstTwoRotationOrders_iff + ] + refine ⟨?_, ?_, ?_, ?_⟩ + · simpa only [normalizedPuncturedPointEulerSevenComplement, + normalizedSurfaceOfPunctured, + puncturedNormalizationEquiv_coe] using Nat.lt_succ_of_le hfirst + · simpa only [normalizedPuncturedPointEulerSevenComplement, + normalizedSurfaceOfPunctured, + puncturedNormalizationEquiv_coe] using Nat.lt_succ_of_le hsecond + · simpa only [normalizedPuncturedPointEulerSevenComplement, + normalizedSurfaceOfPunctured, + puncturedNormalizationEquiv_coe] using hnonparabolic.1 + · simpa only [normalizedPuncturedPointEulerSevenComplement, + normalizedSurfaceOfPunctured, + puncturedNormalizationEquiv_coe] using hnonparabolic.2 + have hfourPLeBad : 4 * p ≤ bad.card := by + apply four_mul_prime_le_puncturedComponentComplementFinset_card + p hpThree c + · simpa [bad] using hbadNonempty + · exact hfour + have heightPLeSmallOrderSquare : + 8 * p ≤ + (d * maximalDivisorCountSum p (d + 1)) ^ 2 := by + calc + 8 * p = 2 * (4 * p) := by ring + _ ≤ 2 * bad.card := Nat.mul_le_mul_left 2 hfourPLeBad + _ ≤ 2 * + (puncturedMarkoffPointsWithSmallNonparabolicFirstTwoRotationOrders + p (d + 1)).card := + Nat.mul_le_mul_left 2 hbadSmall + _ ≤ (d * maximalDivisorCountSum p (d + 1)) ^ 2 := + two_mul_puncturedSmallNonparabolicOrder_succ_card_le_maximalDivisors + hpTwo d + have hcubeCount := hcube d hdPos heightPLeSmallOrderSquare + have hlinearCount := hlinear d hdUpper + have hmaximalCard : + (middleGameMaximalOrders p d).card ≤ + maximalDivisorCountSum p (d + 1) := by + simpa [maximalDivisorCountSum] using + middleGameMaximalOrders_card_le p d + have hcube' : + 189 * (middleGameMaximalOrders p d).card ^ 3 < d := by + apply lt_of_le_of_lt _ hcubeCount + gcongr + have hlinearCoefficient : + 24 * (middleGameMaximalOrders p d).card ≤ + 24 * maximalDivisorCountSum p (d + 1) := + Nat.mul_le_mul_left 24 hmaximalCard + have hlinear' : + 24 * (middleGameMaximalOrders p d).card * d < p := + (Nat.mul_le_mul_right d hlinearCoefficient).trans_lt hlinearCount + obtain ⟨y, hzy, hincrease⟩ := + exists_sameNormalizedComponent_maximalOrder_increase_of_eulerSevenPairedMaximalDivisorBounds + p hpTwo (delta := (1 / 3 : ℝ)) (by norm_num) + (normalizedPuncturedPointEulerSevenComplement z) + (by simpa only [show (1 / 2 + 1 / 3 : ℝ) = 5 / 6 by norm_num, + d, orderMeasure] using hdUpper) + (by simpa [d, orderMeasure] using hcube') + (by simpa [d, orderMeasure] using hlinear') + obtain ⟨g, hg⟩ := + (sameNormalizedComponent_iff_exists_gamma + (normalizedPuncturedPointEulerSevenComplement z) y).1 hzy + let w : PuncturedMarkoffSurface (ZMod p) := g • z + have hzw : SamePuncturedComponent z w := + (samePuncturedComponent_iff_exists z w).2 ⟨g, rfl⟩ + have hwBad : w ∈ bad := by + rw [show bad = puncturedComponentComplementFinset p c by rfl, + mem_puncturedComponentComplementFinset_iff] + intro hcw + apply hzNotComponent + exact samePuncturedComponent_trans hcw + (samePuncturedComponent_symm hzw) + have hwNormalized : + normalizedPuncturedPointEulerSevenComplement w = y := by + change normalizedPuncturedPointEulerSevenComplement (g • z) = y + rw [normalizedPuncturedPointEulerSevenComplement_smul] + exact hg + have hwMax := hmax w hwBad + change maximalCoordinateRotationOrder + (normalizedPuncturedPointEulerSevenComplement w).1 ≤ d at hwMax + rw [hwNormalized] at hwMax + have hincrease' : d < maximalCoordinateRotationOrder y.1 := by + simpa [d, orderMeasure] using hincrease + exact (not_lt_of_ge hwMax) hincrease' + intro a b + obtain ⟨ga, hga⟩ := + (samePuncturedComponent_iff_exists c a).1 (hAll a) + obtain ⟨gb, hgb⟩ := + (samePuncturedComponent_iff_exists c b).1 (hAll b) + refine ⟨gb * ga⁻¹, ?_⟩ + calc + (gb * ga⁻¹) • a = gb • (ga⁻¹ • a) := mul_smul _ _ _ + _ = gb • c := by rw [← hga]; simp + _ = b := hgb + +end + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Assembly/EulerSevenPairedMaximalDivisorMiddleGame.lean b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/EulerSevenPairedMaximalDivisorMiddleGame.lean new file mode 100644 index 0000000000..9d4d43441c --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/EulerSevenPairedMaximalDivisorMiddleGame.lean @@ -0,0 +1,141 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.MiddleGameThenEndgame +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.EulerSevenPairedMaximalDivisorCorvajaZannierEscape + +/-! +# Euler-seven paired maximal-divisor middle-game assembly + +This lifts the exact `189 * K^3 < d` paired escape from a chosen coordinate +to the maximum of the three coordinate rotation orders. +-/ + +@[expose] public section + +namespace BGS.Markoff + +open BGS.NumberTheory + +noncomputable section + +/-- One exact Euler-seven paired middle-game step strictly increases the +maximum coordinate order. -/ +theorem + exists_sameNormalizedComponent_maximalOrder_increase_of_eulerSevenPairedMaximalDivisorBounds + (p : ℕ) [Fact p.Prime] [Invertible (3 : ZMod p)] + [Fintype (quadraticFiniteField p)] (hpTwo : p ≠ 2) + {delta : ℝ} (hdelta : delta ≤ (1 : ℝ) / 2) + (x : NormalizedMarkoffSurface (ZMod p)) + (hbelow : (maximalCoordinateRotationOrder x.1 : ℝ) < + (p : ℝ) ^ ((1 : ℝ) / 2 + delta)) + (hcube : + 189 * + (middleGameMaximalOrders p + (maximalCoordinateRotationOrder x.1)).card ^ 3 < + maximalCoordinateRotationOrder x.1) + (hlinear : + 24 * + (middleGameMaximalOrders p + (maximalCoordinateRotationOrder x.1)).card * + maximalCoordinateRotationOrder x.1 < p) : + ∃ y : NormalizedMarkoffSurface (ZMod p), + SameNormalizedComponent x y ∧ + maximalCoordinateRotationOrder x.1 < + maximalCoordinateRotationOrder y.1 := by + obtain ⟨x', hxx', hx'Order⟩ := + exists_sameNormalizedComponent_firstRotation_eq_maximal x + have hx'Cube : + 189 * + (middleGameMaximalOrders p (rotationOrder x'.1.u1)).card ^ 3 < + rotationOrder x'.1.u1 := by + simpa [hx'Order] using hcube + have hx'Linear : + 24 * (middleGameMaximalOrders p (rotationOrder x'.1.u1)).card * + rotationOrder x'.1.u1 < p := by + simpa [hx'Order] using hlinear + have hordersPos : + 0 < (middleGameMaximalOrders p (rotationOrder x'.1.u1)).card := by + apply Finset.card_pos.mpr + have hpPlus : p + 1 ≠ 0 := by omega + have honeBound : 1 < rotationOrder x'.1.u1 + 1 := by + exact Nat.lt_succ_of_le (rotationOrder_pos x'.1.u1) + obtain ⟨m, hm, _hmultiple⟩ := + exists_dvd_maximalDivisorBelow hpPlus (one_dvd (p + 1)) honeBound + refine ⟨m, ?_⟩ + rw [middleGameMaximalOrders, Finset.mem_union] + exact Or.inr hm + have hbase : + 4 < + 189 * + (middleGameMaximalOrders p + (rotationOrder x'.1.u1)).card ^ 3 := by + have hcubePos : + 0 < + (middleGameMaximalOrders p + (rotationOrder x'.1.u1)).card ^ 3 := + pow_pos hordersPos 3 + nlinarith + have hx'AboveFour : 4 < rotationOrder x'.1.u1 := + hbase.trans hx'Cube + have hx'Below : (rotationOrder x'.1.u1 : ℝ) < + (p : ℝ) ^ ((1 : ℝ) / 2 + delta) := by + simpa [hx'Order] using hbelow + have hx'0 : x'.1.u1 ≠ 0 := by + intro hzero + have hle := rotationOrder_zero_le_four p + rw [hzero] at hx'AboveFour + omega + have hx'Nonparabolic : x'.1.u1 ^ 2 ≠ 4 := by + intro hparabolic + have hcases : x'.1.u1 = 2 ∨ x'.1.u1 = -2 := by + apply (sq_eq_sq_iff_eq_or_eq_neg).mp + calc + x'.1.u1 ^ 2 = 4 := hparabolic + _ = (2 : ZMod p) ^ 2 := by norm_num + have hpOne : (1 : ℝ) ≤ p := by + exact_mod_cast + (show 1 ≤ p by exact (Fact.out : p.Prime).one_le) + have hexponentLe : (1 : ℝ) / 2 + delta ≤ 1 := by + linarith + have hrpowLe : + (p : ℝ) ^ ((1 : ℝ) / 2 + delta) ≤ (p : ℝ) := by + simpa using Real.rpow_le_rpow_of_exponent_le hpOne hexponentLe + rcases hcases with htwo | hnegTwo + · rw [htwo, rotationOrder_two] at hx'Below + linarith + · rw [hnegTwo, rotationOrder_neg_two p hpTwo] at hx'Below + have htwoP : ((2 * p : ℕ) : ℝ) = 2 * (p : ℝ) := by norm_num + rw [htwoP] at hx'Below + have hpPos : (0 : ℝ) < p := by positivity + linarith + obtain ⟨n, hnIncrease⟩ := + exists_iterate_with_larger_secondRotationOrder_of_nonzero_nonparabolic_eulerSevenPairedMaximalOrders + p hpTwo delta hdelta x'.1 x'.property hx'0 hx'Nonparabolic + hx'Below hx'Cube hx'Linear + let y := (normalizedRotate1Surface^[n]) x' + have hcoe : y.1 = (normalizedRotate1^[n]) x'.1 := + coe_iterate_normalizedRotate1Surface x' n + refine ⟨y, sameNormalizedComponent_trans hxx' + (sameNormalizedComponent_iterate_normalizedRotate1Surface x' n), ?_⟩ + rw [← hx'Order] + exact hnIncrease.trans_le <| by + have hmeasureEq : maximalCoordinateRotationOrder y.1 = + maximalCoordinateRotationOrder + ((normalizedRotate1^[n]) x'.1) := + congrArg maximalCoordinateRotationOrder hcoe + calc + rotationOrder ((normalizedRotate1^[n]) x'.1).u2 ≤ + maximalCoordinateRotationOrder + ((normalizedRotate1^[n]) x'.1) := + rotationOrder_second_le_maximalCoordinateRotationOrder _ + _ = maximalCoordinateRotationOrder y.1 := hmeasureEq.symm + +end + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Assembly/EulerSevenSplitCageCoarseLinearTail.lean b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/EulerSevenSplitCageCoarseLinearTail.lean new file mode 100644 index 0000000000..63c7b29eb9 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/EulerSevenSplitCageCoarseLinearTail.lean @@ -0,0 +1,97 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.CoarseLinearTail +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.EulerSevenSplitCageSquareEnvelopeSurjectivity + +/-! +# Euler-seven split-cage frontier with automatic linear tail + +Above `24^15 * 2^687`, the tenth-moment estimate discharges the full linear +middle-game family. Only the square-envelope cube obstruction remains. +-/ + +@[expose] public section + +namespace BGS.Markoff + +open BGS.NumberTheory + +/-- Split-cage transitivity with no separate linear-table hypothesis. -/ +theorem + puncturedMarkoffTransitiveAt_of_splitCage_eulerSevenSquareEnvelope_coarseLinearTail + (p : ℕ) [Fact p.Prime] [Invertible (3 : ZMod p)] + (hpSeven : 7 ≤ p) + (hpLinearTail : 24 ^ 15 * 2 ^ 687 < p) + (c : PuncturedMarkoffSurface (ZMod p)) + (hbase : IsInSplitCage p + (normalizedSurfaceOfPunctured + (puncturedNormalizationEquiv (ZMod p) c))) + (hhalfThreshold : + (p : ℝ) ^ (5 / 6 : ℝ) ≤ (((p - 1) / 2 : ℕ) : ℝ)) + (squareEnvelope : ℕ → ℕ) + (hsquare : ∀ d : ℕ, + maximalDivisorCountSum p (d + 1) ^ 2 ≤ squareEnvelope d) + (hglobal : ∀ d : ℕ, + 35721 * squareEnvelope d ^ 4 < 8 * p) + (hlarge : ∀ z : NormalizedMarkoffSurface (ZMod p), + (p : ℝ) ^ (5 / 6 : ℝ) ≤ + maximalCoordinateRotationOrder z.1 → + SameNormalizedComponent + (normalizedSurfaceOfPunctured + (puncturedNormalizationEquiv (ZMod p) c)) z) : + PuncturedMarkoffTransitiveAt p Fact.out := by + apply + puncturedMarkoffTransitiveAt_of_splitCage_nonparabolicComplement_eulerSevenPairedMaximalDivisor_frontier + p hpSeven c hbase hhalfThreshold + · intro d _hd hcount + by_contra hnot + have hdegree : + d ≤ 189 * maximalDivisorCountSum p (d + 1) ^ 3 := + Nat.le_of_not_gt hnot + have hbad : + 8 * p ≤ 35721 * squareEnvelope d ^ 4 := + eight_mul_le_35721_mul_fourth_of_count_degree_squareEnvelope + hcount hdegree (hsquare d) + exact (Nat.not_le_of_lt (hglobal d)) hbad + · intro d hd + exact maximalDivisorCountSum_linear_lt_of_coarseBound hpLinearTail hd + · exact hlarge + +/-- Natural Markoff reduction surjectivity with the same automatic linear +tail and no separate linear-table hypothesis. -/ +theorem + markoffReduction_surjective_of_splitCage_eulerSevenSquareEnvelope_coarseLinearTail + (p : ℕ) [Fact p.Prime] [Invertible (3 : ZMod p)] + (hpSeven : 7 ≤ p) + (hpLinearTail : 24 ^ 15 * 2 ^ 687 < p) + (c : PuncturedMarkoffSurface (ZMod p)) + (hbase : IsInSplitCage p + (normalizedSurfaceOfPunctured + (puncturedNormalizationEquiv (ZMod p) c))) + (hhalfThreshold : + (p : ℝ) ^ (5 / 6 : ℝ) ≤ (((p - 1) / 2 : ℕ) : ℝ)) + (squareEnvelope : ℕ → ℕ) + (hsquare : ∀ d : ℕ, + maximalDivisorCountSum p (d + 1) ^ 2 ≤ squareEnvelope d) + (hglobal : ∀ d : ℕ, + 35721 * squareEnvelope d ^ 4 < 8 * p) + (hlarge : ∀ z : NormalizedMarkoffSurface (ZMod p), + (p : ℝ) ^ (5 / 6 : ℝ) ≤ + maximalCoordinateRotationOrder z.1 → + SameNormalizedComponent + (normalizedSurfaceOfPunctured + (puncturedNormalizationEquiv (ZMod p) c)) z) : + Function.Surjective (markoffReduction p) := + (puncturedMarkoffTransitiveAt_iff_markoffReduction_surjective + p Fact.out).mp + (puncturedMarkoffTransitiveAt_of_splitCage_eulerSevenSquareEnvelope_coarseLinearTail + p hpSeven hpLinearTail c hbase hhalfThreshold + squareEnvelope hsquare hglobal hlarge) + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Assembly/EulerSevenSplitCageNonparabolicComplementFrontier.lean b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/EulerSevenSplitCageNonparabolicComplementFrontier.lean new file mode 100644 index 0000000000..dc3f1892f8 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/EulerSevenSplitCageNonparabolicComplementFrontier.lean @@ -0,0 +1,70 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.SplitCageNonparabolicComplementFrontier +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.EulerSevenNonparabolicComplementFrontier + +/-! +# Split-cage Euler-seven nonparabolic complement frontier + +The split-cage base discharges the even-sign inputs, while the middle game +uses the exact paired coefficient `189`. +-/ + +@[expose] public section + +namespace BGS.Markoff + +open BGS.NumberTheory + +/-- Exact Euler-seven nonparabolic complement frontier with the even-sign +invariance and factor-four hypotheses discharged by a split-cage base. -/ +theorem + puncturedMarkoffTransitiveAt_of_splitCage_nonparabolicComplement_eulerSevenPairedMaximalDivisor_frontier + (p : ℕ) [Fact p.Prime] [Invertible (3 : ZMod p)] + (hpSeven : 7 ≤ p) + (c : PuncturedMarkoffSurface (ZMod p)) + (hbase : IsInSplitCage p + (normalizedSurfaceOfPunctured + (puncturedNormalizationEquiv (ZMod p) c))) + (hhalfThreshold : + (p : ℝ) ^ (5 / 6 : ℝ) ≤ (((p - 1) / 2 : ℕ) : ℝ)) + (hcube : ∀ d : ℕ, 0 < d → + 8 * p ≤ + (d * maximalDivisorCountSum p (d + 1)) ^ 2 → + 189 * maximalDivisorCountSum p (d + 1) ^ 3 < d) + (hlinear : ∀ d : ℕ, + (d : ℝ) < (p : ℝ) ^ (5 / 6 : ℝ) → + 24 * maximalDivisorCountSum p (d + 1) * d < p) + (hlarge : ∀ z : NormalizedMarkoffSurface (ZMod p), + (p : ℝ) ^ (5 / 6 : ℝ) ≤ + maximalCoordinateRotationOrder z.1 → + SameNormalizedComponent + (normalizedSurfaceOfPunctured + (puncturedNormalizationEquiv (ZMod p) c)) z) : + PuncturedMarkoffTransitiveAt p Fact.out := by + have hbaseSign : + ∀ s : EvenSign, SamePuncturedComponent c (s • c) := + samePuncturedComponent_evenSign_smul_of_splitCageBase + p hpSeven c hbase hhalfThreshold hlarge + have hsign : + ∀ (s : EvenSign) (x : PuncturedMarkoffSurface (ZMod p)), + s • x ∈ puncturedComponentComplementFinset p c ↔ + x ∈ puncturedComponentComplementFinset p c := + fun s x => + puncturedComponentComplementFinset_evenSign_mem_iff_of_base_stable + p c x hbaseSign s + have hfour : + 4 ∣ (puncturedComponentComplementFinset p c).card := + four_dvd_puncturedComponentComplementFinset_card_of_base_sign_stable + p (by omega) c hbaseSign + exact + puncturedMarkoffTransitiveAt_of_nonparabolicComplement_eulerSevenPairedMaximalDivisor_frontier + p (by omega) c hcube hlinear hlarge hsign hfour + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Assembly/EulerSevenSplitCageSquareEnvelopeFrontier.lean b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/EulerSevenSplitCageSquareEnvelopeFrontier.lean new file mode 100644 index 0000000000..b3fa33f2ed --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/EulerSevenSplitCageSquareEnvelopeFrontier.lean @@ -0,0 +1,87 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.EulerSevenSplitCageNonparabolicComplementFrontier +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.JointMaximalDivisorFrontier +public import LeanPool.MarkoffModP.BGS.NumberTheory.NonparabolicComplementCriterion + +/-! +# Root-free Euler-seven split-cage square-envelope frontier + +For `M = maximalDivisorCountSum p (d + 1)`, a certificate `M^2 ≤ S` +reduces the exact Euler-seven cube branch to + +`35721 * S^4 < 8 * p`, + +because `35721 = 189^2`. The linear branch is independently reduced to + +`24^2 * S * d^2 < p^2`. +-/ + +@[expose] public section + +namespace BGS.Markoff + +open BGS.NumberTheory + +noncomputable section + +/-- The exact Euler-seven split-cage endpoint in root-free square-envelope +form. The split-cage base, half-threshold comparison, and large-order orbit +bridge remain explicit inputs. -/ +theorem + puncturedMarkoffTransitiveAt_of_splitCage_eulerSevenSquareEnvelope_frontier + (p : ℕ) [Fact p.Prime] [Invertible (3 : ZMod p)] + (hpSeven : 7 ≤ p) + (c : PuncturedMarkoffSurface (ZMod p)) + (hbase : IsInSplitCage p + (normalizedSurfaceOfPunctured + (puncturedNormalizationEquiv (ZMod p) c))) + (hhalfThreshold : + (p : ℝ) ^ (5 / 6 : ℝ) ≤ (((p - 1) / 2 : ℕ) : ℝ)) + (squareEnvelope : ℕ → ℕ) + (hsquare : ∀ d : ℕ, + maximalDivisorCountSum p (d + 1) ^ 2 ≤ squareEnvelope d) + (hglobal : ∀ d : ℕ, + 35721 * squareEnvelope d ^ 4 < 8 * p) + (hlinear : ∀ d : ℕ, + (d : ℝ) < (p : ℝ) ^ (5 / 6 : ℝ) → + 24 ^ 2 * squareEnvelope d * d ^ 2 < p ^ 2) + (hlarge : ∀ z : NormalizedMarkoffSurface (ZMod p), + (p : ℝ) ^ (5 / 6 : ℝ) ≤ + maximalCoordinateRotationOrder z.1 → + SameNormalizedComponent + (normalizedSurfaceOfPunctured + (puncturedNormalizationEquiv (ZMod p) c)) z) : + PuncturedMarkoffTransitiveAt p Fact.out := by + apply + puncturedMarkoffTransitiveAt_of_splitCage_nonparabolicComplement_eulerSevenPairedMaximalDivisor_frontier + p hpSeven c hbase hhalfThreshold + · intro d _hd hcount + by_contra hnot + have hdegree : + d ≤ 189 * maximalDivisorCountSum p (d + 1) ^ 3 := + Nat.le_of_not_gt hnot + have hbad : + 8 * p ≤ 35721 * squareEnvelope d ^ 4 := + eight_mul_le_35721_mul_fourth_of_count_degree_squareEnvelope + hcount hdegree (hsquare d) + exact (Nat.not_le_of_lt (hglobal d)) hbad + · intro d hd + exact + coefficient_mul_count_mul_order_lt_of_squareEnvelope + (coefficient := 24) + (count := maximalDivisorCountSum p (d + 1)) + (envelope := squareEnvelope d) + (order := d) (p := p) + (hsquare d) (hlinear d hd) + · exact hlarge + +end + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Assembly/EulerSevenSplitCageSquareEnvelopeSurjectivity.lean b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/EulerSevenSplitCageSquareEnvelopeSurjectivity.lean new file mode 100644 index 0000000000..49ccd6497f --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/EulerSevenSplitCageSquareEnvelopeSurjectivity.lean @@ -0,0 +1,58 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.EulerSevenSplitCageSquareEnvelopeFrontier +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.TransitivitySurjectivity + +/-! +# Euler-seven square-envelope reduction surjectivity + +This separate façade converts the exact split-cage transitivity endpoint to +surjectivity of natural Markoff reduction using the canonical equivalence. +-/ + +@[expose] public section + +namespace BGS.Markoff + +open BGS.NumberTheory + +/-- Natural Markoff reduction is surjective under the exact Euler-seven +split-cage square-envelope hypotheses. -/ +theorem + markoffReduction_surjective_of_splitCage_eulerSevenSquareEnvelope_frontier + (p : ℕ) [Fact p.Prime] [Invertible (3 : ZMod p)] + (hpSeven : 7 ≤ p) + (c : PuncturedMarkoffSurface (ZMod p)) + (hbase : IsInSplitCage p + (normalizedSurfaceOfPunctured + (puncturedNormalizationEquiv (ZMod p) c))) + (hhalfThreshold : + (p : ℝ) ^ (5 / 6 : ℝ) ≤ (((p - 1) / 2 : ℕ) : ℝ)) + (squareEnvelope : ℕ → ℕ) + (hsquare : ∀ d : ℕ, + maximalDivisorCountSum p (d + 1) ^ 2 ≤ squareEnvelope d) + (hglobal : ∀ d : ℕ, + 35721 * squareEnvelope d ^ 4 < 8 * p) + (hlinear : ∀ d : ℕ, + (d : ℝ) < (p : ℝ) ^ (5 / 6 : ℝ) → + 24 ^ 2 * squareEnvelope d * d ^ 2 < p ^ 2) + (hlarge : ∀ z : NormalizedMarkoffSurface (ZMod p), + (p : ℝ) ^ (5 / 6 : ℝ) ≤ + maximalCoordinateRotationOrder z.1 → + SameNormalizedComponent + (normalizedSurfaceOfPunctured + (puncturedNormalizationEquiv (ZMod p) c)) z) : + Function.Surjective (markoffReduction p) := + (puncturedMarkoffTransitiveAt_iff_markoffReduction_surjective + p Fact.out).mp + (puncturedMarkoffTransitiveAt_of_splitCage_eulerSevenSquareEnvelope_frontier + p hpSeven c hbase hhalfThreshold squareEnvelope + hsquare hglobal hlinear hlarge) + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Assembly/EvenSignBaseStableComplement.lean b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/EvenSignBaseStableComplement.lean new file mode 100644 index 0000000000..421715fa6d --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/EvenSignBaseStableComplement.lean @@ -0,0 +1,90 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.EvenSignComplementDivisibility + +/-! +# From base sign-stability to complement divisibility + +Because `Gamma` normalizes the even-sign subgroup, it is enough to connect the +four sign changes of one base point back to that base component. Every even +sign change then preserves the whole component and its finite complement. +-/ + +@[expose] public section + +namespace BGS.Markoff + +/-- If all even-sign changes of the base point lie in its `Gamma` component, +then every even sign preserves membership in that component. -/ +theorem samePuncturedComponent_evenSign_smul_iff_of_base_stable + {R : Type*} [CommRing R] + (c x : PuncturedMarkoffSurface R) + (hbase : ∀ s : EvenSign, SamePuncturedComponent c (s • c)) + (s : EvenSign) : + SamePuncturedComponent c (s • x) ↔ + SamePuncturedComponent c x := by + have hforward : + ∀ (t : EvenSign) (y : PuncturedMarkoffSurface R), + SamePuncturedComponent c y → + SamePuncturedComponent c (t • y) := by + intro t y hy + obtain ⟨g, hgy⟩ := (samePuncturedComponent_iff_exists c y).1 hy + obtain ⟨u, hcommute⟩ := exists_evenSign_smul_Gamma_smul t g + have hbaseU := hbase u + have hmove : + SamePuncturedComponent (u • c) (g • (u • c)) := + (samePuncturedComponent_iff_exists (u • c) (g • (u • c))).2 + ⟨g, rfl⟩ + have htarget : + SamePuncturedComponent c (g • (u • c)) := + samePuncturedComponent_trans hbaseU hmove + have heq : t • y = g • (u • c) := by + calc + t • y = t • (g • c) := congrArg (t • ·) hgy.symm + _ = g • (u • c) := hcommute c + rw [heq] + exact htarget + constructor + · intro hsx + have hback := hforward s⁻¹ (s • x) hsx + rw [inv_smul_smul] at hback + exact hback + · exact hforward s x + +/-- Base sign-stability makes the finite component complement invariant under +every even sign. -/ +theorem puncturedComponentComplementFinset_evenSign_mem_iff_of_base_stable + (p : ℕ) [Fact p.Prime] + (c x : PuncturedMarkoffSurface (ZMod p)) + (hbase : ∀ s : EvenSign, SamePuncturedComponent c (s • c)) + (s : EvenSign) : + s • x ∈ puncturedComponentComplementFinset p c ↔ + x ∈ puncturedComponentComplementFinset p c := by + rw [mem_puncturedComponentComplementFinset_iff, + mem_puncturedComponentComplementFinset_iff] + exact not_congr + (samePuncturedComponent_evenSign_smul_iff_of_base_stable c x hbase s) + +/-- The expected factor four in the complement size follows from the sole +geometric input that the four sign changes of the base point return to its +`Gamma` component. -/ +theorem four_dvd_puncturedComponentComplementFinset_card_of_base_sign_stable + (p : ℕ) [Fact p.Prime] (hpThree : 3 < p) + (c : PuncturedMarkoffSurface (ZMod p)) + (hbase : ∀ s : EvenSign, SamePuncturedComponent c (s • c)) : + 4 ∣ (puncturedComponentComplementFinset p c).card := by + apply + four_dvd_puncturedComponentComplementFinset_card_of_evenSign_invariant + p hpThree c + intro s x + exact + puncturedComponentComplementFinset_evenSign_mem_iff_of_base_stable + p c x hbase s + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Assembly/EvenSignComplementDivisibility.lean b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/EvenSignComplementDivisibility.lean new file mode 100644 index 0000000000..e927c74312 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/EvenSignComplementDivisibility.lean @@ -0,0 +1,42 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.EvenSignOrbitDivisibility +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.NonparabolicComplementFrontier + +/-! +# Even-sign divisibility for component complements + +This file specializes the free even-sign action to the finite complement used +by the nonparabolic complement frontier. +-/ + +@[expose] public section + +namespace BGS.Markoff + +/-- An even-sign-invariant component complement has cardinality divisible by +four. The hypothesis is stated in the same form as the complement frontier's +`hsign` input. -/ +theorem four_dvd_puncturedComponentComplementFinset_card_of_evenSign_invariant + (p : ℕ) [Fact p.Prime] (hpThree : 3 < p) + (c : PuncturedMarkoffSurface (ZMod p)) + (hsign : ∀ (s : EvenSign) + (x : PuncturedMarkoffSurface (ZMod p)), + s • x ∈ puncturedComponentComplementFinset p c ↔ + x ∈ puncturedComponentComplementFinset p c) : + 4 ∣ (puncturedComponentComplementFinset p c).card := by + have htwo : (2 : ZMod p) ≠ 0 := by + intro hzero + have hpDvd : p ∣ 2 := (ZMod.natCast_eq_zero_iff 2 p).mp hzero + exact (Nat.not_dvd_of_pos_of_lt (by omega) (by omega)) hpDvd + exact four_dvd_finset_card_of_evenSign_invariant htwo + (puncturedComponentComplementFinset p c) + (fun s x hx => (hsign s x).2 hx) + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Assembly/EvenSignOrbitDivisibility.lean b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/EvenSignOrbitDivisibility.lean new file mode 100644 index 0000000000..be20918f5d --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/EvenSignOrbitDivisibility.lean @@ -0,0 +1,259 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Core.EvenSignAction + +/-! +# Divisibility from the free even-sign action + +For odd characteristic, the Klein four-group of even sign changes acts freely +on the punctured Markoff surface. Consequently every finite sign-invariant set +is a disjoint union of four-element sign orbits. +-/ + +@[expose] public section + +namespace BGS.Markoff + +noncomputable section + +private theorem eq_zero_of_neg_eq + {F : Type*} [Field F] (htwo : (2 : F) ≠ 0) + {a : F} (ha : -a = a) : + a = 0 := by + have hmul : (2 : F) * a = 0 := by + rw [two_mul] + calc + a + a = -a + a := congrArg (fun z => z + a) ha.symm + _ = 0 := neg_add_cancel a + exact (mul_eq_zero.mp hmul).resolve_left htwo + +/-- In characteristic different from two, no nontrivial even sign change +fixes a punctured Markoff point. -/ +theorem evenSign_eq_one_of_smul_eq + {F : Type*} [Field F] (htwo : (2 : F) ≠ 0) + (s : EvenSign) (x : PuncturedMarkoffSurface F) + (hfixed : s • x = x) : + s = 1 := by + have fixedPoint : + evenSignPoint s x.1.1 = x.1.1 := by + exact congrArg (fun y : PuncturedMarkoffSurface F => y.1.1) hfixed + cases s with + | id => + rfl + | neg12 => + have hfirst : x.1.1.x1 = 0 := + eq_zero_of_neg_eq htwo (congrArg Point.x1 fixedPoint) + have hsecond : x.1.1.x2 = 0 := + eq_zero_of_neg_eq htwo (congrArg Point.x2 fixedPoint) + have hthird : x.1.1.x3 = 0 := by + have hmarkoff := x.1.2 + simp [IsMarkoff, markoffPolynomial, hfirst, hsecond] at hmarkoff + exact hmarkoff + exfalso + apply x.2 + apply Subtype.ext + ext <;> simp [surfaceOrigin, origin, hfirst, hsecond, hthird] + | neg13 => + have hfirst : x.1.1.x1 = 0 := + eq_zero_of_neg_eq htwo (congrArg Point.x1 fixedPoint) + have hthird : x.1.1.x3 = 0 := + eq_zero_of_neg_eq htwo (congrArg Point.x3 fixedPoint) + have hsecond : x.1.1.x2 = 0 := by + have hmarkoff := x.1.2 + simp [IsMarkoff, markoffPolynomial, hfirst, hthird] at hmarkoff + exact hmarkoff + exfalso + apply x.2 + apply Subtype.ext + ext <;> simp [surfaceOrigin, origin, hfirst, hsecond, hthird] + | neg23 => + have hsecond : x.1.1.x2 = 0 := + eq_zero_of_neg_eq htwo (congrArg Point.x2 fixedPoint) + have hthird : x.1.1.x3 = 0 := + eq_zero_of_neg_eq htwo (congrArg Point.x3 fixedPoint) + have hfirst : x.1.1.x1 = 0 := by + have hmarkoff := x.1.2 + simp [IsMarkoff, markoffPolynomial, hsecond, hthird] at hmarkoff + exact hmarkoff + exfalso + apply x.2 + apply Subtype.ext + ext <;> simp [surfaceOrigin, origin, hfirst, hsecond, hthird] + +/-- The even-sign action on the punctured Markoff surface is free in +characteristic different from two. -/ +theorem evenSign_isCancelSMul_punctured + {F : Type*} [Field F] (htwo : (2 : F) ≠ 0) : + IsCancelSMul EvenSign (PuncturedMarkoffSurface F) := by + rw [isCancelSMul_iff_eq_one_of_smul_eq] + exact fun s x hfixed => evenSign_eq_one_of_smul_eq htwo s x hfixed + +/-- The four-point orbit of a punctured point under even sign changes. -/ +def evenSignOrbitFinset + {R : Type*} [CommRing R] (x : PuncturedMarkoffSurface R) : + Finset (PuncturedMarkoffSurface R) := by + classical + exact Finset.univ.image fun s : EvenSign => s • x + +@[simp] +theorem mem_evenSignOrbitFinset_iff + {R : Type*} [CommRing R] {x y : PuncturedMarkoffSurface R} : + y ∈ evenSignOrbitFinset x ↔ ∃ s : EvenSign, s • x = y := by + classical + simp [evenSignOrbitFinset] + +theorem evenSignOrbitFinset_eq_of_mem + {R : Type*} [CommRing R] {x y : PuncturedMarkoffSurface R} + (hy : y ∈ evenSignOrbitFinset x) : + evenSignOrbitFinset y = evenSignOrbitFinset x := by + classical + obtain ⟨s, hs⟩ := mem_evenSignOrbitFinset_iff.mp hy + ext z + constructor + · intro hz + obtain ⟨t, ht⟩ := mem_evenSignOrbitFinset_iff.mp hz + apply mem_evenSignOrbitFinset_iff.mpr + refine ⟨t * s, ?_⟩ + calc + (t * s) • x = t • (s • x) := mul_smul t s x + _ = t • y := congrArg (t • ·) hs + _ = z := ht + · intro hz + obtain ⟨u, hu⟩ := mem_evenSignOrbitFinset_iff.mp hz + apply mem_evenSignOrbitFinset_iff.mpr + refine ⟨u * s⁻¹, ?_⟩ + calc + (u * s⁻¹) • y = (u * s⁻¹) • (s • x) := + congrArg ((u * s⁻¹) • ·) hs.symm + _ = u • (s⁻¹ • (s • x)) := mul_smul u s⁻¹ (s • x) + _ = u • x := congrArg (u • ·) (inv_smul_smul s x) + _ = z := hu + +theorem evenSignOrbitFinset_card_eq_four + {F : Type*} [Field F] (htwo : (2 : F) ≠ 0) + (x : PuncturedMarkoffSurface F) : + (evenSignOrbitFinset x).card = 4 := by + classical + let : IsCancelSMul EvenSign (PuncturedMarkoffSurface F) := + evenSign_isCancelSMul_punctured htwo + have hinjective : + Function.Injective (fun s : EvenSign => s • x) := by + intro s t hst + exact IsCancelSMul.right_cancel s t x hst + calc + (evenSignOrbitFinset x).card = + (Finset.univ : Finset EvenSign).card := by + exact Finset.card_image_of_injective Finset.univ hinjective + _ = 4 := EvenSign.card_eq_four + +/-- The finite family of distinct even-sign orbits meeting `C`. -/ +def evenSignOrbitPartition + {R : Type*} [CommRing R] + (C : Finset (PuncturedMarkoffSurface R)) : + Finset (Finset (PuncturedMarkoffSurface R)) := by + classical + exact C.image evenSignOrbitFinset + +/-- The union of all even-sign orbits meeting `C`. This wrapper fixes one +classical equality-decider for the nested finite union. -/ +def evenSignOrbitPartitionUnion + {R : Type*} [CommRing R] + (C : Finset (PuncturedMarkoffSurface R)) : + Finset (PuncturedMarkoffSurface R) := by + classical + exact (evenSignOrbitPartition C).biUnion id + +theorem evenSignOrbitPartition_pairwiseDisjoint + {R : Type*} [CommRing R] + (C : Finset (PuncturedMarkoffSurface R)) : + ((evenSignOrbitPartition C : Finset + (Finset (PuncturedMarkoffSurface R))) : Set + (Finset (PuncturedMarkoffSurface R))).PairwiseDisjoint id := by + classical + intro A hA B hB hne + change A ∈ evenSignOrbitPartition C at hA + change B ∈ evenSignOrbitPartition C at hB + rw [evenSignOrbitPartition] at hA hB + obtain ⟨x, _hx, rfl⟩ := Finset.mem_image.mp hA + obtain ⟨y, _hy, rfl⟩ := Finset.mem_image.mp hB + change Disjoint (evenSignOrbitFinset x) (evenSignOrbitFinset y) + rw [Finset.disjoint_left] + intro z hzx hzy + apply hne + calc + evenSignOrbitFinset x = evenSignOrbitFinset z := + (evenSignOrbitFinset_eq_of_mem hzx).symm + _ = evenSignOrbitFinset y := + evenSignOrbitFinset_eq_of_mem hzy + +theorem evenSignOrbitPartitionUnion_eq + {R : Type*} [CommRing R] + (C : Finset (PuncturedMarkoffSurface R)) + (hC : ∀ (s : EvenSign) (x : PuncturedMarkoffSurface R), + x ∈ C → s • x ∈ C) : + evenSignOrbitPartitionUnion C = C := by + classical + rw [evenSignOrbitPartitionUnion] + ext z + constructor + · intro hz + obtain ⟨A, hA, hzA⟩ := Finset.mem_biUnion.mp hz + rw [evenSignOrbitPartition] at hA + obtain ⟨x, hx, rfl⟩ := Finset.mem_image.mp hA + obtain ⟨s, rfl⟩ := mem_evenSignOrbitFinset_iff.mp hzA + exact hC s x hx + · intro hz + apply Finset.mem_biUnion.mpr + refine ⟨evenSignOrbitFinset z, ?_, ?_⟩ + · rw [evenSignOrbitPartition] + exact Finset.mem_image.mpr ⟨z, hz, rfl⟩ + · exact mem_evenSignOrbitFinset_iff.mpr ⟨1, one_smul EvenSign z⟩ + +/-- Any finite set of punctured Markoff points preserved by all even sign +changes has cardinality divisible by four. -/ +theorem four_dvd_finset_card_of_evenSign_invariant + {F : Type*} [Field F] (htwo : (2 : F) ≠ 0) + (C : Finset (PuncturedMarkoffSurface F)) + (hC : ∀ (s : EvenSign) (x : PuncturedMarkoffSurface F), + x ∈ C → s • x ∈ C) : + 4 ∣ C.card := by + classical + let P := evenSignOrbitPartition C + have hpartition : evenSignOrbitPartitionUnion C = C := + evenSignOrbitPartitionUnion_eq C hC + have hdisjoint : + ((P : Finset (Finset (PuncturedMarkoffSurface F))) : Set + (Finset (PuncturedMarkoffSurface F))).PairwiseDisjoint id := + evenSignOrbitPartition_pairwiseDisjoint C + have hunionCard : + (evenSignOrbitPartitionUnion C).card = + ∑ A ∈ P, A.card := by + rw [evenSignOrbitPartitionUnion] + simpa using Finset.card_biUnion hdisjoint + have hcard : + C.card = ∑ A ∈ P, A.card := by + calc + C.card = (evenSignOrbitPartitionUnion C).card := + congrArg Finset.card hpartition.symm + _ = ∑ A ∈ P, A.card := hunionCard + refine ⟨P.card, ?_⟩ + rw [hcard] + calc + ∑ A ∈ P, A.card = ∑ _A ∈ P, 4 := by + apply Finset.sum_congr rfl + intro A hA + change A ∈ evenSignOrbitPartition C at hA + rw [evenSignOrbitPartition] at hA + obtain ⟨x, _hx, rfl⟩ := Finset.mem_image.mp hA + exact evenSignOrbitFinset_card_eq_four htwo x + _ = 4 * P.card := by simp [Nat.mul_comm] + +end + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Assembly/ExactOrderComplementObstruction.lean b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/ExactOrderComplementObstruction.lean new file mode 100644 index 0000000000..4bb5eb1011 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/ExactOrderComplementObstruction.lean @@ -0,0 +1,208 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.ExactOrderPuncturedSmallOrderCount +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.NonparabolicComplementFrontier + +/-! +# Exact-order root obstruction from a nontransitive complement + +With the root-sum convention + +`R = Σ_{e ∣ p-1, 2 + maximalCoordinateRotationOrder + (normalizedPuncturedPointExactOrderComplement w).1 + obtain ⟨z, hzBad, hzMax⟩ := + Finset.exists_max_image bad orderMeasure hbadNonempty + let d := orderMeasure z + have hmax : ∀ w : PuncturedMarkoffSurface (ZMod p), + w ∈ bad → orderMeasure w ≤ d := by + intro w hw + exact hzMax w hw + have hzNotComponent : ¬ SamePuncturedComponent c z := by + simpa [bad] using hzBad + have hdPos : 0 < d := by + have hfirstPos : 0 < + rotationOrder + (normalizedPuncturedPointExactOrderComplement z).1.u1 := + rotationOrder_pos _ + exact hfirstPos.trans_le <| by + simpa [d, orderMeasure] using + rotationOrder_first_le_maximalCoordinateRotationOrder + (normalizedPuncturedPointExactOrderComplement z).1 + have hnotBaseZ : ¬ SameNormalizedComponent + (normalizedPuncturedPointExactOrderComplement c) + (normalizedPuncturedPointExactOrderComplement z) := by + intro hcz + apply hzNotComponent + exact + (samePuncturedComponent_iff_sameNormalizedComponent c z).2 hcz + have hdUpper : (d : ℝ) < (p : ℝ) ^ (5 / 6 : ℝ) := by + by_contra hd + apply hnotBaseZ + apply hlarge (normalizedPuncturedPointExactOrderComplement z) + simpa [d, orderMeasure] using le_of_not_gt hd + have hbadSmall : + bad.card ≤ + (puncturedMarkoffPointsWithSmallNonparabolicFirstTwoRotationOrders + p (d + 1)).card := by + apply Finset.card_le_card + intro w hwBad + have hwNotComponent : ¬ SamePuncturedComponent c w := by + simpa [bad] using hwBad + have hwNotBase : ¬ SameNormalizedComponent + (normalizedPuncturedPointExactOrderComplement c) + (normalizedPuncturedPointExactOrderComplement w) := by + intro hcw + apply hwNotComponent + exact + (samePuncturedComponent_iff_sameNormalizedComponent c w).2 hcw + have hnonparabolic := + first_two_nonparabolic_of_not_sameComponent_of_endgame_large_connected + hpTwo + (normalizedPuncturedPointExactOrderComplement c) + (normalizedPuncturedPointExactOrderComplement w) + hlarge hwNotBase + have hwMax := hmax w hwBad + have hfirst : + rotationOrder + (normalizedPuncturedPointExactOrderComplement w).1.u1 ≤ d := + (rotationOrder_first_le_maximalCoordinateRotationOrder + (normalizedPuncturedPointExactOrderComplement w).1).trans hwMax + have hsecond : + rotationOrder + (normalizedPuncturedPointExactOrderComplement w).1.u2 ≤ d := + (rotationOrder_second_le_maximalCoordinateRotationOrder + (normalizedPuncturedPointExactOrderComplement w).1).trans hwMax + change w ∈ + puncturedMarkoffPointsWithSmallNonparabolicFirstTwoRotationOrders + p (d + 1) + rw [ + puncturedMarkoffPointsWithSmallNonparabolicFirstTwoRotationOrders, + mem_originalPuncturedFinsetOfNormalized_iff, + mem_normalizedPuncturedMarkoffPointsWithSmallNonparabolicFirstTwoRotationOrders_iff + ] + refine ⟨?_, ?_, ?_, ?_⟩ + · simpa only [normalizedPuncturedPointExactOrderComplement, + normalizedSurfaceOfPunctured, + puncturedNormalizationEquiv_coe] using Nat.lt_succ_of_le hfirst + · simpa only [normalizedPuncturedPointExactOrderComplement, + normalizedSurfaceOfPunctured, + puncturedNormalizationEquiv_coe] using Nat.lt_succ_of_le hsecond + · simpa only [normalizedPuncturedPointExactOrderComplement, + normalizedSurfaceOfPunctured, + puncturedNormalizationEquiv_coe] using hnonparabolic.1 + · simpa only [normalizedPuncturedPointExactOrderComplement, + normalizedSurfaceOfPunctured, + puncturedNormalizationEquiv_coe] using hnonparabolic.2 + have hfourPLeBad : 4 * p ≤ bad.card := by + apply four_mul_prime_le_puncturedComponentComplementFinset_card + p hpThree c + · simpa [bad] using hbadNonempty + · exact hfour + have hrootObstruction : + 8 * p ≤ (combinedTruncatedOrderTotientSum p d) ^ 2 := by + calc + 8 * p = 2 * (4 * p) := by ring + _ ≤ 2 * bad.card := Nat.mul_le_mul_left 2 hfourPLeBad + _ ≤ 2 * + (puncturedMarkoffPointsWithSmallNonparabolicFirstTwoRotationOrders + p (d + 1)).card := + Nat.mul_le_mul_left 2 hbadSmall + _ ≤ (combinedTruncatedOrderTotientSum p d) ^ 2 := + two_mul_puncturedSmallNonparabolicOrder_succ_card_le_rootSumSq + hpTwo d + exact ⟨d, hdPos, hdUpper, hrootObstruction⟩ + +/-- Global nontransitivity forces an exact root-sum obstruction below the +large-order endgame threshold. -/ +theorem exists_exactOrderRootSum_obstruction_of_not_puncturedTransitive + (p : ℕ) [Fact p.Prime] [Invertible (3 : ZMod p)] + (hpThree : 3 < p) + (c : PuncturedMarkoffSurface (ZMod p)) + (hlarge : ∀ z : NormalizedMarkoffSurface (ZMod p), + (p : ℝ) ^ (5 / 6 : ℝ) ≤ + maximalCoordinateRotationOrder z.1 → + SameNormalizedComponent + (normalizedSurfaceOfPunctured (puncturedNormalizationEquiv (ZMod p) c)) z) + (hfour : 4 ∣ (puncturedComponentComplementFinset p c).card) + (hnotTransitive : ¬ PuncturedMarkoffTransitiveAt p Fact.out) : + ∃ d : ℕ, + 0 < d ∧ + (d : ℝ) < (p : ℝ) ^ (5 / 6 : ℝ) ∧ + 8 * p ≤ (combinedTruncatedOrderTotientSum p d) ^ 2 := by + have hexists : + ∃ x : PuncturedMarkoffSurface (ZMod p), + ¬ SamePuncturedComponent c x := by + by_contra hnone + have hAll : ∀ x : PuncturedMarkoffSurface (ZMod p), + SamePuncturedComponent c x := by + intro x + by_contra hx + exact hnone ⟨x, hx⟩ + apply hnotTransitive + intro a b + obtain ⟨ga, hga⟩ := + (samePuncturedComponent_iff_exists c a).1 (hAll a) + obtain ⟨gb, hgb⟩ := + (samePuncturedComponent_iff_exists c b).1 (hAll b) + refine ⟨gb * ga⁻¹, ?_⟩ + calc + (gb * ga⁻¹) • a = gb • (ga⁻¹ • a) := mul_smul _ _ _ + _ = gb • c := by rw [← hga]; simp + _ = b := hgb + obtain ⟨x, hx⟩ := hexists + exact + exists_exactOrderRootSum_obstruction_of_not_samePuncturedComponent + p hpThree c x hlarge hfour hx + +end + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Assembly/ExactOrderEulerSevenComplementObstruction.lean b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/ExactOrderEulerSevenComplementObstruction.lean new file mode 100644 index 0000000000..4b5c454068 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/ExactOrderEulerSevenComplementObstruction.lean @@ -0,0 +1,276 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.ExactOrderComplementObstruction +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.EulerSevenPairedMaximalDivisorMiddleGame + +/-! +# Exact-order obstruction with the Euler-seven cap + +The exact-order root budget and the Euler-seven middle-game cap must concern +the same maximal bad rotation order. This file keeps that common witness +visible instead of composing two unrelated existential statements. +-/ + +@[expose] public section + +namespace BGS.Markoff + +noncomputable section + +private def normalizedPuncturedPointExactOrderEulerSeven + {R : Type*} [Field R] [Invertible (3 : R)] + (x : PuncturedMarkoffSurface R) : NormalizedMarkoffSurface R := + normalizedSurfaceOfPunctured (puncturedNormalizationEquiv R x) + +private theorem normalizedPuncturedPointExactOrderEulerSeven_smul + {R : Type*} [Field R] [Invertible (3 : R)] + (g : Gamma R) (z : PuncturedMarkoffSurface R) : + normalizedPuncturedPointExactOrderEulerSeven (g • z) = + normalizedGammaPerm R g + (normalizedPuncturedPointExactOrderEulerSeven z) := by + have hzinv : + (normalizationSurfaceEquiv R).symm + (normalizedSurfaceOfPunctured + (puncturedNormalizationEquiv R z)) = z.1 := by + apply Subtype.ext + exact (normalizationEquiv R).symm_apply_apply z.1.1 + unfold normalizedPuncturedPointExactOrderEulerSeven + rw [normalizedGammaPerm_apply, hzinv] + apply Subtype.ext + rfl + +/-- A point outside the base component gives one order `d` which +simultaneously satisfies the exact root-sum obstruction and the negation of +the strict Euler-seven escape condition. -/ +theorem + exists_exactOrderRootSum_eulerSevenCap_of_not_samePuncturedComponent + (p : ℕ) [Fact p.Prime] [Invertible (3 : ZMod p)] + (hpThree : 3 < p) + (c x : PuncturedMarkoffSurface (ZMod p)) + (hlarge : ∀ z : NormalizedMarkoffSurface (ZMod p), + (p : ℝ) ^ (5 / 6 : ℝ) ≤ + maximalCoordinateRotationOrder z.1 → + SameNormalizedComponent + (normalizedSurfaceOfPunctured (puncturedNormalizationEquiv (ZMod p) c)) z) + (hlinear : ∀ d : ℕ, + (d : ℝ) < (p : ℝ) ^ (5 / 6 : ℝ) → + 24 * (middleGameMaximalOrders p d).card * d < p) + (hfour : 4 ∣ (puncturedComponentComplementFinset p c).card) + (hcx : ¬ SamePuncturedComponent c x) : + ∃ d : ℕ, + 0 < d ∧ + (d : ℝ) < (p : ℝ) ^ (5 / 6 : ℝ) ∧ + 8 * p ≤ (combinedTruncatedOrderTotientSum p d) ^ 2 ∧ + d ≤ 189 * (middleGameMaximalOrders p d).card ^ 3 := by + classical + have hpTwo : p ≠ 2 := by omega + let : Fintype (quadraticFiniteField p) := Fintype.ofFinite _ + let bad := puncturedComponentComplementFinset p c + have hxBad : x ∈ bad := by + simpa [bad] using hcx + have hbadNonempty : bad.Nonempty := ⟨x, hxBad⟩ + let orderMeasure : PuncturedMarkoffSurface (ZMod p) → ℕ := fun w => + maximalCoordinateRotationOrder + (normalizedPuncturedPointExactOrderEulerSeven w).1 + obtain ⟨z, hzBad, hzMax⟩ := + Finset.exists_max_image bad orderMeasure hbadNonempty + let d := orderMeasure z + have hmax : ∀ w : PuncturedMarkoffSurface (ZMod p), + w ∈ bad → orderMeasure w ≤ d := by + intro w hw + exact hzMax w hw + have hzNotComponent : ¬ SamePuncturedComponent c z := by + simpa [bad] using hzBad + have hdPos : 0 < d := by + have hfirstPos : 0 < + rotationOrder + (normalizedPuncturedPointExactOrderEulerSeven z).1.u1 := + rotationOrder_pos _ + exact hfirstPos.trans_le <| by + simpa [d, orderMeasure] using + rotationOrder_first_le_maximalCoordinateRotationOrder + (normalizedPuncturedPointExactOrderEulerSeven z).1 + have hnotBaseZ : ¬ SameNormalizedComponent + (normalizedPuncturedPointExactOrderEulerSeven c) + (normalizedPuncturedPointExactOrderEulerSeven z) := by + intro hcz + apply hzNotComponent + exact + (samePuncturedComponent_iff_sameNormalizedComponent c z).2 hcz + have hdUpper : (d : ℝ) < (p : ℝ) ^ (5 / 6 : ℝ) := by + by_contra hd + apply hnotBaseZ + apply hlarge (normalizedPuncturedPointExactOrderEulerSeven z) + simpa [d, orderMeasure] using le_of_not_gt hd + have hcap : + d ≤ 189 * (middleGameMaximalOrders p d).card ^ 3 := by + by_contra hnotCap + have hcube : + 189 * (middleGameMaximalOrders p d).card ^ 3 < d := + Nat.lt_of_not_ge hnotCap + have hlinearD : + 24 * (middleGameMaximalOrders p d).card * d < p := + hlinear d hdUpper + obtain ⟨y, hzy, hincrease⟩ := + exists_sameNormalizedComponent_maximalOrder_increase_of_eulerSevenPairedMaximalDivisorBounds + p hpTwo (delta := (1 / 3 : ℝ)) (by norm_num) + (normalizedPuncturedPointExactOrderEulerSeven z) + (by + simpa only [ + show (1 / 2 + 1 / 3 : ℝ) = 5 / 6 by norm_num, + d, orderMeasure] using hdUpper) + (by simpa [d, orderMeasure] using hcube) + (by simpa [d, orderMeasure] using hlinearD) + obtain ⟨g, hg⟩ := + (sameNormalizedComponent_iff_exists_gamma + (normalizedPuncturedPointExactOrderEulerSeven z) y).1 hzy + let w : PuncturedMarkoffSurface (ZMod p) := g • z + have hzw : SamePuncturedComponent z w := + (samePuncturedComponent_iff_exists z w).2 ⟨g, rfl⟩ + have hwBad : w ∈ bad := by + rw [show bad = puncturedComponentComplementFinset p c by rfl, + mem_puncturedComponentComplementFinset_iff] + intro hcw + apply hzNotComponent + exact samePuncturedComponent_trans hcw + (samePuncturedComponent_symm hzw) + have hwNormalized : + normalizedPuncturedPointExactOrderEulerSeven w = y := by + change normalizedPuncturedPointExactOrderEulerSeven (g • z) = y + rw [normalizedPuncturedPointExactOrderEulerSeven_smul] + exact hg + have hwMax := hmax w hwBad + change maximalCoordinateRotationOrder + (normalizedPuncturedPointExactOrderEulerSeven w).1 ≤ d at hwMax + rw [hwNormalized] at hwMax + have hincrease' : d < maximalCoordinateRotationOrder y.1 := by + simpa [d, orderMeasure] using hincrease + exact (not_lt_of_ge hwMax) hincrease' + have hbadSmall : + bad.card ≤ + (puncturedMarkoffPointsWithSmallNonparabolicFirstTwoRotationOrders + p (d + 1)).card := by + apply Finset.card_le_card + intro w hwBad + have hwNotComponent : ¬ SamePuncturedComponent c w := by + simpa [bad] using hwBad + have hwNotBase : ¬ SameNormalizedComponent + (normalizedPuncturedPointExactOrderEulerSeven c) + (normalizedPuncturedPointExactOrderEulerSeven w) := by + intro hcw + apply hwNotComponent + exact + (samePuncturedComponent_iff_sameNormalizedComponent c w).2 hcw + have hnonparabolic := + first_two_nonparabolic_of_not_sameComponent_of_endgame_large_connected + hpTwo + (normalizedPuncturedPointExactOrderEulerSeven c) + (normalizedPuncturedPointExactOrderEulerSeven w) + hlarge hwNotBase + have hwMax := hmax w hwBad + have hfirst : + rotationOrder + (normalizedPuncturedPointExactOrderEulerSeven w).1.u1 ≤ d := + (rotationOrder_first_le_maximalCoordinateRotationOrder + (normalizedPuncturedPointExactOrderEulerSeven w).1).trans hwMax + have hsecond : + rotationOrder + (normalizedPuncturedPointExactOrderEulerSeven w).1.u2 ≤ d := + (rotationOrder_second_le_maximalCoordinateRotationOrder + (normalizedPuncturedPointExactOrderEulerSeven w).1).trans hwMax + change w ∈ + puncturedMarkoffPointsWithSmallNonparabolicFirstTwoRotationOrders + p (d + 1) + rw [ + puncturedMarkoffPointsWithSmallNonparabolicFirstTwoRotationOrders, + mem_originalPuncturedFinsetOfNormalized_iff, + mem_normalizedPuncturedMarkoffPointsWithSmallNonparabolicFirstTwoRotationOrders_iff + ] + refine ⟨?_, ?_, ?_, ?_⟩ + · simpa only [normalizedPuncturedPointExactOrderEulerSeven, + normalizedSurfaceOfPunctured, + puncturedNormalizationEquiv_coe] using Nat.lt_succ_of_le hfirst + · simpa only [normalizedPuncturedPointExactOrderEulerSeven, + normalizedSurfaceOfPunctured, + puncturedNormalizationEquiv_coe] using Nat.lt_succ_of_le hsecond + · simpa only [normalizedPuncturedPointExactOrderEulerSeven, + normalizedSurfaceOfPunctured, + puncturedNormalizationEquiv_coe] using hnonparabolic.1 + · simpa only [normalizedPuncturedPointExactOrderEulerSeven, + normalizedSurfaceOfPunctured, + puncturedNormalizationEquiv_coe] using hnonparabolic.2 + have hfourPLeBad : 4 * p ≤ bad.card := by + apply four_mul_prime_le_puncturedComponentComplementFinset_card + p hpThree c + · simpa [bad] using hbadNonempty + · exact hfour + have hrootObstruction : + 8 * p ≤ (combinedTruncatedOrderTotientSum p d) ^ 2 := by + calc + 8 * p = 2 * (4 * p) := by ring + _ ≤ 2 * bad.card := Nat.mul_le_mul_left 2 hfourPLeBad + _ ≤ 2 * + (puncturedMarkoffPointsWithSmallNonparabolicFirstTwoRotationOrders + p (d + 1)).card := + Nat.mul_le_mul_left 2 hbadSmall + _ ≤ (combinedTruncatedOrderTotientSum p d) ^ 2 := + two_mul_puncturedSmallNonparabolicOrder_succ_card_le_rootSumSq + hpTwo d + exact ⟨d, hdPos, hdUpper, hrootObstruction, hcap⟩ + +/-- Global nontransitivity forces one common exact-order/Euler-seven witness, +not two independently chosen orders. -/ +theorem + exists_exactOrderRootSum_eulerSevenCap_of_not_puncturedTransitive + (p : ℕ) [Fact p.Prime] [Invertible (3 : ZMod p)] + (hpThree : 3 < p) + (c : PuncturedMarkoffSurface (ZMod p)) + (hlarge : ∀ z : NormalizedMarkoffSurface (ZMod p), + (p : ℝ) ^ (5 / 6 : ℝ) ≤ + maximalCoordinateRotationOrder z.1 → + SameNormalizedComponent + (normalizedSurfaceOfPunctured (puncturedNormalizationEquiv (ZMod p) c)) z) + (hlinear : ∀ d : ℕ, + (d : ℝ) < (p : ℝ) ^ (5 / 6 : ℝ) → + 24 * (middleGameMaximalOrders p d).card * d < p) + (hfour : 4 ∣ (puncturedComponentComplementFinset p c).card) + (hnotTransitive : ¬ PuncturedMarkoffTransitiveAt p Fact.out) : + ∃ d : ℕ, + 0 < d ∧ + (d : ℝ) < (p : ℝ) ^ (5 / 6 : ℝ) ∧ + 8 * p ≤ (combinedTruncatedOrderTotientSum p d) ^ 2 ∧ + d ≤ 189 * (middleGameMaximalOrders p d).card ^ 3 := by + have hexists : + ∃ x : PuncturedMarkoffSurface (ZMod p), + ¬ SamePuncturedComponent c x := by + by_contra hnone + have hAll : ∀ x : PuncturedMarkoffSurface (ZMod p), + SamePuncturedComponent c x := by + intro x + by_contra hx + exact hnone ⟨x, hx⟩ + apply hnotTransitive + intro a b + obtain ⟨ga, hga⟩ := + (samePuncturedComponent_iff_exists c a).1 (hAll a) + obtain ⟨gb, hgb⟩ := + (samePuncturedComponent_iff_exists c b).1 (hAll b) + refine ⟨gb * ga⁻¹, ?_⟩ + calc + (gb * ga⁻¹) • a = gb • (ga⁻¹ • a) := mul_smul _ _ _ + _ = gb • c := by rw [← hga]; simp + _ = b := hgb + obtain ⟨x, hx⟩ := hexists + exact + exists_exactOrderRootSum_eulerSevenCap_of_not_samePuncturedComponent + p hpThree c x hlarge hlinear hfour hx + +end + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Assembly/ExactOrderPuncturedSmallOrderCount.lean b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/ExactOrderPuncturedSmallOrderCount.lean new file mode 100644 index 0000000000..4790f6a783 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/ExactOrderPuncturedSmallOrderCount.lean @@ -0,0 +1,70 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.ExactOrderTraceBudget +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.NonparabolicPuncturedSmallOrderCount + +/-! +# Exact-order square bound for punctured small-order points + +The root-sum convention is retained: `combinedTruncatedOrderTotientSum` counts +eigenvalue roots, not traces. Inversion pairing supplies the factor two +before the two-coordinate Markoff fiber estimate is squared. +-/ + +@[expose] public section + +namespace BGS.Markoff + +noncomputable section + +/-- The punctured two-coordinate low-order set is bounded by the square of +the exact combined split/nonsplit root budget. -/ +theorem two_mul_puncturedSmallNonparabolicOrder_succ_card_le_rootSumSq + {p : ℕ} [Fact p.Prime] [Invertible (3 : ZMod p)] + (hpTwo : p ≠ 2) (bound : ℕ) : + 2 * + (puncturedMarkoffPointsWithSmallNonparabolicFirstTwoRotationOrders + p (bound + 1)).card ≤ + (combinedTruncatedOrderTotientSum p bound) ^ 2 := by + classical + rw [ + puncturedMarkoffPointsWithSmallNonparabolicFirstTwoRotationOrders_card_eq_normalized + ] + let smallSet := + normalizedPuncturedMarkoffPointsWithSmallNonparabolicFirstTwoRotationOrders + p (bound + 1) + let traceSet := + nonparabolicConcreteLowOrderTraceSet p (bound + 1) + have hpoints : smallSet.card ≤ 2 * traceSet.card ^ 2 := by + rw [← Finset.card_map + (f := ⟨Subtype.val, Subtype.val_injective⟩)] + exact + (Finset.card_mono + (normalizedPuncturedSmallNonparabolicOrderValues_subset_traceSet + hpTwo (bound + 1))).trans + (normalizedMarkoffPointsWithFirstTwoCoordinatesIn_card_le traceSet) + have htraces : + 2 * traceSet.card ≤ + combinedTruncatedOrderTotientSum p bound := by + exact + two_mul_nonparabolicConcreteLowOrderTraceSet_succ_card_le_totient + bound + change + 2 * smallSet.card ≤ + (combinedTruncatedOrderTotientSum p bound) ^ 2 + calc + 2 * smallSet.card ≤ 2 * (2 * traceSet.card ^ 2) := + Nat.mul_le_mul_left 2 hpoints + _ = (2 * traceSet.card) ^ 2 := by ring + _ ≤ (combinedTruncatedOrderTotientSum p bound) ^ 2 := by + gcongr + +end + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Assembly/ExactOrderRankinEnvelope.lean b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/ExactOrderRankinEnvelope.lean new file mode 100644 index 0000000000..7f418b89af --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/ExactOrderRankinEnvelope.lean @@ -0,0 +1,485 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.ExactOrderEulerSevenComplementObstruction +public import LeanPool.MarkoffModP.BGS.NumberTheory.RankinProfileCertificate +public import LeanPool.MarkoffModP.BGS.NumberTheory.RankinProfileMatching +public import LeanPool.MarkoffModP.BGS.NumberTheory.RankinJointEnvelopeCertificate +public import LeanPool.MarkoffModP.BGS.NumberTheory.TruncatedOrderTotientRankinFactorization + +/-! +# Exact-order Rankin envelope for the Markoff obstruction + +This file combines the new exact-order obstruction with the rational Rankin +Euler product. The deliberately coarse first endpoint uses the total numbers +of divisors of `p - 1` and `p + 1`; the already formalized Sperner width can +replace this envelope later without changing the Rankin layer. +-/ + +@[expose] public section + +namespace BGS.Markoff + +open BGS.NumberTheory + +/-- Coarse joint envelope for the two sets of maximal candidate orders. -/ +def jointDivisorCount (p : ℕ) : ℕ := + (p - 1).divisors.card + (p + 1).divisors.card + +/-- Exact rational Euler-product envelope for the two neighboring torus +orders. -/ +def jointRankinEulerProduct + (p : ℕ) (primeWeight : ℕ → ℚ) : ℚ := + ((p - 1).factorization.prod fun prime exponent => + rankinPrimePowerFactor prime exponent (primeWeight prime)) + + ((p + 1).factorization.prod fun prime exponent => + rankinPrimePowerFactor prime exponent (primeWeight prime)) + +theorem middleGameMaximalOrders_card_le_jointDivisorCount + (p bound : ℕ) : + (middleGameMaximalOrders p bound).card ≤ jointDivisorCount p := by + calc + (middleGameMaximalOrders p bound).card ≤ + (maximalDivisorsBelow (p - 1) (bound + 1)).card + + (maximalDivisorsBelow (p + 1) (bound + 1)).card := + middleGameMaximalOrders_card_le p bound + _ ≤ (p - 1).divisors.card + (p + 1).divisors.card := + Nat.add_le_add + (maximalDivisorsBelow_card_le_card_divisors _ _) + (maximalDivisorsBelow_card_le_card_divisors _ _) + _ = jointDivisorCount p := rfl + +/-- The Euler-seven common witness is bounded using only the two complete +divisor counts. -/ +theorem bound_le_jointDivisorCube + {p bound : ℕ} + (hbound : + bound ≤ 189 * (middleGameMaximalOrders p bound).card ^ 3) : + bound ≤ 189 * (jointDivisorCount p) ^ 3 := by + exact hbound.trans (by + gcongr + exact middleGameMaximalOrders_card_le_jointDivisorCount p bound) + +theorem combinedTruncatedOrderTotientSum_cast_le_jointFactorizationRankin + (p bound : ℕ) (hp : 1 < p) + (primeWeight : ℕ → ℚ) (cap : ℚ) + (hprimeWeightNonneg : ∀ prime, 0 ≤ primeWeight prime) + (hprimeWeightPower : + ∀ prime : ℕ, prime.Prime → + 1 ≤ (prime : ℚ) * (primeWeight prime) ^ 12) + (hcapNonneg : 0 ≤ cap) + (hboundCap : (bound : ℚ) ≤ cap ^ 12) : + (combinedTruncatedOrderTotientSum p bound : ℚ) ≤ + (bound : ℚ) * cap * jointRankinEulerProduct p primeWeight := by + have hminusNe : p - 1 ≠ 0 := by omega + have hplusNe : p + 1 ≠ 0 := by omega + rw [combinedTruncatedOrderTotientSum, Nat.cast_add] + calc + (truncatedOrderTotientSum (p - 1) bound : ℚ) + + (truncatedOrderTotientSum (p + 1) bound : ℚ) ≤ + ((bound : ℚ) * cap * + ((p - 1).factorization.prod fun prime exponent => + rankinPrimePowerFactor prime exponent (primeWeight prime))) + + ((bound : ℚ) * cap * + ((p + 1).factorization.prod fun prime exponent => + rankinPrimePowerFactor prime exponent (primeWeight prime))) := + add_le_add + (truncatedOrderTotientSum_cast_le_factorizationRankin + (p - 1) bound primeWeight cap hprimeWeightNonneg + hprimeWeightPower hcapNonneg hboundCap hminusNe) + (truncatedOrderTotientSum_cast_le_factorizationRankin + (p + 1) bound primeWeight cap hprimeWeightNonneg + hprimeWeightPower hcapNonneg hboundCap hplusNe) + _ = (bound : ℚ) * cap * + jointRankinEulerProduct p primeWeight := by + simp only [jointRankinEulerProduct] + ring + +theorem jointRankinEulerProduct_nonneg + (p : ℕ) (hp : 1 < p) + (primeWeight : ℕ → ℚ) + (hprimeWeightNonneg : ∀ prime, 0 ≤ primeWeight prime) : + 0 ≤ jointRankinEulerProduct p primeWeight := by + have hminusNe : p - 1 ≠ 0 := by omega + have hplusNe : p + 1 ≠ 0 := by omega + exact add_nonneg + (factorizationEulerProduct_nonneg + (p - 1) hminusNe primeWeight hprimeWeightNonneg) + (factorizationEulerProduct_nonneg + (p + 1) hplusNe primeWeight hprimeWeightNonneg) + +/-- The exact-order obstruction, a natural cap `D` for its witness, and a +rational twelfth-root cap force one closed rational square inequality. -/ +theorem eight_mul_prime_cast_le_jointRankinSquare + {p bound D : ℕ} + (hp : 1 < p) + (hroot : + 8 * p ≤ (combinedTruncatedOrderTotientSum p bound) ^ 2) + (hbound : bound ≤ D) + (primeWeight : ℕ → ℚ) (cap : ℚ) + (hprimeWeightNonneg : ∀ prime, 0 ≤ primeWeight prime) + (hprimeWeightPower : + ∀ prime : ℕ, prime.Prime → + 1 ≤ (prime : ℚ) * (primeWeight prime) ^ 12) + (hcapNonneg : 0 ≤ cap) + (hDCap : (D : ℚ) ≤ cap ^ 12) : + (8 * p : ℚ) ≤ + ((D : ℚ) * cap * jointRankinEulerProduct p primeWeight) ^ 2 := by + have hboundCast : (bound : ℚ) ≤ D := by + exact_mod_cast hbound + have hboundCap : (bound : ℚ) ≤ cap ^ 12 := by + exact hboundCast.trans hDCap + have hRankin := + combinedTruncatedOrderTotientSum_cast_le_jointFactorizationRankin + p bound hp primeWeight cap hprimeWeightNonneg + hprimeWeightPower hcapNonneg hboundCap + have hEulerNonneg := + jointRankinEulerProduct_nonneg p hp primeWeight + hprimeWeightNonneg + have hUpper : + (combinedTruncatedOrderTotientSum p bound : ℚ) ≤ + (D : ℚ) * cap * jointRankinEulerProduct p primeWeight := by + calc + (combinedTruncatedOrderTotientSum p bound : ℚ) ≤ + (bound : ℚ) * cap * + jointRankinEulerProduct p primeWeight := hRankin + _ ≤ (D : ℚ) * cap * + jointRankinEulerProduct p primeWeight := by + exact mul_le_mul_of_nonneg_right + (mul_le_mul_of_nonneg_right hboundCast hcapNonneg) + hEulerNonneg + have hrootCast : + (8 * p : ℚ) ≤ + (combinedTruncatedOrderTotientSum p bound : ℚ) ^ 2 := by + exact_mod_cast hroot + have hcombinedNonneg : + (0 : ℚ) ≤ combinedTruncatedOrderTotientSum p bound := by + positivity + have hrightNonneg : + (0 : ℚ) ≤ + (D : ℚ) * cap * jointRankinEulerProduct p primeWeight := by + positivity + exact hrootCast.trans + ((sq_le_sq₀ hcombinedNonneg hrightNonneg).2 hUpper) + +/-- Soundness boundary for one complete factorization profile. Coverage is +kept separate: this theorem only assumes the two semantic majorizations that +a later canonical-profile theorem must provide. -/ +theorem prime_le_of_rankinNeighborProfile_closes + {p bound cutoff : ℕ} + (hp : 1 < p) + (hroot : + 8 * p ≤ (combinedTruncatedOrderTotientSum p bound) ^ 2) + (hboundWitness : + bound ≤ 189 * (middleGameMaximalOrders p bound).card ^ 3) + (profile : RankinNeighborProfile) + (hprofile : profile.Valid) + (hcloses : profile.ClosesCutoff cutoff) + (primeWeight : ℕ → ℚ) + (hprimeWeightNonneg : ∀ prime, 0 ≤ primeWeight prime) + (hprimeWeightPower : + ∀ prime : ℕ, prime.Prime → + 1 ≤ (prime : ℚ) * (primeWeight prime) ^ 12) + (hdivisorCount : + jointDivisorCount p ≤ profile.jointDivisorCount) + (hEuler : + jointRankinEulerProduct p primeWeight ≤ + profile.jointCoarseEulerProduct) : + p ≤ cutoff := by + rcases hprofile with + ⟨htwo, htwoWeight, htwoFloor, hodd, + hfloors, hrootCapPos, hwitnessCap⟩ + have hboundJoint := + bound_le_jointDivisorCube hboundWitness + have hboundProfile : bound ≤ profile.witnessCap := by + exact hboundJoint.trans (by + simp only [RankinNeighborProfile.witnessCap] + gcongr) + have hrootCapNonneg : (0 : ℚ) ≤ profile.rootCap := by + positivity + have hwitnessCapCast : + (profile.witnessCap : ℚ) ≤ (profile.rootCap : ℚ) ^ 12 := by + exact_mod_cast hwitnessCap + have hfailure := + eight_mul_prime_cast_le_jointRankinSquare + hp hroot hboundProfile primeWeight profile.rootCap + hprimeWeightNonneg hprimeWeightPower hrootCapNonneg + hwitnessCapCast + have hEulerActualNonneg := + jointRankinEulerProduct_nonneg p hp primeWeight + hprimeWeightNonneg + have hEulerProfileNonneg : + (0 : ℚ) ≤ profile.jointCoarseEulerProduct := + hEulerActualNonneg.trans hEuler + have hscaleNonneg : + (0 : ℚ) ≤ (profile.witnessCap : ℚ) * profile.rootCap := by + positivity + have hupper : + (profile.witnessCap : ℚ) * profile.rootCap * + jointRankinEulerProduct p primeWeight ≤ + (profile.witnessCap : ℚ) * profile.rootCap * + profile.jointCoarseEulerProduct := + mul_le_mul_of_nonneg_left hEuler hscaleNonneg + have hleftNonneg : + (0 : ℚ) ≤ + (profile.witnessCap : ℚ) * profile.rootCap * + jointRankinEulerProduct p primeWeight := by + positivity + have hrightNonneg : + (0 : ℚ) ≤ + (profile.witnessCap : ℚ) * profile.rootCap * + profile.jointCoarseEulerProduct := by + positivity + have hprofileSquare : + (8 * p : ℚ) ≤ + ((profile.witnessCap : ℚ) * profile.rootCap * + profile.jointCoarseEulerProduct) ^ 2 := + hfailure.trans ((sq_le_sq₀ hleftNonneg hrightNonneg).2 hupper) + by_contra hnot + have hcutoffSucc : cutoff + 1 ≤ p := by omega + have hcutoffCast : + (8 * (cutoff + 1) : ℚ) ≤ (8 * p : ℚ) := by + exact_mod_cast Nat.mul_le_mul_left 8 hcutoffSucc + have hclosesCast : + ((profile.witnessCap : ℚ) * profile.rootCap * + profile.jointCoarseEulerProduct) ^ 2 < + (8 * (cutoff + 1) : ℚ) := by + simpa only [RankinNeighborProfile.ClosesCutoff, + RankinNeighborProfile.failureSquare, + Nat.cast_mul, Nat.cast_add, Nat.cast_ofNat, + Nat.cast_one] using hcloses + exact (not_lt_of_ge (hcutoffCast.trans hprofileSquare)) hclosesCast + +/-- The semantic matching theorem discharges both majorization hypotheses of +`prime_le_of_rankinNeighborProfile_closes`. A valid, closing profile that +matches the actual factorizations of `p - 1` and `p + 1` therefore bounds the +prime directly. -/ +theorem prime_le_of_matching_rankinNeighborProfile_closes + {p bound cutoff : ℕ} + (hpPrime : p.Prime) (hpTwo : 2 < p) + (hroot : + 8 * p ≤ (combinedTruncatedOrderTotientSum p bound) ^ 2) + (hboundWitness : + bound ≤ 189 * (middleGameMaximalOrders p bound).card ^ 3) + (profile : RankinNeighborProfile) + (hprofile : profile.Valid) + (hcloses : profile.ClosesCutoff cutoff) + (hmatch : profile.Matches p) : + p ≤ cutoff := by + have hp : 1 < p := by omega + obtain ⟨assignment, hweightNonneg, hweightPower, + hminusEuler, hplusEuler⟩ := + profile.exists_assignedPrimeWeight_bounds + hpPrime hpTwo hprofile hmatch + have hdivisorEq := + profile.jointDivisorCount_eq_neighborCards + hpPrime hpTwo hmatch + apply prime_le_of_rankinNeighborProfile_closes + hp hroot hboundWitness profile hprofile hcloses + (assignedPrimeWeight p profile assignment) + hweightNonneg hweightPower + · change + (p - 1).divisors.card + (p + 1).divisors.card ≤ + profile.jointDivisorCount + exact le_of_eq hdivisorEq.symm + · change + ((p - 1).factorization.prod fun prime exponent => + rankinPrimePowerFactor prime exponent + (assignedPrimeWeight p profile assignment prime)) + + ((p + 1).factorization.prod fun prime exponent => + rankinPrimePowerFactor prime exponent + (assignedPrimeWeight p profile assignment prime)) ≤ + profile.coarseEulerProduct .minus + + profile.coarseEulerProduct .plus + exact add_le_add hminusEuler hplusEuler + +/-- The exact-order obstruction forces the profile failure square itself, +after both semantic bounds have been discharged by matching. -/ +theorem eight_mul_prime_cast_le_matching_profile_failureSquare + {p bound : ℕ} + (hpPrime : p.Prime) (hpTwo : 2 < p) + (hroot : + 8 * p ≤ (combinedTruncatedOrderTotientSum p bound) ^ 2) + (hboundWitness : + bound ≤ 189 * (middleGameMaximalOrders p bound).card ^ 3) + (profile : RankinNeighborProfile) + (hprofile : profile.Valid) + (hmatch : profile.Matches p) : + (8 * p : ℚ) ≤ profile.failureSquare := by + have hp : 1 < p := by omega + obtain ⟨assignment, hweightNonneg, hweightPower, + hminusEuler, hplusEuler⟩ := + profile.exists_assignedPrimeWeight_bounds + hpPrime hpTwo hprofile hmatch + have hdivisorEq := + profile.jointDivisorCount_eq_neighborCards + hpPrime hpTwo hmatch + have hboundJoint := bound_le_jointDivisorCube hboundWitness + have hboundProfile : bound ≤ profile.witnessCap := by + apply hboundJoint.trans + simp only [RankinNeighborProfile.witnessCap] + gcongr + change + (p - 1).divisors.card + (p + 1).divisors.card ≤ + profile.jointDivisorCount + exact le_of_eq hdivisorEq.symm + have hrootCapNonneg : (0 : ℚ) ≤ profile.rootCap := by positivity + have hwitnessCapCast : + (profile.witnessCap : ℚ) ≤ (profile.rootCap : ℚ) ^ 12 := by + exact_mod_cast hprofile.2.2.2.2.2.2 + have hfailure := + eight_mul_prime_cast_le_jointRankinSquare + hp hroot hboundProfile + (assignedPrimeWeight p profile assignment) profile.rootCap + hweightNonneg hweightPower hrootCapNonneg hwitnessCapCast + have hEuler : + jointRankinEulerProduct p + (assignedPrimeWeight p profile assignment) ≤ + profile.jointCoarseEulerProduct := by + exact add_le_add hminusEuler hplusEuler + have hEulerActualNonneg := + jointRankinEulerProduct_nonneg p hp + (assignedPrimeWeight p profile assignment) hweightNonneg + have hEulerProfileNonneg : + (0 : ℚ) ≤ profile.jointCoarseEulerProduct := + hEulerActualNonneg.trans hEuler + have hscaleNonneg : + (0 : ℚ) ≤ (profile.witnessCap : ℚ) * profile.rootCap := by + positivity + have hupper : + (profile.witnessCap : ℚ) * profile.rootCap * + jointRankinEulerProduct p + (assignedPrimeWeight p profile assignment) ≤ + (profile.witnessCap : ℚ) * profile.rootCap * + profile.jointCoarseEulerProduct := + mul_le_mul_of_nonneg_left hEuler hscaleNonneg + have hleftNonneg : + (0 : ℚ) ≤ + (profile.witnessCap : ℚ) * profile.rootCap * + jointRankinEulerProduct p + (assignedPrimeWeight p profile assignment) := by + positivity + have hrightNonneg : + (0 : ℚ) ≤ + (profile.witnessCap : ℚ) * profile.rootCap * + profile.jointCoarseEulerProduct := by + positivity + simpa only [RankinNeighborProfile.failureSquare] using + hfailure.trans ((sq_le_sq₀ hleftNonneg hrightNonneg).2 hupper) + +/-- A checked lower-product exclusion cannot coexist with the exact-order +failure obstruction. -/ +theorem false_of_matching_rankinNeighborProfile_excludes + {p bound : ℕ} + (hpPrime : p.Prime) (hpTwo : 2 < p) + (hroot : + 8 * p ≤ (combinedTruncatedOrderTotientSum p bound) ^ 2) + (hboundWitness : + bound ≤ 189 * (middleGameMaximalOrders p bound).card ^ 3) + (profile : RankinNeighborProfile) + (hprofile : profile.Valid) + (hmatch : profile.Matches p) + (hexcludes : profile.ExcludesFailure) : False := by + have hfailure := + eight_mul_prime_cast_le_matching_profile_failureSquare + hpPrime hpTwo hroot hboundWitness profile hprofile hmatch + have hlower := + profile.lowerNeighborProducts_le hpPrime hpTwo hmatch + rcases hexcludes with hminus | hplus | hjoint + · have hlowerPrime : + profile.lowerNeighborProduct .minus + 1 ≤ p := by omega + have hlowerCast : + (((8 * (profile.lowerNeighborProduct .minus + 1) : ℕ) : ℚ)) ≤ + (8 * p : ℚ) := by + exact_mod_cast Nat.mul_le_mul_left 8 hlowerPrime + exact (not_lt_of_ge (hlowerCast.trans hfailure)) hminus + · have hlowerPrime : + profile.lowerNeighborProduct .plus - 1 ≤ p := by omega + have hlowerCast : + (((8 * (profile.lowerNeighborProduct .plus - 1) : ℕ) : ℚ)) ≤ + (8 * p : ℚ) := by + have hnat := Nat.mul_le_mul_left 8 hlowerPrime + exact_mod_cast hnat + exact (not_lt_of_ge (hlowerCast.trans hfailure)) hplus + · have hneighborProduct : + profile.lowerNeighborProduct .minus * + profile.lowerNeighborProduct .plus ≤ + (p - 1) * (p + 1) := + Nat.mul_le_mul hlower.1 hlower.2 + have hneighborLt : (p - 1) * (p + 1) < p ^ 2 := by + have hsub : p - 1 + 1 = p := by omega + nlinarith + have hlowerJointCast : + (((64 * (profile.lowerNeighborProduct .minus * + profile.lowerNeighborProduct .plus) : ℕ) : ℚ)) < + (64 * p ^ 2 : ℚ) := by + have hnat := (Nat.mul_lt_mul_left (by omega : 0 < 64)).2 + (hneighborProduct.trans_lt hneighborLt) + exact_mod_cast hnat + have hfailureNonneg : (0 : ℚ) ≤ profile.failureSquare := by + rw [RankinNeighborProfile.failureSquare] + exact sq_nonneg _ + have heighthPrimeNonneg : (0 : ℚ) ≤ (8 * p : ℚ) := by positivity + have hfailureSquared : + (64 * p ^ 2 : ℚ) ≤ profile.failureSquare ^ 2 := by + have hsquare := + (sq_le_sq₀ heighthPrimeNonneg hfailureNonneg).2 hfailure + norm_num [mul_pow] at hsquare ⊢ + exact hsquare + exact (not_lt_of_ge + (hlowerJointCast.le.trans hfailureSquared)) hjoint + +/-- Every fully matched profile can be certified by either a direct cutoff +closure or a lower-product exclusion. This disjunction is the leaf predicate +for the forthcoming exhaustive profile tree. -/ +theorem prime_le_of_matching_rankinNeighborProfile_closes_or_excludes + {p bound cutoff : ℕ} + (hpPrime : p.Prime) (hpTwo : 2 < p) + (hroot : + 8 * p ≤ (combinedTruncatedOrderTotientSum p bound) ^ 2) + (hboundWitness : + bound ≤ 189 * (middleGameMaximalOrders p bound).card ^ 3) + (profile : RankinNeighborProfile) + (hprofile : profile.Valid) + (hmatch : profile.Matches p) + (hleaf : profile.ClosesCutoff cutoff ∨ profile.ExcludesFailure) : + p ≤ cutoff := by + rcases hleaf with hcloses | hexcludes + · exact prime_le_of_matching_rankinNeighborProfile_closes + hpPrime hpTwo hroot hboundWitness profile hprofile hcloses hmatch + · exact False.elim + (false_of_matching_rankinNeighborProfile_excludes + hpPrime hpTwo hroot hboundWitness profile hprofile hmatch hexcludes) + +/-- Side-erased profiles eliminate the exponential assignment word from the +future exhaustive search: it is enough to check the product envelope leaf. -/ +theorem prime_le_of_matching_rankinNeighborProfile_jointEnvelope_leaf + {p bound cutoff : ℕ} + (hpPrime : p.Prime) (hpTwo : 2 < p) + (hroot : + 8 * p ≤ (combinedTruncatedOrderTotientSum p bound) ^ 2) + (hboundWitness : + bound ≤ 189 * (middleGameMaximalOrders p bound).card ^ 3) + (profile : RankinNeighborProfile) + (hprofile : profile.Valid) + (hmatch : profile.Matches p) + (hleaf : + profile.JointEnvelopeClosesCutoff cutoff ∨ + profile.JointEnvelopeExcludesFailure) : + p ≤ cutoff := by + apply prime_le_of_matching_rankinNeighborProfile_closes_or_excludes + hpPrime hpTwo hroot hboundWitness profile hprofile hmatch + rcases hleaf with hcloses | hexcludes + · exact Or.inl + (profile.jointEnvelopeClosesCutoff_implies_closesCutoff + hprofile hcloses) + · exact Or.inr + (profile.jointEnvelopeExcludesFailure_implies_excludesFailure + hprofile hexcludes) + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Assembly/ExactOrderTraceBudget.lean b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/ExactOrderTraceBudget.lean new file mode 100644 index 0000000000..ba1447c58a --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/ExactOrderTraceBudget.lean @@ -0,0 +1,167 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.NonparabolicMaximalDivisorConcreteCount +public import LeanPool.MarkoffModP.BGS.NumberTheory.TruncatedOrderTotient + +/-! +# Exact-order root budgets for nonparabolic traces + +The old maximal-divisor estimate replaces each exact-order fiber by a common +worst-case size. Here the cyclic fibers remain disjoint and contribute their +exact root counts `φ(e)`. +-/ + +@[expose] public section + +namespace BGS.Markoff + +open BGS.NumberTheory + +noncomputable section + +theorem pow_two_ne_one_iff_two_lt_orderOf + {G : Type*} [Group G] [Finite G] (x : G) : + x ^ 2 ≠ 1 ↔ 2 < orderOf x := by + constructor + · intro hpow + have hpos : 0 < orderOf x := + (isOfFinOrder_of_finite x).orderOf_pos + by_contra hnot + have hle : orderOf x ≤ 2 := Nat.le_of_not_gt hnot + have hcases : orderOf x = 1 ∨ orderOf x = 2 := by + omega + have hdvd : orderOf x ∣ 2 := by + rcases hcases with horder | horder <;> simp [horder] + exact hpow (orderOf_dvd_iff_pow_eq_one.mp hdvd) + · intro horder hpow + have hdvd : orderOf x ∣ 2 := + orderOf_dvd_of_pow_eq_one hpow + have hle : orderOf x ≤ 2 := + Nat.le_of_dvd (by norm_num) hdvd + omega + +section CyclicTrace + +variable {G T : Type*} [Group G] [Fintype G] [DecidableEq G] + [DecidableEq T] [IsCyclic G] + +omit [IsCyclic G] in +theorem nonTwoTorsionBoundedOrderTraceSet_succ_eq_exactOrderImage + (trace : G → T) (bound : ℕ) : + nonTwoTorsionBoundedOrderTraceSet trace (bound + 1) = + (elementsOfOrderBetweenThreeAnd G bound).image trace := by + unfold nonTwoTorsionBoundedOrderTraceSet + congr 1 + ext x + simp only [Finset.mem_filter, Finset.mem_univ, true_and, + mem_elementsOfOrderBetweenThreeAnd_iff, + pow_two_ne_one_iff_two_lt_orderOf] + omega + +/-- An inversion-invariant trace map has at most half the exact cyclic root +budget in the non-two-torsion truncated range. -/ +theorem two_mul_nonTwoTorsionBoundedOrderTraceSet_succ_card_le_totient + (trace : G → T) (bound : ℕ) + (htraceInv : ∀ x, trace x⁻¹ = trace x) : + 2 * (nonTwoTorsionBoundedOrderTraceSet + trace (bound + 1)).card ≤ + truncatedOrderTotientSum (Fintype.card G) bound := by + let roots := elementsOfOrderBetweenThreeAnd G bound + have hsinv : ∀ x ∈ roots, x⁻¹ ∈ roots := by + intro x hx + rw [show roots = elementsOfOrderBetweenThreeAnd G bound by rfl, + mem_elementsOfOrderBetweenThreeAnd_iff] + have hxData := + mem_elementsOfOrderBetweenThreeAnd_iff.mp + (by simpa [roots] using hx) + simpa using hxData + have hnofixed : ∀ x ∈ roots, x⁻¹ ≠ x := by + intro x hx hinv + have hxOrder : + 2 < orderOf x := + (mem_elementsOfOrderBetweenThreeAnd_iff.mp + (by simpa [roots] using hx)).1 + have hxPow : x ^ 2 ≠ 1 := + (pow_two_ne_one_iff_two_lt_orderOf x).mpr hxOrder + apply hxPow + calc + x ^ 2 = x * x := pow_two x + _ = x * x⁻¹ := congrArg (fun z ↦ x * z) hinv.symm + _ = 1 := mul_inv_cancel x + rw [nonTwoTorsionBoundedOrderTraceSet_succ_eq_exactOrderImage] + calc + 2 * (roots.image trace).card ≤ roots.card := + two_mul_card_image_le_card_of_inv_invariant_of_no_fixed + roots trace hsinv htraceInv hnofixed + _ = truncatedOrderTotientSum (Fintype.card G) bound := + elementsOfOrderBetweenThreeAnd_card_eq_truncatedOrderTotientSum + G bound + +end CyclicTrace + +/-- Exact combined root budget for the split and nonsplit rotation tori. -/ +def combinedTruncatedOrderTotientSum (p bound : ℕ) : ℕ := + truncatedOrderTotientSum (p - 1) bound + + truncatedOrderTotientSum (p + 1) bound + +/-- The concrete nonparabolic trace set is bounded by the exact combined +root-order budget. -/ +theorem two_mul_nonparabolicConcreteLowOrderTraceSet_succ_card_le_totient + {p : ℕ} [Fact p.Prime] (bound : ℕ) : + 2 * (nonparabolicConcreteLowOrderTraceSet + p (bound + 1)).card ≤ + combinedTruncatedOrderTotientSum p bound := by + classical + let splitSet := + nonTwoTorsionBoundedOrderTraceSet + (splitTorusTrace : (ZMod p)ˣ → ZMod p) (bound + 1) + let nonsplitSet := + nonTwoTorsionBoundedOrderTraceSet + (quadraticNormOneTrace p) (bound + 1) + have hsplit : + 2 * splitSet.card ≤ + truncatedOrderTotientSum + (Fintype.card (ZMod p)ˣ) bound := by + exact + two_mul_nonTwoTorsionBoundedOrderTraceSet_succ_card_le_totient + (splitTorusTrace : (ZMod p)ˣ → ZMod p) bound + (splitTorusTrace_inv (ZMod p)) + have hnonsplit : + 2 * nonsplitSet.card ≤ + truncatedOrderTotientSum + (Fintype.card (quadraticNormOneTorus p)) bound := by + exact + two_mul_nonTwoTorsionBoundedOrderTraceSet_succ_card_le_totient + (quadraticNormOneTrace p) bound + (quadraticNormOneTrace_inv p) + have hsplitCard : Fintype.card (ZMod p)ˣ = p - 1 := by + rw [← Nat.card_eq_fintype_card, Nat.card_units, Nat.card_zmod] + have hnonsplitCard : + Fintype.card (quadraticNormOneTorus p) = p + 1 := by + rw [← Nat.card_eq_fintype_card, quadraticNormOneTorus_natCard] + calc + 2 * (nonparabolicConcreteLowOrderTraceSet + p (bound + 1)).card ≤ + 2 * (splitSet.card + nonsplitSet.card) := by + apply Nat.mul_le_mul_left + simpa [nonparabolicConcreteLowOrderTraceSet, splitSet, nonsplitSet] using + (Finset.card_union_le splitSet nonsplitSet) + _ = 2 * splitSet.card + 2 * nonsplitSet.card := by ring + _ ≤ truncatedOrderTotientSum + (Fintype.card (ZMod p)ˣ) bound + + truncatedOrderTotientSum + (Fintype.card (quadraticNormOneTorus p)) bound := by + omega + _ = combinedTruncatedOrderTotientSum p bound := by + rw [hsplitCard, hnonsplitCard] + rfl + +end + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Assembly/ExceptionalPrimeCount.lean b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/ExceptionalPrimeCount.lean new file mode 100644 index 0000000000..7a29cbf603 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/ExceptionalPrimeCount.lean @@ -0,0 +1,119 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import Mathlib.Order.Interval.Set.Nat +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.DivisibleOrbitTransitivity +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.GiantOrbit +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.TransitivitySurjectivity + +/-! +# Exceptional-prime consequences of Chen orbit divisibility + +Chen's component-divisibility theorem, formalized here through Martin's later elementary proof, +upgrades the giant-orbit half of Theorem 1 to strong approximation at every sufficiently large +prime. This file records the resulting finite exceptional-prime set and derives the subpower +exceptional-prime bound of Theorem 2. +-/ + +@[expose] public section + +namespace BGS.Markoff + +open Filter +open scoped Topology + +/-- If strong approximation holds at every prime beyond `p0`, then at most `p0` primes are +exceptional below any cutoff. -/ +theorem exceptionalPrimeCount_le_of_eventually_strongApproximationAt + (p0 : ℕ) + (hstrong : ∀ (p : ℕ), p.Prime → p0 ≤ p → StrongApproximationAt p) + (T : ℕ) : + exceptionalPrimeCount T ≤ p0 := by + rw [exceptionalPrimeCount] + calc + {p : ℕ | p ≤ T ∧ IsExceptionalPrime p}.ncard ≤ (Set.Iio p0).ncard := by + refine Set.ncard_le_ncard ?_ (Set.toFinite (Set.Iio p0)) + intro p hp + change p ≤ T ∧ IsExceptionalPrime p at hp + rcases hp.2 with ⟨hpPrime, hpFailure⟩ + change p < p0 + by_contra hpNotLt + exact hpFailure (hstrong p hpPrime (Nat.le_of_not_gt hpNotLt)) + _ = p0 := Set.ncard_Iio_nat p0 + +/-- Eventual strong approximation implies the subpower exceptional-prime estimate of +`TheoremTwoStatement`. -/ +theorem theoremTwoStatement_of_eventually_strongApproximationAt + (hstrong : ∃ p0 : ℕ, ∀ (p : ℕ), p.Prime → p0 ≤ p → StrongApproximationAt p) : + TheoremTwoStatement := by + obtain ⟨p0, hp0⟩ := hstrong + intro epsilon hepsilon + have hEventually : + ∀ᶠ T : ℕ in atTop, (p0 : ℝ) ≤ (T : ℝ) ^ epsilon := + ((tendsto_rpow_atTop hepsilon).comp tendsto_natCast_atTop_atTop).eventually + (eventually_ge_atTop (p0 : ℝ)) + rw [eventually_atTop] at hEventually + obtain ⟨T0, hT0⟩ := hEventually + refine ⟨T0, fun T hT => ?_⟩ + have hcount : exceptionalPrimeCount T ≤ p0 := + exceptionalPrimeCount_le_of_eventually_strongApproximationAt p0 hp0 T + have hcountReal : (exceptionalPrimeCount T : ℝ) ≤ p0 := by + exact_mod_cast hcount + exact hcountReal.trans (hT0 T hT) + +/-- The giant-orbit half of Theorem 1 and Chen orbit divisibility, via Martin's proof, imply +eventual punctured finite-field transitivity. -/ +theorem eventually_puncturedMarkoffTransitiveAt_of_theoremOneStatement + (hOne : TheoremOneStatement) : + ∃ p0 : ℕ, ∀ (p : ℕ) (hp : p.Prime), p0 ≤ p → + PuncturedMarkoffTransitiveAt p hp := by + exact eventually_puncturedMarkoffTransitiveAt_of_giantOrbit + (1 / 2 : ℝ) (by norm_num) (hOne.1 (1 / 2 : ℝ) (by norm_num)) + +/-- Theorem 1 and Chen orbit divisibility, through Martin's proof, imply eventual strong +approximation after applying natural Markoff connectivity. -/ +theorem eventually_strongApproximationAt_of_theoremOneStatement + (hOne : TheoremOneStatement) : + ∃ p0 : ℕ, ∀ (p : ℕ), p.Prime → p0 ≤ p → StrongApproximationAt p := by + obtain ⟨p0, hp0⟩ := + eventually_puncturedMarkoffTransitiveAt_of_theoremOneStatement hOne + refine ⟨p0, fun p hp hple => ?_⟩ + exact (puncturedMarkoffTransitiveAt_iff_strongApproximationAt p hp).mp + (hp0 p hp hple) + +/-- The general-interface form of eventual BGS Conjecture 1. + +Theorem 1 and Chen's orbit-divisibility theorem, via Martin's proof, imply +strong approximation at every sufficiently large prime. The parameter-free endpoint is +`BGS.Markoff.eventually_strongApproximationAt`. -/ +theorem eventually_strongApproximationAt_of_generalHasseWeil + (hHasse : BGS.External.GeneralBivariateAffineHasseWeilTheorem) : + ∃ p0 : ℕ, ∀ (p : ℕ), p.Prime → p0 ≤ p → StrongApproximationAt p := + eventually_strongApproximationAt_of_theoremOneStatement + (theoremOneStatement_of_generalHasseWeil hHasse) + +/-- Theorem 1 together with Chen's orbit-divisibility theorem, via Martin's elementary proof, +implies Theorem 2. -/ +theorem theoremTwoStatement_of_theoremOneStatement + (hOne : TheoremOneStatement) : + TheoremTwoStatement := + theoremTwoStatement_of_eventually_strongApproximationAt + (eventually_strongApproximationAt_of_theoremOneStatement hOne) + +/-- The general-interface form of BGS Theorem 2. + +The completed Theorem 1 assembly supplies the in-repository Corvaja--Zannier +estimate. The parameter-free endpoint is +`BGS.Markoff.theoremTwoStatement`. -/ +theorem theoremTwoStatement_of_generalHasseWeil + (hHasse : BGS.External.GeneralBivariateAffineHasseWeilTheorem) : + TheoremTwoStatement := + theoremTwoStatement_of_theoremOneStatement + (theoremOneStatement_of_generalHasseWeil hHasse) + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Assembly/ExplicitPuncturedTransitivity.lean b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/ExplicitPuncturedTransitivity.lean new file mode 100644 index 0000000000..88dbc754fb --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/ExplicitPuncturedTransitivity.lean @@ -0,0 +1,333 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.GiantOrbit +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.OrbitDivisibility +public import LeanPool.MarkoffModP.BGS.Markoff.ExplicitEndgame +public import LeanPool.MarkoffModP.BGS.Markoff.ExplicitNumericCertificates +public import LeanPool.MarkoffModP.BGS.Markoff.PreliminaryEndgame + +/-! +# Explicit punctured transitivity + +This file isolates the finite maximal-orbit argument used by the explicit +punctured-transitivity proof. The only geometric input is a stated +large-order-to-base-component hypothesis; the middle-game step is the proved +Corvaja--Zannier escape theorem. +-/ + +@[expose] public section + +namespace BGS.Markoff + +noncomputable section + +/-- The normalized surface point underlying an original punctured point. -/ +private def normalizedPuncturedPoint + {R : Type*} [Field R] [Invertible (3 : R)] + (x : PuncturedMarkoffSurface R) : NormalizedMarkoffSurface R := + normalizedSurfaceOfPunctured (puncturedNormalizationEquiv R x) + +/-- Normalizing an original punctured point intertwines the two `Gamma` +actions. -/ +private theorem normalizedPuncturedPoint_smul + {R : Type*} [Field R] [Invertible (3 : R)] + (g : Gamma R) (z : PuncturedMarkoffSurface R) : + normalizedPuncturedPoint (g • z) = + normalizedGammaPerm R g (normalizedPuncturedPoint z) := by + have hzinv : + (normalizationSurfaceEquiv R).symm + (normalizedSurfaceOfPunctured (puncturedNormalizationEquiv R z)) = z.1 := by + apply Subtype.ext + exact (normalizationEquiv R).symm_apply_apply z.1.1 + unfold normalizedPuncturedPoint + rw [normalizedGammaPerm_apply, hzinv] + apply Subtype.ext + rfl + +/-- The finite maximal-orbit argument at a fixed prime. The hypotheses expose +exactly the three frontiers consumed by the argument: the divisor-sensitive +count forces the cubic middle-game bound, the upper range supplies the linear +bound, and large order connects to one base component. -/ +theorem puncturedMarkoffTransitiveAt_of_maximalOrbit_frontier + (p : ℕ) [Fact p.Prime] [Invertible (3 : ZMod p)] (hpThree : 3 < p) + (c : PuncturedMarkoffSurface (ZMod p)) + (hcube : ∀ d : ℕ, 0 < d → + p ≤ 2 * (2 + d * + ((p - 1).divisors.card + (p + 1).divisors.card)) ^ 2 → + (corvajaZannierCorollaryTwoSafeCoefficient * + ((p - 1).divisors.card + (p + 1).divisors.card)) ^ 3 < d) + (hlinear : ∀ d : ℕ, + (d : ℝ) < (p : ℝ) ^ (5 / 6 : ℝ) → + corvajaZannierCorollaryTwoSafeCoefficient * + ((p - 1).divisors.card + (p + 1).divisors.card) * d < p) + (hlarge : ∀ z : NormalizedMarkoffSurface (ZMod p), + (p : ℝ) ^ (5 / 6 : ℝ) ≤ maximalCoordinateRotationOrder z.1 → + SameNormalizedComponent + (normalizedSurfaceOfPunctured (puncturedNormalizationEquiv (ZMod p) c)) z) : + PuncturedMarkoffTransitiveAt p Fact.out := by + classical + have hpTwo : p ≠ 2 := by omega + letI : Fintype (quadraticFiniteField p) := Fintype.ofFinite _ + have hAll : ∀ x : PuncturedMarkoffSurface (ZMod p), + SamePuncturedComponent c x := by + intro x + by_contra hcx + let orderMeasure : PuncturedMarkoffSurface (ZMod p) → ℕ := fun w => + maximalCoordinateRotationOrder (normalizedPuncturedPoint w).1 + let orbitFinset := (puncturedGammaOrbit x).toFinite.toFinset + have hxMem : x ∈ orbitFinset := by + have hxOrbit : x ∈ puncturedGammaOrbit x := samePuncturedComponent_refl x + simpa [orbitFinset] using hxOrbit + obtain ⟨z, hzMem, hzMax⟩ := + Finset.exists_max_image orbitFinset orderMeasure ⟨x, hxMem⟩ + let d := orderMeasure z + have hzComponent : SamePuncturedComponent x z := by + change z ∈ puncturedGammaOrbit x + simpa [orbitFinset] using hzMem + have hmax : ∀ w : PuncturedMarkoffSurface (ZMod p), + SamePuncturedComponent x w → orderMeasure w ≤ d := by + intro w hw + apply hzMax w + change w ∈ puncturedGammaOrbit x at hw + simpa [orbitFinset] using hw + have hdPos : 0 < d := by + have hfirstPos : 0 < rotationOrder (normalizedPuncturedPoint z).1.u1 := + rotationOrder_pos _ + exact hfirstPos.trans_le <| by + simpa [d, orderMeasure] using + rotationOrder_first_le_maximalCoordinateRotationOrder + (normalizedPuncturedPoint z).1 + have hnotBaseZ : ¬ SameNormalizedComponent + (normalizedPuncturedPoint c) (normalizedPuncturedPoint z) := by + intro hcz + apply hcx + have hczPunctured : SamePuncturedComponent c z := + (samePuncturedComponent_iff_sameNormalizedComponent c z).2 hcz + exact samePuncturedComponent_trans hczPunctured + (samePuncturedComponent_symm hzComponent) + have hdUpper : (d : ℝ) < (p : ℝ) ^ (5 / 6 : ℝ) := by + by_contra hd + apply hnotBaseZ + apply hlarge (normalizedPuncturedPoint z) + simpa [d, orderMeasure] using le_of_not_gt hd + have hpLeOrbit : p ≤ (puncturedGammaOrbit x).ncard := by + have horbitPos : 0 < (puncturedGammaOrbit x).ncard := + (Set.ncard_pos (Set.toFinite _)).2 ⟨x, samePuncturedComponent_refl x⟩ + exact Nat.le_of_dvd horbitPos + (prime_dvd_puncturedGammaOrbit_ncard p hpThree x) + have horbitSmall : (puncturedGammaOrbit x).ncard ≤ + (puncturedMarkoffPointsWithSmallFirstTwoRotationOrders p (d + 1)).card := by + rw [Set.ncard_eq_toFinset_card (puncturedGammaOrbit x) (Set.toFinite _)] + apply Finset.card_le_card + intro w hwFinset + have hw : SamePuncturedComponent x w := by + change w ∈ puncturedGammaOrbit x + simpa [orbitFinset] using hwFinset + have hwMax := hmax w hw + have hfirst : rotationOrder (normalizedPuncturedPoint w).1.u1 ≤ d := + (rotationOrder_first_le_maximalCoordinateRotationOrder + (normalizedPuncturedPoint w).1).trans hwMax + have hsecond : rotationOrder (normalizedPuncturedPoint w).1.u2 ≤ d := + (rotationOrder_second_le_maximalCoordinateRotationOrder + (normalizedPuncturedPoint w).1).trans hwMax + change w ∈ puncturedMarkoffPointsWithSmallFirstTwoRotationOrders p (d + 1) + rw [puncturedMarkoffPointsWithSmallFirstTwoRotationOrders, + mem_originalPuncturedFinsetOfNormalized_iff, + mem_normalizedPuncturedMarkoffPointsWithSmallFirstTwoRotationOrders_iff] + constructor + · simpa only [normalizedPuncturedPoint, normalizedSurfaceOfPunctured, + puncturedNormalizationEquiv_coe] using Nat.lt_succ_of_le hfirst + · simpa only [normalizedPuncturedPoint, normalizedSurfaceOfPunctured, + puncturedNormalizationEquiv_coe] using Nat.lt_succ_of_le hsecond + have hpLeSmallOrderSet : p ≤ 2 * (2 + d * + ((p - 1).divisors.card + (p + 1).divisors.card)) ^ 2 := by + calc + p ≤ (puncturedGammaOrbit x).ncard := hpLeOrbit + _ ≤ (puncturedMarkoffPointsWithSmallFirstTwoRotationOrders p (d + 1)).card := + horbitSmall + _ ≤ 2 * (2 + d * + ((p - 1).divisors.card + (p + 1).divisors.card)) ^ 2 := + puncturedMarkoffPointsWithSmallFirstTwoRotationOrders_succ_card_le_divisor_sensitive + hpTwo d + have hcube' := hcube d hdPos hpLeSmallOrderSet + have hlinear' := hlinear d hdUpper + obtain ⟨y, hzy, hincrease⟩ := + exists_sameNormalizedComponent_maximalOrder_increase_of_directBounds + p hpTwo (δ := (1 / 3 : ℝ)) (by norm_num) + (corvajaZannierWeightedTraceBound p (quadraticFiniteField p)) + (normalizedPuncturedPoint z) + (by simpa only [show (1 / 2 + 1 / 3 : ℝ) = 5 / 6 by norm_num, + d, orderMeasure] using hdUpper) + (by simpa [d, orderMeasure] using hcube') + (by simpa [d, orderMeasure] using hlinear') + obtain ⟨g, hg⟩ := + (sameNormalizedComponent_iff_exists_gamma (normalizedPuncturedPoint z) y).1 hzy + let w : PuncturedMarkoffSurface (ZMod p) := g • z + have hwComponent : SamePuncturedComponent x w := + samePuncturedComponent_trans hzComponent + ((samePuncturedComponent_iff_exists z w).2 ⟨g, rfl⟩) + have hwNormalized : normalizedPuncturedPoint w = y := by + change normalizedPuncturedPoint (g • z) = y + rw [normalizedPuncturedPoint_smul] + exact hg + have hwMax := hmax w hwComponent + change maximalCoordinateRotationOrder (normalizedPuncturedPoint w).1 ≤ d at hwMax + rw [hwNormalized] at hwMax + have hincrease' : d < maximalCoordinateRotationOrder y.1 := by + simpa [d, orderMeasure] using hincrease + exact (not_lt_of_ge hwMax) hincrease' + intro a b + obtain ⟨ga, hga⟩ := (samePuncturedComponent_iff_exists c a).1 (hAll a) + obtain ⟨gb, hgb⟩ := (samePuncturedComponent_iff_exists c b).1 (hAll b) + refine ⟨gb * ga⁻¹, ?_⟩ + calc + (gb * ga⁻¹) • a = gb • (ga⁻¹ • a) := mul_smul _ _ _ + _ = gb • c := by rw [← hga]; simp + _ = b := hgb + +private theorem explicitCutoff_seven_le_for_assembly + {p : ℕ} [Fact p.Prime] + (hp : explicitStrongApproximationCutoff ≤ p) : 7 ≤ p := by + have hpOne : (1 : ℝ) ≤ p := by + exact_mod_cast (explicitCutoff_gt_one.trans_le hp).le + have hrootLe : (p : ℝ) ^ (1 / 8 : ℝ) ≤ p := by + simpa using Real.rpow_le_self_of_one_le hpOne (by norm_num : (1 / 8 : ℝ) ≤ 1) + have hfiveRoot : (5 : ℝ) < (p : ℝ) ^ (1 / 8 : ℝ) := + small_fixed_lt_rpow_one_div_eight_of_explicitCutoff hp (by norm_num) + have hfive : 5 < p := by + exact_mod_cast hfiveRoot.trans_le hrootLe + have hpSix : p ≠ 6 := by + intro hpEq + subst p + have hprime : Nat.Prime 6 := Fact.out + norm_num at hprime + omega + +/-- **Explicit punctured transitivity.** The closed cutoff supplies +all numerical estimates; the large-order route and cage connectivity are the +pointwise explicit endgame theorems. -/ +theorem puncturedMarkoffTransitiveAt_of_explicitCutoff + (p : ℕ) (hpPrime : p.Prime) + (hp : explicitStrongApproximationCutoff ≤ p) : + PuncturedMarkoffTransitiveAt p hpPrime := by + letI : Fact p.Prime := ⟨hpPrime⟩ + have hpSeven : 7 ≤ p := explicitCutoff_seven_le_for_assembly hp + have hpThree : 3 < p := by omega + have hthree : (3 : ZMod p) ≠ 0 := by + intro hzero + have hpDvd : p ∣ 3 := (ZMod.natCast_eq_zero_iff 3 p).mp hzero + exact (Nat.not_dvd_of_pos_of_lt (by omega) hpThree) hpDvd + letI : Invertible (3 : ZMod p) := invertibleOfNonzero hthree + obtain ⟨baseNormalized, hbaseCage⟩ := + exists_normalizedPunctured_splitCagePoint p hpSeven + let base : PuncturedMarkoffSurface (ZMod p) := + (puncturedNormalizationEquiv (ZMod p)).symm baseNormalized + apply puncturedMarkoffTransitiveAt_of_maximalOrbit_frontier p hpThree base + · intro d hdPos hpLe + exact explicit_lowOrder_divisorSensitive_cube hp hdPos hpLe + · intro d hUpper + exact explicit_middleGame_corvajaZannier_linearBound hp hUpper + · intro z hzLarge + have hcoordinate : + (p : ℝ) ^ (5 / 6 : ℝ) ≤ rotationOrder z.1.u1 ∨ + (p : ℝ) ^ (5 / 6 : ℝ) ≤ rotationOrder z.1.u2 ∨ + (p : ℝ) ^ (5 / 6 : ℝ) ≤ rotationOrder z.1.u3 := by + by_contra hsmall + push_neg at hsmall + have hmaxSmall : (maximalCoordinateRotationOrder z.1 : ℝ) < + (p : ℝ) ^ (5 / 6 : ℝ) := by + rw [maximalCoordinateRotationOrder, Nat.cast_max, Nat.cast_max] + exact max_lt hsmall.1 (max_lt hsmall.2.1 hsmall.2.2) + exact (not_lt_of_ge hzLarge) hmaxSmall + have hcomponent := + explicit_sameNormalizedComponent_of_largeOrder_to_splitCage + hp (normalizedSurfaceOfPunctured baseNormalized) z hbaseCage hcoordinate + simpa [base, normalizedPuncturedPoint] using hcomponent + +/-- Raw-expression form of the explicit endpoint. This displays the actual +closed natural-number bound without requiring clients to unfold either sealed +constant. -/ +theorem puncturedMarkoffTransitiveAt_of_concreteExplicitBound + (p : ℕ) (hpPrime : p.Prime) + (hp : (2 ^ 9 * (48 ^ 3 + 1) ^ 18 * + (2 ^ 9 * (9 ^ 9) ^ (2 ^ 9)) ^ 8 + 1) ≤ p) : + PuncturedMarkoffTransitiveAt p hpPrime := by + apply puncturedMarkoffTransitiveAt_of_explicitCutoff p hpPrime + simpa only [explicitStrongApproximationCutoff_eq, + explicitDivisorMomentConstant_eq] using hp + +private theorem preliminaryCutoff_seven_le_for_assembly + {p : ℕ} [Fact p.Prime] + (hp : preliminaryStrongApproximationCutoff ≤ p) : 7 ≤ p := by + have hpOne : (1 : ℝ) ≤ p := by + exact_mod_cast (preliminaryCutoff_gt_one.trans_le hp).le + have hrootLe : (p : ℝ) ^ (1 / 8 : ℝ) ≤ p := by + simpa using + Real.rpow_le_self_of_one_le hpOne (by norm_num : (1 / 8 : ℝ) ≤ 1) + have hfiveRoot : (5 : ℝ) < (p : ℝ) ^ (1 / 8 : ℝ) := + preliminary_small_fixed_lt_rpow_one_div_eight hp (by norm_num) + have hfive : 5 < p := by + exact_mod_cast hfiveRoot.trans_le hrootLe + have hpSix : p ≠ 6 := by + intro hpEq + subst p + have hprime : Nat.Prime 6 := Fact.out + norm_num at hprime + omega +/-- **Elementary preliminary-route punctured transitivity.** This is the +paper's all-divisors Corvaja--Zannier route with the analytic Nicolas estimate +replaced by the fully formalized elementary tenth-moment divisor bound. -/ +theorem puncturedMarkoffTransitiveAt_of_preliminaryCutoff + (p : ℕ) (hpPrime : p.Prime) + (hp : preliminaryStrongApproximationCutoff ≤ p) : + PuncturedMarkoffTransitiveAt p hpPrime := by + letI : Fact p.Prime := ⟨hpPrime⟩ + have hpSeven : 7 ≤ p := preliminaryCutoff_seven_le_for_assembly hp + have hpThree : 3 < p := by omega + have hthree : (3 : ZMod p) ≠ 0 := by + intro hzero + have hpDvd : p ∣ 3 := (ZMod.natCast_eq_zero_iff 3 p).mp hzero + exact (Nat.not_dvd_of_pos_of_lt (by omega) hpThree) hpDvd + letI : Invertible (3 : ZMod p) := invertibleOfNonzero hthree + obtain ⟨baseNormalized, hbaseCage⟩ := + exists_normalizedPunctured_splitCagePoint p hpSeven + let base : PuncturedMarkoffSurface (ZMod p) := + (puncturedNormalizationEquiv (ZMod p)).symm baseNormalized + apply puncturedMarkoffTransitiveAt_of_maximalOrbit_frontier p hpThree base + · intro d hdPos hpLe + exact preliminary_lowOrder_divisorSensitive_cube hp hdPos hpLe + · intro d hUpper + exact preliminary_middleGame_corvajaZannier_linearBound hp hUpper + · intro z hzLarge + have hcoordinate : + (p : ℝ) ^ (5 / 6 : ℝ) ≤ rotationOrder z.1.u1 ∨ + (p : ℝ) ^ (5 / 6 : ℝ) ≤ rotationOrder z.1.u2 ∨ + (p : ℝ) ^ (5 / 6 : ℝ) ≤ rotationOrder z.1.u3 := by + by_contra hsmall + push_neg at hsmall + have hmaxSmall : (maximalCoordinateRotationOrder z.1 : ℝ) < + (p : ℝ) ^ (5 / 6 : ℝ) := by + rw [maximalCoordinateRotationOrder, Nat.cast_max, Nat.cast_max] + exact max_lt hsmall.1 (max_lt hsmall.2.1 hsmall.2.2) + exact (not_lt_of_ge hzLarge) hmaxSmall + have hcomponent := + preliminary_sameNormalizedComponent_of_largeOrder_to_splitCage + hp (normalizedSurfaceOfPunctured baseNormalized) z hbaseCage hcoordinate + simpa [base, normalizedPuncturedPoint] using hcomponent + +/-- Raw-expression form of the elementary preliminary-route endpoint. -/ +theorem puncturedMarkoffTransitiveAt_of_concretePreliminaryBound + (p : ℕ) (hpPrime : p.Prime) + (hp : (2 ^ 1833 * (48 ^ 3 + 1) ^ 10 + 1) ≤ p) : + PuncturedMarkoffTransitiveAt p hpPrime := by + apply puncturedMarkoffTransitiveAt_of_preliminaryCutoff p hpPrime + simpa only [preliminaryStrongApproximationCutoff_eq] using hp +end + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Assembly/FixedPointFreeMaximalDivisorTraceCount.lean b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/FixedPointFreeMaximalDivisorTraceCount.lean new file mode 100644 index 0000000000..e1a53b6711 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/FixedPointFreeMaximalDivisorTraceCount.lean @@ -0,0 +1,217 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.PairedMaximalDivisorTraceCount + +/-! +# Fixed-point-free maximal-divisor trace pairing + +After restricting to eigenvalues with `x^2 ≠ 1`, inversion has no fixed +points. Every trace fiber therefore contains a genuine inverse pair, with no +additive exceptional term. Applying this on each maximal-divisor piece gives + +`2 * |non-two-torsion bounded traces| ≤ (bound - 1) * M`. +-/ + +@[expose] public section + +namespace BGS.Markoff + +open BGS.NumberTheory + +noncomputable section + +section FixedPointFreeInvolutionImage + +variable {G T : Type*} [Group G] [Fintype G] [DecidableEq G] + [DecidableEq T] [IsCyclic G] + +omit [Fintype G] [IsCyclic G] in +/-- An inversion-invariant map has at most half as many values as inputs when +inversion has no fixed point on the source. -/ +theorem two_mul_card_image_le_card_of_inv_invariant_of_no_fixed + (s : Finset G) (f : G → T) + (hsinv : ∀ x ∈ s, x⁻¹ ∈ s) + (hfinv : ∀ x, f x⁻¹ = f x) + (hnofixed : ∀ x ∈ s, x⁻¹ ≠ x) : + 2 * (s.image f).card ≤ s.card := by + classical + have hcardFibers : + s.card = + ∑ y ∈ s.image f, (s.filter fun x => f x = y).card := + Finset.card_eq_sum_card_fiberwise + (s := s) (t := s.image f) (f := f) (by + intro x hx + exact Finset.mem_image.mpr ⟨x, hx, rfl⟩) + have hfiber : + ∀ y ∈ s.image f, + 2 ≤ (s.filter fun x => f x = y).card := by + intro y hy + obtain ⟨x, hx, hxy⟩ := Finset.mem_image.mp hy + have hxFiber : x ∈ s.filter fun z => f z = y := + Finset.mem_filter.mpr ⟨hx, hxy⟩ + have hxInvFiber : x⁻¹ ∈ s.filter fun z => f z = y := by + refine Finset.mem_filter.mpr ⟨hsinv x hx, ?_⟩ + rw [hfinv, hxy] + have hpair : + ({x, x⁻¹} : Finset G) ⊆ s.filter fun z => f z = y := by + intro z hz + simp only [Finset.mem_insert, Finset.mem_singleton] at hz + rcases hz with rfl | rfl + · exact hxFiber + · exact hxInvFiber + have hne : x ≠ x⁻¹ := Ne.symm (hnofixed x hx) + simpa [hne] using Finset.card_le_card hpair + calc + 2 * (s.image f).card = + ∑ _y ∈ s.image f, 2 := by simp [Nat.mul_comm] + _ ≤ ∑ y ∈ s.image f, + (s.filter fun x => f x = y).card := by + gcongr with y hy + exact hfiber y hy + _ = s.card := hcardFibers.symm + +/-- Elements of a roots-of-unity piece that are not fixed by inversion. -/ +def nonTwoTorsionElementsWithPowOne (m : ℕ) : Finset G := + (elementsWithPowOne G m).filter fun x => x ^ 2 ≠ 1 + +omit [IsCyclic G] in +@[simp] +theorem mem_nonTwoTorsionElementsWithPowOne_iff + {m : ℕ} {x : G} : + x ∈ nonTwoTorsionElementsWithPowOne (G := G) m ↔ + x ^ m = 1 ∧ x ^ 2 ≠ 1 := by + simp [nonTwoTorsionElementsWithPowOne] + +/-- Bounded-order trace values represented by non-two-torsion eigenvalues. -/ +def nonTwoTorsionBoundedOrderTraceSet + (trace : G → T) (bound : ℕ) : Finset T := + (Finset.univ.filter fun x : G => + orderOf x < bound ∧ x ^ 2 ≠ 1).image trace + +/-- The maximal-divisor cover built only from non-two-torsion roots. -/ +def nonTwoTorsionMaximalDivisorTraceCover + (trace : G → T) (bound : ℕ) : Finset T := + (maximalDivisorsBelow (Fintype.card G) bound).biUnion fun m => + (nonTwoTorsionElementsWithPowOne (G := G) m).image trace + +omit [IsCyclic G] in +/-- Every bounded-order non-two-torsion trace lies in the fixed-point-free +maximal-divisor cover. -/ +theorem nonTwoTorsionBoundedOrderTraceSet_subset_maximalDivisorTraceCover + (trace : G → T) (bound : ℕ) : + nonTwoTorsionBoundedOrderTraceSet trace bound ⊆ + nonTwoTorsionMaximalDivisorTraceCover trace bound := by + intro y hy + rw [nonTwoTorsionBoundedOrderTraceSet, Finset.mem_image] at hy + obtain ⟨x, hx, rfl⟩ := hy + have hxData := Finset.mem_filter.mp hx + obtain ⟨m, hm, horderDvd⟩ := + exists_dvd_maximalDivisorBelow Fintype.card_ne_zero + orderOf_dvd_card hxData.2.1 + rw [nonTwoTorsionMaximalDivisorTraceCover, Finset.mem_biUnion] + refine ⟨m, hm, Finset.mem_image.mpr ⟨x, ?_, rfl⟩⟩ + rw [mem_nonTwoTorsionElementsWithPowOne_iff] + exact ⟨orderOf_dvd_iff_pow_eq_one.mp horderDvd, hxData.2.2⟩ + +/-- Each maximal-divisor piece is paired without fixed points, so summing the +pieces introduces no additive constant. -/ +theorem two_mul_nonTwoTorsionMaximalDivisorTraceCover_card_le + (trace : G → T) (bound : ℕ) + (htraceInv : ∀ x, trace x⁻¹ = trace x) : + 2 * (nonTwoTorsionMaximalDivisorTraceCover trace bound).card ≤ + (bound - 1) * + (maximalDivisorsBelow (Fintype.card G) bound).card := by + classical + have hpiece : + ∀ m ∈ maximalDivisorsBelow (Fintype.card G) bound, + 2 * ((nonTwoTorsionElementsWithPowOne + (G := G) m).image trace).card ≤ bound - 1 := by + intro m hm + have hmData := mem_maximalDivisorsBelow_iff.mp hm + have hmPos : 0 < m := by + have hmDvd : m ∣ Fintype.card G := + (Nat.mem_divisors.mp hmData.1).1 + exact Nat.pos_of_dvd_of_pos hmDvd Fintype.card_pos + let s := nonTwoTorsionElementsWithPowOne (G := G) m + have hsinv : ∀ x ∈ s, x⁻¹ ∈ s := by + intro x hx + have hxData : + x ^ m = 1 ∧ x ^ 2 ≠ 1 := by + simpa [s] using + (mem_nonTwoTorsionElementsWithPowOne_iff.mp hx) + rw [show s = nonTwoTorsionElementsWithPowOne (G := G) m by rfl, + mem_nonTwoTorsionElementsWithPowOne_iff] + constructor + · simpa using congrArg Inv.inv hxData.1 + · intro hinvSq + apply hxData.2 + have h := congrArg Inv.inv hinvSq + simpa using h + have hnofixed : ∀ x ∈ s, x⁻¹ ≠ x := by + intro x hx hinv + have hxSq : x ^ 2 ≠ 1 := + (mem_nonTwoTorsionElementsWithPowOne_iff.mp + (by simpa [s] using hx)).2 + apply hxSq + calc + x ^ 2 = x * x := pow_two x + _ = x * x⁻¹ := by rw [hinv] + _ = 1 := mul_inv_cancel x + have hpaired : + 2 * (s.image trace).card ≤ s.card := + two_mul_card_image_le_card_of_inv_invariant_of_no_fixed + s trace hsinv htraceInv hnofixed + calc + 2 * ((nonTwoTorsionElementsWithPowOne + (G := G) m).image trace).card = + 2 * (s.image trace).card := by rfl + _ ≤ s.card := hpaired + _ ≤ (elementsWithPowOne G m).card := + Finset.card_le_card (Finset.filter_subset _ _) + _ ≤ m := IsCyclic.card_pow_eq_one_le hmPos + _ ≤ bound - 1 := Nat.le_sub_one_of_lt hmData.2.1 + calc + 2 * (nonTwoTorsionMaximalDivisorTraceCover trace bound).card ≤ + 2 * ∑ m ∈ maximalDivisorsBelow (Fintype.card G) bound, + ((nonTwoTorsionElementsWithPowOne + (G := G) m).image trace).card := by + apply Nat.mul_le_mul_left + exact Finset.card_biUnion_le + _ = ∑ m ∈ maximalDivisorsBelow (Fintype.card G) bound, + 2 * ((nonTwoTorsionElementsWithPowOne + (G := G) m).image trace).card := by + simp [Finset.mul_sum] + _ ≤ ∑ _m ∈ maximalDivisorsBelow (Fintype.card G) bound, + (bound - 1) := by + gcongr with m hm + exact hpiece m hm + _ = (bound - 1) * + (maximalDivisorsBelow (Fintype.card G) bound).card := by + simp [Nat.mul_comm] + +/-- Fixed-point-free inversion pairing for the bounded-order trace set. -/ +theorem two_mul_nonTwoTorsionBoundedOrderTraceSet_card_le_maximalDivisors + (trace : G → T) (bound : ℕ) + (htraceInv : ∀ x, trace x⁻¹ = trace x) : + 2 * (nonTwoTorsionBoundedOrderTraceSet trace bound).card ≤ + (bound - 1) * + (maximalDivisorsBelow (Fintype.card G) bound).card := by + exact + (Nat.mul_le_mul_left 2 + (Finset.card_le_card + (nonTwoTorsionBoundedOrderTraceSet_subset_maximalDivisorTraceCover + trace bound))).trans + (two_mul_nonTwoTorsionMaximalDivisorTraceCover_card_le + trace bound htraceInv) + +end FixedPointFreeInvolutionImage + +end + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Assembly/GiantOrbit.lean b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/GiantOrbit.lean new file mode 100644 index 0000000000..183af6b621 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/GiantOrbit.lean @@ -0,0 +1,319 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.MiddleGameThenEndgame +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.Asymptotics +public import LeanPool.MarkoffModP.BGS.Markoff.Opening.EveryOrbitLarge +public import LeanPool.MarkoffModP.BGS.Markoff.Endgame.WeilFromGeneralHasse +public import LeanPool.MarkoffModP.BGS.Markoff.Endgame.Nonsplit.HasseFromGeneral +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.CorvajaZannierFromGeneral +public import LeanPool.MarkoffModP.BGS.Markoff.Cage.EstimateFromPlane + +/-! +# Assembly of the giant orbit + +This file connects the selected split cage component to the original punctured +Markoff action, bounds the complement by the already-counted small-order set, +and assembles Theorem 1 first from explicit specialized estimates and then from +the reusable general Hasse--Weil interface. The interface is inhabited in +`BGS.HasseWeil.GeneralBivariateAffineHasseWeil`; the parameter-free endpoint is +exported by `BGS.Markoff.Assembly.Unconditional`. +-/ + +@[expose] public section + +namespace BGS.Markoff + +open Filter + +noncomputable section + +/-- Regard a normalized punctured point as a point of the normalized surface. -/ +def normalizedSurfaceOfPunctured + {R : Type*} [CommRing R] (x : ↥(normalizedPuncturedSurface R)) : + NormalizedMarkoffSurface R := + ⟨x.1, x.2.1⟩ + +/-- Normalization identifies the punctured component relation with the transported +component relation on normalized surface points. -/ +theorem samePuncturedComponent_iff_sameNormalizedComponent + {R : Type*} [Field R] [Invertible (3 : R)] + (x y : PuncturedMarkoffSurface R) : + SamePuncturedComponent x y ↔ + SameNormalizedComponent + (normalizedSurfaceOfPunctured (puncturedNormalizationEquiv R x)) + (normalizedSurfaceOfPunctured (puncturedNormalizationEquiv R y)) := by + have hx : (normalizationSurfaceEquiv R).symm + (normalizedSurfaceOfPunctured (puncturedNormalizationEquiv R x)) = x.1 := by + apply Subtype.ext + exact (normalizationEquiv R).symm_apply_apply x.1.1 + have hy : (normalizationSurfaceEquiv R).symm + (normalizedSurfaceOfPunctured (puncturedNormalizationEquiv R y)) = y.1 := by + apply Subtype.ext + exact (normalizationEquiv R).symm_apply_apply y.1.1 + rw [SameNormalizedComponent, hx, hy] + constructor + · rintro ⟨g, hg⟩ + refine ⟨g, ?_⟩ + exact congrArg Subtype.val hg + · rintro ⟨g, hg⟩ + refine ⟨g, Subtype.ext hg⟩ + +private theorem exists_fullOrderBaseUnit (p : ℕ) [Fact p.Prime] : + ∃ u : (ZMod p)ˣ, orderOf u = Nat.card (ZMod p)ˣ := by + obtain ⟨u, hu⟩ := IsCyclic.exists_generator (α := (ZMod p)ˣ) + exact ⟨u, orderOf_eq_card_of_forall_mem_zpowers hu⟩ + +/-- For every sufficiently large prime, an explicit split conic point supplies a +punctured base point in the selected cage. -/ +theorem exists_normalizedPunctured_splitCagePoint + (p : ℕ) [Fact p.Prime] [Invertible (3 : ZMod p)] (hpSeven : 7 ≤ p) : + ∃ x : ↥(normalizedPuncturedSurface (ZMod p)), + IsInSplitCage p (normalizedSurfaceOfPunctured x) := by + obtain ⟨u, huOrder⟩ := exists_fullOrderBaseUnit p + have hcard : Nat.card (ZMod p)ˣ = p - 1 := by + rw [Nat.card_units, Nat.card_zmod] + have huSq : (u : ZMod p) ^ 2 ≠ 1 := by + intro huSq + have huDvd : orderOf u ∣ 2 := orderOf_dvd_of_pow_eq_one <| by + apply Units.ext + exact huSq + have huLe : orderOf u ≤ 2 := Nat.le_of_dvd (by norm_num) huDvd + rw [huOrder, hcard] at huLe + omega + let point : NormalizedPoint (ZMod p) := splitFiberPoint u 1 + have hpointFiber : point ∈ normalizedFiber1 (splitTorusTrace u) := + splitFiberPoint_mem u 1 huSq + have hrotation : rotationOrder (splitTorusTrace u) = p - 1 := by + rw [rotationOrder_splitTorusTrace u huSq, huOrder, hcard] + have hpointNe : point ≠ normalizedOrigin := by + intro hzero + have htraceZero : splitTorusTrace u = 0 := by + have hfirst := congrArg NormalizedPoint.u1 hzero + change splitTorusTrace u = (0 : ZMod p) at hfirst + exact hfirst + have hzeroOrder := rotationOrder_zero_le_four p + rw [← htraceZero, hrotation] at hzeroOrder + omega + let x : ↥(normalizedPuncturedSurface (ZMod p)) := + ⟨point, hpointFiber.1, by simpa using hpointNe⟩ + refine ⟨x, .first, ?_⟩ + exact hrotation + +/-- A ceiling buffer over a smaller real power is eventually bounded by any +strictly larger real power. -/ +theorem eventually_natCeil_rpow_add_one_le_rpow + {δ η : ℝ} (hδ : 0 < δ) (hδη : δ < η) : + ∀ᶠ p : ℕ in atTop, + ((Nat.ceil ((p : ℝ) ^ δ) + 1 : ℕ) : ℝ) ≤ (p : ℝ) ^ η := by + have htwoEventually : + ∀ᶠ p : ℕ in atTop, (2 : ℝ) * (p : ℝ) ^ (0 : ℝ) < (p : ℝ) ^ δ := + eventually_const_mul_rpow_lt_rpow (C := (2 : ℝ)) (a := (0 : ℝ)) + (b := δ) hδ + have hdoubleEventually : + ∀ᶠ p : ℕ in atTop, (2 : ℝ) * (p : ℝ) ^ δ < (p : ℝ) ^ η := + eventually_const_mul_rpow_lt_rpow (C := (2 : ℝ)) (a := δ) + (b := η) hδη + filter_upwards [htwoEventually, hdoubleEventually] with p htwo hdouble + have hpPowTwo : (2 : ℝ) < (p : ℝ) ^ δ := by + simpa using htwo + have hceil : ((Nat.ceil ((p : ℝ) ^ δ) + 1 : ℕ) : ℝ) < + (p : ℝ) ^ δ + 2 := by + norm_num only [Nat.cast_add, Nat.cast_one] + have hceilBase := Nat.ceil_lt_add_one + (Real.rpow_nonneg (Nat.cast_nonneg p) δ) + linarith + have haddDouble : (p : ℝ) ^ δ + 2 < 2 * (p : ℝ) ^ δ := by + calc + (p : ℝ) ^ δ + 2 < (p : ℝ) ^ δ + (p : ℝ) ^ δ := + by simpa [add_comm] using add_lt_add_left hpPowTwo ((p : ℝ) ^ δ) + _ = 2 * (p : ℝ) ^ δ := by ring + exact le_of_lt (hceil.trans (haddDouble.trans hdouble)) + +/-- If every point above the middle-game cutoff reaches a connected split cage, +then every point outside the chosen cage component has small maximal order. -/ +theorem maximalCoordinateRotationOrder_le_rpow_of_not_same_splitCageComponent + (p : ℕ) [Fact p.Prime] [Invertible (3 : ZMod p)] {δ : ℝ} + (c x : NormalizedMarkoffSurface (ZMod p)) + (hescape : ∀ z : NormalizedMarkoffSurface (ZMod p), + (p : ℝ) ^ δ < maximalCoordinateRotationOrder z.1 → + ∃ y : NormalizedMarkoffSurface (ZMod p), + SameNormalizedComponent z y ∧ IsInSplitCage p y) + (hconnected : ∀ y : NormalizedMarkoffSurface (ZMod p), + IsInSplitCage p y → SameNormalizedComponent c y) + (hnot : ¬ SameNormalizedComponent c x) : + (maximalCoordinateRotationOrder x.1 : ℝ) ≤ (p : ℝ) ^ δ := by + by_contra hlarge + obtain ⟨y, hxy, hyCage⟩ := hescape x (lt_of_not_ge hlarge) + exact hnot (sameNormalizedComponent_trans (hconnected y hyCage) + (sameNormalizedComponent_symm hxy)) + +/-- Intermediate assembly relative to a neutral weighted-trace +torsion-intersection bound and three specialized point-count estimates. + +The public endpoint supplies the weighted-trace bound from the completed +Corvaja--Zannier theorem and derives the three point-count specializations from +the general affine Hasse--Weil theorem. -/ +theorem eventually_hasGiantOrbit_of_specializedEstimates + (hBound : ∀ (p : ℕ) [Fact p.Prime] [Fintype (quadraticFiniteField p)], + WeightedTraceTorsionIntersectionBound p (quadraticFiniteField p)) + (splitCoefficient : ℕ) + (hSplitWeil : WeightedSplitTraceWeilBoundAssumption splitCoefficient) + (nonsplitCoefficient : ℕ) + (hNonsplitWeil : SeededNonsplitTraceWeilBoundAssumption nonsplitCoefficient) + (cageCoefficient : ℕ) (hCageEstimate : CageWitnessPointEstimate cageCoefficient) : + ∀ epsilon : ℝ, 0 < epsilon → + ∃ p0 : ℕ, ∀ (p : ℕ) (hpPrime : p.Prime), p0 ≤ p → + HasGiantOrbitAt p hpPrime epsilon := by + intro epsilon hEpsilon + let δ : ℝ := min (epsilon / 10) (1 / 4) + have hδ : 0 < δ := by + dsimp [δ] + exact lt_min (div_pos hEpsilon (by norm_num)) (by norm_num) + have hδQuarter : δ ≤ (1 : ℝ) / 4 := min_le_right _ _ + have hδEpsilon : δ < epsilon / 5 := by + have hδTen : δ ≤ epsilon / 10 := min_le_left _ _ + linarith + obtain ⟨middleThreshold, hmiddle⟩ := + exists_threshold_middleGame_to_splitCage hBound splitCoefficient hSplitWeil + nonsplitCoefficient hNonsplitWeil hδ hδQuarter + obtain ⟨cageThreshold, hcage⟩ := + exists_threshold_splitCage_connected cageCoefficient hCageEstimate + obtain ⟨boundThreshold, hboundThreshold⟩ := + eventually_atTop.mp + (eventually_natCeil_rpow_add_one_le_rpow hδ hδEpsilon) + obtain ⟨countThreshold, hcountThreshold⟩ := + eventually_atTop.mp (eventually_smallOrderPointBound_le_rpow hEpsilon) + refine ⟨max (max (max middleThreshold cageThreshold) boundThreshold) + (max countThreshold 7), ?_⟩ + intro p hpPrime hp + let : Fact p.Prime := ⟨hpPrime⟩ + have hpMiddle : middleThreshold ≤ p := by omega + have hpCage : cageThreshold ≤ p := by omega + have hpBound : boundThreshold ≤ p := by omega + have hpCount : countThreshold ≤ p := by omega + have hpSeven : 7 ≤ p := by omega + have hpTwo : p ≠ 2 := by omega + have hpThree : p ≠ 3 := by omega + let : Invertible (3 : ZMod p) := + invertibleOfNonzero (endgame_three_ne_zero_zmod_of_prime_ne_three p hpThree) + let : Fintype (quadraticFiniteField p) := Fintype.ofFinite _ + obtain ⟨cNormalized, hcNormalizedCage⟩ := + exists_normalizedPunctured_splitCagePoint p hpSeven + let c : PuncturedMarkoffSurface (ZMod p) := + (puncturedNormalizationEquiv (ZMod p)).symm cNormalized + let bound : ℕ := Nat.ceil ((p : ℝ) ^ δ) + 1 + let bad := puncturedMarkoffPointsWithSmallFirstTwoRotationOrders p bound + apply hasGiantOrbitAt_of_complement_subset_finset p hpPrime epsilon c bad + · intro x hxOutside + have hxNotComponent : ¬ SamePuncturedComponent c x := hxOutside.2 + let xNormalized := puncturedNormalizationEquiv (ZMod p) x + let xSurface := normalizedSurfaceOfPunctured xNormalized + have hxNotNormalized : ¬ SameNormalizedComponent + (normalizedSurfaceOfPunctured cNormalized) xSurface := by + intro hcx + apply hxNotComponent + apply (samePuncturedComponent_iff_sameNormalizedComponent c x).2 + simpa [c, xSurface, xNormalized] using hcx + have hxMaxSmall : (maximalCoordinateRotationOrder xSurface.1 : ℝ) ≤ + (p : ℝ) ^ δ := + maximalCoordinateRotationOrder_le_rpow_of_not_same_splitCageComponent + p (normalizedSurfaceOfPunctured cNormalized) xSurface + (hmiddle p hpMiddle hpThree) + (fun y hy => hcage p hpCage hpThree _ y hcNormalizedCage hy) + hxNotNormalized + have hfirstReal : (rotationOrder xSurface.1.u1 : ℝ) ≤ (p : ℝ) ^ δ := by + have hfirstMax : (rotationOrder xSurface.1.u1 : ℝ) ≤ + maximalCoordinateRotationOrder xSurface.1 := by + exact_mod_cast rotationOrder_first_le_maximalCoordinateRotationOrder xSurface.1 + exact hfirstMax.trans hxMaxSmall + have hsecondReal : (rotationOrder xSurface.1.u2 : ℝ) ≤ (p : ℝ) ^ δ := by + have hsecondMax : (rotationOrder xSurface.1.u2 : ℝ) ≤ + maximalCoordinateRotationOrder xSurface.1 := by + exact_mod_cast rotationOrder_second_le_maximalCoordinateRotationOrder xSurface.1 + exact hsecondMax.trans hxMaxSmall + have hfirstCeil : rotationOrder xSurface.1.u1 ≤ Nat.ceil ((p : ℝ) ^ δ) := by + exact_mod_cast hfirstReal.trans (Nat.le_ceil ((p : ℝ) ^ δ)) + have hsecondCeil : rotationOrder xSurface.1.u2 ≤ Nat.ceil ((p : ℝ) ^ δ) := by + exact_mod_cast hsecondReal.trans (Nat.le_ceil ((p : ℝ) ^ δ)) + have hfirstCeil' : rotationOrder (toNormalized x.1.1).u1 ≤ + Nat.ceil ((p : ℝ) ^ δ) := by + simpa only [xSurface, xNormalized, normalizedSurfaceOfPunctured, + puncturedNormalizationEquiv_coe] using hfirstCeil + have hsecondCeil' : rotationOrder (toNormalized x.1.1).u2 ≤ + Nat.ceil ((p : ℝ) ^ δ) := by + simpa only [xSurface, xNormalized, normalizedSurfaceOfPunctured, + puncturedNormalizationEquiv_coe] using hsecondCeil + change x ∈ puncturedMarkoffPointsWithSmallFirstTwoRotationOrders p bound + rw [puncturedMarkoffPointsWithSmallFirstTwoRotationOrders, + mem_originalPuncturedFinsetOfNormalized_iff, + mem_normalizedPuncturedMarkoffPointsWithSmallFirstTwoRotationOrders_iff] + exact ⟨by simpa [bound] using hfirstCeil', + by simpa [bound] using hsecondCeil'⟩ + · have hbound : (bound : ℝ) ≤ (p : ℝ) ^ (epsilon / 5) := by + exact hboundThreshold p hpBound + calc + (bad.card : ℝ) ≤ (2 * (2 + 2 * bound ^ 2) ^ 2 : ℕ) := by + exact_mod_cast + puncturedMarkoffPointsWithSmallFirstTwoRotationOrders_card_le hpTwo bound + _ ≤ (p : ℝ) ^ epsilon := hcountThreshold p hpCount bound hbound + +/-- Modular bound-injection form of Theorem 1. + +It exposes the neutral weighted-trace torsion-intersection contract together +with the split, nonsplit, and cage point-count specializations. The public +endpoint below supplies these inputs from the completed Corvaja--Zannier +theorem and the remaining general affine Hasse--Weil input. -/ +theorem theoremOneStatement_of_specializedEstimates + (hBound : ∀ (p : ℕ) [Fact p.Prime] [Fintype (quadraticFiniteField p)], + WeightedTraceTorsionIntersectionBound p (quadraticFiniteField p)) + (splitCoefficient : ℕ) + (hSplitWeil : WeightedSplitTraceWeilBoundAssumption splitCoefficient) + (nonsplitCoefficient : ℕ) + (hNonsplitWeil : SeededNonsplitTraceWeilBoundAssumption nonsplitCoefficient) + (cageCoefficient : ℕ) (hCageEstimate : CageWitnessPointEstimate cageCoefficient) : + TheoremOneStatement := by + apply theoremOneStatement_of_eventually_hasGiantOrbit + exact eventually_hasGiantOrbit_of_specializedEstimates hBound splitCoefficient hSplitWeil + nonsplitCoefficient hNonsplitWeil cageCoefficient hCageEstimate + +/-- The near-final Theorem 1 assembly with Corvaja--Zannier discharged by the +in-repository theorem. This intermediate adapter keeps the general affine +Hasse--Weil input explicit, together with its descended nonsplit adapter. -/ +theorem theoremOneStatement_of_generalHasseWeil_and_nonsplitHasseAdapter + (hHasse : BGS.External.GeneralBivariateAffineHasseWeilTheorem) + (nonsplitCoefficient : ℕ) + (hNonsplitWeil : SeededNonsplitTraceWeilBoundAssumption nonsplitCoefficient) : + TheoremOneStatement := by + classical + obtain ⟨splitCoefficient, hSplitWeil⟩ := + exists_weightedSplitTraceWeilBoundAssumption_of_generalHasseWeil hHasse + obtain ⟨cageCoefficient, _hcagePositive, hCageEstimate⟩ := + exists_cageWitnessPointEstimate_of_generalHasseWeil hHasse + apply theoremOneStatement_of_specializedEstimates + (fun p _ _ => + corvajaZannierWeightedTraceBound p (quadraticFiniteField p)) + splitCoefficient hSplitWeil nonsplitCoefficient hNonsplitWeil + cageCoefficient hCageEstimate + +/-- **BGS Theorem 1 with Corvaja--Zannier fully discharged.** + +The in-repository Corvaja--Zannier theorem supplies the middle-game estimate. +This theorem is the general-interface assembly step; the parameter-free public +endpoint is `BGS.Markoff.theoremOneStatement`. -/ +theorem theoremOneStatement_of_generalHasseWeil + (hHasse : BGS.External.GeneralBivariateAffineHasseWeilTheorem) : + TheoremOneStatement := by + obtain ⟨nonsplitCoefficient, hNonsplitWeil⟩ := + exists_seededNonsplitTraceWeilBoundAssumption_of_generalHasseWeil hHasse + exact theoremOneStatement_of_generalHasseWeil_and_nonsplitHasseAdapter + hHasse nonsplitCoefficient hNonsplitWeil + +end + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Assembly/JointMaximalDivisorFrontier.lean b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/JointMaximalDivisorFrontier.lean new file mode 100644 index 0000000000..e49418c883 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/JointMaximalDivisorFrontier.lean @@ -0,0 +1,154 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.MaximalDivisorPuncturedTransitivity +public import LeanPool.MarkoffModP.BGS.NumberTheory.JointMaximalDivisorCriterion + +/-! +# Root-free joint maximal-divisor frontier + +The improved arithmetic naturally controls the square of the sum of the two +maximal-divisor counts. This module keeps that square envelope intact instead +of taking an integer square root and losing information. +-/ + +@[expose] public section + +namespace BGS.Markoff + +open BGS.NumberTheory + +noncomputable section + +private def jointNormalizedPuncturedPoint + {R : Type*} [Field R] [Invertible (3 : R)] + (x : PuncturedMarkoffSurface R) : NormalizedMarkoffSurface R := + normalizedSurfaceOfPunctured (puncturedNormalizationEquiv R x) + +/-- A square envelope converts a root-free sixth-power comparison into the +cube inequality required by the middle game. -/ +theorem coefficient_mul_count_cube_lt_of_squareEnvelope + {coefficient count envelope order : ℕ} + (hsquare : count ^ 2 ≤ envelope) + (hstrict : coefficient ^ 6 * envelope ^ 3 < order ^ 2) : + (coefficient * count) ^ 3 < order := by + have hpower : + ((coefficient * count) ^ 3) ^ 2 ≤ + coefficient ^ 6 * envelope ^ 3 := by + calc + ((coefficient * count) ^ 3) ^ 2 = + coefficient ^ 6 * (count ^ 2) ^ 3 := by ring + _ ≤ coefficient ^ 6 * envelope ^ 3 := by gcongr + by_contra hnot + have hreverse : order ≤ (coefficient * count) ^ 3 := + Nat.le_of_not_gt hnot + have hreverseSq : + order ^ 2 ≤ ((coefficient * count) ^ 3) ^ 2 := + Nat.pow_le_pow_left hreverse 2 + exact (Nat.not_le_of_lt (hpower.trans_lt hstrict)) hreverseSq + +/-- A square envelope also converts the linear middle-game comparison into a +root-free quadratic comparison. -/ +theorem coefficient_mul_count_mul_order_lt_of_squareEnvelope + {coefficient count envelope order p : ℕ} + (hsquare : count ^ 2 ≤ envelope) + (hstrict : + coefficient ^ 2 * envelope * order ^ 2 < p ^ 2) : + coefficient * count * order < p := by + have hpower : + (coefficient * count * order) ^ 2 ≤ + coefficient ^ 2 * envelope * order ^ 2 := by + calc + (coefficient * count * order) ^ 2 = + coefficient ^ 2 * count ^ 2 * order ^ 2 := by ring + _ ≤ coefficient ^ 2 * envelope * order ^ 2 := by gcongr + by_contra hnot + have hreverse : p ≤ coefficient * count * order := + Nat.le_of_not_gt hnot + have hreverseSq : + p ^ 2 ≤ (coefficient * count * order) ^ 2 := + Nat.pow_le_pow_left hreverse 2 + exact (Nat.not_le_of_lt (hpower.trans_lt hstrict)) hreverseSq + +/-- Punctured transitivity from a square envelope for the two neighboring +maximal-divisor counts. Both numerical hypotheses are polynomial +inequalities over natural numbers. -/ +theorem puncturedMarkoffTransitiveAt_of_jointSquareEnvelope_frontier + (p : ℕ) [Fact p.Prime] [Invertible (3 : ZMod p)] + (hpThree : 3 < p) + (c : PuncturedMarkoffSurface (ZMod p)) + (squareEnvelope : ℕ → ℕ) + (hsquare : ∀ d : ℕ, + (maximalDivisorCountSum p (d + 1)) ^ 2 ≤ squareEnvelope d) + (hcube : ∀ d : ℕ, 0 < d → + p ≤ 2 * (2 + d * maximalDivisorCountSum p (d + 1)) ^ 2 → + corvajaZannierCorollaryTwoSafeCoefficient ^ 6 * + (squareEnvelope d) ^ 3 < d ^ 2) + (hlinear : ∀ d : ℕ, + (d : ℝ) < (p : ℝ) ^ (5 / 6 : ℝ) → + corvajaZannierCorollaryTwoSafeCoefficient ^ 2 * + squareEnvelope d * d ^ 2 < p ^ 2) + (hlarge : ∀ z : NormalizedMarkoffSurface (ZMod p), + (p : ℝ) ^ (5 / 6 : ℝ) ≤ + maximalCoordinateRotationOrder z.1 → + SameNormalizedComponent + (normalizedSurfaceOfPunctured (puncturedNormalizationEquiv (ZMod p) c)) z) : + PuncturedMarkoffTransitiveAt p Fact.out := by + apply puncturedMarkoffTransitiveAt_of_maximalDivisor_frontier + p hpThree c + · intro d hd hpLow + exact coefficient_mul_count_cube_lt_of_squareEnvelope + (hsquare d) (hcube d hd hpLow) + · intro d hd + exact coefficient_mul_count_mul_order_lt_of_squareEnvelope + (hsquare d) (hlinear d hd) + · intro z hz + exact hlarge z hz + +/-- Specialization of the square-envelope frontier to the new +`C^2 + 3J` bound. -/ +theorem puncturedMarkoffTransitiveAt_of_jointMaximalDivisorBounds + (p : ℕ) [Fact p.Prime] [Invertible (3 : ZMod p)] + (hpThree : 3 < p) + (c : PuncturedMarkoffSurface (ZMod p)) + (central productEnvelope : ℕ → ℕ) + (hminus : ∀ d : ℕ, + (maximalDivisorsBelow (p - 1) (d + 1)).card ≤ central d) + (hplus : ∀ d : ℕ, + (maximalDivisorsBelow (p + 1) (d + 1)).card ≤ central d) + (hproduct : ∀ d : ℕ, + (maximalDivisorsBelow (p - 1) (d + 1)).card * + (maximalDivisorsBelow (p + 1) (d + 1)).card ≤ + productEnvelope d) + (hcube : ∀ d : ℕ, 0 < d → + p ≤ 2 * (2 + d * maximalDivisorCountSum p (d + 1)) ^ 2 → + corvajaZannierCorollaryTwoSafeCoefficient ^ 6 * + (central d ^ 2 + 3 * productEnvelope d) ^ 3 < d ^ 2) + (hlinear : ∀ d : ℕ, + (d : ℝ) < (p : ℝ) ^ (5 / 6 : ℝ) → + corvajaZannierCorollaryTwoSafeCoefficient ^ 2 * + (central d ^ 2 + 3 * productEnvelope d) * d ^ 2 < p ^ 2) + (hlarge : ∀ z : NormalizedMarkoffSurface (ZMod p), + (p : ℝ) ^ (5 / 6 : ℝ) ≤ + maximalCoordinateRotationOrder z.1 → + SameNormalizedComponent + (normalizedSurfaceOfPunctured (puncturedNormalizationEquiv (ZMod p) c)) z) : + PuncturedMarkoffTransitiveAt p Fact.out := by + apply puncturedMarkoffTransitiveAt_of_jointSquareEnvelope_frontier + p hpThree c (fun d ↦ central d ^ 2 + 3 * productEnvelope d) + · intro d + simpa [maximalDivisorCountSum] using + maximalDivisorCounts_add_sq_le + (hminus d) (hplus d) (hproduct d) + · exact hcube + · exact hlinear + · exact hlarge + +end + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Assembly/MaximalDivisorLowOrderCount.lean b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/MaximalDivisorLowOrderCount.lean new file mode 100644 index 0000000000..558426a7a0 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/MaximalDivisorLowOrderCount.lean @@ -0,0 +1,137 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.PuncturedSmallOrderCount +public import LeanPool.MarkoffModP.BGS.NumberTheory.MaximalDivisorBounds + +/-! +# Small-order Markoff counts using maximal divisors + +This is the counting half of the paper's maximal-divisor improvement, +formalized at the finite-set boundary used by the maximal-orbit argument. +-/ + +@[expose] public section + +namespace BGS.Markoff + +open BGS.NumberTheory + +def maximalDivisorCountSum (p bound : ℕ) : ℕ := + (maximalDivisorsBelow (p - 1) bound).card + + (maximalDivisorsBelow (p + 1) bound).card + +theorem concreteLowOrderTraceSet_card_le_maximalDivisors + {p : ℕ} [Fact p.Prime] (bound : ℕ) : + (concreteLowOrderTraceSet p bound).card ≤ + 2 + (bound - 1) * maximalDivisorCountSum p bound := by + classical + have hsplitCard : Fintype.card (ZMod p)ˣ = p - 1 := by + rw [← Nat.card_eq_fintype_card, Nat.card_units, Nat.card_zmod] + have hnonsplitCard : Fintype.card (quadraticNormOneTorus p) = p + 1 := by + rw [← Nat.card_eq_fintype_card, quadraticNormOneTorus_natCard] + have hsplit : + (boundedOrderTraceSet + (splitTorusTrace : (ZMod p)ˣ → ZMod p) bound).card ≤ + (bound - 1) * + (maximalDivisorsBelow (Fintype.card (ZMod p)ˣ) bound).card := by + calc + (boundedOrderTraceSet + (splitTorusTrace : (ZMod p)ˣ → ZMod p) bound).card ≤ + (elementsOfOrderLessThan (ZMod p)ˣ bound).card := + Finset.card_image_le + _ ≤ (bound - 1) * + (maximalDivisorsBelow (Fintype.card (ZMod p)ˣ) bound).card := by + simpa [elementsOfOrderLessThan] using + (BGS.NumberTheory.elementsOfOrderLessThan_card_le_maximalDivisors + ((ZMod p)ˣ) bound) + have hnonsplit : + (boundedOrderTraceSet (quadraticNormOneTrace p) bound).card ≤ + (bound - 1) * + (maximalDivisorsBelow + (Fintype.card (quadraticNormOneTorus p)) bound).card := by + calc + (boundedOrderTraceSet (quadraticNormOneTrace p) bound).card ≤ + (elementsOfOrderLessThan (quadraticNormOneTorus p) bound).card := + Finset.card_image_le + _ ≤ (bound - 1) * + (maximalDivisorsBelow + (Fintype.card (quadraticNormOneTorus p)) bound).card := by + simpa [elementsOfOrderLessThan] using + (BGS.NumberTheory.elementsOfOrderLessThan_card_le_maximalDivisors + (quadraticNormOneTorus p) bound) + unfold concreteLowOrderTraceSet lowOrderTraceSet + calc + (normalizedParabolicTraceSet p ∪ + boundedOrderTraceSet (splitTorusTrace : (ZMod p)ˣ → ZMod p) bound ∪ + boundedOrderTraceSet (quadraticNormOneTrace p) bound).card ≤ + (normalizedParabolicTraceSet p ∪ + boundedOrderTraceSet + (splitTorusTrace : (ZMod p)ˣ → ZMod p) bound).card + + (boundedOrderTraceSet (quadraticNormOneTrace p) bound).card := + Finset.card_union_le _ _ + _ ≤ ((normalizedParabolicTraceSet p).card + + (boundedOrderTraceSet + (splitTorusTrace : (ZMod p)ˣ → ZMod p) bound).card) + + (boundedOrderTraceSet (quadraticNormOneTrace p) bound).card := by + gcongr + exact Finset.card_union_le _ _ + _ ≤ 2 + + (bound - 1) * + (maximalDivisorsBelow (Fintype.card (ZMod p)ˣ) bound).card + + (bound - 1) * + (maximalDivisorsBelow + (Fintype.card (quadraticNormOneTorus p)) bound).card := by + gcongr + exact Finset.card_le_two + _ = 2 + (bound - 1) * maximalDivisorCountSum p bound := by + rw [hsplitCard, hnonsplitCard] + simp only [maximalDivisorCountSum, Nat.mul_add] + omega + +theorem concreteLowOrderTraceSet_succ_card_le_maximalDivisors + {p : ℕ} [Fact p.Prime] (d : ℕ) : + (concreteLowOrderTraceSet p (d + 1)).card ≤ + 2 + d * maximalDivisorCountSum p (d + 1) := by + simpa using + (concreteLowOrderTraceSet_card_le_maximalDivisors (p := p) (d + 1)) + +theorem normalizedMarkoffPointsWithSmallFirstTwoRotationOrders_card_le_maximalDivisors + {p : ℕ} [Fact p.Prime] [Invertible (3 : ZMod p)] + (hpTwo : p ≠ 2) (bound : ℕ) : + (normalizedMarkoffPointsWithSmallFirstTwoRotationOrders p bound).card ≤ + 2 * (2 + (bound - 1) * maximalDivisorCountSum p bound) ^ 2 := by + calc + (normalizedMarkoffPointsWithSmallFirstTwoRotationOrders p bound).card ≤ + (normalizedMarkoffPointsWithFirstTwoCoordinatesIn + (concreteLowOrderTraceSet p bound)).card := + Finset.card_mono + (normalizedMarkoffPointsWithSmallFirstTwoRotationOrders_subset_traceSet + hpTwo bound) + _ ≤ 2 * (concreteLowOrderTraceSet p bound).card ^ 2 := + normalizedMarkoffPointsWithFirstTwoCoordinatesIn_card_le _ + _ ≤ 2 * (2 + (bound - 1) * + maximalDivisorCountSum p bound) ^ 2 := by + gcongr + exact concreteLowOrderTraceSet_card_le_maximalDivisors bound + +theorem puncturedMarkoffPointsWithSmallFirstTwoRotationOrders_succ_card_le_maximalDivisors + {p : ℕ} [Fact p.Prime] [Invertible (3 : ZMod p)] + (hpTwo : p ≠ 2) (d : ℕ) : + (puncturedMarkoffPointsWithSmallFirstTwoRotationOrders p (d + 1)).card ≤ + 2 * (2 + d * maximalDivisorCountSum p (d + 1)) ^ 2 := by + rw [puncturedMarkoffPointsWithSmallFirstTwoRotationOrders_card_eq_normalized] + exact + (normalizedPuncturedMarkoffPointsWithSmallFirstTwoRotationOrders_card_le_ambient + (d + 1)).trans + (by + simpa using + (normalizedMarkoffPointsWithSmallFirstTwoRotationOrders_card_le_maximalDivisors + (p := p) hpTwo (d + 1))) + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Assembly/MaximalDivisorMiddleGame.lean b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/MaximalDivisorMiddleGame.lean new file mode 100644 index 0000000000..a6805bea8d --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/MaximalDivisorMiddleGame.lean @@ -0,0 +1,146 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.MiddleGameThenEndgame +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.MaximalDivisorCorvajaZannierEscape + +/-! +# Maximal-divisor middle-game assembly + +This module lifts the maximal-order Corvaja--Zannier escape from a chosen +coordinate to the maximum of the three coordinate rotation orders. +-/ + +@[expose] public section + +namespace BGS.Markoff + +open BGS.NumberTheory + +noncomputable section + +/-- One middle-game step strictly increases the maximum coordinate order when +the two size inequalities use only divisibility-maximal candidate orders. -/ +theorem exists_sameNormalizedComponent_maximalOrder_increase_of_maximalDivisorBounds + (p : ℕ) [Fact p.Prime] [Invertible (3 : ZMod p)] + [Fintype (quadraticFiniteField p)] (hpTwo : p ≠ 2) + {delta : ℝ} (hdelta : delta ≤ (1 : ℝ) / 2) + (hBound : + WeightedTraceTorsionIntersectionBound p (quadraticFiniteField p)) + (x : NormalizedMarkoffSurface (ZMod p)) + (hbelow : (maximalCoordinateRotationOrder x.1 : ℝ) < + (p : ℝ) ^ ((1 : ℝ) / 2 + delta)) + (hcube : + (corvajaZannierCorollaryTwoSafeCoefficient * + (middleGameMaximalOrders p + (maximalCoordinateRotationOrder x.1)).card) ^ 3 < + maximalCoordinateRotationOrder x.1) + (hlinear : + corvajaZannierCorollaryTwoSafeCoefficient * + (middleGameMaximalOrders p + (maximalCoordinateRotationOrder x.1)).card * + maximalCoordinateRotationOrder x.1 < p) : + ∃ y : NormalizedMarkoffSurface (ZMod p), + SameNormalizedComponent x y ∧ + maximalCoordinateRotationOrder x.1 < + maximalCoordinateRotationOrder y.1 := by + obtain ⟨x', hxx', hx'Order⟩ := + exists_sameNormalizedComponent_firstRotation_eq_maximal x + have hx'Cube : + (corvajaZannierCorollaryTwoSafeCoefficient * + (middleGameMaximalOrders p (rotationOrder x'.1.u1)).card) ^ 3 < + rotationOrder x'.1.u1 := by + simpa [hx'Order] using hcube + have hx'Linear : + corvajaZannierCorollaryTwoSafeCoefficient * + (middleGameMaximalOrders p (rotationOrder x'.1.u1)).card * + rotationOrder x'.1.u1 < p := by + simpa [hx'Order] using hlinear + have hordersPos : + 0 < (middleGameMaximalOrders p (rotationOrder x'.1.u1)).card := by + apply Finset.card_pos.mpr + have hpPlus : p + 1 ≠ 0 := by omega + have honeBound : 1 < rotationOrder x'.1.u1 + 1 := by + exact Nat.lt_succ_of_le (rotationOrder_pos x'.1.u1) + obtain ⟨m, hm, _hmultiple⟩ := + exists_dvd_maximalDivisorBelow hpPlus (one_dvd (p + 1)) honeBound + refine ⟨m, ?_⟩ + rw [middleGameMaximalOrders, Finset.mem_union] + exact Or.inr hm + have hbase : + 4 < (corvajaZannierCorollaryTwoSafeCoefficient * + (middleGameMaximalOrders p (rotationOrder x'.1.u1)).card) ^ 3 := by + have hcoeff : corvajaZannierCorollaryTwoSafeCoefficient ≤ + corvajaZannierCorollaryTwoSafeCoefficient * + (middleGameMaximalOrders p (rotationOrder x'.1.u1)).card := by + simp only [corvajaZannierCorollaryTwoSafeCoefficient] + nlinarith + calc + 4 < corvajaZannierCorollaryTwoSafeCoefficient ^ 3 := by + norm_num [corvajaZannierCorollaryTwoSafeCoefficient] + _ ≤ (corvajaZannierCorollaryTwoSafeCoefficient * + (middleGameMaximalOrders p + (rotationOrder x'.1.u1)).card) ^ 3 := + Nat.pow_le_pow_left hcoeff 3 + have hx'AboveFour : 4 < rotationOrder x'.1.u1 := + hbase.trans hx'Cube + have hx'Below : (rotationOrder x'.1.u1 : ℝ) < + (p : ℝ) ^ ((1 : ℝ) / 2 + delta) := by + simpa [hx'Order] using hbelow + have hx'0 : x'.1.u1 ≠ 0 := by + intro hzero + have hle := rotationOrder_zero_le_four p + rw [hzero] at hx'AboveFour + omega + have hx'Nonparabolic : x'.1.u1 ^ 2 ≠ 4 := by + intro hparabolic + have hcases : x'.1.u1 = 2 ∨ x'.1.u1 = -2 := by + apply (sq_eq_sq_iff_eq_or_eq_neg).mp + calc + x'.1.u1 ^ 2 = 4 := hparabolic + _ = (2 : ZMod p) ^ 2 := by norm_num + have hpOne : (1 : ℝ) ≤ p := by + exact_mod_cast (show 1 ≤ p by exact (Fact.out : p.Prime).one_le) + have hexponentLe : (1 : ℝ) / 2 + delta ≤ 1 := by + linarith + have hrpowLe : + (p : ℝ) ^ ((1 : ℝ) / 2 + delta) ≤ (p : ℝ) := by + simpa using Real.rpow_le_rpow_of_exponent_le hpOne hexponentLe + rcases hcases with htwo | hnegTwo + · rw [htwo, rotationOrder_two] at hx'Below + linarith + · rw [hnegTwo, rotationOrder_neg_two p hpTwo] at hx'Below + have htwoP : ((2 * p : ℕ) : ℝ) = 2 * (p : ℝ) := by norm_num + rw [htwoP] at hx'Below + have hpPos : (0 : ℝ) < p := by positivity + linarith + obtain ⟨n, hnIncrease⟩ := + exists_iterate_with_larger_secondRotationOrder_of_weightedTraceBound_maximalOrders + p hpTwo delta hdelta x'.1 x'.property hx'0 hx'Nonparabolic hx'Below + hx'Cube hx'Linear hBound + let y := (normalizedRotate1Surface^[n]) x' + have hcoe : y.1 = (normalizedRotate1^[n]) x'.1 := + coe_iterate_normalizedRotate1Surface x' n + refine ⟨y, sameNormalizedComponent_trans hxx' + (sameNormalizedComponent_iterate_normalizedRotate1Surface x' n), ?_⟩ + rw [← hx'Order] + exact hnIncrease.trans_le <| by + have hmeasureEq : maximalCoordinateRotationOrder y.1 = + maximalCoordinateRotationOrder + ((normalizedRotate1^[n]) x'.1) := + congrArg maximalCoordinateRotationOrder hcoe + calc + rotationOrder ((normalizedRotate1^[n]) x'.1).u2 ≤ + maximalCoordinateRotationOrder + ((normalizedRotate1^[n]) x'.1) := + rotationOrder_second_le_maximalCoordinateRotationOrder _ + _ = maximalCoordinateRotationOrder y.1 := hmeasureEq.symm + +end + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Assembly/MaximalDivisorPuncturedTransitivity.lean b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/MaximalDivisorPuncturedTransitivity.lean new file mode 100644 index 0000000000..52f84aa795 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/MaximalDivisorPuncturedTransitivity.lean @@ -0,0 +1,240 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.ExplicitPuncturedTransitivity +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.MaximalDivisorLowOrderCount +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.MaximalDivisorMiddleGame + +/-! +# Punctured transitivity from the maximal-divisor frontier + +The maximal-orbit argument now uses the same maximal-divisor count in both +places where the published proof used all divisors: + +* counting points whose first two rotation orders are small; +* the Corvaja--Zannier union that forces an order increase. + +This is the idea-level endpoint. A separate arithmetic certificate can +discharge its two explicit inequalities using the joint `p - 1`, `p + 1` +square envelope. +-/ + +@[expose] public section + +namespace BGS.Markoff + +noncomputable section + +private def normalizedPuncturedPointMaximalDivisors + {R : Type*} [Field R] [Invertible (3 : R)] + (x : PuncturedMarkoffSurface R) : NormalizedMarkoffSurface R := + normalizedSurfaceOfPunctured (puncturedNormalizationEquiv R x) + +private theorem normalizedPuncturedPointMaximalDivisors_smul + {R : Type*} [Field R] [Invertible (3 : R)] + (g : Gamma R) (z : PuncturedMarkoffSurface R) : + normalizedPuncturedPointMaximalDivisors (g • z) = + normalizedGammaPerm R g + (normalizedPuncturedPointMaximalDivisors z) := by + have hzinv : + (normalizationSurfaceEquiv R).symm + (normalizedSurfaceOfPunctured + (puncturedNormalizationEquiv R z)) = z.1 := by + apply Subtype.ext + exact (normalizationEquiv R).symm_apply_apply z.1.1 + unfold normalizedPuncturedPointMaximalDivisors + rw [normalizedGammaPerm_apply, hzinv] + apply Subtype.ext + rfl + +/-- The finite maximal-orbit argument with maximal-divisor counts at both +small-order and middle-game boundaries. -/ +theorem puncturedMarkoffTransitiveAt_of_maximalDivisor_frontier + (p : ℕ) [Fact p.Prime] [Invertible (3 : ZMod p)] + (hpThree : 3 < p) + (c : PuncturedMarkoffSurface (ZMod p)) + (hcube : ∀ d : ℕ, 0 < d → + p ≤ 2 * (2 + d * maximalDivisorCountSum p (d + 1)) ^ 2 → + (corvajaZannierCorollaryTwoSafeCoefficient * + maximalDivisorCountSum p (d + 1)) ^ 3 < d) + (hlinear : ∀ d : ℕ, + (d : ℝ) < (p : ℝ) ^ (5 / 6 : ℝ) → + corvajaZannierCorollaryTwoSafeCoefficient * + maximalDivisorCountSum p (d + 1) * d < p) + (hlarge : ∀ z : NormalizedMarkoffSurface (ZMod p), + (p : ℝ) ^ (5 / 6 : ℝ) ≤ + maximalCoordinateRotationOrder z.1 → + SameNormalizedComponent + (normalizedSurfaceOfPunctured (puncturedNormalizationEquiv (ZMod p) c)) z) : + PuncturedMarkoffTransitiveAt p Fact.out := by + classical + have hpTwo : p ≠ 2 := by omega + letI : Fintype (quadraticFiniteField p) := Fintype.ofFinite _ + have hAll : ∀ x : PuncturedMarkoffSurface (ZMod p), + SamePuncturedComponent c x := by + intro x + by_contra hcx + let orderMeasure : PuncturedMarkoffSurface (ZMod p) → ℕ := fun w => + maximalCoordinateRotationOrder + (normalizedPuncturedPointMaximalDivisors w).1 + let orbitFinset := (puncturedGammaOrbit x).toFinite.toFinset + have hxMem : x ∈ orbitFinset := by + have hxOrbit : x ∈ puncturedGammaOrbit x := + samePuncturedComponent_refl x + simpa [orbitFinset] using hxOrbit + obtain ⟨z, hzMem, hzMax⟩ := + Finset.exists_max_image orbitFinset orderMeasure ⟨x, hxMem⟩ + let d := orderMeasure z + have hzComponent : SamePuncturedComponent x z := by + change z ∈ puncturedGammaOrbit x + simpa [orbitFinset] using hzMem + have hmax : ∀ w : PuncturedMarkoffSurface (ZMod p), + SamePuncturedComponent x w → orderMeasure w ≤ d := by + intro w hw + apply hzMax w + change w ∈ puncturedGammaOrbit x at hw + simpa [orbitFinset] using hw + have hdPos : 0 < d := by + have hfirstPos : 0 < + rotationOrder + (normalizedPuncturedPointMaximalDivisors z).1.u1 := + rotationOrder_pos _ + exact hfirstPos.trans_le <| by + simpa [d, orderMeasure] using + rotationOrder_first_le_maximalCoordinateRotationOrder + (normalizedPuncturedPointMaximalDivisors z).1 + have hnotBaseZ : ¬ SameNormalizedComponent + (normalizedPuncturedPointMaximalDivisors c) + (normalizedPuncturedPointMaximalDivisors z) := by + intro hcz + apply hcx + have hczPunctured : SamePuncturedComponent c z := + (samePuncturedComponent_iff_sameNormalizedComponent c z).2 hcz + exact samePuncturedComponent_trans hczPunctured + (samePuncturedComponent_symm hzComponent) + have hdUpper : (d : ℝ) < (p : ℝ) ^ (5 / 6 : ℝ) := by + by_contra hd + apply hnotBaseZ + apply hlarge (normalizedPuncturedPointMaximalDivisors z) + simpa [d, orderMeasure] using le_of_not_gt hd + have hpLeOrbit : p ≤ (puncturedGammaOrbit x).ncard := by + have horbitPos : 0 < (puncturedGammaOrbit x).ncard := + (Set.ncard_pos (Set.toFinite _)).2 + ⟨x, samePuncturedComponent_refl x⟩ + exact Nat.le_of_dvd horbitPos + (prime_dvd_puncturedGammaOrbit_ncard p hpThree x) + have horbitSmall : (puncturedGammaOrbit x).ncard ≤ + (puncturedMarkoffPointsWithSmallFirstTwoRotationOrders + p (d + 1)).card := by + rw [Set.ncard_eq_toFinset_card + (puncturedGammaOrbit x) (Set.toFinite _)] + apply Finset.card_le_card + intro w hwFinset + have hw : SamePuncturedComponent x w := by + change w ∈ puncturedGammaOrbit x + simpa [orbitFinset] using hwFinset + have hwMax := hmax w hw + have hfirst : + rotationOrder + (normalizedPuncturedPointMaximalDivisors w).1.u1 ≤ d := + (rotationOrder_first_le_maximalCoordinateRotationOrder + (normalizedPuncturedPointMaximalDivisors w).1).trans hwMax + have hsecond : + rotationOrder + (normalizedPuncturedPointMaximalDivisors w).1.u2 ≤ d := + (rotationOrder_second_le_maximalCoordinateRotationOrder + (normalizedPuncturedPointMaximalDivisors w).1).trans hwMax + change w ∈ + puncturedMarkoffPointsWithSmallFirstTwoRotationOrders p (d + 1) + rw [puncturedMarkoffPointsWithSmallFirstTwoRotationOrders, + mem_originalPuncturedFinsetOfNormalized_iff, + mem_normalizedPuncturedMarkoffPointsWithSmallFirstTwoRotationOrders_iff] + constructor + · simpa only [normalizedPuncturedPointMaximalDivisors, + normalizedSurfaceOfPunctured, + puncturedNormalizationEquiv_coe] using + Nat.lt_succ_of_le hfirst + · simpa only [normalizedPuncturedPointMaximalDivisors, + normalizedSurfaceOfPunctured, + puncturedNormalizationEquiv_coe] using + Nat.lt_succ_of_le hsecond + have hpLeSmallOrderSet : p ≤ + 2 * (2 + d * maximalDivisorCountSum p (d + 1)) ^ 2 := by + calc + p ≤ (puncturedGammaOrbit x).ncard := hpLeOrbit + _ ≤ (puncturedMarkoffPointsWithSmallFirstTwoRotationOrders + p (d + 1)).card := horbitSmall + _ ≤ 2 * (2 + d * + maximalDivisorCountSum p (d + 1)) ^ 2 := + puncturedMarkoffPointsWithSmallFirstTwoRotationOrders_succ_card_le_maximalDivisors + hpTwo d + have hcubeCount := + hcube d hdPos hpLeSmallOrderSet + have hlinearCount := hlinear d hdUpper + have hmaximalCard : + (middleGameMaximalOrders p d).card ≤ + maximalDivisorCountSum p (d + 1) := by + simpa [maximalDivisorCountSum] using + middleGameMaximalOrders_card_le p d + have hcoefficient : + corvajaZannierCorollaryTwoSafeCoefficient * + (middleGameMaximalOrders p d).card ≤ + corvajaZannierCorollaryTwoSafeCoefficient * + maximalDivisorCountSum p (d + 1) := + Nat.mul_le_mul_left + corvajaZannierCorollaryTwoSafeCoefficient hmaximalCard + have hcube' : + (corvajaZannierCorollaryTwoSafeCoefficient * + (middleGameMaximalOrders p d).card) ^ 3 < d := + (Nat.pow_le_pow_left hcoefficient 3).trans_lt hcubeCount + have hlinear' : + corvajaZannierCorollaryTwoSafeCoefficient * + (middleGameMaximalOrders p d).card * d < p := + (Nat.mul_le_mul_right d hcoefficient).trans_lt hlinearCount + obtain ⟨y, hzy, hincrease⟩ := + exists_sameNormalizedComponent_maximalOrder_increase_of_maximalDivisorBounds + p hpTwo (delta := (1 / 3 : ℝ)) (by norm_num) + (corvajaZannierWeightedTraceBound p (quadraticFiniteField p)) + (normalizedPuncturedPointMaximalDivisors z) + (by simpa only [show (1 / 2 + 1 / 3 : ℝ) = 5 / 6 by norm_num, + d, orderMeasure] using hdUpper) + (by simpa [d, orderMeasure] using hcube') + (by simpa [d, orderMeasure] using hlinear') + obtain ⟨g, hg⟩ := + (sameNormalizedComponent_iff_exists_gamma + (normalizedPuncturedPointMaximalDivisors z) y).1 hzy + let w : PuncturedMarkoffSurface (ZMod p) := g • z + have hwComponent : SamePuncturedComponent x w := + samePuncturedComponent_trans hzComponent + ((samePuncturedComponent_iff_exists z w).2 ⟨g, rfl⟩) + have hwNormalized : + normalizedPuncturedPointMaximalDivisors w = y := by + change normalizedPuncturedPointMaximalDivisors (g • z) = y + rw [normalizedPuncturedPointMaximalDivisors_smul] + exact hg + have hwMax := hmax w hwComponent + change maximalCoordinateRotationOrder + (normalizedPuncturedPointMaximalDivisors w).1 ≤ d at hwMax + rw [hwNormalized] at hwMax + have hincrease' : d < maximalCoordinateRotationOrder y.1 := by + simpa [d, orderMeasure] using hincrease + exact (not_lt_of_ge hwMax) hincrease' + intro a b + obtain ⟨ga, hga⟩ := + (samePuncturedComponent_iff_exists c a).1 (hAll a) + obtain ⟨gb, hgb⟩ := + (samePuncturedComponent_iff_exists c b).1 (hAll b) + refine ⟨gb * ga⁻¹, ?_⟩ + calc + (gb * ga⁻¹) • a = gb • (ga⁻¹ • a) := mul_smul _ _ _ + _ = gb • c := by rw [← hga]; simp + _ = b := hgb + +end + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Assembly/MiddleGameThenEndgame.lean b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/MiddleGameThenEndgame.lean new file mode 100644 index 0000000000..9b5553ab07 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/MiddleGameThenEndgame.lean @@ -0,0 +1,365 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Cage.Connectivity +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.CorvajaZannierEscape +public import LeanPool.MarkoffModP.BGS.Dynamics.StrictMeasureEscape + +/-! +# Iterating the middle-game escape to the cage +-/ + +@[expose] public section + +namespace BGS.Markoff + +open Filter + +noncomputable section + +/-- Maximum of the three coordinate rotation orders. -/ +def maximalCoordinateRotationOrder {R : Type*} [CommRing R] + (x : NormalizedPoint R) : ℕ := + max (rotationOrder x.u1) (max (rotationOrder x.u2) (rotationOrder x.u3)) + +theorem rotationOrder_first_le_maximalCoordinateRotationOrder + {R : Type*} [CommRing R] (x : NormalizedPoint R) : + rotationOrder x.u1 ≤ maximalCoordinateRotationOrder x := by + simp [maximalCoordinateRotationOrder] + +theorem rotationOrder_second_le_maximalCoordinateRotationOrder + {R : Type*} [CommRing R] (x : NormalizedPoint R) : + rotationOrder x.u2 ≤ maximalCoordinateRotationOrder x := by + simp [maximalCoordinateRotationOrder] + +theorem rotationOrder_third_le_maximalCoordinateRotationOrder + {R : Type*} [CommRing R] (x : NormalizedPoint R) : + rotationOrder x.u3 ≤ maximalCoordinateRotationOrder x := by + simp [maximalCoordinateRotationOrder] + +/-- A coordinate permutation puts a coordinate of maximum rotation order first. -/ +theorem exists_sameNormalizedComponent_firstRotation_eq_maximal + {R : Type*} [CommRing R] [Invertible (3 : R)] + (x : NormalizedMarkoffSurface R) : + ∃ y : NormalizedMarkoffSurface R, + SameNormalizedComponent x y ∧ + rotationOrder y.1.u1 = maximalCoordinateRotationOrder x.1 := by + by_cases hfirst : rotationOrder x.1.u2 ≤ rotationOrder x.1.u1 ∧ + rotationOrder x.1.u3 ≤ rotationOrder x.1.u1 + · refine ⟨x, sameNormalizedComponent_refl x, ?_⟩ + simp [maximalCoordinateRotationOrder, hfirst.1, hfirst.2] + · by_cases hsecond : rotationOrder x.1.u1 ≤ rotationOrder x.1.u2 ∧ + rotationOrder x.1.u3 ≤ rotationOrder x.1.u2 + · let y := normalizedSwap12Surface x + refine ⟨y, sameNormalizedComponent_swap12Surface x, ?_⟩ + simp [y, normalizedSwap12, maximalCoordinateRotationOrder, + hsecond.1, hsecond.2] + · have hthirdFirst : rotationOrder x.1.u1 ≤ rotationOrder x.1.u3 := by omega + have hthirdSecond : rotationOrder x.1.u2 ≤ rotationOrder x.1.u3 := by omega + let y := normalizedSwap12Surface (normalizedSwap23Surface x) + have hcomp := sameNormalizedComponent_trans + (sameNormalizedComponent_swap23Surface x) + (sameNormalizedComponent_swap12Surface (normalizedSwap23Surface x)) + refine ⟨y, hcomp, ?_⟩ + simp [y, normalizedSwap12, normalizedSwap23, maximalCoordinateRotationOrder, + hthirdFirst, hthirdSecond] + +/-- One genuine middle-game step strictly increases the maximum coordinate order. -/ +theorem exists_sameNormalizedComponent_maximalOrder_increase_of_middleRange + (p : ℕ) [Fact p.Prime] [Invertible (3 : ZMod p)] + [Fintype (quadraticFiniteField p)] (hpTwo : p ≠ 2) + {δ : ℝ} (hδ : 0 < δ) (hδQuarter : δ ≤ (1 : ℝ) / 4) + (hfour : (4 : ℝ) < (p : ℝ) ^ δ) + (hsize : ∀ currentOrder : ℕ, + (p : ℝ) ^ δ < currentOrder → + (currentOrder : ℝ) < (p : ℝ) ^ (1 - δ) → + (corvajaZannierCorollaryTwoSafeCoefficient * + ((p - 1).divisors.card + (p + 1).divisors.card)) ^ 3 < currentOrder ∧ + corvajaZannierCorollaryTwoSafeCoefficient * + ((p - 1).divisors.card + (p + 1).divisors.card) * currentOrder < p) + (hBound : WeightedTraceTorsionIntersectionBound p (quadraticFiniteField p)) + (x : NormalizedMarkoffSurface (ZMod p)) + (hlower : (p : ℝ) ^ δ < maximalCoordinateRotationOrder x.1) + (hbelow : (maximalCoordinateRotationOrder x.1 : ℝ) < + (p : ℝ) ^ ((1 : ℝ) / 2 + δ)) : + ∃ y : NormalizedMarkoffSurface (ZMod p), + SameNormalizedComponent x y ∧ + maximalCoordinateRotationOrder x.1 < maximalCoordinateRotationOrder y.1 := by + obtain ⟨x', hxx', hx'Order⟩ := + exists_sameNormalizedComponent_firstRotation_eq_maximal x + have hpOne : (1 : ℝ) ≤ p := by + exact_mod_cast (show 1 ≤ p by exact (Fact.out : p.Prime).one_le) + have hx'Lower : (p : ℝ) ^ δ < rotationOrder x'.1.u1 := by + simpa [hx'Order] using hlower + have hx'Below : (rotationOrder x'.1.u1 : ℝ) < + (p : ℝ) ^ ((1 : ℝ) / 2 + δ) := by + simpa [hx'Order] using hbelow + have hx'0 : x'.1.u1 ≠ 0 := by + intro hzero + have hle := rotationOrder_zero_le_four p + rw [hzero] at hx'Lower + have : (rotationOrder (0 : ZMod p) : ℝ) ≤ 4 := by exact_mod_cast hle + linarith + have hx'Nonparabolic : x'.1.u1 ^ 2 ≠ 4 := by + intro hparabolic + have hcases : x'.1.u1 = 2 ∨ x'.1.u1 = -2 := by + apply (sq_eq_sq_iff_eq_or_eq_neg).mp + calc + x'.1.u1 ^ 2 = 4 := hparabolic + _ = (2 : ZMod p) ^ 2 := by norm_num + have hexponentLe : (1 : ℝ) / 2 + δ ≤ 1 := by linarith + have hrpowLe : (p : ℝ) ^ ((1 : ℝ) / 2 + δ) ≤ (p : ℝ) := by + simpa using Real.rpow_le_rpow_of_exponent_le hpOne hexponentLe + rcases hcases with htwo | hnegTwo + · rw [htwo, rotationOrder_two] at hx'Below + linarith + · rw [hnegTwo, rotationOrder_neg_two p hpTwo] at hx'Below + have htwoP : (((2 * p : ℕ) : ℝ)) = 2 * (p : ℝ) := by norm_num + rw [htwoP] at hx'Below + have hpPos : (0 : ℝ) < p := by positivity + linarith + have hupperExponent : (1 : ℝ) / 2 + δ ≤ 1 - δ := by linarith + have hupperPower : (p : ℝ) ^ ((1 : ℝ) / 2 + δ) ≤ (p : ℝ) ^ (1 - δ) := + Real.rpow_le_rpow_of_exponent_le hpOne hupperExponent + have hx'Upper : (rotationOrder x'.1.u1 : ℝ) < (p : ℝ) ^ (1 - δ) := + hx'Below.trans_le hupperPower + obtain ⟨hcube, hlinear⟩ := hsize (rotationOrder x'.1.u1) hx'Lower hx'Upper + obtain ⟨n, hnIncrease⟩ := + exists_iterate_with_larger_secondRotationOrder_of_weightedTraceBound + p hpTwo δ (by linarith) x'.1 x'.property + hx'0 hx'Nonparabolic hx'Below hcube hlinear hBound + let y := (normalizedRotate1Surface^[n]) x' + have hcoe : y.1 = (normalizedRotate1^[n]) x'.1 := + coe_iterate_normalizedRotate1Surface x' n + refine ⟨y, sameNormalizedComponent_trans hxx' + (sameNormalizedComponent_iterate_normalizedRotate1Surface x' n), ?_⟩ + rw [← hx'Order] + exact hnIncrease.trans_le <| by + have hmeasureEq : maximalCoordinateRotationOrder y.1 = + maximalCoordinateRotationOrder ((normalizedRotate1^[n]) x'.1) := + congrArg maximalCoordinateRotationOrder hcoe + calc + rotationOrder ((normalizedRotate1^[n]) x'.1).u2 ≤ + maximalCoordinateRotationOrder ((normalizedRotate1^[n]) x'.1) := + rotationOrder_second_le_maximalCoordinateRotationOrder _ + _ = maximalCoordinateRotationOrder y.1 := hmeasureEq.symm + +/-- One middle-game step strictly increases the maximum coordinate order when the two +Corvaja--Zannier size inequalities are supplied directly. Unlike +`exists_sameNormalizedComponent_maximalOrder_increase_of_middleRange`, this interface does not +require a fixed lower power threshold for the current order. -/ +theorem exists_sameNormalizedComponent_maximalOrder_increase_of_directBounds + (p : ℕ) [Fact p.Prime] [Invertible (3 : ZMod p)] + [Fintype (quadraticFiniteField p)] (hpTwo : p ≠ 2) + {δ : ℝ} (hδ : δ ≤ (1 : ℝ) / 2) + (hBound : WeightedTraceTorsionIntersectionBound p (quadraticFiniteField p)) + (x : NormalizedMarkoffSurface (ZMod p)) + (hbelow : (maximalCoordinateRotationOrder x.1 : ℝ) < + (p : ℝ) ^ ((1 : ℝ) / 2 + δ)) + (hcube : + (corvajaZannierCorollaryTwoSafeCoefficient * + ((p - 1).divisors.card + (p + 1).divisors.card)) ^ 3 < + maximalCoordinateRotationOrder x.1) + (hlinear : + corvajaZannierCorollaryTwoSafeCoefficient * + ((p - 1).divisors.card + (p + 1).divisors.card) * + maximalCoordinateRotationOrder x.1 < p) : + ∃ y : NormalizedMarkoffSurface (ZMod p), + SameNormalizedComponent x y ∧ + maximalCoordinateRotationOrder x.1 < maximalCoordinateRotationOrder y.1 := by + obtain ⟨x', hxx', hx'Order⟩ := + exists_sameNormalizedComponent_firstRotation_eq_maximal x + have hx'Cube : + (corvajaZannierCorollaryTwoSafeCoefficient * + ((p - 1).divisors.card + (p + 1).divisors.card)) ^ 3 < + rotationOrder x'.1.u1 := by + simpa [hx'Order] using hcube + have hx'Linear : + corvajaZannierCorollaryTwoSafeCoefficient * + ((p - 1).divisors.card + (p + 1).divisors.card) * + rotationOrder x'.1.u1 < p := by + simpa [hx'Order] using hlinear + have hsumPos : + 0 < (p - 1).divisors.card + (p + 1).divisors.card := by + have hpPlus : p + 1 ≠ 0 := by omega + have hone : 1 ∈ (p + 1).divisors := Nat.one_mem_divisors.mpr hpPlus + have hcard : 0 < (p + 1).divisors.card := Finset.card_pos.mpr ⟨1, hone⟩ + omega + have hbase : + 4 < (corvajaZannierCorollaryTwoSafeCoefficient * + ((p - 1).divisors.card + (p + 1).divisors.card)) ^ 3 := by + have hcoeff : corvajaZannierCorollaryTwoSafeCoefficient ≤ + corvajaZannierCorollaryTwoSafeCoefficient * + ((p - 1).divisors.card + (p + 1).divisors.card) := by + simp only [corvajaZannierCorollaryTwoSafeCoefficient] + nlinarith + calc + 4 < corvajaZannierCorollaryTwoSafeCoefficient ^ 3 := by + norm_num [corvajaZannierCorollaryTwoSafeCoefficient] + _ ≤ (corvajaZannierCorollaryTwoSafeCoefficient * + ((p - 1).divisors.card + (p + 1).divisors.card)) ^ 3 := + Nat.pow_le_pow_left hcoeff 3 + have hx'AboveFour : 4 < rotationOrder x'.1.u1 := hbase.trans hx'Cube + have hx'Below : (rotationOrder x'.1.u1 : ℝ) < + (p : ℝ) ^ ((1 : ℝ) / 2 + δ) := by + simpa [hx'Order] using hbelow + have hx'0 : x'.1.u1 ≠ 0 := by + intro hzero + have hle := rotationOrder_zero_le_four p + rw [hzero] at hx'AboveFour + omega + have hx'Nonparabolic : x'.1.u1 ^ 2 ≠ 4 := by + intro hparabolic + have hcases : x'.1.u1 = 2 ∨ x'.1.u1 = -2 := by + apply (sq_eq_sq_iff_eq_or_eq_neg).mp + calc + x'.1.u1 ^ 2 = 4 := hparabolic + _ = (2 : ZMod p) ^ 2 := by norm_num + have hpOne : (1 : ℝ) ≤ p := by + exact_mod_cast (show 1 ≤ p by exact (Fact.out : p.Prime).one_le) + have hexponentLe : (1 : ℝ) / 2 + δ ≤ 1 := by linarith + have hrpowLe : (p : ℝ) ^ ((1 : ℝ) / 2 + δ) ≤ (p : ℝ) := by + simpa using Real.rpow_le_rpow_of_exponent_le hpOne hexponentLe + rcases hcases with htwo | hnegTwo + · rw [htwo, rotationOrder_two] at hx'Below + linarith + · rw [hnegTwo, rotationOrder_neg_two p hpTwo] at hx'Below + have htwoP : (((2 * p : ℕ) : ℝ)) = 2 * (p : ℝ) := by norm_num + rw [htwoP] at hx'Below + have hpPos : (0 : ℝ) < p := by positivity + linarith + obtain ⟨n, hnIncrease⟩ := + exists_iterate_with_larger_secondRotationOrder_of_weightedTraceBound + p hpTwo δ hδ x'.1 x'.property hx'0 hx'Nonparabolic hx'Below + hx'Cube hx'Linear hBound + let y := (normalizedRotate1Surface^[n]) x' + have hcoe : y.1 = (normalizedRotate1^[n]) x'.1 := + coe_iterate_normalizedRotate1Surface x' n + refine ⟨y, sameNormalizedComponent_trans hxx' + (sameNormalizedComponent_iterate_normalizedRotate1Surface x' n), ?_⟩ + rw [← hx'Order] + exact hnIncrease.trans_le <| by + have hmeasureEq : maximalCoordinateRotationOrder y.1 = + maximalCoordinateRotationOrder ((normalizedRotate1^[n]) x'.1) := + congrArg maximalCoordinateRotationOrder hcoe + calc + rotationOrder ((normalizedRotate1^[n]) x'.1).u2 ≤ + maximalCoordinateRotationOrder ((normalizedRotate1^[n]) x'.1) := + rotationOrder_second_le_maximalCoordinateRotationOrder _ + _ = maximalCoordinateRotationOrder y.1 := hmeasureEq.symm + +/-- Repeated weighted-trace escape steps reach the real endgame threshold. -/ +theorem exists_threshold_middleGame_reaches_endgame + (hBound : ∀ (p : ℕ) [Fact p.Prime] [Fintype (quadraticFiniteField p)], + WeightedTraceTorsionIntersectionBound p (quadraticFiniteField p)) + {δ : ℝ} (hδ : 0 < δ) (hδQuarter : δ ≤ (1 : ℝ) / 4) : + ∃ threshold : ℕ, ∀ p : ℕ, threshold ≤ p → [Fact p.Prime] → ∀ hpThree : p ≠ 3, + letI : Invertible (3 : ZMod p) := + invertibleOfNonzero (endgame_three_ne_zero_zmod_of_prime_ne_three p hpThree) + ∀ x : NormalizedMarkoffSurface (ZMod p), + (p : ℝ) ^ δ < maximalCoordinateRotationOrder x.1 → + ∃ y : NormalizedMarkoffSurface (ZMod p), + SameNormalizedComponent x y ∧ + (p : ℝ) ^ ((1 : ℝ) / 2 + δ) ≤ + maximalCoordinateRotationOrder y.1 := by + obtain ⟨sizeThreshold, hsizeThreshold⟩ := + eventually_atTop.mp (eventually_middleGame_corvajaZannier_sizeBounds hδ) + have hfourEventually : + ∀ᶠ p : ℕ in atTop, (4 : ℝ) < (p : ℝ) ^ δ := by + simpa using + (eventually_const_mul_rpow_lt_rpow + (C := (4 : ℝ)) (a := (0 : ℝ)) (b := δ) hδ) + obtain ⟨fourThreshold, hfourThreshold⟩ := eventually_atTop.mp hfourEventually + refine ⟨max (max sizeThreshold fourThreshold) 7, ?_⟩ + intro p hp _ hpThree + let : Invertible (3 : ZMod p) := + invertibleOfNonzero + (endgame_three_ne_zero_zmod_of_prime_ne_three p hpThree) + let : Fintype (quadraticFiniteField p) := Fintype.ofFinite _ + intro x hxLower + have hpSize : sizeThreshold ≤ p := + (le_max_left sizeThreshold fourThreshold).trans + ((le_max_left (max sizeThreshold fourThreshold) 7).trans hp) + have hpFour : fourThreshold ≤ p := + (le_max_right sizeThreshold fourThreshold).trans + ((le_max_left (max sizeThreshold fourThreshold) 7).trans hp) + have hsize := hsizeThreshold p hpSize + have hfour := hfourThreshold p hpFour + let endgameReal : ℝ := (p : ℝ) ^ ((1 : ℝ) / 2 + δ) + let target : ℕ := Nat.ceil endgameReal + let MiddleState := {q : NormalizedMarkoffSurface (ZMod p) // + (p : ℝ) ^ δ < maximalCoordinateRotationOrder q.1} + let start : MiddleState := ⟨x, hxLower⟩ + let r : MiddleState → MiddleState → Prop := fun q z => + SameNormalizedComponent q.1 z.1 + let measure : MiddleState → ℕ := fun q => maximalCoordinateRotationOrder q.1.1 + have hstep : ∀ q : MiddleState, measure q < target → + ∃ z : MiddleState, r q z ∧ measure q < measure z := by + intro q hqTarget + have hqBelow : (maximalCoordinateRotationOrder q.1.1 : ℝ) < endgameReal := by + exact (Nat.lt_ceil.mp hqTarget) + obtain ⟨z, hqz, hincrease⟩ := + exists_sameNormalizedComponent_maximalOrder_increase_of_middleRange + p (by omega) hδ hδQuarter hfour hsize (hBound p) q.1 q.2 hqBelow + exact ⟨⟨z, q.2.trans_le (by exact_mod_cast hincrease.le)⟩, hqz, hincrease⟩ + obtain ⟨finish, hchain, htarget⟩ := + BGS.exists_reflTransGen_measure_ge r measure target hstep start + have hcomponent : SameNormalizedComponent x finish.1 := by + have hchainComponent : ∀ {q z : MiddleState}, Relation.ReflTransGen r q z → + SameNormalizedComponent q.1 z.1 := by + intro q z hqz + induction hqz with + | refl => exact sameNormalizedComponent_refl q.1 + | tail hqa hab ih => + exact sameNormalizedComponent_trans ih hab + exact hchainComponent hchain + have hendgame : endgameReal ≤ (maximalCoordinateRotationOrder finish.1.1 : ℝ) := by + exact (Nat.ceil_le.mp htarget) + exact ⟨finish.1, hcomponent, hendgame⟩ + +/-- The weighted-trace middle-game bound, followed by the completed endgame, +lands every point above the opening threshold in the selected split cage. -/ +theorem exists_threshold_middleGame_to_splitCage + (hBound : ∀ (p : ℕ) [Fact p.Prime] [Fintype (quadraticFiniteField p)], + WeightedTraceTorsionIntersectionBound p (quadraticFiniteField p)) + (splitCoefficient : ℕ) + (hSplitWeil : WeightedSplitTraceWeilBoundAssumption splitCoefficient) + (nonsplitCoefficient : ℕ) + (hNonsplitWeil : SeededNonsplitTraceWeilBoundAssumption nonsplitCoefficient) + {δ : ℝ} (hδ : 0 < δ) (hδQuarter : δ ≤ (1 : ℝ) / 4) : + ∃ threshold : ℕ, ∀ p : ℕ, threshold ≤ p → [Fact p.Prime] → ∀ hpThree : p ≠ 3, + letI : Invertible (3 : ZMod p) := + invertibleOfNonzero (endgame_three_ne_zero_zmod_of_prime_ne_three p hpThree) + ∀ x : NormalizedMarkoffSurface (ZMod p), + (p : ℝ) ^ δ < maximalCoordinateRotationOrder x.1 → + ∃ y : NormalizedMarkoffSurface (ZMod p), + SameNormalizedComponent x y ∧ IsInSplitCage p y := by + obtain ⟨middleThreshold, hmiddle⟩ := + exists_threshold_middleGame_reaches_endgame hBound hδ hδQuarter + obtain ⟨endgameThreshold, hendgame⟩ := + exists_threshold_largeOrder_to_splitCage splitCoefficient hSplitWeil + nonsplitCoefficient hNonsplitWeil hδ + refine ⟨max middleThreshold endgameThreshold, ?_⟩ + intro p hp _ hpThree + let : Invertible (3 : ZMod p) := + invertibleOfNonzero (endgame_three_ne_zero_zmod_of_prime_ne_three p hpThree) + intro x hxLarge + have hpMiddle : middleThreshold ≤ p := (le_max_left _ _).trans hp + have hpEndgame : endgameThreshold ≤ p := (le_max_right _ _).trans hp + obtain ⟨z, hxz, hzLarge⟩ := hmiddle p hpMiddle hpThree x hxLarge + obtain ⟨z', hzz', hz'First⟩ := + exists_sameNormalizedComponent_firstRotation_eq_maximal z + have hz'Large : (p : ℝ) ^ ((1 : ℝ) / 2 + δ) ≤ rotationOrder z'.1.u1 := by + simpa [hz'First] using hzLarge + obtain ⟨y, hz'y, hyCage⟩ := hendgame p hpEndgame hpThree z' (Or.inl hz'Large) + exact ⟨y, sameNormalizedComponent_trans hxz + (sameNormalizedComponent_trans hzz' hz'y), hyCage⟩ + +end + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Assembly/NonparabolicBadComponent.lean b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/NonparabolicBadComponent.lean new file mode 100644 index 0000000000..241eb5e188 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/NonparabolicBadComponent.lean @@ -0,0 +1,68 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.GiantOrbit +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.ParabolicEscape + +/-! +# Nonparabolic coordinates outside the endgame component + +At the exponent used by the explicit route, a normalized parabolic trace has +rotation order at least `p ^ (5 / 6)`. Consequently, once every point at that +threshold is connected to a fixed base point, every point outside the base +component has nonparabolic coordinates. +-/ + +@[expose] public section + +namespace BGS.Markoff + +/-- A point outside a component containing every endgame-large point has +nonparabolic first and second coordinates. -/ +theorem first_two_nonparabolic_of_not_sameComponent_of_endgame_large_connected + {p : ℕ} [Fact p.Prime] [Invertible (3 : ZMod p)] + (hpTwo : p ≠ 2) + (base z : NormalizedMarkoffSurface (ZMod p)) + (hlarge : ∀ y : NormalizedMarkoffSurface (ZMod p), + (p : ℝ) ^ (5 / 6 : ℝ) ≤ maximalCoordinateRotationOrder y.1 → + SameNormalizedComponent base y) + (hnot : ¬ SameNormalizedComponent base z) : + z.1.u1 ^ 2 ≠ 4 ∧ z.1.u2 ^ 2 ≠ 4 := by + constructor + · intro hparabolic + apply hnot + apply hlarge z + have hcases := + (normalizedTrace_sq_eq_four_iff_parabolic p z.1.u1).mp hparabolic + have hthreshold := + endgamePowerThreshold_le_rotationOrder_of_parabolicTrace + p hpTwo (1 / 3 : ℝ) (by norm_num) z.1.u1 hcases + calc + (p : ℝ) ^ (5 / 6 : ℝ) = + (p : ℝ) ^ ((1 : ℝ) / 2 + 1 / 3) := by norm_num + _ ≤ (rotationOrder z.1.u1 : ℝ) := hthreshold + _ ≤ maximalCoordinateRotationOrder z.1 := by + exact_mod_cast + rotationOrder_first_le_maximalCoordinateRotationOrder z.1 + · intro hparabolic + apply hnot + apply hlarge z + have hcases := + (normalizedTrace_sq_eq_four_iff_parabolic p z.1.u2).mp hparabolic + have hthreshold := + endgamePowerThreshold_le_rotationOrder_of_parabolicTrace + p hpTwo (1 / 3 : ℝ) (by norm_num) z.1.u2 hcases + calc + (p : ℝ) ^ (5 / 6 : ℝ) = + (p : ℝ) ^ ((1 : ℝ) / 2 + 1 / 3) := by norm_num + _ ≤ (rotationOrder z.1.u2 : ℝ) := hthreshold + _ ≤ maximalCoordinateRotationOrder z.1 := by + exact_mod_cast + rotationOrder_second_le_maximalCoordinateRotationOrder z.1 + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Assembly/NonparabolicComplementFrontier.lean b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/NonparabolicComplementFrontier.lean new file mode 100644 index 0000000000..d6a160d21f --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/NonparabolicComplementFrontier.lean @@ -0,0 +1,385 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.NonparabolicBadComponent +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.NonparabolicPuncturedSmallOrderCount +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.OrbitDivisibility +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.PairedMaximalDivisorMiddleGame +public import LeanPool.MarkoffModP.BGS.Markoff.Core.EvenSignAction + +/-! +# Nonparabolic complement frontier + +Instead of maximizing the rotation order on one bad orbit, this route +maximizes it on the entire complement of a fixed punctured component. That +complement is Vieta-invariant, so its cardinality is divisible by `p`. +Assuming the expected even-sign divisibility by four, every nonempty +complement therefore has at least `4 * p` points. + +The parabolic endgame bridge puts the whole complement in the +fixed-point-free small-order set. Consequently its maximal order `d` forces + +`8 * p ≤ (d * M) ^ 2`, + +with no additive parabolic correction. +-/ + +@[expose] public section + +namespace BGS.Markoff + +open BGS.NumberTheory + +noncomputable section + +/-- The finite complement of the punctured component of `c`. -/ +def puncturedComponentComplementFinset + (p : ℕ) [Fact p.Prime] + (c : PuncturedMarkoffSurface (ZMod p)) : + Finset (PuncturedMarkoffSurface (ZMod p)) := by + classical + exact Finset.univ.filter fun x => ¬ SamePuncturedComponent c x + +@[simp] +theorem mem_puncturedComponentComplementFinset_iff + {p : ℕ} [Fact p.Prime] + {c x : PuncturedMarkoffSurface (ZMod p)} : + x ∈ puncturedComponentComplementFinset p c ↔ + ¬ SamePuncturedComponent c x := by + classical + simp [puncturedComponentComplementFinset] + +theorem puncturedComponentComplementFinset_vieta1_mem_iff + {p : ℕ} [Fact p.Prime] + (c x : PuncturedMarkoffSurface (ZMod p)) : + vieta1PuncturedPerm (ZMod p) x ∈ + puncturedComponentComplementFinset p c ↔ + x ∈ puncturedComponentComplementFinset p c := by + rw [mem_puncturedComponentComplementFinset_iff, + mem_puncturedComponentComplementFinset_iff] + constructor + · intro hnot hcx + apply hnot + exact samePuncturedComponent_trans hcx + (samePuncturedComponent_vieta1 x) + · intro hnot hcv + apply hnot + exact samePuncturedComponent_trans hcv + (samePuncturedComponent_symm (samePuncturedComponent_vieta1 x)) + +theorem puncturedComponentComplementFinset_vieta2_mem_iff + {p : ℕ} [Fact p.Prime] + (c x : PuncturedMarkoffSurface (ZMod p)) : + vieta2PuncturedPerm (ZMod p) x ∈ + puncturedComponentComplementFinset p c ↔ + x ∈ puncturedComponentComplementFinset p c := by + rw [mem_puncturedComponentComplementFinset_iff, + mem_puncturedComponentComplementFinset_iff] + constructor + · intro hnot hcx + apply hnot + exact samePuncturedComponent_trans hcx + (samePuncturedComponent_vieta2 x) + · intro hnot hcv + apply hnot + exact samePuncturedComponent_trans hcv + (samePuncturedComponent_symm (samePuncturedComponent_vieta2 x)) + +theorem puncturedComponentComplementFinset_vieta3_mem_iff + {p : ℕ} [Fact p.Prime] + (c x : PuncturedMarkoffSurface (ZMod p)) : + vieta3PuncturedPerm (ZMod p) x ∈ + puncturedComponentComplementFinset p c ↔ + x ∈ puncturedComponentComplementFinset p c := by + rw [mem_puncturedComponentComplementFinset_iff, + mem_puncturedComponentComplementFinset_iff] + constructor + · intro hnot hcx + apply hnot + exact samePuncturedComponent_trans hcx + (samePuncturedComponent_vieta3 x) + · intro hnot hcv + apply hnot + exact samePuncturedComponent_trans hcv + (samePuncturedComponent_symm (samePuncturedComponent_vieta3 x)) + +/-- The complement of one component is itself Vieta-invariant, hence its +cardinality is divisible by the characteristic prime. -/ +theorem prime_dvd_puncturedComponentComplementFinset_card + (p : ℕ) [Fact p.Prime] (hpThree : 3 < p) + (c : PuncturedMarkoffSurface (ZMod p)) : + p ∣ (puncturedComponentComplementFinset p c).card := by + have htwo : (2 : ZMod p) ≠ 0 := by + intro hzero + have hpDvd : p ∣ 2 := (ZMod.natCast_eq_zero_iff 2 p).mp hzero + exact (Nat.not_dvd_of_pos_of_lt (by omega) (by omega)) hpDvd + have hthree : (3 : ZMod p) ≠ 0 := by + intro hzero + have hpDvd : p ∣ 3 := (ZMod.natCast_eq_zero_iff 3 p).mp hzero + exact (Nat.not_dvd_of_pos_of_lt (by omega) hpThree) hpDvd + apply (ZMod.natCast_eq_zero_iff _ _).mp + exact card_cast_eq_zero_of_vieta_invariant htwo hthree + (puncturedComponentComplementFinset p c) + (puncturedComponentComplementFinset_vieta1_mem_iff c) + (puncturedComponentComplementFinset_vieta2_mem_iff c) + (puncturedComponentComplementFinset_vieta3_mem_iff c) + +/-- Combining Vieta `p`-divisibility with a supplied even-sign +four-divisibility gives the exact `4 * p` lower bound for a nonempty +component complement. -/ +theorem four_mul_prime_le_puncturedComponentComplementFinset_card + (p : ℕ) [Fact p.Prime] (hpThree : 3 < p) + (c : PuncturedMarkoffSurface (ZMod p)) + (hnonempty : (puncturedComponentComplementFinset p c).Nonempty) + (hfour : 4 ∣ (puncturedComponentComplementFinset p c).card) : + 4 * p ≤ (puncturedComponentComplementFinset p c).card := by + have hpOdd : Odd p := + (Fact.out : p.Prime).odd_of_ne_two (by omega) + have hcoprime : Nat.Coprime 4 p := by + simpa using + hpOdd.coprime_two_left.mul_left hpOdd.coprime_two_left + have hdiv : + 4 * p ∣ (puncturedComponentComplementFinset p c).card := + hcoprime.mul_dvd_of_dvd_of_dvd hfour + (prime_dvd_puncturedComponentComplementFinset_card p hpThree c) + exact Nat.le_of_dvd (Finset.card_pos.mpr hnonempty) hdiv + +private def normalizedPuncturedPointNonparabolicComplement + {R : Type*} [Field R] [Invertible (3 : R)] + (x : PuncturedMarkoffSurface R) : NormalizedMarkoffSurface R := + normalizedSurfaceOfPunctured (puncturedNormalizationEquiv R x) + +private theorem normalizedPuncturedPointNonparabolicComplement_smul + {R : Type*} [Field R] [Invertible (3 : R)] + (g : Gamma R) (z : PuncturedMarkoffSurface R) : + normalizedPuncturedPointNonparabolicComplement (g • z) = + normalizedGammaPerm R g + (normalizedPuncturedPointNonparabolicComplement z) := by + have hzinv : + (normalizationSurfaceEquiv R).symm + (normalizedSurfaceOfPunctured + (puncturedNormalizationEquiv R z)) = z.1 := by + apply Subtype.ext + exact (normalizationEquiv R).symm_apply_apply z.1.1 + unfold normalizedPuncturedPointNonparabolicComplement + rw [normalizedGammaPerm_apply, hzinv] + apply Subtype.ext + rfl + +/-- Complement-maximal paired frontier with the fixed-point-free low-order +count. The even-sign action is kept explicit: `hsign` records invariance of +the component complement, while `hfour` supplies the remaining free-action +cardinality consequence. -/ +theorem + puncturedMarkoffTransitiveAt_of_nonparabolicComplement_pairedMaximalDivisor_frontier + (p : ℕ) [Fact p.Prime] [Invertible (3 : ZMod p)] + (hpThree : 3 < p) + (c : PuncturedMarkoffSurface (ZMod p)) + (hcube : ∀ d : ℕ, 0 < d → + 8 * p ≤ + (d * maximalDivisorCountSum p (d + 1)) ^ 2 → + (6 * maximalDivisorCountSum p (d + 1)) ^ 3 < d) + (hlinear : ∀ d : ℕ, + (d : ℝ) < (p : ℝ) ^ (5 / 6 : ℝ) → + 24 * maximalDivisorCountSum p (d + 1) * d < p) + (hlarge : ∀ z : NormalizedMarkoffSurface (ZMod p), + (p : ℝ) ^ (5 / 6 : ℝ) ≤ + maximalCoordinateRotationOrder z.1 → + SameNormalizedComponent + (normalizedSurfaceOfPunctured (puncturedNormalizationEquiv (ZMod p) c)) z) + (hsign : ∀ (s : EvenSign) + (x : PuncturedMarkoffSurface (ZMod p)), + s • x ∈ puncturedComponentComplementFinset p c ↔ + x ∈ puncturedComponentComplementFinset p c) + (hfour : 4 ∣ (puncturedComponentComplementFinset p c).card) : + PuncturedMarkoffTransitiveAt p Fact.out := by + classical + have hpTwo : p ≠ 2 := by omega + let : Fintype (quadraticFiniteField p) := Fintype.ofFinite _ + have hAll : ∀ x : PuncturedMarkoffSurface (ZMod p), + SamePuncturedComponent c x := by + intro x + by_contra hcx + let bad := puncturedComponentComplementFinset p c + have hxBad : x ∈ bad := by + simpa [bad] using hcx + have hbadNonempty : bad.Nonempty := by + refine ⟨(1 : EvenSign) • x, ?_⟩ + exact (by simpa [bad] using (hsign (1 : EvenSign) x).2 hxBad) + let orderMeasure : PuncturedMarkoffSurface (ZMod p) → ℕ := fun w => + maximalCoordinateRotationOrder + (normalizedPuncturedPointNonparabolicComplement w).1 + obtain ⟨z, hzBad, hzMax⟩ := + Finset.exists_max_image bad orderMeasure hbadNonempty + let d := orderMeasure z + have hmax : ∀ w : PuncturedMarkoffSurface (ZMod p), + w ∈ bad → orderMeasure w ≤ d := by + intro w hw + exact hzMax w hw + have hzNotComponent : ¬ SamePuncturedComponent c z := by + simpa [bad] using hzBad + have hdPos : 0 < d := by + have hfirstPos : 0 < + rotationOrder + (normalizedPuncturedPointNonparabolicComplement z).1.u1 := + rotationOrder_pos _ + exact hfirstPos.trans_le <| by + simpa [d, orderMeasure] using + rotationOrder_first_le_maximalCoordinateRotationOrder + (normalizedPuncturedPointNonparabolicComplement z).1 + have hnotBaseZ : ¬ SameNormalizedComponent + (normalizedPuncturedPointNonparabolicComplement c) + (normalizedPuncturedPointNonparabolicComplement z) := by + intro hcz + apply hzNotComponent + exact + (samePuncturedComponent_iff_sameNormalizedComponent c z).2 hcz + have hdUpper : (d : ℝ) < (p : ℝ) ^ (5 / 6 : ℝ) := by + by_contra hd + apply hnotBaseZ + apply hlarge (normalizedPuncturedPointNonparabolicComplement z) + simpa [d, orderMeasure] using le_of_not_gt hd + have hbadSmall : + bad.card ≤ + (puncturedMarkoffPointsWithSmallNonparabolicFirstTwoRotationOrders + p (d + 1)).card := by + apply Finset.card_le_card + intro w hwBad + have hwNotComponent : ¬ SamePuncturedComponent c w := by + simpa [bad] using hwBad + have hwNotBase : ¬ SameNormalizedComponent + (normalizedPuncturedPointNonparabolicComplement c) + (normalizedPuncturedPointNonparabolicComplement w) := by + intro hcw + apply hwNotComponent + exact + (samePuncturedComponent_iff_sameNormalizedComponent c w).2 hcw + have hnonparabolic := + first_two_nonparabolic_of_not_sameComponent_of_endgame_large_connected + hpTwo + (normalizedPuncturedPointNonparabolicComplement c) + (normalizedPuncturedPointNonparabolicComplement w) + hlarge hwNotBase + have hwMax := hmax w hwBad + have hfirst : + rotationOrder + (normalizedPuncturedPointNonparabolicComplement w).1.u1 ≤ d := + (rotationOrder_first_le_maximalCoordinateRotationOrder + (normalizedPuncturedPointNonparabolicComplement w).1).trans hwMax + have hsecond : + rotationOrder + (normalizedPuncturedPointNonparabolicComplement w).1.u2 ≤ d := + (rotationOrder_second_le_maximalCoordinateRotationOrder + (normalizedPuncturedPointNonparabolicComplement w).1).trans hwMax + change w ∈ + puncturedMarkoffPointsWithSmallNonparabolicFirstTwoRotationOrders + p (d + 1) + rw [ + puncturedMarkoffPointsWithSmallNonparabolicFirstTwoRotationOrders, + mem_originalPuncturedFinsetOfNormalized_iff, + mem_normalizedPuncturedMarkoffPointsWithSmallNonparabolicFirstTwoRotationOrders_iff + ] + refine ⟨?_, ?_, ?_, ?_⟩ + · simpa only [normalizedPuncturedPointNonparabolicComplement, + normalizedSurfaceOfPunctured, + puncturedNormalizationEquiv_coe] using Nat.lt_succ_of_le hfirst + · simpa only [normalizedPuncturedPointNonparabolicComplement, + normalizedSurfaceOfPunctured, + puncturedNormalizationEquiv_coe] using Nat.lt_succ_of_le hsecond + · simpa only [normalizedPuncturedPointNonparabolicComplement, + normalizedSurfaceOfPunctured, + puncturedNormalizationEquiv_coe] using hnonparabolic.1 + · simpa only [normalizedPuncturedPointNonparabolicComplement, + normalizedSurfaceOfPunctured, + puncturedNormalizationEquiv_coe] using hnonparabolic.2 + have hfourPLeBad : 4 * p ≤ bad.card := by + apply four_mul_prime_le_puncturedComponentComplementFinset_card + p hpThree c + · simpa [bad] using hbadNonempty + · exact hfour + have heightPLeSmallOrderSquare : + 8 * p ≤ + (d * maximalDivisorCountSum p (d + 1)) ^ 2 := by + calc + 8 * p = 2 * (4 * p) := by ring + _ ≤ 2 * bad.card := Nat.mul_le_mul_left 2 hfourPLeBad + _ ≤ 2 * + (puncturedMarkoffPointsWithSmallNonparabolicFirstTwoRotationOrders + p (d + 1)).card := + Nat.mul_le_mul_left 2 hbadSmall + _ ≤ (d * maximalDivisorCountSum p (d + 1)) ^ 2 := + two_mul_puncturedSmallNonparabolicOrder_succ_card_le_maximalDivisors + hpTwo d + have hcubeCount := hcube d hdPos heightPLeSmallOrderSquare + have hlinearCount := hlinear d hdUpper + have hmaximalCard : + (middleGameMaximalOrders p d).card ≤ + maximalDivisorCountSum p (d + 1) := by + simpa [maximalDivisorCountSum] using + middleGameMaximalOrders_card_le p d + have hrootCoefficient : + 6 * (middleGameMaximalOrders p d).card ≤ + 6 * maximalDivisorCountSum p (d + 1) := + Nat.mul_le_mul_left 6 hmaximalCard + have hlinearCoefficient : + 24 * (middleGameMaximalOrders p d).card ≤ + 24 * maximalDivisorCountSum p (d + 1) := + Nat.mul_le_mul_left 24 hmaximalCard + have hcube' : + (6 * (middleGameMaximalOrders p d).card) ^ 3 < d := + (Nat.pow_le_pow_left hrootCoefficient 3).trans_lt hcubeCount + have hlinear' : + 24 * (middleGameMaximalOrders p d).card * d < p := + (Nat.mul_le_mul_right d hlinearCoefficient).trans_lt hlinearCount + obtain ⟨y, hzy, hincrease⟩ := + exists_sameNormalizedComponent_maximalOrder_increase_of_pairedMaximalDivisorBounds + p hpTwo (delta := (1 / 3 : ℝ)) (by norm_num) + (normalizedPuncturedPointNonparabolicComplement z) + (by simpa only [show (1 / 2 + 1 / 3 : ℝ) = 5 / 6 by norm_num, + d, orderMeasure] using hdUpper) + (by simpa [d, orderMeasure] using hcube') + (by simpa [d, orderMeasure] using hlinear') + obtain ⟨g, hg⟩ := + (sameNormalizedComponent_iff_exists_gamma + (normalizedPuncturedPointNonparabolicComplement z) y).1 hzy + let w : PuncturedMarkoffSurface (ZMod p) := g • z + have hzw : SamePuncturedComponent z w := + (samePuncturedComponent_iff_exists z w).2 ⟨g, rfl⟩ + have hwBad : w ∈ bad := by + rw [show bad = puncturedComponentComplementFinset p c by rfl, + mem_puncturedComponentComplementFinset_iff] + intro hcw + apply hzNotComponent + exact samePuncturedComponent_trans hcw + (samePuncturedComponent_symm hzw) + have hwNormalized : + normalizedPuncturedPointNonparabolicComplement w = y := by + change normalizedPuncturedPointNonparabolicComplement (g • z) = y + rw [normalizedPuncturedPointNonparabolicComplement_smul] + exact hg + have hwMax := hmax w hwBad + change maximalCoordinateRotationOrder + (normalizedPuncturedPointNonparabolicComplement w).1 ≤ d at hwMax + rw [hwNormalized] at hwMax + have hincrease' : d < maximalCoordinateRotationOrder y.1 := by + simpa [d, orderMeasure] using hincrease + exact (not_lt_of_ge hwMax) hincrease' + intro a b + obtain ⟨ga, hga⟩ := + (samePuncturedComponent_iff_exists c a).1 (hAll a) + obtain ⟨gb, hgb⟩ := + (samePuncturedComponent_iff_exists c b).1 (hAll b) + refine ⟨gb * ga⁻¹, ?_⟩ + calc + (gb * ga⁻¹) • a = gb • (ga⁻¹ • a) := mul_smul _ _ _ + _ = gb • c := by rw [← hga]; simp + _ = b := hgb + +end + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Assembly/NonparabolicMaximalDivisorConcreteCount.lean b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/NonparabolicMaximalDivisorConcreteCount.lean new file mode 100644 index 0000000000..21f06a2ffb --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/NonparabolicMaximalDivisorConcreteCount.lean @@ -0,0 +1,142 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.FixedPointFreeMaximalDivisorTraceCount + +/-! +# Fixed-point-free low-order traces on the two rotation tori + +The nonparabolic low-order trace set omits the global parabolic set and uses +only eigenvalues whose square is not one. Inversion is therefore +fixed-point-free on both the split and norm-one sources, giving + +`2 * |nonparabolic low traces| ≤ (bound - 1) * M`. +-/ + +@[expose] public section + +namespace BGS.Markoff + +open BGS.NumberTheory + +noncomputable section + +/-- Nonparabolic bounded-order traces represented in either the split torus +or the quadratic norm-one torus. -/ +def nonparabolicConcreteLowOrderTraceSet + (p : ℕ) [Fact p.Prime] (bound : ℕ) : Finset (ZMod p) := by + classical + exact + nonTwoTorsionBoundedOrderTraceSet + (splitTorusTrace : (ZMod p)ˣ → ZMod p) bound ∪ + nonTwoTorsionBoundedOrderTraceSet + (quadraticNormOneTrace p) bound + +/-- Every nonparabolic trace of small rotation order lies in the +fixed-point-free concrete trace set. -/ +theorem mem_nonparabolicConcreteLowOrderTraceSet_of_rotationOrder_lt + {p : ℕ} [Fact p.Prime] + (hpTwo : p ≠ 2) (t : ZMod p) (bound : ℕ) + (hnonparabolic : t ^ 2 ≠ 4) + (hsmall : rotationOrder t < bound) : + t ∈ nonparabolicConcreteLowOrderTraceSet p bound := by + classical + rcases exists_split_or_quadraticNormOneTrace + p hpTwo t hnonparabolic with + ⟨w, htrace, hw⟩ | ⟨w, htrace, hw⟩ + · rw [nonparabolicConcreteLowOrderTraceSet, Finset.mem_union] + apply Or.inl + rw [nonTwoTorsionBoundedOrderTraceSet, Finset.mem_image] + refine ⟨w, Finset.mem_filter.mpr ⟨Finset.mem_univ _, ?_, ?_⟩, + htrace⟩ + · rw [← rotationOrder_splitTorusTrace w hw, htrace] + exact hsmall + · intro hsq + apply hw + simpa using congrArg (fun u : (ZMod p)ˣ ↦ (u : ZMod p)) hsq + · rw [nonparabolicConcreteLowOrderTraceSet, Finset.mem_union] + apply Or.inr + rw [nonTwoTorsionBoundedOrderTraceSet, Finset.mem_image] + refine ⟨w, Finset.mem_filter.mpr ⟨Finset.mem_univ _, ?_, ?_⟩, + htrace⟩ + · rw [← rotationOrder_quadraticNormOneTrace p w hw, htrace] + exact hsmall + · intro hsq + apply hw + simpa using congrArg + (fun u : quadraticNormOneTorus p ↦ + (((u : (quadraticFiniteField p)ˣ) : + quadraticFiniteField p))) hsq + +/-- The exact fixed-point-free maximal-divisor trace count. -/ +theorem two_mul_nonparabolicConcreteLowOrderTraceSet_card_le + {p : ℕ} [Fact p.Prime] (bound : ℕ) : + 2 * (nonparabolicConcreteLowOrderTraceSet p bound).card ≤ + (bound - 1) * maximalDivisorCountSum p bound := by + classical + let splitSet := + nonTwoTorsionBoundedOrderTraceSet + (splitTorusTrace : (ZMod p)ˣ → ZMod p) bound + let nonsplitSet := + nonTwoTorsionBoundedOrderTraceSet + (quadraticNormOneTrace p) bound + have hsplit : + 2 * splitSet.card ≤ + (bound - 1) * + (maximalDivisorsBelow + (Fintype.card (ZMod p)ˣ) bound).card := by + exact + two_mul_nonTwoTorsionBoundedOrderTraceSet_card_le_maximalDivisors + (splitTorusTrace : (ZMod p)ˣ → ZMod p) bound + (splitTorusTrace_inv (ZMod p)) + have hnonsplit : + 2 * nonsplitSet.card ≤ + (bound - 1) * + (maximalDivisorsBelow + (Fintype.card (quadraticNormOneTorus p)) bound).card := by + exact + two_mul_nonTwoTorsionBoundedOrderTraceSet_card_le_maximalDivisors + (quadraticNormOneTrace p) bound + (quadraticNormOneTrace_inv p) + have hsplitCard : Fintype.card (ZMod p)ˣ = p - 1 := by + rw [← Nat.card_eq_fintype_card, Nat.card_units, Nat.card_zmod] + have hnonsplitCard : + Fintype.card (quadraticNormOneTorus p) = p + 1 := by + rw [← Nat.card_eq_fintype_card, quadraticNormOneTorus_natCard] + calc + 2 * (nonparabolicConcreteLowOrderTraceSet p bound).card ≤ + 2 * (splitSet.card + nonsplitSet.card) := by + apply Nat.mul_le_mul_left + simpa [nonparabolicConcreteLowOrderTraceSet, splitSet, nonsplitSet] using + (Finset.card_union_le splitSet nonsplitSet) + _ = 2 * splitSet.card + 2 * nonsplitSet.card := by ring + _ ≤ (bound - 1) * + (maximalDivisorsBelow + (Fintype.card (ZMod p)ˣ) bound).card + + (bound - 1) * + (maximalDivisorsBelow + (Fintype.card (quadraticNormOneTorus p)) bound).card := by + omega + _ = (bound - 1) * maximalDivisorCountSum p bound := by + rw [hsplitCard, hnonsplitCard] + simp only [maximalDivisorCountSum, Nat.mul_add] + +/-- At `bound = d + 1`, the fixed-point-free trace estimate has the exact +coefficient `d`. -/ +theorem two_mul_nonparabolicConcreteLowOrderTraceSet_succ_card_le + {p : ℕ} [Fact p.Prime] (d : ℕ) : + 2 * + (nonparabolicConcreteLowOrderTraceSet p (d + 1)).card ≤ + d * maximalDivisorCountSum p (d + 1) := by + simpa using + (two_mul_nonparabolicConcreteLowOrderTraceSet_card_le + (p := p) (d + 1)) + +end + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Assembly/NonparabolicPuncturedSmallOrderCount.lean b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/NonparabolicPuncturedSmallOrderCount.lean new file mode 100644 index 0000000000..1cf7c9a1a6 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/NonparabolicPuncturedSmallOrderCount.lean @@ -0,0 +1,143 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.NonparabolicMaximalDivisorConcreteCount +public import LeanPool.MarkoffModP.BGS.Markoff.Core.PuncturedNormalization + +/-! +# Fixed-point-free small-order counts on the punctured surface + +Restricting both counted coordinates to nonparabolic traces removes the +two-torsion correction from the torus trace count. The resulting transported +punctured set satisfies + +`2 * |small nonparabolic points| ≤ ((bound - 1) * M) ^ 2`. +-/ + +@[expose] public section + +namespace BGS.Markoff + +noncomputable section + +/-- Normalized punctured points whose first two coordinates are both +nonparabolic and have rotation order below `bound`. -/ +def normalizedPuncturedMarkoffPointsWithSmallNonparabolicFirstTwoRotationOrders + (p : ℕ) [Fact p.Prime] [Invertible (3 : ZMod p)] (bound : ℕ) : + Finset ↥(normalizedPuncturedSurface (ZMod p)) := by + classical + exact Finset.univ.filter fun x => + rotationOrder x.1.u1 < bound ∧ + rotationOrder x.1.u2 < bound ∧ + x.1.u1 ^ 2 ≠ 4 ∧ x.1.u2 ^ 2 ≠ 4 + +@[simp] +theorem mem_normalizedPuncturedMarkoffPointsWithSmallNonparabolicFirstTwoRotationOrders_iff + {p : ℕ} [Fact p.Prime] [Invertible (3 : ZMod p)] {bound : ℕ} + {x : ↥(normalizedPuncturedSurface (ZMod p))} : + x ∈ + normalizedPuncturedMarkoffPointsWithSmallNonparabolicFirstTwoRotationOrders + p bound ↔ + rotationOrder x.1.u1 < bound ∧ + rotationOrder x.1.u2 < bound ∧ + x.1.u1 ^ 2 ≠ 4 ∧ x.1.u2 ^ 2 ≠ 4 := by + classical + simp + [normalizedPuncturedMarkoffPointsWithSmallNonparabolicFirstTwoRotationOrders] + +/-- Forgetting the puncture embeds the nonparabolic small-order set into the +ambient set cut out by the fixed-point-free trace set. -/ +theorem normalizedPuncturedSmallNonparabolicOrderValues_subset_traceSet + {p : ℕ} [Fact p.Prime] [Invertible (3 : ZMod p)] + (hpTwo : p ≠ 2) (bound : ℕ) : + (normalizedPuncturedMarkoffPointsWithSmallNonparabolicFirstTwoRotationOrders + p bound).map ⟨Subtype.val, Subtype.val_injective⟩ ⊆ + normalizedMarkoffPointsWithFirstTwoCoordinatesIn + (nonparabolicConcreteLowOrderTraceSet p bound) := by + intro x hx + obtain ⟨y, hy, rfl⟩ := Finset.mem_map.mp hx + rw [ + mem_normalizedPuncturedMarkoffPointsWithSmallNonparabolicFirstTwoRotationOrders_iff + ] at hy + exact mem_normalizedMarkoffPointsWithFirstTwoCoordinatesIn_iff.mpr + ⟨y.2.1, + mem_nonparabolicConcreteLowOrderTraceSet_of_rotationOrder_lt + hpTwo y.1.u1 bound hy.2.2.1 hy.1, + mem_nonparabolicConcreteLowOrderTraceSet_of_rotationOrder_lt + hpTwo y.1.u2 bound hy.2.2.2 hy.2.1⟩ + +/-- Original punctured points transported from the normalized nonparabolic +small-order set. -/ +def puncturedMarkoffPointsWithSmallNonparabolicFirstTwoRotationOrders + (p : ℕ) [Fact p.Prime] [Invertible (3 : ZMod p)] (bound : ℕ) : + Finset (PuncturedMarkoffSurface (ZMod p)) := + originalPuncturedFinsetOfNormalized + (normalizedPuncturedMarkoffPointsWithSmallNonparabolicFirstTwoRotationOrders + p bound) + +theorem puncturedMarkoffPointsWithSmallNonparabolicFirstTwoRotationOrders_card_eq_normalized + {p : ℕ} [Fact p.Prime] [Invertible (3 : ZMod p)] (bound : ℕ) : + (puncturedMarkoffPointsWithSmallNonparabolicFirstTwoRotationOrders + p bound).card = + (normalizedPuncturedMarkoffPointsWithSmallNonparabolicFirstTwoRotationOrders + p bound).card := by + exact originalPuncturedFinsetOfNormalized_card _ + +/-- The fixed-point-free trace pairing on both coordinates gives a square +bound with no additive parabolic correction. -/ +theorem two_mul_puncturedSmallNonparabolicOrder_card_le_maximalDivisors + {p : ℕ} [Fact p.Prime] [Invertible (3 : ZMod p)] + (hpTwo : p ≠ 2) (bound : ℕ) : + 2 * + (puncturedMarkoffPointsWithSmallNonparabolicFirstTwoRotationOrders + p bound).card ≤ + ((bound - 1) * maximalDivisorCountSum p bound) ^ 2 := by + classical + rw [ + puncturedMarkoffPointsWithSmallNonparabolicFirstTwoRotationOrders_card_eq_normalized + ] + let smallSet := + normalizedPuncturedMarkoffPointsWithSmallNonparabolicFirstTwoRotationOrders + p bound + let traceSet := nonparabolicConcreteLowOrderTraceSet p bound + have hpoints : smallSet.card ≤ 2 * traceSet.card ^ 2 := by + rw [← Finset.card_map + (f := ⟨Subtype.val, Subtype.val_injective⟩)] + exact + (Finset.card_mono + (normalizedPuncturedSmallNonparabolicOrderValues_subset_traceSet + hpTwo bound)).trans + (normalizedMarkoffPointsWithFirstTwoCoordinatesIn_card_le traceSet) + have htraces : + 2 * traceSet.card ≤ + (bound - 1) * maximalDivisorCountSum p bound := by + exact two_mul_nonparabolicConcreteLowOrderTraceSet_card_le bound + change 2 * smallSet.card ≤ + ((bound - 1) * maximalDivisorCountSum p bound) ^ 2 + calc + 2 * smallSet.card ≤ 2 * (2 * traceSet.card ^ 2) := + Nat.mul_le_mul_left 2 hpoints + _ = (2 * traceSet.card) ^ 2 := by ring + _ ≤ ((bound - 1) * maximalDivisorCountSum p bound) ^ 2 := by + gcongr + +/-- At `bound = d + 1`, the low-order square has coefficient exactly `d`. -/ +theorem two_mul_puncturedSmallNonparabolicOrder_succ_card_le_maximalDivisors + {p : ℕ} [Fact p.Prime] [Invertible (3 : ZMod p)] + (hpTwo : p ≠ 2) (d : ℕ) : + 2 * + (puncturedMarkoffPointsWithSmallNonparabolicFirstTwoRotationOrders + p (d + 1)).card ≤ + (d * maximalDivisorCountSum p (d + 1)) ^ 2 := by + simpa using + (two_mul_puncturedSmallNonparabolicOrder_card_le_maximalDivisors + hpTwo (d + 1)) + +end + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Assembly/NormalizationCount.lean b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/NormalizationCount.lean new file mode 100644 index 0000000000..95829a578f --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/NormalizationCount.lean @@ -0,0 +1,130 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.ElementaryCounts +public import LeanPool.MarkoffModP.BGS.Markoff.Core.Normalization + +/-! +# Finite counts in normalized Markoff coordinates + +This module transports the canonical two-point bound for a fixed pair of original Markoff +coordinates across `normalizationEquiv`. It then sums that bound over a finite set of possible +first and second normalized coordinates. +-/ + +@[expose] public section + +namespace BGS.Markoff + +universe u + +section NormalizedThirdCoordinateFiber + +variable {F : Type u} [Field F] [Fintype F] [Invertible (3 : F)] + +/-- The original coordinate whose normalized value is `a`. -/ +def originalCoordinateOfNormalized (a : F) : F := + (⅟ (3 : F)) * a + +/-- Normalized Markoff points with prescribed first and second coordinates, obtained by mapping +the canonical original-coordinate fiber through the normalization equivalence. -/ +noncomputable def normalizedMarkoffPointsWithFirstTwoCoordinates (a b : F) : + Finset (NormalizedPoint F) := + (markoffPointsWithFirstTwoCoordinates + (originalCoordinateOfNormalized a) (originalCoordinateOfNormalized b)).map + (normalizationEquiv F).toEmbedding + +@[simp] +theorem mem_normalizedMarkoffPointsWithFirstTwoCoordinates_iff + {a b : F} {x : NormalizedPoint F} : + x ∈ normalizedMarkoffPointsWithFirstTwoCoordinates a b ↔ + IsNormalizedMarkoff x ∧ x.u1 = a ∧ x.u2 = b := by + classical + constructor + · intro hx + obtain ⟨y, hy, rfl⟩ := Finset.mem_map.mp hx + obtain ⟨hyMarkoff, hy1, hy2⟩ := + mem_markoffPointsWithFirstTwoCoordinates_iff.mp hy + refine ⟨(isNormalizedMarkoff_toNormalized_iff y).2 hyMarkoff, ?_, ?_⟩ + · simp [normalizationEquiv, toNormalized, originalCoordinateOfNormalized, hy1, + ← mul_assoc] + · simp [normalizationEquiv, toNormalized, originalCoordinateOfNormalized, hy2, + ← mul_assoc] + · rintro ⟨hxMarkoff, hx1, hx2⟩ + let y : Point F := fromNormalized x + have hnormalize : toNormalized y = x := by + change (normalizationEquiv F) ((normalizationEquiv F).symm x) = x + exact (normalizationEquiv F).apply_symm_apply x + have hyMarkoff : IsMarkoff y := by + apply (isNormalizedMarkoff_toNormalized_iff y).mp + rw [hnormalize] + exact hxMarkoff + have hy1 : y.x1 = originalCoordinateOfNormalized a := by + simp [y, fromNormalized, originalCoordinateOfNormalized, hx1] + have hy2 : y.x2 = originalCoordinateOfNormalized b := by + simp [y, fromNormalized, originalCoordinateOfNormalized, hx2] + apply Finset.mem_map.mpr + refine ⟨y, mem_markoffPointsWithFirstTwoCoordinates_iff.mpr ⟨hyMarkoff, hy1, hy2⟩, ?_⟩ + exact hnormalize + +/-- Mapping through normalization preserves the exact cardinality of a fixed-coordinate fiber. -/ +theorem normalizedMarkoffPointsWithFirstTwoCoordinates_card_eq_original (a b : F) : + (normalizedMarkoffPointsWithFirstTwoCoordinates a b).card = + (markoffPointsWithFirstTwoCoordinates + (originalCoordinateOfNormalized a) (originalCoordinateOfNormalized b)).card := by + classical + simp [normalizedMarkoffPointsWithFirstTwoCoordinates] + +/-- Fixing the first two normalized coordinates leaves at most two normalized Markoff points. -/ +theorem normalizedMarkoffPointsWithFirstTwoCoordinates_card_le_two (a b : F) : + (normalizedMarkoffPointsWithFirstTwoCoordinates a b).card ≤ 2 := by + rw [normalizedMarkoffPointsWithFirstTwoCoordinates_card_eq_original] + exact markoffPointsWithFirstTwoCoordinates_card_le_two _ _ + +/-- Normalized Markoff points whose first two coordinates both lie in `S`. -/ +noncomputable def normalizedMarkoffPointsWithFirstTwoCoordinatesIn (S : Finset F) : + Finset (NormalizedPoint F) := by + classical + exact (S.product S).biUnion fun ab => + normalizedMarkoffPointsWithFirstTwoCoordinates ab.1 ab.2 + +@[simp] +theorem mem_normalizedMarkoffPointsWithFirstTwoCoordinatesIn_iff + {S : Finset F} {x : NormalizedPoint F} : + x ∈ normalizedMarkoffPointsWithFirstTwoCoordinatesIn S ↔ + IsNormalizedMarkoff x ∧ x.u1 ∈ S ∧ x.u2 ∈ S := by + classical + rw [normalizedMarkoffPointsWithFirstTwoCoordinatesIn, Finset.mem_biUnion] + constructor + · rintro ⟨ab, hab, hx⟩ + have hab' : ab.1 ∈ S ∧ ab.2 ∈ S := Finset.mem_product.mp hab + rw [mem_normalizedMarkoffPointsWithFirstTwoCoordinates_iff] at hx + exact ⟨hx.1, hx.2.1 ▸ hab'.1, hx.2.2 ▸ hab'.2⟩ + · rintro ⟨hxMarkoff, hx1, hx2⟩ + refine ⟨(x.u1, x.u2), Finset.mem_product.mpr ⟨hx1, hx2⟩, ?_⟩ + exact mem_normalizedMarkoffPointsWithFirstTwoCoordinates_iff.mpr + ⟨hxMarkoff, rfl, rfl⟩ + +/-- If both of the first two normalized coordinates lie in a finite set `S`, there are at most +`2 * |S|^2` normalized Markoff points. -/ +theorem normalizedMarkoffPointsWithFirstTwoCoordinatesIn_card_le + (S : Finset F) : + (normalizedMarkoffPointsWithFirstTwoCoordinatesIn S).card ≤ 2 * S.card ^ 2 := by + classical + calc + (normalizedMarkoffPointsWithFirstTwoCoordinatesIn S).card ≤ + (S.product S).card * 2 := by + apply Finset.card_biUnion_le_card_mul + intro ab hab + exact normalizedMarkoffPointsWithFirstTwoCoordinates_card_le_two ab.1 ab.2 + _ = 2 * S.card ^ 2 := by + simp [Finset.card_product, pow_two, Nat.mul_comm] + +end NormalizedThirdCoordinateFiber + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Assembly/NormalizedSmallOrderCount.lean b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/NormalizedSmallOrderCount.lean new file mode 100644 index 0000000000..ddc0c9309d --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/NormalizedSmallOrderCount.lean @@ -0,0 +1,127 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.NormalizationCount +public import LeanPool.MarkoffModP.BGS.Markoff.Core.ConicParametrization + +/-! +# The elementary small-order point count + +This module connects matrix rotation order to the concrete split/nonsplit trace set and then to +the normalized fixed-fiber bound. It is the counting step omitted from the paper's final +assembly; no dynamical assertion about escaping to the cage is assumed here. +-/ + +@[expose] public section + +namespace BGS.Markoff + +/-- Normalized Markoff points whose first two matrix rotation orders are below `bound`. -/ +noncomputable def normalizedMarkoffPointsWithSmallFirstTwoRotationOrders + (p : ℕ) [Fact p.Prime] [Invertible (3 : ZMod p)] (bound : ℕ) : + Finset (NormalizedPoint (ZMod p)) := by + classical + exact Finset.univ.filter fun x => + IsNormalizedMarkoff x ∧ rotationOrder x.u1 < bound ∧ rotationOrder x.u2 < bound + +@[simp] +theorem mem_normalizedMarkoffPointsWithSmallFirstTwoRotationOrders_iff + {p : ℕ} [Fact p.Prime] [Invertible (3 : ZMod p)] {bound : ℕ} + {x : NormalizedPoint (ZMod p)} : + x ∈ normalizedMarkoffPointsWithSmallFirstTwoRotationOrders p bound ↔ + IsNormalizedMarkoff x ∧ rotationOrder x.u1 < bound ∧ rotationOrder x.u2 < bound := by + classical + simp [normalizedMarkoffPointsWithSmallFirstTwoRotationOrders] + +theorem normalizedMarkoffPointsWithSmallFirstTwoRotationOrders_subset_traceSet + {p : ℕ} [Fact p.Prime] [Invertible (3 : ZMod p)] (hpTwo : p ≠ 2) (bound : ℕ) : + normalizedMarkoffPointsWithSmallFirstTwoRotationOrders p bound ⊆ + normalizedMarkoffPointsWithFirstTwoCoordinatesIn (concreteLowOrderTraceSet p bound) := by + intro x hx + rw [mem_normalizedMarkoffPointsWithSmallFirstTwoRotationOrders_iff] at hx + exact mem_normalizedMarkoffPointsWithFirstTwoCoordinatesIn_iff.mpr + ⟨hx.1, + mem_concreteLowOrderTraceSet_of_rotationOrder_lt p hpTwo x.u1 bound hx.2.1, + mem_concreteLowOrderTraceSet_of_rotationOrder_lt p hpTwo x.u2 bound hx.2.2⟩ + +/-- The concrete low-order trace set, counted using the divisors of the two torus orders. -/ +theorem concreteLowOrderTraceSet_card_le_divisor_sensitive + {p : ℕ} [Fact p.Prime] (bound : ℕ) : + (concreteLowOrderTraceSet p bound).card ≤ + 2 + (bound - 1) * ((p - 1).divisors.card + (p + 1).divisors.card) := by + have hsplit : Fintype.card (ZMod p)ˣ = p - 1 := by + rw [← Nat.card_eq_fintype_card, Nat.card_units, Nat.card_zmod] + have hnonsplit : Fintype.card (quadraticNormOneTorus p) = p + 1 := by + rw [← Nat.card_eq_fintype_card, quadraticNormOneTorus_natCard] + calc + (concreteLowOrderTraceSet p bound).card ≤ + (normalizedParabolicTraceSet p).card + (bound - 1) * + ((Fintype.card (ZMod p)ˣ).divisors.card + + (Fintype.card (quadraticNormOneTorus p)).divisors.card) := by + exact lowOrderTraceSet_card_le_parabolic_add_pred_mul_divisor_cards + (normalizedParabolicTraceSet p) (splitTorusTrace : (ZMod p)ˣ → ZMod p) + (quadraticNormOneTrace p) bound + _ ≤ 2 + (bound - 1) * ((p - 1).divisors.card + (p + 1).divisors.card) := by + rw [hsplit, hnonsplit] + gcongr + exact Finset.card_le_two + +theorem concreteLowOrderTraceSet_succ_card_le_divisor_sensitive + {p : ℕ} [Fact p.Prime] (d : ℕ) : + (concreteLowOrderTraceSet p (d + 1)).card ≤ + 2 + d * ((p - 1).divisors.card + (p + 1).divisors.card) := by + simpa using (concreteLowOrderTraceSet_card_le_divisor_sensitive (p := p) (d + 1)) + +/-- The fully connected crude count used in the giant-orbit assembly. -/ +theorem normalizedMarkoffPointsWithSmallFirstTwoRotationOrders_card_le + {p : ℕ} [Fact p.Prime] [Invertible (3 : ZMod p)] (hpTwo : p ≠ 2) (bound : ℕ) : + (normalizedMarkoffPointsWithSmallFirstTwoRotationOrders p bound).card ≤ + 2 * (2 + 2 * bound ^ 2) ^ 2 := by + calc + (normalizedMarkoffPointsWithSmallFirstTwoRotationOrders p bound).card ≤ + (normalizedMarkoffPointsWithFirstTwoCoordinatesIn + (concreteLowOrderTraceSet p bound)).card := + Finset.card_mono + (normalizedMarkoffPointsWithSmallFirstTwoRotationOrders_subset_traceSet + hpTwo bound) + _ ≤ 2 * (concreteLowOrderTraceSet p bound).card ^ 2 := + normalizedMarkoffPointsWithFirstTwoCoordinatesIn_card_le _ + _ ≤ 2 * (2 + 2 * bound ^ 2) ^ 2 := by + gcongr + exact concreteLowOrderTraceSet_card_le p bound + +/-- The normalized small-order point count obtained from the divisor-sensitive trace count. -/ +theorem normalizedMarkoffPointsWithSmallFirstTwoRotationOrders_card_le_divisor_sensitive + {p : ℕ} [Fact p.Prime] [Invertible (3 : ZMod p)] (hpTwo : p ≠ 2) (bound : ℕ) : + (normalizedMarkoffPointsWithSmallFirstTwoRotationOrders p bound).card ≤ + 2 * (2 + (bound - 1) * + ((p - 1).divisors.card + (p + 1).divisors.card)) ^ 2 := by + calc + (normalizedMarkoffPointsWithSmallFirstTwoRotationOrders p bound).card ≤ + (normalizedMarkoffPointsWithFirstTwoCoordinatesIn + (concreteLowOrderTraceSet p bound)).card := + Finset.card_mono + (normalizedMarkoffPointsWithSmallFirstTwoRotationOrders_subset_traceSet + hpTwo bound) + _ ≤ 2 * (concreteLowOrderTraceSet p bound).card ^ 2 := + normalizedMarkoffPointsWithFirstTwoCoordinatesIn_card_le _ + _ ≤ 2 * + (2 + (bound - 1) * + ((p - 1).divisors.card + (p + 1).divisors.card)) ^ 2 := by + gcongr + exact concreteLowOrderTraceSet_card_le_divisor_sensitive bound + +theorem normalizedMarkoffPointsWithSmallFirstTwoRotationOrders_succ_card_le_divisor_sensitive + {p : ℕ} [Fact p.Prime] [Invertible (3 : ZMod p)] (hpTwo : p ≠ 2) (d : ℕ) : + (normalizedMarkoffPointsWithSmallFirstTwoRotationOrders p (d + 1)).card ≤ + 2 * (2 + d * ((p - 1).divisors.card + (p + 1).divisors.card)) ^ 2 := by + simpa using + (normalizedMarkoffPointsWithSmallFirstTwoRotationOrders_card_le_divisor_sensitive + hpTwo (d + 1)) + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Assembly/OrbitDivisibility.lean b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/OrbitDivisibility.lean new file mode 100644 index 0000000000..21dac327d0 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/OrbitDivisibility.lean @@ -0,0 +1,383 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Core.Action + +/-! +# Divisibility of Markoff orbit cardinalities + +This file formalizes Daniel E. Martin's elementary proof of the Markoff-graph corollary of +Chen's theorem. Piecewise Penner weights sum to one at every punctured Markoff point, while the +weight in coordinate `i` pairs to one across the `i`-th Vieta involution. Reindexing a finite +Vieta-invariant set by those involutions then forces its cardinality to vanish in the ground +field. Over `ZMod p`, this says that `p` divides the cardinality. + +The result is stated only for `3 < p`. This is the range used in Martin's proof and is necessary: +at `p = 3` the eight points with all coordinates in `{1, -1}` form one Vieta component. +-/ + +@[expose] public section + +namespace BGS.Markoff + +universe u + +/-- Martin's piecewise Penner weights in the original Markoff coordinates. -/ +noncomputable def pennerWeights {F : Type u} [Field F] (x : Point F) : Point F := by + classical + exact if hx1 : x.x1 = 0 then + ⟨0, 1 / 2, 1 / 2⟩ + else if hx2 : x.x2 = 0 then + ⟨1 / 2, 0, 1 / 2⟩ + else if hx3 : x.x3 = 0 then + ⟨1 / 2, 1 / 2, 0⟩ + else + ⟨x.x1 / (3 * x.x2 * x.x3), + x.x2 / (3 * x.x1 * x.x3), + x.x3 / (3 * x.x1 * x.x2)⟩ + +/-- Penner weights restricted to the punctured Markoff surface. -/ +noncomputable def puncturedPennerWeights {F : Type u} [Field F] + (x : PuncturedMarkoffSurface F) : Point F := + pennerWeights x.1.1 + +private theorem half_add_half_eq_one {F : Type u} [Field F] (htwo : (2 : F) ≠ 0) : + (1 / 2 : F) + 1 / 2 = 1 := by + field_simp + ring + +private theorem first_ne_zero_of_second_eq_zero + {F : Type u} [Field F] (x : PuncturedMarkoffSurface F) + (hx2 : x.1.1.x2 = 0) : x.1.1.x1 ≠ 0 := by + intro hx1 + have hx3 : x.1.1.x3 = 0 := by + have hmark := x.1.2 + simp [IsMarkoff, markoffPolynomial, hx1, hx2] at hmark + exact hmark + apply x.2 + apply Subtype.ext + ext <;> simp [surfaceOrigin, origin, hx1, hx2, hx3] + +private theorem first_ne_zero_of_third_eq_zero + {F : Type u} [Field F] (x : PuncturedMarkoffSurface F) + (hx3 : x.1.1.x3 = 0) : x.1.1.x1 ≠ 0 := by + intro hx1 + have hx2 : x.1.1.x2 = 0 := by + have hmark := x.1.2 + simp [IsMarkoff, markoffPolynomial, hx1, hx3] at hmark + exact hmark + apply x.2 + apply Subtype.ext + ext <;> simp [surfaceOrigin, origin, hx1, hx2, hx3] + +private theorem second_ne_zero_of_first_eq_zero + {F : Type u} [Field F] (x : PuncturedMarkoffSurface F) + (hx1 : x.1.1.x1 = 0) : x.1.1.x2 ≠ 0 := by + intro hx2 + have hx3 : x.1.1.x3 = 0 := by + have hmark := x.1.2 + simp [IsMarkoff, markoffPolynomial, hx1, hx2] at hmark + exact hmark + apply x.2 + apply Subtype.ext + ext <;> simp [surfaceOrigin, origin, hx1, hx2, hx3] + +private theorem second_ne_zero_of_third_eq_zero + {F : Type u} [Field F] (x : PuncturedMarkoffSurface F) + (hx3 : x.1.1.x3 = 0) : x.1.1.x2 ≠ 0 := by + intro hx2 + have hx1 : x.1.1.x1 = 0 := by + have hmark := x.1.2 + simp [IsMarkoff, markoffPolynomial, hx2, hx3] at hmark + exact hmark + apply x.2 + apply Subtype.ext + ext <;> simp [surfaceOrigin, origin, hx1, hx2, hx3] + +private theorem third_ne_zero_of_first_eq_zero + {F : Type u} [Field F] (x : PuncturedMarkoffSurface F) + (hx1 : x.1.1.x1 = 0) : x.1.1.x3 ≠ 0 := by + intro hx3 + have hx2 : x.1.1.x2 = 0 := by + have hmark := x.1.2 + simp [IsMarkoff, markoffPolynomial, hx1, hx3] at hmark + exact hmark + apply x.2 + apply Subtype.ext + ext <;> simp [surfaceOrigin, origin, hx1, hx2, hx3] + +private theorem third_ne_zero_of_second_eq_zero + {F : Type u} [Field F] (x : PuncturedMarkoffSurface F) + (hx2 : x.1.1.x2 = 0) : x.1.1.x3 ≠ 0 := by + intro hx3 + have hx1 : x.1.1.x1 = 0 := by + have hmark := x.1.2 + simp [IsMarkoff, markoffPolynomial, hx2, hx3] at hmark + exact hmark + apply x.2 + apply Subtype.ext + ext <;> simp [surfaceOrigin, origin, hx1, hx2, hx3] + +private theorem pennerWeights_first_of_second_third_ne_zero + {F : Type u} [Field F] (x : Point F) (hx2 : x.x2 ≠ 0) (hx3 : x.x3 ≠ 0) : + (pennerWeights x).x1 = x.x1 / (3 * x.x2 * x.x3) := by + by_cases hx1 : x.x1 = 0 + · simp [pennerWeights, hx1] + · simp [pennerWeights, hx1, hx2, hx3] + +private theorem pennerWeights_second_of_first_third_ne_zero + {F : Type u} [Field F] (x : Point F) (hx1 : x.x1 ≠ 0) (hx3 : x.x3 ≠ 0) : + (pennerWeights x).x2 = x.x2 / (3 * x.x1 * x.x3) := by + by_cases hx2 : x.x2 = 0 + · simp [pennerWeights, hx1, hx2] + · simp [pennerWeights, hx1, hx2, hx3] + +private theorem pennerWeights_third_of_first_second_ne_zero + {F : Type u} [Field F] (x : Point F) (hx1 : x.x1 ≠ 0) (hx2 : x.x2 ≠ 0) : + (pennerWeights x).x3 = x.x3 / (3 * x.x1 * x.x2) := by + by_cases hx3 : x.x3 = 0 + · simp [pennerWeights, hx1, hx2, hx3] + · simp [pennerWeights, hx1, hx2, hx3] + +/-- The three Penner weights at a punctured Markoff point sum to one. -/ +theorem puncturedPennerWeights_sum_eq_one + {F : Type u} [Field F] (htwo : (2 : F) ≠ 0) (hthree : (3 : F) ≠ 0) + (x : PuncturedMarkoffSurface F) : + (puncturedPennerWeights x).x1 + (puncturedPennerWeights x).x2 + + (puncturedPennerWeights x).x3 = 1 := by + by_cases hx1 : x.1.1.x1 = 0 + · simpa [puncturedPennerWeights, pennerWeights, hx1] using half_add_half_eq_one htwo + by_cases hx2 : x.1.1.x2 = 0 + · simpa [puncturedPennerWeights, pennerWeights, hx1, hx2] using half_add_half_eq_one htwo + by_cases hx3 : x.1.1.x3 = 0 + · simpa [puncturedPennerWeights, pennerWeights, hx1, hx2, hx3] using + half_add_half_eq_one htwo + have hmark := x.1.2 + change x.1.1.x1 ^ 2 + x.1.1.x2 ^ 2 + x.1.1.x3 ^ 2 - + 3 * x.1.1.x1 * x.1.1.x2 * x.1.1.x3 = 0 at hmark + rw [sub_eq_zero] at hmark + simp only [puncturedPennerWeights, pennerWeights, hx1, hx2, hx3, ↓reduceDIte] + calc + x.1.1.x1 / (3 * x.1.1.x2 * x.1.1.x3) + + x.1.1.x2 / (3 * x.1.1.x1 * x.1.1.x3) + + x.1.1.x3 / (3 * x.1.1.x1 * x.1.1.x2) = + (x.1.1.x1 ^ 2 + x.1.1.x2 ^ 2 + x.1.1.x3 ^ 2) / + (3 * x.1.1.x1 * x.1.1.x2 * x.1.1.x3) := by + field_simp [hx1, hx2, hx3, hthree] + _ = 1 := by rw [hmark]; field_simp [hx1, hx2, hx3, hthree] + +/-- The first Penner weight pairs to one across the first Vieta involution. -/ +theorem puncturedPennerWeight_first_add_vieta1_eq_one + {F : Type u} [Field F] (htwo : (2 : F) ≠ 0) (hthree : (3 : F) ≠ 0) + (x : PuncturedMarkoffSurface F) : + (puncturedPennerWeights x).x1 + + (puncturedPennerWeights (vieta1PuncturedPerm F x)).x1 = 1 := by + change (pennerWeights x.1.1).x1 + (pennerWeights (vieta1 x.1.1)).x1 = 1 + by_cases hx2 : x.1.1.x2 = 0 + · have hx1 := first_ne_zero_of_second_eq_zero x hx2 + simpa [pennerWeights, vieta1, hx1, hx2] using half_add_half_eq_one htwo + by_cases hx3 : x.1.1.x3 = 0 + · have hx1 := first_ne_zero_of_third_eq_zero x hx3 + simpa [pennerWeights, vieta1, hx1, hx2, hx3] using half_add_half_eq_one htwo + rw [pennerWeights_first_of_second_third_ne_zero x.1.1 hx2 hx3] + rw [pennerWeights_first_of_second_third_ne_zero (vieta1 x.1.1) (by simpa [vieta1]) + (by simpa [vieta1])] + simp only [vieta1] + field_simp [hx2, hx3, hthree] + ring + +/-- The second Penner weight pairs to one across the second Vieta involution. -/ +theorem puncturedPennerWeight_second_add_vieta2_eq_one + {F : Type u} [Field F] (htwo : (2 : F) ≠ 0) (hthree : (3 : F) ≠ 0) + (x : PuncturedMarkoffSurface F) : + (puncturedPennerWeights x).x2 + + (puncturedPennerWeights (vieta2PuncturedPerm F x)).x2 = 1 := by + change (pennerWeights x.1.1).x2 + (pennerWeights (vieta2 x.1.1)).x2 = 1 + by_cases hx1 : x.1.1.x1 = 0 + · have hx2 := second_ne_zero_of_first_eq_zero x hx1 + simpa [pennerWeights, vieta2, hx1, hx2] using half_add_half_eq_one htwo + by_cases hx3 : x.1.1.x3 = 0 + · have hx2 := second_ne_zero_of_third_eq_zero x hx3 + simpa [pennerWeights, vieta2, hx1, hx2, hx3] using half_add_half_eq_one htwo + rw [pennerWeights_second_of_first_third_ne_zero x.1.1 hx1 hx3] + rw [pennerWeights_second_of_first_third_ne_zero (vieta2 x.1.1) (by simpa [vieta2]) + (by simpa [vieta2])] + simp only [vieta2] + field_simp [hx1, hx3, hthree] + ring + +/-- The third Penner weight pairs to one across the third Vieta involution. -/ +theorem puncturedPennerWeight_third_add_vieta3_eq_one + {F : Type u} [Field F] (htwo : (2 : F) ≠ 0) (hthree : (3 : F) ≠ 0) + (x : PuncturedMarkoffSurface F) : + (puncturedPennerWeights x).x3 + + (puncturedPennerWeights (vieta3PuncturedPerm F x)).x3 = 1 := by + change (pennerWeights x.1.1).x3 + (pennerWeights (vieta3 x.1.1)).x3 = 1 + by_cases hx1 : x.1.1.x1 = 0 + · have hx3 := third_ne_zero_of_first_eq_zero x hx1 + simpa [pennerWeights, vieta3, hx1, hx3] using half_add_half_eq_one htwo + by_cases hx2 : x.1.1.x2 = 0 + · have hx3 := third_ne_zero_of_second_eq_zero x hx2 + simpa [pennerWeights, vieta3, hx1, hx2, hx3] using half_add_half_eq_one htwo + rw [pennerWeights_third_of_first_second_ne_zero x.1.1 hx1 hx2] + rw [pennerWeights_third_of_first_second_ne_zero (vieta3 x.1.1) (by simpa [vieta3]) + (by simpa [vieta3])] + simp only [vieta3] + field_simp [hx1, hx2, hthree] + ring + +/-- A finite punctured Markoff set invariant under all three Vieta involutions has cardinality +zero in the ground field. -/ +theorem card_cast_eq_zero_of_vieta_invariant + {F : Type u} [Field F] (htwo : (2 : F) ≠ 0) (hthree : (3 : F) ≠ 0) + (C : Finset (PuncturedMarkoffSurface F)) + (hC1 : ∀ x, vieta1PuncturedPerm F x ∈ C ↔ x ∈ C) + (hC2 : ∀ x, vieta2PuncturedPerm F x ∈ C ↔ x ∈ C) + (hC3 : ∀ x, vieta3PuncturedPerm F x ∈ C ↔ x ∈ C) : + (C.card : F) = 0 := by + classical + have hreindex1 : + (∑ x : C, (puncturedPennerWeights (vieta1PuncturedPerm F x.1)).x1) = + ∑ x : C, (puncturedPennerWeights x.1).x1 := by + simpa [Equiv.Perm.subtypePerm_apply] using + (Equiv.sum_comp ((vieta1PuncturedPerm F).subtypePerm hC1) + (fun x : C ↦ (puncturedPennerWeights x.1).x1)) + have hreindex2 : + (∑ x : C, (puncturedPennerWeights (vieta2PuncturedPerm F x.1)).x2) = + ∑ x : C, (puncturedPennerWeights x.1).x2 := by + simpa [Equiv.Perm.subtypePerm_apply] using + (Equiv.sum_comp ((vieta2PuncturedPerm F).subtypePerm hC2) + (fun x : C ↦ (puncturedPennerWeights x.1).x2)) + have hreindex3 : + (∑ x : C, (puncturedPennerWeights (vieta3PuncturedPerm F x.1)).x3) = + ∑ x : C, (puncturedPennerWeights x.1).x3 := by + simpa [Equiv.Perm.subtypePerm_apply] using + (Equiv.sum_comp ((vieta3PuncturedPerm F).subtypePerm hC3) + (fun x : C ↦ (puncturedPennerWeights x.1).x3)) + have hsum1 : + (2 : F) * (∑ x : C, (puncturedPennerWeights x.1).x1) = C.card := by + calc + (2 : F) * (∑ x : C, (puncturedPennerWeights x.1).x1) = + (∑ x : C, (puncturedPennerWeights x.1).x1) + + ∑ x : C, (puncturedPennerWeights x.1).x1 := by ring + _ = (∑ x : C, (puncturedPennerWeights x.1).x1) + + ∑ x : C, (puncturedPennerWeights (vieta1PuncturedPerm F x.1)).x1 := by + rw [hreindex1] + _ = ∑ x : C, ((puncturedPennerWeights x.1).x1 + + (puncturedPennerWeights (vieta1PuncturedPerm F x.1)).x1) := by + rw [Finset.sum_add_distrib] + _ = ∑ _x : C, (1 : F) := by + apply Finset.sum_congr rfl + intro x _hx + exact puncturedPennerWeight_first_add_vieta1_eq_one htwo hthree x.1 + _ = C.card := by simp + have hsum2 : + (2 : F) * (∑ x : C, (puncturedPennerWeights x.1).x2) = C.card := by + calc + (2 : F) * (∑ x : C, (puncturedPennerWeights x.1).x2) = + (∑ x : C, (puncturedPennerWeights x.1).x2) + + ∑ x : C, (puncturedPennerWeights x.1).x2 := by ring + _ = (∑ x : C, (puncturedPennerWeights x.1).x2) + + ∑ x : C, (puncturedPennerWeights (vieta2PuncturedPerm F x.1)).x2 := by + rw [hreindex2] + _ = ∑ x : C, ((puncturedPennerWeights x.1).x2 + + (puncturedPennerWeights (vieta2PuncturedPerm F x.1)).x2) := by + rw [Finset.sum_add_distrib] + _ = ∑ _x : C, (1 : F) := by + apply Finset.sum_congr rfl + intro x _hx + exact puncturedPennerWeight_second_add_vieta2_eq_one htwo hthree x.1 + _ = C.card := by simp + have hsum3 : + (2 : F) * (∑ x : C, (puncturedPennerWeights x.1).x3) = C.card := by + calc + (2 : F) * (∑ x : C, (puncturedPennerWeights x.1).x3) = + (∑ x : C, (puncturedPennerWeights x.1).x3) + + ∑ x : C, (puncturedPennerWeights x.1).x3 := by ring + _ = (∑ x : C, (puncturedPennerWeights x.1).x3) + + ∑ x : C, (puncturedPennerWeights (vieta3PuncturedPerm F x.1)).x3 := by + rw [hreindex3] + _ = ∑ x : C, ((puncturedPennerWeights x.1).x3 + + (puncturedPennerWeights (vieta3PuncturedPerm F x.1)).x3) := by + rw [Finset.sum_add_distrib] + _ = ∑ _x : C, (1 : F) := by + apply Finset.sum_congr rfl + intro x _hx + exact puncturedPennerWeight_third_add_vieta3_eq_one htwo hthree x.1 + _ = C.card := by simp + have htotal : + (∑ x : C, (puncturedPennerWeights x.1).x1) + + (∑ x : C, (puncturedPennerWeights x.1).x2) + + (∑ x : C, (puncturedPennerWeights x.1).x3) = C.card := by + calc + (∑ x : C, (puncturedPennerWeights x.1).x1) + + (∑ x : C, (puncturedPennerWeights x.1).x2) + + (∑ x : C, (puncturedPennerWeights x.1).x3) = + ∑ x : C, ((puncturedPennerWeights x.1).x1 + + (puncturedPennerWeights x.1).x2 + (puncturedPennerWeights x.1).x3) := by + rw [Finset.sum_add_distrib, Finset.sum_add_distrib] + _ = ∑ _x : C, (1 : F) := by + apply Finset.sum_congr rfl + intro x _hx + exact puncturedPennerWeights_sum_eq_one htwo hthree x.1 + _ = C.card := by simp + linear_combination 2 * htotal - hsum1 - hsum2 - hsum3 + +/-- Every `Gamma` orbit on the punctured Markoff surface over `ZMod p` has cardinality divisible +by `p` once `3 < p`. -/ +theorem prime_dvd_puncturedGammaOrbit_ncard + (p : ℕ) [Fact p.Prime] (hpThree : 3 < p) + (x : PuncturedMarkoffSurface (ZMod p)) : + p ∣ (puncturedGammaOrbit x).ncard := by + classical + have htwo : (2 : ZMod p) ≠ 0 := by + intro hzero + have hpDvd : p ∣ 2 := (ZMod.natCast_eq_zero_iff 2 p).mp hzero + exact (Nat.not_dvd_of_pos_of_lt (by omega) (by omega)) hpDvd + have hthree : (3 : ZMod p) ≠ 0 := by + intro hzero + have hpDvd : p ∣ 3 := (ZMod.natCast_eq_zero_iff 3 p).mp hzero + exact (Nat.not_dvd_of_pos_of_lt (by omega) hpThree) hpDvd + let S := puncturedGammaOrbit x + have hS : S.Finite := Set.toFinite S + let C : Finset (PuncturedMarkoffSurface (ZMod p)) := hS.toFinset + have hC1 : ∀ y, vieta1PuncturedPerm (ZMod p) y ∈ C ↔ y ∈ C := by + intro y + simp only [C, Set.Finite.mem_toFinset] + constructor + · intro hy + exact samePuncturedComponent_trans hy + (samePuncturedComponent_symm (samePuncturedComponent_vieta1 y)) + · intro hy + exact samePuncturedComponent_trans hy (samePuncturedComponent_vieta1 y) + have hC2 : ∀ y, vieta2PuncturedPerm (ZMod p) y ∈ C ↔ y ∈ C := by + intro y + simp only [C, Set.Finite.mem_toFinset] + constructor + · intro hy + exact samePuncturedComponent_trans hy + (samePuncturedComponent_symm (samePuncturedComponent_vieta2 y)) + · intro hy + exact samePuncturedComponent_trans hy (samePuncturedComponent_vieta2 y) + have hC3 : ∀ y, vieta3PuncturedPerm (ZMod p) y ∈ C ↔ y ∈ C := by + intro y + simp only [C, Set.Finite.mem_toFinset] + constructor + · intro hy + exact samePuncturedComponent_trans hy + (samePuncturedComponent_symm (samePuncturedComponent_vieta3 y)) + · intro hy + exact samePuncturedComponent_trans hy (samePuncturedComponent_vieta3 y) + have hzero : (C.card : ZMod p) = 0 := + card_cast_eq_zero_of_vieta_invariant htwo hthree C hC1 hC2 hC3 + change p ∣ S.ncard + apply (ZMod.natCast_eq_zero_iff _ _).mp + rw [Set.ncard_eq_toFinset_card S hS] + simpa [C] using hzero + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Assembly/PairedMaximalDivisorLowOrderCount.lean b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/PairedMaximalDivisorLowOrderCount.lean new file mode 100644 index 0000000000..86104a5382 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/PairedMaximalDivisorLowOrderCount.lean @@ -0,0 +1,130 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.MaximalDivisorLowOrderCount + +/-! +# Small-order trace counts after inversion pairing + +The trace maps on both rotation tori identify an eigenvalue with its +inverse. Applying this before the maximal-divisor union removes the factor +two that is lost by counting eigenvalues instead of traces. +-/ + +@[expose] public section + +namespace BGS.Markoff + +open BGS.NumberTheory + +noncomputable section + +section InvolutionImage + +variable {G T : Type*} [Group G] [Fintype G] [DecidableEq G] + [DecidableEq T] [IsCyclic G] + +/-- An inversion-invariant map has at most half as many values as inputs, +apart from the at most two elements satisfying `x² = 1`. -/ +theorem two_mul_card_image_le_card_add_two_of_inv_invariant + (s : Finset G) (f : G → T) + (hsinv : ∀ x ∈ s, x⁻¹ ∈ s) + (hfinv : ∀ x, f x⁻¹ = f x) : + 2 * (s.image f).card ≤ s.card + 2 := by + classical + let fixed : Finset G := s.filter fun x => x⁻¹ = x + have hfixedSubset : + fixed ⊆ BGS.NumberTheory.elementsWithPowOne G 2 := by + intro x hx + rw [Finset.mem_filter] at hx + rw [BGS.NumberTheory.mem_elementsWithPowOne_iff] + have hmul := congrArg (fun y : G => y * x) hx.2 + simpa [pow_two] using hmul.symm + have hfixedCard : fixed.card ≤ 2 := + (Finset.card_le_card hfixedSubset).trans + (IsCyclic.card_pow_eq_one_le (α := G) (n := 2) (by norm_num)) + have hcardFibers : + s.card = + ∑ y ∈ s.image f, (s.filter fun x => f x = y).card := + Finset.card_eq_sum_card_fiberwise + (s := s) (t := s.image f) (f := f) (by + intro x hx + exact Finset.mem_image.mpr ⟨x, hx, rfl⟩) + have hfiber : + ∀ y ∈ s.image f, + 2 ≤ (s.filter fun x => f x = y).card + + if y ∈ fixed.image f then 1 else 0 := by + intro y hy + obtain ⟨x, hx, hxy⟩ := Finset.mem_image.mp hy + by_cases hyfixed : y ∈ fixed.image f + · rw [ite_eq_left hyfixed] + have hxFiber : x ∈ s.filter fun z => f z = y := + Finset.mem_filter.mpr ⟨hx, hxy⟩ + have hpositive : 1 ≤ (s.filter fun z => f z = y).card := + Finset.one_le_card.mpr ⟨x, hxFiber⟩ + omega + · rw [ite_eq_right hyfixed] + have hfix : x⁻¹ ≠ x := by + intro h + apply hyfixed + exact Finset.mem_image.mpr + ⟨x, Finset.mem_filter.mpr ⟨hx, h⟩, hxy⟩ + have hxFiber : x ∈ s.filter fun z => f z = y := + Finset.mem_filter.mpr ⟨hx, hxy⟩ + have hxInvFiber : x⁻¹ ∈ s.filter fun z => f z = y := by + refine Finset.mem_filter.mpr ⟨hsinv x hx, ?_⟩ + rw [hfinv, hxy] + have hpair : + ({x, x⁻¹} : Finset G) ⊆ s.filter fun z => f z = y := by + intro z hz + simp only [Finset.mem_insert, Finset.mem_singleton] at hz + rcases hz with rfl | rfl + · exact hxFiber + · exact hxInvFiber + have hne : x ≠ x⁻¹ := Ne.symm hfix + have htwo : 2 ≤ (s.filter fun z => f z = y).card := by + simpa [hne] using Finset.card_le_card hpair + simpa using htwo + have hfixedImageSubset : fixed.image f ⊆ s.image f := by + apply Finset.image_subset_iff.mpr + intro x hx + exact Finset.mem_image.mpr + ⟨x, (Finset.mem_filter.mp hx).1, rfl⟩ + have hconditional : + (∑ y ∈ s.image f, if y ∈ fixed.image f then 1 else 0) = + (fixed.image f).card := by + calc + (∑ y ∈ s.image f, if y ∈ fixed.image f then 1 else 0) = + ((s.image f).filter fun y => y ∈ fixed.image f).card := by + simp + _ = (fixed.image f).card := by + congr 1 + ext y + simp only [Finset.mem_filter] + constructor + · exact fun h => h.2 + · intro h + exact ⟨hfixedImageSubset h, h⟩ + calc + 2 * (s.image f).card = + ∑ _y ∈ s.image f, 2 := by simp [Nat.mul_comm] + _ ≤ ∑ y ∈ s.image f, + ((s.filter fun x => f x = y).card + + if y ∈ fixed.image f then 1 else 0) := by + gcongr with y hy + exact hfiber y hy + _ = s.card + (fixed.image f).card := by + rw [Finset.sum_add_distrib, ← hcardFibers, hconditional] + _ ≤ s.card + 2 := Nat.add_le_add_left + (Finset.card_image_le.trans hfixedCard) _ + +end InvolutionImage + +end + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Assembly/PairedMaximalDivisorMiddleGame.lean b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/PairedMaximalDivisorMiddleGame.lean new file mode 100644 index 0000000000..0c596e98df --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/PairedMaximalDivisorMiddleGame.lean @@ -0,0 +1,147 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.MiddleGameThenEndgame +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.PairedMaximalDivisorCorvajaZannierEscape + +/-! +# Paired maximal-divisor middle-game assembly + +This module lifts the paired maximal-order escape from a chosen coordinate to +the maximum of the three coordinate rotation orders. +-/ + +@[expose] public section + +namespace BGS.Markoff + +open BGS.NumberTheory + +noncomputable section + +/-- One paired middle-game step strictly increases the maximum coordinate +order under the coefficient-sensitive maximal-divisor inequalities. -/ +theorem + exists_sameNormalizedComponent_maximalOrder_increase_of_pairedMaximalDivisorBounds + (p : ℕ) [Fact p.Prime] [Invertible (3 : ZMod p)] + [Fintype (quadraticFiniteField p)] (hpTwo : p ≠ 2) + {delta : ℝ} (hdelta : delta ≤ (1 : ℝ) / 2) + (x : NormalizedMarkoffSurface (ZMod p)) + (hbelow : (maximalCoordinateRotationOrder x.1 : ℝ) < + (p : ℝ) ^ ((1 : ℝ) / 2 + delta)) + (hcube : + (6 * + (middleGameMaximalOrders p + (maximalCoordinateRotationOrder x.1)).card) ^ 3 < + maximalCoordinateRotationOrder x.1) + (hlinear : + 24 * + (middleGameMaximalOrders p + (maximalCoordinateRotationOrder x.1)).card * + maximalCoordinateRotationOrder x.1 < p) : + ∃ y : NormalizedMarkoffSurface (ZMod p), + SameNormalizedComponent x y ∧ + maximalCoordinateRotationOrder x.1 < + maximalCoordinateRotationOrder y.1 := by + obtain ⟨x', hxx', hx'Order⟩ := + exists_sameNormalizedComponent_firstRotation_eq_maximal x + have hx'Cube : + (6 * + (middleGameMaximalOrders p (rotationOrder x'.1.u1)).card) ^ 3 < + rotationOrder x'.1.u1 := by + simpa [hx'Order] using hcube + have hx'Linear : + 24 * (middleGameMaximalOrders p (rotationOrder x'.1.u1)).card * + rotationOrder x'.1.u1 < p := by + simpa [hx'Order] using hlinear + have hordersPos : + 0 < (middleGameMaximalOrders p (rotationOrder x'.1.u1)).card := by + apply Finset.card_pos.mpr + have hpPlus : p + 1 ≠ 0 := by omega + have honeBound : 1 < rotationOrder x'.1.u1 + 1 := by + exact Nat.lt_succ_of_le (rotationOrder_pos x'.1.u1) + obtain ⟨m, hm, _hmultiple⟩ := + exists_dvd_maximalDivisorBelow hpPlus (one_dvd (p + 1)) honeBound + refine ⟨m, ?_⟩ + rw [middleGameMaximalOrders, Finset.mem_union] + exact Or.inr hm + have hbase : + 4 < + (6 * + (middleGameMaximalOrders p + (rotationOrder x'.1.u1)).card) ^ 3 := by + have hcoeff : + 6 ≤ + 6 * + (middleGameMaximalOrders p + (rotationOrder x'.1.u1)).card := by + nlinarith + calc + 4 < 6 ^ 3 := by norm_num + _ ≤ (6 * + (middleGameMaximalOrders p + (rotationOrder x'.1.u1)).card) ^ 3 := + Nat.pow_le_pow_left hcoeff 3 + have hx'AboveFour : 4 < rotationOrder x'.1.u1 := + hbase.trans hx'Cube + have hx'Below : (rotationOrder x'.1.u1 : ℝ) < + (p : ℝ) ^ ((1 : ℝ) / 2 + delta) := by + simpa [hx'Order] using hbelow + have hx'0 : x'.1.u1 ≠ 0 := by + intro hzero + have hle := rotationOrder_zero_le_four p + rw [hzero] at hx'AboveFour + omega + have hx'Nonparabolic : x'.1.u1 ^ 2 ≠ 4 := by + intro hparabolic + have hcases : x'.1.u1 = 2 ∨ x'.1.u1 = -2 := by + apply (sq_eq_sq_iff_eq_or_eq_neg).mp + calc + x'.1.u1 ^ 2 = 4 := hparabolic + _ = (2 : ZMod p) ^ 2 := by norm_num + have hpOne : (1 : ℝ) ≤ p := by + exact_mod_cast + (show 1 ≤ p by exact (Fact.out : p.Prime).one_le) + have hexponentLe : (1 : ℝ) / 2 + delta ≤ 1 := by + linarith + have hrpowLe : + (p : ℝ) ^ ((1 : ℝ) / 2 + delta) ≤ (p : ℝ) := by + simpa using Real.rpow_le_rpow_of_exponent_le hpOne hexponentLe + rcases hcases with htwo | hnegTwo + · rw [htwo, rotationOrder_two] at hx'Below + linarith + · rw [hnegTwo, rotationOrder_neg_two p hpTwo] at hx'Below + have htwoP : ((2 * p : ℕ) : ℝ) = 2 * (p : ℝ) := by norm_num + rw [htwoP] at hx'Below + have hpPos : (0 : ℝ) < p := by positivity + linarith + obtain ⟨n, hnIncrease⟩ := + exists_iterate_with_larger_secondRotationOrder_of_nonzero_nonparabolic_pairedMaximalOrders + p hpTwo delta hdelta x'.1 x'.property hx'0 hx'Nonparabolic + hx'Below hx'Cube hx'Linear + let y := (normalizedRotate1Surface^[n]) x' + have hcoe : y.1 = (normalizedRotate1^[n]) x'.1 := + coe_iterate_normalizedRotate1Surface x' n + refine ⟨y, sameNormalizedComponent_trans hxx' + (sameNormalizedComponent_iterate_normalizedRotate1Surface x' n), ?_⟩ + rw [← hx'Order] + exact hnIncrease.trans_le <| by + have hmeasureEq : maximalCoordinateRotationOrder y.1 = + maximalCoordinateRotationOrder + ((normalizedRotate1^[n]) x'.1) := + congrArg maximalCoordinateRotationOrder hcoe + calc + rotationOrder ((normalizedRotate1^[n]) x'.1).u2 ≤ + maximalCoordinateRotationOrder + ((normalizedRotate1^[n]) x'.1) := + rotationOrder_second_le_maximalCoordinateRotationOrder _ + _ = maximalCoordinateRotationOrder y.1 := hmeasureEq.symm + +end + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Assembly/PairedMaximalDivisorTraceCount.lean b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/PairedMaximalDivisorTraceCount.lean new file mode 100644 index 0000000000..bdab544b37 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/PairedMaximalDivisorTraceCount.lean @@ -0,0 +1,128 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.PairedMaximalDivisorLowOrderCount + +/-! +# Maximal-divisor trace covers after inversion pairing + +This module applies the abstract involution estimate to every maximal cyclic +subgroup in the low-order cover. The resulting inequality is kept +division-free: + +`2 * |trace values| ≤ (bound + 1) * |maximal divisors|`. +-/ + +@[expose] public section + +namespace BGS.Markoff + +open BGS.NumberTheory + +noncomputable section + +section CyclicTraceCover + +variable {G T : Type*} [Group G] [Fintype G] [DecidableEq G] + [DecidableEq T] [IsCyclic G] + +def maximalDivisorTraceCover (trace : G → T) (bound : ℕ) : Finset T := + (maximalDivisorsBelow (Fintype.card G) bound).biUnion fun m => + (elementsWithPowOne G m).image trace + +theorem boundedOrderTraceSet_subset_maximalDivisorTraceCover + (trace : G → T) (bound : ℕ) : + boundedOrderTraceSet trace bound ⊆ + maximalDivisorTraceCover trace bound := by + intro y hy + rw [boundedOrderTraceSet, Finset.mem_image] at hy + obtain ⟨x, hx, rfl⟩ := hy + have hxCover := + elementsOfOrderLessThan_subset_maximalDivisorCover G bound hx + rw [Finset.mem_biUnion] at hxCover + obtain ⟨m, hm, hxm⟩ := hxCover + rw [maximalDivisorTraceCover, Finset.mem_biUnion] + exact ⟨m, hm, Finset.mem_image.mpr ⟨x, hxm, rfl⟩⟩ + +theorem two_mul_maximalDivisorTraceCover_card_le + (trace : G → T) (bound : ℕ) + (htraceInv : ∀ x, trace x⁻¹ = trace x) : + 2 * (maximalDivisorTraceCover trace bound).card ≤ + (bound + 1) * + (maximalDivisorsBelow (Fintype.card G) bound).card := by + classical + have hpiece : + ∀ m ∈ maximalDivisorsBelow (Fintype.card G) bound, + 2 * ((elementsWithPowOne G m).image trace).card ≤ bound + 1 := by + intro m hm + have hmData := mem_maximalDivisorsBelow_iff.mp hm + have hmPos : 0 < m := by + have hmDvd : m ∣ Fintype.card G := + (Nat.mem_divisors.mp hmData.1).1 + exact Nat.pos_of_dvd_of_pos hmDvd Fintype.card_pos + have hpair := + two_mul_card_image_le_card_add_two_of_inv_invariant + (elementsWithPowOne G m) trace + (by + intro x hx + rw [mem_elementsWithPowOne_iff] at hx ⊢ + simpa using congrArg Inv.inv hx) + htraceInv + calc + 2 * ((elementsWithPowOne G m).image trace).card ≤ + (elementsWithPowOne G m).card + 2 := hpair + _ ≤ m + 2 := Nat.add_le_add_right + (IsCyclic.card_pow_eq_one_le hmPos) 2 + _ ≤ bound + 1 := by omega + calc + 2 * (maximalDivisorTraceCover trace bound).card ≤ + 2 * ∑ m ∈ maximalDivisorsBelow (Fintype.card G) bound, + ((elementsWithPowOne G m).image trace).card := by + apply Nat.mul_le_mul_left + exact Finset.card_biUnion_le + _ = ∑ m ∈ maximalDivisorsBelow (Fintype.card G) bound, + 2 * ((elementsWithPowOne G m).image trace).card := by + simp [Finset.mul_sum] + _ ≤ ∑ _m ∈ maximalDivisorsBelow (Fintype.card G) bound, + (bound + 1) := by + gcongr with m hm + exact hpiece m hm + _ = (bound + 1) * + (maximalDivisorsBelow (Fintype.card G) bound).card := by + simp [Nat.mul_comm] + +theorem two_mul_boundedOrderTraceSet_card_le_maximalDivisors + (trace : G → T) (bound : ℕ) + (htraceInv : ∀ x, trace x⁻¹ = trace x) : + 2 * (boundedOrderTraceSet trace bound).card ≤ + (bound + 1) * + (maximalDivisorsBelow (Fintype.card G) bound).card := by + exact + (Nat.mul_le_mul_left 2 + (Finset.card_le_card + (boundedOrderTraceSet_subset_maximalDivisorTraceCover + trace bound))).trans + (two_mul_maximalDivisorTraceCover_card_le trace bound htraceInv) + +end CyclicTraceCover + +theorem splitTorusTrace_inv (F : Type*) [Field F] (x : Fˣ) : + splitTorusTrace x⁻¹ = splitTorusTrace x := by + simp [splitTorusTrace, add_comm] + +theorem quadraticNormOneTrace_inv + (p : ℕ) [Fact p.Prime] (x : quadraticNormOneTorus p) : + quadraticNormOneTrace p x⁻¹ = quadraticNormOneTrace p x := by + apply (algebraMap (ZMod p) (quadraticFiniteField p)).injective + rw [algebraMap_quadraticNormOneTrace, + algebraMap_quadraticNormOneTrace] + simp [splitTorusTrace, add_comm] + +end + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Assembly/PuncturedSmallOrderCount.lean b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/PuncturedSmallOrderCount.lean new file mode 100644 index 0000000000..30c060278f --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/PuncturedSmallOrderCount.lean @@ -0,0 +1,151 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Core.PuncturedNormalization +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.NormalizedSmallOrderCount + +/-! +# Small-order counts on the punctured Markoff surface + +This module transports the normalized small-order set through the core punctured-normalization +equivalence. Keeping these finite-set estimates here prevents the core equivalence module from +depending on the giant-orbit counting layer. +-/ + +@[expose] public section + +namespace BGS.Markoff + +/-- The canonical small-order set, restricted to the normalized punctured surface. -/ +noncomputable def normalizedPuncturedMarkoffPointsWithSmallFirstTwoRotationOrders + (p : ℕ) [Fact p.Prime] [Invertible (3 : ZMod p)] (bound : ℕ) : + Finset ↑(normalizedPuncturedSurface (ZMod p)) := by + classical + exact Finset.univ.filter fun x => + rotationOrder x.1.u1 < bound ∧ rotationOrder x.1.u2 < bound + +@[simp] +theorem mem_normalizedPuncturedMarkoffPointsWithSmallFirstTwoRotationOrders_iff + {p : ℕ} [Fact p.Prime] [Invertible (3 : ZMod p)] {bound : ℕ} + {x : ↑(normalizedPuncturedSurface (ZMod p))} : + x ∈ normalizedPuncturedMarkoffPointsWithSmallFirstTwoRotationOrders p bound ↔ + rotationOrder x.1.u1 < bound ∧ rotationOrder x.1.u2 < bound := by + classical + simp [normalizedPuncturedMarkoffPointsWithSmallFirstTwoRotationOrders] + +/-- Forgetting the puncture proof embeds the normalized punctured small-order set in the +canonical normalized small-order set. -/ +theorem normalizedPuncturedSmallOrderValues_subset + {p : ℕ} [Fact p.Prime] [Invertible (3 : ZMod p)] (bound : ℕ) : + (normalizedPuncturedMarkoffPointsWithSmallFirstTwoRotationOrders p bound).map + ⟨Subtype.val, Subtype.val_injective⟩ ⊆ + normalizedMarkoffPointsWithSmallFirstTwoRotationOrders p bound := by + intro x hx + obtain ⟨y, hy, rfl⟩ := Finset.mem_map.mp hx + rw [mem_normalizedPuncturedMarkoffPointsWithSmallFirstTwoRotationOrders_iff] at hy + exact mem_normalizedMarkoffPointsWithSmallFirstTwoRotationOrders_iff.mpr + ⟨y.2.1, hy.1, hy.2⟩ + +/-- After forgetting the puncture proof, the punctured small-order set is exactly the canonical +ambient small-order set with the normalized origin erased. Thus the puncture is exposed rather +than silently discarded during transport. -/ +theorem normalizedPuncturedSmallOrderValues_eq_erase_origin + {p : ℕ} [Fact p.Prime] [Invertible (3 : ZMod p)] (bound : ℕ) : + (normalizedPuncturedMarkoffPointsWithSmallFirstTwoRotationOrders p bound).map + ⟨Subtype.val, Subtype.val_injective⟩ = + (normalizedMarkoffPointsWithSmallFirstTwoRotationOrders p bound).erase normalizedOrigin := by + classical + ext x + constructor + · intro hx + obtain ⟨y, hy, rfl⟩ := Finset.mem_map.mp hx + rw [mem_normalizedPuncturedMarkoffPointsWithSmallFirstTwoRotationOrders_iff] at hy + apply Finset.mem_erase.mpr + refine ⟨?_, mem_normalizedMarkoffPointsWithSmallFirstTwoRotationOrders_iff.mpr + ⟨y.2.1, hy.1, hy.2⟩⟩ + simpa using y.2.2 + · intro hx + obtain ⟨hxOrigin, hxSmall⟩ := Finset.mem_erase.mp hx + rw [mem_normalizedMarkoffPointsWithSmallFirstTwoRotationOrders_iff] at hxSmall + let y : ↑(normalizedPuncturedSurface (ZMod p)) := + ⟨x, by + change IsNormalizedMarkoff x ∧ x ∉ ({normalizedOrigin} : Set (NormalizedPoint (ZMod p))) + exact ⟨hxSmall.1, by simpa using hxOrigin⟩⟩ + apply Finset.mem_map.mpr + refine ⟨y, ?_, rfl⟩ + exact mem_normalizedPuncturedMarkoffPointsWithSmallFirstTwoRotationOrders_iff.mpr + ⟨hxSmall.2.1, hxSmall.2.2⟩ + +/-- Removing the normalized origin cannot enlarge the canonical small-order set. -/ +theorem normalizedPuncturedMarkoffPointsWithSmallFirstTwoRotationOrders_card_le_ambient + {p : ℕ} [Fact p.Prime] [Invertible (3 : ZMod p)] (bound : ℕ) : + (normalizedPuncturedMarkoffPointsWithSmallFirstTwoRotationOrders p bound).card ≤ + (normalizedMarkoffPointsWithSmallFirstTwoRotationOrders p bound).card := by + classical + rw [← Finset.card_map (f := ⟨Subtype.val, Subtype.val_injective⟩)] + exact Finset.card_mono (normalizedPuncturedSmallOrderValues_subset bound) + +/-- Original punctured Markoff points obtained by transporting the canonical normalized +punctured small-order set. -/ +noncomputable def puncturedMarkoffPointsWithSmallFirstTwoRotationOrders + (p : ℕ) [Fact p.Prime] [Invertible (3 : ZMod p)] (bound : ℕ) : + Finset (PuncturedMarkoffSurface (ZMod p)) := + originalPuncturedFinsetOfNormalized + (normalizedPuncturedMarkoffPointsWithSmallFirstTwoRotationOrders p bound) + +/-- The transported original punctured set has exactly the cardinality of its normalized +source. -/ +theorem puncturedMarkoffPointsWithSmallFirstTwoRotationOrders_card_eq_normalized + {p : ℕ} [Fact p.Prime] [Invertible (3 : ZMod p)] (bound : ℕ) : + (puncturedMarkoffPointsWithSmallFirstTwoRotationOrders p bound).card = + (normalizedPuncturedMarkoffPointsWithSmallFirstTwoRotationOrders p bound).card := by + exact originalPuncturedFinsetOfNormalized_card _ + +/-- Equivalently, the transported original set has exactly the cardinality of the ambient +canonical normalized small-order set after its origin is removed. -/ +theorem puncturedMarkoffPointsWithSmallFirstTwoRotationOrders_card_eq_normalized_erase_origin + {p : ℕ} [Fact p.Prime] [Invertible (3 : ZMod p)] (bound : ℕ) : + (puncturedMarkoffPointsWithSmallFirstTwoRotationOrders p bound).card = + ((normalizedMarkoffPointsWithSmallFirstTwoRotationOrders p bound).erase + normalizedOrigin).card := by + rw [puncturedMarkoffPointsWithSmallFirstTwoRotationOrders_card_eq_normalized] + rw [← normalizedPuncturedSmallOrderValues_eq_erase_origin] + simp + +/-- The elementary normalized small-order count therefore bounds the transported finite set on +the original punctured surface. -/ +theorem puncturedMarkoffPointsWithSmallFirstTwoRotationOrders_card_le + {p : ℕ} [Fact p.Prime] [Invertible (3 : ZMod p)] + (hpTwo : p ≠ 2) (bound : ℕ) : + (puncturedMarkoffPointsWithSmallFirstTwoRotationOrders p bound).card ≤ + 2 * (2 + 2 * bound ^ 2) ^ 2 := by + rw [puncturedMarkoffPointsWithSmallFirstTwoRotationOrders_card_eq_normalized] + exact (normalizedPuncturedMarkoffPointsWithSmallFirstTwoRotationOrders_card_le_ambient bound).trans + (normalizedMarkoffPointsWithSmallFirstTwoRotationOrders_card_le hpTwo bound) + +/-- The divisor-sensitive normalized count also bounds the transported punctured set. -/ +theorem puncturedMarkoffPointsWithSmallFirstTwoRotationOrders_card_le_divisor_sensitive + {p : ℕ} [Fact p.Prime] [Invertible (3 : ZMod p)] + (hpTwo : p ≠ 2) (bound : ℕ) : + (puncturedMarkoffPointsWithSmallFirstTwoRotationOrders p bound).card ≤ + 2 * (2 + (bound - 1) * + ((p - 1).divisors.card + (p + 1).divisors.card)) ^ 2 := by + rw [puncturedMarkoffPointsWithSmallFirstTwoRotationOrders_card_eq_normalized] + exact (normalizedPuncturedMarkoffPointsWithSmallFirstTwoRotationOrders_card_le_ambient bound).trans + (normalizedMarkoffPointsWithSmallFirstTwoRotationOrders_card_le_divisor_sensitive hpTwo bound) + +theorem puncturedMarkoffPointsWithSmallFirstTwoRotationOrders_succ_card_le_divisor_sensitive + {p : ℕ} [Fact p.Prime] [Invertible (3 : ZMod p)] + (hpTwo : p ≠ 2) (d : ℕ) : + (puncturedMarkoffPointsWithSmallFirstTwoRotationOrders p (d + 1)).card ≤ + 2 * (2 + d * ((p - 1).divisors.card + (p + 1).divisors.card)) ^ 2 := by + simpa using + (puncturedMarkoffPointsWithSmallFirstTwoRotationOrders_card_le_divisor_sensitive + hpTwo (d + 1)) + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Assembly/RankinJointAntichainSperner.lean b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/RankinJointAntichainSperner.lean new file mode 100644 index 0000000000..4a8727b2fe --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/RankinJointAntichainSperner.lean @@ -0,0 +1,98 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.RankinJointAntichainWidth +public import LeanPool.MarkoffModP.BGS.Combinatorics.SymmetricChainBasic + +/-! +# Sperner handoff for the joint maximal-order antichain + +This file isolates the final semantic obligation for a central-coefficient +width bound. It is enough to encode the nontrivial maximal orders injectively +into any finite ranked poset with a symmetric-chain decomposition, in such a +way that comparison of encoded points implies divisibility of the original +orders. The joint antichain then has cardinality at most the central rank. +-/ + +@[expose] public section + +namespace BGS.Markoff + +open BGS.Combinatorics + +/-- A comparison-reflecting factorization encoding transports the joint +divisor antichain into any explicitly symmetric-chain-decomposed poset. -/ +theorem nontrivialMiddleGameMaximalOrders_card_le_centralRank_of_encoding + {P : Type*} [PartialOrder P] [Fintype P] [DecidableEq P] + {rank : P -> Nat} {total p bound : Nat} + (hp : 1 < p) + (decomposition : SymmetricChainDecomposition P rank total) + (encode : Nat -> P) + (hinjective : Function.Injective encode) + (hcomparison : + ∀ {a b : Nat}, + a ∈ nontrivialMiddleGameMaximalOrders p bound -> + b ∈ nontrivialMiddleGameMaximalOrders p bound -> + encode a <= encode b -> a ∣ b) : + (nontrivialMiddleGameMaximalOrders p bound).card <= + Fintype.card {point : P // rank point = total / 2} := by + let embedding : Nat ↪ P := ⟨encode, hinjective⟩ + let encoded : Finset P := + (nontrivialMiddleGameMaximalOrders p bound).map embedding + have hencodedAntichain : + IsAntichain (· <= ·) (encoded : Set P) := by + intro x hx y hy hxy hle + have hx' : x ∈ encoded := by simpa using hx + have hy' : y ∈ encoded := by simpa using hy + change x ∈ + (nontrivialMiddleGameMaximalOrders p bound).map embedding at hx' + change y ∈ + (nontrivialMiddleGameMaximalOrders p bound).map embedding at hy' + rcases Finset.mem_map.mp hx' with ⟨a, ha, hax⟩ + rcases Finset.mem_map.mp hy' with ⟨b, hb, hby⟩ + have hdiv : a ∣ b := by + apply hcomparison ha hb + change embedding a <= embedding b + rw [hax, hby] + exact hle + have hab : a = b := + nontrivialMiddleGameMaximalOrders_eq_of_dvd hp ha hb hdiv + apply hxy + calc + x = embedding a := hax.symm + _ = embedding b := congrArg embedding hab + _ = y := hby + have hcentral := + decomposition.antichain_card_le_central_rank + encoded hencodedAntichain + simpa [encoded] using hcentral + +/-- The central rank supplied by a factorization encoding can be inserted +directly into the Corvaja--Zannier witness cap, with the two exceptional +divisors restored. -/ +theorem bound_le_rankinCentralRankWitnessCap_of_encoding + {P : Type*} [PartialOrder P] [Fintype P] [DecidableEq P] + {rank : P -> Nat} {total p bound : Nat} + (hp : 1 < p) + (hbound : + bound <= 189 * (middleGameMaximalOrders p bound).card ^ 3) + (decomposition : SymmetricChainDecomposition P rank total) + (encode : Nat -> P) + (hinjective : Function.Injective encode) + (hcomparison : + ∀ {a b : Nat}, + a ∈ nontrivialMiddleGameMaximalOrders p bound -> + b ∈ nontrivialMiddleGameMaximalOrders p bound -> + encode a <= encode b -> a ∣ b) : + bound <= rankinWidthWitnessCap + (Fintype.card {point : P // rank point = total / 2} + 2) := by + apply bound_le_rankinJointAntichainWitnessCap hbound + exact nontrivialMiddleGameMaximalOrders_card_le_centralRank_of_encoding + hp decomposition encode hinjective hcomparison + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Assembly/RankinJointAntichainWidth.lean b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/RankinJointAntichainWidth.lean new file mode 100644 index 0000000000..895171d30e --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/RankinJointAntichainWidth.lean @@ -0,0 +1,216 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.RankinWidthEnvelope +public import Mathlib.Order.Antichain + +/-! +# One joint antichain for the two neighboring tori + +The maximal candidate orders dividing `p - 1` and `p + 1` are not two +independent divisor families. After removing the possible divisors `1` and +`2`, their union is a single antichain: a cross-side divisibility relation +would force its smaller term to divide the difference `2`. + +This is the arithmetic input that makes the width-sensitive Rankin endpoint +strictly sharper than summing two complete divisor counts. +-/ + +@[expose] public section + +namespace BGS.Markoff + +open BGS.NumberTheory + +/-- The actual middle-game maximal orders after removing the only divisors of +the neighbor difference `2`. -/ +def nontrivialMiddleGameMaximalOrders (p bound : Nat) : Finset Nat := + (middleGameMaximalOrders p bound).filter fun d => ¬ d ∣ 2 + +@[simp] theorem mem_nontrivialMiddleGameMaximalOrders_iff + {p bound d : Nat} : + d ∈ nontrivialMiddleGameMaximalOrders p bound <-> + (d ∈ maximalDivisorsBelow (p - 1) (bound + 1) \/ + d ∈ maximalDivisorsBelow (p + 1) (bound + 1)) /\ + ¬ d ∣ 2 := by + simp [nontrivialMiddleGameMaximalOrders, middleGameMaximalOrders] + +/-- Every nontrivial maximal order divides the common product `p^2 - 1`. -/ +theorem nontrivialMiddleGameMaximalOrders_subset_divisors_sq_sub_one + {p bound : Nat} (hp : 1 < p) : + nontrivialMiddleGameMaximalOrders p bound ⊆ + (p ^ 2 - 1).divisors := by + intro d hd + have hfactor : p ^ 2 - 1 = (p + 1) * (p - 1) := by + simpa using (sq_tsub_sq p 1) + have hsq : 1 < p ^ 2 := by nlinarith + have hcommonNe : p ^ 2 - 1 ≠ 0 := + (Nat.sub_pos_of_lt hsq).ne' + have hdData := mem_nontrivialMiddleGameMaximalOrders_iff.mp hd + apply Nat.mem_divisors.mpr + refine ⟨?_, hcommonNe⟩ + rcases hdData.1 with hdMinus | hdPlus + · have hdDvd : d ∣ p - 1 := + (Nat.mem_divisors.mp + (mem_maximalDivisorsBelow_iff.mp hdMinus).1).1 + obtain ⟨k, hk⟩ := hdDvd + refine ⟨(p + 1) * k, ?_⟩ + calc + p ^ 2 - 1 = (p + 1) * (p - 1) := hfactor + _ = (p + 1) * (d * k) := by rw [hk] + _ = d * ((p + 1) * k) := by ring + · have hdDvd : d ∣ p + 1 := + (Nat.mem_divisors.mp + (mem_maximalDivisorsBelow_iff.mp hdPlus).1).1 + obtain ⟨k, hk⟩ := hdDvd + refine ⟨k * (p - 1), ?_⟩ + calc + p ^ 2 - 1 = (p + 1) * (p - 1) := hfactor + _ = (d * k) * (p - 1) := by rw [hk] + _ = d * (k * (p - 1)) := by ring + +/-- Divisibility between two nontrivial joint maximal orders forces equality. +The same-side cases use maximality; the cross-side cases use the difference +of the two neighboring torus orders. -/ +theorem nontrivialMiddleGameMaximalOrders_eq_of_dvd + {p bound a b : Nat} (hp : 1 < p) + (ha : a ∈ nontrivialMiddleGameMaximalOrders p bound) + (hb : b ∈ nontrivialMiddleGameMaximalOrders p bound) + (hab : a ∣ b) : + a = b := by + have haData := mem_nontrivialMiddleGameMaximalOrders_iff.mp ha + have hbData := mem_nontrivialMiddleGameMaximalOrders_iff.mp hb + rcases haData.1 with haMinus | haPlus + · rcases hbData.1 with hbMinus | hbPlus + · exact + ((mem_maximalDivisorsBelow_iff.mp haMinus).2.2 b + (mem_maximalDivisorsBelow_iff.mp hbMinus).1 + (mem_maximalDivisorsBelow_iff.mp hbMinus).2.1 + hab).symm + · exfalso + apply haData.2 + have haDvdMinus : a ∣ p - 1 := + (Nat.mem_divisors.mp + (mem_maximalDivisorsBelow_iff.mp haMinus).1).1 + have hbDvdPlus : b ∣ p + 1 := + (Nat.mem_divisors.mp + (mem_maximalDivisorsBelow_iff.mp hbPlus).1).1 + have haDvdPlus : a ∣ p + 1 := hab.trans hbDvdPlus + have hsub := Nat.dvd_sub haDvdPlus haDvdMinus + have hdifference : (p + 1) - (p - 1) = 2 := by omega + rw [hdifference] at hsub + exact hsub + · rcases hbData.1 with hbMinus | hbPlus + · exfalso + apply haData.2 + have haDvdPlus : a ∣ p + 1 := + (Nat.mem_divisors.mp + (mem_maximalDivisorsBelow_iff.mp haPlus).1).1 + have hbDvdMinus : b ∣ p - 1 := + (Nat.mem_divisors.mp + (mem_maximalDivisorsBelow_iff.mp hbMinus).1).1 + have haDvdMinus : a ∣ p - 1 := hab.trans hbDvdMinus + have hsub := Nat.dvd_sub haDvdPlus haDvdMinus + have hdifference : (p + 1) - (p - 1) = 2 := by omega + rw [hdifference] at hsub + exact hsub + · exact + ((mem_maximalDivisorsBelow_iff.mp haPlus).2.2 b + (mem_maximalDivisorsBelow_iff.mp hbPlus).1 + (mem_maximalDivisorsBelow_iff.mp hbPlus).2.1 + hab).symm + +/-- The nontrivial maximal candidate orders from both neighboring tori form +one canonical antichain under divisibility. -/ +theorem nontrivialMiddleGameMaximalOrders_isAntichain + {p bound : Nat} (hp : 1 < p) : + IsAntichain (· ∣ ·) + (nontrivialMiddleGameMaximalOrders p bound : Set Nat) := by + intro a ha b hb hab hdiv + apply hab + exact nontrivialMiddleGameMaximalOrders_eq_of_dvd hp + (by simpa using ha) (by simpa using hb) hdiv + +/-- Restoring the discarded part costs at most the two exceptional divisors +`1` and `2`. -/ +theorem middleGameMaximalOrders_card_le_nontrivial_add_two + (p bound : Nat) : + (middleGameMaximalOrders p bound).card <= + (nontrivialMiddleGameMaximalOrders p bound).card + 2 := by + classical + let orders := middleGameMaximalOrders p bound + let exceptional := orders.filter fun d => d ∣ 2 + have hexceptionalSubset : exceptional ⊆ ({1, 2} : Finset Nat) := by + intro d hd + have hdTwo : d ∣ 2 := (Finset.mem_filter.mp hd).2 + rcases Nat.prime_two.eq_one_or_self_of_dvd d hdTwo with rfl | rfl + · simp + · simp + have hexceptionalCard : exceptional.card <= 2 := by + calc + exceptional.card <= ({1, 2} : Finset Nat).card := + Finset.card_le_card hexceptionalSubset + _ = 2 := by decide + have hsplit := + Finset.card_filter_add_card_filter_not + (s := orders) (fun d => ¬ d ∣ 2) + have hsplit' : + (nontrivialMiddleGameMaximalOrders p bound).card + + exceptional.card = + (middleGameMaximalOrders p bound).card := by + simpa [orders, exceptional, nontrivialMiddleGameMaximalOrders] using + hsplit + omega + +/-- Any bound on the one nontrivial antichain gives a bound on all maximal +orders with an additive cost of only two. -/ +theorem middleGameMaximalOrders_card_le_of_nontrivialWidth + {p bound width : Nat} + (hwidth : + (nontrivialMiddleGameMaximalOrders p bound).card <= width) : + (middleGameMaximalOrders p bound).card <= width + 2 := by + exact (middleGameMaximalOrders_card_le_nontrivial_add_two p bound).trans + (Nat.add_le_add_right hwidth 2) + +/-- The exact-order witness cap can therefore use the width of the single +joint antichain, plus the two exceptional divisors. -/ +theorem bound_le_rankinJointAntichainWitnessCap + {p bound width : Nat} + (hbound : + bound <= 189 * (middleGameMaximalOrders p bound).card ^ 3) + (hwidth : + (nontrivialMiddleGameMaximalOrders p bound).card <= width) : + bound <= rankinWidthWitnessCap (width + 2) := by + exact bound_le_rankinWidthWitnessCap hbound + (middleGameMaximalOrders_card_le_of_nontrivialWidth hwidth) + +/-- Width-sensitive Rankin closure fed directly by the single joint +antichain. -/ +theorem prime_le_of_matching_rankinNeighborProfile_jointAntichainWidth_leaf + {p bound width rootCap cutoff : Nat} + (hpPrime : p.Prime) (hpTwo : 2 < p) + (hroot : + 8 * p <= (combinedTruncatedOrderTotientSum p bound) ^ 2) + (hboundWitness : + bound <= 189 * (middleGameMaximalOrders p bound).card ^ 3) + (hwidth : + (nontrivialMiddleGameMaximalOrders p bound).card <= width) + (profile : RankinNeighborProfile) + (hprofile : profile.Valid) + (hmatch : profile.Matches p) + (hrootValid : RankinWidthRootValid (width + 2) rootCap) + (hleaf : + RankinWidthClosesCutoff (width + 2) rootCap profile cutoff \/ + RankinWidthExcludesFailure (width + 2) rootCap profile) : + p <= cutoff := by + exact prime_le_of_matching_rankinNeighborProfile_rankinWidth_leaf + hpPrime hpTwo hroot hboundWitness + (middleGameMaximalOrders_card_le_of_nontrivialWidth hwidth) + profile hprofile hmatch hrootValid hleaf + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Assembly/RankinWidthEnvelope.lean b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/RankinWidthEnvelope.lean new file mode 100644 index 0000000000..22387862ca --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/RankinWidthEnvelope.lean @@ -0,0 +1,231 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.ExactOrderRankinEnvelope + +/-! +# A width-sensitive exact-order Rankin envelope + +The first exact-order Rankin endpoint bounded the middle-game maximal orders +by all divisors of `p - 1` and `p + 1`. This file separates that coarse +choice from the analytic argument. Any certified upper bound for the actual +maximal-order set can now be cubed directly, while the Euler product remains +the same side-erased Rankin product. + +This is the interface needed for a joint-antichain or symmetric-chain width +certificate. It does not assume such a certificate. +-/ + +@[expose] public section + +namespace BGS.Markoff + +open BGS.NumberTheory + +/-- The Corvaja--Zannier witness cap obtained from an arbitrary certified +upper bound for the number of maximal candidate orders. -/ +def rankinWidthWitnessCap (width : Nat) : Nat := + 189 * width ^ 3 + +/-- The side-erased Rankin failure square using a maximal-order width rather +than the total number of neighboring divisors. -/ +def rankinWidthJointFailureSquare + (width rootCap : Nat) (profile : RankinNeighborProfile) : Rat := + ((rankinWidthWitnessCap width : Rat) * rootCap * + (2 * profile.jointCoarseEulerProductProduct)) ^ 2 + +/-- The chosen integral root cap is sufficient for the width witness. -/ +def RankinWidthRootValid (width rootCap : Nat) : Prop := + rankinWidthWitnessCap width <= rootCap ^ 12 + +/-- A direct cutoff leaf for the width-sensitive envelope. -/ +def RankinWidthClosesCutoff + (width rootCap : Nat) (profile : RankinNeighborProfile) + (cutoff : Nat) : Prop := + rankinWidthJointFailureSquare width rootCap profile < + (8 * (cutoff + 1) : Nat) + +/-- A side-erased lower-product contradiction for the width-sensitive +envelope. -/ +def RankinWidthExcludesFailure + (width rootCap : Nat) (profile : RankinNeighborProfile) : Prop := + rankinWidthJointFailureSquare width rootCap profile ^ 2 < + (64 * profile.jointLowerNeighborProduct : Nat) + +def rankinWidthLeafCheck + (width rootCap cutoff : Nat) (profile : RankinNeighborProfile) : Bool := + decide + (rankinWidthWitnessCap width <= rootCap ^ 12 /\ + (rankinWidthJointFailureSquare width rootCap profile < + ((8 * (cutoff + 1) : Nat) : Rat) \/ + rankinWidthJointFailureSquare width rootCap profile ^ 2 < + ((64 * profile.jointLowerNeighborProduct : Nat) : Rat))) + +@[simp] theorem rankinWidthLeafCheck_eq_true_iff + (width rootCap cutoff : Nat) (profile : RankinNeighborProfile) : + rankinWidthLeafCheck width rootCap cutoff profile = true <-> + RankinWidthRootValid width rootCap /\ + (RankinWidthClosesCutoff width rootCap profile cutoff \/ + RankinWidthExcludesFailure width rootCap profile) := by + simp [rankinWidthLeafCheck, RankinWidthRootValid, + RankinWidthClosesCutoff, RankinWidthExcludesFailure] + +theorem bound_le_rankinWidthWitnessCap + {p bound width : Nat} + (hbound : + bound <= 189 * (middleGameMaximalOrders p bound).card ^ 3) + (hwidth : (middleGameMaximalOrders p bound).card <= width) : + bound <= rankinWidthWitnessCap width := by + exact hbound.trans (by + simp only [rankinWidthWitnessCap] + gcongr) + +/-- A matched profile and any certified maximal-order width force the new +side-erased failure square. No divisor-count upper bound occurs here. -/ +theorem eight_mul_prime_cast_le_matching_profile_rankinWidthFailureSquare + {p bound width rootCap : Nat} + (hpPrime : p.Prime) (hpTwo : 2 < p) + (hroot : + 8 * p <= (combinedTruncatedOrderTotientSum p bound) ^ 2) + (hboundWitness : + bound <= 189 * (middleGameMaximalOrders p bound).card ^ 3) + (hwidth : (middleGameMaximalOrders p bound).card <= width) + (profile : RankinNeighborProfile) + (hprofile : profile.Valid) + (hmatch : profile.Matches p) + (hrootValid : RankinWidthRootValid width rootCap) : + (8 * p : Rat) <= + rankinWidthJointFailureSquare width rootCap profile := by + have hp : 1 < p := by omega + obtain ⟨assignment, hweightNonneg, hweightPower, + hminusEuler, hplusEuler⟩ := + profile.exists_assignedPrimeWeight_bounds + hpPrime hpTwo hprofile hmatch + have hboundWidth : bound <= rankinWidthWitnessCap width := + bound_le_rankinWidthWitnessCap hboundWitness hwidth + have hrootCapNonneg : (0 : Rat) <= rootCap := by positivity + have hrootValidCast : + (rankinWidthWitnessCap width : Rat) <= (rootCap : Rat) ^ 12 := by + exact_mod_cast hrootValid + have hfailure := + eight_mul_prime_cast_le_jointRankinSquare + hp hroot hboundWidth + (assignedPrimeWeight p profile assignment) rootCap + hweightNonneg hweightPower hrootCapNonneg hrootValidCast + have hEuler : + jointRankinEulerProduct p + (assignedPrimeWeight p profile assignment) <= + profile.jointCoarseEulerProduct := by + change + ((p - 1).factorization.prod fun prime exponent => + rankinPrimePowerFactor prime exponent + (assignedPrimeWeight p profile assignment prime)) + + ((p + 1).factorization.prod fun prime exponent => + rankinPrimePowerFactor prime exponent + (assignedPrimeWeight p profile assignment prime)) <= + profile.coarseEulerProduct .minus + + profile.coarseEulerProduct .plus + exact add_le_add hminusEuler hplusEuler + have hEulerErased : + jointRankinEulerProduct p + (assignedPrimeWeight p profile assignment) <= + 2 * profile.jointCoarseEulerProductProduct := + hEuler.trans profile.jointCoarseEulerProduct_le_two_mul_product + have hEulerActualNonneg := + jointRankinEulerProduct_nonneg p hp + (assignedPrimeWeight p profile assignment) hweightNonneg + have hEulerErasedNonneg : + (0 : Rat) <= 2 * profile.jointCoarseEulerProductProduct := + hEulerActualNonneg.trans hEulerErased + have hscaleNonneg : + (0 : Rat) <= + (rankinWidthWitnessCap width : Rat) * rootCap := by + positivity + have hupper : + (rankinWidthWitnessCap width : Rat) * rootCap * + jointRankinEulerProduct p + (assignedPrimeWeight p profile assignment) <= + (rankinWidthWitnessCap width : Rat) * rootCap * + (2 * profile.jointCoarseEulerProductProduct) := + mul_le_mul_of_nonneg_left hEulerErased hscaleNonneg + have hleftNonneg : + (0 : Rat) <= + (rankinWidthWitnessCap width : Rat) * rootCap * + jointRankinEulerProduct p + (assignedPrimeWeight p profile assignment) := by + positivity + have hrightNonneg : + (0 : Rat) <= + (rankinWidthWitnessCap width : Rat) * rootCap * + (2 * profile.jointCoarseEulerProductProduct) := by + exact mul_nonneg hscaleNonneg hEulerErasedNonneg + simpa only [rankinWidthJointFailureSquare] using + hfailure.trans ((sq_le_sq₀ hleftNonneg hrightNonneg).2 hupper) + +/-- A valid checked width leaf bounds the prime. This is the replacement +endpoint to be fed by the forthcoming joint-antichain width certificate. -/ +theorem prime_le_of_matching_rankinNeighborProfile_rankinWidth_leaf + {p bound width rootCap cutoff : Nat} + (hpPrime : p.Prime) (hpTwo : 2 < p) + (hroot : + 8 * p <= (combinedTruncatedOrderTotientSum p bound) ^ 2) + (hboundWitness : + bound <= 189 * (middleGameMaximalOrders p bound).card ^ 3) + (hwidth : (middleGameMaximalOrders p bound).card <= width) + (profile : RankinNeighborProfile) + (hprofile : profile.Valid) + (hmatch : profile.Matches p) + (hrootValid : RankinWidthRootValid width rootCap) + (hleaf : + RankinWidthClosesCutoff width rootCap profile cutoff \/ + RankinWidthExcludesFailure width rootCap profile) : + p <= cutoff := by + have hfailure := + eight_mul_prime_cast_le_matching_profile_rankinWidthFailureSquare + hpPrime hpTwo hroot hboundWitness hwidth profile hprofile hmatch + hrootValid + rcases hleaf with hcloses | hexcludes + · by_contra hnot + have hcutoffSucc : cutoff + 1 <= p := by omega + have hcutoffCast : + (8 * (cutoff + 1) : Rat) <= (8 * p : Rat) := by + exact_mod_cast Nat.mul_le_mul_left 8 hcutoffSucc + exact (not_lt_of_ge (hcutoffCast.trans hfailure)) (by + simpa [RankinWidthClosesCutoff, Nat.cast_mul, Nat.cast_add, + Nat.cast_ofNat, Nat.cast_one] using hcloses) + · have hlower := profile.lowerNeighborProducts_le hpPrime hpTwo hmatch + have hneighborProduct : + profile.jointLowerNeighborProduct <= (p - 1) * (p + 1) := by + rw [profile.jointLowerNeighborProduct_eq_mul] + exact Nat.mul_le_mul hlower.1 hlower.2 + have hneighborLt : (p - 1) * (p + 1) < p ^ 2 := by + have hsub : p - 1 + 1 = p := by omega + nlinarith + have hlowerJointCast : + ((64 * profile.jointLowerNeighborProduct : Nat) : Rat) < + (64 * p ^ 2 : Rat) := by + have hnat := (Nat.mul_lt_mul_left (by omega : 0 < 64)).2 + (hneighborProduct.trans_lt hneighborLt) + exact_mod_cast hnat + have hfailureNonneg : + (0 : Rat) <= rankinWidthJointFailureSquare width rootCap profile := by + rw [rankinWidthJointFailureSquare] + exact sq_nonneg _ + have heighthPrimeNonneg : (0 : Rat) <= (8 * p : Rat) := by + positivity + have hfailureSquared : + (64 * p ^ 2 : Rat) <= + rankinWidthJointFailureSquare width rootCap profile ^ 2 := by + have hsquare := + (sq_le_sq₀ heighthPrimeNonneg hfailureNonneg).2 hfailure + norm_num [mul_pow] at hsquare ⊢ + exact hsquare + exact False.elim + ((not_lt_of_ge (hlowerJointCast.le.trans hfailureSquared)) hexcludes) + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Assembly/ReductionSurjectivity.lean b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/ReductionSurjectivity.lean new file mode 100644 index 0000000000..8aa4be26b9 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/ReductionSurjectivity.lean @@ -0,0 +1,58 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.ExplicitPuncturedTransitivity +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.WeightedCoarseSupportSurjectivity +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.TransitivitySurjectivity + +/-! +# Explicit strong approximation + +The explicit punctured-transitivity theorem, together with natural Markoff connectivity, +gives surjectivity of reduction from natural-number Markoff solutions. +-/ + +@[expose] public section + +namespace BGS.Markoff + +/-- **Explicit strong approximation in its source-faithful form.** For every prime above the +closed cutoff, every Markoff solution modulo `p` is the reduction of a natural-number solution. -/ +theorem markoffReduction_surjective_of_concreteExplicitBound + (p : ℕ) (hpPrime : p.Prime) + (hp : (2 ^ 9 * (48 ^ 3 + 1) ^ 18 * + (2 ^ 9 * (9 ^ 9) ^ (2 ^ 9)) ^ 8 + 1) ≤ p) : + Function.Surjective (markoffReduction p) := + (puncturedMarkoffTransitiveAt_iff_markoffReduction_surjective p hpPrime).mp + (puncturedMarkoffTransitiveAt_of_concreteExplicitBound p hpPrime hp) + +/-- Strong approximation obtained from the elementary preliminary route. -/ +theorem markoffReduction_surjective_of_concretePreliminaryBound + (p : ℕ) (hpPrime : p.Prime) + (hp : (2 ^ 1833 * (48 ^ 3 + 1) ^ 10 + 1) ≤ p) : + Function.Surjective (markoffReduction p) := + (puncturedMarkoffTransitiveAt_iff_markoffReduction_surjective p hpPrime).mp + (puncturedMarkoffTransitiveAt_of_concretePreliminaryBound p hpPrime hp) + +/-- The weighted certificate-free Euler-seven coarse-support theorem in the +functor presentation used by the Comparator challenge. -/ +theorem reduction_surjective_of_explicitBound : + let p₀ := 35721 ^ 5 * 2 ^ 1547 * 32769 ^ 2 + 1 + ∀ (p : ℕ), p.Prime → p₀ ≤ p → + Function.Surjective + (BGS.Markoff.map (CommSemiRingCat.ofHom (Nat.castRingHom (ZMod p)))) := by + dsimp only + intro p hpPrime hp y + obtain ⟨x, hx⟩ := + markoffReduction_surjective_of_weightedCoarseSupportBound p hpPrime hp + (markoffEquivSemiringMarkoffSurface (ZMod p) y) + refine ⟨(markoffEquivSemiringMarkoffSurface ℕ).symm x, ?_⟩ + apply (markoffEquivSemiringMarkoffSurface (ZMod p)).injective + simpa [markoffReduction] using hx + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Assembly/SplitCageEvenSignBase.lean b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/SplitCageEvenSignBase.lean new file mode 100644 index 0000000000..82756e8e56 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/SplitCageEvenSignBase.lean @@ -0,0 +1,199 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.GiantOrbit +public import LeanPool.MarkoffModP.BGS.Markoff.Core.EvenSignAction + +/-! +# Even-sign stability of a split-cage base component + +If `u` has full split-torus order `p - 1`, then `-u` has order at least +`(p - 1) / 2`. Thus negating a split-maximal trace still produces a +coordinate above the endgame threshold whenever + +`p ^ (5 / 6) ≤ (p - 1) / 2`. + +Every even sign change preserves or negates each normalized coordinate. +Consequently, under the usual large-order-to-base hypothesis, all four even +sign images of a split-cage base lie in its Gamma orbit. +-/ + +@[expose] public section + +namespace BGS.Markoff + +noncomputable section + +@[simp] +theorem splitTorusTrace_neg + {F : Type*} [Field F] (u : Fˣ) : + splitTorusTrace (-u) = -splitTorusTrace u := by + simp [splitTorusTrace] + ring + +/-- A split-maximal trace is represented by a full-order split-torus unit. -/ +theorem exists_fullOrder_splitUnit_of_isSplitMaximalTrace + (p : ℕ) [Fact p.Prime] (hpSeven : 7 ≤ p) + (t : ZMod p) (hmax : IsSplitMaximalTrace p t) : + ∃ u : (ZMod p)ˣ, + splitTorusTrace u = t ∧ + orderOf u = p - 1 ∧ + (u : ZMod p) ^ 2 ≠ 1 := by + have hpTwo : p ≠ 2 := by omega + have htNonparabolic := + splitMaximalTrace_sq_ne_four p hpSeven t hmax + rcases exists_split_or_quadraticNormOneTrace + p hpTwo t htNonparabolic with + ⟨u, htrace, huSq⟩ | ⟨u, htrace, huSq⟩ + · refine ⟨u, htrace, ?_, huSq⟩ + calc + orderOf u = rotationOrder t := by + rw [← htrace, rotationOrder_splitTorusTrace u huSq] + _ = p - 1 := hmax + · exfalso + have hrotation : rotationOrder t = orderOf u := by + rw [← htrace, rotationOrder_quadraticNormOneTrace p u huSq] + have horder : orderOf u = p - 1 := by + rw [← hmax] + exact hrotation.symm + have hdvd := orderOf_dvd_natCard u + rw [quadraticNormOneTorus_natCard, horder] at hdvd + have hdvdTwo : p - 1 ∣ 2 := by + have hsub := Nat.dvd_sub hdvd (dvd_refl (p - 1)) + have heq : (p + 1) - (p - 1) = 2 := by omega + rw [heq] at hsub + exact hsub + have hle : p - 1 ≤ 2 := Nat.le_of_dvd (by norm_num) hdvdTwo + omega + +/-- Negating a full-order unit loses at most a factor of two in its order. -/ +theorem half_card_sub_one_le_orderOf_neg_of_fullOrder + (p : ℕ) [Fact p.Prime] (hpTwo : p ≠ 2) + (u : (ZMod p)ˣ) (huOrder : orderOf u = p - 1) : + (p - 1) / 2 ≤ orderOf (-u) := by + have hnegOneOrder : orderOf (-1 : (ZMod p)ˣ) = 2 := by + rw [← orderOf_units, Units.coe_neg_one, orderOf_neg_one, + ringChar.eq (ZMod p) p, ite_eq_right hpTwo] + have huEq : u = (-1 : (ZMod p)ˣ) * (-u) := by simp + have hdvd : + p - 1 ∣ 2 * orderOf (-u) := by + have hproduct := + (Commute.all (-1 : (ZMod p)ˣ) (-u)).orderOf_mul_dvd_mul_orderOf + rw [← huEq, huOrder, hnegOneOrder] at hproduct + exact hproduct + have hle : p - 1 ≤ 2 * orderOf (-u) := + Nat.le_of_dvd + (Nat.mul_pos (by norm_num) (orderOf_pos (-u))) hdvd + omega + +/-- The negated trace of a full-order split unit has rotation order at least +half the split-torus cardinality. -/ +theorem half_card_sub_one_le_rotationOrder_neg_splitTorusTrace + (p : ℕ) [Fact p.Prime] (hpTwo : p ≠ 2) + (u : (ZMod p)ˣ) + (huOrder : orderOf u = p - 1) + (huSq : (u : ZMod p) ^ 2 ≠ 1) : + (p - 1) / 2 ≤ rotationOrder (-splitTorusTrace u) := by + have hnegSq : ((-u : (ZMod p)ˣ) : ZMod p) ^ 2 ≠ 1 := by + intro hsq + apply huSq + simpa using hsq + rw [← splitTorusTrace_neg, + rotationOrder_splitTorusTrace (-u) hnegSq] + exact half_card_sub_one_le_orderOf_neg_of_fullOrder + p hpTwo u huOrder + +/-- Normalization sends a signed point's selected coordinate either to the +original normalized coordinate or to its negative. -/ +theorem normalizedCoordinateAt_evenSign_smul_eq_or_eq_neg + {R : Type*} [CommRing R] [Invertible (3 : R)] + (axis : NormalizedCoordinateAxis) (s : EvenSign) + (x : PuncturedMarkoffSurface R) : + normalizedCoordinateAt axis + (normalizedSurfaceOfPunctured + (puncturedNormalizationEquiv R (s • x))).1 = + normalizedCoordinateAt axis + (normalizedSurfaceOfPunctured + (puncturedNormalizationEquiv R x)).1 ∨ + normalizedCoordinateAt axis + (normalizedSurfaceOfPunctured + (puncturedNormalizationEquiv R (s • x))).1 = + -normalizedCoordinateAt axis + (normalizedSurfaceOfPunctured + (puncturedNormalizationEquiv R x)).1 := by + cases axis <;> cases s <;> + simp [normalizedCoordinateAt, normalizedSurfaceOfPunctured, + puncturedNormalizationEquiv_coe, toNormalized, + evenSign_smul_punctured_coe, evenSign_smul_surface_coe, + evenSignPoint] + +/-- Under the explicit half-order threshold, every even sign image of a +split-cage base lies in the base Gamma component. -/ +theorem samePuncturedComponent_evenSign_smul_of_splitCageBase + (p : ℕ) [Fact p.Prime] [Invertible (3 : ZMod p)] + (hpSeven : 7 ≤ p) + (c : PuncturedMarkoffSurface (ZMod p)) + (hbase : IsInSplitCage p + (normalizedSurfaceOfPunctured + (puncturedNormalizationEquiv (ZMod p) c))) + (hhalfThreshold : + (p : ℝ) ^ (5 / 6 : ℝ) ≤ (((p - 1) / 2 : ℕ) : ℝ)) + (hlarge : ∀ z : NormalizedMarkoffSurface (ZMod p), + (p : ℝ) ^ (5 / 6 : ℝ) ≤ + maximalCoordinateRotationOrder z.1 → + SameNormalizedComponent + (normalizedSurfaceOfPunctured + (puncturedNormalizationEquiv (ZMod p) c)) z) : + ∀ s : EvenSign, SamePuncturedComponent c (s • c) := by + intro s + apply (samePuncturedComponent_iff_sameNormalizedComponent c (s • c)).2 + let base := + normalizedSurfaceOfPunctured + (puncturedNormalizationEquiv (ZMod p) c) + let signed := + normalizedSurfaceOfPunctured + (puncturedNormalizationEquiv (ZMod p) (s • c)) + obtain ⟨axis, hmax⟩ := hbase + let t := normalizedCoordinateAt axis base.1 + have hmaxT : IsSplitMaximalTrace p t := by + simpa [t, base] using hmax + obtain ⟨u, htrace, huOrder, huSq⟩ := + exists_fullOrder_splitUnit_of_isSplitMaximalTrace + p hpSeven t hmaxT + have hnegOrder : + (p - 1) / 2 ≤ rotationOrder (-t) := by + rw [← htrace] + exact half_card_sub_one_le_rotationOrder_neg_splitTorusTrace + p (by omega) u huOrder huSq + have hcoordinate := + normalizedCoordinateAt_evenSign_smul_eq_or_eq_neg axis s c + have hcoordinateOrder : + (p - 1) / 2 ≤ + rotationOrder (normalizedCoordinateAt axis signed.1) := by + rcases hcoordinate with hpositive | hnegative + · rw [show normalizedCoordinateAt axis signed.1 = t by + simpa [signed, base, t] using hpositive, + hmaxT] + exact Nat.div_le_self _ _ + · rw [show normalizedCoordinateAt axis signed.1 = -t by + simpa [signed, base, t] using hnegative] + exact hnegOrder + have hcoordinateLe : + rotationOrder (normalizedCoordinateAt axis signed.1) ≤ + maximalCoordinateRotationOrder signed.1 := by + cases axis + · exact rotationOrder_first_le_maximalCoordinateRotationOrder signed.1 + · exact rotationOrder_second_le_maximalCoordinateRotationOrder signed.1 + · exact rotationOrder_third_le_maximalCoordinateRotationOrder signed.1 + apply hlarge signed + exact hhalfThreshold.trans (by + exact_mod_cast hcoordinateOrder.trans hcoordinateLe) + +end + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Assembly/SplitCageNonparabolicComplementFrontier.lean b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/SplitCageNonparabolicComplementFrontier.lean new file mode 100644 index 0000000000..43d9bf327e --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/SplitCageNonparabolicComplementFrontier.lean @@ -0,0 +1,97 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.SplitCageEvenSignBase +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.EvenSignBaseStableComplement +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.NonparabolicComplementFrontier + +/-! +# Split-cage nonparabolic complement frontier + +The split-cage base supplies the only geometric input needed for the +even-sign factor four: every signed image of the base point returns to its +Gamma component. This module discharges both sign-invariance hypotheses of +the nonparabolic complement frontier automatically. +-/ + +@[expose] public section + +namespace BGS.Markoff + +open BGS.NumberTheory + +/-- A split-cage base above the half-order threshold has a component +complement whose cardinality is divisible by four. -/ +theorem four_dvd_puncturedComponentComplementFinset_card_of_splitCageBase + (p : ℕ) [Fact p.Prime] [Invertible (3 : ZMod p)] + (hpSeven : 7 ≤ p) + (c : PuncturedMarkoffSurface (ZMod p)) + (hbase : IsInSplitCage p + (normalizedSurfaceOfPunctured + (puncturedNormalizationEquiv (ZMod p) c))) + (hhalfThreshold : + (p : ℝ) ^ (5 / 6 : ℝ) ≤ (((p - 1) / 2 : ℕ) : ℝ)) + (hlarge : ∀ z : NormalizedMarkoffSurface (ZMod p), + (p : ℝ) ^ (5 / 6 : ℝ) ≤ + maximalCoordinateRotationOrder z.1 → + SameNormalizedComponent + (normalizedSurfaceOfPunctured + (puncturedNormalizationEquiv (ZMod p) c)) z) : + 4 ∣ (puncturedComponentComplementFinset p c).card := by + apply + four_dvd_puncturedComponentComplementFinset_card_of_base_sign_stable + p (by omega) c + exact samePuncturedComponent_evenSign_smul_of_splitCageBase + p hpSeven c hbase hhalfThreshold hlarge + +/-- Nonparabolic paired-maximal-divisor frontier with the even-sign +invariance and factor-four hypotheses discharged by a split-cage base. -/ +theorem + puncturedMarkoffTransitiveAt_of_splitCage_nonparabolicComplement_pairedMaximalDivisor_frontier + (p : ℕ) [Fact p.Prime] [Invertible (3 : ZMod p)] + (hpSeven : 7 ≤ p) + (c : PuncturedMarkoffSurface (ZMod p)) + (hbase : IsInSplitCage p + (normalizedSurfaceOfPunctured + (puncturedNormalizationEquiv (ZMod p) c))) + (hhalfThreshold : + (p : ℝ) ^ (5 / 6 : ℝ) ≤ (((p - 1) / 2 : ℕ) : ℝ)) + (hcube : ∀ d : ℕ, 0 < d → + 8 * p ≤ + (d * maximalDivisorCountSum p (d + 1)) ^ 2 → + (6 * maximalDivisorCountSum p (d + 1)) ^ 3 < d) + (hlinear : ∀ d : ℕ, + (d : ℝ) < (p : ℝ) ^ (5 / 6 : ℝ) → + 24 * maximalDivisorCountSum p (d + 1) * d < p) + (hlarge : ∀ z : NormalizedMarkoffSurface (ZMod p), + (p : ℝ) ^ (5 / 6 : ℝ) ≤ + maximalCoordinateRotationOrder z.1 → + SameNormalizedComponent + (normalizedSurfaceOfPunctured + (puncturedNormalizationEquiv (ZMod p) c)) z) : + PuncturedMarkoffTransitiveAt p Fact.out := by + have hbaseSign : + ∀ s : EvenSign, SamePuncturedComponent c (s • c) := + samePuncturedComponent_evenSign_smul_of_splitCageBase + p hpSeven c hbase hhalfThreshold hlarge + have hsign : + ∀ (s : EvenSign) (x : PuncturedMarkoffSurface (ZMod p)), + s • x ∈ puncturedComponentComplementFinset p c ↔ + x ∈ puncturedComponentComplementFinset p c := + fun s x => + puncturedComponentComplementFinset_evenSign_mem_iff_of_base_stable + p c x hbaseSign s + have hfour : + 4 ∣ (puncturedComponentComplementFinset p c).card := + four_dvd_puncturedComponentComplementFinset_card_of_base_sign_stable + p (by omega) c hbaseSign + exact + puncturedMarkoffTransitiveAt_of_nonparabolicComplement_pairedMaximalDivisor_frontier + p (by omega) c hcube hlinear hlarge hsign hfour + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Assembly/TransitivitySurjectivity.lean b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/TransitivitySurjectivity.lean new file mode 100644 index 0000000000..b803bdc44e --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/TransitivitySurjectivity.lean @@ -0,0 +1,326 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Core.NatConnectivity +public import LeanPool.MarkoffModP.BGS.Markoff.Core.Statements + +/-! +# Punctured finite-field transitivity and reduction surjectivity + +The Markoff equation defines a functor on commutative semirings. This file identifies the +finite-field transitivity statement used by the dynamical proof with the source-faithful +arithmetic statement that reduction from natural-number Markoff solutions is surjective. +-/ + +@[expose] public section + +namespace BGS.Markoff + +/-- Reduction from natural-number solutions, viewed in the existing ring-level surface. -/ +def markoffReductionSurface (p : ℕ) : + SemiringMarkoffSurface ℕ → MarkoffSurface (ZMod p) := + semiringMarkoffSurfaceEquiv (ZMod p) ∘ markoffReduction p + +@[simp] +theorem markoffReductionSurface_origin (p : ℕ) : + markoffReductionSurface p (semiringSurfaceOrigin ℕ) = surfaceOrigin (ZMod p) := by + change semiringMarkoffSurfaceEquiv (ZMod p) + (markoffReduction p (semiringSurfaceOrigin ℕ)) = surfaceOrigin (ZMod p) + rw [markoffReduction_origin, semiringMarkoffSurfaceEquiv_origin] + +@[simp] +theorem markoffReductionSurface_root (p : ℕ) : + markoffReductionSurface p (semiringSurfaceRoot ℕ) = surfaceRoot (ZMod p) := by + change semiringMarkoffSurfaceEquiv (ZMod p) + (markoffReduction p (semiringSurfaceRoot ℕ)) = surfaceRoot (ZMod p) + rw [markoffReduction_root, semiringMarkoffSurfaceEquiv_root] + +private theorem natCoordinate_le_vietaProduct {a b c : ℕ} + (h : a ^ 2 + b ^ 2 + c ^ 2 = 3 * a * b * c) : + a ≤ 3 * b * c := by + by_cases ha : a = 0 + · simp [ha] + · have haPos : 0 < a := Nat.pos_of_ne_zero ha + apply Nat.le_of_mul_le_mul_left _ haPos + calc + a * a ≤ a ^ 2 + b ^ 2 + c ^ 2 := by nlinarith + _ = 3 * a * b * c := h + _ = a * (3 * b * c) := by ring + +@[simp] +theorem markoffReductionSurface_natVieta1 (p : ℕ) (x : SemiringMarkoffSurface ℕ) : + markoffReductionSurface p (natVieta1Surface x) = + vieta1SurfacePerm (ZMod p) (markoffReductionSurface p x) := by + have hle : x.1.x1 ≤ 3 * x.1.x2 * x.1.x3 := + natCoordinate_le_vietaProduct x.2 + apply Subtype.ext + ext + · change ((3 * x.1.x2 * x.1.x3 - x.1.x1 : ℕ) : ZMod p) = + 3 * (x.1.x2 : ZMod p) * (x.1.x3 : ZMod p) - (x.1.x1 : ZMod p) + rw [Nat.cast_sub hle] + push_cast + rfl + · rfl + · rfl + +@[simp] +theorem markoffReductionSurface_natVieta2 (p : ℕ) (x : SemiringMarkoffSurface ℕ) : + markoffReductionSurface p (natVieta2Surface x) = + vieta2SurfacePerm (ZMod p) (markoffReductionSurface p x) := by + have hreorder : x.1.x2 ^ 2 + x.1.x1 ^ 2 + x.1.x3 ^ 2 = + 3 * x.1.x2 * x.1.x1 * x.1.x3 := by + simpa [IsSemiringMarkoff, add_comm, add_left_comm, add_assoc, + mul_comm, mul_left_comm, mul_assoc] using x.2 + have hle : x.1.x2 ≤ 3 * x.1.x1 * x.1.x3 := + natCoordinate_le_vietaProduct hreorder + apply Subtype.ext + ext + · rfl + · change ((3 * x.1.x1 * x.1.x3 - x.1.x2 : ℕ) : ZMod p) = + 3 * (x.1.x1 : ZMod p) * (x.1.x3 : ZMod p) - (x.1.x2 : ZMod p) + rw [Nat.cast_sub hle] + push_cast + rfl + · rfl + +@[simp] +theorem markoffReductionSurface_natVieta3 (p : ℕ) (x : SemiringMarkoffSurface ℕ) : + markoffReductionSurface p (natVieta3Surface x) = + vieta3SurfacePerm (ZMod p) (markoffReductionSurface p x) := by + have hreorder : x.1.x3 ^ 2 + x.1.x1 ^ 2 + x.1.x2 ^ 2 = + 3 * x.1.x3 * x.1.x1 * x.1.x2 := by + simpa [IsSemiringMarkoff, add_comm, add_left_comm, add_assoc, + mul_comm, mul_left_comm, mul_assoc] using x.2 + have hle : x.1.x3 ≤ 3 * x.1.x1 * x.1.x2 := + natCoordinate_le_vietaProduct hreorder + apply Subtype.ext + ext + · rfl + · rfl + · change ((3 * x.1.x1 * x.1.x2 - x.1.x3 : ℕ) : ZMod p) = + 3 * (x.1.x1 : ZMod p) * (x.1.x2 : ZMod p) - (x.1.x3 : ZMod p) + rw [Nat.cast_sub hle] + push_cast + rfl + +@[simp] +theorem markoffReductionSurface_natSwap12 (p : ℕ) (x : SemiringMarkoffSurface ℕ) : + markoffReductionSurface p (natSwap12Surface x) = + swap12SurfacePerm (ZMod p) (markoffReductionSurface p x) := by + apply Subtype.ext + ext <;> rfl + +@[simp] +theorem markoffReductionSurface_natSwap23 (p : ℕ) (x : SemiringMarkoffSurface ℕ) : + markoffReductionSurface p (natSwap23Surface x) = + swap23SurfacePerm (ZMod p) (markoffReductionSurface p x) := by + apply Subtype.ext + ext <;> rfl + +/-- Every word in the finite-field Markoff group has a word in the natural Markoff group whose +action commutes with reduction. -/ +theorem exists_naturalGamma_lift (p : ℕ) (g : Gamma (ZMod p)) : + ∃ h : NaturalGamma, ∀ x : SemiringMarkoffSurface ℕ, + markoffReductionSurface p (h • x) = g • markoffReductionSurface p x := by + let motive : ∀ q : Equiv.Perm (MarkoffSurface (ZMod p)), + q ∈ Subgroup.closure (gammaGenerators (ZMod p)) → Prop := + fun q hq ↦ ∃ h : NaturalGamma, ∀ x : SemiringMarkoffSurface ℕ, + markoffReductionSurface p (h • x) = + (⟨q, hq⟩ : Gamma (ZMod p)) • markoffReductionSurface p x + apply Subgroup.closure_induction (p := motive) + · intro q hq + simp only [gammaGenerators, Set.mem_insert_iff, Set.mem_singleton_iff] at hq + rcases hq with rfl | rfl | rfl | rfl | rfl + · refine ⟨⟨natVieta1SurfaceEquiv, natVieta1SurfaceEquiv_mem_NaturalGamma⟩, fun x ↦ ?_⟩ + exact markoffReductionSurface_natVieta1 p x + · refine ⟨⟨natVieta2SurfaceEquiv, natVieta2SurfaceEquiv_mem_NaturalGamma⟩, fun x ↦ ?_⟩ + exact markoffReductionSurface_natVieta2 p x + · refine ⟨⟨natVieta3SurfaceEquiv, natVieta3SurfaceEquiv_mem_NaturalGamma⟩, fun x ↦ ?_⟩ + exact markoffReductionSurface_natVieta3 p x + · refine ⟨⟨natSwap12SurfaceEquiv, natSwap12SurfaceEquiv_mem_NaturalGamma⟩, fun x ↦ ?_⟩ + exact markoffReductionSurface_natSwap12 p x + · refine ⟨⟨natSwap23SurfaceEquiv, natSwap23SurfaceEquiv_mem_NaturalGamma⟩, fun x ↦ ?_⟩ + exact markoffReductionSurface_natSwap23 p x + · refine ⟨1, fun x ↦ ?_⟩ + change markoffReductionSurface p ((1 : NaturalGamma) • x) = + (1 : Gamma (ZMod p)) • markoffReductionSurface p x + simp + · intro q r hq hr hqLift hrLift + obtain ⟨qNat, hqNat⟩ := hqLift + obtain ⟨rNat, hrNat⟩ := hrLift + refine ⟨qNat * rNat, fun x ↦ ?_⟩ + change markoffReductionSurface p ((qNat * rNat) • x) = + ((⟨q, hq⟩ : Gamma (ZMod p)) * (⟨r, hr⟩ : Gamma (ZMod p))) • + markoffReductionSurface p x + rw [mul_smul, mul_smul, hqNat, hrNat] + · intro q hq hqLift + obtain ⟨qNat, hqNat⟩ := hqLift + refine ⟨qNat⁻¹, fun x ↦ ?_⟩ + change markoffReductionSurface p (qNat⁻¹ • x) = + (⟨q, hq⟩ : Gamma (ZMod p))⁻¹ • markoffReductionSurface p x + have h := congrArg (fun y ↦ (⟨q, hq⟩ : Gamma (ZMod p))⁻¹ • y) + (hqNat (qNat⁻¹ • x)) + simpa [mul_smul] using h.symm + +/-- Every word in the natural Markoff group reduces to a word in the finite-field Markoff group. -/ +theorem exists_gamma_reduction_of_naturalGamma (p : ℕ) (h : NaturalGamma) : + ∃ g : Gamma (ZMod p), ∀ x : SemiringMarkoffSurface ℕ, + markoffReductionSurface p (h • x) = g • markoffReductionSurface p x := by + let motive : ∀ q : Equiv.Perm (SemiringMarkoffSurface ℕ), + q ∈ Subgroup.closure naturalGammaGenerators → Prop := + fun q hq ↦ ∃ g : Gamma (ZMod p), ∀ x : SemiringMarkoffSurface ℕ, + markoffReductionSurface p ((⟨q, hq⟩ : NaturalGamma) • x) = + g • markoffReductionSurface p x + apply Subgroup.closure_induction (p := motive) + · intro q hq + simp only [naturalGammaGenerators, Set.mem_insert_iff, Set.mem_singleton_iff] at hq + rcases hq with rfl | rfl | rfl | rfl | rfl + · refine ⟨gammaVieta1 (ZMod p), fun x ↦ ?_⟩ + exact markoffReductionSurface_natVieta1 p x + · refine ⟨gammaVieta2 (ZMod p), fun x ↦ ?_⟩ + exact markoffReductionSurface_natVieta2 p x + · refine ⟨gammaVieta3 (ZMod p), fun x ↦ ?_⟩ + exact markoffReductionSurface_natVieta3 p x + · refine ⟨gammaSwap12 (ZMod p), fun x ↦ ?_⟩ + exact markoffReductionSurface_natSwap12 p x + · refine ⟨gammaSwap23 (ZMod p), fun x ↦ ?_⟩ + exact markoffReductionSurface_natSwap23 p x + · refine ⟨1, fun x ↦ ?_⟩ + change markoffReductionSurface p ((1 : NaturalGamma) • x) = + (1 : Gamma (ZMod p)) • markoffReductionSurface p x + simp + · intro q r hq hr hqLift hrLift + obtain ⟨qMod, hqMod⟩ := hqLift + obtain ⟨rMod, hrMod⟩ := hrLift + refine ⟨qMod * rMod, fun x ↦ ?_⟩ + change markoffReductionSurface p + (((⟨q, hq⟩ : NaturalGamma) * (⟨r, hr⟩ : NaturalGamma)) • x) = + (qMod * rMod) • markoffReductionSurface p x + rw [mul_smul, mul_smul, hqMod, hrMod] + · intro q hq hqLift + obtain ⟨qMod, hqMod⟩ := hqLift + refine ⟨qMod⁻¹, fun x ↦ ?_⟩ + change markoffReductionSurface p ((⟨q, hq⟩ : NaturalGamma)⁻¹ • x) = + qMod⁻¹ • markoffReductionSurface p x + have hred := congrArg (fun y ↦ qMod⁻¹ • y) + (hqMod ((⟨q, hq⟩ : NaturalGamma)⁻¹ • x)) + simpa [mul_smul] using hred.symm + +/-- Natural Markoff connectivity descends to finite-field Markoff connectivity. -/ +theorem sameComponent_markoffReductionSurface_of_sameNatMarkoffComponent + (p : ℕ) {x y : SemiringMarkoffSurface ℕ} + (hxy : SameNatMarkoffComponent x y) : + SameComponent (markoffReductionSurface p x) (markoffReductionSurface p y) := by + unfold SameNatMarkoffComponent at hxy + rw [MulAction.mem_orbit_iff] at hxy + obtain ⟨h, rfl⟩ := hxy + obtain ⟨g, hg⟩ := exists_gamma_reduction_of_naturalGamma p h + exact (sameComponent_iff_exists _ _).2 ⟨g, (hg x).symm⟩ + +@[simp] +theorem surfaceRoot_ne_surfaceOrigin (R : Type*) [CommRing R] [Nontrivial R] : + surfaceRoot R ≠ surfaceOrigin R := by + intro h + have hfirst := congrArg (fun x : MarkoffSurface R ↦ x.1.x1) h + change (1 : R) = 0 at hfirst + exact one_ne_zero hfirst + +/-- Finite-field transitivity implies surjectivity of reduction from natural-number solutions. -/ +theorem markoffReduction_surjective_of_puncturedMarkoffTransitiveAt + (p : ℕ) (hp : p.Prime) (htransitive : PuncturedMarkoffTransitiveAt p hp) : + Function.Surjective (markoffReduction p) := by + let : Fact p.Prime := ⟨hp⟩ + change ∀ x y : PuncturedMarkoffSurface (ZMod p), + ∃ g : Gamma (ZMod p), g • x = y at htransitive + intro y + let ySurface : MarkoffSurface (ZMod p) := semiringMarkoffSurfaceEquiv (ZMod p) y + by_cases hy : ySurface = surfaceOrigin (ZMod p) + · refine ⟨semiringSurfaceOrigin ℕ, ?_⟩ + apply (semiringMarkoffSurfaceEquiv (ZMod p)).injective + change markoffReductionSurface p (semiringSurfaceOrigin ℕ) = ySurface + rw [markoffReductionSurface_origin, hy] + · let root : PuncturedMarkoffSurface (ZMod p) := + ⟨surfaceRoot (ZMod p), surfaceRoot_ne_surfaceOrigin (ZMod p)⟩ + let target : PuncturedMarkoffSurface (ZMod p) := ⟨ySurface, hy⟩ + obtain ⟨g, hg⟩ := htransitive root target + obtain ⟨h, hh⟩ := exists_naturalGamma_lift p g + refine ⟨h • semiringSurfaceRoot ℕ, ?_⟩ + apply (semiringMarkoffSurfaceEquiv (ZMod p)).injective + change markoffReductionSurface p (h • semiringSurfaceRoot ℕ) = ySurface + calc + markoffReductionSurface p (h • semiringSurfaceRoot ℕ) = + g • markoffReductionSurface p (semiringSurfaceRoot ℕ) := + hh (semiringSurfaceRoot ℕ) + _ = g • surfaceRoot (ZMod p) := by rw [markoffReductionSurface_root] + _ = ySurface := congrArg Subtype.val hg + +/-- Surjectivity of natural-number reduction implies finite-field transitivity. The classical +connectivity of nonzero natural Markoff solutions is the essential input in this direction. -/ +theorem puncturedMarkoffTransitiveAt_of_markoffReduction_surjective + (p : ℕ) (hp : p.Prime) (hsurjective : Function.Surjective (markoffReduction p)) : + PuncturedMarkoffTransitiveAt p hp := by + let : Fact p.Prime := ⟨hp⟩ + change ∀ x y : PuncturedMarkoffSurface (ZMod p), + ∃ g : Gamma (ZMod p), g • x = y + intro x y + let xSemiring : SemiringMarkoffSurface (ZMod p) := + (semiringMarkoffSurfaceEquiv (ZMod p)).symm x.1 + let ySemiring : SemiringMarkoffSurface (ZMod p) := + (semiringMarkoffSurfaceEquiv (ZMod p)).symm y.1 + obtain ⟨xNat, hxNat⟩ := hsurjective xSemiring + obtain ⟨yNat, hyNat⟩ := hsurjective ySemiring + have hxSurface : markoffReductionSurface p xNat = x.1 := by + change semiringMarkoffSurfaceEquiv (ZMod p) (markoffReduction p xNat) = x.1 + rw [hxNat, Equiv.apply_symm_apply] + have hySurface : markoffReductionSurface p yNat = y.1 := by + change semiringMarkoffSurfaceEquiv (ZMod p) (markoffReduction p yNat) = y.1 + rw [hyNat, Equiv.apply_symm_apply] + have hxNatNe : xNat ≠ semiringSurfaceOrigin ℕ := by + intro hxOrigin + subst xNat + rw [markoffReductionSurface_origin] at hxSurface + exact x.2 hxSurface.symm + have hyNatNe : yNat ≠ semiringSurfaceOrigin ℕ := by + intro hyOrigin + subst yNat + rw [markoffReductionSurface_origin] at hySurface + exact y.2 hySurface.symm + have hxNatural : SameNatMarkoffComponent (semiringSurfaceRoot ℕ) xNat := + (natMarkoff_eq_origin_or_sameComponent_root xNat).resolve_left hxNatNe + have hyNatural : SameNatMarkoffComponent (semiringSurfaceRoot ℕ) yNat := + (natMarkoff_eq_origin_or_sameComponent_root yNat).resolve_left hyNatNe + have hxComponent : SameComponent (surfaceRoot (ZMod p)) x.1 := by + simpa only [markoffReductionSurface_root, hxSurface] using + sameComponent_markoffReductionSurface_of_sameNatMarkoffComponent p hxNatural + have hyComponent : SameComponent (surfaceRoot (ZMod p)) y.1 := by + simpa only [markoffReductionSurface_root, hySurface] using + sameComponent_markoffReductionSurface_of_sameNatMarkoffComponent p hyNatural + have hxy : SameComponent x.1 y.1 := + sameComponent_trans (sameComponent_symm hxComponent) hyComponent + obtain ⟨g, hg⟩ := (sameComponent_iff_exists x.1 y.1).1 hxy + refine ⟨g, ?_⟩ + apply Subtype.ext + exact hg + +/-- The source-faithful reduction statement is equivalent to the finite-field transitivity +statement used by the BGS dynamical proof. -/ +theorem puncturedMarkoffTransitiveAt_iff_markoffReduction_surjective + (p : ℕ) (hp : p.Prime) : + PuncturedMarkoffTransitiveAt p hp ↔ Function.Surjective (markoffReduction p) := + ⟨markoffReduction_surjective_of_puncturedMarkoffTransitiveAt p hp, + puncturedMarkoffTransitiveAt_of_markoffReduction_surjective p hp⟩ + +/-- For prime moduli, punctured finite-field transitivity is equivalent to strong +approximation. Natural Markoff connectivity is the essential input from right to left. -/ +theorem puncturedMarkoffTransitiveAt_iff_strongApproximationAt + (p : ℕ) (hp : p.Prime) : + PuncturedMarkoffTransitiveAt p hp ↔ StrongApproximationAt p := + (puncturedMarkoffTransitiveAt_iff_markoffReduction_surjective p hp).trans + (strongApproximationAt_iff_markoffReduction_surjective p).symm + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Assembly/Unconditional.lean b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/Unconditional.lean new file mode 100644 index 0000000000..1ca8f1141e --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/Unconditional.lean @@ -0,0 +1,43 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.GeneralBivariateAffineHasseWeil +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.ExceptionalPrimeCount + +/-! +# Unconditional BGS assembly + +The closed function-field Hasse--Weil theorem now supplies the general affine +plane-curve estimate used by the split, nonsplit, and cage arguments. These +short wrappers close the final parameter of the existing BGS assembly. +-/ + +@[expose] public section + +namespace BGS.Markoff + +/-- **BGS Theorem 1**, with both Corvaja--Zannier and affine Hasse--Weil +discharged in the repository. -/ +theorem theoremOneStatement : TheoremOneStatement := + theoremOneStatement_of_generalHasseWeil + BGS.HasseWeil.generalBivariateAffineHasseWeilTheorem + +/-- The eventual form of BGS Conjecture 1: strong approximation holds at +every sufficiently large prime. -/ +theorem eventually_strongApproximationAt : + ∃ p0 : ℕ, ∀ (p : ℕ), p.Prime → p0 ≤ p → StrongApproximationAt p := + eventually_strongApproximationAt_of_generalHasseWeil + BGS.HasseWeil.generalBivariateAffineHasseWeilTheorem + +/-- **BGS Theorem 2**, obtained from the unconditional Theorem 1 and Chen's +orbit-divisibility theorem, using Martin's later elementary proof. -/ +theorem theoremTwoStatement : TheoremTwoStatement := + theoremTwoStatement_of_generalHasseWeil + BGS.HasseWeil.generalBivariateAffineHasseWeilTheorem + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Assembly/WeightedCoarseSupportSurjectivity.lean b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/WeightedCoarseSupportSurjectivity.lean new file mode 100644 index 0000000000..cafad3b1df --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Assembly/WeightedCoarseSupportSurjectivity.lean @@ -0,0 +1,150 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.CoarseSupportSurjectivity +public import LeanPool.MarkoffModP.BGS.NumberTheory.WeightedNeighborDivisorBound + +/-! +# Weighted certificate-free coarse-support surjectivity + +This module feeds the weighted twentieth moment for the neighboring divisor +counts into the Euler-seven coarse-support obstruction. It improves the +tenth-moment checkpoint without changing the geometric frontier and without +introducing a divisor table or a finite maximal-divisor certificate. +-/ + +@[expose] public section + +namespace BGS.Markoff + +open BGS.NumberTheory + +/-- Open cutoff supplied by the weighted twentieth moment and the Euler-seven +obstruction. -/ +def weightedCoarseSupportStrongApproximationOpenCutoff : ℕ := + 35721 ^ 5 * 2 ^ 1547 * 32769 ^ 2 + +/-- Closed version of `weightedCoarseSupportStrongApproximationOpenCutoff`. -/ +def weightedCoarseSupportStrongApproximationCutoff : ℕ := + weightedCoarseSupportStrongApproximationOpenCutoff + 1 + +private theorem twoPow756_lt_weightedCoarseSupportStrongApproximationOpenCutoff : + 2 ^ 756 < weightedCoarseSupportStrongApproximationOpenCutoff := by + calc + 2 ^ 756 < 2 ^ 1547 := + Nat.pow_lt_pow_right (by norm_num) (by norm_num) + _ = 1 * 2 ^ 1547 * 1 := by ring + _ ≤ 35721 ^ 5 * 2 ^ 1547 * 32769 ^ 2 := by + gcongr <;> norm_num + +/-- The weighted joint twentieth moment rules out the final Euler-seven +obstruction above the exact weighted cutoff. -/ +theorem weighted_35721_mul_divisorSum_pow_eight_lt + {p : ℕ} (hpOdd : Odd p) + (hp : weightedCoarseSupportStrongApproximationOpenCutoff < p) : + 35721 * ((p - 1).divisors.card + (p + 1).divisors.card) ^ 8 < 8 * p := by + let T := (p - 1).divisors.card + (p + 1).divisors.card + let D := neighboringDivisorSumWeightedMomentConstant + have hpPos : 0 < p := (Nat.zero_le _).trans_lt hp + have hpSupport : 2 ^ 756 < p := + twoPow756_lt_weightedCoarseSupportStrongApproximationOpenCutoff.trans hp + have hpLarge : 794039 ≤ p := by + have hsmall : 794039 < 2 ^ 20 := by norm_num + have hpowers : 2 ^ 20 ≤ 2 ^ 756 := + Nat.pow_le_pow_right (by norm_num) (by norm_num) + omega + have hmoment : T ^ 20 ≤ D * p ^ 2 := by + simpa [T, D] using + card_divisors_pred_add_card_divisors_succ_pow_twenty_le hpOdd hpLarge + by_contra hnot + have hbad : 8 * p ≤ 35721 * T ^ 8 := by + exact Nat.le_of_not_gt (by simpa [T] using hnot) + have hbadPow : (8 * p) ^ 5 ≤ (35721 * T ^ 8) ^ 5 := + Nat.pow_le_pow_left hbad 5 + have hmomentPow : (T ^ 20) ^ 2 ≤ (D * p ^ 2) ^ 2 := + Nat.pow_le_pow_left hmoment 2 + have hcombined : + 2 ^ 15 * p ^ 5 ≤ 35721 ^ 5 * D ^ 2 * p ^ 4 := by + calc + 2 ^ 15 * p ^ 5 = (8 * p) ^ 5 := by ring + _ ≤ (35721 * T ^ 8) ^ 5 := hbadPow + _ = 35721 ^ 5 * (T ^ 20) ^ 2 := by ring + _ ≤ 35721 ^ 5 * (D * p ^ 2) ^ 2 := + Nat.mul_le_mul_left _ hmomentPow + _ = 35721 ^ 5 * D ^ 2 * p ^ 4 := by ring + have hcombined' : + (2 ^ 15 * p) * p ^ 4 ≤ + (35721 ^ 5 * D ^ 2) * p ^ 4 := by + simpa only [show p ^ 5 = p * p ^ 4 by ring, Nat.mul_assoc] using hcombined + have hcancel : 2 ^ 15 * p ≤ 35721 ^ 5 * D ^ 2 := + Nat.le_of_mul_le_mul_right hcombined' (pow_pos hpPos 4) + have hfactor : + 35721 ^ 5 * D ^ 2 = + 2 ^ 15 * weightedCoarseSupportStrongApproximationOpenCutoff := by + have hD : D = 2 ^ 781 * 32769 := + neighboringDivisorSumWeightedMomentConstant_eq + rw [hD, mul_pow] + rw [show (2 ^ 781) ^ 2 = 2 ^ 1562 by + rw [show (1562 : ℕ) = 781 * 2 by norm_num, pow_mul]] + rw [show (1562 : ℕ) = 15 + 1547 by norm_num, pow_add] + unfold weightedCoarseSupportStrongApproximationOpenCutoff + ring + have hcutoffUpper : + p ≤ weightedCoarseSupportStrongApproximationOpenCutoff := by + rw [hfactor] at hcancel + have hcancel' : + p * 2 ^ 15 ≤ + weightedCoarseSupportStrongApproximationOpenCutoff * 2 ^ 15 := by + simpa only [Nat.mul_comm] using hcancel + exact Nat.le_of_mul_le_mul_right hcancel' (pow_pos (by norm_num) 15) + exact (Nat.not_le_of_lt hp) hcutoffUpper + +/-- The weighted cutoff dominates the support-only threshold used by the +coarse endgame and cage arguments. -/ +theorem twoPow756_lt_of_weightedCoarseSupportOpenCutoff_lt + {p : ℕ} + (hp : weightedCoarseSupportStrongApproximationOpenCutoff < p) : + 2 ^ 756 < p := + twoPow756_lt_weightedCoarseSupportStrongApproximationOpenCutoff.trans hp + +/-- Natural Markoff reduction is surjective above the weighted +certificate-free cutoff. -/ +theorem markoffReduction_surjective_of_weightedCoarseSupportOpenCutoff + (p : ℕ) (hpPrime : p.Prime) + (hp : weightedCoarseSupportStrongApproximationOpenCutoff < p) : + Function.Surjective (markoffReduction p) := by + letI : Fact p.Prime := ⟨hpPrime⟩ + have hpThree : 3 < p := by + have hsupport := twoPow756_lt_of_weightedCoarseSupportOpenCutoff_lt hp + omega + have hpOdd : Odd p := + hpPrime.odd_of_ne_two (by omega) + letI : Invertible (3 : ZMod p) := + invertibleOfNonzero + (natCast_ne_zero_zmod_of_pos_of_lt (by norm_num) hpThree) + let T := (p - 1).divisors.card + (p + 1).divisors.card + apply markoffReduction_surjective_of_eulerSevenSquareEnvelope_coarseSupport + p (twoPow756_lt_of_weightedCoarseSupportOpenCutoff_lt hp) (fun _ ↦ T ^ 2) + · intro d + simpa [T] using maximalDivisorCountSum_sq_le_divisorSum_sq p d + · intro d + calc + 35721 * (T ^ 2) ^ 4 = 35721 * T ^ 8 := by ring + _ < 8 * p := by + simpa [T] using + weighted_35721_mul_divisorSum_pow_eight_lt hpOdd hp + +/-- Closed-cutoff form used by the public Comparator theorem. -/ +theorem markoffReduction_surjective_of_weightedCoarseSupportBound + (p : ℕ) (hpPrime : p.Prime) + (hp : weightedCoarseSupportStrongApproximationCutoff ≤ p) : + Function.Surjective (markoffReduction p) := by + apply markoffReduction_surjective_of_weightedCoarseSupportOpenCutoff p hpPrime + simpa [weightedCoarseSupportStrongApproximationCutoff] using hp + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Cage.lean b/LeanPool/MarkoffModP/BGS/Markoff/Cage.lean new file mode 100644 index 0000000000..7095c00a82 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Cage.lean @@ -0,0 +1,22 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Cage.AxisEquivalence +public import LeanPool.MarkoffModP.BGS.Markoff.Cage.BiquadraticPrimitiveQuartic +public import LeanPool.MarkoffModP.BGS.Markoff.Cage.Connectivity +public import LeanPool.MarkoffModP.BGS.Markoff.Cage.EstimateFromPlane +public import LeanPool.MarkoffModP.BGS.Markoff.Cage.HasseWeilAssumption +public import LeanPool.MarkoffModP.BGS.Markoff.Cage.IncidenceGeometry +public import LeanPool.MarkoffModP.BGS.Markoff.Cage.PlaneCountComparison +public import LeanPool.MarkoffModP.BGS.Markoff.Cage.PlaneHasseWeil +public import LeanPool.MarkoffModP.BGS.Markoff.Cage.PlaneModels +public import LeanPool.MarkoffModP.BGS.Markoff.Cage.PowerCover +public import LeanPool.MarkoffModP.BGS.Markoff.Cage.PulledRadicand +public import LeanPool.MarkoffModP.BGS.Markoff.Cage.ShiftedTraceCurveIrreducibility +public import LeanPool.MarkoffModP.BGS.Markoff.Cage.SmallPrime +public import LeanPool.MarkoffModP.BGS.Markoff.Cage.WitnessEquations diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Cage/AxisEquivalence.lean b/LeanPool/MarkoffModP/BGS/Markoff/Cage/AxisEquivalence.lean new file mode 100644 index 0000000000..5109fb4811 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Cage/AxisEquivalence.lean @@ -0,0 +1,298 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Cage.HasseWeilAssumption + +/-! +# Coordinate-axis invariance of cage witnesses + +The cage geometry is symmetric in the three normalized coordinates, but its +point-count argument is written for the canonical ordered pair of outer axes +`(.first, .second)`. The two incidence witnesses are independent points, so +they may be permuted independently while their common bridge coordinate is +sent to the third coordinate. This file records that symmetry as an actual +equivalence, retaining the common trace exactly. +-/ + +@[expose] public section + +namespace BGS.Markoff + +noncomputable section + +/-- Swapping the first two normalized coordinates as an equivalence. -/ +def normalizedSwap12Equiv (R : Type*) : + NormalizedPoint R ≃ NormalizedPoint R where + toFun := normalizedSwap12 + invFun := normalizedSwap12 + left_inv x := by ext <;> rfl + right_inv x := by ext <;> rfl + +/-- Swapping the last two normalized coordinates as an equivalence. -/ +def normalizedSwap23Equiv (R : Type*) : + NormalizedPoint R ≃ NormalizedPoint R where + toFun := normalizedSwap23 + invFun := normalizedSwap23 + left_inv x := by ext <;> rfl + right_inv x := by ext <;> rfl + +/-- Permute the first incidence point so that its outer coordinate is first +and its bridge coordinate is third. -/ +def cageFirstPointCanonicalEquiv (R : Type*) + (axis other : NormalizedCoordinateAxis) : + NormalizedPoint R ≃ NormalizedPoint R := + match axis, other with + | .first, .first => normalizedSwap23Equiv R + | .first, .second => Equiv.refl _ + | .first, .third => normalizedSwap23Equiv R + | .second, .first => normalizedSwap12Equiv R + | .second, .second => + (normalizedSwap12Equiv R).trans (normalizedSwap23Equiv R) + | .second, .third => + (normalizedSwap12Equiv R).trans (normalizedSwap23Equiv R) + | .third, .first => + (normalizedSwap23Equiv R).trans (normalizedSwap12Equiv R) + | .third, .second => + ((normalizedSwap12Equiv R).trans (normalizedSwap23Equiv R)).trans + (normalizedSwap12Equiv R) + | .third, .third => + ((normalizedSwap12Equiv R).trans (normalizedSwap23Equiv R)).trans + (normalizedSwap12Equiv R) + +/-- Permute the second incidence point so that its outer coordinate is second +and its bridge coordinate is third. -/ +def cageSecondPointCanonicalEquiv (R : Type*) + (axis other : NormalizedCoordinateAxis) : + NormalizedPoint R ≃ NormalizedPoint R := + match axis, other with + | .first, .first => + (normalizedSwap23Equiv R).trans (normalizedSwap12Equiv R) + | .first, .second => Equiv.refl _ + | .first, .third => normalizedSwap23Equiv R + | .second, .first => normalizedSwap12Equiv R + | .second, .second => + ((normalizedSwap12Equiv R).trans (normalizedSwap23Equiv R)).trans + (normalizedSwap12Equiv R) + | .second, .third => + (normalizedSwap12Equiv R).trans (normalizedSwap23Equiv R) + | .third, .first => + (normalizedSwap23Equiv R).trans (normalizedSwap12Equiv R) + | .third, .second => + ((normalizedSwap12Equiv R).trans (normalizedSwap23Equiv R)).trans + (normalizedSwap12Equiv R) + | .third, .third => + (normalizedSwap12Equiv R).trans (normalizedSwap23Equiv R) + +/-- Canonicalizing the first incidence point preserves its outer and bridge coordinates. -/ +theorem cageFirstPointCanonical_mem + {R : Type*} [CommRing R] + (axis other : NormalizedCoordinateAxis) (xi middle : R) + {x : NormalizedPoint R} + (hOuter : x ∈ normalizedFiberAt axis xi) + (hMiddle : normalizedCoordinateAt (cageBridgeAxis axis other) x = middle) : + (cageFirstPointCanonicalEquiv R axis other) x ∈ + normalizedFiberAt .first xi ∧ + normalizedCoordinateAt .third + ((cageFirstPointCanonicalEquiv R axis other) x) = middle := by + cases axis <;> cases other <;> + simp only [cageFirstPointCanonicalEquiv, normalizedSwap12Equiv, + normalizedSwap23Equiv, Equiv.trans_apply, Equiv.refl_apply, + normalizedFiberAt, normalizedCoordinateAt, cageBridgeAxis] + at hOuter hMiddle ⊢ + all_goals + refine ⟨⟨?_, hOuter.2⟩, ?_⟩ + · have hSurface := hOuter.1 + dsimp [IsNormalizedMarkoff, normalizedPolynomial] at hSurface + dsimp [IsNormalizedMarkoff, normalizedPolynomial, + normalizedSwap12, normalizedSwap23] + ring_nf at hSurface ⊢ + exact hSurface + · exact hMiddle + +/-- Canonicalizing the second incidence point preserves its outer and bridge coordinates. -/ +theorem cageSecondPointCanonical_mem + {R : Type*} [CommRing R] + (axis other : NormalizedCoordinateAxis) (eta middle : R) + {x : NormalizedPoint R} + (hOuter : x ∈ normalizedFiberAt other eta) + (hMiddle : normalizedCoordinateAt (cageBridgeAxis axis other) x = middle) : + (cageSecondPointCanonicalEquiv R axis other) x ∈ + normalizedFiberAt .second eta ∧ + normalizedCoordinateAt .third + ((cageSecondPointCanonicalEquiv R axis other) x) = middle := by + cases axis <;> cases other <;> + simp only [cageSecondPointCanonicalEquiv, normalizedSwap12Equiv, + normalizedSwap23Equiv, Equiv.trans_apply, Equiv.refl_apply, + normalizedFiberAt, normalizedCoordinateAt, cageBridgeAxis] + at hOuter hMiddle ⊢ + all_goals + refine ⟨⟨?_, hOuter.2⟩, ?_⟩ + · have hSurface := hOuter.1 + dsimp [IsNormalizedMarkoff, normalizedPolynomial] at hSurface + dsimp [IsNormalizedMarkoff, normalizedPolynomial, + normalizedSwap12, normalizedSwap23] + ring_nf at hSurface ⊢ + exact hSurface + · exact hMiddle + +/-- Send an arbitrary ordered pair of cage axes to the canonical ordered pair. +The two points are permuted independently and their common bridge coordinate +becomes the common third coordinate. -/ +def cageMiddleWitnessToCanonical + (p : ℕ) [Fact p.Prime] + (axis other : NormalizedCoordinateAxis) (xi eta : ZMod p) : + CageMiddleWitnessPair p axis other xi eta → + CageMiddleWitnessPair p .first .second xi eta := fun z => by + let firstPoint := + (cageFirstPointCanonicalEquiv (ZMod p) axis other) z.1.1 + let secondPoint := + (cageSecondPointCanonicalEquiv (ZMod p) axis other) z.1.2 + have hFirst := cageFirstPointCanonical_mem axis other xi + (normalizedCoordinateAt (cageBridgeAxis axis other) z.1.1) + z.2.1 rfl + have hSecondMiddle : + normalizedCoordinateAt (cageBridgeAxis axis other) z.1.2 = + normalizedCoordinateAt (cageBridgeAxis axis other) z.1.1 := + z.2.2.2.symm + have hSecond := cageSecondPointCanonical_mem axis other eta + (normalizedCoordinateAt (cageBridgeAxis axis other) z.1.1) + z.2.2.1 hSecondMiddle + exact ⟨(firstPoint, secondPoint), hFirst.1, hSecond.1, + hFirst.2.trans hSecond.2.symm⟩ + +private theorem cageFirstPointCanonicalEquiv_preserves_surface + {R : Type*} [CommRing R] + (axis other : NormalizedCoordinateAxis) (x : NormalizedPoint R) : + IsNormalizedMarkoff ((cageFirstPointCanonicalEquiv R axis other) x) ↔ + IsNormalizedMarkoff x := by + cases axis <;> cases other <;> + simp [cageFirstPointCanonicalEquiv, normalizedSwap12Equiv, + normalizedSwap23Equiv, IsNormalizedMarkoff, + normalizedPolynomial_swap12, normalizedPolynomial_swap23] + +private theorem cageSecondPointCanonicalEquiv_preserves_surface + {R : Type*} [CommRing R] + (axis other : NormalizedCoordinateAxis) (x : NormalizedPoint R) : + IsNormalizedMarkoff ((cageSecondPointCanonicalEquiv R axis other) x) ↔ + IsNormalizedMarkoff x := by + cases axis <;> cases other <;> + simp [cageSecondPointCanonicalEquiv, normalizedSwap12Equiv, + normalizedSwap23Equiv, IsNormalizedMarkoff, + normalizedPolynomial_swap12, normalizedPolynomial_swap23] + +/-- The inverse coordinate permutations reconstruct a witness on the original +ordered pair of axes. -/ +def canonicalCageMiddleWitnessToAxes + (p : ℕ) [Fact p.Prime] + (axis other : NormalizedCoordinateAxis) (xi eta : ZMod p) : + CageMiddleWitnessPair p .first .second xi eta → + CageMiddleWitnessPair p axis other xi eta := fun z => by + let firstPoint := + (cageFirstPointCanonicalEquiv (ZMod p) axis other).symm z.1.1 + let secondPoint := + (cageSecondPointCanonicalEquiv (ZMod p) axis other).symm z.1.2 + refine ⟨(firstPoint, secondPoint), ?_⟩ + cases axis <;> cases other <;> + simp [firstPoint, secondPoint, cageFirstPointCanonicalEquiv, + cageSecondPointCanonicalEquiv, normalizedSwap12Equiv, + normalizedSwap23Equiv, + normalizedSwap12, normalizedSwap23, normalizedFiberAt, + normalizedCoordinateAt, cageBridgeAxis] at z ⊢ + all_goals + rcases z.2 with ⟨⟨hFirstSurface, hxi⟩, + ⟨⟨hSecondSurface, heta⟩, hmiddle⟩⟩ + exact ⟨⟨by + dsimp [IsNormalizedMarkoff, normalizedPolynomial, + normalizedSwap12, normalizedSwap23] at hFirstSurface ⊢ + ring_nf at hFirstSurface ⊢ + exact hFirstSurface, hxi⟩, + ⟨⟨by + dsimp [IsNormalizedMarkoff, normalizedPolynomial, + normalizedSwap12, normalizedSwap23] at hSecondSurface ⊢ + ring_nf at hSecondSurface ⊢ + exact hSecondSurface, heta⟩, + hmiddle⟩⟩ + +/-- Cage witness pairs for arbitrary axes are canonically equivalent to the +first--second model used by the plane equations. -/ +def cageMiddleWitnessEquivCanonical + (p : ℕ) [Fact p.Prime] + (axis other : NormalizedCoordinateAxis) (xi eta : ZMod p) : + CageMiddleWitnessPair p axis other xi eta ≃ + CageMiddleWitnessPair p .first .second xi eta where + toFun := cageMiddleWitnessToCanonical p axis other xi eta + invFun := canonicalCageMiddleWitnessToAxes p axis other xi eta + left_inv z := by + apply Subtype.ext + apply Prod.ext <;> apply NormalizedPoint.ext <;> + cases axis <;> cases other <;> rfl + right_inv z := by + apply Subtype.ext + apply Prod.ext <;> apply NormalizedPoint.ext <;> + cases axis <;> cases other <;> rfl + +/-- Canonicalizing the axes preserves the common middle trace exactly. -/ +@[simp] +theorem cageMiddleWitnessEquivCanonical_trace + (p : ℕ) [Fact p.Prime] + (axis other : NormalizedCoordinateAxis) (xi eta : ZMod p) + (z : CageMiddleWitnessPair p axis other xi eta) : + cageMiddleWitnessTrace + (cageMiddleWitnessEquivCanonical p axis other xi eta z) = + cageMiddleWitnessTrace z := by + cases axis <;> cases other <;> rfl + +/-- Axis canonicalization extends to the one-sided power-range solutions used +by the cage point count. -/ +def cageMiddleWitnessPowerRangeEquivCanonical + (p : ℕ) [Fact p.Prime] + (axis other : NormalizedCoordinateAxis) (xi eta : ZMod p) (d : ℕ) : + cageMiddleWitnessPowerRangeSolutions p axis other xi eta d ≃ + cageMiddleWitnessPowerRangeSolutions p .first .second xi eta d where + toFun z := ⟨(cageMiddleWitnessEquivCanonical p axis other xi eta z.1.1, z.1.2), by + simpa using z.2⟩ + invFun z := ⟨((cageMiddleWitnessEquivCanonical p axis other xi eta).symm z.1.1, + z.1.2), by + have htrace := cageMiddleWitnessEquivCanonical_trace + p axis other xi eta + ((cageMiddleWitnessEquivCanonical p axis other xi eta).symm z.1.1) + calc + cageMiddleWitnessTrace + ((cageMiddleWitnessEquivCanonical p axis other xi eta).symm z.1.1) = + cageMiddleWitnessTrace + (cageMiddleWitnessEquivCanonical p axis other xi eta + ((cageMiddleWitnessEquivCanonical p axis other xi eta).symm z.1.1)) := + htrace.symm + _ = cageMiddleWitnessTrace z.1.1 := by + rw [(cageMiddleWitnessEquivCanonical p axis other xi eta).apply_symm_apply] + _ = splitTorusTrace z.1.2 := z.2⟩ + left_inv z := by + apply Subtype.ext + apply Prod.ext + · exact (cageMiddleWitnessEquivCanonical p axis other xi eta).left_inv z.1.1 + · rfl + right_inv z := by + apply Subtype.ext + apply Prod.ext + · exact (cageMiddleWitnessEquivCanonical p axis other xi eta).right_inv z.1.1 + · rfl + +/-- The witness-bearing cage count is independent of the chosen ordered pair +of outer coordinate axes. -/ +theorem natCard_cageMiddleWitnessPowerRangeSolutions_eq_canonical + (p : ℕ) [Fact p.Prime] + (axis other : NormalizedCoordinateAxis) (xi eta : ZMod p) (d : ℕ) : + Nat.card (cageMiddleWitnessPowerRangeSolutions p axis other xi eta d) = + Nat.card (cageMiddleWitnessPowerRangeSolutions + p .first .second xi eta d) := + Nat.card_congr + (cageMiddleWitnessPowerRangeEquivCanonical p axis other xi eta d) + +end + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Cage/BiquadraticPrimitiveQuartic.lean b/LeanPool/MarkoffModP/BGS/Markoff/Cage/BiquadraticPrimitiveQuartic.lean new file mode 100644 index 0000000000..27ec265b07 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Cage/BiquadraticPrimitiveQuartic.lean @@ -0,0 +1,278 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import Mathlib.Algebra.Polynomial.Degree.IsMonicOfDegree +public import LeanPool.MarkoffModP.BGS.Markoff.Incidence.CoordinateRing + +/-! +# A primitive quartic for a biquadratic extension + +If `f`, `g`, and `f * g` are nonsquares in a field of characteristic different +from two, then `sqrt f + sqrt g` generates the corresponding biquadratic +extension. Its minimal polynomial is + +`(X^2 - (f + g))^2 - 4 * f * g`. + +This file packages that calculation as a reusable irreducibility theorem. +-/ + +@[expose] public section + +namespace BGS.Markoff + +open Polynomial + +noncomputable section + +variable {F : Type*} [Field F] + +private lemma sum_of_square_roots_power_sum + {R : Type*} [CommRing R] (a b f g c0 c1 c2 c3 : R) + (ha : a ^ 2 = f) (hb : b ^ 2 = g) : + (c0 + c2 * (f + g)) + + (c1 + c3 * (f + 3 * g)) * a + + (c1 + c3 * (3 * f + g)) * b + + (2 * c2) * a * b = + c0 * 1 + c1 * (a + b) + c2 * (a + b) ^ 2 + c3 * (a + b) ^ 3 := by + rw [← ha, ← hb] + ring + +private lemma sum_of_square_roots_quartic_relation + {R : Type*} [CommRing R] (a b f g : R) + (ha : a ^ 2 = f) (hb : b ^ 2 = g) : + ((a + b) ^ 2 - (f + g)) ^ 2 - 4 * f * g = 0 := by + rw [← ha, ← hb] + ring + +private lemma finFour_power_relation + {R S : Type*} [CommRing R] [CommRing S] [Algebra R S] + (c : Fin 4 → R) (z : S) + (h : ∑ i : Fin 4, c i • z ^ (i : ℕ) = 0) : + algebraMap R S (c 0) * 1 + algebraMap R S (c 1) * z + + algebraMap R S (c 2) * z ^ 2 + algebraMap R S (c 3) * z ^ 3 = 0 := by + simpa [Fin.sum_univ_four, Algebra.smul_def] using h + +private lemma regroup_quadratic_tower_coefficients + {R S T : Type*} [CommRing R] [CommRing S] [CommRing T] + [Algebra R S] [Algebra S T] [Algebra R T] [IsScalarTower R S T] + (r : S) (s : T) (A0 A1 B0 B1 : R) : + algebraMap R T A0 + algebraMap R T A1 * algebraMap S T r + + algebraMap R T B0 * s + algebraMap R T B1 * algebraMap S T r * s = + algebraMap S T (algebraMap R S A0 + algebraMap R S A1 * r) + + algebraMap S T (algebraMap R S B0 + algebraMap R S B1 * r) * s := by + simp only [map_add, map_mul, IsScalarTower.algebraMap_apply R S T] + ring + +/-- The minimal-polynomial candidate for `sqrt f + sqrt g`. -/ +def biquadraticPrimitiveQuartic (f g : F) : F[X] := + (X ^ 2 - C (f + g)) ^ 2 - C (4 * f * g) + +lemma biquadraticPrimitiveQuartic_monic (f g : F) : + (biquadraticPrimitiveQuartic f g).Monic := by + have hquadratic : IsMonicOfDegree (X ^ 2 - C (f + g) : F[X]) 2 := + (isMonicOfDegree_X_pow F 2).sub (by simp) + exact ((hquadratic.pow 2).sub (by + have hpos : 0 < 2 * 2 := by norm_num + simpa only [← C_mul, natDegree_C] using hpos)).monic + +lemma biquadraticPrimitiveQuartic_degree (f g : F) : + (biquadraticPrimitiveQuartic f g).degree = 4 := by + have hquadratic : IsMonicOfDegree (X ^ 2 - C (f + g) : F[X]) 2 := + (isMonicOfDegree_X_pow F 2).sub (by simp) + have hquartic : IsMonicOfDegree (biquadraticPrimitiveQuartic f g) 4 := by + simpa [biquadraticPrimitiveQuartic] using + (hquadratic.pow 2).sub (by + have hpos : 0 < 2 * 2 := by norm_num + simpa only [← C_mul, natDegree_C] using hpos) + rw [degree_eq_natDegree hquartic.ne_zero, hquartic.natDegree_eq] + norm_num + +/-- Three independent square classes give the irreducible primitive quartic +of the associated biquadratic extension. -/ +theorem biquadraticPrimitiveQuartic_irreducible + (h2 : (2 : F) ≠ 0) {f g : F} + (hf : ¬ IsSquare f) (hg : ¬ IsSquare g) + (hfg : ¬ IsSquare (f * g)) : + Irreducible (biquadraticPrimitiveQuartic f g) := by + let qf : F[X] := adjoinSquarePolynomial f + have hqfIrreducible : Irreducible qf := by + simpa [qf] using adjoinSquarePolynomial_irreducible_of_not_isSquare hf + let : Fact (Irreducible qf) := ⟨hqfIrreducible⟩ + let E := AdjoinRoot qf + let gE : E := algebraMap F E g + have hgE : ¬ IsSquare gE := by + exact not_isSquare_algebraMap_adjoinSquare_of_independent h2 hf hg hfg + let qg : E[X] := adjoinSquarePolynomial gE + have hqgIrreducible : Irreducible qg := by + simpa [qg] using adjoinSquarePolynomial_irreducible_of_not_isSquare hgE + let : Fact (Irreducible qg) := ⟨hqgIrreducible⟩ + let L := AdjoinRoot qg + let a : L := algebraMap E L (AdjoinRoot.root qf) + let b : L := AdjoinRoot.root qg + let z : L := a + b + have hqfMonic : qf.Monic := by + simpa [qf] using adjoinSquarePolynomial_monic f + have hqgMonic : qg.Monic := by + simpa [qg] using adjoinSquarePolynomial_monic gE + have hqfDegree : qf.natDegree = 2 := by + simpa [qf] using adjoinSquarePolynomial_natDegree f + have hqgDegree : qg.natDegree = 2 := by + simpa [qg] using adjoinSquarePolynomial_natDegree gE + have ha_sq : a ^ 2 = algebraMap F L f := by + change (algebraMap E L (AdjoinRoot.root qf)) ^ 2 = algebraMap F L f + rw [← map_pow, show (AdjoinRoot.root qf) ^ 2 = algebraMap F E f by + simpa only [E, qf, AdjoinRoot.algebraMap_eq] using adjoinSquareRoot_sq f] + exact IsScalarTower.algebraMap_apply F E L f + have hb_sq : b ^ 2 = algebraMap F L g := by + change (AdjoinRoot.root qg) ^ 2 = algebraMap F L g + rw [show (AdjoinRoot.root qg) ^ 2 = algebraMap E L gE by + simpa only [L, qg, AdjoinRoot.algebraMap_eq] using adjoinSquareRoot_sq gE] + exact IsScalarTower.algebraMap_apply F E L g + have hfg_ne : f ≠ g := by + intro heq + apply hfg + refine ⟨f, ?_⟩ + rw [heq] + let firstBasis : Module.Basis (Fin qf.natDegree) F E := + (AdjoinRoot.powerBasis' hqfMonic).basis + let secondBasis : Module.Basis (Fin qg.natDegree) E L := + (AdjoinRoot.powerBasis' hqgMonic).basis + let firstZero : Fin qf.natDegree := ⟨0, by rw [hqfDegree]; norm_num⟩ + let firstOne : Fin qf.natDegree := ⟨1, by rw [hqfDegree]; norm_num⟩ + let secondZero : Fin qg.natDegree := ⟨0, by rw [hqgDegree]; norm_num⟩ + let secondOne : Fin qg.natDegree := ⟨1, by rw [hqgDegree]; norm_num⟩ + have hfirst_ne : firstZero ≠ firstOne := by + intro h + have := congrArg Fin.val h + norm_num [firstZero, firstOne] at this + have hsecond_ne : secondZero ≠ secondOne := by + intro h + have := congrArg Fin.val h + norm_num [secondZero, secondOne] at this + have hfirst0 : firstBasis firstZero = 1 := by + change (AdjoinRoot.powerBasis' hqfMonic).basis firstZero = 1 + simp only [PowerBasis.coe_basis] + change AdjoinRoot.root qf ^ 0 = 1 + exact pow_zero _ + have hfirst1 : firstBasis firstOne = AdjoinRoot.root qf := by + change (AdjoinRoot.powerBasis' hqfMonic).basis firstOne = AdjoinRoot.root qf + simp only [PowerBasis.coe_basis] + change AdjoinRoot.root qf ^ 1 = AdjoinRoot.root qf + exact pow_one _ + have hsecond0 : secondBasis secondZero = 1 := by + change (AdjoinRoot.powerBasis' hqgMonic).basis secondZero = 1 + simp only [PowerBasis.coe_basis] + change AdjoinRoot.root qg ^ 0 = 1 + exact pow_zero _ + have hsecond1 : secondBasis secondOne = AdjoinRoot.root qg := by + change (AdjoinRoot.powerBasis' hqgMonic).basis secondOne = AdjoinRoot.root qg + simp only [PowerBasis.coe_basis] + change AdjoinRoot.root qg ^ 1 = AdjoinRoot.root qg + exact pow_one _ + have hpowers : LinearIndependent F (fun i : Fin 4 ↦ z ^ (i : ℕ)) := by + refine Fintype.linearIndependent_iff.mpr ?_ + intro c hc i + have hcExpanded := finFour_power_relation c z hc + have hrelation : + algebraMap F L (c 0 + c 2 * (f + g)) + + algebraMap F L (c 1 + c 3 * (f + 3 * g)) * a + + algebraMap F L (c 1 + c 3 * (3 * f + g)) * b + + algebraMap F L (2 * c 2) * a * b = 0 := by + calc + algebraMap F L (c 0 + c 2 * (f + g)) + + algebraMap F L (c 1 + c 3 * (f + 3 * g)) * a + + algebraMap F L (c 1 + c 3 * (3 * f + g)) * b + + algebraMap F L (2 * c 2) * a * b = + algebraMap F L (c 0) * 1 + + algebraMap F L (c 1) * z + + algebraMap F L (c 2) * z ^ 2 + + algebraMap F L (c 3) * z ^ 3 := by + simpa only [z, map_add, map_mul, map_ofNat] using + sum_of_square_roots_power_sum a b + (algebraMap F L f) (algebraMap F L g) + (algebraMap F L (c 0)) (algebraMap F L (c 1)) + (algebraMap F L (c 2)) (algebraMap F L (c 3)) ha_sq hb_sq + _ = 0 := hcExpanded + let constantCoefficient : E := + algebraMap F E (c 0 + c 2 * (f + g)) + + algebraMap F E (c 1 + c 3 * (f + 3 * g)) * AdjoinRoot.root qf + let rootCoefficient : E := + algebraMap F E (c 1 + c 3 * (3 * f + g)) + + algebraMap F E (2 * c 2) * AdjoinRoot.root qf + have hregroup : + algebraMap E L constantCoefficient + + algebraMap E L rootCoefficient * b = 0 := by + rw [← hrelation] + simpa only [constantCoefficient, rootCoefficient, a] using + (regroup_quadratic_tower_coefficients + (R := F) (S := E) (T := L) (AdjoinRoot.root qf) b + (c 0 + c 2 * (f + g)) + (c 1 + c 3 * (f + 3 * g)) + (c 1 + c 3 * (3 * f + g)) (2 * c 2)).symm + have hsecondRelation : + constantCoefficient • secondBasis secondZero + + rootCoefficient • secondBasis secondOne = 0 := by + simpa only [hsecond0, hsecond1, Algebra.smul_def, b, mul_one] using hregroup + have hconstant := congrArg (secondBasis.coord secondZero) hsecondRelation + have hroot := congrArg (secondBasis.coord secondOne) hsecondRelation + have hconstant_zero : constantCoefficient = 0 := by + simpa [hsecond_ne] using hconstant + have hroot_zero : rootCoefficient = 0 := by + simpa [hsecond_ne] using hroot + have hconstantFirstRelation : + (c 0 + c 2 * (f + g)) • firstBasis firstZero + + (c 1 + c 3 * (f + 3 * g)) • firstBasis firstOne = 0 := by + simpa [constantCoefficient, hfirst0, hfirst1, Algebra.smul_def] using + hconstant_zero + have hrootFirstRelation : + (c 1 + c 3 * (3 * f + g)) • firstBasis firstZero + + (2 * c 2) • firstBasis firstOne = 0 := by + simpa [rootCoefficient, hfirst0, hfirst1, Algebra.smul_def] using hroot_zero + have hc0c2 := congrArg (firstBasis.coord firstZero) hconstantFirstRelation + have hc1c3Left := congrArg (firstBasis.coord firstOne) hconstantFirstRelation + have hc1c3Right := congrArg (firstBasis.coord firstZero) hrootFirstRelation + have hc2two := congrArg (firstBasis.coord firstOne) hrootFirstRelation + have hc2 : c 2 = 0 := by + have : (2 : F) * c 2 = 0 := by simpa [hfirst_ne] using hc2two + exact (mul_eq_zero.mp this).resolve_left h2 + have hc0 : c 0 = 0 := by + simpa [hfirst_ne, hc2] using hc0c2 + have hc3 : c 3 = 0 := by + have hsub : c 3 * (2 * (g - f)) = 0 := by + have hleft : c 1 + c 3 * (f + 3 * g) = 0 := by + simpa [hfirst_ne] using hc1c3Left + have hright : c 1 + c 3 * (3 * f + g) = 0 := by + simpa [hfirst_ne] using hc1c3Right + calc + c 3 * (2 * (g - f)) = + (c 1 + c 3 * (f + 3 * g)) - + (c 1 + c 3 * (3 * f + g)) := by ring + _ = 0 := by rw [hleft, hright]; ring + apply (mul_eq_zero.mp hsub).resolve_right + exact mul_ne_zero h2 (sub_ne_zero.mpr hfg_ne.symm) + have hc1 : c 1 = 0 := by + simpa [hfirst_ne, hc3] using hc1c3Left + fin_cases i <;> assumption + have hzRoot : (biquadraticPrimitiveQuartic f g).aeval z = 0 := by + simp only [biquadraticPrimitiveQuartic, map_sub, map_pow, aeval_X, aeval_C] + simpa only [z, map_add, map_mul, map_ofNat] using + sum_of_square_roots_quartic_relation a b + (algebraMap F L f) (algebraMap F L g) ha_sq hb_sq + have hminpoly : minpoly F z = biquadraticPrimitiveQuartic f g := + minpoly.eq_of_linearIndependent + F z (biquadraticPrimitiveQuartic_monic f g) hzRoot 4 + (biquadraticPrimitiveQuartic_degree f g) hpowers + have hzIntegral : IsIntegral F z := + ⟨biquadraticPrimitiveQuartic f g, + biquadraticPrimitiveQuartic_monic f g, hzRoot⟩ + rw [← hminpoly] + exact minpoly.irreducible hzIntegral + +end + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Cage/Connectivity.lean b/LeanPool/MarkoffModP/BGS/Markoff/Cage/Connectivity.lean new file mode 100644 index 0000000000..6ca4d8765f --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Cage/Connectivity.lean @@ -0,0 +1,253 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Cage.HasseWeilAssumption +public import LeanPool.MarkoffModP.BGS.Markoff.Endgame.LargeOrderToMaximal + +/-! +# Connectivity of the selected split cage +-/ + +@[expose] public section + +namespace BGS.Markoff + +noncomputable section + +/-- Membership in the selected split cage core. -/ +def IsInSplitCage (p : ℕ) [Fact p.Prime] + (x : NormalizedMarkoffSurface (ZMod p)) : Prop := + ∃ axis : NormalizedCoordinateAxis, + IsSplitMaximalTrace p (normalizedCoordinateAt axis x.1) + +theorem mem_normalizedFiberAt_coordinate + {R : Type*} [CommRing R] (axis : NormalizedCoordinateAxis) + (x : NormalizedMarkoffSurface R) : + x.1 ∈ normalizedFiberAt axis (normalizedCoordinateAt axis x.1) := by + cases axis <;> exact ⟨x.property, rfl⟩ + +theorem isNormalizedMarkoff_of_mem_normalizedFiberAt + {R : Type*} [CommRing R] {axis : NormalizedCoordinateAxis} {t : R} + {x : NormalizedPoint R} (hx : x ∈ normalizedFiberAt axis t) : + IsNormalizedMarkoff x := by + cases axis <;> exact hx.1 + +/-- On a split-maximal first-coordinate fiber, the normalized rotation is transitive. -/ +theorem sameNormalizedComponent_of_mem_splitMaximal_firstFiber + (p : ℕ) [Fact p.Prime] [Invertible (3 : ZMod p)] (hpSeven : 7 ≤ p) + (t : ZMod p) (hmax : IsSplitMaximalTrace p t) + (x y : ↥(normalizedFiber1 t)) : + SameNormalizedComponent + (⟨x.1, x.property.1⟩ : NormalizedMarkoffSurface (ZMod p)) + (⟨y.1, y.property.1⟩ : NormalizedMarkoffSurface (ZMod p)) := by + have ht0 : t ≠ 0 := by + intro htZero + subst t + have hle := rotationOrder_zero_le_four p + rw [IsSplitMaximalTrace] at hmax + rw [hmax] at hle + omega + have ht : t ^ 2 ≠ 4 := by + intro htParabolic + have htCases : t = 2 ∨ t = -2 := by + apply (sq_eq_sq_iff_eq_or_eq_neg).mp + calc + t ^ 2 = 4 := htParabolic + _ = (2 : ZMod p) ^ 2 := by norm_num + rw [IsSplitMaximalTrace] at hmax + rcases htCases with rfl | rfl + · rw [rotationOrder_two] at hmax + omega + · rw [rotationOrder_neg_two p (by omega)] at hmax + omega + rcases exists_split_or_quadraticNormOneTrace p (by omega) t ht with + ⟨w, htrace, hw⟩ | ⟨w, htrace, hw⟩ + · have htrace0 : splitTorusTrace w ≠ 0 := by simpa [htrace] using ht0 + let xw : ↥(normalizedFiber1 (splitTorusTrace w)) := + ⟨x.1, x.property.1, by simpa [htrace] using x.property.2⟩ + let yw : ↥(normalizedFiber1 (splitTorusTrace w)) := + ⟨y.1, y.property.1, by simpa [htrace] using y.property.2⟩ + let sx := (splitFiberEquiv w hw htrace0).symm xw + let sy := (splitFiberEquiv w hw htrace0).symm yw + have hx : splitFiberPoint w sx = (x : NormalizedPoint (ZMod p)) := + congrArg Subtype.val ((splitFiberEquiv w hw htrace0).apply_symm_apply xw) + have hy : splitFiberPoint w sy = (y : NormalizedPoint (ZMod p)) := + congrArg Subtype.val ((splitFiberEquiv w hw htrace0).apply_symm_apply yw) + have horder : orderOf w = Nat.card (ZMod p)ˣ := by + have hrotation : rotationOrder t = orderOf w := by + rw [← htrace, rotationOrder_splitTorusTrace w hw] + have hcard : Nat.card (ZMod p)ˣ = p - 1 := by + rw [Nat.card_units, Nat.card_zmod] + calc + orderOf w = rotationOrder t := hrotation.symm + _ = p - 1 := hmax + _ = Nat.card (ZMod p)ˣ := hcard.symm + have htop : Subgroup.zpowers w = ⊤ := by + apply (Subgroup.card_eq_iff_eq_top (H := Subgroup.zpowers w)).mp + rw [Nat.card_zpowers, horder] + have hmem : sx⁻¹ * sy ∈ Submonoid.powers w := by + apply mem_powers_iff_mem_zpowers.mpr + rw [htop] + exact Subgroup.mem_top _ + obtain ⟨n, hn⟩ := (Submonoid.mem_powers_iff (sx⁻¹ * sy) w).mp hmem + have hiterate : (normalizedRotate1^[n]) (x : NormalizedPoint (ZMod p)) = y := by + rw [← hx, iterate_normalizedRotate1_splitFiberPoint, hn] + simpa [mul_assoc] using hy + let xs : NormalizedMarkoffSurface (ZMod p) := ⟨x.1, x.property.1⟩ + let ys : NormalizedMarkoffSurface (ZMod p) := ⟨y.1, y.property.1⟩ + have hsurface : (normalizedRotate1Surface^[n]) xs = ys := by + apply Subtype.ext + rw [coe_iterate_normalizedRotate1Surface] + exact hiterate + change SameNormalizedComponent xs ys + rw [← hsurface] + exact sameNormalizedComponent_iterate_normalizedRotate1Surface xs n + · have hrotation : rotationOrder t = orderOf w := by + rw [← htrace, rotationOrder_quadraticNormOneTrace p w hw] + have horder : orderOf w = p - 1 := by + rw [← hmax] + exact hrotation.symm + have hdvd := orderOf_dvd_natCard w + rw [quadraticNormOneTorus_natCard, horder] at hdvd + have hdvdTwo : p - 1 ∣ 2 := by + have hsub := Nat.dvd_sub hdvd (dvd_refl (p - 1)) + have heq : (p + 1) - (p - 1) = 2 := by omega + rw [heq] at hsub + exact hsub + have hle : p - 1 ≤ 2 := Nat.le_of_dvd (by norm_num) hdvdTwo + omega + +/-- Any two normalized surface points in the same split-maximal fiber, on any coordinate axis, +lie in the same Markoff component. -/ +theorem sameNormalizedComponent_of_mem_same_splitMaximalFiber + (p : ℕ) [Fact p.Prime] [Invertible (3 : ZMod p)] (hpSeven : 7 ≤ p) + (axis : NormalizedCoordinateAxis) (t : ZMod p) (hmax : IsSplitMaximalTrace p t) + (x y : NormalizedMarkoffSurface (ZMod p)) + (hx : x.1 ∈ normalizedFiberAt axis t) + (hy : y.1 ∈ normalizedFiberAt axis t) : + SameNormalizedComponent x y := by + rcases axis with _ | _ | _ + · let xf : ↥(normalizedFiber1 t) := ⟨x.1, hx⟩ + let yf : ↥(normalizedFiber1 t) := ⟨y.1, hy⟩ + exact sameNormalizedComponent_of_mem_splitMaximal_firstFiber + p hpSeven t hmax xf yf + · let x' := normalizedSwap12Surface x + let y' := normalizedSwap12Surface y + have hxComp : SameNormalizedComponent x x' := sameNormalizedComponent_swap12Surface x + have hyComp : SameNormalizedComponent y y' := sameNormalizedComponent_swap12Surface y + let xf : ↥(normalizedFiber1 t) := ⟨x'.1, x'.property, by + simpa [x', normalizedSwap12, coe_normalizedSwap12Surface] using hx.2⟩ + let yf : ↥(normalizedFiber1 t) := ⟨y'.1, y'.property, by + simpa [y', normalizedSwap12, coe_normalizedSwap12Surface] using hy.2⟩ + have hmiddle : SameNormalizedComponent x' y' := + sameNormalizedComponent_of_mem_splitMaximal_firstFiber + p hpSeven t hmax xf yf + exact sameNormalizedComponent_trans hxComp + (sameNormalizedComponent_trans hmiddle (sameNormalizedComponent_symm hyComp)) + · let x23 := normalizedSwap23Surface x + let y23 := normalizedSwap23Surface y + let x' := normalizedSwap12Surface x23 + let y' := normalizedSwap12Surface y23 + have hx23 : SameNormalizedComponent x x23 := sameNormalizedComponent_swap23Surface x + have hy23 : SameNormalizedComponent y y23 := sameNormalizedComponent_swap23Surface y + have hx12 : SameNormalizedComponent x23 x' := sameNormalizedComponent_swap12Surface x23 + have hy12 : SameNormalizedComponent y23 y' := sameNormalizedComponent_swap12Surface y23 + let xf : ↥(normalizedFiber1 t) := ⟨x'.1, x'.property, by + simpa [x', x23, normalizedSwap12, normalizedSwap23, + coe_normalizedSwap12Surface, coe_normalizedSwap23Surface] using hx.2⟩ + let yf : ↥(normalizedFiber1 t) := ⟨y'.1, y'.property, by + simpa [y', y23, normalizedSwap12, normalizedSwap23, + coe_normalizedSwap12Surface, coe_normalizedSwap23Surface] using hy.2⟩ + have hmiddle : SameNormalizedComponent x' y' := + sameNormalizedComponent_of_mem_splitMaximal_firstFiber + p hpSeven t hmax xf yf + exact sameNormalizedComponent_trans + (sameNormalizedComponent_trans hx23 hx12) + (sameNormalizedComponent_trans hmiddle + (sameNormalizedComponent_trans + (sameNormalizedComponent_symm hy12) (sameNormalizedComponent_symm hy23))) + +/-- The selected split cage is connected for all sufficiently large primes, relative only to +the explicit cage Hasse--Weil count assumption. -/ +theorem exists_threshold_splitCage_connected + (coefficient : ℕ) (hHasse : CageWitnessPointEstimate coefficient) : + ∃ threshold : ℕ, ∀ p : ℕ, threshold ≤ p → [Fact p.Prime] → ∀ hpThree : p ≠ 3, + letI : Invertible (3 : ZMod p) := + invertibleOfNonzero (endgame_three_ne_zero_zmod_of_prime_ne_three p hpThree) + ∀ x y : NormalizedMarkoffSurface (ZMod p), + IsInSplitCage p x → IsInSplitCage p y → SameNormalizedComponent x y := by + obtain ⟨bridgeThreshold, hbridge⟩ := + exists_threshold_splitMaximalFiberBridge coefficient hHasse + refine ⟨max bridgeThreshold 7, ?_⟩ + intro p hp _ hpThree + let : Invertible (3 : ZMod p) := + invertibleOfNonzero (endgame_three_ne_zero_zmod_of_prime_ne_three p hpThree) + intro x y hxCage hyCage + rcases hxCage with ⟨axis, hxi⟩ + rcases hyCage with ⟨other, heta⟩ + let xi := normalizedCoordinateAt axis x.1 + let eta := normalizedCoordinateAt other y.1 + obtain ⟨middle, z, hmiddleAxis, hmiddleOther, hzMax, hxMeet, hyMeet⟩ := + hbridge p ((le_max_left bridgeThreshold 7).trans hp) + axis other xi eta hxi heta + rcases hxMeet with ⟨px, hpxAxis, hpxMiddle⟩ + rcases hyMeet with ⟨py, hpyOther, hpyMiddle⟩ + let pxs : NormalizedMarkoffSurface (ZMod p) := + ⟨px, isNormalizedMarkoff_of_mem_normalizedFiberAt hpxAxis⟩ + let pys : NormalizedMarkoffSurface (ZMod p) := + ⟨py, isNormalizedMarkoff_of_mem_normalizedFiberAt hpyOther⟩ + have hxFiber : x.1 ∈ normalizedFiberAt axis xi := by + exact mem_normalizedFiberAt_coordinate axis x + have hyFiber : y.1 ∈ normalizedFiberAt other eta := by + exact mem_normalizedFiberAt_coordinate other y + have hxpx : SameNormalizedComponent x pxs := + sameNormalizedComponent_of_mem_same_splitMaximalFiber + p ((le_max_right bridgeThreshold 7).trans hp) axis xi hxi x pxs + hxFiber hpxAxis + have hpxpy : SameNormalizedComponent pxs pys := + sameNormalizedComponent_of_mem_same_splitMaximalFiber + p ((le_max_right bridgeThreshold 7).trans hp) middle z hzMax pxs pys + hpxMiddle hpyMiddle + have hypy : SameNormalizedComponent y pys := + sameNormalizedComponent_of_mem_same_splitMaximalFiber + p ((le_max_right bridgeThreshold 7).trans hp) other eta heta y pys + hyFiber hpyOther + exact sameNormalizedComponent_trans hxpx + (sameNormalizedComponent_trans hpxpy (sameNormalizedComponent_symm hypy)) + +/-- The completed endgame lands in the selected split cage core. -/ +theorem exists_threshold_largeOrder_to_splitCage + (splitCoefficient : ℕ) + (hSplitWeil : WeightedSplitTraceWeilBoundAssumption splitCoefficient) + (nonsplitCoefficient : ℕ) + (hNonsplitWeil : SeededNonsplitTraceWeilBoundAssumption nonsplitCoefficient) + {δ : ℝ} (hδ : 0 < δ) : + ∃ threshold : ℕ, ∀ p : ℕ, threshold ≤ p → [Fact p.Prime] → ∀ hpThree : p ≠ 3, + letI : Invertible (3 : ZMod p) := + invertibleOfNonzero (endgame_three_ne_zero_zmod_of_prime_ne_three p hpThree) + ∀ x : NormalizedMarkoffSurface (ZMod p), + ((p : ℝ) ^ ((1 : ℝ) / 2 + δ) ≤ rotationOrder x.1.u1 ∨ + (p : ℝ) ^ ((1 : ℝ) / 2 + δ) ≤ rotationOrder x.1.u2 ∨ + (p : ℝ) ^ ((1 : ℝ) / 2 + δ) ≤ rotationOrder x.1.u3) → + ∃ y : NormalizedMarkoffSurface (ZMod p), + SameNormalizedComponent x y ∧ IsInSplitCage p y := by + obtain ⟨threshold, hendgame⟩ := + exists_threshold_sameComponent_maximalRotation_of_some_largeCoordinate + splitCoefficient hSplitWeil nonsplitCoefficient hNonsplitWeil hδ + refine ⟨threshold, ?_⟩ + intro p hp _ hpThree + let : Invertible (3 : ZMod p) := + invertibleOfNonzero (endgame_three_ne_zero_zmod_of_prime_ne_three p hpThree) + intro x hlarge + obtain ⟨y, hxy, hyOrder⟩ := hendgame p hp hpThree x hlarge + refine ⟨y, hxy, .second, ?_⟩ + exact hyOrder + +end + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Cage/EstimateFromPlane.lean b/LeanPool/MarkoffModP/BGS/Markoff/Cage/EstimateFromPlane.lean new file mode 100644 index 0000000000..666ed27376 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Cage/EstimateFromPlane.lean @@ -0,0 +1,332 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Cage.PlaneCountComparison +public import LeanPool.MarkoffModP.BGS.Markoff.Cage.AxisEquivalence +public import LeanPool.MarkoffModP.BGS.Markoff.Cage.SmallPrime + +/-! +# Transferring plane estimates to the cage witness count + +This file combines the geometric Hasse--Weil estimates, the explicit plane +comparison, the exact `d`-fold power-cover multiplicity, and the all-axis +equivalence. +-/ + +@[expose] public section + +namespace BGS.Markoff + +noncomputable section + +/-- The pulled cage radicand depends on a trace only through its square. -/ +lemma cagePulledRadicand_eq_of_sq_eq + {K : Type*} [Field K] {xi eta : K} (d : ℕ) + (h : xi ^ 2 = eta ^ 2) : + cagePulledRadicand xi d = cagePulledRadicand eta d := by + simp only [cagePulledRadicand, h] + +/-- Replacing either cage trace by another trace with the same square does +not change the pulled root-pair cover. -/ +def cagePulledRootPairEquivOfSqEq + (p : ℕ) [Fact p.Prime] (xi eta eta' : ZMod p) (d : ℕ) + (h : eta ^ 2 = eta' ^ 2) : + CagePulledRootPair p xi eta d ≃ CagePulledRootPair p xi eta' d where + toFun z := + { parameter := z.parameter + firstRoot := z.firstRoot + secondRoot := z.secondRoot + firstEquation := z.firstEquation + secondEquation := by + rw [← cagePulledRadicand_eq_of_sq_eq d h] + exact z.secondEquation } + invFun z := + { parameter := z.parameter + firstRoot := z.firstRoot + secondRoot := z.secondRoot + firstEquation := z.firstEquation + secondEquation := by + rw [cagePulledRadicand_eq_of_sq_eq d h] + exact z.secondEquation } + left_inv z := by + apply CagePulledRootPair.ext <;> rfl + right_inv z := by + apply CagePulledRootPair.ext <;> rfl + +lemma natCard_cagePulledRootPair_eq_of_sq_eq + (p : ℕ) [Fact p.Prime] (xi eta eta' : ZMod p) (d : ℕ) + (h : eta ^ 2 = eta' ^ 2) : + Nat.card (CagePulledRootPair p xi eta d) = + Nat.card (CagePulledRootPair p xi eta' d) := by + exact Nat.card_congr (cagePulledRootPairEquivOfSqEq p xi eta eta' d h) + +/-- The diagonal plane estimate gives the canonical cage range estimate with +the correct geometric multiplicity two. -/ +lemma canonicalDiagonalCageRangeEstimate + (planeCoefficient : ℕ) (hPlane : CagePlanePointEstimate planeCoefficient) + (p : ℕ) [Fact p.Prime] (hpSeven : 7 ≤ p) + (xi : ZMod p) (hxi : IsSplitMaximalTrace p xi) + (d : ℕ) (hd : d ∣ Nat.card (ZMod p)ˣ) (hdPositive : 0 < d) : + |(Nat.card (cageMiddleWitnessPowerRangeSolutions + p .first .second xi xi d) : ℝ) - + (2 : ℝ) * p / d| ≤ + ((2 * planeCoefficient + 8 : ℕ) : ℝ) * Real.sqrt p := by + have hcard : Nat.card (ZMod p)ˣ = p - 1 := by + rw [Nat.card_units, Nat.card_zmod] + have hdPred : d ∣ p - 1 := by + rw [← hcard] + exact hd + have hpTwo : p ≠ 2 := by omega + have hXi := sub_ne_zero.mpr (splitMaximalTrace_sq_ne_four p hpSeven xi hxi) + have hcomparisonInt := cagePulledRootPair_diagonal_card_comparison + p hpTwo xi hdPositive hXi + have hcomparison : + |(Nat.card (CagePulledRootPair p xi xi d) : ℝ) - + 2 * (BGS.External.affinePlaneCurveZeros (ZMod p) + (cageDiagonalPlanePolynomial xi d)).card| ≤ + (4 * d + 4 : ℕ) := by + exact_mod_cast hcomparisonInt + have hHasse := (hPlane p hpSeven xi xi hxi hxi d hdPred hdPositive).1 + have hsqrt : (1 : ℝ) ≤ Real.sqrt p := by + have hpNonnegative : (0 : ℝ) ≤ p := by positivity + have hsquare := Real.sq_sqrt hpNonnegative + have hsqrtNonnegative := Real.sqrt_nonneg (p : ℝ) + have hpSevenReal : (7 : ℝ) ≤ p := by exact_mod_cast hpSeven + nlinarith + have hdOne : (1 : ℝ) ≤ d := by exact_mod_cast hdPositive + have hexception : ((4 * d + 4 : ℕ) : ℝ) ≤ + 8 * Real.sqrt p * d := by + push_cast + nlinarith + have hcoverError : + |(Nat.card (CagePulledRootPair p xi xi d) : ℝ) - (2 : ℝ) * p| ≤ + (((2 * planeCoefficient + 8 : ℕ) : ℝ) * Real.sqrt p) * d := by + let planeCard := (BGS.External.affinePlaneCurveZeros (ZMod p) + (cageDiagonalPlanePolynomial xi d)).card + calc + |(Nat.card (CagePulledRootPair p xi xi d) : ℝ) - (2 : ℝ) * p| = + |((Nat.card (CagePulledRootPair p xi xi d) : ℝ) - + 2 * planeCard) + 2 * ((planeCard : ℝ) - p)| := by + congr 1 + ring + _ ≤ |(Nat.card (CagePulledRootPair p xi xi d) : ℝ) - + 2 * planeCard| + |2 * ((planeCard : ℝ) - p)| := abs_add_le _ _ + _ = |(Nat.card (CagePulledRootPair p xi xi d) : ℝ) - + 2 * planeCard| + 2 * |(planeCard : ℝ) - p| := by + rw [abs_mul] + norm_num + _ ≤ ((4 * d + 4 : ℕ) : ℝ) + + 2 * ((planeCoefficient : ℝ) * Real.sqrt p * d) := by + gcongr + _ ≤ 8 * Real.sqrt p * d + + 2 * ((planeCoefficient : ℝ) * Real.sqrt p * d) := by + gcongr + _ = (((2 * planeCoefficient + 8 : ℕ) : ℝ) * Real.sqrt p) * d := by + push_cast + ring + apply range_count_error_of_exact_cover hdPositive + (natCard_cagePulledRootPair_eq_mul_canonicalPowerRange + p hpTwo xi xi d hdPred) + simpa only [Nat.cast_ofNat] using hcoverError + +/-- When the two cage traces have the same square, their pulled radicands +coincide and the diagonal multiplicity-two estimate applies unchanged. -/ +lemma canonicalEqualSquareCageRangeEstimate + (planeCoefficient : ℕ) (hPlane : CagePlanePointEstimate planeCoefficient) + (p : ℕ) [Fact p.Prime] (hpSeven : 7 ≤ p) + (xi eta : ZMod p) + (hxi : IsSplitMaximalTrace p xi) + (hsquare : xi ^ 2 = eta ^ 2) + (d : ℕ) (hd : d ∣ Nat.card (ZMod p)ˣ) (hdPositive : 0 < d) : + |(Nat.card (cageMiddleWitnessPowerRangeSolutions + p .first .second xi eta d) : ℝ) - + (2 : ℝ) * p / d| ≤ + ((2 * planeCoefficient + 8 : ℕ) : ℝ) * Real.sqrt p := by + have hpTwo : p ≠ 2 := by omega + have hcard : Nat.card (ZMod p)ˣ = p - 1 := by + rw [Nat.card_units, Nat.card_zmod] + have hdPred : d ∣ p - 1 := by + rw [← hcard] + exact hd + have hpulled : + Nat.card (CagePulledRootPair p xi eta d) = + Nat.card (CagePulledRootPair p xi xi d) := + natCard_cagePulledRootPair_eq_of_sq_eq p xi eta xi d hsquare.symm + have hcoverEta := natCard_cagePulledRootPair_eq_mul_canonicalPowerRange + p hpTwo xi eta d hdPred + have hcoverXi := natCard_cagePulledRootPair_eq_mul_canonicalPowerRange + p hpTwo xi xi d hdPred + have hrange : + Nat.card (cageMiddleWitnessPowerRangeSolutions + p .first .second xi eta d) = + Nat.card (cageMiddleWitnessPowerRangeSolutions + p .first .second xi xi d) := by + rw [hpulled] at hcoverEta + rw [hcoverXi] at hcoverEta + exact Nat.eq_of_mul_eq_mul_left hdPositive hcoverEta.symm + rw [hrange] + exact canonicalDiagonalCageRangeEstimate planeCoefficient hPlane p hpSeven + xi hxi d hd hdPositive + +/-- Away from the equal-square diagonal, the primitive quartic plane model +has the same main term as the pulled root-pair cover, up to its explicitly +bounded exceptional fibers. -/ +lemma canonicalOffDiagonalCageRangeEstimate + (planeCoefficient : ℕ) (hPlane : CagePlanePointEstimate planeCoefficient) + (p : ℕ) [Fact p.Prime] (hpSeven : 7 ≤ p) + (xi eta : ZMod p) + (hxi : IsSplitMaximalTrace p xi) + (heta : IsSplitMaximalTrace p eta) + (hoffDiagonal : xi ^ 2 ≠ eta ^ 2) + (d : ℕ) (hd : d ∣ Nat.card (ZMod p)ˣ) (hdPositive : 0 < d) : + |(Nat.card (cageMiddleWitnessPowerRangeSolutions + p .first .second xi eta d) : ℝ) - + (p : ℝ) / d| ≤ + ((planeCoefficient + 10 : ℕ) : ℝ) * Real.sqrt p := by + have hcard : Nat.card (ZMod p)ˣ = p - 1 := by + rw [Nat.card_units, Nat.card_zmod] + have hdPred : d ∣ p - 1 := by + rw [← hcard] + exact hd + have hpTwo : p ≠ 2 := by omega + have hcomparisonInt := cagePulledRootPair_offDiagonal_card_comparison + p hpTwo xi eta hdPositive hoffDiagonal + have hcomparison : + |(Nat.card (CagePulledRootPair p xi eta d) : ℝ) - + (BGS.External.affinePlaneCurveZeros (ZMod p) + (cageOffDiagonalPlanePolynomial xi eta d)).card| ≤ + (6 * d + 4 : ℕ) := by + exact_mod_cast hcomparisonInt + have hHasse := + (hPlane p hpSeven xi eta hxi heta d hdPred hdPositive).2 hoffDiagonal + have hsqrt : (1 : ℝ) ≤ Real.sqrt p := by + have hpNonnegative : (0 : ℝ) ≤ p := by positivity + have hsquare := Real.sq_sqrt hpNonnegative + have hsqrtNonnegative := Real.sqrt_nonneg (p : ℝ) + have hpSevenReal : (7 : ℝ) ≤ p := by exact_mod_cast hpSeven + nlinarith + have hdOne : (1 : ℝ) ≤ d := by exact_mod_cast hdPositive + have hexception : ((6 * d + 4 : ℕ) : ℝ) ≤ + 10 * Real.sqrt p * d := by + push_cast + nlinarith + have hcoverError : + |(Nat.card (CagePulledRootPair p xi eta d) : ℝ) - (p : ℝ)| ≤ + (((planeCoefficient + 10 : ℕ) : ℝ) * Real.sqrt p) * d := by + let planeCard := (BGS.External.affinePlaneCurveZeros (ZMod p) + (cageOffDiagonalPlanePolynomial xi eta d)).card + calc + |(Nat.card (CagePulledRootPair p xi eta d) : ℝ) - (p : ℝ)| = + |((Nat.card (CagePulledRootPair p xi eta d) : ℝ) - planeCard) + + ((planeCard : ℝ) - p)| := by + congr 1 + ring + _ ≤ |(Nat.card (CagePulledRootPair p xi eta d) : ℝ) - planeCard| + + |((planeCard : ℝ) - p)| := abs_add_le _ _ + _ ≤ ((6 * d + 4 : ℕ) : ℝ) + + ((planeCoefficient : ℝ) * Real.sqrt p * d) := by + gcongr + _ ≤ 10 * Real.sqrt p * d + + ((planeCoefficient : ℝ) * Real.sqrt p * d) := by + gcongr + _ = (((planeCoefficient + 10 : ℕ) : ℝ) * Real.sqrt p) * d := by + push_cast + ring + have hrange := range_count_error_of_exact_cover + (coverCard := Nat.card (CagePulledRootPair p xi eta d)) + (rangeCard := Nat.card (cageMiddleWitnessPowerRangeSolutions + p .first .second xi eta d)) + (p := p) (d := d) (multiplicity := 1) + (error := ((planeCoefficient + 10 : ℕ) : ℝ) * Real.sqrt p) + hdPositive + (natCard_cagePulledRootPair_eq_mul_canonicalPowerRange + p hpTwo xi eta d hdPred) + (by simpa only [Nat.cast_one, one_mul] using hcoverError) + simpa only [Nat.cast_one, one_mul] using hrange + +/-- A fixed cage-plane estimate supplies the corresponding fixed witness +estimate. The proof chooses the geometric multiplicity only after splitting +the genuine equal-square and off-diagonal cases. -/ +theorem cageWitnessPointEstimate_of_cagePlanePointEstimate + (planeCoefficient : ℕ) (hPlane : CagePlanePointEstimate planeCoefficient) : + CageWitnessPointEstimate (100000 + 2 * planeCoefficient + 10) := by + let coefficient := 100000 + 2 * planeCoefficient + 10 + change CageWitnessPointEstimate coefficient + intro p _ hpFive axis other xi eta hxi heta + by_cases hpIsFive : p = 5 + · subst p + obtain ⟨multiplicity, hmultiplicity, hestimate⟩ := + cageWitnessPointEstimate_five axis other xi eta hxi heta + refine ⟨multiplicity, hmultiplicity, ?_⟩ + intro d hd hdPositive + calc + |(Nat.card (cageMiddleWitnessPowerRangeSolutions + 5 axis other xi eta d) : ℝ) - + (multiplicity : ℝ) * (5 : ℝ) / d| ≤ + (100000 : ℝ) * Real.sqrt 5 := hestimate d hd hdPositive + _ ≤ (coefficient : ℝ) * Real.sqrt 5 := by + have hsqrtNonnegative : (0 : ℝ) ≤ Real.sqrt 5 := Real.sqrt_nonneg 5 + dsimp [coefficient] + push_cast + nlinarith + · have hpNotSix : p ≠ 6 := by + intro hpSix + subst p + have hprime : Nat.Prime 6 := Fact.out + norm_num at hprime + have hpSeven : 7 ≤ p := by omega + by_cases hsquare : xi ^ 2 = eta ^ 2 + · refine ⟨2, by norm_num, ?_⟩ + intro d hd hdPositive + rw [natCard_cageMiddleWitnessPowerRangeSolutions_eq_canonical + p axis other xi eta d] + calc + |(Nat.card (cageMiddleWitnessPowerRangeSolutions + p .first .second xi eta d) : ℝ) - + (2 : ℝ) * p / d| ≤ + ((2 * planeCoefficient + 8 : ℕ) : ℝ) * Real.sqrt p := + canonicalEqualSquareCageRangeEstimate planeCoefficient hPlane + p hpSeven xi eta hxi hsquare d hd hdPositive + _ ≤ (coefficient : ℝ) * Real.sqrt p := by + have hsqrtNonnegative : (0 : ℝ) ≤ Real.sqrt p := Real.sqrt_nonneg p + dsimp [coefficient] + push_cast + nlinarith + + · refine ⟨1, by norm_num, ?_⟩ + intro d hd hdPositive + rw [natCard_cageMiddleWitnessPowerRangeSolutions_eq_canonical + p axis other xi eta d] + norm_num only [Nat.cast_one, one_mul] + calc + |(Nat.card (cageMiddleWitnessPowerRangeSolutions + p .first .second xi eta d) : ℝ) - + (p : ℝ) / d| ≤ + ((planeCoefficient + 10 : ℕ) : ℝ) * Real.sqrt p := + canonicalOffDiagonalCageRangeEstimate planeCoefficient hPlane + p hpSeven xi eta hxi heta hsquare d hd hdPositive + _ ≤ (coefficient : ℝ) * Real.sqrt p := by + have hsqrtNonnegative : (0 : ℝ) ≤ Real.sqrt p := Real.sqrt_nonneg p + have hplaneNonnegative : (0 : ℝ) ≤ planeCoefficient := by positivity + dsimp [coefficient] + push_cast + nlinarith + +/-- The single allowed general affine Hasse--Weil theorem supplies the full +cage witness estimate. -/ +theorem exists_cageWitnessPointEstimate_of_generalHasseWeil + (hHasse : BGS.External.GeneralBivariateAffineHasseWeilTheorem) : + ∃ coefficient : ℕ, 0 < coefficient ∧ CageWitnessPointEstimate coefficient := by + obtain ⟨planeCoefficient, _hplanePositive, hPlane⟩ := + exists_cagePlanePointEstimate_of_generalHasseWeil hHasse + exact ⟨100000 + 2 * planeCoefficient + 10, by omega, + cageWitnessPointEstimate_of_cagePlanePointEstimate planeCoefficient hPlane⟩ + +end + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Cage/HasseWeilAssumption.lean b/LeanPool/MarkoffModP/BGS/Markoff/Cage/HasseWeilAssumption.lean new file mode 100644 index 0000000000..e1bad58084 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Cage/HasseWeilAssumption.lean @@ -0,0 +1,275 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.NumberTheory.OneSidedPrimitiveWitness +public import LeanPool.MarkoffModP.BGS.Markoff.Incidence.NormalizedGraph + +/-! +# Explicit Hasse--Weil interface for the cage + +The external input is a point-count estimate on the actual finite set used by the cage +inclusion--exclusion. Connectivity and primitive extraction are not assumed here. +-/ + +@[expose] public section + +namespace BGS.Markoff + +open Filter +open scoped ArithmeticFunction.Moebius BigOperators + +noncomputable section + +/-- The selected cage core consists of split-maximal normalized traces. This is sufficient for +Theorem 1 because the endgame constructed in this repository always reaches order `p - 1`. -/ +def IsSplitMaximalTrace (p : ℕ) [Fact p.Prime] (t : ZMod p) : Prop := + rotationOrder t = p - 1 + +/-- Choose an axis different from both prescribed axes. -/ +def cageBridgeAxis : NormalizedCoordinateAxis → NormalizedCoordinateAxis → + NormalizedCoordinateAxis + | .first, .first => .second + | .first, .second => .third + | .first, .third => .second + | .second, .first => .third + | .second, .second => .first + | .second, .third => .first + | .third, .first => .second + | .third, .second => .first + | .third, .third => .first + +theorem cageBridgeAxis_ne_left (axis other : NormalizedCoordinateAxis) : + cageBridgeAxis axis other ≠ axis := by + cases axis <;> cases other <;> decide + +theorem cageBridgeAxis_ne_right (axis other : NormalizedCoordinateAxis) : + cageBridgeAxis axis other ≠ other := by + cases axis <;> cases other <;> decide + +/-- Coordinate selected by an axis label. -/ +def normalizedCoordinateAt (axis : NormalizedCoordinateAxis) {R : Type*} + (x : NormalizedPoint R) : R := + match axis with + | .first => x.u1 + | .second => x.u2 + | .third => x.u3 + +theorem mem_normalizedFiberAt_iff + {R : Type*} [CommRing R] {axis : NormalizedCoordinateAxis} + {t : R} {x : NormalizedPoint R} : + x ∈ normalizedFiberAt axis t ↔ + IsNormalizedMarkoff x ∧ normalizedCoordinateAt axis x = t := by + cases axis <;> rfl + +/-- The concrete incidence condition counted by the cage fiber-product curve. -/ +def CageMiddleTraceRelation + (p : ℕ) [Fact p.Prime] + (axis other : NormalizedCoordinateAxis) (xi eta : ZMod p) + (u : (ZMod p)ˣ) : Prop := + NormalizedFibersMeet + (normalizedFiberAt axis xi) + (normalizedFiberAt (cageBridgeAxis axis other) (splitTorusTrace u)) ∧ + NormalizedFibersMeet + (normalizedFiberAt other eta) + (normalizedFiberAt (cageBridgeAxis axis other) (splitTorusTrace u)) + +/-- A pair of actual intersection witnesses over a common middle trace. -/ +def CageMiddleWitnessPair + (p : ℕ) [Fact p.Prime] + (axis other : NormalizedCoordinateAxis) (xi eta : ZMod p) := + {z : NormalizedPoint (ZMod p) × NormalizedPoint (ZMod p) // + z.1 ∈ normalizedFiberAt axis xi ∧ + z.2 ∈ normalizedFiberAt other eta ∧ + normalizedCoordinateAt (cageBridgeAxis axis other) z.1 = + normalizedCoordinateAt (cageBridgeAxis axis other) z.2} + +/-- The common middle coordinate of a witness pair. -/ +def cageMiddleWitnessTrace + {p : ℕ} [Fact p.Prime] + {axis other : NormalizedCoordinateAxis} {xi eta : ZMod p} + (z : CageMiddleWitnessPair p axis other xi eta) : ZMod p := + normalizedCoordinateAt (cageBridgeAxis axis other) z.1.1 + +/-- Witness-bearing solutions with the middle unit restricted to a power-map image. -/ +abbrev cageMiddleWitnessPowerRangeSolutions + (p : ℕ) [Fact p.Prime] + (axis other : NormalizedCoordinateAxis) (xi eta : ZMod p) (d : ℕ) := + BGS.rightPowerTraceRangeSolutions + (cageMiddleWitnessTrace (p := p) (axis := axis) (other := other) + (xi := xi) (eta := eta)) + (splitTorusTrace : (ZMod p)ˣ → ZMod p) d + +/-- Witness-bearing cage point-count target with the geometric component +multiplicity exposed. The generic fiber product has multiplicity one, while +the diagonal degeneration can have a larger main term. Requiring a single +positive multiplicity for all divisor ranges is exactly what Möbius inversion +needs; fixing it silently to one would make this statement false. + +This is not an allowed external assumption: it must ultimately be derived +from the one general Hasse--Weil theorem. -/ +def CageWitnessPointEstimate (coefficient : ℕ) : Prop := + ∀ (p : ℕ) [Fact p.Prime], 5 ≤ p → + ∀ (axis other : NormalizedCoordinateAxis) (xi eta : ZMod p), + IsSplitMaximalTrace p xi → IsSplitMaximalTrace p eta → + ∃ multiplicity : ℕ, 0 < multiplicity ∧ + ∀ d : ℕ, d ∣ Nat.card (ZMod p)ˣ → 0 < d → + |(Nat.card (cageMiddleWitnessPowerRangeSolutions + p axis other xi eta d) : ℝ) - + (multiplicity : ℝ) * (p : ℝ) / d| ≤ + (coefficient : ℝ) * Real.sqrt (p : ℝ) + +/-- The Hasse--Weil range estimates imply a primitive middle unit once the explicit divisor +error is smaller than the Möbius main term. -/ +theorem exists_primitive_cageMiddleUnit_of_explicitInequality + (coefficient : ℕ) (hHasse : CageWitnessPointEstimate coefficient) + (p : ℕ) [Fact p.Prime] (hpFive : 5 ≤ p) + (axis other : NormalizedCoordinateAxis) (xi eta : ZMod p) + (hxi : IsSplitMaximalTrace p xi) (heta : IsSplitMaximalTrace p eta) + (hexplicit : + ((Nat.card (ZMod p)ˣ).divisors.card : ℝ) ^ 2 * + ((coefficient : ℝ) * Real.sqrt (p : ℝ)) < p) : + ∃ u : (ZMod p)ˣ, + CageMiddleTraceRelation p axis other xi eta u ∧ + orderOf u = Nat.card (ZMod p)ˣ := by + let leftTrace : CageMiddleWitnessPair p axis other xi eta → ZMod p := + cageMiddleWitnessTrace + let rightTrace : (ZMod p)ˣ → ZMod p := splitTorusTrace + obtain ⟨multiplicity, hmultiplicity, hEstimate⟩ := + hHasse p hpFive axis other xi eta hxi heta + have hRange : ∀ d : ℕ, d ∣ Nat.card (ZMod p)ˣ → 0 < d → + |(Nat.card (BGS.rightPowerTraceRangeSolutions + leftTrace rightTrace d) : ℝ) - + (multiplicity : ℝ) * (p : ℝ) / d| ≤ + (coefficient : ℝ) * Real.sqrt (p : ℝ) := by + intro d hdvd hd + simpa [leftTrace, rightTrace, cageMiddleWitnessPowerRangeSolutions] using + hEstimate d hdvd hd + have hpositive := + divisorsError_lt_primitiveTraceMoebiusMainTerm_of_explicitInequality + (Nat.card (ZMod p)ˣ) p 1 coefficient Nat.card_pos (by norm_num) (by + simpa using hexplicit) + let : Finite (CageMiddleWitnessPair p axis other xi eta) := + Finite.of_injective Subtype.val Subtype.val_injective + obtain ⟨z, hz⟩ := + BGS.rightTraceExactOrderSolutions_nonempty_of_divisorsError_lt_moebiusMain + leftTrace rightTrace (fun d => (multiplicity : ℝ) * (p : ℝ) / d) + ((coefficient : ℝ) * Real.sqrt (p : ℝ)) hRange (by + have hmainPositive : + 0 < primitiveTraceMoebiusMainTerm + (Nat.card (ZMod p)ˣ) p 1 := + lt_of_le_of_lt (by positivity) hpositive + have hmultiplicityReal : (1 : ℝ) ≤ multiplicity := by + exact_mod_cast hmultiplicity + have hscale : + primitiveTraceMoebiusMainTerm + (Nat.card (ZMod p)ˣ) p 1 ≤ + (multiplicity : ℝ) * + primitiveTraceMoebiusMainTerm + (Nat.card (ZMod p)ˣ) p 1 := by + nlinarith + calc + ((Nat.card (ZMod p)ˣ).divisors.card : ℝ) * + ((coefficient : ℝ) * Real.sqrt (p : ℝ)) < + primitiveTraceMoebiusMainTerm + (Nat.card (ZMod p)ˣ) p 1 := hpositive + _ ≤ (multiplicity : ℝ) * + primitiveTraceMoebiusMainTerm + (Nat.card (ZMod p)ˣ) p 1 := hscale + _ = ∑ x ∈ (Nat.card (ZMod p)ˣ).divisorsAntidiagonal, + (μ x.fst : ℝ) * + ((multiplicity : ℝ) * (p : ℝ) / x.fst) := by + simp only [primitiveTraceMoebiusMainTerm] + rw [Finset.mul_sum] + apply Finset.sum_congr rfl + intro x hx + ring) + rcases z with ⟨w, u⟩ + have hz' := (BGS.mem_rightTraceExactOrderSolutions_iff + leftTrace rightTrace (Nat.card (ZMod p)ˣ) (w, u)).mp hz + refine ⟨u, ?_, hz'.2⟩ + rcases w with ⟨⟨firstPoint, secondPoint⟩, hfirst, hsecond, hcommon⟩ + let middle := cageBridgeAxis axis other + have htrace : normalizedCoordinateAt middle firstPoint = splitTorusTrace u := by + simpa [leftTrace, rightTrace, cageMiddleWitnessTrace, middle] using hz'.1 + have hfirstSurface : IsNormalizedMarkoff firstPoint := by + cases axis <;> exact hfirst.1 + have hsecondSurface : IsNormalizedMarkoff secondPoint := by + cases other <;> exact hsecond.1 + have hfirstMiddle : firstPoint ∈ normalizedFiberAt middle (splitTorusTrace u) := by + exact mem_normalizedFiberAt_iff.mpr ⟨hfirstSurface, htrace⟩ + have hsecondTrace : normalizedCoordinateAt middle secondPoint = splitTorusTrace u := + hcommon.symm.trans htrace + have hsecondMiddle : secondPoint ∈ normalizedFiberAt middle (splitTorusTrace u) := by + exact mem_normalizedFiberAt_iff.mpr ⟨hsecondSurface, hsecondTrace⟩ + exact ⟨⟨firstPoint, hfirst, hfirstMiddle⟩, + ⟨secondPoint, hsecond, hsecondMiddle⟩⟩ + +/-- Uniform large-prime form of the primitive cage bridge. -/ +theorem exists_threshold_primitive_cageMiddleUnit + (coefficient : ℕ) (hHasse : CageWitnessPointEstimate coefficient) : + ∃ threshold : ℕ, ∀ p : ℕ, threshold ≤ p → [Fact p.Prime] → + ∀ (axis other : NormalizedCoordinateAxis) (xi eta : ZMod p), + IsSplitMaximalTrace p xi → IsSplitMaximalTrace p eta → + ∃ u : (ZMod p)ˣ, + CageMiddleTraceRelation p axis other xi eta u ∧ + orderOf u = Nat.card (ZMod p)ˣ := by + obtain ⟨threshold, hthreshold⟩ := + exists_threshold_endgamePrimitiveTrace_explicitInequality coefficient + (show (0 : ℝ) < 1 / 4 by norm_num) + refine ⟨max threshold 5, ?_⟩ + intro p hp _ axis other xi eta hxi heta + have hpThreshold : threshold ≤ p := (le_max_left threshold 5).trans hp + have hpOne : 1 ≤ p := by omega + have hpOneReal : (1 : ℝ) ≤ (p : ℝ) := by exact_mod_cast hpOne + have honeLe : ((1 : ℕ) : ℝ) ≤ (p : ℝ) ^ ((1 : ℝ) / 2 - 1 / 4) := by + simpa using (Real.one_le_rpow hpOneReal (show (0 : ℝ) ≤ 1 / 2 - 1 / 4 by norm_num)) + have hexplicit := hthreshold p hpThreshold 1 honeLe + apply exists_primitive_cageMiddleUnit_of_explicitInequality + coefficient hHasse p (by omega) axis other xi eta hxi heta + have hcard : Nat.card (ZMod p)ˣ = p - 1 := by + rw [Nat.card_units, Nat.card_zmod] + rw [hcard] + simpa only [Nat.cast_one, one_mul] using hexplicit + +/-- The primitive-incidence bridge derived from the Hasse--Weil count and Möbius inversion. -/ +theorem exists_threshold_splitMaximalFiberBridge + (coefficient : ℕ) (hHasse : CageWitnessPointEstimate coefficient) : + ∃ threshold : ℕ, ∀ p : ℕ, threshold ≤ p → [Fact p.Prime] → + ∀ (axis other : NormalizedCoordinateAxis) (xi eta : ZMod p), + IsSplitMaximalTrace p xi → IsSplitMaximalTrace p eta → + ∃ middle : NormalizedCoordinateAxis, ∃ y : ZMod p, + middle ≠ axis ∧ middle ≠ other ∧ IsSplitMaximalTrace p y ∧ + NormalizedFibersMeet + (normalizedFiberAt axis xi) (normalizedFiberAt middle y) ∧ + NormalizedFibersMeet + (normalizedFiberAt other eta) (normalizedFiberAt middle y) := by + obtain ⟨threshold, hprimitive⟩ := + exists_threshold_primitive_cageMiddleUnit coefficient hHasse + refine ⟨max threshold 5, ?_⟩ + intro p hp _ axis other xi eta hxi heta + obtain ⟨u, huRelation, huOrder⟩ := + hprimitive p ((le_max_left threshold 5).trans hp) axis other xi eta hxi heta + have hcard : Nat.card (ZMod p)ˣ = p - 1 := by + rw [Nat.card_units, Nat.card_zmod] + have huSq : (u : ZMod p) ^ 2 ≠ 1 := by + intro huPower + have huDvd : orderOf u ∣ 2 := orderOf_dvd_of_pow_eq_one <| by + apply Units.ext + exact huPower + have huLe : orderOf u ≤ 2 := Nat.le_of_dvd (by norm_num) huDvd + rw [huOrder, hcard] at huLe + have hpFive : 5 ≤ p := (le_max_right threshold 5).trans hp + omega + refine ⟨cageBridgeAxis axis other, splitTorusTrace u, + cageBridgeAxis_ne_left axis other, cageBridgeAxis_ne_right axis other, ?_, + huRelation.1, huRelation.2⟩ + rw [IsSplitMaximalTrace, rotationOrder_splitTorusTrace u huSq, huOrder, hcard] + +end + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Cage/IncidenceGeometry.lean b/LeanPool/MarkoffModP/BGS/Markoff/Cage/IncidenceGeometry.lean new file mode 100644 index 0000000000..4150e0a6d7 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Cage/IncidenceGeometry.lean @@ -0,0 +1,233 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Cage.WitnessEquations +public import LeanPool.MarkoffModP.BGS.Markoff.Incidence.CoordinateRing +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.Diagonalization + +/-! +# Geometry of the normalized cage incidence curve + +The cage uses normalized trace coordinates, whereas the incidence geometry +already proved in `IncidenceCoordinateRing` uses the paper's original Markoff +coordinates. This file supplies the missing exact scaling bridge. Dividing +the trace, common coordinate, and both retained roots by three identifies the +two pairs of quadratic equations. + +The off-diagonal geometric-integrality theorem below therefore reuses the +existing biquadratic coordinate-ring proof. It does not assert geometric +integrality of the subsequent power-trace pullback; that is the next Kummer +obligation in the cage Hasse--Weil argument. +-/ + +@[expose] public section + +namespace BGS.Markoff + +noncomputable section + +variable {K : Type*} [Field K] + +/-- The two retained incidence equations in normalized trace coordinates. -/ +def NormalizedIncidenceAux (xi eta middle firstRoot secondRoot : K) : Prop := + (xi ^ 2 - 4) * middle ^ 2 - firstRoot ^ 2 = 4 * xi ^ 2 ∧ + (eta ^ 2 - 4) * middle ^ 2 - secondRoot ^ 2 = 4 * eta ^ 2 + +/-- A witness-bearing point of the original-coordinate incidence auxiliary curve. -/ +structure IncidenceAuxEquationWitness (K : Type*) [Field K] (a b : K) where + /-- The common original-coordinate incidence parameter. -/ + middle : K + /-- The retained root for the first quadratic equation. -/ + firstRoot : K + /-- The retained root for the second quadratic equation. -/ + secondRoot : K + /-- Both original-coordinate incidence equations. -/ + equations : IncidenceAux a b middle firstRoot secondRoot + +@[ext] +theorem IncidenceAuxEquationWitness.ext + {a b : K} {x y : IncidenceAuxEquationWitness K a b} + (hmiddle : x.middle = y.middle) + (hfirst : x.firstRoot = y.firstRoot) + (hsecond : x.secondRoot = y.secondRoot) : x = y := by + cases x + cases y + simp_all + +/-- Dividing all five normalized coordinates by three gives exactly the +original-coordinate incidence equations. -/ +theorem normalizedIncidenceAux_iff_incidenceAux_div_three + (h3 : (3 : K) ≠ 0) (xi eta middle firstRoot secondRoot : K) : + NormalizedIncidenceAux xi eta middle firstRoot secondRoot ↔ + IncidenceAux (xi / 3) (eta / 3) (middle / 3) + (firstRoot / 3) (secondRoot / 3) := by + have scaledEquation (trace root : K) : + (trace ^ 2 - 4) * middle ^ 2 - root ^ 2 = 4 * trace ^ 2 ↔ + (9 * (trace / 3) ^ 2 - 4) * (middle / 3) ^ 2 - (root / 3) ^ 2 = + 4 * (trace / 3) ^ 2 := by + let originalResidual := + (trace ^ 2 - 4) * middle ^ 2 - root ^ 2 - 4 * trace ^ 2 + let scaledResidual := + (9 * (trace / 3) ^ 2 - 4) * (middle / 3) ^ 2 - (root / 3) ^ 2 - + 4 * (trace / 3) ^ 2 + have hscale : (9 : K) * scaledResidual = originalResidual := by + dsimp [scaledResidual, originalResidual] + field_simp [h3] + ring + have h9 : (9 : K) ≠ 0 := by + convert mul_ne_zero h3 h3 using 1 + norm_num + constructor + · intro h + have hOriginal : originalResidual = 0 := by + dsimp [originalResidual] + exact sub_eq_zero.mpr h + have hScaled : scaledResidual = 0 := by + apply (mul_eq_zero.mp (hscale.trans hOriginal)).resolve_left h9 + dsimp [scaledResidual] at hScaled + exact sub_eq_zero.mp hScaled + · intro h + have hScaled : scaledResidual = 0 := by + dsimp [scaledResidual] + exact sub_eq_zero.mpr h + have hOriginal : originalResidual = 0 := by + rw [← hscale, hScaled, mul_zero] + dsimp [originalResidual] at hOriginal + exact sub_eq_zero.mp hOriginal + constructor + · rintro ⟨hfirst, hsecond⟩ + exact ⟨(scaledEquation xi firstRoot).mp hfirst, + (scaledEquation eta secondRoot).mp hsecond⟩ + · rintro ⟨hfirst, hsecond⟩ + exact ⟨(scaledEquation xi firstRoot).mpr hfirst, + (scaledEquation eta secondRoot).mpr hsecond⟩ + +/-- The normalized nondegeneracy conditions imply geometric integrality of +the proved original-coordinate model. -/ +theorem normalizedIncidenceAuxGeometricallyIntegral_of_nondegenerate + (h2 : (2 : K) ≠ 0) (h3 : (3 : K) ≠ 0) {xi eta : K} + (hxi : xi ≠ 0) (heta : eta ≠ 0) + (hXi : xi ^ 2 - 4 ≠ 0) (hEta : eta ^ 2 - 4 ≠ 0) + (hneq : xi ^ 2 ≠ eta ^ 2) : + IncidenceAuxGeometricallyIntegral (xi / 3) (eta / 3) := by + apply incidenceAuxGeometricallyIntegral_of_nondegenerate h2 + · exact div_ne_zero hxi h3 + · exact div_ne_zero heta h3 + · have heq : 9 * (xi / 3) ^ 2 - 4 = xi ^ 2 - 4 := by + field_simp [h3] + ring + rw [heq] + exact hXi + · have heq : 9 * (eta / 3) ^ 2 - 4 = eta ^ 2 - 4 := by + field_simp [h3] + ring + rw [heq] + exact hEta + · intro h + apply hneq + calc + xi ^ 2 = 9 * (xi / 3) ^ 2 := by field_simp [h3]; ring + _ = 9 * (eta / 3) ^ 2 := by rw [h] + _ = eta ^ 2 := by field_simp [h3]; ring + +/-- The original-coordinate coordinate-ring model of the normalized cage +incidence curve. The accompanying point equivalence below records the +coordinate scaling, rather than identifying the two coordinate systems. -/ +abbrev NormalizedCageIncidenceCoordinateRing + (K : Type*) [Field K] (xi eta : K) := + IncidenceAuxCoordinateRing K (xi / 3) (eta / 3) + +/-- Geometric integrality of the normalized incidence curve through its +explicit original-coordinate model. -/ +def NormalizedCageIncidenceGeometricallyIntegral + {K : Type*} [Field K] (xi eta : K) : Prop := + IncidenceAuxGeometricallyIntegral (xi / 3) (eta / 3) + +/-- A split-maximal cage trace is nonzero for the primes used by the cage. -/ +theorem splitMaximalTrace_ne_zero + (p : Nat) [Fact p.Prime] (hpSeven : 7 ≤ p) (t : ZMod p) + (hmax : IsSplitMaximalTrace p t) : t ≠ 0 := by + intro ht + subst t + have hle := rotationOrder_zero_le_four p + rw [IsSplitMaximalTrace] at hmax + rw [hmax] at hle + omega + +/-- A split-maximal cage trace is not parabolic. -/ +theorem splitMaximalTrace_sq_ne_four + (p : Nat) [Fact p.Prime] (hpSeven : 7 ≤ p) (t : ZMod p) + (hmax : IsSplitMaximalTrace p t) : t ^ 2 ≠ 4 := by + intro ht + have htCases : t = 2 ∨ t = -2 := by + apply (sq_eq_sq_iff_eq_or_eq_neg).mp + calc + t ^ 2 = 4 := ht + _ = (2 : ZMod p) ^ 2 := by norm_num + rw [IsSplitMaximalTrace] at hmax + rcases htCases with rfl | rfl + · rw [rotationOrder_two] at hmax + omega + · rw [rotationOrder_neg_two p (by omega)] at hmax + omega + +/-- The off-diagonal base incidence curve occurring in the cage is +geometrically integral under the cage's actual split-maximal hypotheses. -/ +theorem normalizedCageIncidence_offDiagonal_geometricallyIntegral + (p : Nat) [Fact p.Prime] (hpSeven : 7 ≤ p) (xi eta : ZMod p) + (hxi : IsSplitMaximalTrace p xi) (heta : IsSplitMaximalTrace p eta) + (hoffDiagonal : xi ^ 2 ≠ eta ^ 2) : + NormalizedCageIncidenceGeometricallyIntegral xi eta := by + apply normalizedIncidenceAuxGeometricallyIntegral_of_nondegenerate + · exact natCast_ne_zero_zmod_of_pos_of_lt (n := 2) (p := p) (by norm_num) (by omega) + · exact natCast_ne_zero_zmod_of_pos_of_lt (n := 3) (p := p) (by norm_num) (by omega) + · exact splitMaximalTrace_ne_zero p hpSeven xi hxi + · exact splitMaximalTrace_ne_zero p hpSeven eta heta + · exact sub_ne_zero.mpr (splitMaximalTrace_sq_ne_four p hpSeven xi hxi) + · exact sub_ne_zero.mpr (splitMaximalTrace_sq_ne_four p hpSeven eta heta) + · exact hoffDiagonal + +/-- Witness-preserving equivalence between the normalized cage equations and +the original-coordinate incidence equations. -/ +def cageIncidenceEquationWitnessScaleEquiv + {p : Nat} [Fact p.Prime] (h3 : (3 : ZMod p) ≠ 0) (xi eta : ZMod p) : + CageIncidenceEquationWitness p xi eta ≃ + IncidenceAuxEquationWitness (ZMod p) (xi / 3) (eta / 3) where + toFun z := + { middle := z.middle / 3 + firstRoot := z.firstRoot / 3 + secondRoot := z.secondRoot / 3 + equations := + (normalizedIncidenceAux_iff_incidenceAux_div_three h3 xi eta + z.middle z.firstRoot z.secondRoot).mp ⟨z.firstEquation, z.secondEquation⟩ } + invFun z := + { middle := 3 * z.middle + firstRoot := 3 * z.firstRoot + secondRoot := 3 * z.secondRoot + firstEquation := by + have hscaled : + IncidenceAux (xi / 3) (eta / 3) ((3 * z.middle) / 3) + ((3 * z.firstRoot) / 3) ((3 * z.secondRoot) / 3) := by + simpa [h3] using z.equations + exact ((normalizedIncidenceAux_iff_incidenceAux_div_three h3 xi eta + (3 * z.middle) (3 * z.firstRoot) (3 * z.secondRoot)).mpr hscaled).1 + secondEquation := by + have hscaled : + IncidenceAux (xi / 3) (eta / 3) ((3 * z.middle) / 3) + ((3 * z.firstRoot) / 3) ((3 * z.secondRoot) / 3) := by + simpa [h3] using z.equations + exact ((normalizedIncidenceAux_iff_incidenceAux_div_three h3 xi eta + (3 * z.middle) (3 * z.firstRoot) (3 * z.secondRoot)).mpr hscaled).2 } + left_inv z := by + apply CageIncidenceEquationWitness.ext <;> field_simp [h3] + right_inv z := by + apply IncidenceAuxEquationWitness.ext <;> simp [h3] + +end + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Cage/PlaneCountComparison.lean b/LeanPool/MarkoffModP/BGS/Markoff/Cage/PlaneCountComparison.lean new file mode 100644 index 0000000000..d80b0fda8c --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Cage/PlaneCountComparison.lean @@ -0,0 +1,767 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Cage.PowerCover + +/-! +# Comparing the pulled cage cover with its affine plane models + +The plane models retain the power parameter `t`, whereas the pulled cover +requires `t ≠ 0`. On the diagonal the plane model also forgets the choice +between the two equal radicand roots. This file isolates those two losses +and bounds them by the roots of explicit univariate polynomials. +-/ + +@[expose] public section + +namespace BGS.Markoff + +open Polynomial + +noncomputable section + +/-- A finite-field polynomial has at most its degree many distinct roots. -/ +private lemma natCard_eval_eq_zero_le_natDegree + {K : Type*} [Field K] [Fintype K] [DecidableEq K] + (f : K[X]) (hf : f ≠ 0) : + Nat.card {x : K // f.eval x = 0} <= f.natDegree := by + classical + let rootEmbedding : {x : K // f.eval x = 0} ↪ f.roots.toFinset := + { toFun := fun x => ⟨x, by + rw [Multiset.mem_toFinset, Polynomial.mem_roots hf] + exact x.2⟩ + inj' := by + intro x y h + apply Subtype.ext + exact congrArg (fun z : f.roots.toFinset => (z : K)) h } + let : Fintype {x : K // f.eval x = 0} := Fintype.ofFinite _ + calc + Nat.card {x : K // f.eval x = 0} <= f.roots.toFinset.card := by + simpa only [Nat.card_eq_fintype_card, Fintype.card_coe] using + Fintype.card_le_of_injective rootEmbedding rootEmbedding.injective + _ <= f.roots.card := Multiset.toFinset_card_le _ + _ <= f.natDegree := Polynomial.card_roots' f + +/-- The pulled radicand has degree at most `4d`. -/ +lemma cagePulledRadicand_natDegree_le (K : Type*) [Field K] + (xi : K) (d : Nat) : + (cagePulledRadicand xi d).natDegree <= 4 * d := by + rw [cagePulledRadicand_expanded] + refine (natDegree_add_le _ _).trans (max_le ?_ ?_) + · refine (natDegree_sub_le _ _).trans (max_le ?_ ?_) + · exact natDegree_C_mul_X_pow_le _ _ + · exact (natDegree_C_mul_X_pow_le _ _).trans (by omega) + · exact (natDegree_C _).le.trans (Nat.zero_le _) + +/-- Rational points of the diagonal plane model. -/ +abbrev CageDiagonalPlanePoint (p : Nat) [Fact p.Prime] + (xi : ZMod p) (d : Nat) := + ↥(BGS.External.affinePlaneCurveZeros (ZMod p) + (cageDiagonalPlanePolynomial xi d)) + +/-- A plane point together with the sign used to recover the second root. -/ +abbrev CageDiagonalTaggedPlanePoint (p : Nat) [Fact p.Prime] + (xi : ZMod p) (d : Nat) := CageDiagonalPlanePoint p xi d × Bool + +/-- The tagged points which recover a unique pulled pair. At a zero root, +the two signs coincide, so only `false` is retained. -/ +def IsGoodDiagonalTaggedPoint {p : Nat} [Fact p.Prime] + {xi : ZMod p} {d : Nat} + (z : CageDiagonalTaggedPlanePoint p xi d) : Prop := + z.1.1.2 ≠ 0 ∧ (z.1.1.1 ≠ 0 ∨ z.2 = false) + +/-- Away from the explicit exceptional set, a signed diagonal plane point +is exactly a pulled pair of roots. -/ +def goodDiagonalTaggedPointEquivPulled + (p : Nat) [Fact p.Prime] (hpTwo : p ≠ 2) + (xi : ZMod p) (d : Nat) : + {z : CageDiagonalTaggedPlanePoint p xi d // + IsGoodDiagonalTaggedPoint z} ≃ CagePulledRootPair p xi xi d where + toFun z := by + let parameter : (ZMod p)ˣ := Units.mk0 z.1.1.1.2 z.2.1 + let root := z.1.1.1.1 + refine + { parameter := parameter + firstRoot := root + secondRoot := if z.1.2 then -root else root + firstEquation := ?_ + secondEquation := ?_ } + · exact (eval_cageDiagonalPlanePolynomial_eq_zero_iff xi d root + z.1.1.1.2).mp + (BGS.External.mem_affinePlaneCurveZeros_iff.mp z.1.1.2) + · have hfirst : root ^ 2 = + (cagePulledRadicand xi d).eval z.1.1.1.2 := + (eval_cageDiagonalPlanePolynomial_eq_zero_iff xi d root + z.1.1.1.2).mp + (BGS.External.mem_affinePlaneCurveZeros_iff.mp z.1.1.2) + split <;> simpa [parameter, root] using hfirst + invFun z := by + have hsquares : z.secondRoot = z.firstRoot ∨ + z.secondRoot = -z.firstRoot := by + rw [← sq_eq_sq_iff_eq_or_eq_neg] + exact z.secondEquation.trans z.firstEquation.symm + let tag : Bool := if z.secondRoot = z.firstRoot then false else true + have htag : z.secondRoot = if tag then -z.firstRoot else z.firstRoot := by + dsimp [tag] + split + · simp_all + · simp_all + refine ⟨(⟨(z.firstRoot, (z.parameter : ZMod p)), ?_⟩, tag), ?_⟩ + · apply BGS.External.mem_affinePlaneCurveZeros_iff.mpr + exact (eval_cageDiagonalPlanePolynomial_eq_zero_iff xi d + z.firstRoot (z.parameter : ZMod p)).mpr z.firstEquation + · refine ⟨z.parameter.ne_zero, ?_⟩ + by_cases hroot : z.firstRoot = 0 + · right + have hsecond : z.secondRoot = 0 := by + rcases hsquares with h | h <;> simp_all + simp [tag, hroot, hsecond] + · exact Or.inl hroot + left_inv z := by + apply Subtype.ext + apply Prod.ext + · apply Subtype.ext + apply Prod.ext <;> rfl + · cases htag : z.1.2 + · simp [htag] + · have hroot : z.1.1.1.1 ≠ 0 := by + rcases z.2.2 with hroot | hfalse + · exact hroot + · simp [htag] at hfalse + have hneg : -z.1.1.1.1 ≠ z.1.1.1.1 := by + intro h + have htwo : (2 : ZMod p) ≠ 0 := two_ne_zero_zmod + (lt_of_le_of_ne (Fact.out : p.Prime).two_le (Ne.symm hpTwo)) + have hzero : z.1.1.1.1 + z.1.1.1.1 = 0 := + neg_eq_iff_add_eq_zero.mp h + have hzero' : (2 : ZMod p) * z.1.1.1.1 = 0 := by + simpa [two_mul] using hzero + exact hroot ((mul_eq_zero.mp hzero').resolve_left htwo) + simp [htag, hneg] + right_inv z := by + apply CagePulledRootPair.ext + · apply Units.ext + rfl + · rfl + · dsimp + split + · symm + assumption + · rename_i hne + rcases (sq_eq_sq_iff_eq_or_eq_neg.mp + (z.secondEquation.trans z.firstEquation.symm)) with h | h + · exact (hne h).elim + · exact h.symm + +/-- The bad signed diagonal points inject into either the two signs above +`t = 0`, or a root of the pulled radicand with the duplicated sign. -/ +def badDiagonalTaggedPointEmbedding + (p : Nat) [Fact p.Prime] (xi : ZMod p) {d : Nat} (hd : 0 < d) : + {z : CageDiagonalTaggedPlanePoint p xi d // + ¬ IsGoodDiagonalTaggedPoint z} ↪ + ({root : ZMod p // root ^ 2 = xi ^ 2 - 4} × Bool) ⊕ + {parameter : ZMod p // (cagePulledRadicand xi d).eval parameter = 0} := + { toFun := fun z => by + by_cases hparameter : z.1.1.1.2 = 0 + · exact Sum.inl ⟨⟨z.1.1.1.1, by + have heq := (eval_cageDiagonalPlanePolynomial_eq_zero_iff xi d + z.1.1.1.1 z.1.1.1.2).mp + (BGS.External.mem_affinePlaneCurveZeros_iff.mp z.1.1.2) + simpa [hparameter, cagePulledRadicand_eval_zero xi hd] using heq⟩, + z.1.2⟩ + · exact Sum.inr ⟨z.1.1.1.2, by + have hbad := z.2 + have hroot : z.1.1.1.1 = 0 := by + by_contra hroot + exact hbad ⟨hparameter, Or.inl hroot⟩ + have heq := (eval_cageDiagonalPlanePolynomial_eq_zero_iff xi d + z.1.1.1.1 z.1.1.1.2).mp + (BGS.External.mem_affinePlaneCurveZeros_iff.mp z.1.1.2) + simpa [hroot] using heq.symm⟩ + inj' := by + intro x y hxy + by_cases hx : x.1.1.1.2 = 0 + · by_cases hy : y.1.1.1.2 = 0 + · simp only [hx, hy, ite_eq_left] at hxy + have hpayload := Sum.inl.inj hxy + apply Subtype.ext + apply Prod.ext + · apply Subtype.ext + apply Prod.ext + · exact congrArg (fun q => q.1.1) hpayload + · exact hx.trans hy.symm + · exact congrArg + (fun q : ({root : ZMod p // root ^ 2 = xi ^ 2 - 4} × Bool) => q.2) + hpayload + · simp [hx, hy] at hxy + · by_cases hy : y.1.1.1.2 = 0 + · simp [hx, hy] at hxy + · simp only [hx, hy, ite_eq_right] at hxy + have hpayload := Sum.inr.inj hxy + have hparameter : x.1.1.1.2 = y.1.1.1.2 := + congrArg Subtype.val hpayload + have hxroot : x.1.1.1.1 = 0 := by + by_contra hroot + exact x.2 ⟨hx, Or.inl hroot⟩ + have hyroot : y.1.1.1.1 = 0 := by + by_contra hroot + exact y.2 ⟨hy, Or.inl hroot⟩ + have hxtag : x.1.2 = true := by + cases htag : x.1.2 + · exact (x.2 ⟨hx, Or.inr htag⟩).elim + · rfl + have hytag : y.1.2 = true := by + cases htag : y.1.2 + · exact (y.2 ⟨hy, Or.inr htag⟩).elim + · rfl + apply Subtype.ext + apply Prod.ext + · apply Subtype.ext + exact Prod.ext (hxroot.trans hyroot.symm) hparameter + · exact hxtag.trans hytag.symm } + +/-- In a field of odd characteristic, a scalar has at most two square roots. -/ +private lemma natCard_sq_eq_le_two + {K : Type*} [Field K] [Fintype K] [DecidableEq K] (a : K) : + Nat.card {x : K // x ^ 2 = a} <= 2 := by + let f : K[X] := X ^ 2 - C a + have hf : f ≠ 0 := by + intro hzero + have hcoeff := congrArg (fun q : K[X] => q.coeff 2) hzero + simp [f] at hcoeff + let e : {x : K // x ^ 2 = a} ≃ {x : K // f.eval x = 0} := + Equiv.subtypeEquiv (Equiv.refl K) (by + intro x + simp [f, sub_eq_zero]) + calc + Nat.card {x : K // x ^ 2 = a} = Nat.card {x : K // f.eval x = 0} := + Nat.card_congr e + _ <= f.natDegree := natCard_eval_eq_zero_le_natDegree f hf + _ = 2 := by simp [f] + +/-- The diagonal exceptional set has size at most `4d + 4`: four signed +points can lie above `t = 0`, and every remaining exception is a zero of the +degree-`4d` pulled radicand. -/ +lemma natCard_badDiagonalTaggedPoint_le + (p : Nat) [Fact p.Prime] (xi : ZMod p) {d : Nat} (hd : 0 < d) + (hXi : xi ^ 2 - 4 ≠ 0) : + Nat.card {z : CageDiagonalTaggedPlanePoint p xi d // + ¬ IsGoodDiagonalTaggedPoint z} <= 4 * d + 4 := by + have hradicand : cagePulledRadicand xi d ≠ 0 := by + intro hzero + have hcoeff := congrArg + (fun q : (ZMod p)[X] => q.coeff (4 * d)) hzero + rw [cagePulledRadicand_coeff_four_mul xi hd, coeff_zero] at hcoeff + exact hXi hcoeff + have hrootBound : + Nat.card {root : ZMod p // root ^ 2 = xi ^ 2 - 4} <= 2 := + natCard_sq_eq_le_two _ + have hradicandBound : + Nat.card {parameter : ZMod p // + (cagePulledRadicand xi d).eval parameter = 0} <= 4 * d := + (natCard_eval_eq_zero_le_natDegree _ hradicand).trans + (cagePulledRadicand_natDegree_le (ZMod p) xi d) + have hinjective := Nat.card_le_card_of_injective + (badDiagonalTaggedPointEmbedding p xi hd).toFun + (badDiagonalTaggedPointEmbedding p xi hd).injective + rw [Nat.card_sum, Nat.card_prod] at hinjective + have hbool : Nat.card Bool = 2 := by simp + rw [hbool] at hinjective + omega + +/-- Exact bookkeeping identity behind the diagonal comparison. -/ +lemma two_mul_diagonalPlanePoint_card_eq_pulled_add_bad + (p : Nat) [Fact p.Prime] (hpTwo : p ≠ 2) + (xi : ZMod p) (d : Nat) : + 2 * (BGS.External.affinePlaneCurveZeros (ZMod p) + (cageDiagonalPlanePolynomial xi d)).card = + Nat.card (CagePulledRootPair p xi xi d) + + Nat.card {z : CageDiagonalTaggedPlanePoint p xi d // + ¬ IsGoodDiagonalTaggedPoint z} := by + classical + have hgood : + Nat.card {z : CageDiagonalTaggedPlanePoint p xi d // + IsGoodDiagonalTaggedPoint z} = + Nat.card (CagePulledRootPair p xi xi d) := + Nat.card_congr (goodDiagonalTaggedPointEquivPulled p hpTwo xi d) + have hplane : Nat.card (CageDiagonalPlanePoint p xi d) = + (BGS.External.affinePlaneCurveZeros (ZMod p) + (cageDiagonalPlanePolynomial xi d)).card := by + simpa only [Nat.card_eq_fintype_card] using + Fintype.card_coe + (BGS.External.affinePlaneCurveZeros (ZMod p) + (cageDiagonalPlanePolynomial xi d)) + have hbool : Nat.card Bool = 2 := by simp + calc + 2 * (BGS.External.affinePlaneCurveZeros (ZMod p) + (cageDiagonalPlanePolynomial xi d)).card = + Nat.card (CageDiagonalTaggedPlanePoint p xi d) := by + rw [Nat.card_prod, hplane, hbool] + omega + _ = Nat.card + ({z : CageDiagonalTaggedPlanePoint p xi d // + IsGoodDiagonalTaggedPoint z} ⊕ + {z : CageDiagonalTaggedPlanePoint p xi d // + ¬ IsGoodDiagonalTaggedPoint z}) := + (Nat.card_congr + (Equiv.sumCompl (fun z : CageDiagonalTaggedPlanePoint p xi d => + IsGoodDiagonalTaggedPoint z))).symm + _ = Nat.card {z : CageDiagonalTaggedPlanePoint p xi d // + IsGoodDiagonalTaggedPoint z} + + Nat.card {z : CageDiagonalTaggedPlanePoint p xi d // + ¬ IsGoodDiagonalTaggedPoint z} := Nat.card_sum + _ = Nat.card (CagePulledRootPair p xi xi d) + + Nat.card {z : CageDiagonalTaggedPlanePoint p xi d // + ¬ IsGoodDiagonalTaggedPoint z} := by rw [hgood] + +/-- The pulled diagonal cover differs from twice its plane-model count by +at most the explicit exceptional contribution `4d + 4`. -/ +theorem cagePulledRootPair_diagonal_card_comparison + (p : Nat) [Fact p.Prime] (hpTwo : p ≠ 2) + (xi : ZMod p) {d : Nat} (hd : 0 < d) + (hXi : xi ^ 2 - 4 ≠ 0) : + |(Nat.card (CagePulledRootPair p xi xi d) : Int) - + 2 * (BGS.External.affinePlaneCurveZeros (ZMod p) + (cageDiagonalPlanePolynomial xi d)).card| <= 4 * d + 4 := by + have hexact := two_mul_diagonalPlanePoint_card_eq_pulled_add_bad + p hpTwo xi d + have hbad := natCard_badDiagonalTaggedPoint_le p xi hd hXi + let bad := {z : CageDiagonalTaggedPlanePoint p xi d // + ¬ IsGoodDiagonalTaggedPoint z} + have hid : + (Nat.card (CagePulledRootPair p xi xi d) : Int) - + 2 * (BGS.External.affinePlaneCurveZeros (ZMod p) + (cageDiagonalPlanePolynomial xi d)).card = + -(Nat.card bad : Int) := by + change 2 * (BGS.External.affinePlaneCurveZeros (ZMod p) + (cageDiagonalPlanePolynomial xi d)).card = + Nat.card (CagePulledRootPair p xi xi d) + Nat.card bad at hexact + exact_mod_cast (by omega : + (Nat.card (CagePulledRootPair p xi xi d) : Int) - + 2 * (BGS.External.affinePlaneCurveZeros (ZMod p) + (cageDiagonalPlanePolynomial xi d)).card = + -(Nat.card bad : Int)) + rw [hid, abs_neg, abs_of_nonneg (Int.natCast_nonneg _)] + exact_mod_cast hbad + +abbrev CageOffDiagonalPlanePoint (p : Nat) [Fact p.Prime] + (xi eta : ZMod p) (d : Nat) := + ↥(BGS.External.affinePlaneCurveZeros (ZMod p) + (cageOffDiagonalPlanePolynomial xi eta d)) + +def IsGoodOffDiagonalPlanePoint {p : Nat} [Fact p.Prime] + {xi eta : ZMod p} {d : Nat} (z : CageOffDiagonalPlanePoint p xi eta d) : Prop := + z.1.1 ≠ 0 ∧ z.1.2 ≠ 0 + +def IsGoodOffDiagonalPulledPair {p : Nat} [Fact p.Prime] + {xi eta : ZMod p} {d : Nat} (z : CagePulledRootPair p xi eta d) : Prop := + z.firstRoot + z.secondRoot ≠ 0 + +def goodOffDiagonalPulledToPlane + (p : Nat) [Fact p.Prime] (hpTwo : p ≠ 2) + (xi eta : ZMod p) (d : Nat) : + {z : CagePulledRootPair p xi eta d // IsGoodOffDiagonalPulledPair z} → + {z : CageOffDiagonalPlanePoint p xi eta d // + IsGoodOffDiagonalPlanePoint z} := fun z => by + let sumRoot := z.1.firstRoot + z.1.secondRoot + refine ⟨⟨(sumRoot, (z.1.parameter : ZMod p)), ?_⟩, + z.2, z.1.parameter.ne_zero⟩ + apply BGS.External.mem_affinePlaneCurveZeros_iff.mpr + apply (eval_cageOffDiagonalPlanePolynomial_eq_zero_iff_exists_rootPair + (two_ne_zero_zmod + (lt_of_le_of_ne (Fact.out : p.Prime).two_le (Ne.symm hpTwo))) + xi eta d z.2).mpr + exact ⟨z.1.firstRoot, z.1.secondRoot, z.1.firstEquation, + z.1.secondEquation, rfl⟩ + +lemma goodOffDiagonalPulledToPlane_bijective + (p : Nat) [Fact p.Prime] (hpTwo : p ≠ 2) + (xi eta : ZMod p) (d : Nat) : + Function.Bijective (goodOffDiagonalPulledToPlane p hpTwo xi eta d) := by + have h2 : (2 : ZMod p) ≠ 0 := two_ne_zero_zmod + (lt_of_le_of_ne (Fact.out : p.Prime).two_le (Ne.symm hpTwo)) + constructor + · intro x y hxy + have hsum : x.1.firstRoot + x.1.secondRoot = + y.1.firstRoot + y.1.secondRoot := by + exact congrArg (fun z => z.1.1.1) hxy + have hparameter : x.1.parameter = y.1.parameter := by + apply Units.ext + exact congrArg (fun z => z.1.1.2) hxy + have hfirstSq : x.1.firstRoot ^ 2 = y.1.firstRoot ^ 2 := by + rw [x.1.firstEquation, y.1.firstEquation, hparameter] + have hsecondSq : x.1.secondRoot ^ 2 = y.1.secondRoot ^ 2 := by + rw [x.1.secondEquation, y.1.secondEquation, hparameter] + rcases sq_eq_sq_iff_eq_or_eq_neg.mp hfirstSq with hfirst | hfirst + · apply Subtype.ext + apply CagePulledRootPair.ext hparameter hfirst + linear_combination hsum - hfirst + · rcases sq_eq_sq_iff_eq_or_eq_neg.mp hsecondSq with hsecond | hsecond + · have hfirstZero : x.1.firstRoot = 0 := by + have : (2 : ZMod p) * x.1.firstRoot = 0 := by + rw [two_mul] + linear_combination hsum - hsecond + hfirst + exact (mul_eq_zero.mp this).resolve_left h2 + apply Subtype.ext + apply CagePulledRootPair.ext hparameter + · have hyfirstZero : y.1.firstRoot = 0 := by + linear_combination hfirst - hfirstZero + simp [hfirstZero, hyfirstZero] + · exact hsecond + · have hsumZero : x.1.firstRoot + x.1.secondRoot = 0 := by + have : (2 : ZMod p) * (x.1.firstRoot + x.1.secondRoot) = 0 := by + rw [two_mul] + linear_combination hsum + hfirst + hsecond + exact (mul_eq_zero.mp this).resolve_left h2 + exact (x.2 hsumZero).elim + · intro z + have hexists := + (eval_cageOffDiagonalPlanePolynomial_eq_zero_iff_exists_rootPair + h2 xi eta d z.2.1).mp + (BGS.External.mem_affinePlaneCurveZeros_iff.mp z.1.2) + rcases hexists with ⟨firstRoot, secondRoot, hfirst, hsecond, hsum⟩ + let parameter : (ZMod p)ˣ := Units.mk0 z.1.1.2 z.2.2 + let pulled : CagePulledRootPair p xi eta d := + { parameter := parameter + firstRoot := firstRoot + secondRoot := secondRoot + firstEquation := by simpa [parameter] using hfirst + secondEquation := by simpa [parameter] using hsecond } + have hpulledGood : IsGoodOffDiagonalPulledPair pulled := by + change firstRoot + secondRoot ≠ 0 + rw [hsum] + exact z.2.1 + refine ⟨⟨pulled, hpulledGood⟩, ?_⟩ + apply Subtype.ext + apply Subtype.ext + apply Prod.ext + · exact hsum + · rfl + +def goodOffDiagonalPulledEquivPlane + (p : Nat) [Fact p.Prime] (hpTwo : p ≠ 2) + (xi eta : ZMod p) (d : Nat) : + {z : CagePulledRootPair p xi eta d // IsGoodOffDiagonalPulledPair z} ≃ + {z : CageOffDiagonalPlanePoint p xi eta d // + IsGoodOffDiagonalPlanePoint z} := + Equiv.ofBijective _ (goodOffDiagonalPulledToPlane_bijective p hpTwo xi eta d) + +private lemma rootCount_le_natDegree + {K : Type*} [Field K] [Fintype K] [DecidableEq K] + (f : K[X]) (hf : f ≠ 0) : + Nat.card {x : K // f.eval x = 0} ≤ f.natDegree := by + classical + let embedding : {x : K // f.eval x = 0} ↪ f.roots.toFinset := + { toFun := fun x => ⟨x, by + rw [Multiset.mem_toFinset, Polynomial.mem_roots hf] + exact x.2⟩ + inj' := by + intro x y h + apply Subtype.ext + exact congrArg (fun z : f.roots.toFinset => (z : K)) h } + let : Fintype {x : K // f.eval x = 0} := Fintype.ofFinite _ + calc + Nat.card {x : K // f.eval x = 0} ≤ f.roots.toFinset.card := by + simpa only [Nat.card_eq_fintype_card, Fintype.card_coe] using + Fintype.card_le_of_injective embedding embedding.injective + _ ≤ f.roots.card := Multiset.toFinset_card_le _ + _ ≤ f.natDegree := Polynomial.card_roots' f + +private lemma sqRootCount_le_two + {K : Type*} [Field K] [Fintype K] [DecidableEq K] (a : K) : + Nat.card {x : K // x ^ 2 = a} ≤ 2 := by + let f : K[X] := X ^ 2 - C a + have hf : f ≠ 0 := by + intro h + have := congrArg (fun q : K[X] => q.coeff 2) h + simp [f] at this + let e : {x : K // x ^ 2 = a} ≃ {x : K // f.eval x = 0} := + Equiv.subtypeEquiv (Equiv.refl K) (by intro x; simp [f, sub_eq_zero]) + rw [Nat.card_congr e] + exact (rootCount_le_natDegree f hf).trans_eq (by simp [f]) + +private lemma powerRootCount_le + {K : Type*} [Field K] [Fintype K] [DecidableEq K] + {n : Nat} (hn : 0 < n) : Nat.card {x : K // x ^ n = 1} ≤ n := by + let f : K[X] := X ^ n - 1 + have hf : f ≠ 0 := by + simpa [f] using (monic_X_pow_sub_C (1 : K) hn.ne').ne_zero + let e : {x : K // x ^ n = 1} ≃ {x : K // f.eval x = 0} := + Equiv.subtypeEquiv (Equiv.refl K) (by intro x; simp [f, sub_eq_zero]) + rw [Nat.card_congr e] + exact (rootCount_le_natDegree f hf).trans_eq (by + simpa [f] using (natDegree_X_pow_sub_C (R := K) (n := n) (r := 1))) + +def badOffDiagonalPulledEmbedding + (p : Nat) [Fact p.Prime] (hpTwo : p ≠ 2) + (xi eta : ZMod p) {d : Nat} (hd : 0 < d) + (hoffDiagonal : xi ^ 2 ≠ eta ^ 2) : + {z : CagePulledRootPair p xi eta d // + ¬ IsGoodOffDiagonalPulledPair z} ↪ + (Σ parameter : {t : ZMod p // t ^ (2 * d) = 1}, + {root : ZMod p // root ^ 2 = + (cagePulledRadicand xi d).eval parameter.1}) := + { toFun := fun z => by + have hsum : z.1.firstRoot + z.1.secondRoot = 0 := + not_ne_iff.mp z.2 + have hsecond : z.1.secondRoot = -z.1.firstRoot := by + linear_combination hsum + have hevals : (cagePulledRadicand xi d).eval + (z.1.parameter : ZMod p) = + (cagePulledRadicand eta d).eval + (z.1.parameter : ZMod p) := by + rw [← z.1.firstEquation, ← z.1.secondEquation, hsecond] + ring + have hdifference := congrArg + (fun q : (ZMod p)[X] => q.eval (z.1.parameter : ZMod p)) + (cagePulledRadicand_sub xi eta d) + have hproduct : (xi ^ 2 - eta ^ 2) * + ((z.1.parameter : ZMod p) ^ (2 * d) - 1) ^ 2 = 0 := by + simpa [hevals] using hdifference + have hscalar : xi ^ 2 - eta ^ 2 ≠ 0 := sub_ne_zero.mpr hoffDiagonal + have hpower : (z.1.parameter : ZMod p) ^ (2 * d) = 1 := by + have hsquare := (mul_eq_zero.mp hproduct).resolve_left hscalar + have hbase : (z.1.parameter : ZMod p) ^ (2 * d) - 1 = 0 := by + apply mul_self_eq_zero.mp + simpa [pow_two] using hsquare + exact sub_eq_zero.mp hbase + exact ⟨⟨(z.1.parameter : ZMod p), hpower⟩, + ⟨z.1.firstRoot, z.1.firstEquation⟩⟩ + inj' := by + intro x y hxy + have hparameter : x.1.parameter = y.1.parameter := by + apply Units.ext + exact congrArg (fun z => (z.1.1 : ZMod p)) hxy + have hfirst : x.1.firstRoot = y.1.firstRoot := + congrArg (fun z => z.2.1) hxy + have hxsum : x.1.firstRoot + x.1.secondRoot = 0 := not_ne_iff.mp x.2 + have hysum : y.1.firstRoot + y.1.secondRoot = 0 := not_ne_iff.mp y.2 + apply Subtype.ext + apply CagePulledRootPair.ext hparameter hfirst + linear_combination hxsum - hysum - hfirst } + +lemma badOffDiagonalPulled_card_le + (p : Nat) [Fact p.Prime] (hpTwo : p ≠ 2) + (xi eta : ZMod p) {d : Nat} (hd : 0 < d) + (hoffDiagonal : xi ^ 2 ≠ eta ^ 2) : + Nat.card {z : CagePulledRootPair p xi eta d // + ¬ IsGoodOffDiagonalPulledPair z} ≤ 4 * d := by + let base := {t : ZMod p // t ^ (2 * d) = 1} + let fiber : base → Type := fun t => + {root : ZMod p // root ^ 2 = (cagePulledRadicand xi d).eval t.1} + have hinj := Nat.card_le_card_of_injective + (badOffDiagonalPulledEmbedding p hpTwo xi eta hd hoffDiagonal).toFun + (badOffDiagonalPulledEmbedding p hpTwo xi eta hd hoffDiagonal).injective + change Nat.card _ ≤ Nat.card (Σ t : base, fiber t) at hinj + rw [Nat.card_sigma] at hinj + have hfiber : ∀ t : base, Nat.card (fiber t) ≤ 2 := + fun t => sqRootCount_le_two _ + have hsum : ∑ t : base, Nat.card (fiber t) ≤ ∑ _t : base, 2 := by + exact Finset.sum_le_sum fun t _ => hfiber t + have hbase : Nat.card base ≤ 2 * d := powerRootCount_le (by omega) + have hsum' : ∑ t : base, Nat.card (fiber t) ≤ Nat.card base * 2 := by + simpa using hsum + omega + +def cageOffDiagonalZeroParameterPolynomial + {K : Type*} [Field K] (xi eta : K) (d : Nat) : K[X] := + (X ^ 2 - C ((cagePulledRadicand xi d).eval 0 + + (cagePulledRadicand eta d).eval 0)) ^ 2 - + C (4 * (cagePulledRadicand xi d).eval 0 * + (cagePulledRadicand eta d).eval 0) + +lemma eval_cageOffDiagonalZeroParameterPolynomial + {K : Type*} [Field K] (xi eta sumRoot : K) (d : Nat) : + (cageOffDiagonalZeroParameterPolynomial xi eta d).eval sumRoot = + MvPolynomial.eval ![sumRoot, 0] + (cageOffDiagonalPlanePolynomial xi eta d) := by + rw [eval_cageOffDiagonalPlanePolynomial] + simp [cageOffDiagonalZeroParameterPolynomial] + +lemma cageOffDiagonalZeroParameterPolynomial_natDegree_le + {K : Type*} [Field K] (xi eta : K) (d : Nat) : + (cageOffDiagonalZeroParameterPolynomial xi eta d).natDegree ≤ 4 := by + unfold cageOffDiagonalZeroParameterPolynomial + refine (natDegree_sub_le _ _).trans (max_le ?_ ?_) + · exact (natDegree_pow_le).trans (by + have hinside : (X ^ 2 - C ((cagePulledRadicand xi d).eval 0 + + (cagePulledRadicand eta d).eval 0) : K[X]).natDegree ≤ 2 := + (natDegree_sub_le _ _).trans (max_le + (natDegree_X_pow_le 2) ((natDegree_C _).le.trans (by omega))) + omega) + · exact (natDegree_C _).le.trans (by omega) + +lemma cageOffDiagonalZeroParameterPolynomial_ne_zero + {K : Type*} [Field K] (xi eta : K) (d : Nat) : + cageOffDiagonalZeroParameterPolynomial xi eta d ≠ 0 := by + have hquadratic : IsMonicOfDegree + (X ^ 2 - C ((cagePulledRadicand xi d).eval 0 + + (cagePulledRadicand eta d).eval 0) : K[X]) 2 := + (isMonicOfDegree_X_pow K 2).sub (by simp) + have hmonic : (cageOffDiagonalZeroParameterPolynomial xi eta d).Monic := by + unfold cageOffDiagonalZeroParameterPolynomial + exact ((hquadratic.pow 2).sub (by + have hpos : 0 < 2 * 2 := by norm_num + simpa only [natDegree_C] using hpos)).monic + exact hmonic.ne_zero + +def badOffDiagonalPlaneEmbedding + (p : Nat) [Fact p.Prime] (xi eta : ZMod p) {d : Nat} + (hoffDiagonal : xi ^ 2 ≠ eta ^ 2) : + {z : CageOffDiagonalPlanePoint p xi eta d // + ¬ IsGoodOffDiagonalPlanePoint z} ↪ + {sumRoot : ZMod p // + (cageOffDiagonalZeroParameterPolynomial xi eta d).eval sumRoot = 0} ⊕ + {parameter : ZMod p // parameter ^ (2 * d) = 1} := + { toFun := fun z => by + by_cases hparameter : z.1.1.2 = 0 + · exact Sum.inl ⟨z.1.1.1, by + rw [eval_cageOffDiagonalZeroParameterPolynomial] + simpa [hparameter] using + (BGS.External.mem_affinePlaneCurveZeros_iff.mp z.1.2)⟩ + · have hsumRoot : z.1.1.1 = 0 := by + by_contra hsum + exact z.2 ⟨hsum, hparameter⟩ + have hplane := BGS.External.mem_affinePlaneCurveZeros_iff.mp z.1.2 + have hquartic : + ((cagePulledRadicand xi d).eval z.1.1.2 - + (cagePulledRadicand eta d).eval z.1.1.2) ^ 2 = 0 := by + rw [eval_cageOffDiagonalPlanePolynomial] at hplane + rw [hsumRoot] at hplane + linear_combination hplane + have hevals : (cagePulledRadicand xi d).eval z.1.1.2 = + (cagePulledRadicand eta d).eval z.1.1.2 := by + exact sub_eq_zero.mp (mul_self_eq_zero.mp (by + simpa [pow_two] using hquartic)) + have hdifference := congrArg + (fun q : (ZMod p)[X] => q.eval z.1.1.2) + (cagePulledRadicand_sub xi eta d) + have hproduct : (xi ^ 2 - eta ^ 2) * + (z.1.1.2 ^ (2 * d) - 1) ^ 2 = 0 := by + simpa [hevals] using hdifference + have hsquare := (mul_eq_zero.mp hproduct).resolve_left + (sub_ne_zero.mpr hoffDiagonal) + have hbase : z.1.1.2 ^ (2 * d) - 1 = 0 := by + apply mul_self_eq_zero.mp + simpa [pow_two] using hsquare + exact Sum.inr ⟨z.1.1.2, sub_eq_zero.mp hbase⟩ + inj' := by + intro x y hxy + by_cases hx : x.1.1.2 = 0 + · by_cases hy : y.1.1.2 = 0 + · simp only [hx, hy, ite_eq_left] at hxy + have hpayload := Sum.inl.inj hxy + apply Subtype.ext + apply Subtype.ext + exact Prod.ext (congrArg Subtype.val hpayload) (hx.trans hy.symm) + · simp [hx, hy] at hxy + · by_cases hy : y.1.1.2 = 0 + · simp [hx, hy] at hxy + · simp only [hx, hy, ite_eq_right] at hxy + have hpayload := Sum.inr.inj hxy + have hparameter : x.1.1.2 = y.1.1.2 := congrArg Subtype.val hpayload + have hxsum : x.1.1.1 = 0 := by + by_contra hsum + exact x.2 ⟨hsum, hx⟩ + have hysum : y.1.1.1 = 0 := by + by_contra hsum + exact y.2 ⟨hsum, hy⟩ + apply Subtype.ext + apply Subtype.ext + exact Prod.ext (hxsum.trans hysum.symm) hparameter } + +lemma badOffDiagonalPlane_card_le + (p : Nat) [Fact p.Prime] (xi eta : ZMod p) {d : Nat} (hd : 0 < d) + (hoffDiagonal : xi ^ 2 ≠ eta ^ 2) : + Nat.card {z : CageOffDiagonalPlanePoint p xi eta d // + ¬ IsGoodOffDiagonalPlanePoint z} ≤ 2 * d + 4 := by + have hinj := Nat.card_le_card_of_injective + (badOffDiagonalPlaneEmbedding p xi eta (d := d) hoffDiagonal).toFun + (badOffDiagonalPlaneEmbedding p xi eta (d := d) hoffDiagonal).injective + rw [Nat.card_sum] at hinj + have hzeroParameter : Nat.card {sumRoot : ZMod p // + (cageOffDiagonalZeroParameterPolynomial xi eta d).eval sumRoot = 0} ≤ 4 := + (rootCount_le_natDegree _ + (cageOffDiagonalZeroParameterPolynomial_ne_zero xi eta d)).trans + (cageOffDiagonalZeroParameterPolynomial_natDegree_le xi eta d) + have hpower : Nat.card {parameter : ZMod p // + parameter ^ (2 * d) = 1} ≤ 2 * d := powerRootCount_le (by omega) + omega + +theorem cagePulledRootPair_offDiagonal_card_comparison + (p : Nat) [Fact p.Prime] (hpTwo : p ≠ 2) + (xi eta : ZMod p) {d : Nat} (hd : 0 < d) + (hoffDiagonal : xi ^ 2 ≠ eta ^ 2) : + |(Nat.card (CagePulledRootPair p xi eta d) : Int) - + (BGS.External.affinePlaneCurveZeros (ZMod p) + (cageOffDiagonalPlanePolynomial xi eta d)).card| ≤ 6 * d + 4 := by + classical + let : Finite (CagePulledRootPair p xi eta d) := + Finite.of_injective + (fun z => (z.parameter, z.firstRoot, z.secondRoot)) (by + intro x y h + apply CagePulledRootPair.ext + · exact congrArg Prod.fst h + · exact congrArg (fun q => q.2.1) h + · exact congrArg (fun q => q.2.2) h) + let goodPulled := {z : CagePulledRootPair p xi eta d // + IsGoodOffDiagonalPulledPair z} + let badPulled := {z : CagePulledRootPair p xi eta d // + ¬ IsGoodOffDiagonalPulledPair z} + let goodPlane := {z : CageOffDiagonalPlanePoint p xi eta d // + IsGoodOffDiagonalPlanePoint z} + let badPlane := {z : CageOffDiagonalPlanePoint p xi eta d // + ¬ IsGoodOffDiagonalPlanePoint z} + have hsplitPulled : Nat.card (CagePulledRootPair p xi eta d) = + Nat.card goodPulled + Nat.card badPulled := by + calc + Nat.card (CagePulledRootPair p xi eta d) = + Nat.card (goodPulled ⊕ badPulled) := + (Nat.card_congr (Equiv.sumCompl + (fun z : CagePulledRootPair p xi eta d => + IsGoodOffDiagonalPulledPair z))).symm + _ = Nat.card goodPulled + Nat.card badPulled := Nat.card_sum + have hplaneCard : Nat.card (CageOffDiagonalPlanePoint p xi eta d) = + (BGS.External.affinePlaneCurveZeros (ZMod p) + (cageOffDiagonalPlanePolynomial xi eta d)).card := by + simpa only [Nat.card_eq_fintype_card] using Fintype.card_coe + (BGS.External.affinePlaneCurveZeros (ZMod p) + (cageOffDiagonalPlanePolynomial xi eta d)) + have hsplitPlane : + (BGS.External.affinePlaneCurveZeros (ZMod p) + (cageOffDiagonalPlanePolynomial xi eta d)).card = + Nat.card goodPlane + Nat.card badPlane := by + calc + _ = Nat.card (CageOffDiagonalPlanePoint p xi eta d) := hplaneCard.symm + _ = Nat.card (goodPlane ⊕ badPlane) := + (Nat.card_congr (Equiv.sumCompl + (fun z : CageOffDiagonalPlanePoint p xi eta d => + IsGoodOffDiagonalPlanePoint z))).symm + _ = Nat.card goodPlane + Nat.card badPlane := Nat.card_sum + have hgood : Nat.card goodPulled = Nat.card goodPlane := + Nat.card_congr (goodOffDiagonalPulledEquivPlane p hpTwo xi eta d) + have hbadPulled : Nat.card badPulled ≤ 4 * d := by + exact badOffDiagonalPulled_card_le p hpTwo xi eta hd hoffDiagonal + have hbadPlane : Nat.card badPlane ≤ 2 * d + 4 := by + exact badOffDiagonalPlane_card_le p xi eta hd hoffDiagonal + have herror : + |(Nat.card (CagePulledRootPair p xi eta d) : Int) - + (BGS.External.affinePlaneCurveZeros (ZMod p) + (cageOffDiagonalPlanePolynomial xi eta d)).card| ≤ + Nat.card badPulled + Nat.card badPlane := by + rw [hsplitPulled, hsplitPlane, hgood] + push_cast + have habs := abs_sub (Nat.card badPulled : Int) + (Nat.card badPlane : Int) + simpa using habs + exact herror.trans (by exact_mod_cast (by omega : + Nat.card badPulled + Nat.card badPlane ≤ 6 * d + 4)) + +end + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Cage/PlaneHasseWeil.lean b/LeanPool/MarkoffModP/BGS/Markoff/Cage/PlaneHasseWeil.lean new file mode 100644 index 0000000000..79af3c7452 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Cage/PlaneHasseWeil.lean @@ -0,0 +1,165 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Cage.PlaneModels +public import LeanPool.MarkoffModP.BGS.Markoff.Cage.HasseWeilAssumption + +/-! +# Hasse--Weil estimates for the direct cage plane models + +This file applies the single allowed general affine Hasse--Weil theorem to +the two explicit cage models. It also proves that the divisor exponents +used by the cage are prime to the characteristic; that condition is not +left as a specialized assumption. +-/ + +@[expose] public section + +namespace BGS.Markoff + +noncomputable section + +/-- A uniform point estimate for both direct cage plane models. -/ +def CagePlanePointEstimate (coefficient : ℕ) : Prop := + ∀ (p : ℕ) [Fact p.Prime], 7 ≤ p → + ∀ (xi eta : ZMod p), + IsSplitMaximalTrace p xi → IsSplitMaximalTrace p eta → + ∀ d : ℕ, d ∣ p - 1 → 0 < d → + |((BGS.External.affinePlaneCurveZeros (ZMod p) + (cageDiagonalPlanePolynomial xi d)).card : ℝ) - p| ≤ + (coefficient : ℝ) * Real.sqrt p * d ∧ + (xi ^ 2 ≠ eta ^ 2 → + |((BGS.External.affinePlaneCurveZeros (ZMod p) + (cageOffDiagonalPlanePolynomial xi eta d)).card : ℝ) - p| ≤ + (coefficient : ℝ) * Real.sqrt p * d) + +/-- A positive divisor of `p-1` is strictly smaller than `p`. -/ +lemma divisor_pred_lt_prime {p d : ℕ} (hpTwo : 2 ≤ p) + (hd : d ∣ p - 1) : + d < p := by + have hdLe : d ≤ p - 1 := Nat.le_of_dvd (by omega) hd + omega + +/-- The pulled-cover exponent `2d` is nonzero in `ZMod p` for every positive +divisor `d` of `p-1` and every prime `p ≥ 7`. -/ +lemma two_mul_divisor_pred_ne_zero_zmod + (p : ℕ) [Fact p.Prime] (hpSeven : 7 ≤ p) + {d : ℕ} (hd : d ∣ p - 1) (hdPositive : 0 < d) : + (((2 * d : ℕ) : ZMod p)) ≠ 0 := by + intro hzero + have hpDvd : p ∣ 2 * d := (ZMod.natCast_eq_zero_iff (2 * d) p).mp hzero + rcases (Fact.out : p.Prime).dvd_mul.mp hpDvd with hpTwo | hpD + · have hpLeTwo := Nat.le_of_dvd (by norm_num) hpTwo + omega + · have hdLt := divisor_pred_lt_prime (by omega) hd + exact (Nat.not_dvd_of_pos_of_lt hdPositive hdLt) hpD + +/-- A fixed-coefficient affine Hasse--Weil bound gives fixed uniform estimates +for both cage plane models. -/ +theorem cagePlanePointEstimate_of_bivariateAffineHasseWeilBound + (generalCoefficient : ℕ) + (hgeneral : BGS.External.BivariateAffineHasseWeilBound generalCoefficient) : + CagePlanePointEstimate (32 * generalCoefficient) := by + let coefficient := 32 * generalCoefficient + change CagePlanePointEstimate coefficient + intro p _ hpSeven xi eta hxi heta d hd hdPositive + have h2 : (2 : ZMod p) ≠ 0 := + natCast_ne_zero_zmod_of_pos_of_lt (n := 2) (p := p) (by norm_num) (by omega) + have hdegree : (((2 * d : ℕ) : ZMod p)) ≠ 0 := + two_mul_divisor_pred_ne_zero_zmod p hpSeven hd hdPositive + have hxiNonzero := splitMaximalTrace_ne_zero p hpSeven xi hxi + have hetaNonzero := splitMaximalTrace_ne_zero p hpSeven eta heta + have hXi := sub_ne_zero.mpr (splitMaximalTrace_sq_ne_four p hpSeven xi hxi) + have hEta := sub_ne_zero.mpr (splitMaximalTrace_sq_ne_four p hpSeven eta heta) + have hDiagonal := hgeneral (ZMod p) + (cageDiagonalPlanePolynomial xi d) 2 (4 * d) + (by norm_num) (by omega) + (cageDiagonalPlanePolynomial_hasBidegreeAtMost xi d) + (cageDiagonalPlanePolynomial_absolutelyIrreducible + hxiNonzero hXi hdPositive h2 hdegree) + constructor + · have hcard : Fintype.card (ZMod p) = p := ZMod.card p + rw [hcard] at hDiagonal + dsimp [coefficient] + calc + |((BGS.External.affinePlaneCurveZeros (ZMod p) + (cageDiagonalPlanePolynomial xi d)).card : ℝ) - p| ≤ + (generalCoefficient : ℝ) * Real.sqrt p * + ((2 : ℕ) : ℝ) * (((4 * d : ℕ) : ℝ)) := hDiagonal + _ = (8 * generalCoefficient : ℝ) * Real.sqrt p * d := by + push_cast + ring + _ ≤ (((32 * generalCoefficient : ℕ) : ℝ)) * Real.sqrt p * d := by + push_cast + have hnonnegative : + 0 ≤ (generalCoefficient : ℝ) * Real.sqrt p * (d : ℝ) := by + positivity + nlinarith + · intro hoffDiagonal + have hOffDiagonal := hgeneral (ZMod p) + (cageOffDiagonalPlanePolynomial xi eta d) 4 (8 * d) + (by norm_num) (by omega) + (cageOffDiagonalPlanePolynomial_hasBidegreeAtMost xi eta d) + (cageOffDiagonalPlanePolynomial_absolutelyIrreducible + hxiNonzero hetaNonzero hXi hEta hoffDiagonal hdPositive h2 hdegree) + have hcard : Fintype.card (ZMod p) = p := ZMod.card p + rw [hcard] at hOffDiagonal + dsimp [coefficient] + calc + |((BGS.External.affinePlaneCurveZeros (ZMod p) + (cageOffDiagonalPlanePolynomial xi eta d)).card : ℝ) - p| ≤ + (generalCoefficient : ℝ) * Real.sqrt p * + ((4 : ℕ) : ℝ) * (((8 * d : ℕ) : ℝ)) := hOffDiagonal + _ = (((32 * generalCoefficient : ℕ) : ℝ)) * Real.sqrt p * d := by + push_cast + ring + +/-- The allowed general Hasse--Weil theorem gives uniform estimates for both +the diagonal and off-diagonal cage plane models. -/ +theorem exists_cagePlanePointEstimate_of_generalHasseWeil + (hHasse : BGS.External.GeneralBivariateAffineHasseWeilTheorem) : + ∃ coefficient : ℕ, 0 < coefficient ∧ CagePlanePointEstimate coefficient := by + obtain ⟨generalCoefficient, hgeneralCoefficient, hgeneral⟩ := hHasse + exact ⟨32 * generalCoefficient, by omega, + cagePlanePointEstimate_of_bivariateAffineHasseWeilBound + generalCoefficient hgeneral⟩ + +/-- Divide an exact `d`-fold cover estimate by its fiber multiplicity. This +is the numerical step used after the geometric count comparison. -/ +lemma range_count_error_of_exact_cover + {coverCard rangeCard p d multiplicity : ℕ} {error : ℝ} + (hd : 0 < d) (hcover : coverCard = d * rangeCard) + (herror : + |(coverCard : ℝ) - (multiplicity : ℝ) * p| ≤ + error * d) : + |(rangeCard : ℝ) - (multiplicity : ℝ) * p / d| ≤ error := by + have hdReal : (d : ℝ) ≠ 0 := by exact_mod_cast hd.ne' + have hdNonnegative : (0 : ℝ) ≤ d := by positivity + have hidentity : + |(rangeCard : ℝ) - (multiplicity : ℝ) * p / d| = + |(coverCard : ℝ) - (multiplicity : ℝ) * p| / d := by + rw [hcover] + push_cast + calc + |(rangeCard : ℝ) - (multiplicity : ℝ) * p / d| = + |((d : ℝ) * rangeCard - (multiplicity : ℝ) * p) / d| := by + congr 1 + field_simp [hdReal] + _ = |(d : ℝ) * rangeCard - (multiplicity : ℝ) * p| / |(d : ℝ)| := + abs_div _ _ + _ = |(d : ℝ) * rangeCard - (multiplicity : ℝ) * p| / d := by + rw [abs_of_nonneg hdNonnegative] + rw [hidentity] + calc + |(coverCard : ℝ) - (multiplicity : ℝ) * p| / d ≤ + (error * d) / d := div_le_div_of_nonneg_right herror hdNonnegative + _ = error := by field_simp [hdReal] + +end + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Cage/PlaneModels.lean b/LeanPool/MarkoffModP/BGS/Markoff/Cage/PlaneModels.lean new file mode 100644 index 0000000000..fad390b403 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Cage/PlaneModels.lean @@ -0,0 +1,550 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Cage.PulledRadicand +public import LeanPool.MarkoffModP.BGS.Markoff.Cage.BiquadraticPrimitiveQuartic +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.WeightedIrreducibility +public import LeanPool.MarkoffModP.BGS.External.GeneralCurveTheorems + +/-! +# Direct affine-plane models for the cage + +The first variable is the primitive root coordinate and the second variable +is the power parameter. Passing through `finTwoToIteratedPolynomial` makes +the defining equations polynomials in the root coordinate with coefficients +in the parameter polynomial ring. +-/ + +@[expose] public section + +namespace BGS.Markoff + +open Polynomial + +noncomputable section + +variable {K : Type*} [Field K] + +/-- The two-variable/iterated-polynomial equivalence commutes with extension +of scalar fields. -/ +lemma finTwoToIteratedPolynomial_map + {L : Type*} [Field L] (phi : K →+* L) + (p : MvPolynomial (Fin 2) K) : + finTwoToIteratedPolynomial (K := L) (MvPolynomial.map phi p) = + (finTwoToIteratedPolynomial (K := K) p).map + (Polynomial.mapRingHom phi) := by + let lhs : MvPolynomial (Fin 2) K →+* L[X][X] := + (finTwoToIteratedPolynomial (K := L)).toRingEquiv.toRingHom.comp + (MvPolynomial.map phi) + let rhs : MvPolynomial (Fin 2) K →+* L[X][X] := + (Polynomial.mapRingHom (Polynomial.mapRingHom phi)).comp + (finTwoToIteratedPolynomial (K := K)).toRingEquiv.toRingHom + have heq : lhs = rhs := by + apply MvPolynomial.ringHom_ext + · intro r + simp [lhs, rhs, RingHom.comp_apply, finTwoToIteratedPolynomial_C] + · intro i + fin_cases i <;> + simp [lhs, rhs, RingHom.comp_apply, + finTwoToIteratedPolynomial_X_zero, + finTwoToIteratedPolynomial_X_one] + exact DFunLike.congr_fun heq p + +/-- The diagonal hyperelliptic model `L² = F_ξ(t)`, written as a polynomial +in `L` over `K[t]`. -/ +def cageDiagonalIteratedPolynomial (xi : K) (d : ℕ) : K[X][X] := + adjoinSquarePolynomial (cagePulledRadicand xi d) + +/-- The off-diagonal primitive-element model. Its root coordinate is +`S = L + M`; eliminating `L` and `M` gives +`(S² - F_ξ - F_η)² - 4 F_ξ F_η`. -/ +def cageOffDiagonalIteratedPolynomial (xi eta : K) (d : ℕ) : K[X][X] := + (X ^ 2 - C (cagePulledRadicand xi d + cagePulledRadicand eta d)) ^ 2 - + C (4 * (cagePulledRadicand xi d * cagePulledRadicand eta d)) + +/-- The pulled radicand placed in the second bivariate coordinate. -/ +def cagePulledRadicandSecondCoordinate (xi : K) (d : ℕ) : + MvPolynomial (Fin 2) K := + MvPolynomial.C (xi ^ 2 - 4) * MvPolynomial.X 1 ^ (4 * d) - + MvPolynomial.C (2 * (xi ^ 2 + 4)) * MvPolynomial.X 1 ^ (2 * d) + + MvPolynomial.C (xi ^ 2 - 4) + +@[simp] +lemma finTwoToIteratedPolynomial_cagePulledRadicandSecondCoordinate + (xi : K) (d : ℕ) : + finTwoToIteratedPolynomial (cagePulledRadicandSecondCoordinate xi d) = + C (cagePulledRadicand xi d) := by + rw [cagePulledRadicand_expanded] + simp [cagePulledRadicandSecondCoordinate] + +/-- The diagonal model as the displayed bivariate polynomial +`L² - F_ξ(t)`. -/ +def cageDiagonalPlanePolynomial (xi : K) (d : ℕ) : MvPolynomial (Fin 2) K := + MvPolynomial.X 0 ^ 2 - cagePulledRadicandSecondCoordinate xi d + +/-- The off-diagonal model as an honest bivariate polynomial. -/ +def cageOffDiagonalPlanePolynomial (xi eta : K) (d : ℕ) : + MvPolynomial (Fin 2) K := + (MvPolynomial.X 0 ^ 2 - + (cagePulledRadicandSecondCoordinate xi d + + cagePulledRadicandSecondCoordinate eta d)) ^ 2 - + MvPolynomial.C 4 * cagePulledRadicandSecondCoordinate xi d * + cagePulledRadicandSecondCoordinate eta d + +@[simp] +lemma finTwoToIteratedPolynomial_cageDiagonalPlanePolynomial (xi : K) (d : ℕ) : + finTwoToIteratedPolynomial (cageDiagonalPlanePolynomial xi d) = + cageDiagonalIteratedPolynomial xi d := by + simp [cageDiagonalPlanePolynomial, cageDiagonalIteratedPolynomial, + adjoinSquarePolynomial] + +@[simp] +lemma finTwoToIteratedPolynomial_cageOffDiagonalPlanePolynomial + (xi eta : K) (d : ℕ) : + finTwoToIteratedPolynomial (cageOffDiagonalPlanePolynomial xi eta d) = + cageOffDiagonalIteratedPolynomial xi eta d := by + simp only [cageOffDiagonalPlanePolynomial, + cageOffDiagonalIteratedPolynomial, map_sub, map_pow, map_add, map_mul, + finTwoToIteratedPolynomial_X_zero, + finTwoToIteratedPolynomial_cagePulledRadicandSecondCoordinate, + finTwoToIteratedPolynomial_C] + have hC4 : (C (4 : K) : K[X]) = 4 := + map_natCast (Polynomial.C : K →+* K[X]) 4 + rw [hC4] + ring + +/-- Gauss's lemma turns nonsquareness of the radicand in `K(t)` into +irreducibility of the diagonal plane equation over `K[t]`. -/ +lemma cageDiagonalIteratedPolynomial_irreducible + {xi : K} (hxi : xi ≠ 0) (hXi : xi ^ 2 - 4 ≠ 0) + {d : ℕ} (hd : 0 < d) (h2 : (2 : K) ≠ 0) + (hdegree : (((2 * d : ℕ) : K)) ≠ 0) : + Irreducible (cageDiagonalIteratedPolynomial xi d) := by + have hsquarefree := + (cagePulledRadicand_separable h2 hxi hXi hd hdegree).squarefree + have hnonsquare : + ¬ IsSquare + (algebraMap K[X] (FractionRing K[X]) (cagePulledRadicand xi d)) := + not_isSquare_algebraMap_of_squarefree_not_isUnit hsquarefree + (cagePulledRadicand_not_isUnit hXi hd) + have hfraction : Irreducible + ((cageDiagonalIteratedPolynomial xi d).map + (algebraMap K[X] (FractionRing K[X]))) := by + simpa [cageDiagonalIteratedPolynomial, adjoinSquarePolynomial] using + adjoinSquarePolynomial_irreducible_of_not_isSquare hnonsquare + have hmonic : (cageDiagonalIteratedPolynomial xi d).Monic := + adjoinSquarePolynomial_monic _ + exact hmonic.isPrimitive.irreducible_iff_irreducible_map_fraction_map.mpr + hfraction + +/-- Ground-field irreducibility of the diagonal bivariate polynomial. -/ +lemma cageDiagonalPlanePolynomial_irreducible + {xi : K} (hxi : xi ≠ 0) (hXi : xi ^ 2 - 4 ≠ 0) + {d : ℕ} (hd : 0 < d) (h2 : (2 : K) ≠ 0) + (hdegree : (((2 * d : ℕ) : K)) ≠ 0) : + Irreducible (cageDiagonalPlanePolynomial xi d) := by + have hiterated := cageDiagonalIteratedPolynomial_irreducible + hxi hXi hd h2 hdegree + have hback := hiterated.map (finTwoToIteratedPolynomial (K := K)).symm + have heq : + (finTwoToIteratedPolynomial (K := K)).symm + (cageDiagonalIteratedPolynomial xi d) = + cageDiagonalPlanePolynomial xi d := by + rw [← finTwoToIteratedPolynomial_cageDiagonalPlanePolynomial] + exact (finTwoToIteratedPolynomial (K := K)).symm_apply_apply _ + rw [heq] at hback + exact hback + +/-- The off-diagonal primitive quartic is irreducible over the parameter +polynomial ring. The only geometric input is the proved independence of the +three pulled-radicand square classes. -/ +lemma cageOffDiagonalIteratedPolynomial_irreducible + {xi eta : K} (hxi : xi ≠ 0) (heta : eta ≠ 0) + (hXi : xi ^ 2 - 4 ≠ 0) (hEta : eta ^ 2 - 4 ≠ 0) + (hoffDiagonal : xi ^ 2 ≠ eta ^ 2) {d : ℕ} (hd : 0 < d) + (h2 : (2 : K) ≠ 0) (hdegree : (((2 * d : ℕ) : K)) ≠ 0) : + Irreducible (cageOffDiagonalIteratedPolynomial xi eta d) := by + obtain ⟨hf, hg, hfg⟩ := + cagePulledRadicand_squareClasses_independent_ratFunc h2 hxi heta + hXi hEta hoffDiagonal hd hdegree + have h2Fraction : (2 : RatFunc K) ≠ 0 := by + intro hzero + apply h2 + apply FaithfulSMul.algebraMap_injective K (RatFunc K) + simpa only [map_ofNat, map_zero] using hzero + have hfg' : ¬ IsSquare + (algebraMap K[X] (RatFunc K) (cagePulledRadicand xi d) * + algebraMap K[X] (RatFunc K) (cagePulledRadicand eta d)) := by + simpa only [map_mul] using hfg + have hfractionGeneric := biquadraticPrimitiveQuartic_irreducible + h2Fraction hf hg hfg' + have hfraction : Irreducible + ((cageOffDiagonalIteratedPolynomial xi eta d).map + (algebraMap K[X] (RatFunc K))) := by + have heq : + (cageOffDiagonalIteratedPolynomial xi eta d).map + (algebraMap K[X] (RatFunc K)) = + biquadraticPrimitiveQuartic + (algebraMap K[X] (RatFunc K) (cagePulledRadicand xi d)) + (algebraMap K[X] (RatFunc K) (cagePulledRadicand eta d)) := by + simp only [cageOffDiagonalIteratedPolynomial, + biquadraticPrimitiveQuartic, Polynomial.map_sub, Polynomial.map_pow, + Polynomial.map_C, Polynomial.map_X, Polynomial.map_add, + Polynomial.map_mul, map_add, map_mul] + have hfour : algebraMap K[X] (RatFunc K) (4 : K[X]) = (4 : RatFunc K) := + map_natCast (algebraMap K[X] (RatFunc K)) 4 + rw [hfour] + ring + rw [heq] + exact hfractionGeneric + have hmonic : (cageOffDiagonalIteratedPolynomial xi eta d).Monic := by + have hquadratic : IsMonicOfDegree + (X ^ 2 - C (cagePulledRadicand xi d + cagePulledRadicand eta d) : K[X][X]) 2 := + (isMonicOfDegree_X_pow K[X] 2).sub (by simp) + exact ((hquadratic.pow 2).sub (by + have hpos : 0 < 2 * 2 := by norm_num + simpa only [← C_mul, natDegree_C] using hpos)).monic + exact hmonic.isPrimitive.irreducible_iff_irreducible_map_fraction_map.mpr + hfraction + +/-- Ground-field irreducibility of the off-diagonal bivariate polynomial. -/ +lemma cageOffDiagonalPlanePolynomial_irreducible + {xi eta : K} (hxi : xi ≠ 0) (heta : eta ≠ 0) + (hXi : xi ^ 2 - 4 ≠ 0) (hEta : eta ^ 2 - 4 ≠ 0) + (hoffDiagonal : xi ^ 2 ≠ eta ^ 2) {d : ℕ} (hd : 0 < d) + (h2 : (2 : K) ≠ 0) (hdegree : (((2 * d : ℕ) : K)) ≠ 0) : + Irreducible (cageOffDiagonalPlanePolynomial xi eta d) := by + have hiterated := cageOffDiagonalIteratedPolynomial_irreducible + hxi heta hXi hEta hoffDiagonal hd h2 hdegree + have hback := hiterated.map (finTwoToIteratedPolynomial (K := K)).symm + have heq : + (finTwoToIteratedPolynomial (K := K)).symm + (cageOffDiagonalIteratedPolynomial xi eta d) = + cageOffDiagonalPlanePolynomial xi eta d := by + rw [← finTwoToIteratedPolynomial_cageOffDiagonalPlanePolynomial] + exact (finTwoToIteratedPolynomial (K := K)).symm_apply_apply _ + rw [heq] at hback + exact hback + +/-- Scalar extension commutes with the explicit pulled radicand. -/ +lemma map_cagePulledRadicand + {L : Type*} [Field L] (phi : K →+* L) (xi : K) (d : ℕ) : + (cagePulledRadicand xi d).map phi = cagePulledRadicand (phi xi) d := by + have h4 : phi (4 : K) = (4 : L) := map_natCast phi 4 + simp only [cagePulledRadicand, Polynomial.map_sub, Polynomial.map_mul, + Polynomial.map_C, Polynomial.map_pow, Polynomial.map_X, + Polynomial.map_add, Polynomial.map_one, + map_sub, map_pow, map_mul] + rw [h4] + +/-- The diagonal plane model is absolutely irreducible. -/ +lemma cageDiagonalPlanePolynomial_absolutelyIrreducible + {xi : K} (hxi : xi ≠ 0) (hXi : xi ^ 2 - 4 ≠ 0) + {d : ℕ} (hd : 0 < d) (h2 : (2 : K) ≠ 0) + (hdegree : (((2 * d : ℕ) : K)) ≠ 0) : + Irreducible + (MvPolynomial.map (algebraMap K (AlgebraicClosure K)) + (cageDiagonalPlanePolynomial xi d)) := by + let phi : K →+* AlgebraicClosure K := algebraMap K (AlgebraicClosure K) + have hxi' : phi xi ≠ 0 := (map_ne_zero_iff phi phi.injective).mpr hxi + have hXi' : (phi xi) ^ 2 - 4 ≠ 0 := by + have hmapped := (map_ne_zero_iff phi phi.injective).mpr hXi + rw [map_sub, map_pow] at hmapped + have hfour : phi (4 : K) = (4 : AlgebraicClosure K) := map_natCast phi 4 + rw [hfour] at hmapped + exact hmapped + have h2' : (2 : AlgebraicClosure K) ≠ 0 := by + have hmapped := (map_ne_zero_iff phi phi.injective).mpr h2 + have htwo : phi (2 : K) = (2 : AlgebraicClosure K) := map_natCast phi 2 + rw [htwo] at hmapped + exact hmapped + have hdegree' : (((2 * d : ℕ) : AlgebraicClosure K)) ≠ 0 := by + have hmapped := (map_ne_zero_iff phi phi.injective).mpr hdegree + have hcast : phi (((2 * d : ℕ) : K)) = + (((2 * d : ℕ) : AlgebraicClosure K)) := map_natCast phi (2 * d) + rw [hcast] at hmapped + exact hmapped + have hiterated := cageDiagonalIteratedPolynomial_irreducible + hxi' hXi' hd h2' hdegree' + have himage : + finTwoToIteratedPolynomial (K := AlgebraicClosure K) + (MvPolynomial.map phi (cageDiagonalPlanePolynomial xi d)) = + cageDiagonalIteratedPolynomial (phi xi) d := by + rw [finTwoToIteratedPolynomial_map] + simp [finTwoToIteratedPolynomial_cageDiagonalPlanePolynomial, + cageDiagonalIteratedPolynomial, adjoinSquarePolynomial, + map_cagePulledRadicand] + rw [← himage] at hiterated + have hback := hiterated.map + (finTwoToIteratedPolynomial (K := AlgebraicClosure K)).symm + simpa [phi] using hback + +/-- The off-diagonal primitive quartic is absolutely irreducible. -/ +lemma cageOffDiagonalPlanePolynomial_absolutelyIrreducible + {xi eta : K} (hxi : xi ≠ 0) (heta : eta ≠ 0) + (hXi : xi ^ 2 - 4 ≠ 0) (hEta : eta ^ 2 - 4 ≠ 0) + (hoffDiagonal : xi ^ 2 ≠ eta ^ 2) {d : ℕ} (hd : 0 < d) + (h2 : (2 : K) ≠ 0) (hdegree : (((2 * d : ℕ) : K)) ≠ 0) : + Irreducible + (MvPolynomial.map (algebraMap K (AlgebraicClosure K)) + (cageOffDiagonalPlanePolynomial xi eta d)) := by + let phi : K →+* AlgebraicClosure K := algebraMap K (AlgebraicClosure K) + have hxi' : phi xi ≠ 0 := (map_ne_zero_iff phi phi.injective).mpr hxi + have heta' : phi eta ≠ 0 := (map_ne_zero_iff phi phi.injective).mpr heta + have hXi' : (phi xi) ^ 2 - 4 ≠ 0 := by + have hmapped := (map_ne_zero_iff phi phi.injective).mpr hXi + rw [map_sub, map_pow] at hmapped + have hfour : phi (4 : K) = (4 : AlgebraicClosure K) := map_natCast phi 4 + rw [hfour] at hmapped + exact hmapped + have hEta' : (phi eta) ^ 2 - 4 ≠ 0 := by + have hmapped := (map_ne_zero_iff phi phi.injective).mpr hEta + rw [map_sub, map_pow] at hmapped + have hfour : phi (4 : K) = (4 : AlgebraicClosure K) := map_natCast phi 4 + rw [hfour] at hmapped + exact hmapped + have hoffDiagonal' : (phi xi) ^ 2 ≠ (phi eta) ^ 2 := by + intro h + apply hoffDiagonal + apply phi.injective + simpa only [map_pow] using h + have h2' : (2 : AlgebraicClosure K) ≠ 0 := by + have hmapped := (map_ne_zero_iff phi phi.injective).mpr h2 + have htwo : phi (2 : K) = (2 : AlgebraicClosure K) := map_natCast phi 2 + rw [htwo] at hmapped + exact hmapped + have hdegree' : (((2 * d : ℕ) : AlgebraicClosure K)) ≠ 0 := by + have hmapped := (map_ne_zero_iff phi phi.injective).mpr hdegree + have hcast : phi (((2 * d : ℕ) : K)) = + (((2 * d : ℕ) : AlgebraicClosure K)) := map_natCast phi (2 * d) + rw [hcast] at hmapped + exact hmapped + have hiterated := cageOffDiagonalIteratedPolynomial_irreducible + hxi' heta' hXi' hEta' hoffDiagonal' hd h2' hdegree' + have himage : + finTwoToIteratedPolynomial (K := AlgebraicClosure K) + (MvPolynomial.map phi (cageOffDiagonalPlanePolynomial xi eta d)) = + cageOffDiagonalIteratedPolynomial (phi xi) (phi eta) d := by + rw [finTwoToIteratedPolynomial_map] + simp [finTwoToIteratedPolynomial_cageOffDiagonalPlanePolynomial, + cageOffDiagonalIteratedPolynomial, map_cagePulledRadicand] + rw [← himage] at hiterated + have hback := hiterated.map + (finTwoToIteratedPolynomial (K := AlgebraicClosure K)).symm + simpa [phi] using hback + +private lemma degreeOf_C_mul_X_one_pow_first_le (a : K) (n : ℕ) : + MvPolynomial.degreeOf (0 : Fin 2) + (MvPolynomial.C a * MvPolynomial.X 1 ^ n) ≤ 0 := by + refine (MvPolynomial.degreeOf_mul_le _ _ _).trans ?_ + rw [MvPolynomial.degreeOf_C, + MvPolynomial.degreeOf_X_pow_of_ne n (by decide : (0 : Fin 2) ≠ 1)] + +private lemma degreeOf_C_mul_X_one_pow_second_le (a : K) (n : ℕ) : + MvPolynomial.degreeOf (1 : Fin 2) + (MvPolynomial.C a * MvPolynomial.X 1 ^ n) ≤ n := by + refine (MvPolynomial.degreeOf_mul_le _ _ _).trans ?_ + rw [MvPolynomial.degreeOf_C, MvPolynomial.degreeOf_X_self_pow] + omega + +/-- Coordinate-degree bound for a pulled radicand: it is independent of the +root coordinate. -/ +lemma cagePulledRadicandSecondCoordinate_degreeOf_first_le + (xi : K) (d : ℕ) : + MvPolynomial.degreeOf (0 : Fin 2) + (cagePulledRadicandSecondCoordinate xi d) ≤ 0 := by + unfold cagePulledRadicandSecondCoordinate + refine (MvPolynomial.degreeOf_add_le _ _ _).trans (max_le ?_ ?_) + · refine (MvPolynomial.degreeOf_sub_le _ _ _).trans (max_le ?_ ?_) + · exact degreeOf_C_mul_X_one_pow_first_le _ _ + · exact degreeOf_C_mul_X_one_pow_first_le _ _ + · rw [MvPolynomial.degreeOf_C] + +/-- Coordinate-degree bound for a pulled radicand in the power parameter. -/ +lemma cagePulledRadicandSecondCoordinate_degreeOf_second_le + (xi : K) (d : ℕ) : + MvPolynomial.degreeOf (1 : Fin 2) + (cagePulledRadicandSecondCoordinate xi d) ≤ 4 * d := by + unfold cagePulledRadicandSecondCoordinate + refine (MvPolynomial.degreeOf_add_le _ _ _).trans (max_le ?_ ?_) + · refine (MvPolynomial.degreeOf_sub_le _ _ _).trans (max_le ?_ ?_) + · exact degreeOf_C_mul_X_one_pow_second_le _ _ + · exact (degreeOf_C_mul_X_one_pow_second_le _ _).trans (by omega) + · rw [MvPolynomial.degreeOf_C] + omega + +/-- The diagonal model has bidegree at most `(2,4d)`. -/ +lemma cageDiagonalPlanePolynomial_hasBidegreeAtMost (xi : K) (d : ℕ) : + BGS.External.HasBidegreeAtMost + (cageDiagonalPlanePolynomial xi d) 2 (4 * d) := by + have hfirst : MvPolynomial.degreeOf (0 : Fin 2) + (cageDiagonalPlanePolynomial xi d) ≤ 2 := by + unfold cageDiagonalPlanePolynomial + refine (MvPolynomial.degreeOf_sub_le _ _ _).trans (max_le ?_ ?_) + · simp + · exact (cagePulledRadicandSecondCoordinate_degreeOf_first_le xi d).trans + (by omega) + have hsecond : MvPolynomial.degreeOf (1 : Fin 2) + (cageDiagonalPlanePolynomial xi d) ≤ 4 * d := by + unfold cageDiagonalPlanePolynomial + refine (MvPolynomial.degreeOf_sub_le _ _ _).trans (max_le ?_ ?_) + · rw [MvPolynomial.degreeOf_X_pow_of_ne 2 (by decide : (1 : Fin 2) ≠ 0)] + omega + · exact cagePulledRadicandSecondCoordinate_degreeOf_second_le xi d + intro monomial hmonomial + exact ⟨(MvPolynomial.degreeOf_le_iff.mp hfirst) monomial hmonomial, + (MvPolynomial.degreeOf_le_iff.mp hsecond) monomial hmonomial⟩ + +/-- The primitive off-diagonal quartic has bidegree at most `(4,8d)`. -/ +lemma cageOffDiagonalPlanePolynomial_hasBidegreeAtMost + (xi eta : K) (d : ℕ) : + BGS.External.HasBidegreeAtMost + (cageOffDiagonalPlanePolynomial xi eta d) 4 (8 * d) := by + have hfirst : MvPolynomial.degreeOf (0 : Fin 2) + (cageOffDiagonalPlanePolynomial xi eta d) ≤ 4 := by + unfold cageOffDiagonalPlanePolynomial + have hsum : MvPolynomial.degreeOf (0 : Fin 2) + (cagePulledRadicandSecondCoordinate xi d + + cagePulledRadicandSecondCoordinate eta d) ≤ 0 := + (MvPolynomial.degreeOf_add_le _ _ _).trans (max_le + (cagePulledRadicandSecondCoordinate_degreeOf_first_le xi d) + (cagePulledRadicandSecondCoordinate_degreeOf_first_le eta d)) + have hinside : MvPolynomial.degreeOf (0 : Fin 2) + (MvPolynomial.X 0 ^ 2 - + (cagePulledRadicandSecondCoordinate xi d + + cagePulledRadicandSecondCoordinate eta d)) ≤ 2 := + (MvPolynomial.degreeOf_sub_le _ _ _).trans (max_le (by simp) (hsum.trans (by omega))) + have hsquare := MvPolynomial.degreeOf_pow_le (0 : Fin 2) + (MvPolynomial.X 0 ^ 2 - + (cagePulledRadicandSecondCoordinate xi d + + cagePulledRadicandSecondCoordinate eta d)) 2 + have hproduct : MvPolynomial.degreeOf (0 : Fin 2) + (MvPolynomial.C 4 * cagePulledRadicandSecondCoordinate xi d * + cagePulledRadicandSecondCoordinate eta d) ≤ 0 := by + have hleft : MvPolynomial.degreeOf (0 : Fin 2) + (MvPolynomial.C 4 * cagePulledRadicandSecondCoordinate xi d) ≤ 0 := by + refine (MvPolynomial.degreeOf_mul_le _ _ _).trans ?_ + rw [MvPolynomial.degreeOf_C] + simpa using cagePulledRadicandSecondCoordinate_degreeOf_first_le xi d + refine (MvPolynomial.degreeOf_mul_le _ _ _).trans ?_ + exact (add_le_add hleft + (cagePulledRadicandSecondCoordinate_degreeOf_first_le eta d)).trans (by omega) + refine (MvPolynomial.degreeOf_sub_le _ _ _).trans (max_le ?_ ?_) + · exact hsquare.trans (by omega) + · exact hproduct.trans (by omega) + have hsecond : MvPolynomial.degreeOf (1 : Fin 2) + (cageOffDiagonalPlanePolynomial xi eta d) ≤ 8 * d := by + unfold cageOffDiagonalPlanePolynomial + have hsum : MvPolynomial.degreeOf (1 : Fin 2) + (cagePulledRadicandSecondCoordinate xi d + + cagePulledRadicandSecondCoordinate eta d) ≤ 4 * d := + (MvPolynomial.degreeOf_add_le _ _ _).trans (max_le + (cagePulledRadicandSecondCoordinate_degreeOf_second_le xi d) + (cagePulledRadicandSecondCoordinate_degreeOf_second_le eta d)) + have hinside : MvPolynomial.degreeOf (1 : Fin 2) + (MvPolynomial.X 0 ^ 2 - + (cagePulledRadicandSecondCoordinate xi d + + cagePulledRadicandSecondCoordinate eta d)) ≤ 4 * d := by + refine (MvPolynomial.degreeOf_sub_le _ _ _).trans (max_le ?_ hsum) + rw [MvPolynomial.degreeOf_X_pow_of_ne 2 (by decide : (1 : Fin 2) ≠ 0)] + omega + refine (MvPolynomial.degreeOf_sub_le _ _ _).trans (max_le ?_ ?_) + · exact (MvPolynomial.degreeOf_pow_le _ _ _).trans + ((Nat.mul_le_mul_left 2 hinside).trans (by omega)) + · have hleft : MvPolynomial.degreeOf (1 : Fin 2) + (MvPolynomial.C 4 * cagePulledRadicandSecondCoordinate xi d) ≤ 4 * d := by + refine (MvPolynomial.degreeOf_mul_le _ _ _).trans ?_ + rw [MvPolynomial.degreeOf_C] + simpa using cagePulledRadicandSecondCoordinate_degreeOf_second_le xi d + refine (MvPolynomial.degreeOf_mul_le _ _ _).trans ?_ + exact (add_le_add hleft + (cagePulledRadicandSecondCoordinate_degreeOf_second_le eta d)).trans (by omega) + intro monomial hmonomial + exact ⟨(MvPolynomial.degreeOf_le_iff.mp hfirst) monomial hmonomial, + (MvPolynomial.degreeOf_le_iff.mp hsecond) monomial hmonomial⟩ + +/-- Evaluation of the embedded radicand is ordinary univariate evaluation +in the second coordinate. -/ +lemma eval_cagePulledRadicandSecondCoordinate + (xi : K) (d : ℕ) (root parameter : K) : + MvPolynomial.eval ![root, parameter] + (cagePulledRadicandSecondCoordinate xi d) = + (cagePulledRadicand xi d).eval parameter := by + rw [cagePulledRadicand_expanded] + simp [cagePulledRadicandSecondCoordinate] + +/-- Zeros of the diagonal plane model are exactly square roots of the +pulled radicand. -/ +lemma eval_cageDiagonalPlanePolynomial_eq_zero_iff + (xi : K) (d : ℕ) (root parameter : K) : + MvPolynomial.eval ![root, parameter] + (cageDiagonalPlanePolynomial xi d) = 0 ↔ + root ^ 2 = (cagePulledRadicand xi d).eval parameter := by + simp [cageDiagonalPlanePolynomial, + eval_cagePulledRadicandSecondCoordinate, sub_eq_zero] + +/-- Evaluation of the off-diagonal plane model is the primitive quartic in +the two scalar radicand values. -/ +lemma eval_cageOffDiagonalPlanePolynomial + (xi eta : K) (d : ℕ) (sumRoot parameter : K) : + MvPolynomial.eval ![sumRoot, parameter] + (cageOffDiagonalPlanePolynomial xi eta d) = + (sumRoot ^ 2 - + ((cagePulledRadicand xi d).eval parameter + + (cagePulledRadicand eta d).eval parameter)) ^ 2 - + 4 * (cagePulledRadicand xi d).eval parameter * + (cagePulledRadicand eta d).eval parameter := by + simp [cageOffDiagonalPlanePolynomial, + eval_cagePulledRadicandSecondCoordinate] + +/-- Away from the primitive-coordinate boundary `S = 0`, the quartic +equation is equivalent to retaining both quadratic roots. The explicit +inverse is +`L = (S² + f - g)/(2S)`, `M = (S² - f + g)/(2S)`. -/ +lemma primitiveQuarticEquation_iff_exists_rootPair + (h2 : (2 : K) ≠ 0) {f g sumRoot : K} (hsum : sumRoot ≠ 0) : + (sumRoot ^ 2 - (f + g)) ^ 2 - 4 * f * g = 0 ↔ + ∃ firstRoot secondRoot : K, + firstRoot ^ 2 = f ∧ secondRoot ^ 2 = g ∧ + firstRoot + secondRoot = sumRoot := by + constructor + · intro hequation + let firstRoot := (sumRoot ^ 2 + f - g) / (2 * sumRoot) + let secondRoot := (sumRoot ^ 2 - f + g) / (2 * sumRoot) + have hdenominator : 2 * sumRoot ≠ 0 := mul_ne_zero h2 hsum + refine ⟨firstRoot, secondRoot, ?_, ?_, ?_⟩ + · dsimp [firstRoot] + field_simp [hdenominator] + linear_combination hequation + · dsimp [secondRoot] + field_simp [hdenominator] + linear_combination hequation + · dsimp [firstRoot, secondRoot] + field_simp [hdenominator] + ring + · rintro ⟨firstRoot, secondRoot, hfirst, hsecond, hsumRoot⟩ + rw [← hfirst, ← hsecond, ← hsumRoot] + ring + +/-- The preceding primitive-element equivalence applied to the actual cage +plane equation. -/ +lemma eval_cageOffDiagonalPlanePolynomial_eq_zero_iff_exists_rootPair + (h2 : (2 : K) ≠ 0) (xi eta : K) (d : ℕ) + {sumRoot parameter : K} (hsum : sumRoot ≠ 0) : + MvPolynomial.eval ![sumRoot, parameter] + (cageOffDiagonalPlanePolynomial xi eta d) = 0 ↔ + ∃ firstRoot secondRoot : K, + firstRoot ^ 2 = (cagePulledRadicand xi d).eval parameter ∧ + secondRoot ^ 2 = (cagePulledRadicand eta d).eval parameter ∧ + firstRoot + secondRoot = sumRoot := by + rw [eval_cageOffDiagonalPlanePolynomial] + exact primitiveQuarticEquation_iff_exists_rootPair h2 hsum + +end + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Cage/PowerCover.lean b/LeanPool/MarkoffModP/BGS/Markoff/Cage/PowerCover.lean new file mode 100644 index 0000000000..766fc20a7c --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Cage/PowerCover.lean @@ -0,0 +1,279 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Cage.PlaneHasseWeil +public import LeanPool.MarkoffModP.BGS.Markoff.Cage.WitnessEquations + +/-! +# The one-sided power cover of the cage witness equations + +This file identifies the exact `d`-fold cover counted before passage to the +power-map range with the two pulled radicand equations. Both incidence roots +remain part of the data. +-/ + +@[expose] public section + +namespace BGS.Markoff + +noncomputable section + +variable {K : Type*} [Field K] + +/-- Clearing the denominator in one incidence equation gives exactly the +pulled radicand. -/ +lemma scaled_incidenceEquation_iff_pulledRadicand + (u xi root : K) (hu : u ≠ 0) (d : ℕ) : + (xi ^ 2 - 4) * (u ^ d + (u ^ d)⁻¹) ^ 2 - root ^ 2 = 4 * xi ^ 2 ↔ + (u ^ d * root) ^ 2 = (cagePulledRadicand xi d).eval u := by + rw [cagePulledRadicand] + simp only [Polynomial.eval_sub, Polynomial.eval_mul, Polynomial.eval_C, + Polynomial.eval_pow, Polynomial.eval_X, Polynomial.eval_add, + Polynomial.eval_one] + have hpow : u ^ (2 * d) = (u ^ d) ^ 2 := by + rw [Nat.mul_comm, pow_mul] + rw [hpow] + have hud : u ^ d ≠ 0 := pow_ne_zero d hu + have hclear : + (u ^ d) ^ 2 * + ((xi ^ 2 - 4) * (u ^ d + (u ^ d)⁻¹) ^ 2 - root ^ 2) = + (xi ^ 2 - 4) * ((u ^ d) ^ 2 + 1) ^ 2 - + (u ^ d) ^ 2 * root ^ 2 := by + field_simp [hud] + constructor + · intro h + have hscaled : + (xi ^ 2 - 4) * ((u ^ d) ^ 2 + 1) ^ 2 - + (u ^ d) ^ 2 * root ^ 2 = + (u ^ d) ^ 2 * (4 * xi ^ 2) := by + rw [← hclear, h] + calc + (u ^ d * root) ^ 2 = (u ^ d) ^ 2 * root ^ 2 := by ring + _ = (xi ^ 2 - 4) * ((u ^ d) ^ 2 + 1) ^ 2 - + 4 * xi ^ 2 * (u ^ d) ^ 2 := by + linear_combination -hscaled + · intro h + apply (mul_left_cancel₀ (pow_ne_zero 2 hud)) + calc + (u ^ d) ^ 2 * + ((xi ^ 2 - 4) * (u ^ d + (u ^ d)⁻¹) ^ 2 - root ^ 2) = + (xi ^ 2 - 4) * ((u ^ d) ^ 2 + 1) ^ 2 - + (u ^ d) ^ 2 * root ^ 2 := hclear + _ = (u ^ d) ^ 2 * (4 * xi ^ 2) := by + linear_combination -h + _ = (u ^ d) ^ 2 * (4 * xi ^ 2) := rfl + +/-- The exact pulled pair of quadratic roots over a nonzero power parameter. -/ +structure CagePulledRootPair + (p : ℕ) [Fact p.Prime] (xi eta : ZMod p) (d : ℕ) where + /-- The parameter before applying the `d`-th power map. -/ + parameter : (ZMod p)ˣ + /-- The first denominator-cleared incidence root. -/ + firstRoot : ZMod p + /-- The second denominator-cleared incidence root. -/ + secondRoot : ZMod p + /-- First pulled radicand equation. -/ + firstEquation : + firstRoot ^ 2 = (cagePulledRadicand xi d).eval (parameter : ZMod p) + /-- Second pulled radicand equation. -/ + secondEquation : + secondRoot ^ 2 = (cagePulledRadicand eta d).eval (parameter : ZMod p) + +@[ext] +lemma CagePulledRootPair.ext + {p : ℕ} [Fact p.Prime] {xi eta : ZMod p} {d : ℕ} + {x y : CagePulledRootPair p xi eta d} + (hparameter : x.parameter = y.parameter) + (hfirst : x.firstRoot = y.firstRoot) + (hsecond : x.secondRoot = y.secondRoot) : x = y := by + cases x + cases y + simp_all + +/-- The canonical witness-bearing one-sided cover. -/ +abbrev canonicalCagePowerCoverSolutions + (p : ℕ) [Fact p.Prime] (xi eta : ZMod p) (d : ℕ) := + BGS.rightPowerTraceCoverSolutions + (cageMiddleWitnessTrace (p := p) (axis := .first) (other := .second) + (xi := xi) (eta := eta)) + (splitTorusTrace : (ZMod p)ˣ → ZMod p) d + +/-- Scale the two retained incidence roots by the common denominator. -/ +def canonicalCagePowerCoverToPulled + (p : ℕ) [Fact p.Prime] (xi eta : ZMod p) (d : ℕ) : + canonicalCagePowerCoverSolutions p xi eta d → + CagePulledRootPair p xi eta d := fun z => by + let equations := canonicalCageWitnessToEquations p xi eta z.1.1 + let parameter := z.1.2 + have hmiddle : equations.middle = splitTorusTrace (parameter ^ d) := by + simpa [equations, parameter, canonicalCageWitnessToEquations, + cageMiddleWitnessTrace, normalizedCoordinateAt, cageBridgeAxis] using z.2 + refine + { parameter := parameter + firstRoot := (parameter : ZMod p) ^ d * equations.firstRoot + secondRoot := (parameter : ZMod p) ^ d * equations.secondRoot + firstEquation := ?_ + secondEquation := ?_ } + · apply (scaled_incidenceEquation_iff_pulledRadicand + (parameter : ZMod p) xi equations.firstRoot parameter.ne_zero d).mp + have htrace : + (parameter : ZMod p) ^ d + ((parameter : ZMod p) ^ d)⁻¹ = + splitTorusTrace (parameter ^ d) := by + simp [splitTorusTrace] + rw [htrace, ← hmiddle] + exact equations.firstEquation + · apply (scaled_incidenceEquation_iff_pulledRadicand + (parameter : ZMod p) eta equations.secondRoot parameter.ne_zero d).mp + have htrace : + (parameter : ZMod p) ^ d + ((parameter : ZMod p) ^ d)⁻¹ = + splitTorusTrace (parameter ^ d) := by + simp [splitTorusTrace] + rw [htrace, ← hmiddle] + exact equations.secondEquation + +/-- Recover the unscaled incidence roots and the two actual Markoff points. -/ +def canonicalCagePulledToPowerCover + (p : ℕ) [Fact p.Prime] (hpTwo : p ≠ 2) + (xi eta : ZMod p) (d : ℕ) : + CagePulledRootPair p xi eta d → + canonicalCagePowerCoverSolutions p xi eta d := fun z => by + let q : ZMod p := (z.parameter : ZMod p) ^ d + have hq : q ≠ 0 := pow_ne_zero d z.parameter.ne_zero + let equations : CageIncidenceEquationWitness p xi eta := + { middle := splitTorusTrace (z.parameter ^ d) + firstRoot := q⁻¹ * z.firstRoot + secondRoot := q⁻¹ * z.secondRoot + firstEquation := by + have h := (scaled_incidenceEquation_iff_pulledRadicand + (z.parameter : ZMod p) xi (q⁻¹ * z.firstRoot) + z.parameter.ne_zero d).mpr (by + simpa [q, hq] using z.firstEquation) + simpa [splitTorusTrace] using h + secondEquation := by + have h := (scaled_incidenceEquation_iff_pulledRadicand + (z.parameter : ZMod p) eta (q⁻¹ * z.secondRoot) + z.parameter.ne_zero d).mpr (by + simpa [q, hq] using z.secondEquation) + simpa [splitTorusTrace] using h } + let witness := canonicalCageEquationsToWitness p hpTwo xi eta equations + refine ⟨(witness, z.parameter), ?_⟩ + simp [witness, equations, canonicalCageEquationsToWitness, + cageMiddleWitnessTrace, normalizedCoordinateAt, cageBridgeAxis] + +@[simp] +lemma canonicalCageWitnessToEquations_equationsToWitness + (p : ℕ) [Fact p.Prime] (hpTwo : p ≠ 2) + (xi eta : ZMod p) (z : CageIncidenceEquationWitness p xi eta) : + canonicalCageWitnessToEquations p xi eta + (canonicalCageEquationsToWitness p hpTwo xi eta z) = z := by + exact (canonicalCageWitnessEquivIncidenceEquations + p hpTwo xi eta).apply_symm_apply z + +/-- The canonical one-sided cage power cover is exactly the pulled pair of +radicand equations. -/ +def canonicalCagePowerCoverEquivPulled + (p : ℕ) [Fact p.Prime] (hpTwo : p ≠ 2) + (xi eta : ZMod p) (d : ℕ) : + canonicalCagePowerCoverSolutions p xi eta d ≃ + CagePulledRootPair p xi eta d where + toFun := canonicalCagePowerCoverToPulled p xi eta d + invFun := canonicalCagePulledToPowerCover p hpTwo xi eta d + left_inv := by + intro z + have hTwo : (2 : ZMod p) ≠ 0 := by + exact two_ne_zero_zmod + (lt_of_le_of_ne (Fact.out : p.Prime).two_le (Ne.symm hpTwo)) + have hxiCoordinate : z.1.1.1.1.u1 = xi := by + simpa [normalizedFiberAt] using z.1.1.2.1.2 + have hetaCoordinate : z.1.1.1.2.u2 = eta := by + simpa [normalizedFiberAt] using z.1.1.2.2.1.2 + have hmiddleFirst : z.1.1.1.1.u3 = splitTorusTrace (z.1.2 ^ d) := by + simpa [cageMiddleWitnessTrace, normalizedCoordinateAt, + cageBridgeAxis] using z.2 + have hmiddleCommon : z.1.1.1.1.u3 = z.1.1.1.2.u3 := by + simpa [normalizedCoordinateAt, cageBridgeAxis] using z.1.1.2.2.2 + apply Subtype.ext + apply Prod.ext + · apply Subtype.ext + apply Prod.ext <;> apply NormalizedPoint.ext + · simpa [canonicalCagePowerCoverToPulled, + canonicalCagePulledToPowerCover, + canonicalCageWitnessToEquations, + canonicalCageEquationsToWitness] using hxiCoordinate.symm + · simp [canonicalCagePowerCoverToPulled, + canonicalCagePulledToPowerCover, + canonicalCageWitnessToEquations, + canonicalCageEquationsToWitness] + rw [← hmiddleFirst] + field_simp [hTwo] + ring + · simpa [canonicalCagePowerCoverToPulled, + canonicalCagePulledToPowerCover, + canonicalCageWitnessToEquations, + canonicalCageEquationsToWitness] using hmiddleFirst.symm + · simp [canonicalCagePowerCoverToPulled, + canonicalCagePulledToPowerCover, + canonicalCageWitnessToEquations, + canonicalCageEquationsToWitness] + rw [← hmiddleFirst] + field_simp [hTwo] + ring + · simpa [canonicalCagePowerCoverToPulled, + canonicalCagePulledToPowerCover, + canonicalCageWitnessToEquations, + canonicalCageEquationsToWitness] using hetaCoordinate.symm + · simpa [canonicalCagePowerCoverToPulled, + canonicalCagePulledToPowerCover, + canonicalCageWitnessToEquations, + canonicalCageEquationsToWitness] using + hmiddleFirst.symm.trans hmiddleCommon + · rfl + right_inv := by + intro z + apply CagePulledRootPair.ext + · rfl + · simp [canonicalCagePowerCoverToPulled, + canonicalCagePulledToPowerCover, + canonicalCageWitnessToEquations_equationsToWitness] + · simp [canonicalCagePowerCoverToPulled, + canonicalCagePulledToPowerCover, + canonicalCageWitnessToEquations_equationsToWitness] + +/-- Exact division of the pulled affine cover by the `d`-th power-map +fibers. -/ +theorem natCard_cagePulledRootPair_eq_mul_canonicalPowerRange + (p : ℕ) [Fact p.Prime] (hpTwo : p ≠ 2) + (xi eta : ZMod p) (d : ℕ) (hd : d ∣ p - 1) : + Nat.card (CagePulledRootPair p xi eta d) = + d * Nat.card (cageMiddleWitnessPowerRangeSolutions + p .first .second xi eta d) := by + have hcard : Nat.card (ZMod p)ˣ = p - 1 := by + rw [Nat.card_units, Nat.card_zmod] + have hdCard : d ∣ Nat.card (ZMod p)ˣ := by + rw [hcard] + exact hd + let : Finite (CageMiddleWitnessPair p .first .second xi eta) := + Finite.of_injective Subtype.val Subtype.val_injective + calc + Nat.card (CagePulledRootPair p xi eta d) = + Nat.card (canonicalCagePowerCoverSolutions p xi eta d) := + Nat.card_congr (canonicalCagePowerCoverEquivPulled + p hpTwo xi eta d).symm + _ = d * Nat.card (cageMiddleWitnessPowerRangeSolutions + p .first .second xi eta d) := by + simpa [canonicalCagePowerCoverSolutions, + cageMiddleWitnessPowerRangeSolutions] using + (BGS.natCard_rightPowerTraceCoverSolutions_of_dvd + (cageMiddleWitnessTrace + (p := p) (axis := .first) (other := .second) + (xi := xi) (eta := eta)) + (splitTorusTrace : (ZMod p)ˣ → ZMod p) d hdCard) + +end + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Cage/PulledRadicand.lean b/LeanPool/MarkoffModP/BGS/Markoff/Cage/PulledRadicand.lean new file mode 100644 index 0000000000..a59f17270a --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Cage/PulledRadicand.lean @@ -0,0 +1,270 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Cage.ShiftedTraceCurveIrreducibility +public import Mathlib.FieldTheory.IsAlgClosed.Basic + +/-! +# Pulled-back cage radicands + +After writing the common normalized trace as `t^d + t⁻ᵈ` and multiplying +an incidence root by `t^d`, the retained quadratic equation becomes + +`L² = (ξ² - 4) (t^(2d) + 1)² - 4 ξ² t^(2d)`. + +This file proves the square-class facts needed for the direct affine-plane +Hasse--Weil model. In particular, the off-diagonal argument is not hidden +behind a geometric-integrality assumption: the two pulled radicands are +proved squarefree and coprime explicitly. +-/ + +@[expose] public section + +namespace BGS.Markoff + +open Polynomial + +noncomputable section + +variable {K : Type*} [Field K] + +/-- The radicand obtained after pulling an incidence conic back along the +power-trace parameter `t ↦ t^d + t⁻ᵈ` and clearing `t⁻ᵈ`. -/ +def cagePulledRadicand (xi : K) (d : ℕ) : K[X] := + C (xi ^ 2 - 4) * (X ^ (2 * d) + 1) ^ 2 - + C (4 * xi ^ 2) * X ^ (2 * d) + +@[simp] +lemma cagePulledRadicand_eval_zero (xi : K) {d : ℕ} (hd : 0 < d) : + (cagePulledRadicand xi d).eval 0 = xi ^ 2 - 4 := by + simp [cagePulledRadicand, Nat.ne_of_gt hd] + +@[simp] +lemma cagePulledRadicand_eval_one (xi : K) (d : ℕ) : + (cagePulledRadicand xi d).eval 1 = -16 := by + simp [cagePulledRadicand] + ring + +/-- Distinct squared cage traces give radicands whose difference is a +nonzero scalar times `(t^(2d) - 1)²`. -/ +lemma cagePulledRadicand_sub (xi eta : K) (d : ℕ) : + cagePulledRadicand xi d - cagePulledRadicand eta d = + C (xi ^ 2 - eta ^ 2) * (X ^ (2 * d) - 1) ^ 2 := by + simp only [cagePulledRadicand, map_sub, map_pow, map_ofNat, map_mul] + ring + +/-- Formal derivative of the pulled radicand. -/ +lemma cagePulledRadicand_derivative (xi : K) (d : ℕ) : + (cagePulledRadicand xi d).derivative = + C (((2 * d : ℕ) : K)) * X ^ (2 * d - 1) * + (2 * C (xi ^ 2 - 4) * (X ^ (2 * d) + 1) - + C (4 * xi ^ 2)) := by + simp only [cagePulledRadicand, + derivative_sub, derivative_mul, derivative_C, zero_mul, zero_add, + derivative_add, derivative_one, add_zero, derivative_pow, derivative_X, + mul_one] + simp only [map_sub, map_pow, map_natCast, map_mul] + ring + +/-- The pulled radicand has no repeated geometric root under the exact +nondegeneracy assumptions used in the cage. -/ +lemma cagePulledRadicand_separable + (h2 : (2 : K) ≠ 0) {xi : K} (hxi : xi ≠ 0) + (hparabolic : xi ^ 2 - 4 ≠ 0) {d : ℕ} (hd : 0 < d) + (hdegree : (((2 * d : ℕ) : K)) ≠ 0) : + (cagePulledRadicand xi d).Separable := by + rw [separable_def] + apply (Polynomial.isCoprime_iff_aeval_ne_zero_of_isAlgClosed + (k := K) (AlgebraicClosure K) (cagePulledRadicand xi d) + (cagePulledRadicand xi d).derivative).2 + intro t + let phi : K →+* AlgebraicClosure K := algebraMap K (AlgebraicClosure K) + by_contra hcommon + push Not at hcommon + rcases hcommon with ⟨hroot, hderivative⟩ + have hphiTwo : phi 2 ≠ 0 := (map_ne_zero_iff phi phi.injective).mpr h2 + have hphiXi : phi xi ≠ 0 := (map_ne_zero_iff phi phi.injective).mpr hxi + have hphiA : phi (xi ^ 2 - 4) ≠ 0 := + (map_ne_zero_iff phi phi.injective).mpr hparabolic + have hphiDegree : phi (((2 * d : ℕ) : K)) ≠ 0 := + (map_ne_zero_iff phi phi.injective).mpr hdegree + have ht : t ≠ 0 := by + intro ht + subst t + apply hphiA + simpa [cagePulledRadicand, phi, Nat.ne_of_gt hd] using hroot + have hcritical : + 2 * phi (xi ^ 2 - 4) * (t ^ (2 * d) + 1) - + phi (4 * xi ^ 2) = 0 := by + rw [cagePulledRadicand_derivative] at hderivative + have hderivative' : + phi (((2 * d : ℕ) : K)) * t ^ (2 * d - 1) * + (2 * phi (xi ^ 2 - 4) * (t ^ (2 * d) + 1) - + phi (4 * xi ^ 2)) = 0 := by + simpa only [aeval_def, eval₂_mul, eval₂_C, eval₂_pow, eval₂_X, + eval₂_sub, eval₂_add, eval₂_one, eval₂_ofNat] using hderivative + exact (mul_eq_zero.mp hderivative').resolve_left + (mul_ne_zero hphiDegree (pow_ne_zero _ ht)) + have hroot' : + phi (xi ^ 2 - 4) * (t ^ (2 * d) + 1) ^ 2 - + phi (4 * xi ^ 2) * t ^ (2 * d) = 0 := by + simpa only [cagePulledRadicand, aeval_def, eval₂_mul, eval₂_C, + eval₂_pow, eval₂_X, eval₂_sub, eval₂_add, eval₂_one] using hroot + have hone : t ^ (2 * d) = 1 := by + have hnonzero : phi (4 * xi ^ 2) ≠ 0 := by + apply (map_ne_zero_iff phi phi.injective).mpr + have h4 : (4 : K) ≠ 0 := by + rw [show (4 : K) = 2 ^ 2 by norm_num] + exact pow_ne_zero 2 h2 + exact mul_ne_zero h4 (pow_ne_zero 2 hxi) + have hproduct : + phi (4 * xi ^ 2) * (1 - t ^ (2 * d)) = 0 := by + linear_combination 2 * hroot' - (t ^ (2 * d) + 1) * hcritical + exact (sub_eq_zero.mp ((mul_eq_zero.mp hproduct).resolve_left hnonzero)).symm + have : phi (16 : K) = 0 := by + apply neg_eq_zero.mp + calc + -phi (16 : K) = + 2 * phi (xi ^ 2 - 4) * (1 + 1) - phi (4 * xi ^ 2) := by + simp only [map_sub, map_pow, map_ofNat, map_mul] + ring + _ = 0 := by simpa [hone] using hcritical + have h16 : (16 : K) ≠ 0 := by + rw [show (16 : K) = 2 ^ 4 by norm_num] + exact pow_ne_zero 4 h2 + exact (map_ne_zero_iff phi phi.injective).mpr h16 this + +/-- Expanded form, used to read off the leading coefficient and degree. -/ +lemma cagePulledRadicand_expanded (xi : K) (d : ℕ) : + cagePulledRadicand xi d = + C (xi ^ 2 - 4) * X ^ (4 * d) - + C (2 * (xi ^ 2 + 4)) * X ^ (2 * d) + C (xi ^ 2 - 4) := by + have hC2 : (C (2 : K) : K[X]) = 2 := + map_natCast (Polynomial.C : K →+* K[X]) 2 + have hC4 : (C (4 : K) : K[X]) = 4 := + map_natCast (Polynomial.C : K →+* K[X]) 4 + simp only [cagePulledRadicand, map_sub, map_pow, map_mul, map_add] + rw [hC2, hC4] + ring_nf + +/-- The coefficient of `t^(4d)` is the nonparabolic factor `xi² - 4`. -/ +lemma cagePulledRadicand_coeff_four_mul + (xi : K) {d : ℕ} (hd : 0 < d) : + (cagePulledRadicand xi d).coeff (4 * d) = xi ^ 2 - 4 := by + rw [cagePulledRadicand_expanded] + rw [coeff_add, coeff_sub, coeff_C_mul_X_pow, + coeff_C_mul_X_pow, coeff_C] + simp only [ite_true, ite_eq_right (show 4 * d ≠ 2 * d by omega), + ite_eq_right (show 4 * d ≠ 0 by omega), sub_zero, add_zero] + +/-- A nonparabolic pulled radicand is not a polynomial unit. -/ +lemma cagePulledRadicand_not_isUnit + {xi : K} (hparabolic : xi ^ 2 - 4 ≠ 0) {d : ℕ} (hd : 0 < d) : + ¬ IsUnit (cagePulledRadicand xi d) := by + apply not_isUnit_of_natDegree_pos + have hcoeff : (cagePulledRadicand xi d).coeff (4 * d) ≠ 0 := by + simpa [cagePulledRadicand_coeff_four_mul xi hd] using hparabolic + have hle := Polynomial.le_natDegree_of_ne_zero hcoeff + omega + +/-- Off the diagonal, the two pulled radicands have disjoint geometric +zero sets. The displayed difference reduces a hypothetical common zero to +`t^(2d)=1`, where every radicand takes the value `-16`. -/ +lemma cagePulledRadicand_isCoprime + (h2 : (2 : K) ≠ 0) {xi eta : K} (hoffDiagonal : xi ^ 2 ≠ eta ^ 2) + (d : ℕ) : + IsCoprime (cagePulledRadicand xi d) (cagePulledRadicand eta d) := by + apply (Polynomial.isCoprime_iff_aeval_ne_zero_of_isAlgClosed + (k := K) (AlgebraicClosure K) (cagePulledRadicand xi d) + (cagePulledRadicand eta d)).2 + intro t + let phi : K →+* AlgebraicClosure K := algebraMap K (AlgebraicClosure K) + by_contra hcommon + push Not at hcommon + rcases hcommon with ⟨hxiRoot, hetaRoot⟩ + have hdifference := congrArg (fun f : K[X] => aeval t f) + (cagePulledRadicand_sub xi eta d) + have hproduct : + phi (xi ^ 2 - eta ^ 2) * (t ^ (2 * d) - 1) ^ 2 = 0 := by + simpa only [map_sub, aeval_def, eval₂_sub, eval₂_mul, eval₂_C, + eval₂_pow, eval₂_X, eval₂_one, hxiRoot, hetaRoot, zero_sub, neg_zero] + using hdifference.symm + have hscalar : phi (xi ^ 2 - eta ^ 2) ≠ 0 := + (map_ne_zero_iff phi phi.injective).mpr (sub_ne_zero.mpr hoffDiagonal) + have hpower : t ^ (2 * d) = 1 := by + have hsquare : (t ^ (2 * d) - 1) ^ 2 = 0 := + (mul_eq_zero.mp hproduct).resolve_left hscalar + have hbase : t ^ (2 * d) - 1 = 0 := by + apply (mul_self_eq_zero.mp) + simpa [pow_two] using hsquare + exact sub_eq_zero.mp hbase + have hminusSixteen : phi (-16 : K) = 0 := by + calc + phi (-16 : K) = + phi (xi ^ 2 - 4) * (t ^ (2 * d) + 1) ^ 2 - + phi (4 * xi ^ 2) * t ^ (2 * d) := by + have hfour : ((1 : AlgebraicClosure K) + 1) ^ 2 = phi (4 : K) := by + calc + ((1 : AlgebraicClosure K) + 1) ^ 2 = 4 := by norm_num + _ = phi (4 : K) := (map_natCast phi 4).symm + rw [hpower, hfour, mul_one] + rw [← map_mul, ← map_sub] + congr 1 + ring + _ = aeval t (cagePulledRadicand xi d) := by + simp only [phi, cagePulledRadicand, aeval_def, eval₂_sub, eval₂_mul, + eval₂_C, eval₂_pow, eval₂_X, eval₂_add, eval₂_one] + _ = 0 := hxiRoot + have h16 : (16 : K) ≠ 0 := by + rw [show (16 : K) = 2 ^ 4 by norm_num] + exact pow_ne_zero 4 h2 + exact (map_ne_zero_iff phi phi.injective).mpr (neg_ne_zero.mpr h16) hminusSixteen + +/-- The two off-diagonal radicands and their product are squarefree. -/ +lemma cagePulledRadicand_squarefree_and_product + (h2 : (2 : K) ≠ 0) {xi eta : K} + (hxi : xi ≠ 0) (heta : eta ≠ 0) + (hXi : xi ^ 2 - 4 ≠ 0) (hEta : eta ^ 2 - 4 ≠ 0) + (hoffDiagonal : xi ^ 2 ≠ eta ^ 2) {d : ℕ} (hd : 0 < d) + (hdegree : (((2 * d : ℕ) : K)) ≠ 0) : + Squarefree (cagePulledRadicand xi d) ∧ + Squarefree (cagePulledRadicand eta d) ∧ + Squarefree (cagePulledRadicand xi d * cagePulledRadicand eta d) := by + have hsepXi := cagePulledRadicand_separable h2 hxi hXi hd hdegree + have hsepEta := cagePulledRadicand_separable h2 heta hEta hd hdegree + have hcoprime := cagePulledRadicand_isCoprime h2 hoffDiagonal d + exact ⟨hsepXi.squarefree, hsepEta.squarefree, + (hsepXi.mul hsepEta hcoprime).squarefree⟩ + +/-- The pulled radicands define two independent quadratic square classes in +the rational function field. This is the algebraic content of the paper's +disjoint-branch argument. -/ +lemma cagePulledRadicand_squareClasses_independent_ratFunc + (h2 : (2 : K) ≠ 0) {xi eta : K} + (hxi : xi ≠ 0) (heta : eta ≠ 0) + (hXi : xi ^ 2 - 4 ≠ 0) (hEta : eta ^ 2 - 4 ≠ 0) + (hoffDiagonal : xi ^ 2 ≠ eta ^ 2) {d : ℕ} (hd : 0 < d) + (hdegree : (((2 * d : ℕ) : K)) ≠ 0) : + ¬ IsSquare (algebraMap K[X] (RatFunc K) (cagePulledRadicand xi d)) ∧ + ¬ IsSquare (algebraMap K[X] (RatFunc K) (cagePulledRadicand eta d)) ∧ + ¬ IsSquare (algebraMap K[X] (RatFunc K) + (cagePulledRadicand xi d * cagePulledRadicand eta d)) := by + obtain ⟨hsqXi, hsqEta, hsqProduct⟩ := + cagePulledRadicand_squarefree_and_product h2 hxi heta hXi hEta + hoffDiagonal hd hdegree + exact ⟨not_isSquare_algebraMap_of_squarefree_not_isUnit hsqXi + (cagePulledRadicand_not_isUnit hXi hd), + not_isSquare_algebraMap_of_squarefree_not_isUnit hsqEta + (cagePulledRadicand_not_isUnit hEta hd), + not_isSquare_algebraMap_of_squarefree_not_isUnit hsqProduct (by + intro hunit + exact cagePulledRadicand_not_isUnit hXi hd (IsUnit.mul_iff.mp hunit).1)⟩ + +end + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Cage/ShiftedTraceCurveIrreducibility.lean b/LeanPool/MarkoffModP/BGS/Markoff/Cage/ShiftedTraceCurveIrreducibility.lean new file mode 100644 index 0000000000..526193b8c7 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Cage/ShiftedTraceCurveIrreducibility.lean @@ -0,0 +1,340 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import Mathlib.Algebra.Polynomial.SpecificDegree +public import LeanPool.MarkoffModP.BGS.Markoff.Cage.IncidenceGeometry + +/-! +# The shifted cage trace cover + +The off-diagonal cage base is the biquadratic incidence function field in the +common original coordinate `y`. The next cover adjoins a root `R` of + +`R^2 - (3y) * R + 1`. + +This file proves the genuinely new branch calculation: the discriminant +`9y^2 - 4` is independent of both incidence square classes, remains a +nonsquare after the two quadratic adjunctions, and hence makes the trace +quadratic irreducible over the exact incidence function-field presentation. + +It deliberately does not claim that `R` is not a `q`-th power. That +place-at-infinity statement is the remaining Kummer obstruction for the +full shifted Laurent cover. +-/ + +@[expose] public section + +namespace BGS.Markoff + +open Polynomial + +noncomputable section + +variable {K : Type*} [Field K] + +/-- The discriminant `9y² - 4` of the normalized trace quadratic. -/ +def cageTraceBranchPolynomial : K[X] := + C 9 * X ^ 2 - C 4 + +/-- The quadratic whose root is a unit with prescribed trace. -/ +def traceRootPolynomial {R : Type*} [CommRing R] (trace : R) : R[X] := + X ^ 2 - C trace * X + 1 + +/-- The prescribed-trace quadratic is monic. -/ +lemma traceRootPolynomial_monic {R : Type*} [Nontrivial R] [CommRing R] (trace : R) : + (traceRootPolynomial trace).Monic := by + simpa [traceRootPolynomial] using isMonicOfDegree_sub_add_two trace (1 : R) |>.monic + +/-- The prescribed-trace quadratic has degree two. -/ +@[simp] +lemma traceRootPolynomial_natDegree {R : Type*} [Nontrivial R] [CommRing R] (trace : R) : + (traceRootPolynomial trace).natDegree = 2 := by + simpa [traceRootPolynomial] using + isMonicOfDegree_sub_add_two trace (1 : R) |>.natDegree_eq + +/-- A prescribed-trace quadratic over a domain is irreducible when its +discriminant is not a square. -/ +lemma traceRootPolynomial_irreducible_of_discriminant_not_isSquare + {R : Type*} [CommRing R] [IsDomain R] + (trace : R) (hdisc : ¬ IsSquare (trace ^ 2 - 4)) : + Irreducible (traceRootPolynomial trace) := by + rw [(traceRootPolynomial_monic trace).irreducible_iff_roots_eq_zero_of_degree_le_three] + · apply Multiset.eq_zero_of_forall_notMem + intro root hroot + have heval := (mem_roots (traceRootPolynomial_monic trace).ne_zero).mp hroot + have heq : root ^ 2 - trace * root + 1 = 0 := by + simpa [traceRootPolynomial] using heval + apply hdisc + refine ⟨2 * root - trace, ?_⟩ + calc + trace ^ 2 - 4 = + (2 * root - trace) * (2 * root - trace) - + 4 * (root ^ 2 - trace * root + 1) := by ring + _ = (2 * root - trace) * (2 * root - trace) := by rw [heq]; ring + · simp + · simp + +/-- The trace discriminant polynomial has degree two outside characteristic three. -/ +lemma cageTraceBranchPolynomial_natDegree (h3 : (3 : K) ≠ 0) : + (cageTraceBranchPolynomial : K[X]).natDegree = 2 := by + rw [cageTraceBranchPolynomial, natDegree_sub_C, + natDegree_C_mul_X_pow 2 (9 : K)] + exact by + convert mul_ne_zero h3 h3 using 1 + norm_num + +/-- The trace discriminant polynomial is not a unit. -/ +lemma cageTraceBranchPolynomial_not_isUnit (h3 : (3 : K) ≠ 0) : + ¬ IsUnit (cageTraceBranchPolynomial : K[X]) := + not_isUnit_of_natDegree_pos _ <| by + rw [cageTraceBranchPolynomial_natDegree h3] + norm_num + +/-- The two trace branch points are distinct outside characteristics two and three. -/ +lemma cageTraceBranchPolynomial_separable + (h2 : (2 : K) ≠ 0) (h3 : (3 : K) ≠ 0) : + (cageTraceBranchPolynomial : K[X]).Separable := by + have h4 : (4 : K) ≠ 0 := by + convert mul_ne_zero h2 h2 using 1 + norm_num + have h9 : (9 : K) ≠ 0 := by + convert mul_ne_zero h3 h3 using 1 + norm_num + have hquot : (4 / 9 : K) ≠ 0 := div_ne_zero h4 h9 + have hsep : (X ^ 2 - C (4 / 9) : K[X]).Separable := + separable_X_pow_sub_C _ h2 hquot + have hunit : IsUnit (C (9 : K) : K[X]) := + isUnit_C.mpr (isUnit_iff_ne_zero.mpr h9) + have heq : (cageTraceBranchPolynomial : K[X]) = + C (9 : K) * (X ^ 2 - C (4 / 9)) := by + simp only [cageTraceBranchPolynomial, mul_sub] + rw [← C_mul, mul_div_cancel₀ (4 : K) h9] + rw [heq] + exact hsep.unit_mul hunit + +/-- An explicit constant Bezout combination of an incidence branch polynomial +and the trace discriminant polynomial. -/ +lemma incidenceBranchPolynomial_cageTrace_linearCombination (a : K) : + C (9 * a ^ 2 - 4) * cageTraceBranchPolynomial - + C 9 * incidenceBranchPolynomial a = C 16 := by + simp only [cageTraceBranchPolynomial, incidenceBranchPolynomial] + ring_nf + rw [← C_mul, ← C_neg, ← C_mul, ← C_add] + congr 1 + ring + +/-- Every nondegenerate incidence branch polynomial is coprime to the trace +discriminant polynomial; the Bezout constant is `16`. -/ +lemma incidenceBranchPolynomial_isCoprime_cageTrace + (h2 : (2 : K) ≠ 0) (a : K) : + IsCoprime (incidenceBranchPolynomial a) cageTraceBranchPolynomial := by + have h16 : (16 : K) ≠ 0 := by + rw [show (16 : K) = 2 ^ 4 by norm_num] + exact pow_ne_zero 4 h2 + refine ⟨-(C (16 : K)⁻¹ * C 9), + C (16 : K)⁻¹ * C (9 * a ^ 2 - 4), ?_⟩ + calc + -(C (16 : K)⁻¹ * C 9) * incidenceBranchPolynomial a + + (C (16 : K)⁻¹ * C (9 * a ^ 2 - 4)) * cageTraceBranchPolynomial = + C (16 : K)⁻¹ * + (C (9 * a ^ 2 - 4) * cageTraceBranchPolynomial - + C 9 * incidenceBranchPolynomial a) := by ring + _ = C (16 : K)⁻¹ * C 16 := by + rw [incidenceBranchPolynomial_cageTrace_linearCombination] + _ = 1 := by rw [← C_mul, inv_mul_cancel₀ h16, map_one] + +/-- The trace discriminant and its products with either incidence branch +class are all nonsquares in the rational function field. -/ +lemma cageTraceBranchSquareClasses_independent_ratFunc + (h2 : (2 : K) ≠ 0) (h3 : (3 : K) ≠ 0) {a b : K} + (ha : a ≠ 0) (hb : b ≠ 0) + (hA : 9 * a ^ 2 - 4 ≠ 0) (hB : 9 * b ^ 2 - 4 ≠ 0) + (hab : a ^ 2 ≠ b ^ 2) : + ¬ IsSquare (algebraMap K[X] (RatFunc K) cageTraceBranchPolynomial) ∧ + ¬ IsSquare (algebraMap K[X] (RatFunc K) + (incidenceBranchPolynomial a * cageTraceBranchPolynomial)) ∧ + ¬ IsSquare (algebraMap K[X] (RatFunc K) + (incidenceBranchPolynomial b * cageTraceBranchPolynomial)) ∧ + ¬ IsSquare (algebraMap K[X] (RatFunc K) + (incidenceBranchPolynomial a * incidenceBranchPolynomial b * + cageTraceBranchPolynomial)) := by + have hsepA := incidenceBranchPolynomial_separable h2 ha hA + have hsepB := incidenceBranchPolynomial_separable h2 hb hB + have hsepTrace := cageTraceBranchPolynomial_separable h2 h3 + have hcopAB := incidenceBranchPolynomial_isCoprime h2 hab + have hcopATrace := incidenceBranchPolynomial_isCoprime_cageTrace h2 a + have hcopBTrace := incidenceBranchPolynomial_isCoprime_cageTrace h2 b + have hcopABTrace : IsCoprime + (incidenceBranchPolynomial a * incidenceBranchPolynomial b) + (cageTraceBranchPolynomial : K[X]) := + hcopATrace.mul_left hcopBTrace + have hsqTrace := hsepTrace.squarefree + have hsqATrace := (hsepA.mul hsepTrace hcopATrace).squarefree + have hsqBTrace := (hsepB.mul hsepTrace hcopBTrace).squarefree + have hsqABTrace := + ((hsepA.mul hsepB hcopAB).mul hsepTrace hcopABTrace).squarefree + refine ⟨not_isSquare_algebraMap_of_squarefree_not_isUnit hsqTrace + (cageTraceBranchPolynomial_not_isUnit h3), + not_isSquare_algebraMap_of_squarefree_not_isUnit hsqATrace ?_, + not_isSquare_algebraMap_of_squarefree_not_isUnit hsqBTrace ?_, + not_isSquare_algebraMap_of_squarefree_not_isUnit hsqABTrace ?_⟩ + · intro hunit + exact incidenceBranchPolynomial_not_isUnit hA (IsUnit.mul_iff.mp hunit).1 + · intro hunit + exact incidenceBranchPolynomial_not_isUnit hB (IsUnit.mul_iff.mp hunit).1 + · intro hunit + exact incidenceBranchPolynomial_not_isUnit hA + (IsUnit.mul_iff.mp (IsUnit.mul_iff.mp hunit).1).1 + +/-- The discriminant of the trace quadratic remains nonsquare after adjoining +both incidence square roots. -/ +theorem incidenceBiquadraticTraceBranch_not_isSquare + (h2 : (2 : K) ≠ 0) (h3 : (3 : K) ≠ 0) {a b : K} + (ha : a ≠ 0) (hb : b ≠ 0) + (hA : 9 * a ^ 2 - 4 ≠ 0) (hB : 9 * b ^ 2 - 4 ≠ 0) + (hab : a ^ 2 ≠ b ^ 2) : + ¬ IsSquare + (algebraMap (IncidenceFirstQuadraticRatFuncRing K a) + (IncidenceBiquadraticRatFuncRing K a b) + (algebraMap (RatFunc K) (IncidenceFirstQuadraticRatFuncRing K a) + (algebraMap K[X] (RatFunc K) cageTraceBranchPolynomial))) := by + let fA : RatFunc K := + algebraMap K[X] (RatFunc K) (incidenceBranchPolynomial a) + let fB : RatFunc K := + algebraMap K[X] (RatFunc K) (incidenceBranchPolynomial b) + let traceBranch : RatFunc K := + algebraMap K[X] (RatFunc K) cageTraceBranchPolynomial + obtain ⟨hfA, hfB, hfAB⟩ := + incidenceBranchSquareClasses_independent_ratFunc h2 ha hb hA hB hab + obtain ⟨hTrace, hATrace, hBTrace, hABTrace⟩ := + cageTraceBranchSquareClasses_independent_ratFunc h2 h3 ha hb hA hB hab + have h2RatFunc : (2 : RatFunc K) ≠ 0 := by + intro hzero + apply h2 + apply FaithfulSMul.algebraMap_injective K (RatFunc K) + simpa only [map_ofNat, map_zero] using hzero + let : Fact + (Irreducible + (adjoinSquarePolynomial + (algebraMap K[X] (RatFunc K) (incidenceBranchPolynomial a)))) := + ⟨adjoinSquarePolynomial_irreducible_of_not_isSquare hfA⟩ + let firstField := IncidenceFirstQuadraticRatFuncRing K a + let secondField := IncidenceBiquadraticRatFuncRing K a b + let fBFirst : firstField := + incidenceFirstQuadraticToRatFunc K a + (algebraMap K[X] (IncidenceFirstQuadraticRing K a) + (incidenceBranchPolynomial b)) + let traceFirst : firstField := algebraMap (RatFunc K) firstField traceBranch + have h2First : (2 : firstField) ≠ 0 := by + intro hzero + apply h2RatFunc + apply (algebraMap (RatFunc K) firstField).injective + simpa only [map_ofNat, map_zero] using hzero + have hfBFirst : ¬ IsSquare fBFirst := by + change ¬ IsSquare + (incidenceFirstQuadraticToRatFunc K a + (algebraMap K[X] (IncidenceFirstQuadraticRing K a) + (incidenceBranchPolynomial b))) + rw [incidenceFirstQuadraticToRatFunc_algebraMap] + apply not_isSquare_algebraMap_adjoinSquare_of_independent h2RatFunc hfA hfB + simpa only [map_mul] using hfAB + have hTraceFirst : ¬ IsSquare traceFirst := by + apply not_isSquare_algebraMap_adjoinSquare_of_independent h2RatFunc hfA hTrace + simpa only [map_mul] using hATrace + have hBTraceFirst : ¬ IsSquare (fBFirst * traceFirst) := by + have hMapped : ¬ IsSquare + (algebraMap (RatFunc K) firstField (fB * traceBranch)) := by + apply not_isSquare_algebraMap_adjoinSquare_of_independent h2RatFunc hfA + · simpa only [fB, traceBranch, map_mul] using hBTrace + · simpa only [fA, fB, traceBranch, map_mul, mul_assoc] using hABTrace + rw [show fBFirst = algebraMap (RatFunc K) firstField fB by + simp [fBFirst, fB, firstField, + incidenceFirstQuadraticToRatFunc_algebraMap]] + simpa only [traceFirst, map_mul] using hMapped + change ¬ IsSquare (algebraMap firstField secondField traceFirst) + exact not_isSquare_algebraMap_adjoinSquare_of_independent + h2First hfBFirst hTraceFirst hBTraceFirst + +/-- The normalized common coordinate `3y` inside the biquadratic incidence +function field. -/ +def incidenceBiquadraticNormalizedTrace (a b : K) : + IncidenceBiquadraticRatFuncRing K a b := + algebraMap (IncidenceFirstQuadraticRatFuncRing K a) + (IncidenceBiquadraticRatFuncRing K a b) + (algebraMap (RatFunc K) (IncidenceFirstQuadraticRatFuncRing K a) + (RatFunc.C 3 * RatFunc.X)) + +/-- The discriminant of the normalized trace inside the biquadratic field is +the image of `9y² - 4`. -/ +lemma incidenceBiquadraticNormalizedTrace_discriminant (a b : K) : + incidenceBiquadraticNormalizedTrace a b ^ 2 - 4 = + algebraMap (IncidenceFirstQuadraticRatFuncRing K a) + (IncidenceBiquadraticRatFuncRing K a b) + (algebraMap (RatFunc K) (IncidenceFirstQuadraticRatFuncRing K a) + (algebraMap K[X] (RatFunc K) cageTraceBranchPolynomial)) := by + simp only [incidenceBiquadraticNormalizedTrace, cageTraceBranchPolynomial, + map_sub, map_mul, map_pow, map_ofNat, RatFunc.algebraMap_X] + ring + +/-- The normalized trace discriminant remains nonsquare in the complete +biquadratic incidence function field. -/ +theorem incidenceBiquadraticNormalizedTrace_discriminant_not_isSquare + (h2 : (2 : K) ≠ 0) (h3 : (3 : K) ≠ 0) {a b : K} + (ha : a ≠ 0) (hb : b ≠ 0) + (hA : 9 * a ^ 2 - 4 ≠ 0) (hB : 9 * b ^ 2 - 4 ≠ 0) + (hab : a ^ 2 ≠ b ^ 2) : + ¬ IsSquare (incidenceBiquadraticNormalizedTrace a b ^ 2 - 4) := by + rw [incidenceBiquadraticNormalizedTrace_discriminant] + exact incidenceBiquadraticTraceBranch_not_isSquare h2 h3 ha hb hA hB hab + +/-- The trace quadratic over the exact incidence biquadratic field +presentation. -/ +def incidenceBiquadraticTraceRootPolynomial (a b : K) : + Polynomial (IncidenceBiquadraticRatFuncRing K a b) := + X ^ 2 - C (incidenceBiquadraticNormalizedTrace a b) * X + 1 + +/-- The trace quadratic is irreducible over the off-diagonal incidence +biquadratic function field. -/ +theorem incidenceBiquadraticTraceRootPolynomial_irreducible + (h2 : (2 : K) ≠ 0) (h3 : (3 : K) ≠ 0) {a b : K} + (ha : a ≠ 0) (hb : b ≠ 0) + (hA : 9 * a ^ 2 - 4 ≠ 0) (hB : 9 * b ^ 2 - 4 ≠ 0) + (hab : a ^ 2 ≠ b ^ 2) : + Irreducible (incidenceBiquadraticTraceRootPolynomial a b) := by + let : IsDomain (IncidenceBiquadraticRatFuncRing K a b) := + incidenceBiquadraticRatFuncRing_isDomain K h2 ha hb hA hB hab + change Irreducible (traceRootPolynomial (incidenceBiquadraticNormalizedTrace a b)) + apply traceRootPolynomial_irreducible_of_discriminant_not_isSquare + exact incidenceBiquadraticNormalizedTrace_discriminant_not_isSquare + h2 h3 ha hb hA hB hab + +/-- The quadratic trace extension of the cage incidence function field. -/ +abbrev IncidenceTraceFunctionField (K : Type*) [Field K] (a b : K) := + AdjoinRoot (incidenceBiquadraticTraceRootPolynomial a b) + +/-- The canonical unit-trace root in the quadratic trace extension. -/ +def incidenceTraceRoot (a b : K) : IncidenceTraceFunctionField K a b := + AdjoinRoot.root (incidenceBiquadraticTraceRootPolynomial a b) + +/-- The canonical trace root satisfies `R² - (3y)R + 1 = 0`. -/ +lemma incidenceTraceRoot_quadratic_relation (a b : K) : + incidenceTraceRoot a b ^ 2 - + algebraMap (IncidenceBiquadraticRatFuncRing K a b) + (IncidenceTraceFunctionField K a b) + (incidenceBiquadraticNormalizedTrace a b) * incidenceTraceRoot a b + 1 = 0 := by + have h := AdjoinRoot.eval₂_root (incidenceBiquadraticTraceRootPolynomial a b) + rw [incidenceBiquadraticTraceRootPolynomial] at h + simp only [Polynomial.eval₂_add, Polynomial.eval₂_sub, Polynomial.eval₂_pow, + Polynomial.eval₂_X, Polynomial.eval₂_mul, Polynomial.eval₂_C, + Polynomial.eval₂_one] at h + rw [← AdjoinRoot.algebraMap_eq] at h + exact h + +end + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Cage/SmallPrime.lean b/LeanPool/MarkoffModP/BGS/Markoff/Cage/SmallPrime.lean new file mode 100644 index 0000000000..89bd451550 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Cage/SmallPrime.lean @@ -0,0 +1,111 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Cage.PowerCover + +/-! +# The small prime in the cage estimate + +The geometric cage proof starts at `p = 7`. The target interface also asks +for `p = 5`; this file handles that one finite field by a transparent ambient +cardinality bound, not by applying an inapplicable irreducibility statement. +-/ + +@[expose] public section + +namespace BGS.Markoff + +noncomputable section + +local instance cageSmallPrime_factPrimeFive : Fact (Nat.Prime 5) := ⟨by norm_num⟩ + +private def cageRangeCoordinatesAtFive + (axis other : NormalizedCoordinateAxis) (xi eta : ZMod 5) (d : ℕ) : + cageMiddleWitnessPowerRangeSolutions 5 axis other xi eta d → + Fin 7 → ZMod 5 := fun z i => + match i with + | 0 => z.1.1.1.1.u1 + | 1 => z.1.1.1.1.u2 + | 2 => z.1.1.1.1.u3 + | 3 => z.1.1.1.2.u1 + | 4 => z.1.1.1.2.u2 + | 5 => z.1.1.1.2.u3 + | 6 => z.1.2.1 + +private lemma cageRangeCoordinatesAtFive_injective + (axis other : NormalizedCoordinateAxis) (xi eta : ZMod 5) (d : ℕ) : + Function.Injective (cageRangeCoordinatesAtFive axis other xi eta d) := by + intro z w h + apply Subtype.ext + apply Prod.ext + · apply Subtype.ext + apply Prod.ext <;> apply NormalizedPoint.ext + · simpa [cageRangeCoordinatesAtFive] using congrFun h (0 : Fin 7) + · simpa [cageRangeCoordinatesAtFive] using congrFun h (1 : Fin 7) + · simpa [cageRangeCoordinatesAtFive] using congrFun h (2 : Fin 7) + · simpa [cageRangeCoordinatesAtFive] using congrFun h (3 : Fin 7) + · simpa [cageRangeCoordinatesAtFive] using congrFun h (4 : Fin 7) + · simpa [cageRangeCoordinatesAtFive] using congrFun h (5 : Fin 7) + · apply Subtype.ext + apply Units.ext + simpa [cageRangeCoordinatesAtFive] using congrFun h (6 : Fin 7) + +/-- Every witness-bearing power-range set over `ZMod 5` has at most `5^7` +elements. -/ +lemma natCard_cageMiddleWitnessPowerRangeSolutions_five_le + (axis other : NormalizedCoordinateAxis) (xi eta : ZMod 5) (d : ℕ) : + Nat.card (cageMiddleWitnessPowerRangeSolutions 5 axis other xi eta d) ≤ + 78125 := by + calc + Nat.card (cageMiddleWitnessPowerRangeSolutions 5 axis other xi eta d) ≤ + Nat.card (Fin 7 → ZMod 5) := + Nat.card_le_card_of_injective + (cageRangeCoordinatesAtFive axis other xi eta d) + (cageRangeCoordinatesAtFive_injective axis other xi eta d) + _ = 78125 := by + rw [Nat.card_fun] + norm_num [Nat.card_fin, Nat.card_zmod] + +/-- A coarse uniform estimate at `p=5`. Multiplicity one is sufficient for +this isolated finite case. -/ +lemma cageWitnessPointEstimate_five : + ∀ (axis other : NormalizedCoordinateAxis) (xi eta : ZMod 5), + IsSplitMaximalTrace 5 xi → IsSplitMaximalTrace 5 eta → + ∃ multiplicity : ℕ, 0 < multiplicity ∧ + ∀ d : ℕ, d ∣ Nat.card (ZMod 5)ˣ → 0 < d → + |(Nat.card (cageMiddleWitnessPowerRangeSolutions + 5 axis other xi eta d) : ℝ) - + (multiplicity : ℝ) * (5 : ℝ) / d| ≤ + (100000 : ℝ) * Real.sqrt 5 := by + intro axis other xi eta _ _ + refine ⟨1, by norm_num, ?_⟩ + intro d _ hd + have hcardNat := + natCard_cageMiddleWitnessPowerRangeSolutions_five_le axis other xi eta d + have hcardReal : + (Nat.card (cageMiddleWitnessPowerRangeSolutions + 5 axis other xi eta d) : ℝ) ≤ 78125 := by + exact_mod_cast hcardNat + have hdReal : (0 : ℝ) < d := by exact_mod_cast hd + have hsqrt : (1 : ℝ) ≤ Real.sqrt 5 := by + have hsquare := Real.sq_sqrt (by norm_num : (0 : ℝ) ≤ 5) + have hnonnegative := Real.sqrt_nonneg 5 + nlinarith + norm_num only [Nat.cast_one, one_mul] + have hdOne : (1 : ℝ) ≤ d := by exact_mod_cast hd + have hdivNonnegative : (0 : ℝ) ≤ 5 / d := + div_nonneg (by norm_num) hdReal.le + have hdivLe : (5 : ℝ) / d ≤ 5 := by + apply (div_le_iff₀ hdReal).mpr + nlinarith + apply abs_le.mpr + constructor <;> nlinarith + +end + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Cage/WitnessEquations.lean b/LeanPool/MarkoffModP/BGS/Markoff/Cage/WitnessEquations.lean new file mode 100644 index 0000000000..64e0c3a28e --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Cage/WitnessEquations.lean @@ -0,0 +1,202 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Cage.HasseWeilAssumption + +/-! +# Witness-preserving equations for the cage fiber product + +This file gives the exact algebraic bridge for the canonical pair of axes. +It deliberately retains the two intersection witnesses. No point-count or +irreducibility assertion is made here. +-/ + +@[expose] public section + +namespace BGS.Markoff + +noncomputable section + +/-- Scalar coordinates of the two incidence witnesses with common third +coordinate. The roots record the two quadratic choices separately. -/ +structure CageIncidenceEquationWitness + (p : ℕ) [Fact p.Prime] (xi eta : ZMod p) where + /-- The common coordinate of the two incidence points. -/ + middle : ZMod p + /-- The discriminant root retaining the first incidence point. -/ + firstRoot : ZMod p + /-- The discriminant root retaining the second incidence point. -/ + secondRoot : ZMod p + /-- The quadratic incidence equation for the first fixed trace. -/ + firstEquation : + (xi ^ 2 - 4) * middle ^ 2 - firstRoot ^ 2 = 4 * xi ^ 2 + /-- The quadratic incidence equation for the second fixed trace. -/ + secondEquation : + (eta ^ 2 - 4) * middle ^ 2 - secondRoot ^ 2 = 4 * eta ^ 2 + +@[ext] +theorem CageIncidenceEquationWitness.ext + {p : ℕ} [Fact p.Prime] {xi eta : ZMod p} + {x y : CageIncidenceEquationWitness p xi eta} + (hmiddle : x.middle = y.middle) + (hfirst : x.firstRoot = y.firstRoot) + (hsecond : x.secondRoot = y.secondRoot) : x = y := by + cases x + cases y + simp_all + +private theorem first_incidence_discriminant_equation + {K : Type*} [CommRing K] (xi other middle : K) + (hSurface : + normalizedPolynomial + (⟨xi, other, middle⟩ : NormalizedPoint K) = 0) : + (xi ^ 2 - 4) * middle ^ 2 - (xi * middle - 2 * other) ^ 2 = + 4 * xi ^ 2 := by + simp only [normalizedPolynomial] at hSurface ⊢ + linear_combination -4 * hSurface + +private theorem second_incidence_discriminant_equation + {K : Type*} [CommRing K] (other eta middle : K) + (hSurface : + normalizedPolynomial + (⟨other, eta, middle⟩ : NormalizedPoint K) = 0) : + (eta ^ 2 - 4) * middle ^ 2 - (eta * middle - 2 * other) ^ 2 = + 4 * eta ^ 2 := by + simp only [normalizedPolynomial] at hSurface ⊢ + linear_combination -4 * hSurface + +/-- A first-coordinate discriminant equation reconstructs a normalized Markoff point. -/ +theorem normalized_first_third_point_of_discriminant_equation + {K : Type*} [Field K] (hTwo : (2 : K) ≠ 0) + (xi middle root : K) + (hEquation : + (xi ^ 2 - 4) * middle ^ 2 - root ^ 2 = 4 * xi ^ 2) : + normalizedPolynomial + (⟨xi, (xi * middle - root) / 2, middle⟩ : NormalizedPoint K) = 0 := by + simp only [normalizedPolynomial] + field_simp [hTwo] + linear_combination -hEquation + +/-- A second-coordinate discriminant equation reconstructs a normalized Markoff point. -/ +theorem normalized_second_third_point_of_discriminant_equation + {K : Type*} [Field K] (hTwo : (2 : K) ≠ 0) + (eta middle root : K) + (hEquation : + (eta ^ 2 - 4) * middle ^ 2 - root ^ 2 = 4 * eta ^ 2) : + normalizedPolynomial + (⟨(eta * middle - root) / 2, eta, middle⟩ : NormalizedPoint K) = 0 := by + change normalizedPolynomial + (normalizedSwap12 + (⟨eta, (eta * middle - root) / 2, middle⟩ : NormalizedPoint K)) = 0 + rw [normalizedPolynomial_swap12] + exact normalized_first_third_point_of_discriminant_equation + hTwo eta middle root hEquation + +/-- A canonical cage witness pair gives the two quadratic incidence roots, +without projecting either root away. -/ +def canonicalCageWitnessToEquations + (p : ℕ) [Fact p.Prime] (xi eta : ZMod p) : + CageMiddleWitnessPair p .first .second xi eta → + CageIncidenceEquationWitness p xi eta := fun z => + { middle := z.1.1.u3 + firstRoot := xi * z.1.1.u3 - 2 * z.1.1.u2 + secondRoot := eta * z.1.1.u3 - 2 * z.1.2.u1 + firstEquation := by + apply first_incidence_discriminant_equation xi z.1.1.u2 z.1.1.u3 + have hxi : z.1.1.u1 = xi := by + simpa [normalizedFiberAt] using z.2.1.2 + have hSurface : normalizedPolynomial z.1.1 = 0 := by + simpa [normalizedFiberAt, IsNormalizedMarkoff] using z.2.1.1 + calc + normalizedPolynomial + (⟨xi, z.1.1.u2, z.1.1.u3⟩ : NormalizedPoint (ZMod p)) = + normalizedPolynomial z.1.1 := by + congr 1 + exact NormalizedPoint.ext hxi.symm rfl rfl + _ = 0 := hSurface + secondEquation := by + apply second_incidence_discriminant_equation z.1.2.u1 eta z.1.1.u3 + have hSurface : normalizedPolynomial z.1.2 = 0 := by + simpa [normalizedFiberAt, IsNormalizedMarkoff] using z.2.2.1.1 + have heta : z.1.2.u2 = eta := by + simpa [normalizedFiberAt] using z.2.2.1.2 + have hmiddle : z.1.1.u3 = z.1.2.u3 := by + simpa [normalizedCoordinateAt, cageBridgeAxis] using z.2.2.2 + calc + normalizedPolynomial + (⟨z.1.2.u1, eta, z.1.1.u3⟩ : NormalizedPoint (ZMod p)) = + normalizedPolynomial z.1.2 := by + congr 1 + exact NormalizedPoint.ext rfl heta.symm hmiddle + _ = 0 := hSurface } + +/-- Reconstruct both actual Markoff points from the common coordinate and +the two retained roots. -/ +def canonicalCageEquationsToWitness + (p : ℕ) [Fact p.Prime] (hpTwo : p ≠ 2) (xi eta : ZMod p) : + CageIncidenceEquationWitness p xi eta → + CageMiddleWitnessPair p .first .second xi eta := fun z => by + have hTwo : (2 : ZMod p) ≠ 0 := by + have hpPrime : p.Prime := Fact.out + exact two_ne_zero_zmod + (lt_of_le_of_ne hpPrime.two_le (Ne.symm hpTwo)) + let firstPoint : NormalizedPoint (ZMod p) := + ⟨xi, (xi * z.middle - z.firstRoot) / 2, z.middle⟩ + let secondPoint : NormalizedPoint (ZMod p) := + ⟨(eta * z.middle - z.secondRoot) / 2, eta, z.middle⟩ + refine ⟨(firstPoint, secondPoint), ?_⟩ + refine ⟨⟨?_, rfl⟩, ⟨⟨?_, rfl⟩, rfl⟩⟩ + · exact normalized_first_third_point_of_discriminant_equation + hTwo xi z.middle z.firstRoot z.firstEquation + · exact normalized_second_third_point_of_discriminant_equation + hTwo eta z.middle z.secondRoot z.secondEquation + +/-- For odd characteristic, the canonical witness pair is exactly the pair +of quadratic equations. In particular this equivalence exposes the +diagonal case: the two root fields remain independent even when the two +equations coincide. -/ +def canonicalCageWitnessEquivIncidenceEquations + (p : ℕ) [Fact p.Prime] (hpTwo : p ≠ 2) (xi eta : ZMod p) : + CageMiddleWitnessPair p .first .second xi eta ≃ + CageIncidenceEquationWitness p xi eta where + toFun := canonicalCageWitnessToEquations p xi eta + invFun := canonicalCageEquationsToWitness p hpTwo xi eta + left_inv := by + intro z + have hpPrime : p.Prime := Fact.out + have hTwo : (2 : ZMod p) ≠ 0 := two_ne_zero_zmod + (lt_of_le_of_ne hpPrime.two_le (Ne.symm hpTwo)) + have hxi : xi = z.1.1.u1 := by + simpa [normalizedFiberAt] using z.2.1.2.symm + have heta : eta = z.1.2.u2 := by + simpa [normalizedFiberAt] using z.2.2.1.2.symm + have hmiddle : z.1.1.u3 = z.1.2.u3 := by + simpa [normalizedCoordinateAt, cageBridgeAxis] using z.2.2.2 + apply Subtype.ext + apply Prod.ext <;> apply NormalizedPoint.ext <;> + simp [canonicalCageWitnessToEquations, + canonicalCageEquationsToWitness, hTwo, hxi, heta, hmiddle] + right_inv := by + intro z + have hpPrime : p.Prime := Fact.out + have hTwo : (2 : ZMod p) ≠ 0 := two_ne_zero_zmod + (lt_of_le_of_ne hpPrime.two_le (Ne.symm hpTwo)) + apply CageIncidenceEquationWitness.ext + · rfl + · simp only [canonicalCageWitnessToEquations, + canonicalCageEquationsToWitness] + field_simp [hTwo] + ring + · simp only [canonicalCageWitnessToEquations, + canonicalCageEquationsToWitness] + field_simp [hTwo] + ring + +end + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Core.lean b/LeanPool/MarkoffModP/BGS/Markoff/Core.lean new file mode 100644 index 0000000000..697d79c4a0 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Core.lean @@ -0,0 +1,22 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Core.Action +public import LeanPool.MarkoffModP.BGS.Markoff.Core.Basic +public import LeanPool.MarkoffModP.BGS.Markoff.Core.ConicParametrization +public import LeanPool.MarkoffModP.BGS.Markoff.Core.FiniteRotationEigenvalues +public import LeanPool.MarkoffModP.BGS.Markoff.Core.Normalization +public import LeanPool.MarkoffModP.BGS.Markoff.Core.NormalizedOrbit +public import LeanPool.MarkoffModP.BGS.Markoff.Core.NatConnectivity +public import LeanPool.MarkoffModP.BGS.Markoff.Core.ParabolicFibers +public import LeanPool.MarkoffModP.BGS.Markoff.Core.PuncturedNormalization +public import LeanPool.MarkoffModP.BGS.Markoff.Core.Rotation +public import LeanPool.MarkoffModP.BGS.Markoff.Core.RotationTorus +public import LeanPool.MarkoffModP.BGS.Markoff.Core.SemiringFunctor +public import LeanPool.MarkoffModP.BGS.Markoff.Core.Statements +public import LeanPool.MarkoffModP.BGS.Markoff.Core.TraceClassification diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Core/Action.lean b/LeanPool/MarkoffModP/BGS/Markoff/Core/Action.lean new file mode 100644 index 0000000000..cc8034966a --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Core/Action.lean @@ -0,0 +1,458 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Core.Basic + +/-! +# The Markoff group action + +This file turns the polynomial identities from `BGS.Markoff.Basic` into an action on the +Markoff surface itself. In particular, membership in the surface is part of the type of every +generator. The group `Gamma` is the subgroup generated by the three Vieta involutions and the +two adjacent coordinate transpositions. + +The origin is fixed by every generator, hence by all of `Gamma`. Consequently the same group +acts on the punctured surface; this is the action used in finite-field transitivity statements. +-/ + +@[expose] public section + +namespace BGS.Markoff + +universe u + +/-- The Markoff surface as a subtype of affine three-space. -/ +abbrev MarkoffSurface (R : Type u) [CommRing R] := {x : Point R // IsMarkoff x} + +/-- The origin, regarded as a point of the Markoff surface. -/ +def surfaceOrigin (R : Type u) [CommRing R] : MarkoffSurface R := + ⟨origin, isMarkoff_origin⟩ + +@[simp] +theorem isMarkoff_swap12 {R : Type u} [CommRing R] (x : Point R) : + IsMarkoff (swap12 x) ↔ IsMarkoff x := by + simp only [IsMarkoff, markoffPolynomial_swap12] + +@[simp] +theorem isMarkoff_swap23 {R : Type u} [CommRing R] (x : Point R) : + IsMarkoff (swap23 x) ↔ IsMarkoff x := by + simp only [IsMarkoff, markoffPolynomial_swap23] + +/-- The first Vieta involution, restricted to the Markoff surface. -/ +def vieta1SurfacePerm (R : Type u) [CommRing R] : Equiv.Perm (MarkoffSurface R) where + __ := (vieta1Equiv R).subtypeEquiv fun x => (isMarkoff_vieta1 x).symm + +/-- The second Vieta involution, restricted to the Markoff surface. -/ +def vieta2SurfacePerm (R : Type u) [CommRing R] : Equiv.Perm (MarkoffSurface R) where + __ := (vieta2Equiv R).subtypeEquiv fun x => (isMarkoff_vieta2 x).symm + +/-- The third Vieta involution, restricted to the Markoff surface. -/ +def vieta3SurfacePerm (R : Type u) [CommRing R] : Equiv.Perm (MarkoffSurface R) where + __ := (vieta3Equiv R).subtypeEquiv fun x => (isMarkoff_vieta3 x).symm + +/-- The first coordinate transposition, restricted to the Markoff surface. -/ +def swap12SurfacePerm (R : Type u) [CommRing R] : Equiv.Perm (MarkoffSurface R) where + __ := (swap12Equiv R).subtypeEquiv fun x => (isMarkoff_swap12 x).symm + +/-- The second coordinate transposition, restricted to the Markoff surface. -/ +def swap23SurfacePerm (R : Type u) [CommRing R] : Equiv.Perm (MarkoffSurface R) where + __ := (swap23Equiv R).subtypeEquiv fun x => (isMarkoff_swap23 x).symm + +@[simp] +theorem coe_vieta1SurfacePerm {R : Type u} [CommRing R] (x : MarkoffSurface R) : + ((vieta1SurfacePerm R x : MarkoffSurface R) : Point R) = vieta1 x := rfl + +@[simp] +theorem coe_vieta2SurfacePerm {R : Type u} [CommRing R] (x : MarkoffSurface R) : + ((vieta2SurfacePerm R x : MarkoffSurface R) : Point R) = vieta2 x := rfl + +@[simp] +theorem coe_vieta3SurfacePerm {R : Type u} [CommRing R] (x : MarkoffSurface R) : + ((vieta3SurfacePerm R x : MarkoffSurface R) : Point R) = vieta3 x := rfl + +@[simp] +theorem coe_swap12SurfacePerm {R : Type u} [CommRing R] (x : MarkoffSurface R) : + ((swap12SurfacePerm R x : MarkoffSurface R) : Point R) = swap12 x := rfl + +@[simp] +theorem coe_swap23SurfacePerm {R : Type u} [CommRing R] (x : MarkoffSurface R) : + ((swap23SurfacePerm R x : MarkoffSurface R) : Point R) = swap23 x := rfl + +@[simp] +theorem vieta1SurfacePerm_surfaceOrigin (R : Type u) [CommRing R] : + vieta1SurfacePerm R (surfaceOrigin R) = surfaceOrigin R := by + ext <;> simp [vieta1SurfacePerm, vieta1Equiv, surfaceOrigin, vieta1, origin] + +@[simp] +theorem vieta2SurfacePerm_surfaceOrigin (R : Type u) [CommRing R] : + vieta2SurfacePerm R (surfaceOrigin R) = surfaceOrigin R := by + ext <;> simp [vieta2SurfacePerm, vieta2Equiv, surfaceOrigin, vieta2, origin] + +@[simp] +theorem vieta3SurfacePerm_surfaceOrigin (R : Type u) [CommRing R] : + vieta3SurfacePerm R (surfaceOrigin R) = surfaceOrigin R := by + ext <;> simp [vieta3SurfacePerm, vieta3Equiv, surfaceOrigin, vieta3, origin] + +@[simp] +theorem swap12SurfacePerm_surfaceOrigin (R : Type u) [CommRing R] : + swap12SurfacePerm R (surfaceOrigin R) = surfaceOrigin R := by + ext <;> rfl + +@[simp] +theorem swap23SurfacePerm_surfaceOrigin (R : Type u) [CommRing R] : + swap23SurfacePerm R (surfaceOrigin R) = surfaceOrigin R := by + ext <;> rfl + +private theorem perm_ne_fixed_iff {A : Type*} (e : Equiv.Perm A) (a : A) (h : e a = a) + (x : A) : e x ≠ a ↔ x ≠ a := by + constructor + · intro hex hxa + exact hex (hxa ▸ h) + · intro hxa hex + exact hxa (e.injective (hex.trans h.symm)) + +@[simp] +theorem vieta1SurfacePerm_ne_origin_iff {R : Type u} [CommRing R] (x : MarkoffSurface R) : + vieta1SurfacePerm R x ≠ surfaceOrigin R ↔ x ≠ surfaceOrigin R := + perm_ne_fixed_iff (vieta1SurfacePerm R) (surfaceOrigin R) + (vieta1SurfacePerm_surfaceOrigin R) x + +@[simp] +theorem vieta2SurfacePerm_ne_origin_iff {R : Type u} [CommRing R] (x : MarkoffSurface R) : + vieta2SurfacePerm R x ≠ surfaceOrigin R ↔ x ≠ surfaceOrigin R := + perm_ne_fixed_iff (vieta2SurfacePerm R) (surfaceOrigin R) + (vieta2SurfacePerm_surfaceOrigin R) x + +@[simp] +theorem vieta3SurfacePerm_ne_origin_iff {R : Type u} [CommRing R] (x : MarkoffSurface R) : + vieta3SurfacePerm R x ≠ surfaceOrigin R ↔ x ≠ surfaceOrigin R := + perm_ne_fixed_iff (vieta3SurfacePerm R) (surfaceOrigin R) + (vieta3SurfacePerm_surfaceOrigin R) x + +@[simp] +theorem swap12SurfacePerm_ne_origin_iff {R : Type u} [CommRing R] (x : MarkoffSurface R) : + swap12SurfacePerm R x ≠ surfaceOrigin R ↔ x ≠ surfaceOrigin R := + perm_ne_fixed_iff (swap12SurfacePerm R) (surfaceOrigin R) + (swap12SurfacePerm_surfaceOrigin R) x + +@[simp] +theorem swap23SurfacePerm_ne_origin_iff {R : Type u} [CommRing R] (x : MarkoffSurface R) : + swap23SurfacePerm R x ≠ surfaceOrigin R ↔ x ≠ surfaceOrigin R := + perm_ne_fixed_iff (swap23SurfacePerm R) (surfaceOrigin R) + (swap23SurfacePerm_surfaceOrigin R) x + +/-- The punctured Markoff surface, expressed as the complement of the surface origin. -/ +abbrev PuncturedMarkoffSurface (R : Type u) [CommRing R] := + {x : MarkoffSurface R // x ≠ surfaceOrigin R} + +/-- The action carrier is the same punctured surface as the set defined in `Basic`. -/ +def puncturedSurfaceEquiv (R : Type u) [CommRing R] : + PuncturedMarkoffSurface R ≃ ↑(puncturedSurface R) where + toFun x := + ⟨x.1.1, by + change IsMarkoff x.1.1 ∧ x.1.1 ≠ origin + exact ⟨x.1.2, fun hx => x.2 (Subtype.ext hx)⟩⟩ + invFun x := by + have hx := x.2 + change IsMarkoff x.1 ∧ x.1 ≠ origin at hx + exact ⟨⟨x.1, hx.1⟩, fun h => hx.2 (congrArg Subtype.val h)⟩ + left_inv x := by + apply Subtype.ext + rfl + right_inv x := by + apply Subtype.ext + rfl + +@[simp] +theorem puncturedSurfaceEquiv_coe {R : Type u} [CommRing R] + (x : PuncturedMarkoffSurface R) : (puncturedSurfaceEquiv R x : Point R) = x.1.1 := + rfl + +/-- Restrict a permutation to the complement of one of its fixed points. -/ +def restrictPermNe {A : Type*} (e : Equiv.Perm A) (a : A) (h : e a = a) : + Equiv.Perm {x : A // x ≠ a} where + toFun x := + ⟨e x, fun hex => x.2 (e.injective (hex.trans h.symm))⟩ + invFun x := + ⟨e.symm x, fun hex => by + apply x.2 + calc + x.1 = e (e.symm x.1) := (e.apply_symm_apply x.1).symm + _ = e a := congrArg e hex + _ = a := h⟩ + left_inv x := Subtype.ext (e.symm_apply_apply x) + right_inv x := Subtype.ext (e.apply_symm_apply x) + +/-- The first Vieta involution on the punctured Markoff surface. -/ +def vieta1PuncturedPerm (R : Type u) [CommRing R] : Equiv.Perm (PuncturedMarkoffSurface R) := + restrictPermNe (vieta1SurfacePerm R) (surfaceOrigin R) (vieta1SurfacePerm_surfaceOrigin R) + +/-- The second Vieta involution on the punctured Markoff surface. -/ +def vieta2PuncturedPerm (R : Type u) [CommRing R] : Equiv.Perm (PuncturedMarkoffSurface R) := + restrictPermNe (vieta2SurfacePerm R) (surfaceOrigin R) (vieta2SurfacePerm_surfaceOrigin R) + +/-- The third Vieta involution on the punctured Markoff surface. -/ +def vieta3PuncturedPerm (R : Type u) [CommRing R] : Equiv.Perm (PuncturedMarkoffSurface R) := + restrictPermNe (vieta3SurfacePerm R) (surfaceOrigin R) (vieta3SurfacePerm_surfaceOrigin R) + +/-- The first coordinate transposition on the punctured Markoff surface. -/ +def swap12PuncturedPerm (R : Type u) [CommRing R] : Equiv.Perm (PuncturedMarkoffSurface R) := + restrictPermNe (swap12SurfacePerm R) (surfaceOrigin R) (swap12SurfacePerm_surfaceOrigin R) + +/-- The second coordinate transposition on the punctured Markoff surface. -/ +def swap23PuncturedPerm (R : Type u) [CommRing R] : Equiv.Perm (PuncturedMarkoffSurface R) := + restrictPermNe (swap23SurfacePerm R) (surfaceOrigin R) (swap23SurfacePerm_surfaceOrigin R) + +/-- The five standard generators of the Markoff group on the surface. -/ +def gammaGenerators (R : Type u) [CommRing R] : Set (Equiv.Perm (MarkoffSurface R)) := + {vieta1SurfacePerm R, vieta2SurfacePerm R, vieta3SurfacePerm R, swap12SurfacePerm R, + swap23SurfacePerm R} + +/-- The Markoff group generated by Vieta involutions and coordinate permutations. -/ +def Gamma (R : Type u) [CommRing R] : Subgroup (Equiv.Perm (MarkoffSurface R)) := + Subgroup.closure (gammaGenerators R) + +theorem vieta1SurfacePerm_mem_Gamma (R : Type u) [CommRing R] : + vieta1SurfacePerm R ∈ Gamma R := + Subgroup.subset_closure (by simp [gammaGenerators]) + +theorem vieta2SurfacePerm_mem_Gamma (R : Type u) [CommRing R] : + vieta2SurfacePerm R ∈ Gamma R := + Subgroup.subset_closure (by simp [gammaGenerators]) + +theorem vieta3SurfacePerm_mem_Gamma (R : Type u) [CommRing R] : + vieta3SurfacePerm R ∈ Gamma R := + Subgroup.subset_closure (by simp [gammaGenerators]) + +theorem swap12SurfacePerm_mem_Gamma (R : Type u) [CommRing R] : + swap12SurfacePerm R ∈ Gamma R := + Subgroup.subset_closure (by simp [gammaGenerators]) + +theorem swap23SurfacePerm_mem_Gamma (R : Type u) [CommRing R] : + swap23SurfacePerm R ∈ Gamma R := + Subgroup.subset_closure (by simp [gammaGenerators]) + +/-- The first Vieta generator as an element of `Gamma`. -/ +def gammaVieta1 (R : Type u) [CommRing R] : Gamma R := + ⟨vieta1SurfacePerm R, vieta1SurfacePerm_mem_Gamma R⟩ + +/-- The second Vieta generator as an element of `Gamma`. -/ +def gammaVieta2 (R : Type u) [CommRing R] : Gamma R := + ⟨vieta2SurfacePerm R, vieta2SurfacePerm_mem_Gamma R⟩ + +/-- The third Vieta generator as an element of `Gamma`. -/ +def gammaVieta3 (R : Type u) [CommRing R] : Gamma R := + ⟨vieta3SurfacePerm R, vieta3SurfacePerm_mem_Gamma R⟩ + +/-- The first adjacent transposition as an element of `Gamma`. -/ +def gammaSwap12 (R : Type u) [CommRing R] : Gamma R := + ⟨swap12SurfacePerm R, swap12SurfacePerm_mem_Gamma R⟩ + +/-- The second adjacent transposition as an element of `Gamma`. -/ +def gammaSwap23 (R : Type u) [CommRing R] : Gamma R := + ⟨swap23SurfacePerm R, swap23SurfacePerm_mem_Gamma R⟩ + +@[simp] +theorem gammaVieta1_smul_surface {R : Type u} [CommRing R] (x : MarkoffSurface R) : + gammaVieta1 R • x = vieta1SurfacePerm R x := rfl + +@[simp] +theorem gammaVieta2_smul_surface {R : Type u} [CommRing R] (x : MarkoffSurface R) : + gammaVieta2 R • x = vieta2SurfacePerm R x := rfl + +@[simp] +theorem gammaVieta3_smul_surface {R : Type u} [CommRing R] (x : MarkoffSurface R) : + gammaVieta3 R • x = vieta3SurfacePerm R x := rfl + +@[simp] +theorem gammaSwap12_smul_surface {R : Type u} [CommRing R] (x : MarkoffSurface R) : + gammaSwap12 R • x = swap12SurfacePerm R x := rfl + +@[simp] +theorem gammaSwap23_smul_surface {R : Type u} [CommRing R] (x : MarkoffSurface R) : + gammaSwap23 R • x = swap23SurfacePerm R x := rfl + +/-- Every standard generator fixes the origin. This is public so that the +standalone Comparator specification can reproduce the exact declaration +closure without depending on a module-private generated name. -/ +theorem gammaGenerator_fixes_origin {R : Type u} [CommRing R] + {g : Equiv.Perm (MarkoffSurface R)} (hg : g ∈ gammaGenerators R) : + g (surfaceOrigin R) = surfaceOrigin R := by + simp only [gammaGenerators, Set.mem_insert_iff, Set.mem_singleton_iff] at hg + rcases hg with rfl | rfl | rfl | rfl | rfl <;> simp + +/-- Every element of `Gamma` fixes the origin. -/ +theorem Gamma_le_origin_stabilizer (R : Type u) [CommRing R] : + Gamma R ≤ MulAction.stabilizer (Equiv.Perm (MarkoffSurface R)) (surfaceOrigin R) := + (Subgroup.closure_le _).2 fun g hg => by + change g (surfaceOrigin R) = surfaceOrigin R + exact gammaGenerator_fixes_origin hg + +@[simp] +theorem Gamma_fixes_surfaceOrigin {R : Type u} [CommRing R] (g : Gamma R) : + g • surfaceOrigin R = surfaceOrigin R := + Gamma_le_origin_stabilizer R g.2 + +/-- The action of `Gamma` on the surface restricts to its punctured complement. -/ +instance {R : Type u} [CommRing R] : MulAction (Gamma R) (PuncturedMarkoffSurface R) where + smul g x := + ⟨g • x.1, fun hgx => x.2 <| by + calc + x.1 = g⁻¹ • (g • x.1) := (inv_smul_smul g x.1).symm + _ = g⁻¹ • surfaceOrigin R := congrArg (g⁻¹ • ·) hgx + _ = surfaceOrigin R := Gamma_fixes_surfaceOrigin g⁻¹⟩ + one_smul x := Subtype.ext (one_smul (Gamma R) x.1) + mul_smul g h x := Subtype.ext (mul_smul g h x.1) + +@[simp] +theorem gammaVieta1_smul_punctured {R : Type u} [CommRing R] + (x : PuncturedMarkoffSurface R) : gammaVieta1 R • x = vieta1PuncturedPerm R x := by + apply Subtype.ext + rfl + +@[simp] +theorem gammaVieta2_smul_punctured {R : Type u} [CommRing R] + (x : PuncturedMarkoffSurface R) : gammaVieta2 R • x = vieta2PuncturedPerm R x := by + apply Subtype.ext + rfl + +@[simp] +theorem gammaVieta3_smul_punctured {R : Type u} [CommRing R] + (x : PuncturedMarkoffSurface R) : gammaVieta3 R • x = vieta3PuncturedPerm R x := by + apply Subtype.ext + rfl + +@[simp] +theorem gammaSwap12_smul_punctured {R : Type u} [CommRing R] + (x : PuncturedMarkoffSurface R) : gammaSwap12 R • x = swap12PuncturedPerm R x := by + apply Subtype.ext + rfl + +@[simp] +theorem gammaSwap23_smul_punctured {R : Type u} [CommRing R] + (x : PuncturedMarkoffSurface R) : gammaSwap23 R • x = swap23PuncturedPerm R x := by + apply Subtype.ext + rfl + +/-- The orbit of a point on the Markoff surface under `Gamma`. -/ +def gammaOrbit {R : Type u} [CommRing R] (x : MarkoffSurface R) : Set (MarkoffSurface R) := + MulAction.orbit (Gamma R) x + +/-- Two surface points lie in the same Markoff component when they are in one `Gamma`-orbit. -/ +def SameComponent {R : Type u} [CommRing R] (x y : MarkoffSurface R) : Prop := + y ∈ gammaOrbit x + +theorem sameComponent_iff_exists {R : Type u} [CommRing R] (x y : MarkoffSurface R) : + SameComponent x y ↔ ∃ g : Gamma R, g • x = y := + Iff.rfl + +@[refl] +theorem sameComponent_refl {R : Type u} [CommRing R] (x : MarkoffSurface R) : + SameComponent x x := + MulAction.mem_orbit_self x + +@[symm] +theorem sameComponent_symm {R : Type u} [CommRing R] {x y : MarkoffSurface R} + (h : SameComponent x y) : SameComponent y x := + MulAction.mem_orbit_symm.mp h + +@[trans] +theorem sameComponent_trans {R : Type u} [CommRing R] {x y z : MarkoffSurface R} + (hxy : SameComponent x y) (hyz : SameComponent y z) : SameComponent x z := by + unfold SameComponent gammaOrbit at * + rwa [(MulAction.orbit_eq_iff).2 hxy] at hyz + +theorem sameComponent_iff_orbit_eq {R : Type u} [CommRing R] (x y : MarkoffSurface R) : + SameComponent x y ↔ gammaOrbit x = gammaOrbit y := by + unfold SameComponent gammaOrbit + exact MulAction.mem_orbit_symm.trans MulAction.orbit_eq_iff.symm + +theorem sameComponent_vieta1 {R : Type u} [CommRing R] (x : MarkoffSurface R) : + SameComponent x (vieta1SurfacePerm R x) := + (sameComponent_iff_exists x _).2 ⟨gammaVieta1 R, gammaVieta1_smul_surface x⟩ + +theorem sameComponent_vieta2 {R : Type u} [CommRing R] (x : MarkoffSurface R) : + SameComponent x (vieta2SurfacePerm R x) := + (sameComponent_iff_exists x _).2 ⟨gammaVieta2 R, gammaVieta2_smul_surface x⟩ + +theorem sameComponent_vieta3 {R : Type u} [CommRing R] (x : MarkoffSurface R) : + SameComponent x (vieta3SurfacePerm R x) := + (sameComponent_iff_exists x _).2 ⟨gammaVieta3 R, gammaVieta3_smul_surface x⟩ + +theorem sameComponent_swap12 {R : Type u} [CommRing R] (x : MarkoffSurface R) : + SameComponent x (swap12SurfacePerm R x) := + (sameComponent_iff_exists x _).2 ⟨gammaSwap12 R, gammaSwap12_smul_surface x⟩ + +theorem sameComponent_swap23 {R : Type u} [CommRing R] (x : MarkoffSurface R) : + SameComponent x (swap23SurfacePerm R x) := + (sameComponent_iff_exists x _).2 ⟨gammaSwap23 R, gammaSwap23_smul_surface x⟩ + +/-- The orbit of a punctured point under the restricted `Gamma` action. -/ +def puncturedGammaOrbit {R : Type u} [CommRing R] (x : PuncturedMarkoffSurface R) : + Set (PuncturedMarkoffSurface R) := + MulAction.orbit (Gamma R) x + +/-- The component relation on the punctured Markoff surface. -/ +def SamePuncturedComponent {R : Type u} [CommRing R] + (x y : PuncturedMarkoffSurface R) : Prop := + y ∈ puncturedGammaOrbit x + +theorem samePuncturedComponent_iff_exists {R : Type u} [CommRing R] + (x y : PuncturedMarkoffSurface R) : + SamePuncturedComponent x y ↔ ∃ g : Gamma R, g • x = y := + Iff.rfl + +@[refl] +theorem samePuncturedComponent_refl {R : Type u} [CommRing R] + (x : PuncturedMarkoffSurface R) : SamePuncturedComponent x x := + MulAction.mem_orbit_self x + +@[symm] +theorem samePuncturedComponent_symm {R : Type u} [CommRing R] + {x y : PuncturedMarkoffSurface R} (h : SamePuncturedComponent x y) : + SamePuncturedComponent y x := + MulAction.mem_orbit_symm.mp h + +@[trans] +theorem samePuncturedComponent_trans {R : Type u} [CommRing R] + {x y z : PuncturedMarkoffSurface R} (hxy : SamePuncturedComponent x y) + (hyz : SamePuncturedComponent y z) : SamePuncturedComponent x z := by + unfold SamePuncturedComponent puncturedGammaOrbit at * + rwa [(MulAction.orbit_eq_iff).2 hxy] at hyz + +theorem samePuncturedComponent_vieta1 {R : Type u} [CommRing R] + (x : PuncturedMarkoffSurface R) : + SamePuncturedComponent x (vieta1PuncturedPerm R x) := + (samePuncturedComponent_iff_exists x _).2 + ⟨gammaVieta1 R, gammaVieta1_smul_punctured x⟩ + +theorem samePuncturedComponent_vieta2 {R : Type u} [CommRing R] + (x : PuncturedMarkoffSurface R) : + SamePuncturedComponent x (vieta2PuncturedPerm R x) := + (samePuncturedComponent_iff_exists x _).2 + ⟨gammaVieta2 R, gammaVieta2_smul_punctured x⟩ + +theorem samePuncturedComponent_vieta3 {R : Type u} [CommRing R] + (x : PuncturedMarkoffSurface R) : + SamePuncturedComponent x (vieta3PuncturedPerm R x) := + (samePuncturedComponent_iff_exists x _).2 + ⟨gammaVieta3 R, gammaVieta3_smul_punctured x⟩ + +theorem samePuncturedComponent_swap12 {R : Type u} [CommRing R] + (x : PuncturedMarkoffSurface R) : + SamePuncturedComponent x (swap12PuncturedPerm R x) := + (samePuncturedComponent_iff_exists x _).2 + ⟨gammaSwap12 R, gammaSwap12_smul_punctured x⟩ + +theorem samePuncturedComponent_swap23 {R : Type u} [CommRing R] + (x : PuncturedMarkoffSurface R) : + SamePuncturedComponent x (swap23PuncturedPerm R x) := + (samePuncturedComponent_iff_exists x _).2 + ⟨gammaSwap23 R, gammaSwap23_smul_punctured x⟩ + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Core/Basic.lean b/LeanPool/MarkoffModP/BGS/Markoff/Core/Basic.lean new file mode 100644 index 0000000000..ad89eb1487 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Core/Basic.lean @@ -0,0 +1,202 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import Mathlib.Data.Fintype.Sigma +public import Mathlib.Tactic +public import Mathlib.Tactic.Ring.Basic + +/-! +# The elementary Markoff surface + +This file fixes the unscaled coordinates used in the introduction of +Bourgain--Gamburd--Sarnak, arXiv:1607.01530v1. Later parts of the paper use +trace coordinates obtained by multiplying each coordinate by three; that +normalization is deliberately kept separate. +-/ + +@[expose] public section + +namespace BGS.Markoff + +universe u + +/-- A point of affine three-space over a type `R`. -/ +@[ext] +structure Point (R : Type u) where + /-- The first coordinate. -/ + x1 : R + /-- The second coordinate. -/ + x2 : R + /-- The third coordinate. -/ + x3 : R +deriving DecidableEq, Repr, Fintype + +/-- The origin in affine three-space. -/ +def origin {R : Type u} [Zero R] : Point R := ⟨0, 0, 0⟩ + +/-- The polynomial whose zero locus is the Markoff surface. -/ +def markoffPolynomial {R : Type u} [CommRing R] (x : Point R) : R := + x.x1 ^ 2 + x.x2 ^ 2 + x.x3 ^ 2 - 3 * x.x1 * x.x2 * x.x3 + +/-- The predicate that a point lies on the Markoff surface. -/ +def IsMarkoff {R : Type u} [CommRing R] (x : Point R) : Prop := + markoffPolynomial x = 0 + +/-- The Markoff surface as a set. -/ +def surface (R : Type u) [CommRing R] : Set (Point R) := + {x | IsMarkoff x} + +/-- The punctured Markoff surface, with the origin removed. -/ +def puncturedSurface (R : Type u) [CommRing R] : Set (Point R) := + surface R \ {origin} + +/-- The first Vieta involution. -/ +def vieta1 {R : Type u} [CommRing R] (x : Point R) : Point R := + ⟨3 * x.x2 * x.x3 - x.x1, x.x2, x.x3⟩ + +/-- The second Vieta involution. -/ +def vieta2 {R : Type u} [CommRing R] (x : Point R) : Point R := + ⟨x.x1, 3 * x.x1 * x.x3 - x.x2, x.x3⟩ + +/-- The third Vieta involution. -/ +def vieta3 {R : Type u} [CommRing R] (x : Point R) : Point R := + ⟨x.x1, x.x2, 3 * x.x1 * x.x2 - x.x3⟩ + +/-- Exchange the first two coordinates. -/ +def swap12 {R : Type u} (x : Point R) : Point R := + ⟨x.x2, x.x1, x.x3⟩ + +/-- Exchange the last two coordinates. -/ +def swap23 {R : Type u} (x : Point R) : Point R := + ⟨x.x1, x.x3, x.x2⟩ + +/-- The fundamental rotation fixing the first coordinate. -/ +def rotate1 {R : Type u} [CommRing R] (x : Point R) : Point R := + ⟨x.x1, x.x3, 3 * x.x1 * x.x3 - x.x2⟩ + +@[simp] +theorem markoffPolynomial_origin {R : Type u} [CommRing R] : + markoffPolynomial (origin : Point R) = 0 := by + simp [markoffPolynomial, origin] + +@[simp] +theorem isMarkoff_origin {R : Type u} [CommRing R] : + IsMarkoff (origin : Point R) := by + simp [IsMarkoff] + +theorem markoffPolynomial_vieta1 {R : Type u} [CommRing R] (x : Point R) : + markoffPolynomial (vieta1 x) = markoffPolynomial x := by + simp [markoffPolynomial, vieta1] + ring + +theorem markoffPolynomial_vieta2 {R : Type u} [CommRing R] (x : Point R) : + markoffPolynomial (vieta2 x) = markoffPolynomial x := by + simp [markoffPolynomial, vieta2] + ring + +theorem markoffPolynomial_vieta3 {R : Type u} [CommRing R] (x : Point R) : + markoffPolynomial (vieta3 x) = markoffPolynomial x := by + simp [markoffPolynomial, vieta3] + ring + +theorem markoffPolynomial_swap12 {R : Type u} [CommRing R] (x : Point R) : + markoffPolynomial (swap12 x) = markoffPolynomial x := by + simp [markoffPolynomial, swap12] + ring + +theorem markoffPolynomial_swap23 {R : Type u} [CommRing R] (x : Point R) : + markoffPolynomial (swap23 x) = markoffPolynomial x := by + simp [markoffPolynomial, swap23] + ring + +theorem markoffPolynomial_rotate1 {R : Type u} [CommRing R] (x : Point R) : + markoffPolynomial (rotate1 x) = markoffPolynomial x := by + simp [markoffPolynomial, rotate1] + ring + +@[simp] +theorem isMarkoff_vieta1 {R : Type u} [CommRing R] (x : Point R) : + IsMarkoff (vieta1 x) ↔ IsMarkoff x := by + simp only [IsMarkoff, markoffPolynomial_vieta1] + +@[simp] +theorem isMarkoff_vieta2 {R : Type u} [CommRing R] (x : Point R) : + IsMarkoff (vieta2 x) ↔ IsMarkoff x := by + simp only [IsMarkoff, markoffPolynomial_vieta2] + +@[simp] +theorem isMarkoff_vieta3 {R : Type u} [CommRing R] (x : Point R) : + IsMarkoff (vieta3 x) ↔ IsMarkoff x := by + simp only [IsMarkoff, markoffPolynomial_vieta3] + +@[simp] +theorem isMarkoff_rotate1 {R : Type u} [CommRing R] (x : Point R) : + IsMarkoff (rotate1 x) ↔ IsMarkoff x := by + simp only [IsMarkoff, markoffPolynomial_rotate1] + +@[simp] +theorem vieta1_involutive {R : Type u} [CommRing R] (x : Point R) : + vieta1 (vieta1 x) = x := by + ext <;> simp [vieta1] + +@[simp] +theorem vieta2_involutive {R : Type u} [CommRing R] (x : Point R) : + vieta2 (vieta2 x) = x := by + ext <;> simp [vieta2] + +@[simp] +theorem vieta3_involutive {R : Type u} [CommRing R] (x : Point R) : + vieta3 (vieta3 x) = x := by + ext <;> simp [vieta3] + +@[simp] +theorem swap12_involutive {R : Type u} (x : Point R) : + swap12 (swap12 x) = x := by + rfl + +@[simp] +theorem swap23_involutive {R : Type u} (x : Point R) : + swap23 (swap23 x) = x := by + rfl + +/-- The first Vieta move as a permutation of affine three-space. -/ +def vieta1Equiv (R : Type u) [CommRing R] : Equiv.Perm (Point R) where + toFun := vieta1 + invFun := vieta1 + left_inv := vieta1_involutive + right_inv := vieta1_involutive + +/-- The second Vieta move as a permutation of affine three-space. -/ +def vieta2Equiv (R : Type u) [CommRing R] : Equiv.Perm (Point R) where + toFun := vieta2 + invFun := vieta2 + left_inv := vieta2_involutive + right_inv := vieta2_involutive + +/-- The third Vieta move as a permutation of affine three-space. -/ +def vieta3Equiv (R : Type u) [CommRing R] : Equiv.Perm (Point R) where + toFun := vieta3 + invFun := vieta3 + left_inv := vieta3_involutive + right_inv := vieta3_involutive + +/-- The transposition of the first two coordinates as a permutation. -/ +def swap12Equiv (R : Type u) : Equiv.Perm (Point R) where + toFun := swap12 + invFun := swap12 + left_inv := swap12_involutive + right_inv := swap12_involutive + +/-- The transposition of the last two coordinates as a permutation. -/ +def swap23Equiv (R : Type u) : Equiv.Perm (Point R) where + toFun := swap23 + invFun := swap23 + left_inv := swap23_involutive + right_inv := swap23_involutive + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Core/ConicParametrization.lean b/LeanPool/MarkoffModP/BGS/Markoff/Core/ConicParametrization.lean new file mode 100644 index 0000000000..9477143531 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Core/ConicParametrization.lean @@ -0,0 +1,1179 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Core.ParabolicFibers +public import LeanPool.MarkoffModP.BGS.Markoff.Core.TraceClassification + +/-! +# Explicit parametrizations of normalized Markoff fibers + +This module formalizes the split and nonsplit parametrizations underlying Lemmas 4 and 5 of +Bourgain--Gamburd--Sarnak. The trace-zero fiber is deliberately kept visible: although its +rotation is semisimple, its conic is singular, so the paper's claimed single-torus +parametrization needs the additional hypothesis that the fixed normalized trace is nonzero. +-/ + +@[expose] public section + +namespace BGS.Markoff + +universe u + +section SplitFiber + +variable {F : Type u} [Field F] + +/-- The scalar product of the two eigen-coordinates on a nonparabolic normalized fiber. -/ +def splitFiberProduct (w : Fˣ) : F := + splitTorusTrace w ^ 2 / (splitTorusTrace w ^ 2 - 4) + +/-- The point on the normalized fiber obtained from a nonzero first eigen-coordinate. -/ +def splitFiberPoint (w s : Fˣ) : NormalizedPoint F := + ⟨splitTorusTrace w, + (s : F) + splitFiberProduct w * ((s⁻¹ : Fˣ) : F), + (s : F) * (w : F) + + splitFiberProduct w * ((s⁻¹ : Fˣ) : F) * ((w⁻¹ : Fˣ) : F)⟩ + +/-- The first eigen-coordinate recovered from a point in the fixed-trace plane. -/ +def splitFiberFirstEigenCoordinate (w : Fˣ) (x : NormalizedPoint F) : F := + (x.u3 - ((w⁻¹ : Fˣ) : F) * x.u2) / + ((w : F) - ((w⁻¹ : Fˣ) : F)) + +/-- The second eigen-coordinate recovered from a point in the fixed-trace plane. -/ +def splitFiberSecondEigenCoordinate (w : Fˣ) (x : NormalizedPoint F) : F := + ((w : F) * x.u2 - x.u3) / + ((w : F) - ((w⁻¹ : Fˣ) : F)) + +theorem splitTorusTrace_sq_sub_four (w : Fˣ) : + splitTorusTrace w ^ 2 - 4 = + ((w : F) - ((w⁻¹ : Fˣ) : F)) ^ 2 := by + simp [splitTorusTrace] + field_simp + ring + +theorem splitEigenvalueDifference_ne_zero (w : Fˣ) (hw : (w : F) ^ 2 ≠ 1) : + (w : F) - ((w⁻¹ : Fˣ) : F) ≠ 0 := by + intro h + apply hw + have hinv : ((w⁻¹ : Fˣ) : F) = (w : F) := by + exact (sub_eq_zero.mp h).symm + rw [pow_two] + calc + (w : F) * (w : F) = ((w⁻¹ : Fˣ) : F) * (w : F) := by rw [hinv] + _ = 1 := by simp + +theorem splitFiberProduct_ne_zero (w : Fˣ) + (hw : (w : F) ^ 2 ≠ 1) (htrace : splitTorusTrace w ≠ 0) : + splitFiberProduct w ≠ 0 := by + apply div_ne_zero + · exact pow_ne_zero 2 htrace + · rw [splitTorusTrace_sq_sub_four] + exact pow_ne_zero 2 (splitEigenvalueDifference_ne_zero w hw) + +theorem normalizedPolynomial_splitEigenCoordinates (w : Fˣ) (a b : F) : + normalizedPolynomial + (⟨splitTorusTrace w, a + b, + a * (w : F) + b * ((w⁻¹ : Fˣ) : F)⟩ : NormalizedPoint F) = + splitTorusTrace w ^ 2 + (4 - splitTorusTrace w ^ 2) * a * b := by + simp [normalizedPolynomial, splitTorusTrace] + field_simp + ring + +theorem splitFiberPoint_mem (w s : Fˣ) (hw : (w : F) ^ 2 ≠ 1) : + splitFiberPoint w s ∈ normalizedFiber1 (splitTorusTrace w) := by + constructor + · change normalizedPolynomial (splitFiberPoint w s) = 0 + change normalizedPolynomial + (⟨splitTorusTrace w, + (s : F) + splitFiberProduct w * ((s⁻¹ : Fˣ) : F), + (s : F) * (w : F) + + (splitFiberProduct w * ((s⁻¹ : Fˣ) : F)) * ((w⁻¹ : Fˣ) : F)⟩ : + NormalizedPoint F) = 0 + rw [normalizedPolynomial_splitEigenCoordinates] + rw [splitFiberProduct, splitTorusTrace_sq_sub_four] + have hdifference := splitEigenvalueDifference_ne_zero w hw + field_simp + simp [splitTorusTrace] + right + field_simp + ring + · rfl + +theorem splitFiberFirstEigenCoordinate_point (w s : Fˣ) + (hw : (w : F) ^ 2 ≠ 1) : + splitFiberFirstEigenCoordinate w (splitFiberPoint w s) = (s : F) := by + rw [splitFiberFirstEigenCoordinate, splitFiberPoint] + have hdifference := splitEigenvalueDifference_ne_zero w hw + simp only [mul_assoc] + simp + field_simp + ring + +theorem splitFiberEigenCoordinates_add (w : Fˣ) (hw : (w : F) ^ 2 ≠ 1) + (x : NormalizedPoint F) : + splitFiberFirstEigenCoordinate w x + splitFiberSecondEigenCoordinate w x = x.u2 := by + rw [splitFiberFirstEigenCoordinate, splitFiberSecondEigenCoordinate] + have hdifference := splitEigenvalueDifference_ne_zero w hw + field_simp + ring + +theorem splitFiberEigenCoordinates_weighted_add + (w : Fˣ) (hw : (w : F) ^ 2 ≠ 1) (x : NormalizedPoint F) : + splitFiberFirstEigenCoordinate w x * (w : F) + + splitFiberSecondEigenCoordinate w x * ((w⁻¹ : Fˣ) : F) = x.u3 := by + rw [splitFiberFirstEigenCoordinate, splitFiberSecondEigenCoordinate] + have hdifference := splitEigenvalueDifference_ne_zero w hw + field_simp + simp + ring + +theorem splitFiberEigenCoordinates_product (w : Fˣ) + (hw : (w : F) ^ 2 ≠ 1) + (x : ↑(normalizedFiber1 (splitTorusTrace w))) : + splitFiberFirstEigenCoordinate w x * splitFiberSecondEigenCoordinate w x = + splitFiberProduct w := by + have hpoint : + (x : NormalizedPoint F) = + ⟨splitTorusTrace w, + splitFiberFirstEigenCoordinate w x + splitFiberSecondEigenCoordinate w x, + splitFiberFirstEigenCoordinate w x * (w : F) + + splitFiberSecondEigenCoordinate w x * ((w⁻¹ : Fˣ) : F)⟩ := by + ext + · exact x.property.2 + · exact (splitFiberEigenCoordinates_add w hw x).symm + · exact (splitFiberEigenCoordinates_weighted_add w hw x).symm + have hpolynomial : normalizedPolynomial (x : NormalizedPoint F) = 0 := x.property.1 + rw [hpoint, normalizedPolynomial_splitEigenCoordinates] at hpolynomial + rw [show 4 - splitTorusTrace w ^ 2 = -(splitTorusTrace w ^ 2 - 4) by ring, + splitTorusTrace_sq_sub_four] at hpolynomial + rw [splitFiberProduct, splitTorusTrace_sq_sub_four] + have hdifference := splitEigenvalueDifference_ne_zero w hw + field_simp + linear_combination -hpolynomial + +theorem splitFiberFirstEigenCoordinate_ne_zero (w : Fˣ) + (hw : (w : F) ^ 2 ≠ 1) (htrace : splitTorusTrace w ≠ 0) + (x : ↑(normalizedFiber1 (splitTorusTrace w))) : + splitFiberFirstEigenCoordinate w x ≠ 0 := by + intro hzero + have hproduct := splitFiberEigenCoordinates_product w hw x + rw [hzero, zero_mul] at hproduct + exact splitFiberProduct_ne_zero w hw htrace hproduct.symm + +/-- The split semisimple normalized fiber, away from trace zero, is explicitly equivalent to +the multiplicative group of the base field. -/ +noncomputable def splitFiberEquiv (w : Fˣ) (hw : (w : F) ^ 2 ≠ 1) + (htrace : splitTorusTrace w ≠ 0) : + Fˣ ≃ ↑(normalizedFiber1 (splitTorusTrace w)) where + toFun s := ⟨splitFiberPoint w s, splitFiberPoint_mem w s hw⟩ + invFun x := Units.mk0 (splitFiberFirstEigenCoordinate w x) + (splitFiberFirstEigenCoordinate_ne_zero w hw htrace x) + left_inv s := by + apply Units.ext + exact splitFiberFirstEigenCoordinate_point w s hw + right_inv x := by + apply Subtype.ext + let a := splitFiberFirstEigenCoordinate w x + let b := splitFiberSecondEigenCoordinate w x + have ha : a ≠ 0 := splitFiberFirstEigenCoordinate_ne_zero w hw htrace x + have hab : a * b = splitFiberProduct w := splitFiberEigenCoordinates_product w hw x + have hb : splitFiberProduct w * a⁻¹ = b := by + rw [← hab] + field_simp + ext + · exact x.property.2.symm + · change a + splitFiberProduct w * a⁻¹ = x.val.u2 + rw [hb] + exact splitFiberEigenCoordinates_add w hw x + · change a * (w : F) + splitFiberProduct w * a⁻¹ * ((w⁻¹ : Fˣ) : F) = + x.val.u3 + rw [hb] + exact splitFiberEigenCoordinates_weighted_add w hw x + +/-- Under the explicit split-fiber parametrization, normalized rotation is multiplication by +the chosen eigenvalue. -/ +theorem normalizedRotate1_splitFiberPoint (w s : Fˣ) : + normalizedRotate1 (splitFiberPoint w s) = splitFiberPoint w (s * w) := by + ext + · rfl + · simp [normalizedRotate1, splitFiberPoint, splitTorusTrace] + field_simp + · simp [normalizedRotate1, splitFiberPoint, splitTorusTrace] + field_simp + ring + +/-- Every iterate of the split-fiber rotation multiplies the eigen-coordinate by the matching +power of the eigenvalue. -/ +theorem iterate_normalizedRotate1_splitFiberPoint (w s : Fˣ) (n : ℕ) : + (normalizedRotate1^[n]) (splitFiberPoint w s) = splitFiberPoint w (s * w ^ n) := by + induction n with + | zero => simp + | succ n ih => + rw [Function.iterate_succ_apply', ih, normalizedRotate1_splitFiberPoint] + congr 1 + rw [pow_succ, mul_assoc] + +theorem iterate_normalizedRotate1_splitFiberPoint_eq_self_iff + (w s : Fˣ) (hw : (w : F) ^ 2 ≠ 1) (n : ℕ) : + (normalizedRotate1^[n]) (splitFiberPoint w s) = splitFiberPoint w s ↔ w ^ n = 1 := by + rw [iterate_normalizedRotate1_splitFiberPoint] + constructor + · intro hpoint + have hcoordinate := congrArg (splitFiberFirstEigenCoordinate w) hpoint + rw [splitFiberFirstEigenCoordinate_point w (s * w ^ n) hw, + splitFiberFirstEigenCoordinate_point w s hw] at hcoordinate + have hunit : s * w ^ n = s * 1 := by + apply Units.ext + simpa using hcoordinate + exact mul_left_cancel hunit + · intro hpower + rw [hpower, mul_one] + +/-- The finite cycle obtained from one full split rotation period. -/ +noncomputable def splitRotationCycle (w s : Fˣ) : Finset (NormalizedPoint F) := by + classical + exact (Finset.range (orderOf w)).image fun n => + (normalizedRotate1^[n]) (splitFiberPoint w s) + +/-- The split rotation cycle has exactly the multiplicative order of its eigenvalue. -/ +theorem splitRotationCycle_card (w s : Fˣ) (hw : (w : F) ^ 2 ≠ 1) : + (splitRotationCycle w s).card = orderOf w := by + classical + let f : ℕ → NormalizedPoint F := fun n => + (normalizedRotate1^[n]) (splitFiberPoint w s) + have hinjective : Set.InjOn f (Finset.range (orderOf w)) := by + intro n hn m hm hequal + have hn' : n < orderOf w := by simpa using hn + have hm' : m < orderOf w := by simpa using hm + change (normalizedRotate1^[n]) (splitFiberPoint w s) = + (normalizedRotate1^[m]) (splitFiberPoint w s) at hequal + rw [iterate_normalizedRotate1_splitFiberPoint, + iterate_normalizedRotate1_splitFiberPoint] at hequal + have hcoordinate := congrArg (splitFiberFirstEigenCoordinate w) hequal + rw [splitFiberFirstEigenCoordinate_point w (s * w ^ n) hw, + splitFiberFirstEigenCoordinate_point w (s * w ^ m) hw] at hcoordinate + have hpowers : w ^ n = w ^ m := by + have hunit : s * w ^ n = s * w ^ m := by + apply Units.ext + simpa using hcoordinate + exact mul_left_cancel hunit + exact pow_injOn_Iio_orderOf hn' hm' hpowers + calc + (splitRotationCycle w s).card = ((Finset.range (orderOf w)).image f).card := by + rfl + _ = (Finset.range (orderOf w)).card := Finset.card_image_iff.mpr hinjective + _ = orderOf w := Finset.card_range _ + +/-- Replacing the eigenvalue order by the already-proved matrix rotation order connects the +explicit split cycle to the project's canonical `rotationOrder`. -/ +theorem splitRotationCycle_card_eq_rotationOrder + (w s : Fˣ) (hw : (w : F) ^ 2 ≠ 1) : + (splitRotationCycle w s).card = rotationOrder (splitTorusTrace w) := by + rw [splitRotationCycle_card w s hw, rotationOrder_splitTorusTrace w hw] + +/-- Consequently a finite split fiber with nonzero trace has exactly one fewer point than the +base field. -/ +theorem splitFiber_card + [Finite F] (w : Fˣ) (hw : (w : F) ^ 2 ≠ 1) + (htrace : splitTorusTrace w ≠ 0) : + Nat.card ↑(normalizedFiber1 (splitTorusTrace w)) = Nat.card F - 1 := by + rw [← Nat.card_units] + exact Nat.card_congr (splitFiberEquiv w hw htrace).symm + +theorem splitNormalizedFiber_zmod_natCard + (p : ℕ) [Fact p.Prime] (w : (ZMod p)ˣ) + (hw : (w : ZMod p) ^ 2 ≠ 1) (htrace : splitTorusTrace w ≠ 0) : + Nat.card ↑(normalizedFiber1 (splitTorusTrace w)) = p - 1 := by + rw [splitFiber_card w hw htrace, Nat.card_zmod] + +end SplitFiber + +section TraceZeroObstruction + +/-- The punctured normalized fiber used by the paper's conic sections. -/ +def normalizedPuncturedFiber1 {R : Type u} [CommRing R] (a : R) : + Set (NormalizedPoint R) := + normalizedFiber1 a \ {normalizedOrigin} + +/-- A computable finite presentation of a normalized fixed-coordinate fiber. -/ +def normalizedFiber1Finset (R : Type u) [CommRing R] [Fintype R] [DecidableEq R] + (a : R) : Finset (NormalizedPoint R) := + Finset.univ.filter fun x => normalizedPolynomial x = 0 ∧ x.u1 = a + +/-- A computable finite presentation of a punctured normalized fixed-coordinate fiber. -/ +def normalizedPuncturedFiber1Finset + (R : Type u) [CommRing R] [Fintype R] [DecidableEq R] (a : R) : + Finset (NormalizedPoint R) := + (normalizedFiber1Finset R a).erase normalizedOrigin + +@[simp] +theorem mem_normalizedFiber1Finset_iff + {R : Type u} [CommRing R] [Fintype R] [DecidableEq R] + {a : R} {x : NormalizedPoint R} : + x ∈ normalizedFiber1Finset R a ↔ x ∈ normalizedFiber1 a := by + simp [normalizedFiber1Finset, normalizedFiber1, IsNormalizedMarkoff] + +@[simp] +theorem mem_normalizedPuncturedFiber1Finset_iff + {R : Type u} [CommRing R] [Fintype R] [DecidableEq R] + {a : R} {x : NormalizedPoint R} : + x ∈ normalizedPuncturedFiber1Finset R a ↔ x ∈ normalizedPuncturedFiber1 a := by + simp [normalizedPuncturedFiber1Finset, normalizedPuncturedFiber1, and_comm] + +/-- The set-theoretic and computable-finset presentations have the same elements. -/ +def normalizedPuncturedFiber1EquivFinset + (R : Type u) [CommRing R] [Fintype R] [DecidableEq R] (a : R) : + ↑(normalizedPuncturedFiber1 a) ≃ ↑(normalizedPuncturedFiber1Finset R a) where + toFun x := ⟨x, mem_normalizedPuncturedFiber1Finset_iff.mpr x.property⟩ + invFun x := ⟨x, mem_normalizedPuncturedFiber1Finset_iff.mp x.property⟩ + left_inv _ := rfl + right_inv _ := rfl + +/-- At the split semisimple trace zero over `ZMod 5`, the full affine fiber has nine points. -/ +theorem normalizedFiber1_zero_zmod_five_card : + (normalizedFiber1Finset (ZMod 5) 0).card = 9 := by + decide + +/-- Removing the singular origin leaves eight points, not the four predicted by the paper's +uniform `p - 1` assertion for split semisimple fibers. -/ +theorem normalizedPuncturedFiber1_zero_zmod_five_card : + (normalizedPuncturedFiber1Finset (ZMod 5) 0).card = 8 := by + decide + +/-- Thus the trace-zero punctured fiber cannot be equivalent to the multiplicative group, which +has four elements. This is the exact obstruction requiring the nonzero-trace hypothesis above. -/ +theorem no_split_torus_equiv_normalizedPuncturedFiber1_zero_zmod_five : + ¬ Nonempty ((ZMod 5)ˣ ≃ ↑(normalizedPuncturedFiber1 (0 : ZMod 5))) := by + rintro ⟨e⟩ + let e' := e.trans (normalizedPuncturedFiber1EquivFinset (ZMod 5) 0) + have hcard := Fintype.card_congr e' + have hunits : Fintype.card (ZMod 5)ˣ = 4 := by decide + rw [hunits, Fintype.card_coe, + normalizedPuncturedFiber1_zero_zmod_five_card] at hcard + omega + +end TraceZeroObstruction + +section QuadraticNormFiber + +variable (p : ℕ) [Fact p.Prime] + +/-- The norm homomorphism on units of the canonical quadratic extension. -/ +noncomputable def quadraticNormUnitsHom : + (quadraticFiniteField p)ˣ →* (ZMod p)ˣ := + Units.map (Algebra.norm (ZMod p) (S := quadraticFiniteField p)) + +/-- A nonzero norm fiber in the canonical quadratic extension. -/ +noncomputable def quadraticNormFiber (k : (ZMod p)ˣ) : + Set (quadraticFiniteField p)ˣ := + quadraticNormUnitsHom p ⁻¹' {k} + +/-- Every nonzero norm fiber is a torsor for the concrete quadratic norm-one torus. -/ +noncomputable def quadraticNormFiberEquivNormOne (k : (ZMod p)ˣ) : + ↑(quadraticNormFiber p k) ≃ quadraticNormOneTorus p := by + change ↑((quadraticNormUnitsHom p) ⁻¹' {k}) ≃ + (quadraticNormUnitsHom p).ker + exact MonoidHom.fiberEquivKerOfSurjective + (FiniteField.unitsMap_norm_surjective (ZMod p) (quadraticFiniteField p)) k + +/-- The equality-form fiber used by `Equiv.sigmaFiberEquiv` is the same norm torsor. -/ +noncomputable def quadraticNormEquationFiberEquivNormOne (k : (ZMod p)ˣ) : + {s : (quadraticFiniteField p)ˣ // quadraticNormUnitsHom p s = k} ≃ + quadraticNormOneTorus p := by + let equationToSet : + {s : (quadraticFiniteField p)ˣ // quadraticNormUnitsHom p s = k} ≃ + ↑(quadraticNormFiber p k) := + { toFun := fun s => ⟨s, by + change quadraticNormUnitsHom p s ∈ ({k} : Set (ZMod p)ˣ) + simpa using s.property⟩ + invFun := fun s => ⟨s, by + have hs := s.property + change quadraticNormUnitsHom p s ∈ ({k} : Set (ZMod p)ˣ) at hs + simpa using hs⟩ + left_inv := fun _ => rfl + right_inv := fun _ => rfl } + exact equationToSet.trans (quadraticNormFiberEquivNormOne p k) + +/-- The multiplicative group of the quadratic field is a product of the base-field units and +the norm-one torus, after making the canonical finite-field norm-fiber choices. -/ +noncomputable def quadraticUnitsEquivBaseUnitsProdNormOne : + (quadraticFiniteField p)ˣ ≃ (ZMod p)ˣ × quadraticNormOneTorus p := + (Equiv.sigmaFiberEquiv (quadraticNormUnitsHom p)).symm.trans <| + Equiv.sigmaEquivProdOfEquiv fun k => quadraticNormEquationFiberEquivNormOne p k + +/-- The concrete quadratic norm-one torus has exactly `p + 1` elements. -/ +theorem quadraticNormOneTorus_natCard : Nat.card (quadraticNormOneTorus p) = p + 1 := by + have hcard := Nat.card_congr (quadraticUnitsEquivBaseUnitsProdNormOne p) + rw [Nat.card_units, Nat.card_prod, Nat.card_units, + GaloisField.card p (n := 2) (by norm_num), Nat.card_zmod] at hcard + have hpPositive : 0 < p - 1 := Nat.sub_pos_of_lt (Fact.out : p.Prime).one_lt + apply Nat.eq_of_mul_eq_mul_left hpPositive + calc + (p - 1) * Nat.card (quadraticNormOneTorus p) = p ^ 2 - 1 := hcard.symm + _ = (p - 1) * (p + 1) := by + rw [show p ^ 2 - 1 = (p + 1) * (p - 1) by + simpa using (sq_tsub_sq p 1)] + ring + +/-- Every nonzero quadratic norm fiber has `p + 1` points. -/ +theorem quadraticNormFiber_natCard (k : (ZMod p)ˣ) : + Nat.card ↑(quadraticNormFiber p k) = p + 1 := by + rw [Nat.card_congr (quadraticNormFiberEquivNormOne p k)] + exact quadraticNormOneTorus_natCard p + +private theorem quadraticFiniteField_finrank : + Module.finrank (ZMod p) (quadraticFiniteField p) = 2 := + GaloisField.finrank p (n := 2) (by norm_num) + +/-- The quadratic field trace is the sum of an element and its `p`-power Frobenius conjugate. -/ +theorem algebraMap_quadraticTrace (x : quadraticFiniteField p) : + algebraMap (ZMod p) (quadraticFiniteField p) + (Algebra.trace (ZMod p) (quadraticFiniteField p) x) = + x + x ^ p := by + have h := FiniteField.algebraMap_trace_eq_sum_pow + (ZMod p) (quadraticFiniteField p) x + rw [quadraticFiniteField_finrank p, Nat.card_zmod] at h + simpa [Finset.sum_range_succ] using h + +/-- The quadratic field norm is the product of an element and its `p`-power Frobenius +conjugate. -/ +theorem algebraMap_quadraticNorm (x : quadraticFiniteField p) : + algebraMap (ZMod p) (quadraticFiniteField p) + (Algebra.norm (ZMod p) x) = x * x ^ p := by + have h := FiniteField.algebraMap_norm_eq_prod_pow + (ZMod p) (quadraticFiniteField p) x + rw [quadraticFiniteField_finrank p, Nat.card_zmod] at h + simpa [Finset.prod_range_succ] using h + +/-- Frobenius acts on a norm-one eigenvalue by inversion. -/ +theorem quadraticNormOne_frobenius_eq_inv (w : quadraticNormOneTorus p) : + (((w : (quadraticFiniteField p)ˣ) : quadraticFiniteField p) ^ p) = + (((w : (quadraticFiniteField p)ˣ)⁻¹ : (quadraticFiniteField p)ˣ) : + quadraticFiniteField p) := by + have hwNorm : Algebra.norm (ZMod p) + ((w : (quadraticFiniteField p)ˣ) : quadraticFiniteField p) = 1 := by + exact congrArg Units.val w.property + have hnorm := algebraMap_quadraticNorm p + ((w : (quadraticFiniteField p)ˣ) : quadraticFiniteField p) + rw [hwNorm, map_one] at hnorm + have hscalar : + (((w : (quadraticFiniteField p)ˣ) : quadraticFiniteField p) ^ p) = + (((w : (quadraticFiniteField p)ˣ) : quadraticFiniteField p)⁻¹) := by + apply (mul_eq_one_iff_eq_inv₀ + (show ((w : (quadraticFiniteField p)ˣ) : quadraticFiniteField p) ≠ 0 by + exact Units.ne_zero _)).mp + rw [mul_comm] + exact hnorm.symm + simpa using hscalar + +/-- Frobenius on a nonzero norm fiber is multiplication by the prescribed norm followed by +inversion. -/ +theorem quadraticNormFiber_frobenius_eq_norm_mul_inv + (k : (ZMod p)ˣ) (s : ↑(quadraticNormFiber p k)) : + ((s.1 : quadraticFiniteField p) ^ p) = + algebraMap (ZMod p) (quadraticFiniteField p) (k : ZMod p) * + ((s.1 : quadraticFiniteField p)⁻¹) := by + have hsNormUnits : quadraticNormUnitsHom p s.1 = k := by + have hs := s.property + change quadraticNormUnitsHom p s.1 ∈ ({k} : Set (ZMod p)ˣ) at hs + simpa only [Set.mem_singleton_iff] using hs + have hsNorm : Algebra.norm (ZMod p) (s.1 : quadraticFiniteField p) = (k : ZMod p) := + congrArg Units.val hsNormUnits + have hnorm := algebraMap_quadraticNorm p (s.1 : quadraticFiniteField p) + rw [hsNorm] at hnorm + field_simp + simpa [mul_comm] using hnorm.symm + +/-- The scalar `t²/(t²-4)` controlling either eigen-coordinate parametrization. -/ +noncomputable def quadraticFiberProduct (t : ZMod p) : ZMod p := + t ^ 2 / (t ^ 2 - 4) + +theorem quadraticFiberProduct_ne_zero (t : ZMod p) + (ht : t ^ 2 ≠ 4) (ht0 : t ≠ 0) : quadraticFiberProduct p t ≠ 0 := by + exact div_ne_zero (pow_ne_zero 2 ht0) (sub_ne_zero.mpr ht) + +/-- The nonzero scalar as a unit, used to index its norm fiber. -/ +noncomputable def quadraticFiberProductUnit + (t : ZMod p) (ht : t ^ 2 ≠ 4) (ht0 : t ≠ 0) : + (ZMod p)ˣ := + Units.mk0 (quadraticFiberProduct p t) (quadraticFiberProduct_ne_zero p t ht ht0) + +/-- The norm fiber occurring in the paper's nonsplit conic parametrization. -/ +noncomputable def quadraticConicNormFiber + (t : ZMod p) (ht : t ^ 2 ≠ 4) (ht0 : t ≠ 0) : + Set (quadraticFiniteField p)ˣ := + quadraticNormFiber p (quadraticFiberProductUnit p t ht ht0) + +/-- Coordinatewise scalar extension of a normalized point. -/ +noncomputable def algebraMapNormalizedPoint (x : NormalizedPoint (ZMod p)) : + NormalizedPoint (quadraticFiniteField p) := + ⟨algebraMap (ZMod p) (quadraticFiniteField p) x.u1, + algebraMap (ZMod p) (quadraticFiniteField p) x.u2, + algebraMap (ZMod p) (quadraticFiniteField p) x.u3⟩ + +theorem normalizedPolynomial_algebraMapNormalizedPoint + (x : NormalizedPoint (ZMod p)) : + normalizedPolynomial (algebraMapNormalizedPoint p x) = + algebraMap (ZMod p) (quadraticFiniteField p) (normalizedPolynomial x) := by + simp [normalizedPolynomial, algebraMapNormalizedPoint] + +/-- Trace coordinates turn a point of the prescribed norm fiber into a normalized base-field +point. -/ +noncomputable def quadraticNormFiberPoint + (t : ZMod p) (ht : t ^ 2 ≠ 4) (ht0 : t ≠ 0) + (w : quadraticNormOneTorus p) + (s : ↑(quadraticConicNormFiber p t ht ht0)) : NormalizedPoint (ZMod p) := + ⟨t, + Algebra.trace (ZMod p) (quadraticFiniteField p) + (s.1 : quadraticFiniteField p), + Algebra.trace (ZMod p) (quadraticFiniteField p) + ((s.1 : quadraticFiniteField p) * + ((w : (quadraticFiniteField p)ˣ) : quadraticFiniteField p))⟩ + +theorem algebraMap_quadraticFiberProduct + (t : ZMod p) (w : quadraticNormOneTorus p) + (htrace : quadraticNormOneTrace p w = t) : + algebraMap (ZMod p) (quadraticFiniteField p) (quadraticFiberProduct p t) = + splitFiberProduct (w : (quadraticFiniteField p)ˣ) := by + have htraceExtension : + algebraMap (ZMod p) (quadraticFiniteField p) t = + splitTorusTrace (w : (quadraticFiniteField p)ˣ) := by + rw [← htrace] + exact algebraMap_quadraticNormOneTrace p w + simp [quadraticFiberProduct, splitFiberProduct, htraceExtension, map_ofNat] + +theorem algebraMap_quadraticNormFiberPoint + (t : ZMod p) (ht : t ^ 2 ≠ 4) (ht0 : t ≠ 0) + (w : quadraticNormOneTorus p) (htrace : quadraticNormOneTrace p w = t) + (s : ↑(quadraticConicNormFiber p t ht ht0)) : + algebraMapNormalizedPoint p (quadraticNormFiberPoint p t ht ht0 w s) = + splitFiberPoint (w : (quadraticFiniteField p)ˣ) s.1 := by + let k := quadraticFiberProductUnit p t ht ht0 + have hsFrobenius := quadraticNormFiber_frobenius_eq_norm_mul_inv p k s + have hwFrobenius := quadraticNormOne_frobenius_eq_inv p w + have hk : + algebraMap (ZMod p) (quadraticFiniteField p) (k : ZMod p) = + splitFiberProduct (w : (quadraticFiniteField p)ˣ) := by + exact algebraMap_quadraticFiberProduct p t w htrace + ext + · change algebraMap (ZMod p) (quadraticFiniteField p) t = + splitTorusTrace (w : (quadraticFiniteField p)ˣ) + rw [← htrace] + exact algebraMap_quadraticNormOneTrace p w + · change algebraMap (ZMod p) (quadraticFiniteField p) + (Algebra.trace (ZMod p) (quadraticFiniteField p) + (s.1 : quadraticFiniteField p)) = _ + rw [algebraMap_quadraticTrace, hsFrobenius, hk] + simp [splitFiberPoint] + · change algebraMap (ZMod p) (quadraticFiniteField p) + (Algebra.trace (ZMod p) (quadraticFiniteField p) + ((s.1 : quadraticFiniteField p) * + ((w : (quadraticFiniteField p)ˣ) : quadraticFiniteField p))) = _ + rw [algebraMap_quadraticTrace, mul_pow, hsFrobenius, hwFrobenius, hk] + simp [splitFiberPoint] + +theorem quadraticNormFiberPoint_mem + (t : ZMod p) (ht : t ^ 2 ≠ 4) (ht0 : t ≠ 0) + (w : quadraticNormOneTorus p) (htrace : quadraticNormOneTrace p w = t) + (hw : (((w : (quadraticFiniteField p)ˣ) : quadraticFiniteField p) ^ 2 ≠ 1)) + (s : ↑(quadraticConicNormFiber p t ht ht0)) : + quadraticNormFiberPoint p t ht ht0 w s ∈ normalizedFiber1 t := by + constructor + · change normalizedPolynomial (quadraticNormFiberPoint p t ht ht0 w s) = 0 + apply (algebraMap (ZMod p) (quadraticFiniteField p)).injective + rw [← normalizedPolynomial_algebraMapNormalizedPoint] + rw [algebraMap_quadraticNormFiberPoint p t ht ht0 w htrace s] + rw [map_zero] + simpa only [IsNormalizedMarkoff] using + (splitFiberPoint_mem (w : (quadraticFiniteField p)ˣ) s.1 hw).1 + · rfl + +/-- Multiplication by a norm-one element preserves every nonzero norm fiber. -/ +noncomputable def quadraticNormFiberMulNormOne + (k : (ZMod p)ˣ) (s : ↑(quadraticNormFiber p k)) + (g : quadraticNormOneTorus p) : ↑(quadraticNormFiber p k) := by + refine ⟨s.1 * (g : (quadraticFiniteField p)ˣ), ?_⟩ + have hs := s.property + change quadraticNormUnitsHom p s.1 ∈ ({k} : Set (ZMod p)ˣ) at hs + have hg := g.property + change quadraticNormUnitsHom p (g : (quadraticFiniteField p)ˣ) = 1 at hg + change quadraticNormUnitsHom p (s.1 * (g : (quadraticFiniteField p)ˣ)) ∈ + ({k} : Set (ZMod p)ˣ) + rw [Set.mem_singleton_iff, map_mul, Set.mem_singleton_iff.mp hs, hg, mul_one] + +theorem algebraMapNormalizedPoint_injective : + Function.Injective (algebraMapNormalizedPoint p) := by + intro x y h + ext + · apply (algebraMap (ZMod p) (quadraticFiniteField p)).injective + exact congrArg NormalizedPoint.u1 h + · apply (algebraMap (ZMod p) (quadraticFiniteField p)).injective + exact congrArg NormalizedPoint.u2 h + · apply (algebraMap (ZMod p) (quadraticFiniteField p)).injective + exact congrArg NormalizedPoint.u3 h + +theorem algebraMapNormalizedPoint_normalizedRotate1 (x : NormalizedPoint (ZMod p)) : + algebraMapNormalizedPoint p (normalizedRotate1 x) = + normalizedRotate1 (algebraMapNormalizedPoint p x) := by + ext <;> simp [algebraMapNormalizedPoint, normalizedRotate1] + +theorem algebraMap_zmod_pow_card (a : ZMod p) : + (algebraMap (ZMod p) (quadraticFiniteField p) a) ^ p = + algebraMap (ZMod p) (quadraticFiniteField p) a := by + rw [← map_pow, ZMod.pow_card] + +/-- A base-field fiber point, viewed on the diagonalized fiber in the quadratic extension. -/ +noncomputable def algebraMapNormalizedFiberPoint + (t : ZMod p) (w : quadraticNormOneTorus p) + (htrace : quadraticNormOneTrace p w = t) + (x : ↑(normalizedFiber1 t)) : + ↑(normalizedFiber1 (splitTorusTrace (w : (quadraticFiniteField p)ˣ))) := by + refine ⟨algebraMapNormalizedPoint p x, ?_⟩ + constructor + · change normalizedPolynomial (algebraMapNormalizedPoint p x) = 0 + rw [normalizedPolynomial_algebraMapNormalizedPoint] + rw [x.property.1] + exact map_zero _ + · change algebraMap (ZMod p) (quadraticFiniteField p) x.val.u1 = + splitTorusTrace (w : (quadraticFiniteField p)ˣ) + rw [x.property.2, ← htrace] + exact algebraMap_quadraticNormOneTrace p w + +/-- For a base-field point, Frobenius exchanges its two eigen-coordinates in the quadratic +extension. -/ +theorem quadraticFiberFirstEigenCoordinate_frobenius + (t : ZMod p) (w : quadraticNormOneTorus p) + (hw : (((w : (quadraticFiniteField p)ˣ) : quadraticFiniteField p) ^ 2 ≠ 1)) + (x : ↑(normalizedFiber1 t)) : + (splitFiberFirstEigenCoordinate (w : (quadraticFiniteField p)ˣ) + (algebraMapNormalizedPoint p x)) ^ p = + splitFiberSecondEigenCoordinate (w : (quadraticFiniteField p)ˣ) + (algebraMapNormalizedPoint p x) := by + have hwFrobenius := quadraticNormOne_frobenius_eq_inv p w + have hwInverseFrobenius : + ((((w : (quadraticFiniteField p)ˣ)⁻¹ : (quadraticFiniteField p)ˣ) : + quadraticFiniteField p) ^ p) = + ((w : (quadraticFiniteField p)ˣ) : quadraticFiniteField p) := by + have hwFrobeniusScalar : + (((w : (quadraticFiniteField p)ˣ) : quadraticFiniteField p) ^ p) = + (((w : (quadraticFiniteField p)ˣ) : quadraticFiniteField p)⁻¹) := by + simpa using hwFrobenius + have hscalar : + ((((w : (quadraticFiniteField p)ˣ) : quadraticFiniteField p)⁻¹) ^ p) = + ((w : (quadraticFiniteField p)ˣ) : quadraticFiniteField p) := by + rw [inv_pow, hwFrobeniusScalar, inv_inv] + simpa using hscalar + rw [splitFiberFirstEigenCoordinate, splitFiberSecondEigenCoordinate, div_pow, + sub_pow_char, mul_pow, sub_pow_char] + change + ((algebraMap (ZMod p) (quadraticFiniteField p) x.val.u3) ^ p - + ((((w : (quadraticFiniteField p)ˣ)⁻¹ : (quadraticFiniteField p)ˣ) : + quadraticFiniteField p) ^ p) * + (algebraMap (ZMod p) (quadraticFiniteField p) x.val.u2) ^ p) / + (((w : (quadraticFiniteField p)ˣ) : quadraticFiniteField p) ^ p - + ((((w : (quadraticFiniteField p)ˣ)⁻¹ : (quadraticFiniteField p)ˣ) : + quadraticFiniteField p) ^ p)) = _ + rw [algebraMap_zmod_pow_card, algebraMap_zmod_pow_card, + hwFrobenius, hwInverseFrobenius] + have hdifference := splitEigenvalueDifference_ne_zero + (w : (quadraticFiniteField p)ˣ) hw + simp only [algebraMapNormalizedPoint] + rw [show (((w : (quadraticFiniteField p)ˣ)⁻¹ : (quadraticFiniteField p)ˣ) : + quadraticFiniteField p) - + ((w : (quadraticFiniteField p)ˣ) : quadraticFiniteField p) = + -(((w : (quadraticFiniteField p)ˣ) : quadraticFiniteField p) - + (((w : (quadraticFiniteField p)ˣ)⁻¹ : (quadraticFiniteField p)ˣ) : + quadraticFiniteField p)) by ring] + field_simp [hdifference] + ring + +/-- Recover the first extension-field eigen-coordinate from a base-field conic point and prove +that it lies in the prescribed norm fiber. -/ +noncomputable def quadraticNormFiberParameter + (t : ZMod p) (ht : t ^ 2 ≠ 4) (ht0 : t ≠ 0) + (w : quadraticNormOneTorus p) (htrace : quadraticNormOneTrace p w = t) + (hw : (((w : (quadraticFiniteField p)ˣ) : quadraticFiniteField p) ^ 2 ≠ 1)) + (x : ↑(normalizedFiber1 t)) : + ↑(quadraticConicNormFiber p t ht ht0) := by + let extensionPoint := algebraMapNormalizedFiberPoint p t w htrace x + have htraceExtension : + splitTorusTrace (w : (quadraticFiniteField p)ˣ) ≠ 0 := by + rw [← algebraMap_quadraticNormOneTrace p w, htrace] + simpa using (algebraMap (ZMod p) (quadraticFiniteField p)).injective.ne ht0 + let parameterValue := splitFiberFirstEigenCoordinate + (w : (quadraticFiniteField p)ˣ) extensionPoint + have hparameterValue : parameterValue ≠ 0 := + splitFiberFirstEigenCoordinate_ne_zero + (w : (quadraticFiniteField p)ˣ) hw htraceExtension extensionPoint + let parameterUnit : (quadraticFiniteField p)ˣ := + Units.mk0 parameterValue hparameterValue + refine ⟨parameterUnit, ?_⟩ + change parameterUnit ∈ quadraticNormFiber p (quadraticFiberProductUnit p t ht ht0) + change quadraticNormUnitsHom p parameterUnit ∈ + ({quadraticFiberProductUnit p t ht ht0} : Set (ZMod p)ˣ) + rw [Set.mem_singleton_iff] + apply Units.ext + change Algebra.norm (ZMod p) parameterValue = quadraticFiberProduct p t + apply (algebraMap (ZMod p) (quadraticFiniteField p)).injective + rw [algebraMap_quadraticNorm] + rw [show parameterValue ^ p = + splitFiberSecondEigenCoordinate (w : (quadraticFiniteField p)ˣ) + (algebraMapNormalizedPoint p x) by + exact quadraticFiberFirstEigenCoordinate_frobenius p t w hw x] + rw [algebraMap_quadraticFiberProduct p t w htrace] + exact splitFiberEigenCoordinates_product + (w : (quadraticFiniteField p)ˣ) hw extensionPoint + +theorem quadraticNormFiberParameter_point + (t : ZMod p) (ht : t ^ 2 ≠ 4) (ht0 : t ≠ 0) + (w : quadraticNormOneTorus p) (htrace : quadraticNormOneTrace p w = t) + (hw : (((w : (quadraticFiniteField p)ˣ) : quadraticFiniteField p) ^ 2 ≠ 1)) + (s : ↑(quadraticConicNormFiber p t ht ht0)) : + quadraticNormFiberParameter p t ht ht0 w htrace hw + ⟨quadraticNormFiberPoint p t ht ht0 w s, + quadraticNormFiberPoint_mem p t ht ht0 w htrace hw s⟩ = s := by + apply Subtype.ext + apply Units.ext + change splitFiberFirstEigenCoordinate (w : (quadraticFiniteField p)ˣ) + (algebraMapNormalizedPoint p (quadraticNormFiberPoint p t ht ht0 w s)) = + (s.1 : quadraticFiniteField p) + rw [algebraMap_quadraticNormFiberPoint p t ht ht0 w htrace s] + exact splitFiberFirstEigenCoordinate_point + (w : (quadraticFiniteField p)ˣ) s.1 hw + +theorem quadraticNormFiberPoint_parameter + (t : ZMod p) (ht : t ^ 2 ≠ 4) (ht0 : t ≠ 0) + (w : quadraticNormOneTorus p) (htrace : quadraticNormOneTrace p w = t) + (hw : (((w : (quadraticFiniteField p)ˣ) : quadraticFiniteField p) ^ 2 ≠ 1)) + (x : ↑(normalizedFiber1 t)) : + quadraticNormFiberPoint p t ht ht0 w + (quadraticNormFiberParameter p t ht ht0 w htrace hw x) = x := by + apply algebraMapNormalizedPoint_injective p + erw [algebraMap_quadraticNormFiberPoint p t ht ht0 w htrace] + let extensionPoint := algebraMapNormalizedFiberPoint p t w htrace x + have htraceExtension : + splitTorusTrace (w : (quadraticFiniteField p)ˣ) ≠ 0 := by + rw [← algebraMap_quadraticNormOneTrace p w, htrace] + simpa using (algebraMap (ZMod p) (quadraticFiniteField p)).injective.ne ht0 + have hright := (splitFiberEquiv + (w : (quadraticFiniteField p)ˣ) hw htraceExtension).apply_symm_apply extensionPoint + exact congrArg Subtype.val hright + +/-- The nonsplit nonzero normalized fiber is explicitly equivalent to its quadratic norm fiber. -/ +noncomputable def quadraticNormFiberEquiv + (t : ZMod p) (ht : t ^ 2 ≠ 4) (ht0 : t ≠ 0) + (w : quadraticNormOneTorus p) (htrace : quadraticNormOneTrace p w = t) + (hw : (((w : (quadraticFiniteField p)ˣ) : quadraticFiniteField p) ^ 2 ≠ 1)) : + ↑(quadraticConicNormFiber p t ht ht0) ≃ ↑(normalizedFiber1 t) where + toFun s := ⟨quadraticNormFiberPoint p t ht ht0 w s, + quadraticNormFiberPoint_mem p t ht ht0 w htrace hw s⟩ + invFun := quadraticNormFiberParameter p t ht ht0 w htrace hw + left_inv := quadraticNormFiberParameter_point p t ht ht0 w htrace hw + right_inv x := by + apply Subtype.ext + exact quadraticNormFiberPoint_parameter p t ht ht0 w htrace hw x + +/-- Consequently the nonsplit nonzero normalized fiber has exactly `p + 1` points. -/ +theorem nonsplitNormalizedFiber_natCard + (t : ZMod p) (ht : t ^ 2 ≠ 4) (ht0 : t ≠ 0) + (w : quadraticNormOneTorus p) (htrace : quadraticNormOneTrace p w = t) + (hw : (((w : (quadraticFiniteField p)ˣ) : quadraticFiniteField p) ^ 2 ≠ 1)) : + Nat.card ↑(normalizedFiber1 t) = p + 1 := by + rw [← Nat.card_congr (quadraticNormFiberEquiv p t ht ht0 w htrace hw)] + exact quadraticNormFiber_natCard p (quadraticFiberProductUnit p t ht ht0) + +/-- On the nonsplit norm-fiber parametrization, normalized rotation is multiplication by its +norm-one eigenvalue. -/ +theorem normalizedRotate1_quadraticNormFiberPoint + (t : ZMod p) (ht : t ^ 2 ≠ 4) (ht0 : t ≠ 0) + (w : quadraticNormOneTorus p) (htrace : quadraticNormOneTrace p w = t) + (s : ↑(quadraticConicNormFiber p t ht ht0)) : + normalizedRotate1 (quadraticNormFiberPoint p t ht ht0 w s) = + quadraticNormFiberPoint p t ht ht0 w + (quadraticNormFiberMulNormOne p (quadraticFiberProductUnit p t ht ht0) s w) := by + apply algebraMapNormalizedPoint_injective p + rw [algebraMapNormalizedPoint_normalizedRotate1] + rw [algebraMap_quadraticNormFiberPoint p t ht ht0 w htrace s] + erw [algebraMap_quadraticNormFiberPoint p t ht ht0 w htrace] + rw [normalizedRotate1_splitFiberPoint] + rfl + +theorem quadraticNormFiberMulNormOne_assoc + (k : (ZMod p)ˣ) (s : ↑(quadraticNormFiber p k)) + (g h : quadraticNormOneTorus p) : + quadraticNormFiberMulNormOne p k (quadraticNormFiberMulNormOne p k s g) h = + quadraticNormFiberMulNormOne p k s (g * h) := by + apply Subtype.ext + simp [quadraticNormFiberMulNormOne, mul_assoc] + +theorem quadraticNormFiberMulNormOne_one + (k : (ZMod p)ˣ) (s : ↑(quadraticNormFiber p k)) : + quadraticNormFiberMulNormOne p k s 1 = s := by + apply Subtype.ext + simp [quadraticNormFiberMulNormOne] + +theorem quadraticNormFiberMulNormOne_pow + (k : (ZMod p)ˣ) (s : ↑(quadraticNormFiber p k)) + (g : quadraticNormOneTorus p) (n : ℕ) : + (quadraticNormFiberMulNormOne p k s (g ^ n)).1 = + s.1 * (g : (quadraticFiniteField p)ˣ) ^ n := by + rfl + +theorem quadraticNormFiberPoint_injective + (t : ZMod p) (ht : t ^ 2 ≠ 4) (ht0 : t ≠ 0) + (w : quadraticNormOneTorus p) (htrace : quadraticNormOneTrace p w = t) + (hw : (((w : (quadraticFiniteField p)ˣ) : quadraticFiniteField p) ^ 2 ≠ 1)) : + Function.Injective (quadraticNormFiberPoint p t ht ht0 w) := by + intro s r hpoint + have hextension := congrArg (algebraMapNormalizedPoint p) hpoint + rw [algebraMap_quadraticNormFiberPoint p t ht ht0 w htrace s, + algebraMap_quadraticNormFiberPoint p t ht ht0 w htrace r] at hextension + have hcoordinate := congrArg + (splitFiberFirstEigenCoordinate (w : (quadraticFiniteField p)ˣ)) hextension + rw [splitFiberFirstEigenCoordinate_point (w : (quadraticFiniteField p)ˣ) s.1 hw, + splitFiberFirstEigenCoordinate_point (w : (quadraticFiniteField p)ˣ) r.1 hw] at hcoordinate + apply Subtype.ext + apply Units.ext + exact hcoordinate + +theorem iterate_normalizedRotate1_quadraticNormFiberPoint + (t : ZMod p) (ht : t ^ 2 ≠ 4) (ht0 : t ≠ 0) + (w : quadraticNormOneTorus p) (htrace : quadraticNormOneTrace p w = t) + (s : ↑(quadraticConicNormFiber p t ht ht0)) (n : ℕ) : + (normalizedRotate1^[n]) (quadraticNormFiberPoint p t ht ht0 w s) = + quadraticNormFiberPoint p t ht ht0 w + (quadraticNormFiberMulNormOne p (quadraticFiberProductUnit p t ht ht0) s (w ^ n)) := by + induction n with + | zero => + simp only [Function.iterate_zero, id_eq, pow_zero] + congr 1 + exact (quadraticNormFiberMulNormOne_one p _ s).symm + | succ n ih => + erw [Function.iterate_succ_apply', ih, + normalizedRotate1_quadraticNormFiberPoint p t ht ht0 w htrace] + congr 1 + erw [quadraticNormFiberMulNormOne_assoc, pow_succ] + +theorem iterate_normalizedRotate1_quadraticNormFiberPoint_eq_self_iff + (t : ZMod p) (ht : t ^ 2 ≠ 4) (ht0 : t ≠ 0) + (w : quadraticNormOneTorus p) (htrace : quadraticNormOneTrace p w = t) + (hw : (((w : (quadraticFiniteField p)ˣ) : quadraticFiniteField p) ^ 2 ≠ 1)) + (s : ↑(quadraticConicNormFiber p t ht ht0)) (n : ℕ) : + (normalizedRotate1^[n]) (quadraticNormFiberPoint p t ht ht0 w s) = + quadraticNormFiberPoint p t ht ht0 w s ↔ w ^ n = 1 := by + rw [iterate_normalizedRotate1_quadraticNormFiberPoint p t ht ht0 w htrace] + constructor + · intro hpoint + have hparameter := quadraticNormFiberPoint_injective p t ht ht0 w htrace hw hpoint + have hunit : s.1 * ((w ^ n : quadraticNormOneTorus p) : + (quadraticFiniteField p)ˣ) = s.1 * 1 := by + simpa [quadraticNormFiberMulNormOne] using congrArg Subtype.val hparameter + apply Subtype.ext + exact mul_left_cancel hunit + · intro hpower + erw [hpower, quadraticNormFiberMulNormOne_one] + +/-- One full nonsplit rotation cycle, represented in the base-field conic. -/ +noncomputable def quadraticNormFiberRotationCycle + (t : ZMod p) (ht : t ^ 2 ≠ 4) (ht0 : t ≠ 0) + (w : quadraticNormOneTorus p) + (s : ↑(quadraticConicNormFiber p t ht ht0)) : + Finset (NormalizedPoint (ZMod p)) := by + classical + exact (Finset.range (orderOf w)).image fun n => + (normalizedRotate1^[n]) (quadraticNormFiberPoint p t ht ht0 w s) + +theorem quadraticNormFiberRotationCycle_card + (t : ZMod p) (ht : t ^ 2 ≠ 4) (ht0 : t ≠ 0) + (w : quadraticNormOneTorus p) (htrace : quadraticNormOneTrace p w = t) + (hw : (((w : (quadraticFiniteField p)ˣ) : quadraticFiniteField p) ^ 2 ≠ 1)) + (s : ↑(quadraticConicNormFiber p t ht ht0)) : + (quadraticNormFiberRotationCycle p t ht ht0 w s).card = orderOf w := by + classical + let f : ℕ → NormalizedPoint (ZMod p) := fun n => + (normalizedRotate1^[n]) (quadraticNormFiberPoint p t ht ht0 w s) + have hinjective : Set.InjOn f (Finset.range (orderOf w)) := by + intro n hn m hm hequal + have hn' : n < orderOf w := by simpa using hn + have hm' : m < orderOf w := by simpa using hm + change (normalizedRotate1^[n]) (quadraticNormFiberPoint p t ht ht0 w s) = + (normalizedRotate1^[m]) (quadraticNormFiberPoint p t ht ht0 w s) at hequal + rw [iterate_normalizedRotate1_quadraticNormFiberPoint p t ht ht0 w htrace, + iterate_normalizedRotate1_quadraticNormFiberPoint p t ht ht0 w htrace] at hequal + have hparameter := quadraticNormFiberPoint_injective p t ht ht0 w htrace hw hequal + have hpowers : w ^ n = w ^ m := by + apply Subtype.ext + have hunit : s.1 * ((w ^ n : quadraticNormOneTorus p) : + (quadraticFiniteField p)ˣ) = + s.1 * ((w ^ m : quadraticNormOneTorus p) : (quadraticFiniteField p)ˣ) := + by simpa [quadraticNormFiberMulNormOne] using congrArg Subtype.val hparameter + exact mul_left_cancel hunit + exact pow_injOn_Iio_orderOf hn' hm' hpowers + calc + (quadraticNormFiberRotationCycle p t ht ht0 w s).card = + ((Finset.range (orderOf w)).image f).card := by rfl + _ = (Finset.range (orderOf w)).card := Finset.card_image_iff.mpr hinjective + _ = orderOf w := Finset.card_range _ + +theorem quadraticNormFiberRotationCycle_card_eq_rotationOrder + (t : ZMod p) (ht : t ^ 2 ≠ 4) (ht0 : t ≠ 0) + (w : quadraticNormOneTorus p) (htrace : quadraticNormOneTrace p w = t) + (hw : (((w : (quadraticFiniteField p)ˣ) : quadraticFiniteField p) ^ 2 ≠ 1)) + (s : ↑(quadraticConicNormFiber p t ht ht0)) : + (quadraticNormFiberRotationCycle p t ht ht0 w s).card = rotationOrder t := by + rw [quadraticNormFiberRotationCycle_card p t ht ht0 w htrace hw s] + rw [← htrace, rotationOrder_quadraticNormOneTrace p w hw] + +end QuadraticNormFiber + +section RotationCycles + +variable {F : Type u} [Field F] + +/-- The canonical finite cycle cut out by one full matrix rotation period. -/ +noncomputable def normalizedRotationCycle (t : F) (x : NormalizedPoint F) : + Finset (NormalizedPoint F) := by + classical + exact (Finset.range (rotationOrder t)).image fun n => (normalizedRotate1^[n]) x + +/-- Every point of a nonzero split semisimple fiber has orbit-cycle cardinality equal to the +canonical matrix rotation order. -/ +theorem normalizedRotationCycle_card_split + (w : Fˣ) (hw : (w : F) ^ 2 ≠ 1) (htrace : splitTorusTrace w ≠ 0) + (x : ↑(normalizedFiber1 (splitTorusTrace w))) : + (normalizedRotationCycle (splitTorusTrace w) x).card = + rotationOrder (splitTorusTrace w) := by + let s := (splitFiberEquiv w hw htrace).symm x + have hx : splitFiberPoint w s = x := + congrArg Subtype.val ((splitFiberEquiv w hw htrace).apply_symm_apply x) + simpa [normalizedRotationCycle, splitRotationCycle, hx, + rotationOrder_splitTorusTrace w hw] using + splitRotationCycle_card w s hw + +end RotationCycles + +section QuadraticRotationCycles + +variable (p : ℕ) [Fact p.Prime] + +/-- Every point of a nonzero nonsplit semisimple fiber has orbit-cycle cardinality equal to the +canonical matrix rotation order. -/ +theorem normalizedRotationCycle_card_nonsplit + (t : ZMod p) (ht : t ^ 2 ≠ 4) (ht0 : t ≠ 0) + (w : quadraticNormOneTorus p) (htrace : quadraticNormOneTrace p w = t) + (hw : (((w : (quadraticFiniteField p)ˣ) : quadraticFiniteField p) ^ 2 ≠ 1)) + (x : ↑(normalizedFiber1 t)) : + (normalizedRotationCycle t x).card = rotationOrder t := by + let s := (quadraticNormFiberEquiv p t ht ht0 w htrace hw).symm x + have hx : quadraticNormFiberPoint p t ht ht0 w s = x := + congrArg Subtype.val + ((quadraticNormFiberEquiv p t ht ht0 w htrace hw).apply_symm_apply x) + have horder : rotationOrder t = orderOf w := by + rw [← htrace, rotationOrder_quadraticNormOneTrace p w hw] + have hcycle : normalizedRotationCycle t x = + quadraticNormFiberRotationCycle p t ht ht0 w s := by + classical + ext y + simp [normalizedRotationCycle, quadraticNormFiberRotationCycle, hx, horder] + rw [hcycle] + exact quadraticNormFiberRotationCycle_card_eq_rotationOrder + p t ht ht0 w htrace hw s + +end QuadraticRotationCycles + +section ClassifiedRotationCycles + +/-- Every point of a nonzero nonparabolic normalized fiber has rotation-cycle cardinality equal +to the canonical matrix rotation order. The split/nonsplit classification is consumed here to +obtain the explicit eigenvalue witness required by the two parametrization kernels. -/ +theorem normalizedRotationCycle_card_of_nonzero_nonparabolic + (p : ℕ) [Fact p.Prime] (hpTwo : p ≠ 2) + (t : ZMod p) (ht : t ^ 2 ≠ 4) (ht0 : t ≠ 0) + (x : ↑(normalizedFiber1 t)) : + (normalizedRotationCycle t x).card = rotationOrder t := by + rcases exists_split_or_quadraticNormOneTrace p hpTwo t ht with + ⟨w, htrace, hw⟩ | ⟨w, htrace, hw⟩ + · let xw : ↑(normalizedFiber1 (splitTorusTrace w)) := + ⟨x.1, x.property.1, by simpa [htrace] using x.property.2⟩ + simpa [htrace, xw] using normalizedRotationCycle_card_split w hw + (by simpa [htrace] using ht0) xw + · exact normalizedRotationCycle_card_nonsplit p t ht ht0 w htrace hw x + +end ClassifiedRotationCycles + +section ParabolicRotationCycles + +/-- An even number of trace-`-2` rotations stays on the same parabolic line and translates its +parameter by a multiple of `-4i`. -/ +theorem iterate_two_mul_normalizedRotate1_parabolicLineAtNegTwo + {R : Type u} [CommRing R] (k : ℕ) (i t : R) : + (normalizedRotate1^[2 * k]) (parabolicLineAtNegTwo i t) = + parabolicLineAtNegTwo i (t - (k : R) * (4 * i)) := by + induction k with + | zero => simp + | succ k ih => + rw [show 2 * (k + 1) = 2 + 2 * k by omega, + Function.iterate_add_apply, ih] + change normalizedRotate1 + (normalizedRotate1 (parabolicLineAtNegTwo i (t - (k : R) * (4 * i)))) = _ + rw [normalizedRotate1_twice_parabolicLineAtNegTwo] + congr 1 + push_cast + ring + +/-- An odd number of trace-`-2` rotations lands on the opposite parabolic line. -/ +theorem iterate_two_mul_add_one_normalizedRotate1_parabolicLineAtNegTwo + {R : Type u} [CommRing R] (k : ℕ) (i t : R) : + (normalizedRotate1^[2 * k + 1]) (parabolicLineAtNegTwo i t) = + parabolicLineAtNegTwo (-i) (-(t - (k : R) * (4 * i)) + 2 * i) := by + rw [Function.iterate_succ_apply', + iterate_two_mul_normalizedRotate1_parabolicLineAtNegTwo, + normalizedRotate1_parabolicLineAtNegTwo] + +/-- Every point on either trace-`2` parabolic line has a full rotation cycle of cardinality +`p`, matching the separately computed unipotent matrix order. -/ +theorem normalizedRotationCycle_card_parabolicLineAtTwo + (p : ℕ) [Fact p.Prime] (hpTwo : p ≠ 2) + (i t : ZMod p) (hi : i ^ 2 = -1) : + (normalizedRotationCycle (2 : ZMod p) (parabolicLineAtTwo i t)).card = + rotationOrder (2 : ZMod p) := by + classical + let f : ℕ → NormalizedPoint (ZMod p) := fun n => + (normalizedRotate1^[n]) (parabolicLineAtTwo i t) + have hi0 : i ≠ 0 := by + intro hzero + subst i + norm_num at hi + have htwo : (2 : ZMod p) ≠ 0 := by + intro hzero + have hdvd : p ∣ 2 := (ZMod.natCast_eq_zero_iff 2 p).mp hzero + have hpLe : p ≤ 2 := Nat.le_of_dvd (by norm_num) hdvd + exact hpTwo (Nat.le_antisymm hpLe (Fact.out : p.Prime).two_le) + have hstep : (2 : ZMod p) * i ≠ 0 := mul_ne_zero htwo hi0 + have hinjective : Set.InjOn f (Finset.range p) := by + intro n hn m hm hequal + have hn' : n < p := by simpa using hn + have hm' : m < p := by simpa using hm + change (normalizedRotate1^[n]) (parabolicLineAtTwo i t) = + (normalizedRotate1^[m]) (parabolicLineAtTwo i t) at hequal + rw [iterate_normalizedRotate1_parabolicLineAtTwo, + iterate_normalizedRotate1_parabolicLineAtTwo] at hequal + have hparameter := congrArg NormalizedPoint.u2 hequal + change t + (n : ZMod p) * (2 * i) = t + (m : ZMod p) * (2 * i) at hparameter + have hproducts : (n : ZMod p) * (2 * i) = (m : ZMod p) * (2 * i) := by + exact add_left_cancel hparameter + have hcasts : (n : ZMod p) = (m : ZMod p) := + mul_right_cancel₀ hstep hproducts + rw [ZMod.natCast_eq_natCast_iff'] at hcasts + simpa [Nat.mod_eq_of_lt hn', Nat.mod_eq_of_lt hm'] using hcasts + have horder : rotationOrder (2 : ZMod p) = p := rotationOrder_two p + have hcycle : normalizedRotationCycle (2 : ZMod p) (parabolicLineAtTwo i t) = + (Finset.range p).image f := by + ext y + simp [normalizedRotationCycle, f, horder] + calc + (normalizedRotationCycle (2 : ZMod p) (parabolicLineAtTwo i t)).card = + ((Finset.range p).image f).card := congrArg Finset.card hcycle + _ = (Finset.range p).card := Finset.card_image_iff.mpr hinjective + _ = p := Finset.card_range _ + _ = rotationOrder (2 : ZMod p) := horder.symm + +/-- Every point on either trace-`-2` parabolic line has a full cycle of cardinality `2p`, +matching the separately computed matrix order. -/ +theorem normalizedRotationCycle_card_parabolicLineAtNegTwo + (p : ℕ) [Fact p.Prime] (hpTwo : p ≠ 2) + (i t : ZMod p) (hi : i ^ 2 = -1) : + (normalizedRotationCycle (-2 : ZMod p) (parabolicLineAtNegTwo i t)).card = + rotationOrder (-2 : ZMod p) := by + classical + let f : ℕ → NormalizedPoint (ZMod p) := fun n => + (normalizedRotate1^[n]) (parabolicLineAtNegTwo i t) + have hi0 : i ≠ 0 := by + intro hzero + subst i + norm_num at hi + have htwo : (2 : ZMod p) ≠ 0 := by + intro hzero + have hdvd : p ∣ 2 := (ZMod.natCast_eq_zero_iff 2 p).mp hzero + have hpLe : p ≤ 2 := Nat.le_of_dvd (by norm_num) hdvd + exact hpTwo (Nat.le_antisymm hpLe (Fact.out : p.Prime).two_le) + have hfour : (4 : ZMod p) ≠ 0 := by + rw [show (4 : ZMod p) = (2 : ZMod p) ^ 2 by norm_num] + exact pow_ne_zero 2 htwo + have hstep : (4 : ZMod p) * i ≠ 0 := mul_ne_zero hfour hi0 + have hdisjoint := parabolicLineAtNegTwo_disjoint i hstep + have hinjective : Set.InjOn f (Finset.range (2 * p)) := by + intro n hn m hm hequal + have hn' : n < 2 * p := by simpa using hn + have hm' : m < 2 * p := by simpa using hm + rcases n.even_or_odd' with ⟨k, rfl | rfl⟩ + · rcases m.even_or_odd' with ⟨l, rfl | rfl⟩ + · have hk : k < p := by omega + have hl : l < p := by omega + change (normalizedRotate1^[2 * k]) (parabolicLineAtNegTwo i t) = + (normalizedRotate1^[2 * l]) (parabolicLineAtNegTwo i t) at hequal + rw [iterate_two_mul_normalizedRotate1_parabolicLineAtNegTwo, + iterate_two_mul_normalizedRotate1_parabolicLineAtNegTwo] at hequal + have hparameter := congrArg NormalizedPoint.u2 hequal + change t - (k : ZMod p) * (4 * i) = + t - (l : ZMod p) * (4 * i) at hparameter + have hproducts : (k : ZMod p) * (4 * i) = (l : ZMod p) * (4 * i) := by + linear_combination -hparameter + have hcasts : (k : ZMod p) = (l : ZMod p) := + mul_right_cancel₀ hstep hproducts + rw [ZMod.natCast_eq_natCast_iff'] at hcasts + have hkl : k = l := by + simpa [Nat.mod_eq_of_lt hk, Nat.mod_eq_of_lt hl] using hcasts + omega + · change (normalizedRotate1^[2 * k]) (parabolicLineAtNegTwo i t) = + (normalizedRotate1^[2 * l + 1]) (parabolicLineAtNegTwo i t) at hequal + rw [iterate_two_mul_normalizedRotate1_parabolicLineAtNegTwo, + iterate_two_mul_add_one_normalizedRotate1_parabolicLineAtNegTwo] at hequal + exfalso + exact Set.disjoint_left.mp hdisjoint + ⟨_, rfl⟩ ⟨_, hequal.symm⟩ + · rcases m.even_or_odd' with ⟨l, rfl | rfl⟩ + · change (normalizedRotate1^[2 * k + 1]) (parabolicLineAtNegTwo i t) = + (normalizedRotate1^[2 * l]) (parabolicLineAtNegTwo i t) at hequal + rw [iterate_two_mul_add_one_normalizedRotate1_parabolicLineAtNegTwo, + iterate_two_mul_normalizedRotate1_parabolicLineAtNegTwo] at hequal + exfalso + exact Set.disjoint_left.mp hdisjoint + ⟨_, rfl⟩ ⟨_, hequal⟩ + · have hk : k < p := by omega + have hl : l < p := by omega + change (normalizedRotate1^[2 * k + 1]) (parabolicLineAtNegTwo i t) = + (normalizedRotate1^[2 * l + 1]) (parabolicLineAtNegTwo i t) at hequal + rw [iterate_two_mul_add_one_normalizedRotate1_parabolicLineAtNegTwo, + iterate_two_mul_add_one_normalizedRotate1_parabolicLineAtNegTwo] at hequal + have hparameter := congrArg NormalizedPoint.u2 hequal + change -(t - (k : ZMod p) * (4 * i)) + 2 * i = + -(t - (l : ZMod p) * (4 * i)) + 2 * i at hparameter + have hproducts : (k : ZMod p) * (4 * i) = (l : ZMod p) * (4 * i) := by + linear_combination hparameter + have hcasts : (k : ZMod p) = (l : ZMod p) := + mul_right_cancel₀ hstep hproducts + rw [ZMod.natCast_eq_natCast_iff'] at hcasts + have hkl : k = l := by + simpa [Nat.mod_eq_of_lt hk, Nat.mod_eq_of_lt hl] using hcasts + omega + have horder : rotationOrder (-2 : ZMod p) = 2 * p := rotationOrder_neg_two p hpTwo + have hcycle : normalizedRotationCycle (-2 : ZMod p) (parabolicLineAtNegTwo i t) = + (Finset.range (2 * p)).image f := by + ext y + simp [normalizedRotationCycle, f, horder] + calc + (normalizedRotationCycle (-2 : ZMod p) (parabolicLineAtNegTwo i t)).card = + ((Finset.range (2 * p)).image f).card := congrArg Finset.card hcycle + _ = (Finset.range (2 * p)).card := Finset.card_image_iff.mpr hinjective + _ = 2 * p := Finset.card_range _ + _ = rotationOrder (-2 : ZMod p) := horder.symm + +end ParabolicRotationCycles + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Core/EvenSignAction.lean b/LeanPool/MarkoffModP/BGS/Markoff/Core/EvenSignAction.lean new file mode 100644 index 0000000000..46dae3e27e --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Core/EvenSignAction.lean @@ -0,0 +1,387 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Core.Action + +/-! +# Even sign changes on the Markoff surface + +Changing the signs of exactly two coordinates preserves the Markoff equation. +The four transformations form a Klein four-group. Vieta involutions commute +with them, and coordinate transpositions permute them. Thus `Gamma` normalizes +the even-sign subgroup. +-/ + +@[expose] public section + +namespace BGS.Markoff + +universe u + +/-- The four sign vectors with product one. -/ +inductive EvenSign + | id + | neg12 + | neg13 + | neg23 + deriving DecidableEq, Repr + +instance : Fintype EvenSign where + elems := {.id, .neg12, .neg13, .neg23} + complete x := by cases x <;> simp + +namespace EvenSign + +def mul : EvenSign → EvenSign → EvenSign + | .id, s => s + | s, .id => s + | .neg12, .neg12 => .id + | .neg12, .neg13 => .neg23 + | .neg12, .neg23 => .neg13 + | .neg13, .neg12 => .neg23 + | .neg13, .neg13 => .id + | .neg13, .neg23 => .neg12 + | .neg23, .neg12 => .neg13 + | .neg23, .neg13 => .neg12 + | .neg23, .neg23 => .id + +instance : One EvenSign := ⟨.id⟩ +instance : Mul EvenSign := ⟨mul⟩ +instance : Inv EvenSign := ⟨fun s => s⟩ + +instance : CommGroup EvenSign where + mul_assoc := by decide + one_mul := by decide + mul_one := by decide + inv_mul_cancel := by decide + mul_comm := by decide + +@[simp] theorem one_eq_id : (1 : EvenSign) = .id := rfl +@[simp] theorem inv_eq_self (s : EvenSign) : s⁻¹ = s := rfl +@[simp] theorem card_eq_four : Fintype.card EvenSign = 4 := by decide + +end EvenSign + +/-- Apply an even sign vector to an affine point. -/ +def evenSignPoint {R : Type u} [CommRing R] : EvenSign → Point R → Point R + | .id, x => x + | .neg12, x => ⟨-x.x1, -x.x2, x.x3⟩ + | .neg13, x => ⟨-x.x1, x.x2, -x.x3⟩ + | .neg23, x => ⟨x.x1, -x.x2, -x.x3⟩ + +@[simp] +theorem evenSignPoint_id {R : Type u} [CommRing R] (x : Point R) : + evenSignPoint .id x = x := rfl + +@[simp] +theorem evenSignPoint_mul {R : Type u} [CommRing R] + (s t : EvenSign) (x : Point R) : + evenSignPoint (s * t) x = evenSignPoint s (evenSignPoint t x) := by + change evenSignPoint (EvenSign.mul s t) x = + evenSignPoint s (evenSignPoint t x) + cases s <;> cases t <;> ext <;> simp [evenSignPoint, EvenSign.mul] + +@[simp] +theorem markoffPolynomial_evenSignPoint {R : Type u} [CommRing R] + (s : EvenSign) (x : Point R) : + markoffPolynomial (evenSignPoint s x) = markoffPolynomial x := by + cases s <;> simp [evenSignPoint, markoffPolynomial] + +@[simp] +theorem isMarkoff_evenSignPoint {R : Type u} [CommRing R] + (s : EvenSign) (x : Point R) : + IsMarkoff (evenSignPoint s x) ↔ IsMarkoff x := by + simp only [IsMarkoff, markoffPolynomial_evenSignPoint] + +instance evenSignMulActionMarkoffSurface {R : Type u} [CommRing R] : + MulAction EvenSign (MarkoffSurface R) where + smul s x := ⟨evenSignPoint s x.1, (isMarkoff_evenSignPoint s x.1).2 x.2⟩ + one_smul x := Subtype.ext (evenSignPoint_id x.1) + mul_smul s t x := Subtype.ext (evenSignPoint_mul s t x.1) + +@[simp] +theorem evenSign_smul_surface_coe {R : Type u} [CommRing R] + (s : EvenSign) (x : MarkoffSurface R) : + ((s • x : MarkoffSurface R) : Point R) = evenSignPoint s x.1 := rfl + +@[simp] +theorem evenSign_smul_surfaceOrigin {R : Type u} [CommRing R] (s : EvenSign) : + s • surfaceOrigin R = surfaceOrigin R := by + cases s <;> apply Subtype.ext <;> ext <;> + simp [evenSignPoint, surfaceOrigin, origin] + +theorem evenSign_smul_ne_surfaceOrigin_iff {R : Type u} [CommRing R] + (s : EvenSign) (x : MarkoffSurface R) : + s • x ≠ surfaceOrigin R ↔ x ≠ surfaceOrigin R := by + constructor + · intro hs hx + exact hs (hx ▸ evenSign_smul_surfaceOrigin s) + · intro hx hs + apply hx + calc + x = s⁻¹ • (s • x) := (inv_smul_smul s x).symm + _ = s⁻¹ • surfaceOrigin R := congrArg (s⁻¹ • ·) hs + _ = surfaceOrigin R := evenSign_smul_surfaceOrigin s⁻¹ + +instance evenSignMulActionPuncturedMarkoffSurface {R : Type u} [CommRing R] : + MulAction EvenSign (PuncturedMarkoffSurface R) where + smul s x := ⟨s • x.1, (evenSign_smul_ne_surfaceOrigin_iff s x.1).2 x.2⟩ + one_smul x := Subtype.ext (one_smul EvenSign x.1) + mul_smul s t x := Subtype.ext (mul_smul s t x.1) + +@[simp] +theorem evenSign_smul_punctured_coe {R : Type u} [CommRing R] + (s : EvenSign) (x : PuncturedMarkoffSurface R) : + ((s • x : PuncturedMarkoffSurface R) : MarkoffSurface R) = s • x.1 := rfl + +def evenSignSurfacePermHom (R : Type u) [CommRing R] : + EvenSign →* Equiv.Perm (MarkoffSurface R) := + MulAction.toPermHom EvenSign (MarkoffSurface R) + +@[simp] +theorem evenSignSurfacePermHom_apply {R : Type u} [CommRing R] + (s : EvenSign) (x : MarkoffSurface R) : + evenSignSurfacePermHom R s x = s • x := rfl + +def evenSignSurfaceSubgroup (R : Type u) [CommRing R] : + Subgroup (Equiv.Perm (MarkoffSurface R)) := + (evenSignSurfacePermHom R).range + +@[simp] +theorem vieta1_evenSignPoint {R : Type u} [CommRing R] + (s : EvenSign) (x : Point R) : + vieta1 (evenSignPoint s x) = evenSignPoint s (vieta1 x) := by + cases s <;> ext <;> simp [vieta1, evenSignPoint] <;> ring + +@[simp] +theorem vieta2_evenSignPoint {R : Type u} [CommRing R] + (s : EvenSign) (x : Point R) : + vieta2 (evenSignPoint s x) = evenSignPoint s (vieta2 x) := by + cases s <;> ext <;> simp [vieta2, evenSignPoint] <;> ring + +@[simp] +theorem vieta3_evenSignPoint {R : Type u} [CommRing R] + (s : EvenSign) (x : Point R) : + vieta3 (evenSignPoint s x) = evenSignPoint s (vieta3 x) := by + cases s <;> ext <;> simp [vieta3, evenSignPoint] <;> ring + +def EvenSign.swap12 : EvenSign → EvenSign + | .id => .id + | .neg12 => .neg12 + | .neg13 => .neg23 + | .neg23 => .neg13 + +def EvenSign.swap23 : EvenSign → EvenSign + | .id => .id + | .neg12 => .neg13 + | .neg13 => .neg12 + | .neg23 => .neg23 + +@[simp] theorem EvenSign.swap12_swap12 (s : EvenSign) : + s.swap12.swap12 = s := by cases s <;> rfl + +@[simp] theorem EvenSign.swap23_swap23 (s : EvenSign) : + s.swap23.swap23 = s := by cases s <;> rfl + +@[simp] +theorem swap12_evenSignPoint {R : Type u} [CommRing R] + (s : EvenSign) (x : Point R) : + swap12 (evenSignPoint s x) = evenSignPoint s.swap12 (swap12 x) := by + cases s <;> rfl + +@[simp] +theorem swap23_evenSignPoint {R : Type u} [CommRing R] + (s : EvenSign) (x : Point R) : + swap23 (evenSignPoint s x) = evenSignPoint s.swap23 (swap23 x) := by + cases s <;> rfl + +private theorem perm_ext_of_point_coe_eq {R : Type u} [CommRing R] + {f g : Equiv.Perm (MarkoffSurface R)} + (h : ∀ x : MarkoffSurface R, ((f x : MarkoffSurface R) : Point R) = g x) : + f = g := by + apply Equiv.ext + intro x + apply Subtype.ext + exact h x + +theorem vieta1SurfacePerm_commute_evenSign {R : Type u} [CommRing R] + (s : EvenSign) : + vieta1SurfacePerm R * evenSignSurfacePermHom R s = + evenSignSurfacePermHom R s * vieta1SurfacePerm R := by + apply perm_ext_of_point_coe_eq + intro x + exact vieta1_evenSignPoint s x.1 + +theorem vieta2SurfacePerm_commute_evenSign {R : Type u} [CommRing R] + (s : EvenSign) : + vieta2SurfacePerm R * evenSignSurfacePermHom R s = + evenSignSurfacePermHom R s * vieta2SurfacePerm R := by + apply perm_ext_of_point_coe_eq + intro x + exact vieta2_evenSignPoint s x.1 + +theorem vieta3SurfacePerm_commute_evenSign {R : Type u} [CommRing R] + (s : EvenSign) : + vieta3SurfacePerm R * evenSignSurfacePermHom R s = + evenSignSurfacePermHom R s * vieta3SurfacePerm R := by + apply perm_ext_of_point_coe_eq + intro x + exact vieta3_evenSignPoint s x.1 + +theorem swap12SurfacePerm_mul_evenSign {R : Type u} [CommRing R] + (s : EvenSign) : + swap12SurfacePerm R * evenSignSurfacePermHom R s = + evenSignSurfacePermHom R s.swap12 * swap12SurfacePerm R := by + apply perm_ext_of_point_coe_eq + intro x + exact swap12_evenSignPoint s x.1 + +theorem swap23SurfacePerm_mul_evenSign {R : Type u} [CommRing R] + (s : EvenSign) : + swap23SurfacePerm R * evenSignSurfacePermHom R s = + evenSignSurfacePermHom R s.swap23 * swap23SurfacePerm R := by + apply perm_ext_of_point_coe_eq + intro x + exact swap23_evenSignPoint s x.1 + +private theorem vieta1SurfacePerm_conj_evenSign {R : Type u} [CommRing R] + (s : EvenSign) : + vieta1SurfacePerm R * evenSignSurfacePermHom R s * + (vieta1SurfacePerm R)⁻¹ = + evenSignSurfacePermHom R s := by + rw [vieta1SurfacePerm_commute_evenSign] + simp + +private theorem vieta2SurfacePerm_conj_evenSign {R : Type u} [CommRing R] + (s : EvenSign) : + vieta2SurfacePerm R * evenSignSurfacePermHom R s * + (vieta2SurfacePerm R)⁻¹ = + evenSignSurfacePermHom R s := by + rw [vieta2SurfacePerm_commute_evenSign] + simp + +private theorem vieta3SurfacePerm_conj_evenSign {R : Type u} [CommRing R] + (s : EvenSign) : + vieta3SurfacePerm R * evenSignSurfacePermHom R s * + (vieta3SurfacePerm R)⁻¹ = + evenSignSurfacePermHom R s := by + rw [vieta3SurfacePerm_commute_evenSign] + simp + +private theorem swap12SurfacePerm_conj_evenSign {R : Type u} [CommRing R] + (s : EvenSign) : + swap12SurfacePerm R * evenSignSurfacePermHom R s * + (swap12SurfacePerm R)⁻¹ = + evenSignSurfacePermHom R s.swap12 := by + rw [swap12SurfacePerm_mul_evenSign] + simp + +private theorem swap23SurfacePerm_conj_evenSign {R : Type u} [CommRing R] + (s : EvenSign) : + swap23SurfacePerm R * evenSignSurfacePermHom R s * + (swap23SurfacePerm R)⁻¹ = + evenSignSurfacePermHom R s.swap23 := by + rw [swap23SurfacePerm_mul_evenSign] + simp + +private theorem mem_evenSign_normalizer_of_conj + {R : Type u} [CommRing R] + (q : Equiv.Perm (MarkoffSurface R)) (f : EvenSign → EvenSign) + (hconj : ∀ s, q * evenSignSurfacePermHom R s * q⁻¹ = + evenSignSurfacePermHom R (f s)) + (hsurj : Function.Surjective f) : + q ∈ Subgroup.normalizer (evenSignSurfaceSubgroup R : Set _) := by + rw [Subgroup.mem_set_normalizer_iff] + intro r + constructor + · rintro ⟨s, rfl⟩ + exact ⟨f s, (hconj s).symm⟩ + · rintro ⟨s, hs⟩ + obtain ⟨t, rfl⟩ := hsurj s + refine ⟨t, ?_⟩ + apply (MulAut.conj q).injective + rw [MulAut.conj_apply, MulAut.conj_apply, hconj] + exact hs + +private theorem vieta1SurfacePerm_normalizes_evenSign {R : Type u} [CommRing R] : + vieta1SurfacePerm R ∈ + Subgroup.normalizer (evenSignSurfaceSubgroup R : Set _) := + mem_evenSign_normalizer_of_conj (vieta1SurfacePerm R) id + vieta1SurfacePerm_conj_evenSign Function.surjective_id + +private theorem vieta2SurfacePerm_normalizes_evenSign {R : Type u} [CommRing R] : + vieta2SurfacePerm R ∈ + Subgroup.normalizer (evenSignSurfaceSubgroup R : Set _) := + mem_evenSign_normalizer_of_conj (vieta2SurfacePerm R) id + vieta2SurfacePerm_conj_evenSign Function.surjective_id + +private theorem vieta3SurfacePerm_normalizes_evenSign {R : Type u} [CommRing R] : + vieta3SurfacePerm R ∈ + Subgroup.normalizer (evenSignSurfaceSubgroup R : Set _) := + mem_evenSign_normalizer_of_conj (vieta3SurfacePerm R) id + vieta3SurfacePerm_conj_evenSign Function.surjective_id + +private theorem swap12SurfacePerm_normalizes_evenSign {R : Type u} [CommRing R] : + swap12SurfacePerm R ∈ + Subgroup.normalizer (evenSignSurfaceSubgroup R : Set _) := + mem_evenSign_normalizer_of_conj (swap12SurfacePerm R) EvenSign.swap12 + swap12SurfacePerm_conj_evenSign + (fun s => ⟨s.swap12, by simp⟩) + +private theorem swap23SurfacePerm_normalizes_evenSign {R : Type u} [CommRing R] : + swap23SurfacePerm R ∈ + Subgroup.normalizer (evenSignSurfaceSubgroup R : Set _) := + mem_evenSign_normalizer_of_conj (swap23SurfacePerm R) EvenSign.swap23 + swap23SurfacePerm_conj_evenSign + (fun s => ⟨s.swap23, by simp⟩) + +/-- Every Markoff-group element normalizes the subgroup of even sign changes. -/ +theorem Gamma_le_evenSignSurfaceSubgroup_normalizer + (R : Type u) [CommRing R] : + Gamma R ≤ Subgroup.normalizer (evenSignSurfaceSubgroup R : Set _) := by + change Subgroup.closure (gammaGenerators R) ≤ + Subgroup.normalizer (evenSignSurfaceSubgroup R : Set _) + rw [Subgroup.closure_le] + intro q hq + simp only [gammaGenerators, Set.mem_insert_iff, Set.mem_singleton_iff] at hq + rcases hq with rfl | rfl | rfl | rfl | rfl + · exact vieta1SurfacePerm_normalizes_evenSign + · exact vieta2SurfacePerm_normalizes_evenSign + · exact vieta3SurfacePerm_normalizes_evenSign + · exact swap12SurfacePerm_normalizes_evenSign + · exact swap23SurfacePerm_normalizes_evenSign + +/-- An even sign change can be moved through an arbitrary Gamma word. -/ +theorem exists_evenSign_smul_Gamma_smul + {R : Type u} [CommRing R] (s : EvenSign) (g : Gamma R) : + ∃ t : EvenSign, ∀ x : PuncturedMarkoffSurface R, + s • (g • x) = g • (t • x) := by + have hnormal : + (g⁻¹ : Gamma R).1 ∈ + Subgroup.normalizer (evenSignSurfaceSubgroup R : Set _) := + Gamma_le_evenSignSurfaceSubgroup_normalizer R g⁻¹.2 + have hsign : + (g⁻¹ : Gamma R).1 * evenSignSurfacePermHom R s * g.1 ∈ + evenSignSurfaceSubgroup R := by + simpa using + (Subgroup.mem_set_normalizer_iff.mp hnormal + (evenSignSurfacePermHom R s)).1 ⟨s, rfl⟩ + obtain ⟨t, ht⟩ := hsign + refine ⟨t, fun x => ?_⟩ + apply Subtype.ext + have hperm : + evenSignSurfacePermHom R s * g.1 = + g.1 * evenSignSurfacePermHom R t := by + calc + evenSignSurfacePermHom R s * g.1 = + g.1 * ((g⁻¹ : Gamma R).1 * evenSignSurfacePermHom R s * g.1) := by + simp [mul_assoc] + _ = g.1 * evenSignSurfacePermHom R t := by rw [← ht] + exact Equiv.congr_fun hperm x.1 + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Core/FiniteRotationEigenvalues.lean b/LeanPool/MarkoffModP/BGS/Markoff/Core/FiniteRotationEigenvalues.lean new file mode 100644 index 0000000000..b61648afd3 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Core/FiniteRotationEigenvalues.lean @@ -0,0 +1,121 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Core.ParabolicFibers +public import LeanPool.MarkoffModP.BGS.Markoff.Core.RotationTorus + +/-! +# Finite-order Markoff rotations have torsion eigenvalues + +This file isolates the algebraic kernel used in the opening argument of +Bourgain--Gamburd--Sarnak. Over an algebraically closed field, a finite-order +normalized rotation has an eigenvalue of finite multiplicative order, and its +trace is the sum of that eigenvalue and its inverse. + +The passage from a finite orbit of a *point* to finite order of the rotation +matrix is deliberately not assumed here. It is a separate geometric step, +and is delicate at the parabolic traces `2` and `-2`. +-/ + +@[expose] public section + +namespace BGS.Markoff + +open scoped Matrix +open Polynomial + +variable {K : Type*} [Field K] [IsAlgClosed K] + +/-- A finite-order normalized rotation has a torsion eigenvalue whose +eigenvalue trace is the rotation parameter. + +This includes the parabolic eigenvalues. In that case the eigenvalue squares +to one, so it is visibly torsion; away from that case the existing +diagonalization theorem transfers finite order from the rotation to the +eigenvalue. -/ +theorem finiteOrderRotation_has_torsion_eigenvalue (t : K) + (hfinite : IsOfFinOrder (rhoSL t)) : + ∃ w : Kˣ, IsOfFinOrder w ∧ t = splitTorusTrace w := by + let f : K[X] := X ^ 2 - C t * X + 1 + have hfdegree : f.degree ≠ 0 := by + have hfshape : IsMonicOfDegree f 2 := by + simpa [f] using isMonicOfDegree_sub_add_two t (1 : K) + rw [degree_eq_natDegree hfshape.monic.ne_zero, hfshape.natDegree_eq] + norm_num + obtain ⟨r, hr⟩ := IsAlgClosed.exists_root f hfdegree + have hreigen : r ^ 2 - t * r + 1 = 0 := by + simpa [f] using hr + have hrne : r ≠ 0 := by + intro hrzero + simp [hrzero] at hreigen + let w : Kˣ := Units.mk0 r hrne + have htrace : t = splitTorusTrace w := by + have hmul : t * r = r ^ 2 + 1 := by + linear_combination -hreigen + change t = r + r⁻¹ + apply (mul_right_cancel₀ hrne) + rw [hmul] + field_simp + refine ⟨w, ?_, htrace⟩ + by_cases hparabolic : (w : K) ^ 2 = 1 + · rw [isOfFinOrder_iff_pow_eq_one] + refine ⟨2, by omega, ?_⟩ + apply Units.ext + exact hparabolic + · rw [← orderOf_pos_iff] + have hrotation : 0 < rotationOrder t := by + simpa [rotationOrder] using hfinite.orderOf_pos + rw [htrace, rotationOrder_splitTorusTrace w hparabolic] at hrotation + exact hrotation + +section ParabolicObstruction + +variable {R : Type*} [CommRing R] [CharZero R] + +/-- The trace-`2` unipotent rotation has infinite order in characteristic +zero. -/ +theorem rhoSL_two_not_finiteOrder : ¬ IsOfFinOrder (rhoSL (2 : R)) := by + intro hfinite + obtain ⟨n, hnpos, hpower⟩ := hfinite.exists_pow_eq_one + have hmatrix := congrArg + (fun g : Matrix.SpecialLinearGroup (Fin 2) R ↦ + (g : Matrix (Fin 2) (Fin 2) R)) hpower + change rho (2 : R) ^ n = 1 at hmatrix + have hoffDiagonal := congrArg + (fun m : Matrix (Fin 2) (Fin 2) R ↦ m 0 1) hmatrix + have hnzero : (n : R) = 0 := by + simpa [rho_two_pow] using hoffDiagonal + have : n = 0 := by exact_mod_cast hnzero + exact hnpos.ne' this + +/-- Periodicity of one vector under a coordinate rotation does not by itself +imply finite order of the rotation matrix. The nonzero vector `(1,1)` is +fixed by the trace-`2` rotation, while that matrix has infinite order in +characteristic zero. + +This is the parabolic obstruction that must be handled before the paper's +finite-orbit discussion can invoke `finiteOrderRotation_has_torsion_eigenvalue`. +-/ +theorem exists_nonzero_fixedVector_with_infiniteOrder_rotation : + ∃ v : Fin 2 → R, + v ≠ 0 ∧ rho (2 : R) *ᵥ v = v ∧ ¬ IsOfFinOrder (rhoSL (2 : R)) := by + refine ⟨![1, 1], ?_, ?_, ?_⟩ + · intro hzero + have hentry := congrFun hzero 0 + norm_num at hentry + · rw [rho_mulVec] + ext i + fin_cases i + · simp + · simp + ring + · exact rhoSL_two_not_finiteOrder + +end ParabolicObstruction + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Core/NatConnectivity.lean b/LeanPool/MarkoffModP/BGS/Markoff/Core/NatConnectivity.lean new file mode 100644 index 0000000000..eac66430a7 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Core/NatConnectivity.lean @@ -0,0 +1,520 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Core.SemiringFunctor + +/-! +# Connectivity of natural-number Markoff solutions + +Every nonzero solution in natural numbers of + +`x₁² + x₂² + x₃² = 3 * x₁ * x₂ * x₃` + +is connected to `(1, 1, 1)` by coordinate transpositions and the natural-number Vieta moves. +The proof is the classical descent: after ordering the coordinates `a ≤ b ≤ c`, replace `c` by +`3ab - c`. Away from `(1, 1, 1)`, this is positive and strictly smaller than `c`. + +Natural subtraction is used only after proving the needed lower bound, so reduction to a ring +recovers the usual Vieta involution. +-/ + +@[expose] public section + +namespace BGS.Markoff + +/-- The first Vieta replacement on points with natural-number coordinates. -/ +def natVieta1 (x : Point ℕ) : Point ℕ := + ⟨3 * x.x2 * x.x3 - x.x1, x.x2, x.x3⟩ + +/-- The second Vieta replacement on points with natural-number coordinates. -/ +def natVieta2 (x : Point ℕ) : Point ℕ := + ⟨x.x1, 3 * x.x1 * x.x3 - x.x2, x.x3⟩ + +/-- The third Vieta replacement on points with natural-number coordinates. -/ +def natVieta3 (x : Point ℕ) : Point ℕ := + ⟨x.x1, x.x2, 3 * x.x1 * x.x2 - x.x3⟩ + +private theorem coordinate_le_vietaProduct {a b c : ℕ} + (h : a ^ 2 + b ^ 2 + c ^ 2 = 3 * a * b * c) : + a ≤ 3 * b * c := by + by_cases ha : a = 0 + · simp [ha] + have haPos : 0 < a := Nat.pos_of_ne_zero ha + apply Nat.le_of_mul_le_mul_left _ haPos + calc + a * a ≤ a ^ 2 + b ^ 2 + c ^ 2 := by nlinarith + _ = 3 * a * b * c := h + _ = a * (3 * b * c) := by ring + +private theorem vietaReplacement_preserves {a b c : ℕ} + (h : a ^ 2 + b ^ 2 + c ^ 2 = 3 * a * b * c) : + (3 * b * c - a) ^ 2 + b ^ 2 + c ^ 2 = + 3 * (3 * b * c - a) * b * c := by + have hle : a ≤ 3 * b * c := coordinate_le_vietaProduct h + have hcast : ((3 * b * c - a : ℕ) : ℤ) = 3 * b * c - a := by + rw [Nat.cast_sub hle] + norm_num + have hz : (a : ℤ) ^ 2 + (b : ℤ) ^ 2 + (c : ℤ) ^ 2 = + 3 * a * b * c := by + exact_mod_cast h + apply_mod_cast (show ((3 * b * c - a : ℕ) : ℤ) ^ 2 + (b : ℤ) ^ 2 + + (c : ℤ) ^ 2 = 3 * ((3 * b * c - a : ℕ) : ℤ) * b * c by + rw [hcast] + nlinarith) + +theorem isSemiringMarkoff_natVieta1 (x : Point ℕ) (hx : IsSemiringMarkoff x) : + IsSemiringMarkoff (natVieta1 x) := by + exact vietaReplacement_preserves (by simpa [IsSemiringMarkoff] using hx) + +theorem isSemiringMarkoff_natVieta2 (x : Point ℕ) (hx : IsSemiringMarkoff x) : + IsSemiringMarkoff (natVieta2 x) := by + have hreorder : IsSemiringMarkoff x ↔ + x.x2 ^ 2 + x.x1 ^ 2 + x.x3 ^ 2 = 3 * x.x2 * x.x1 * x.x3 := by + simp only [IsSemiringMarkoff] + ring_nf + have hp := vietaReplacement_preserves (a := x.x2) (b := x.x1) (c := x.x3) + (hreorder.mp hx) + simpa [IsSemiringMarkoff, natVieta2, add_comm, add_left_comm, add_assoc, + mul_comm, mul_left_comm, mul_assoc] using hp + +theorem isSemiringMarkoff_natVieta3 (x : Point ℕ) (hx : IsSemiringMarkoff x) : + IsSemiringMarkoff (natVieta3 x) := by + have hreorder : IsSemiringMarkoff x ↔ + x.x3 ^ 2 + x.x1 ^ 2 + x.x2 ^ 2 = 3 * x.x3 * x.x1 * x.x2 := by + simp only [IsSemiringMarkoff] + ring_nf + have hp := vietaReplacement_preserves (a := x.x3) (b := x.x1) (c := x.x2) + (hreorder.mp hx) + simpa [IsSemiringMarkoff, natVieta3, add_comm, add_left_comm, add_assoc, + mul_comm, mul_left_comm, mul_assoc] using hp + +/-- The first natural-number Vieta move restricted to the Markoff surface. -/ +def natVieta1Surface (x : SemiringMarkoffSurface ℕ) : SemiringMarkoffSurface ℕ := + ⟨natVieta1 x.1, isSemiringMarkoff_natVieta1 x.1 x.2⟩ + +/-- The second natural-number Vieta move restricted to the Markoff surface. -/ +def natVieta2Surface (x : SemiringMarkoffSurface ℕ) : SemiringMarkoffSurface ℕ := + ⟨natVieta2 x.1, isSemiringMarkoff_natVieta2 x.1 x.2⟩ + +/-- The third natural-number Vieta move restricted to the Markoff surface. -/ +def natVieta3Surface (x : SemiringMarkoffSurface ℕ) : SemiringMarkoffSurface ℕ := + ⟨natVieta3 x.1, isSemiringMarkoff_natVieta3 x.1 x.2⟩ + +/-- Exchange the first two coordinates of a natural-number Markoff solution. -/ +def natSwap12Surface (x : SemiringMarkoffSurface ℕ) : SemiringMarkoffSurface ℕ := + ⟨swap12 x.1, by + simpa [IsSemiringMarkoff, swap12, add_comm, add_left_comm, add_assoc, + mul_comm, mul_left_comm, mul_assoc] using x.2⟩ + +/-- Exchange the last two coordinates of a natural-number Markoff solution. -/ +def natSwap23Surface (x : SemiringMarkoffSurface ℕ) : SemiringMarkoffSurface ℕ := + ⟨swap23 x.1, by + simpa [IsSemiringMarkoff, swap23, add_comm, add_left_comm, add_assoc, + mul_comm, mul_left_comm, mul_assoc] using x.2⟩ + +@[simp] theorem natVieta1Surface_coe (x : SemiringMarkoffSurface ℕ) : + (natVieta1Surface x).1 = natVieta1 x.1 := rfl + +@[simp] theorem natVieta2Surface_coe (x : SemiringMarkoffSurface ℕ) : + (natVieta2Surface x).1 = natVieta2 x.1 := rfl + +@[simp] theorem natVieta3Surface_coe (x : SemiringMarkoffSurface ℕ) : + (natVieta3Surface x).1 = natVieta3 x.1 := rfl + +@[simp] theorem natSwap12Surface_coe (x : SemiringMarkoffSurface ℕ) : + (natSwap12Surface x).1 = swap12 x.1 := rfl + +@[simp] theorem natSwap23Surface_coe (x : SemiringMarkoffSurface ℕ) : + (natSwap23Surface x).1 = swap23 x.1 := rfl + +@[simp] +theorem natVieta1Surface_involutive (x : SemiringMarkoffSurface ℕ) : + natVieta1Surface (natVieta1Surface x) = x := by + have hle : x.1.x1 ≤ 3 * x.1.x2 * x.1.x3 := + coordinate_le_vietaProduct x.2 + apply Subtype.ext + ext <;> simp [natVieta1Surface, natVieta1, Nat.sub_sub_self hle] + +@[simp] +theorem natVieta2Surface_involutive (x : SemiringMarkoffSurface ℕ) : + natVieta2Surface (natVieta2Surface x) = x := by + have hreorder : x.1.x2 ^ 2 + x.1.x1 ^ 2 + x.1.x3 ^ 2 = + 3 * x.1.x2 * x.1.x1 * x.1.x3 := by + simpa [IsSemiringMarkoff, add_comm, add_left_comm, add_assoc, + mul_comm, mul_left_comm, mul_assoc] using x.2 + have hle : x.1.x2 ≤ 3 * x.1.x1 * x.1.x3 := + coordinate_le_vietaProduct hreorder + apply Subtype.ext + ext <;> simp [natVieta2Surface, natVieta2, Nat.sub_sub_self hle] + +@[simp] +theorem natVieta3Surface_involutive (x : SemiringMarkoffSurface ℕ) : + natVieta3Surface (natVieta3Surface x) = x := by + have hreorder : x.1.x3 ^ 2 + x.1.x1 ^ 2 + x.1.x2 ^ 2 = + 3 * x.1.x3 * x.1.x1 * x.1.x2 := by + simpa [IsSemiringMarkoff, add_comm, add_left_comm, add_assoc, + mul_comm, mul_left_comm, mul_assoc] using x.2 + have hle : x.1.x3 ≤ 3 * x.1.x1 * x.1.x2 := + coordinate_le_vietaProduct hreorder + apply Subtype.ext + ext <;> simp [natVieta3Surface, natVieta3, Nat.sub_sub_self hle] + +@[simp] +theorem natSwap12Surface_involutive (x : SemiringMarkoffSurface ℕ) : + natSwap12Surface (natSwap12Surface x) = x := by + apply Subtype.ext + rfl + +@[simp] +theorem natSwap23Surface_involutive (x : SemiringMarkoffSurface ℕ) : + natSwap23Surface (natSwap23Surface x) = x := by + apply Subtype.ext + rfl + +/-- The first natural Vieta move as a permutation of the natural Markoff surface. -/ +def natVieta1SurfaceEquiv : Equiv.Perm (SemiringMarkoffSurface ℕ) where + toFun := natVieta1Surface + invFun := natVieta1Surface + left_inv := natVieta1Surface_involutive + right_inv := natVieta1Surface_involutive + +/-- The second natural Vieta move as a permutation of the natural Markoff surface. -/ +def natVieta2SurfaceEquiv : Equiv.Perm (SemiringMarkoffSurface ℕ) where + toFun := natVieta2Surface + invFun := natVieta2Surface + left_inv := natVieta2Surface_involutive + right_inv := natVieta2Surface_involutive + +/-- The third natural Vieta move as a permutation of the natural Markoff surface. -/ +def natVieta3SurfaceEquiv : Equiv.Perm (SemiringMarkoffSurface ℕ) where + toFun := natVieta3Surface + invFun := natVieta3Surface + left_inv := natVieta3Surface_involutive + right_inv := natVieta3Surface_involutive + +/-- The first coordinate transposition as a permutation of the natural Markoff surface. -/ +def natSwap12SurfaceEquiv : Equiv.Perm (SemiringMarkoffSurface ℕ) where + toFun := natSwap12Surface + invFun := natSwap12Surface + left_inv := natSwap12Surface_involutive + right_inv := natSwap12Surface_involutive + +/-- The second coordinate transposition as a permutation of the natural Markoff surface. -/ +def natSwap23SurfaceEquiv : Equiv.Perm (SemiringMarkoffSurface ℕ) where + toFun := natSwap23Surface + invFun := natSwap23Surface + left_inv := natSwap23Surface_involutive + right_inv := natSwap23Surface_involutive + +/-- The five standard generators acting on natural-number Markoff solutions. -/ +def naturalGammaGenerators : Set (Equiv.Perm (SemiringMarkoffSurface ℕ)) := + {natVieta1SurfaceEquiv, natVieta2SurfaceEquiv, natVieta3SurfaceEquiv, + natSwap12SurfaceEquiv, natSwap23SurfaceEquiv} + +/-- The group generated by natural Vieta moves and coordinate transpositions. -/ +def NaturalGamma : Subgroup (Equiv.Perm (SemiringMarkoffSurface ℕ)) := + Subgroup.closure naturalGammaGenerators + +theorem natVieta1SurfaceEquiv_mem_NaturalGamma : natVieta1SurfaceEquiv ∈ NaturalGamma := + Subgroup.subset_closure (by simp [naturalGammaGenerators]) + +theorem natVieta2SurfaceEquiv_mem_NaturalGamma : natVieta2SurfaceEquiv ∈ NaturalGamma := + Subgroup.subset_closure (by simp [naturalGammaGenerators]) + +theorem natVieta3SurfaceEquiv_mem_NaturalGamma : natVieta3SurfaceEquiv ∈ NaturalGamma := + Subgroup.subset_closure (by simp [naturalGammaGenerators]) + +theorem natSwap12SurfaceEquiv_mem_NaturalGamma : natSwap12SurfaceEquiv ∈ NaturalGamma := + Subgroup.subset_closure (by simp [naturalGammaGenerators]) + +theorem natSwap23SurfaceEquiv_mem_NaturalGamma : natSwap23SurfaceEquiv ∈ NaturalGamma := + Subgroup.subset_closure (by simp [naturalGammaGenerators]) + +/-- The orbit relation for the natural Markoff group. -/ +def SameNatMarkoffComponent (x y : SemiringMarkoffSurface ℕ) : Prop := + y ∈ MulAction.orbit NaturalGamma x + +theorem sameNatMarkoffComponent_iff_exists (x y : SemiringMarkoffSurface ℕ) : + SameNatMarkoffComponent x y ↔ ∃ g : NaturalGamma, g • x = y := + Iff.rfl + +/-- A single standard move between natural-number Markoff solutions. -/ +inductive NatMarkoffStep : SemiringMarkoffSurface ℕ → SemiringMarkoffSurface ℕ → Prop + | vieta1 (x) : NatMarkoffStep x (natVieta1Surface x) + | vieta2 (x) : NatMarkoffStep x (natVieta2Surface x) + | vieta3 (x) : NatMarkoffStep x (natVieta3Surface x) + | swap12 (x) : NatMarkoffStep x (natSwap12Surface x) + | swap23 (x) : NatMarkoffStep x (natSwap23Surface x) + +@[refl] theorem sameNatMarkoffComponent_refl (x : SemiringMarkoffSurface ℕ) : + SameNatMarkoffComponent x x := + MulAction.mem_orbit_self x + +@[symm] theorem sameNatMarkoffComponent_symm {x y : SemiringMarkoffSurface ℕ} + (h : SameNatMarkoffComponent x y) : SameNatMarkoffComponent y x := + MulAction.mem_orbit_symm.mp h + +@[trans] theorem sameNatMarkoffComponent_trans {x y z : SemiringMarkoffSurface ℕ} + (hxy : SameNatMarkoffComponent x y) (hyz : SameNatMarkoffComponent y z) : + SameNatMarkoffComponent x z := by + unfold SameNatMarkoffComponent at * + rwa [(MulAction.orbit_eq_iff).2 hxy] at hyz + +theorem sameNatMarkoffComponent_vieta1 (x : SemiringMarkoffSurface ℕ) : + SameNatMarkoffComponent x (natVieta1Surface x) := by + exact ⟨⟨natVieta1SurfaceEquiv, natVieta1SurfaceEquiv_mem_NaturalGamma⟩, rfl⟩ + +theorem sameNatMarkoffComponent_vieta2 (x : SemiringMarkoffSurface ℕ) : + SameNatMarkoffComponent x (natVieta2Surface x) := by + exact ⟨⟨natVieta2SurfaceEquiv, natVieta2SurfaceEquiv_mem_NaturalGamma⟩, rfl⟩ + +theorem sameNatMarkoffComponent_vieta3 (x : SemiringMarkoffSurface ℕ) : + SameNatMarkoffComponent x (natVieta3Surface x) := by + exact ⟨⟨natVieta3SurfaceEquiv, natVieta3SurfaceEquiv_mem_NaturalGamma⟩, rfl⟩ + +theorem sameNatMarkoffComponent_swap12 (x : SemiringMarkoffSurface ℕ) : + SameNatMarkoffComponent x (natSwap12Surface x) := by + exact ⟨⟨natSwap12SurfaceEquiv, natSwap12SurfaceEquiv_mem_NaturalGamma⟩, rfl⟩ + +theorem sameNatMarkoffComponent_swap23 (x : SemiringMarkoffSurface ℕ) : + SameNatMarkoffComponent x (natSwap23Surface x) := by + exact ⟨⟨natSwap23SurfaceEquiv, natSwap23SurfaceEquiv_mem_NaturalGamma⟩, rfl⟩ + +/-- A generated sequence of standard natural moves lies in a single `NaturalGamma` orbit. -/ +theorem eqvGen_natMarkoffStep_sameComponent {x y : SemiringMarkoffSurface ℕ} + (h : Relation.EqvGen NatMarkoffStep x y) : SameNatMarkoffComponent x y := by + induction h with + | rel x y hxy => + cases hxy with + | vieta1 => exact sameNatMarkoffComponent_vieta1 x + | vieta2 => exact sameNatMarkoffComponent_vieta2 x + | vieta3 => exact sameNatMarkoffComponent_vieta3 x + | swap12 => exact sameNatMarkoffComponent_swap12 x + | swap23 => exact sameNatMarkoffComponent_swap23 x + | refl x => exact sameNatMarkoffComponent_refl x + | symm x y _ ih => exact sameNatMarkoffComponent_symm ih + | trans x y z _ _ ihxy ihyz => exact sameNatMarkoffComponent_trans ihxy ihyz + +/-- Sum of the coordinates, used as the well-founded descent measure. -/ +def natMarkoffHeight (x : SemiringMarkoffSurface ℕ) : ℕ := + x.1.x1 + x.1.x2 + x.1.x3 + +private theorem ordered_descending_vieta {a b c : ℕ} + (ha : 0 < a) (hab : a ≤ b) (hbc : b ≤ c) + (h : a ^ 2 + b ^ 2 + c ^ 2 = 3 * a * b * c) + (hnotRoot : ¬(a = 1 ∧ b = 1 ∧ c = 1)) : + 0 < 3 * a * b - c ∧ 3 * a * b - c < c := by + have hc_le : c ≤ 3 * a * b := by + have hcPos : 0 < c := lt_of_lt_of_le ha (hab.trans hbc) + apply Nat.le_of_mul_le_mul_left _ hcPos + calc + c * c ≤ a ^ 2 + b ^ 2 + c ^ 2 := by nlinarith + _ = 3 * a * b * c := h + _ = c * (3 * a * b) := by ring + have hc_lt : c < 3 * a * b := by + have hcPos : 0 < c := lt_of_lt_of_le ha (hab.trans hbc) + apply Nat.lt_of_mul_lt_mul_left + calc + c * c < a ^ 2 + b ^ 2 + c ^ 2 := by nlinarith [sq_pos_of_pos ha] + _ = 3 * a * b * c := h + _ = c * (3 * a * b) := by ring + have hb_lt : b < c := by + apply lt_of_le_of_ne hbc + intro hne + subst c + have haSqLe : a ^ 2 ≤ b ^ 2 := Nat.pow_le_pow_left hab 2 + have haOne : a = 1 := by + by_contra haNe + have haTwo : 2 ≤ a := by omega + have hmul : 2 * b ^ 2 ≤ a * b ^ 2 := + Nat.mul_le_mul_right (b ^ 2) haTwo + have hbPos : 0 < b := lt_of_lt_of_le ha hab + nlinarith [sq_pos_of_pos hbPos] + have hbOne : b = 1 := by + subst a + nlinarith + exact hnotRoot ⟨haOne, hbOne, hbOne⟩ + have haSqLe : a ^ 2 ≤ b ^ 2 := Nat.pow_le_pow_left hab 2 + have hbSqLe : b ^ 2 ≤ a * b ^ 2 := by + calc + b ^ 2 = 1 * b ^ 2 := by simp + _ ≤ a * b ^ 2 := Nat.mul_le_mul_right (b ^ 2) ha + have hf : a ^ 2 + 2 * b ^ 2 ≤ 3 * a * b ^ 2 := by + nlinarith + have hsum : 3 * a * b ≤ b + c := by + by_contra hnot + have hstrict : b + c < 3 * a * b := Nat.lt_of_not_ge hnot + have hEqZ : (a : ℤ) ^ 2 + (b : ℤ) ^ 2 + (c : ℤ) ^ 2 = + 3 * a * b * c := by + exact_mod_cast h + have hfZ : (a : ℤ) ^ 2 + 2 * (b : ℤ) ^ 2 ≤ 3 * a * b ^ 2 := by + exact_mod_cast hf + have hbLtZ : (b : ℤ) < c := by exact_mod_cast hb_lt + have hstrictZ : (b : ℤ) + c < 3 * a * b := by exact_mod_cast hstrict + have hprod : 0 < ((c : ℤ) - b) * (3 * a * b - b - c) := + mul_pos (sub_pos.mpr hbLtZ) (by omega) + nlinarith + exact ⟨Nat.sub_pos_of_lt hc_lt, by omega⟩ + +theorem natMarkoff_eq_origin_of_x1_eq_zero (x : SemiringMarkoffSurface ℕ) + (hx1 : x.1.x1 = 0) : x = semiringSurfaceOrigin ℕ := by + have heq := x.2 + change x.1.x1 ^ 2 + x.1.x2 ^ 2 + x.1.x3 ^ 2 = + 3 * x.1.x1 * x.1.x2 * x.1.x3 at heq + have hsum : x.1.x2 ^ 2 + x.1.x3 ^ 2 = 0 := by simpa [hx1] using heq + have hx2 : x.1.x2 = 0 := by nlinarith [hsum] + have hx3 : x.1.x3 = 0 := by nlinarith [hsum] + apply Subtype.ext + ext <;> simp [semiringSurfaceOrigin, origin, hx1, hx2, hx3] + +theorem natMarkoff_eq_origin_of_x2_eq_zero (x : SemiringMarkoffSurface ℕ) + (hx2 : x.1.x2 = 0) : x = semiringSurfaceOrigin ℕ := by + have heq := x.2 + change x.1.x1 ^ 2 + x.1.x2 ^ 2 + x.1.x3 ^ 2 = + 3 * x.1.x1 * x.1.x2 * x.1.x3 at heq + have hsum : x.1.x1 ^ 2 + x.1.x3 ^ 2 = 0 := by simpa [hx2] using heq + have hx1 : x.1.x1 = 0 := by nlinarith [hsum] + exact natMarkoff_eq_origin_of_x1_eq_zero x hx1 + +theorem natMarkoff_eq_origin_of_x3_eq_zero (x : SemiringMarkoffSurface ℕ) + (hx3 : x.1.x3 = 0) : x = semiringSurfaceOrigin ℕ := by + have heq := x.2 + change x.1.x1 ^ 2 + x.1.x2 ^ 2 + x.1.x3 ^ 2 = + 3 * x.1.x1 * x.1.x2 * x.1.x3 at heq + have hsum : x.1.x1 ^ 2 + x.1.x2 ^ 2 = 0 := by simpa [hx3] using heq + have hx1 : x.1.x1 = 0 := by nlinarith [hsum] + exact natMarkoff_eq_origin_of_x1_eq_zero x hx1 + +/-- Every coordinate of a nonzero natural Markoff solution is positive. -/ +theorem natMarkoff_coordinates_pos_of_ne_origin (x : SemiringMarkoffSurface ℕ) + (hx : x ≠ semiringSurfaceOrigin ℕ) : + 0 < x.1.x1 ∧ 0 < x.1.x2 ∧ 0 < x.1.x3 := by + refine ⟨Nat.pos_of_ne_zero fun h => hx (natMarkoff_eq_origin_of_x1_eq_zero x h), + Nat.pos_of_ne_zero fun h => hx (natMarkoff_eq_origin_of_x2_eq_zero x h), + Nat.pos_of_ne_zero fun h => hx (natMarkoff_eq_origin_of_x3_eq_zero x h)⟩ + +private theorem natMarkoff_eq_root_of_coordinates_eq_one + (x : SemiringMarkoffSurface ℕ) (hx1 : x.1.x1 = 1) + (hx2 : x.1.x2 = 1) (hx3 : x.1.x3 = 1) : + x = semiringSurfaceRoot ℕ := by + apply Subtype.ext + ext <;> simp [semiringSurfaceRoot, hx1, hx2, hx3] + +private theorem exists_ordered_sameNatMarkoffComponent (x : SemiringMarkoffSurface ℕ) : + ∃ y : SemiringMarkoffSurface ℕ, + SameNatMarkoffComponent x y ∧ + y.1.x1 ≤ y.1.x2 ∧ y.1.x2 ≤ y.1.x3 ∧ + natMarkoffHeight y = natMarkoffHeight x := by + by_cases h12 : x.1.x1 ≤ x.1.x2 + · by_cases h23 : x.1.x2 ≤ x.1.x3 + · exact ⟨x, sameNatMarkoffComponent_refl x, h12, h23, rfl⟩ + · have h32 : x.1.x3 < x.1.x2 := Nat.lt_of_not_ge h23 + by_cases h13 : x.1.x1 ≤ x.1.x3 + · refine ⟨natSwap23Surface x, sameNatMarkoffComponent_swap23 x, ?_, ?_, ?_⟩ + · exact h13 + · exact h32.le + · simp [natMarkoffHeight, natSwap23Surface, swap23] + omega + · have h31 : x.1.x3 < x.1.x1 := Nat.lt_of_not_ge h13 + let y := natSwap12Surface (natSwap23Surface x) + have hxy : SameNatMarkoffComponent x y := + sameNatMarkoffComponent_trans (sameNatMarkoffComponent_swap23 x) + (sameNatMarkoffComponent_swap12 (natSwap23Surface x)) + refine ⟨y, hxy, ?_, ?_, ?_⟩ + · exact h31.le + · exact h12 + · simp [y, natMarkoffHeight, natSwap12Surface, natSwap23Surface, swap12, swap23] + omega + · have h21 : x.1.x2 < x.1.x1 := Nat.lt_of_not_ge h12 + by_cases h13 : x.1.x1 ≤ x.1.x3 + · refine ⟨natSwap12Surface x, sameNatMarkoffComponent_swap12 x, ?_, ?_, ?_⟩ + · exact h21.le + · exact h13 + · simp [natMarkoffHeight, natSwap12Surface, swap12] + omega + · have h31 : x.1.x3 < x.1.x1 := Nat.lt_of_not_ge h13 + by_cases h23 : x.1.x2 ≤ x.1.x3 + · let y := natSwap23Surface (natSwap12Surface x) + have hxy : SameNatMarkoffComponent x y := + sameNatMarkoffComponent_trans (sameNatMarkoffComponent_swap12 x) + (sameNatMarkoffComponent_swap23 (natSwap12Surface x)) + refine ⟨y, hxy, ?_, ?_, ?_⟩ + · exact h23 + · exact h31.le + · simp [y, natMarkoffHeight, natSwap12Surface, natSwap23Surface, swap12, swap23] + omega + · have h32 : x.1.x3 < x.1.x2 := Nat.lt_of_not_ge h23 + let y := natSwap12Surface (natSwap23Surface (natSwap12Surface x)) + have hxy : SameNatMarkoffComponent x y := + sameNatMarkoffComponent_trans (sameNatMarkoffComponent_swap12 x) <| + sameNatMarkoffComponent_trans + (sameNatMarkoffComponent_swap23 (natSwap12Surface x)) + (sameNatMarkoffComponent_swap12 (natSwap23Surface (natSwap12Surface x))) + refine ⟨y, hxy, ?_, ?_, ?_⟩ + · exact h32.le + · exact h21.le + · simp [y, natMarkoffHeight, natSwap12Surface, natSwap23Surface, swap12, swap23] + omega + +/-- Every nonzero natural-number Markoff solution is in the `NaturalGamma` orbit of `(1,1,1)`. -/ +theorem natMarkoff_ne_origin_sameComponent_root : + ∀ x : SemiringMarkoffSurface ℕ, + x ≠ semiringSurfaceOrigin ℕ → + SameNatMarkoffComponent (semiringSurfaceRoot ℕ) x := by + intro x + induction x using (measure natMarkoffHeight).wf.induction with + | h x ih => + intro hx + obtain ⟨y, hxy, hy12, hy23, hyHeight⟩ := + exists_ordered_sameNatMarkoffComponent x + have hxPos := natMarkoff_coordinates_pos_of_ne_origin x hx + have hxHeightPos : 0 < natMarkoffHeight x := by + simp only [natMarkoffHeight] + omega + have hyHeightPos : 0 < natMarkoffHeight y := by omega + have hy : y ≠ semiringSurfaceOrigin ℕ := by + intro hyOrigin + subst y + simp [natMarkoffHeight, semiringSurfaceOrigin, origin] at hyHeightPos + have hyPos := natMarkoff_coordinates_pos_of_ne_origin y hy + by_cases hyRoot : y = semiringSurfaceRoot ℕ + · exact sameNatMarkoffComponent_symm (hyRoot ▸ hxy) + · have hnotRootCoords : + ¬(y.1.x1 = 1 ∧ y.1.x2 = 1 ∧ y.1.x3 = 1) := by + rintro ⟨hy1, hy2, hy3⟩ + exact hyRoot (natMarkoff_eq_root_of_coordinates_eq_one y hy1 hy2 hy3) + have hdesc := ordered_descending_vieta hyPos.1 hy12 hy23 y.2 hnotRootCoords + let z := natVieta3Surface y + have hzHeight : natMarkoffHeight z < natMarkoffHeight x := by + rw [← hyHeight] + simp only [z, natMarkoffHeight, natVieta3Surface, natVieta3] + omega + have hz : z ≠ semiringSurfaceOrigin ℕ := by + intro hzOrigin + have hz1 : z.1.x1 = 0 := by + rw [hzOrigin] + rfl + change y.1.x1 = 0 at hz1 + omega + have hRootZ : SameNatMarkoffComponent (semiringSurfaceRoot ℕ) z := + ih z hzHeight hz + have hzy : SameNatMarkoffComponent z y := + sameNatMarkoffComponent_symm (sameNatMarkoffComponent_vieta3 y) + exact sameNatMarkoffComponent_trans + (sameNatMarkoffComponent_trans hRootZ hzy) + (sameNatMarkoffComponent_symm hxy) + +/-- The natural Markoff surface consists of the origin and the single orbit rooted at `(1,1,1)`. -/ +theorem natMarkoff_eq_origin_or_sameComponent_root (x : SemiringMarkoffSurface ℕ) : + x = semiringSurfaceOrigin ℕ ∨ + SameNatMarkoffComponent (semiringSurfaceRoot ℕ) x := by + by_cases hx : x = semiringSurfaceOrigin ℕ + · exact Or.inl hx + · exact Or.inr (natMarkoff_ne_origin_sameComponent_root x hx) + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Core/Normalization.lean b/LeanPool/MarkoffModP/BGS/Markoff/Core/Normalization.lean new file mode 100644 index 0000000000..67b479f2cd --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Core/Normalization.lean @@ -0,0 +1,267 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Core.Basic + +/-! +# Normalized coordinates on the Markoff surface + +The paper silently passes from the original coordinates `x` to trace coordinates `u = 3x`. +This file gives the normalized affine space a distinct type, defines its Markoff equation and +Vieta moves, and proves that coordinatewise scaling by three identifies the two theories whenever +three is invertible. +-/ + +@[expose] public section + +namespace BGS.Markoff + +universe u + +/-- A point in normalized trace coordinates. This is intentionally not definitionally equal to +the original-coordinate type `Point R`. -/ +@[ext] +structure NormalizedPoint (R : Type u) where + /-- The first normalized trace coordinate. -/ + u1 : R + /-- The second normalized trace coordinate. -/ + u2 : R + /-- The third normalized trace coordinate. -/ + u3 : R +deriving DecidableEq, Repr, Fintype + +/-- The origin in normalized trace coordinates. -/ +def normalizedOrigin {R : Type u} [Zero R] : NormalizedPoint R := ⟨0, 0, 0⟩ + +/-- The normalized Markoff polynomial `u₁² + u₂² + u₃² - u₁u₂u₃`. -/ +def normalizedPolynomial {R : Type u} [CommRing R] (x : NormalizedPoint R) : R := + x.u1 ^ 2 + x.u2 ^ 2 + x.u3 ^ 2 - x.u1 * x.u2 * x.u3 + +/-- The predicate that a normalized point lies on the normalized Markoff surface. -/ +def IsNormalizedMarkoff {R : Type u} [CommRing R] (x : NormalizedPoint R) : Prop := + normalizedPolynomial x = 0 + +/-- The normalized Markoff surface. -/ +def normalizedSurface (R : Type u) [CommRing R] : Set (NormalizedPoint R) := + {x | IsNormalizedMarkoff x} + +/-- The normalized Markoff surface with the origin removed. -/ +def normalizedPuncturedSurface (R : Type u) [CommRing R] : Set (NormalizedPoint R) := + normalizedSurface R \ {normalizedOrigin} + +/-- The normalized Markoff fiber obtained by fixing the first coordinate. -/ +def normalizedFiber1 {R : Type u} [CommRing R] (a : R) : Set (NormalizedPoint R) := + {x | IsNormalizedMarkoff x ∧ x.u1 = a} + +/-- The normalized Markoff fiber obtained by fixing the second coordinate. -/ +def normalizedFiber2 {R : Type u} [CommRing R] (a : R) : Set (NormalizedPoint R) := + {x | IsNormalizedMarkoff x ∧ x.u2 = a} + +/-- The normalized Markoff fiber obtained by fixing the third coordinate. -/ +def normalizedFiber3 {R : Type u} [CommRing R] (a : R) : Set (NormalizedPoint R) := + {x | IsNormalizedMarkoff x ∧ x.u3 = a} + +/-- The first Vieta involution in normalized coordinates. -/ +def normalizedVieta1 {R : Type u} [CommRing R] (x : NormalizedPoint R) : + NormalizedPoint R := + ⟨x.u2 * x.u3 - x.u1, x.u2, x.u3⟩ + +/-- The second Vieta involution in normalized coordinates. -/ +def normalizedVieta2 {R : Type u} [CommRing R] (x : NormalizedPoint R) : + NormalizedPoint R := + ⟨x.u1, x.u1 * x.u3 - x.u2, x.u3⟩ + +/-- The third Vieta involution in normalized coordinates. -/ +def normalizedVieta3 {R : Type u} [CommRing R] (x : NormalizedPoint R) : + NormalizedPoint R := + ⟨x.u1, x.u2, x.u1 * x.u2 - x.u3⟩ + +/-- Exchange the first two normalized coordinates. -/ +def normalizedSwap12 {R : Type u} (x : NormalizedPoint R) : NormalizedPoint R := + ⟨x.u2, x.u1, x.u3⟩ + +/-- Exchange the last two normalized coordinates. -/ +def normalizedSwap23 {R : Type u} (x : NormalizedPoint R) : NormalizedPoint R := + ⟨x.u1, x.u3, x.u2⟩ + +/-- The fundamental rotation fixing the first normalized coordinate. -/ +def normalizedRotate1 {R : Type u} [CommRing R] (x : NormalizedPoint R) : + NormalizedPoint R := + ⟨x.u1, x.u3, x.u1 * x.u3 - x.u2⟩ + +@[simp] +theorem normalizedPolynomial_origin {R : Type u} [CommRing R] : + normalizedPolynomial (normalizedOrigin : NormalizedPoint R) = 0 := by + simp [normalizedPolynomial, normalizedOrigin] + +@[simp] +theorem isNormalizedMarkoff_origin {R : Type u} [CommRing R] : + IsNormalizedMarkoff (normalizedOrigin : NormalizedPoint R) := by + simp [IsNormalizedMarkoff] + +theorem normalizedPolynomial_vieta1 {R : Type u} [CommRing R] (x : NormalizedPoint R) : + normalizedPolynomial (normalizedVieta1 x) = normalizedPolynomial x := by + simp [normalizedPolynomial, normalizedVieta1] + ring + +theorem normalizedPolynomial_vieta2 {R : Type u} [CommRing R] (x : NormalizedPoint R) : + normalizedPolynomial (normalizedVieta2 x) = normalizedPolynomial x := by + simp [normalizedPolynomial, normalizedVieta2] + ring + +theorem normalizedPolynomial_vieta3 {R : Type u} [CommRing R] (x : NormalizedPoint R) : + normalizedPolynomial (normalizedVieta3 x) = normalizedPolynomial x := by + simp [normalizedPolynomial, normalizedVieta3] + ring + +theorem normalizedPolynomial_swap12 {R : Type u} [CommRing R] (x : NormalizedPoint R) : + normalizedPolynomial (normalizedSwap12 x) = normalizedPolynomial x := by + simp [normalizedPolynomial, normalizedSwap12] + ring + +theorem normalizedPolynomial_swap23 {R : Type u} [CommRing R] (x : NormalizedPoint R) : + normalizedPolynomial (normalizedSwap23 x) = normalizedPolynomial x := by + simp [normalizedPolynomial, normalizedSwap23] + ring + +theorem normalizedPolynomial_rotate1 {R : Type u} [CommRing R] (x : NormalizedPoint R) : + normalizedPolynomial (normalizedRotate1 x) = normalizedPolynomial x := by + simp [normalizedPolynomial, normalizedRotate1] + ring + +@[simp] +theorem isNormalizedMarkoff_vieta1 {R : Type u} [CommRing R] (x : NormalizedPoint R) : + IsNormalizedMarkoff (normalizedVieta1 x) ↔ IsNormalizedMarkoff x := by + simp only [IsNormalizedMarkoff, normalizedPolynomial_vieta1] + +@[simp] +theorem isNormalizedMarkoff_vieta2 {R : Type u} [CommRing R] (x : NormalizedPoint R) : + IsNormalizedMarkoff (normalizedVieta2 x) ↔ IsNormalizedMarkoff x := by + simp only [IsNormalizedMarkoff, normalizedPolynomial_vieta2] + +@[simp] +theorem isNormalizedMarkoff_vieta3 {R : Type u} [CommRing R] (x : NormalizedPoint R) : + IsNormalizedMarkoff (normalizedVieta3 x) ↔ IsNormalizedMarkoff x := by + simp only [IsNormalizedMarkoff, normalizedPolynomial_vieta3] + +@[simp] +theorem isNormalizedMarkoff_rotate1 {R : Type u} [CommRing R] (x : NormalizedPoint R) : + IsNormalizedMarkoff (normalizedRotate1 x) ↔ IsNormalizedMarkoff x := by + simp only [IsNormalizedMarkoff, normalizedPolynomial_rotate1] + +/-- The normalized rotation fixes, and therefore preserves, its first-coordinate fiber. -/ +theorem normalizedRotate1_mem_fiber1_iff + {R : Type u} [CommRing R] (a : R) (x : NormalizedPoint R) : + normalizedRotate1 x ∈ normalizedFiber1 a ↔ x ∈ normalizedFiber1 a := by + change (IsNormalizedMarkoff (normalizedRotate1 x) ∧ x.u1 = a) ↔ + IsNormalizedMarkoff x ∧ x.u1 = a + rw [isNormalizedMarkoff_rotate1] + +@[simp] +theorem normalizedVieta1_involutive {R : Type u} [CommRing R] (x : NormalizedPoint R) : + normalizedVieta1 (normalizedVieta1 x) = x := by + ext <;> simp [normalizedVieta1] + +@[simp] +theorem normalizedVieta2_involutive {R : Type u} [CommRing R] (x : NormalizedPoint R) : + normalizedVieta2 (normalizedVieta2 x) = x := by + ext <;> simp [normalizedVieta2] + +@[simp] +theorem normalizedVieta3_involutive {R : Type u} [CommRing R] (x : NormalizedPoint R) : + normalizedVieta3 (normalizedVieta3 x) = x := by + ext <;> simp [normalizedVieta3] + +/-- Coordinatewise multiplication by three, from original to normalized coordinates. -/ +def toNormalized {R : Type u} [CommRing R] (x : Point R) : NormalizedPoint R := + ⟨3 * x.x1, 3 * x.x2, 3 * x.x3⟩ + +/-- Coordinatewise multiplication by the specified inverse of three. -/ +def fromNormalized {R : Type u} [CommRing R] [Invertible (3 : R)] + (x : NormalizedPoint R) : Point R := + ⟨⅟(3 : R) * x.u1, ⅟(3 : R) * x.u2, ⅟(3 : R) * x.u3⟩ + +@[simp] +theorem toNormalized_origin {R : Type u} [CommRing R] : + toNormalized (origin : Point R) = normalizedOrigin := by + simp [toNormalized, origin, normalizedOrigin] + +@[simp] +theorem fromNormalized_origin {R : Type u} [CommRing R] [Invertible (3 : R)] : + fromNormalized (normalizedOrigin : NormalizedPoint R) = origin := by + simp [fromNormalized, normalizedOrigin, origin] + +/-- Scaling multiplies the Markoff polynomial by `3²`. This identity itself does not need three +to be invertible. -/ +theorem normalizedPolynomial_toNormalized {R : Type u} [CommRing R] (x : Point R) : + normalizedPolynomial (toNormalized x) = (3 : R) ^ 2 * markoffPolynomial x := by + simp [normalizedPolynomial, toNormalized, markoffPolynomial] + ring + +/-- When three is invertible, scaling takes the original Markoff equation to the normalized one +and reflects it. -/ +@[simp] +theorem isNormalizedMarkoff_toNormalized_iff {R : Type u} [CommRing R] + [Invertible (3 : R)] (x : Point R) : + IsNormalizedMarkoff (toNormalized x) ↔ IsMarkoff x := by + rw [IsNormalizedMarkoff, normalizedPolynomial_toNormalized, IsMarkoff] + exact ((isUnit_of_invertible (3 : R)).pow 2).mul_right_eq_zero + +/-- Coordinatewise scaling by three as an equivalence of the two ambient affine spaces. -/ +def normalizationEquiv (R : Type u) [CommRing R] [Invertible (3 : R)] : + Point R ≃ NormalizedPoint R where + toFun := toNormalized + invFun := fromNormalized + left_inv x := by + ext <;> simp [toNormalized, fromNormalized, ← mul_assoc] + right_inv x := by + ext <;> simp [toNormalized, fromNormalized, ← mul_assoc] + +/-- Scaling by three restricts to an equivalence of the original and normalized Markoff +surfaces. -/ +def normalizationSurfaceEquiv (R : Type u) [CommRing R] [Invertible (3 : R)] : + {x : Point R // IsMarkoff x} ≃ {x : NormalizedPoint R // IsNormalizedMarkoff x} := + (normalizationEquiv R).subtypeEquiv fun x => by + change IsMarkoff x ↔ IsNormalizedMarkoff (toNormalized x) + exact (isNormalizedMarkoff_toNormalized_iff x).symm + +@[simp] +theorem toNormalized_vieta1 {R : Type u} [CommRing R] (x : Point R) : + toNormalized (vieta1 x) = normalizedVieta1 (toNormalized x) := by + ext <;> simp [toNormalized, vieta1, normalizedVieta1] + ring + +@[simp] +theorem toNormalized_vieta2 {R : Type u} [CommRing R] (x : Point R) : + toNormalized (vieta2 x) = normalizedVieta2 (toNormalized x) := by + ext <;> simp [toNormalized, vieta2, normalizedVieta2] + ring + +@[simp] +theorem toNormalized_vieta3 {R : Type u} [CommRing R] (x : Point R) : + toNormalized (vieta3 x) = normalizedVieta3 (toNormalized x) := by + ext <;> simp [toNormalized, vieta3, normalizedVieta3] + ring + +@[simp] +theorem toNormalized_swap12 {R : Type u} [CommRing R] (x : Point R) : + toNormalized (swap12 x) = normalizedSwap12 (toNormalized x) := by + rfl + +@[simp] +theorem toNormalized_swap23 {R : Type u} [CommRing R] (x : Point R) : + toNormalized (swap23 x) = normalizedSwap23 (toNormalized x) := by + rfl + +@[simp] +theorem toNormalized_rotate1 {R : Type u} [CommRing R] (x : Point R) : + toNormalized (rotate1 x) = normalizedRotate1 (toNormalized x) := by + ext <;> simp [toNormalized, rotate1, normalizedRotate1] + ring + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Core/NormalizedOrbit.lean b/LeanPool/MarkoffModP/BGS/Markoff/Core/NormalizedOrbit.lean new file mode 100644 index 0000000000..b897918607 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Core/NormalizedOrbit.lean @@ -0,0 +1,344 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Core.Action +public import LeanPool.MarkoffModP.BGS.Markoff.Core.Normalization + +/-! +# Markoff components in normalized coordinates + +The Markoff group is defined on the original-coordinate surface. This file transports its +permutations and component relation through `normalizationSurfaceEquiv`. It also records the +specific group word for the fundamental rotation and proves that every iterate of the normalized +rotation stays in the same transported component. +-/ + +@[expose] public section + +namespace BGS.Markoff + +universe u + +/-- The normalized Markoff surface as a subtype. -/ +abbrev NormalizedMarkoffSurface (R : Type u) [CommRing R] := + {x : NormalizedPoint R // IsNormalizedMarkoff x} + +/-- The fundamental rotation, restricted to the original-coordinate Markoff surface. -/ +def rotate1Surface {R : Type u} [CommRing R] (x : MarkoffSurface R) : + MarkoffSurface R := + ⟨rotate1 x.1, (isMarkoff_rotate1 x.1).2 x.property⟩ + +@[simp] +theorem coe_rotate1Surface {R : Type u} [CommRing R] (x : MarkoffSurface R) : + ((rotate1Surface x : MarkoffSurface R) : Point R) = rotate1 x := + rfl + +/-- The rotation fixing the first coordinate is `swap23` after the second Vieta involution. -/ +theorem rotate1Surface_eq_swap23_after_vieta2 {R : Type u} [CommRing R] + (x : MarkoffSurface R) : + rotate1Surface x = swap23SurfacePerm R (vieta2SurfacePerm R x) := by + apply Subtype.ext + rfl + +/-- The explicit element of `Gamma` realizing the fundamental rotation. -/ +def gammaRotate1 (R : Type u) [CommRing R] : Gamma R := + gammaSwap23 R * gammaVieta2 R + +@[simp] +theorem gammaRotate1_smul_surface {R : Type u} [CommRing R] + (x : MarkoffSurface R) : + gammaRotate1 R • x = rotate1Surface x := by + rw [gammaRotate1, mul_smul, gammaVieta2_smul_surface, gammaSwap23_smul_surface] + exact (rotate1Surface_eq_swap23_after_vieta2 x).symm + +/-- A fundamental rotation is an honest move in the Markoff group. -/ +theorem sameComponent_rotate1Surface {R : Type u} [CommRing R] + (x : MarkoffSurface R) : + SameComponent x (rotate1Surface x) := by + rw [rotate1Surface_eq_swap23_after_vieta2] + exact sameComponent_trans (sameComponent_vieta2 x) + (sameComponent_swap23 (vieta2SurfacePerm R x)) + +/-- Conjugate an element of the original Markoff group to normalized coordinates. -/ +def normalizedGammaPerm (R : Type u) [CommRing R] [Invertible (3 : R)] + (g : Gamma R) : Equiv.Perm (NormalizedMarkoffSurface R) := + (normalizationSurfaceEquiv R).symm.trans + ((g : Equiv.Perm (MarkoffSurface R)).trans (normalizationSurfaceEquiv R)) + +@[simp] +theorem normalizedGammaPerm_apply {R : Type u} [CommRing R] [Invertible (3 : R)] + (g : Gamma R) (x : NormalizedMarkoffSurface R) : + normalizedGammaPerm R g x = + normalizationSurfaceEquiv R + ((g : Equiv.Perm (MarkoffSurface R)) ((normalizationSurfaceEquiv R).symm x)) := + rfl + +/-- The conjugated permutations give the transported `Gamma` action on the normalized surface. -/ +instance normalizedGammaMulAction + {R : Type u} [CommRing R] [Invertible (3 : R)] : + MulAction (Gamma R) (NormalizedMarkoffSurface R) where + smul g x := normalizedGammaPerm R g x + one_smul x := by + change normalizedGammaPerm R 1 x = x + change normalizationSurfaceEquiv R ((normalizationSurfaceEquiv R).symm x) = x + exact (normalizationSurfaceEquiv R).apply_symm_apply x + mul_smul g h x := by + change normalizedGammaPerm R (g * h) x = + normalizedGammaPerm R g (normalizedGammaPerm R h x) + change normalizationSurfaceEquiv R + (((g * h : Gamma R) : Equiv.Perm (MarkoffSurface R)) + ((normalizationSurfaceEquiv R).symm x)) = + normalizationSurfaceEquiv R + ((g : Equiv.Perm (MarkoffSurface R)) ((normalizationSurfaceEquiv R).symm + (normalizationSurfaceEquiv R + ((h : Equiv.Perm (MarkoffSurface R)) + ((normalizationSurfaceEquiv R).symm x))))) + rw [(normalizationSurfaceEquiv R).symm_apply_apply] + rfl + +@[simp] +theorem normalizedGamma_smul_eq_perm + {R : Type u} [CommRing R] [Invertible (3 : R)] + (g : Gamma R) (x : NormalizedMarkoffSurface R) : + g • x = normalizedGammaPerm R g x := + rfl + +/-- The orbit of a normalized point under the transported `Gamma` action. -/ +def normalizedGammaOrbit + {R : Type u} [CommRing R] [Invertible (3 : R)] + (x : NormalizedMarkoffSurface R) : Set (NormalizedMarkoffSurface R) := + MulAction.orbit (Gamma R) x + +/-- Two normalized points are in the same component exactly when their inverse normalizations are +in one original-coordinate `Gamma`-orbit. -/ +def SameNormalizedComponent {R : Type u} [CommRing R] [Invertible (3 : R)] + (x y : NormalizedMarkoffSurface R) : Prop := + SameComponent ((normalizationSurfaceEquiv R).symm x) + ((normalizationSurfaceEquiv R).symm y) + +/-- Orbit membership in normalized coordinates is witnessed by a conjugated element of `Gamma`. -/ +theorem sameNormalizedComponent_iff_exists_gamma + {R : Type u} [CommRing R] [Invertible (3 : R)] + (x y : NormalizedMarkoffSurface R) : + SameNormalizedComponent x y ↔ ∃ g : Gamma R, normalizedGammaPerm R g x = y := by + rw [SameNormalizedComponent, sameComponent_iff_exists] + constructor + · rintro ⟨g, hg⟩ + refine ⟨g, ?_⟩ + rw [normalizedGammaPerm_apply] + change (g : Equiv.Perm (MarkoffSurface R)) + ((normalizationSurfaceEquiv R).symm x) = + (normalizationSurfaceEquiv R).symm y at hg + rw [hg, (normalizationSurfaceEquiv R).apply_symm_apply] + · rintro ⟨g, hg⟩ + refine ⟨g, ?_⟩ + rw [normalizedGammaPerm_apply] at hg + change (g : Equiv.Perm (MarkoffSurface R)) + ((normalizationSurfaceEquiv R).symm x) = + (normalizationSurfaceEquiv R).symm y + apply (normalizationSurfaceEquiv R).injective + simpa using hg + +/-- The transported component relation agrees with the orbit of the transported action. -/ +theorem sameNormalizedComponent_iff_mem_normalizedGammaOrbit + {R : Type u} [CommRing R] [Invertible (3 : R)] + (x y : NormalizedMarkoffSurface R) : + SameNormalizedComponent x y ↔ y ∈ normalizedGammaOrbit x := by + rw [sameNormalizedComponent_iff_exists_gamma] + rfl + +@[refl] +theorem sameNormalizedComponent_refl + {R : Type u} [CommRing R] [Invertible (3 : R)] + (x : NormalizedMarkoffSurface R) : + SameNormalizedComponent x x := + sameComponent_refl _ + +@[symm] +theorem sameNormalizedComponent_symm + {R : Type u} [CommRing R] [Invertible (3 : R)] + {x y : NormalizedMarkoffSurface R} + (h : SameNormalizedComponent x y) : + SameNormalizedComponent y x := + sameComponent_symm h + +@[trans] +theorem sameNormalizedComponent_trans + {R : Type u} [CommRing R] [Invertible (3 : R)] + {x y z : NormalizedMarkoffSurface R} + (hxy : SameNormalizedComponent x y) (hyz : SameNormalizedComponent y z) : + SameNormalizedComponent x z := + sameComponent_trans hxy hyz + +/-- Exchange the first two normalized coordinates on the normalized surface. -/ +def normalizedSwap12Surface {R : Type u} [CommRing R] + (x : NormalizedMarkoffSurface R) : NormalizedMarkoffSurface R := + ⟨normalizedSwap12 x.1, by + change normalizedPolynomial (normalizedSwap12 x.1) = 0 + rw [normalizedPolynomial_swap12] + exact x.property⟩ + +/-- Exchange the last two normalized coordinates on the normalized surface. -/ +def normalizedSwap23Surface {R : Type u} [CommRing R] + (x : NormalizedMarkoffSurface R) : NormalizedMarkoffSurface R := + ⟨normalizedSwap23 x.1, by + change normalizedPolynomial (normalizedSwap23 x.1) = 0 + rw [normalizedPolynomial_swap23] + exact x.property⟩ + +@[simp] +theorem coe_normalizedSwap12Surface {R : Type u} [CommRing R] + (x : NormalizedMarkoffSurface R) : + ((normalizedSwap12Surface x : NormalizedMarkoffSurface R) : NormalizedPoint R) = + normalizedSwap12 x := + rfl + +@[simp] +theorem coe_normalizedSwap23Surface {R : Type u} [CommRing R] + (x : NormalizedMarkoffSurface R) : + ((normalizedSwap23Surface x : NormalizedMarkoffSurface R) : NormalizedPoint R) = + normalizedSwap23 x := + rfl + +/-- The first normalized transposition is transported from the original surface. -/ +theorem normalizedSwap12Surface_eq_transport + {R : Type u} [CommRing R] [Invertible (3 : R)] + (x : NormalizedMarkoffSurface R) : + normalizedSwap12Surface x = + normalizationSurfaceEquiv R + (swap12SurfacePerm R ((normalizationSurfaceEquiv R).symm x)) := by + apply Subtype.ext + change normalizedSwap12 x = + toNormalized (swap12 ((normalizationSurfaceEquiv R).symm x : Point R)) + rw [toNormalized_swap12] + rw [show toNormalized ((normalizationSurfaceEquiv R).symm x : Point R) = x by + exact congrArg Subtype.val ((normalizationSurfaceEquiv R).apply_symm_apply x)] + +/-- The second normalized transposition is transported from the original surface. -/ +theorem normalizedSwap23Surface_eq_transport + {R : Type u} [CommRing R] [Invertible (3 : R)] + (x : NormalizedMarkoffSurface R) : + normalizedSwap23Surface x = + normalizationSurfaceEquiv R + (swap23SurfacePerm R ((normalizationSurfaceEquiv R).symm x)) := by + apply Subtype.ext + change normalizedSwap23 x = + toNormalized (swap23 ((normalizationSurfaceEquiv R).symm x : Point R)) + rw [toNormalized_swap23] + rw [show toNormalized ((normalizationSurfaceEquiv R).symm x : Point R) = x by + exact congrArg Subtype.val ((normalizationSurfaceEquiv R).apply_symm_apply x)] + +/-- The transported first coordinate transposition is the normalized swap. -/ +@[simp] +theorem gammaSwap12_smul_normalizedSurface + {R : Type u} [CommRing R] [Invertible (3 : R)] + (x : NormalizedMarkoffSurface R) : + gammaSwap12 R • x = normalizedSwap12Surface x := by + rw [normalizedGamma_smul_eq_perm, normalizedGammaPerm_apply] + rw [show (gammaSwap12 R : Equiv.Perm (MarkoffSurface R)) + ((normalizationSurfaceEquiv R).symm x) = + swap12SurfacePerm R ((normalizationSurfaceEquiv R).symm x) by + exact gammaSwap12_smul_surface ((normalizationSurfaceEquiv R).symm x)] + exact (normalizedSwap12Surface_eq_transport x).symm + +/-- The transported second coordinate transposition is the normalized swap. -/ +@[simp] +theorem gammaSwap23_smul_normalizedSurface + {R : Type u} [CommRing R] [Invertible (3 : R)] + (x : NormalizedMarkoffSurface R) : + gammaSwap23 R • x = normalizedSwap23Surface x := by + rw [normalizedGamma_smul_eq_perm, normalizedGammaPerm_apply] + rw [show (gammaSwap23 R : Equiv.Perm (MarkoffSurface R)) + ((normalizationSurfaceEquiv R).symm x) = + swap23SurfacePerm R ((normalizationSurfaceEquiv R).symm x) by + exact gammaSwap23_smul_surface ((normalizationSurfaceEquiv R).symm x)] + exact (normalizedSwap23Surface_eq_transport x).symm + +/-- Swapping the first two normalized coordinates stays in the same component. -/ +theorem sameNormalizedComponent_swap12Surface + {R : Type u} [CommRing R] [Invertible (3 : R)] + (x : NormalizedMarkoffSurface R) : + SameNormalizedComponent x (normalizedSwap12Surface x) := + (sameNormalizedComponent_iff_exists_gamma x _).2 + ⟨gammaSwap12 R, by simpa using gammaSwap12_smul_normalizedSurface x⟩ + +/-- Swapping the last two normalized coordinates stays in the same component. -/ +theorem sameNormalizedComponent_swap23Surface + {R : Type u} [CommRing R] [Invertible (3 : R)] + (x : NormalizedMarkoffSurface R) : + SameNormalizedComponent x (normalizedSwap23Surface x) := + (sameNormalizedComponent_iff_exists_gamma x _).2 + ⟨gammaSwap23 R, by simpa using gammaSwap23_smul_normalizedSurface x⟩ + +/-- The fundamental normalized rotation, restricted to the normalized surface. -/ +def normalizedRotate1Surface {R : Type u} [CommRing R] + (x : NormalizedMarkoffSurface R) : NormalizedMarkoffSurface R := + ⟨normalizedRotate1 x.1, (isNormalizedMarkoff_rotate1 x.1).2 x.property⟩ + +@[simp] +theorem coe_normalizedRotate1Surface {R : Type u} [CommRing R] + (x : NormalizedMarkoffSurface R) : + ((normalizedRotate1Surface x : NormalizedMarkoffSurface R) : NormalizedPoint R) = + normalizedRotate1 x := + rfl + +/-- Normalized rotation is the normalization of the original surface rotation. -/ +theorem normalizedRotate1Surface_eq_transport + {R : Type u} [CommRing R] [Invertible (3 : R)] + (x : NormalizedMarkoffSurface R) : + normalizedRotate1Surface x = + normalizationSurfaceEquiv R + (rotate1Surface ((normalizationSurfaceEquiv R).symm x)) := by + apply Subtype.ext + change normalizedRotate1 x = + toNormalized (rotate1 ((normalizationSurfaceEquiv R).symm x : Point R)) + rw [toNormalized_rotate1] + rw [show toNormalized ((normalizationSurfaceEquiv R).symm x : Point R) = x by + exact congrArg Subtype.val ((normalizationSurfaceEquiv R).apply_symm_apply x)] + +/-- The transported explicit rotation element acts by normalized rotation. -/ +@[simp] +theorem gammaRotate1_smul_normalizedSurface + {R : Type u} [CommRing R] [Invertible (3 : R)] + (x : NormalizedMarkoffSurface R) : + gammaRotate1 R • x = normalizedRotate1Surface x := by + rw [normalizedGamma_smul_eq_perm, normalizedGammaPerm_apply] + rw [show (gammaRotate1 R : Equiv.Perm (MarkoffSurface R)) + ((normalizationSurfaceEquiv R).symm x) = + rotate1Surface ((normalizationSurfaceEquiv R).symm x) by + exact gammaRotate1_smul_surface ((normalizationSurfaceEquiv R).symm x)] + exact (normalizedRotate1Surface_eq_transport x).symm + +/-- One normalized rotation stays in the transported Markoff component. -/ +theorem sameNormalizedComponent_rotate1Surface + {R : Type u} [CommRing R] [Invertible (3 : R)] + (x : NormalizedMarkoffSurface R) : + SameNormalizedComponent x (normalizedRotate1Surface x) := by + rw [SameNormalizedComponent, normalizedRotate1Surface_eq_transport] + simpa using sameComponent_rotate1Surface ((normalizationSurfaceEquiv R).symm x) + +/-- Every natural iterate of the normalized rotation stays in the same transported component. -/ +theorem sameNormalizedComponent_iterate_normalizedRotate1Surface + {R : Type u} [CommRing R] [Invertible (3 : R)] + (x : NormalizedMarkoffSurface R) (n : ℕ) : + SameNormalizedComponent x ((normalizedRotate1Surface^[n]) x) := by + induction n with + | zero => exact sameNormalizedComponent_refl x + | succ n ih => + rw [Function.iterate_succ_apply'] + exact sameNormalizedComponent_trans ih + (sameNormalizedComponent_rotate1Surface ((normalizedRotate1Surface^[n]) x)) + +/-- In particular, every positive iterate stays in the same transported component. -/ +theorem sameNormalizedComponent_positive_iterate_normalizedRotate1Surface + {R : Type u} [CommRing R] [Invertible (3 : R)] + (x : NormalizedMarkoffSurface R) (n : ℕ) (_hn : 0 < n) : + SameNormalizedComponent x ((normalizedRotate1Surface^[n]) x) := + sameNormalizedComponent_iterate_normalizedRotate1Surface x n + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Core/ParabolicFibers.lean b/LeanPool/MarkoffModP/BGS/Markoff/Core/ParabolicFibers.lean new file mode 100644 index 0000000000..fff08a28c7 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Core/ParabolicFibers.lean @@ -0,0 +1,464 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Core.Normalization +public import LeanPool.MarkoffModP.BGS.Markoff.Core.Rotation +public import Mathlib.NumberTheory.LegendreSymbol.Basic + +/-! +# Parabolic fibers of the normalized Markoff surface + +This module exposes the elementary algebra suppressed in Lemma 3 of +Bourgain--Gamburd--Sarnak. The parameter fixed in the first coordinate is a normalized trace, +so the exceptional values are `2` and `-2`, not the original-coordinate values `2 / 3` and +`-2 / 3`. +-/ + +@[expose] public section + +namespace BGS.Markoff + +universe u + +open scoped Matrix + +/-- One of the two affine lines above the normalized parabolic trace `2`. Replacing `i` by +`-i` gives the other line. -/ +def parabolicLineAtTwo {R : Type u} [CommRing R] (i t : R) : NormalizedPoint R := + ⟨2, t, t + 2 * i⟩ + +/-- One of the two affine lines above the normalized parabolic trace `-2`. Replacing `i` by +`-i` gives the other line. -/ +def parabolicLineAtNegTwo {R : Type u} [CommRing R] (i t : R) : NormalizedPoint R := + ⟨-2, t, -t + 2 * i⟩ + +/-- At normalized trace `2`, the Markoff equation is the factorized equation +`(u₃ - u₂)² = -4`. -/ +theorem normalizedPolynomial_at_two {R : Type u} [CommRing R] (t s : R) : + normalizedPolynomial (⟨(2 : R), t, s⟩ : NormalizedPoint R) = (s - t) ^ 2 + 4 := by + simp [normalizedPolynomial] + ring + +/-- At normalized trace `-2`, the Markoff equation is the factorized equation +`(u₃ + u₂)² = -4`. -/ +theorem normalizedPolynomial_at_neg_two {R : Type u} [CommRing R] (t s : R) : + normalizedPolynomial (⟨(-2 : R), t, s⟩ : NormalizedPoint R) = (s + t) ^ 2 + 4 := by + simp [normalizedPolynomial] + ring + +theorem isNormalizedMarkoff_at_two_iff {R : Type u} [CommRing R] (t s : R) : + IsNormalizedMarkoff (⟨(2 : R), t, s⟩ : NormalizedPoint R) ↔ + (s - t) ^ 2 = -(2 : R) ^ 2 := by + rw [IsNormalizedMarkoff, normalizedPolynomial_at_two] + constructor <;> intro h + · linear_combination h + · linear_combination h + +theorem isNormalizedMarkoff_at_neg_two_iff {R : Type u} [CommRing R] (t s : R) : + IsNormalizedMarkoff (⟨(-2 : R), t, s⟩ : NormalizedPoint R) ↔ + (s + t) ^ 2 = -(2 : R) ^ 2 := by + rw [IsNormalizedMarkoff, normalizedPolynomial_at_neg_two] + constructor <;> intro h + · linear_combination h + · linear_combination h + +/-- Once a square root `i` of `-1` is fixed, the trace-`2` equation has exactly the two +displayed line solutions. -/ +theorem isNormalizedMarkoff_at_two_iff_on_parabolic_lines + {R : Type u} [CommRing R] [NoZeroDivisors R] {i t s : R} (hi : i ^ 2 = -1) : + IsNormalizedMarkoff (⟨2, t, s⟩ : NormalizedPoint R) ↔ + s = t + 2 * i ∨ s = t + 2 * (-i) := by + rw [isNormalizedMarkoff_at_two_iff] + have hroot : (2 * i) ^ 2 = -(2 : R) ^ 2 := by + rw [mul_pow, hi] + ring + rw [← hroot, sq_eq_sq_iff_eq_or_eq_neg] + constructor + · rintro (h | h) + · left + linear_combination h + · right + linear_combination h + · rintro (h | h) + · left + linear_combination h + · right + linear_combination h + +/-- Once a square root `i` of `-1` is fixed, the trace-`-2` equation has exactly the two +displayed line solutions. -/ +theorem isNormalizedMarkoff_at_neg_two_iff_on_parabolic_lines + {R : Type u} [CommRing R] [NoZeroDivisors R] {i t s : R} (hi : i ^ 2 = -1) : + IsNormalizedMarkoff (⟨-2, t, s⟩ : NormalizedPoint R) ↔ + s = -t + 2 * i ∨ s = -t + 2 * (-i) := by + rw [isNormalizedMarkoff_at_neg_two_iff] + have hroot : (2 * i) ^ 2 = -(2 : R) ^ 2 := by + rw [mul_pow, hi] + ring + rw [← hroot, sq_eq_sq_iff_eq_or_eq_neg] + constructor + · rintro (h | h) + · left + linear_combination h + · right + linear_combination h + · rintro (h | h) + · left + linear_combination h + · right + linear_combination h + +/-- Set-theoretic classification of the normalized trace-`2` fiber as two affine lines. -/ +theorem normalizedFiber1_two_eq_parabolic_lines + {R : Type u} [CommRing R] [NoZeroDivisors R] (i : R) (hi : i ^ 2 = -1) : + normalizedFiber1 (2 : R) = + Set.range (parabolicLineAtTwo i) ∪ Set.range (parabolicLineAtTwo (-i)) := by + ext x + rcases x with ⟨u1, u2, u3⟩ + constructor + · rintro ⟨hx, hx1⟩ + change u1 = 2 at hx1 + subst u1 + rw [isNormalizedMarkoff_at_two_iff_on_parabolic_lines hi] at hx + rcases hx with hline | hline + · left + refine ⟨u2, ?_⟩ + ext <;> simp [parabolicLineAtTwo, hline] + · right + refine ⟨u2, ?_⟩ + ext <;> simp [parabolicLineAtTwo, hline] + · rintro (⟨t, ht⟩ | ⟨t, ht⟩) + · rw [← ht] + constructor + · change IsNormalizedMarkoff (⟨2, t, t + 2 * i⟩ : NormalizedPoint R) + rw [isNormalizedMarkoff_at_two_iff_on_parabolic_lines hi] + exact Or.inl rfl + · rfl + · rw [← ht] + constructor + · change IsNormalizedMarkoff (⟨2, t, t + 2 * (-i)⟩ : NormalizedPoint R) + rw [isNormalizedMarkoff_at_two_iff_on_parabolic_lines hi] + exact Or.inr rfl + · rfl + +/-- Set-theoretic classification of the normalized trace-`-2` fiber as two affine lines. -/ +theorem normalizedFiber1_neg_two_eq_parabolic_lines + {R : Type u} [CommRing R] [NoZeroDivisors R] (i : R) (hi : i ^ 2 = -1) : + normalizedFiber1 (-2 : R) = + Set.range (parabolicLineAtNegTwo i) ∪ Set.range (parabolicLineAtNegTwo (-i)) := by + ext x + rcases x with ⟨u1, u2, u3⟩ + constructor + · rintro ⟨hx, hx1⟩ + change u1 = -2 at hx1 + subst u1 + rw [isNormalizedMarkoff_at_neg_two_iff_on_parabolic_lines hi] at hx + rcases hx with hline | hline + · left + refine ⟨u2, ?_⟩ + ext <;> simp [parabolicLineAtNegTwo, hline] + · right + refine ⟨u2, ?_⟩ + ext <;> simp [parabolicLineAtNegTwo, hline] + · rintro (⟨t, ht⟩ | ⟨t, ht⟩) + · rw [← ht] + constructor + · change IsNormalizedMarkoff (⟨-2, t, -t + 2 * i⟩ : NormalizedPoint R) + rw [isNormalizedMarkoff_at_neg_two_iff_on_parabolic_lines hi] + exact Or.inl rfl + · rfl + · rw [← ht] + constructor + · change IsNormalizedMarkoff (⟨-2, t, -t + 2 * (-i)⟩ : NormalizedPoint R) + rw [isNormalizedMarkoff_at_neg_two_iff_on_parabolic_lines hi] + exact Or.inr rfl + · rfl + +/-- Each parabolic-line parametrization is injective because its second coordinate is the +parameter. -/ +theorem parabolicLineAtTwo_injective + {R : Type u} [CommRing R] (i : R) : Function.Injective (parabolicLineAtTwo i) := by + intro t s h + exact congrArg NormalizedPoint.u2 h + +/-- Each trace-`-2` parabolic-line parametrization is injective. -/ +theorem parabolicLineAtNegTwo_injective + {R : Type u} [CommRing R] (i : R) : Function.Injective (parabolicLineAtNegTwo i) := by + intro t s h + exact congrArg NormalizedPoint.u2 h + +/-- The two trace-`2` lines are disjoint whenever `4i` is nonzero. -/ +theorem parabolicLineAtTwo_disjoint + {R : Type u} [CommRing R] (i : R) (hfourI : (4 : R) * i ≠ 0) : + Disjoint (Set.range (parabolicLineAtTwo i)) (Set.range (parabolicLineAtTwo (-i))) := by + rw [Set.disjoint_left] + rintro x ⟨t, rfl⟩ ⟨s, hs⟩ + have hparameter := congrArg NormalizedPoint.u2 hs + have hst : s = t := by simpa [parabolicLineAtTwo] using hparameter + subst s + have hthird := congrArg NormalizedPoint.u3 hs + change t + 2 * (-i) = t + 2 * i at hthird + apply hfourI + linear_combination -hthird + +/-- The two trace-`-2` lines are disjoint whenever `4i` is nonzero. -/ +theorem parabolicLineAtNegTwo_disjoint + {R : Type u} [CommRing R] (i : R) (hfourI : (4 : R) * i ≠ 0) : + Disjoint (Set.range (parabolicLineAtNegTwo i)) + (Set.range (parabolicLineAtNegTwo (-i))) := by + rw [Set.disjoint_left] + rintro x ⟨t, rfl⟩ ⟨s, hs⟩ + have hparameter := congrArg NormalizedPoint.u2 hs + have hst : s = t := by simpa [parabolicLineAtNegTwo] using hparameter + subst s + have hthird := congrArg NormalizedPoint.u3 hs + change -t + 2 * (-i) = -t + 2 * i at hthird + apply hfourI + linear_combination -hthird + +/-- The normalized rotation at trace `2` acts by translation on either parabolic line. -/ +@[simp] +theorem normalizedRotate1_parabolicLineAtTwo + {R : Type u} [CommRing R] (i t : R) : + normalizedRotate1 (parabolicLineAtTwo i t) = parabolicLineAtTwo i (t + 2 * i) := by + ext <;> simp [normalizedRotate1, parabolicLineAtTwo] + ring + +/-- The normalized rotation at trace `-2` exchanges the two parabolic lines. -/ +@[simp] +theorem normalizedRotate1_parabolicLineAtNegTwo + {R : Type u} [CommRing R] (i t : R) : + normalizedRotate1 (parabolicLineAtNegTwo i t) = + parabolicLineAtNegTwo (-i) (-t + 2 * i) := by + ext <;> simp [normalizedRotate1, parabolicLineAtNegTwo] + ring + +/-- Two steps of the trace-`-2` rotation return to the same line and translate its parameter. -/ +theorem normalizedRotate1_twice_parabolicLineAtNegTwo + {R : Type u} [CommRing R] (i t : R) : + normalizedRotate1 (normalizedRotate1 (parabolicLineAtNegTwo i t)) = + parabolicLineAtNegTwo i (t - 4 * i) := by + ext <;> simp [normalizedRotate1, parabolicLineAtNegTwo] <;> ring + +/-- A natural number strictly between zero and the modulus remains nonzero in `ZMod p`. -/ +private theorem natCast_ne_zero_zmod_of_pos_of_lt + {n p : ℕ} (hn : 0 < n) (hnp : n < p) : (n : ZMod p) ≠ 0 := by + intro hzero + have hdvd : p ∣ n := (ZMod.natCast_eq_zero_iff n p).mp hzero + exact (Nat.not_le_of_gt hnp) (Nat.le_of_dvd hn hdvd) + +/-- If `p ≡ 3 (mod 4)`, the normalized trace-`2` fiber is empty. -/ +theorem normalizedFiber1_two_eq_empty_of_mod_four_eq_three + (p : ℕ) [Fact p.Prime] (hmod : p % 4 = 3) : + normalizedFiber1 (2 : ZMod p) = ∅ := by + ext x + simp only [Set.mem_empty_iff_false, iff_false] + rcases x with ⟨u1, u2, u3⟩ + rintro ⟨hsurface, hu1⟩ + change u1 = 2 at hu1 + subst u1 + have hpGreaterThanTwo : 2 < p := by + by_contra hp + have hpLe : p ≤ 2 := Nat.le_of_not_gt hp + interval_cases p <;> norm_num at hmod + have htwo : (2 : ZMod p) ≠ 0 := + natCast_ne_zero_zmod_of_pos_of_lt (by norm_num) hpGreaterThanTwo + have hsquare : (u3 - u2) ^ 2 = -(2 : ZMod p) ^ 2 := + (isNormalizedMarkoff_at_two_iff u2 u3).mp hsurface + exact (ZMod.mod_four_ne_three_of_sq_eq_neg_sq' htwo hsquare) hmod + +/-- If `p ≡ 3 (mod 4)`, the normalized trace-`-2` fiber is empty. -/ +theorem normalizedFiber1_neg_two_eq_empty_of_mod_four_eq_three + (p : ℕ) [Fact p.Prime] (hmod : p % 4 = 3) : + normalizedFiber1 (-2 : ZMod p) = ∅ := by + ext x + simp only [Set.mem_empty_iff_false, iff_false] + rcases x with ⟨u1, u2, u3⟩ + rintro ⟨hsurface, hu1⟩ + change u1 = -2 at hu1 + subst u1 + have hpGreaterThanTwo : 2 < p := by + by_contra hp + have hpLe : p ≤ 2 := Nat.le_of_not_gt hp + interval_cases p <;> norm_num at hmod + have htwo : (2 : ZMod p) ≠ 0 := + natCast_ne_zero_zmod_of_pos_of_lt (by norm_num) hpGreaterThanTwo + have hsquare : (u3 + u2) ^ 2 = -(2 : ZMod p) ^ 2 := + (isNormalizedMarkoff_at_neg_two_iff u2 u3).mp hsurface + exact (ZMod.mod_four_ne_three_of_sq_eq_neg_sq' htwo hsquare) hmod + +/-- If `p ≡ 1 (mod 4)`, a square root of `-1` exists and simultaneously supplies the two-line +descriptions of both normalized parabolic fibers. -/ +theorem exists_parabolic_line_decomposition_of_mod_four_eq_one + (p : ℕ) [Fact p.Prime] (hmod : p % 4 = 1) : + ∃ i : ZMod p, + i ^ 2 = -1 ∧ + normalizedFiber1 (2 : ZMod p) = + Set.range (parabolicLineAtTwo i) ∪ Set.range (parabolicLineAtTwo (-i)) ∧ + normalizedFiber1 (-2 : ZMod p) = + Set.range (parabolicLineAtNegTwo i) ∪ Set.range (parabolicLineAtNegTwo (-i)) := by + rcases (ZMod.exists_sq_eq_neg_one_iff (p := p)).2 (by omega) with ⟨i, hi⟩ + have hi' : i ^ 2 = -1 := by simpa [pow_two] using hi.symm + exact ⟨i, hi', normalizedFiber1_two_eq_parabolic_lines i hi', + normalizedFiber1_neg_two_eq_parabolic_lines i hi'⟩ + +/-- Iterating the trace-`2` rotation translates the line parameter by `2ni`. -/ +theorem iterate_normalizedRotate1_parabolicLineAtTwo + {R : Type u} [CommRing R] (n : ℕ) (i t : R) : + (normalizedRotate1^[n]) (parabolicLineAtTwo i t) = + parabolicLineAtTwo i (t + (n : R) * (2 * i)) := by + induction n with + | zero => simp + | succ n ih => + rw [Function.iterate_succ_apply', ih, + normalizedRotate1_parabolicLineAtTwo] + congr 1 + push_cast + ring + +/-- On either trace-`2` parabolic line over `ZMod p`, a rotation iterate returns to its starting +point exactly when the exponent is divisible by `p`. -/ +theorem iterate_normalizedRotate1_parabolicLineAtTwo_eq_self_iff + (p : ℕ) [Fact p.Prime] (hpTwo : p ≠ 2) (n : ℕ) (i t : ZMod p) + (hi : i ^ 2 = -1) : + (normalizedRotate1^[n]) (parabolicLineAtTwo i t) = parabolicLineAtTwo i t ↔ p ∣ n := by + rw [iterate_normalizedRotate1_parabolicLineAtTwo] + constructor + · intro hreturn + have hparameter := congrArg NormalizedPoint.u2 hreturn + change t + (n : ZMod p) * (2 * i) = t at hparameter + have hi0 : i ≠ 0 := by + intro hi0 + subst i + norm_num at hi + have htwo : (2 : ZMod p) ≠ 0 := + natCast_ne_zero_zmod_of_pos_of_lt (by norm_num) (by + have hpLower : 2 ≤ p := (Fact.out : p.Prime).two_le + exact lt_of_le_of_ne hpLower (Ne.symm hpTwo)) + have hnzero : (n : ZMod p) = 0 := by + apply (mul_eq_zero.mp ?_).resolve_right (mul_ne_zero htwo hi0) + linear_combination hparameter + exact (ZMod.natCast_eq_zero_iff n p).mp hnzero + · intro hn + have hnzero : (n : ZMod p) = 0 := (ZMod.natCast_eq_zero_iff n p).2 hn + simp [hnzero] + +/-- Closed formula for powers of the unipotent normalized rotation with trace `2`. -/ +theorem rho_two_pow {R : Type u} [CommRing R] (n : ℕ) : + rho (2 : R) ^ n = + !![(1 : R) - n, n; -(n : R), 1 + n] := by + induction n with + | zero => + ext a b + fin_cases a <;> fin_cases b <;> simp + | succ n ih => + rw [pow_succ, ih] + ext a b + fin_cases a <;> fin_cases b <;> + simp [rho, Matrix.mul_apply, Fin.sum_univ_two] <;> ring + +/-- A power of the trace-`2` rotation over `ZMod p` is the identity exactly at multiples of the +characteristic. -/ +theorem rhoSL_two_pow_eq_one_iff + (p : ℕ) [Fact p.Prime] (n : ℕ) : + rhoSL (2 : ZMod p) ^ n = 1 ↔ p ∣ n := by + constructor + · intro hpower + have hmatrix := congrArg + (fun g : Matrix.SpecialLinearGroup (Fin 2) (ZMod p) => + (g : Matrix (Fin 2) (Fin 2) (ZMod p))) hpower + change rho (2 : ZMod p) ^ n = 1 at hmatrix + have hentry := congrArg (fun m : Matrix (Fin 2) (Fin 2) (ZMod p) => m 0 1) hmatrix + simp [rho_two_pow] at hentry + exact (ZMod.natCast_eq_zero_iff n p).mp hentry + · intro hn + have hnzero : (n : ZMod p) = 0 := (ZMod.natCast_eq_zero_iff n p).2 hn + apply Matrix.SpecialLinearGroup.ext + intro a b + change (rho (2 : ZMod p) ^ n) a b = (1 : Matrix (Fin 2) (Fin 2) (ZMod p)) a b + fin_cases a <;> fin_cases b <;> simp [rho_two_pow, hnzero] + +/-- The normalized trace-`2` rotation has exact group-theoretic order `p`. -/ +theorem rotationOrder_two (p : ℕ) [Fact p.Prime] : + rotationOrder (2 : ZMod p) = p := by + rw [rotationOrder, orderOf_eq_iff (Fact.out : p.Prime).pos] + constructor + · exact (rhoSL_two_pow_eq_one_iff p p).2 dvd_rfl + · intro m hmLower hmPositive hpower + exact (Nat.not_dvd_of_pos_of_lt hmPositive hmLower) + ((rhoSL_two_pow_eq_one_iff p m).mp hpower) + +/-- Closed formula for powers of the nontrivial parabolic normalized rotation with trace `-2`. +The scalar factor records its eigenvalue `-1`; the remaining matrix is unipotent. -/ +theorem rho_neg_two_pow {R : Type u} [CommRing R] (n : ℕ) : + rho (-2 : R) ^ n = + !![(-1 : R) ^ n * (1 - n), (-1 : R) ^ n * (-(n : R)); + (-1 : R) ^ n * n, (-1 : R) ^ n * (1 + n)] := by + induction n with + | zero => + ext a b + fin_cases a <;> fin_cases b <;> simp + | succ n ih => + rw [pow_succ, ih] + ext a b + fin_cases a <;> fin_cases b <;> + simp [rho, Matrix.mul_apply, Fin.sum_univ_two, pow_succ] <;> ring + +/-- A power of the trace-`-2` rotation over an odd prime field is the identity exactly at +multiples of `2p`. -/ +theorem rhoSL_neg_two_pow_eq_one_iff + (p : ℕ) [Fact p.Prime] (hpTwo : p ≠ 2) (n : ℕ) : + rhoSL (-2 : ZMod p) ^ n = 1 ↔ 2 * p ∣ n := by + have hnegOne : (-1 : ZMod p) ≠ 1 := by + intro h + have htwo : (2 : ZMod p) = 0 := by linear_combination -h + have hpLe : p ≤ 2 := Nat.le_of_dvd (by norm_num) + ((ZMod.natCast_eq_zero_iff 2 p).mp htwo) + exact hpTwo (Nat.le_antisymm hpLe (Fact.out : p.Prime).two_le) + constructor + · intro hpower + have hmatrix := congrArg + (fun g : Matrix.SpecialLinearGroup (Fin 2) (ZMod p) => + (g : Matrix (Fin 2) (Fin 2) (ZMod p))) hpower + change rho (-2 : ZMod p) ^ n = 1 at hmatrix + have hoffDiagonal := congrArg + (fun m : Matrix (Fin 2) (Fin 2) (ZMod p) => m 0 1) hmatrix + have hnzero : (n : ZMod p) = 0 := by + simpa [rho_neg_two_pow] using hoffDiagonal + have hpdvd : p ∣ n := (ZMod.natCast_eq_zero_iff n p).mp hnzero + have hdiagonal := congrArg + (fun m : Matrix (Fin 2) (Fin 2) (ZMod p) => m 0 0) hmatrix + have hsign : (-1 : ZMod p) ^ n = 1 := by + simpa [rho_neg_two_pow, hnzero] using hdiagonal + have heven : Even n := (neg_one_pow_eq_one_iff_even hnegOne).mp hsign + exact (Fact.out : p.Prime).odd_of_ne_two hpTwo |>.coprime_two_left + |>.mul_dvd_of_dvd_of_dvd heven.two_dvd hpdvd + · intro hn + have hpdvd : p ∣ n := (dvd_mul_left p 2).trans hn + have htwoDvd : 2 ∣ n := (dvd_mul_right 2 p).trans hn + have heven : Even n := even_iff_two_dvd.mpr htwoDvd + have hnzero : (n : ZMod p) = 0 := (ZMod.natCast_eq_zero_iff n p).2 hpdvd + have hsign : (-1 : ZMod p) ^ n = 1 := heven.neg_one_pow + apply Matrix.SpecialLinearGroup.ext + intro a b + change (rho (-2 : ZMod p) ^ n) a b = (1 : Matrix (Fin 2) (Fin 2) (ZMod p)) a b + fin_cases a <;> fin_cases b <;> + simp [rho_neg_two_pow, hnzero, hsign] + +/-- The normalized trace-`-2` rotation has exact group-theoretic order `2p` for odd `p`. -/ +theorem rotationOrder_neg_two + (p : ℕ) [Fact p.Prime] (hpTwo : p ≠ 2) : + rotationOrder (-2 : ZMod p) = 2 * p := by + rw [rotationOrder, orderOf_eq_iff (Nat.mul_pos (by norm_num) (Fact.out : p.Prime).pos)] + constructor + · exact (rhoSL_neg_two_pow_eq_one_iff p hpTwo (2 * p)).2 dvd_rfl + · intro m hmLower hmPositive hpower + exact (Nat.not_dvd_of_pos_of_lt hmPositive hmLower) + ((rhoSL_neg_two_pow_eq_one_iff p hpTwo m).mp hpower) + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Core/PuncturedNormalization.lean b/LeanPool/MarkoffModP/BGS/Markoff/Core/PuncturedNormalization.lean new file mode 100644 index 0000000000..64815ce682 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Core/PuncturedNormalization.lean @@ -0,0 +1,77 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Core.Action +public import LeanPool.MarkoffModP.BGS.Markoff.Core.Normalization + +/-! +# Normalization on the punctured Markoff surface + +Scaling every original Markoff coordinate by three gives an equivalence with the normalized +punctured surface when three is invertible. The assembly-specific small-order sets transported +through this equivalence are defined in `BGS.Markoff.Assembly.PuncturedSmallOrderCount`. +-/ + +@[expose] public section + +namespace BGS.Markoff + +universe u + +/-- Scaling by three identifies the action carrier of original punctured Markoff points with the +subtype of normalized punctured Markoff points. -/ +def puncturedNormalizationEquiv (R : Type u) [CommRing R] [Invertible (3 : R)] : + PuncturedMarkoffSurface R ≃ ↑(normalizedPuncturedSurface R) := + (puncturedSurfaceEquiv R).trans <| + (normalizationEquiv R).subtypeEquiv fun x => by + change (IsMarkoff x ∧ x ≠ origin) ↔ + (IsNormalizedMarkoff (toNormalized x) ∧ toNormalized x ≠ normalizedOrigin) + rw [isNormalizedMarkoff_toNormalized_iff] + constructor + · rintro ⟨hx, hx0⟩ + refine ⟨hx, ?_⟩ + intro hnormalize + apply hx0 + apply (normalizationEquiv R).injective + simpa [normalizationEquiv] using hnormalize + · rintro ⟨hx, hx0⟩ + refine ⟨hx, ?_⟩ + intro horigin + apply hx0 + simp [horigin] + +@[simp] +theorem puncturedNormalizationEquiv_coe + {R : Type u} [CommRing R] [Invertible (3 : R)] + (x : PuncturedMarkoffSurface R) : + ((puncturedNormalizationEquiv R x : ↑(normalizedPuncturedSurface R)) : + NormalizedPoint R) = toNormalized x.1.1 := + rfl + +/-- Pull a finite set of normalized punctured points back to original punctured coordinates. -/ +noncomputable def originalPuncturedFinsetOfNormalized + {R : Type u} [CommRing R] [Invertible (3 : R)] + (S : Finset ↑(normalizedPuncturedSurface R)) : Finset (PuncturedMarkoffSurface R) := + S.map (puncturedNormalizationEquiv R).symm.toEmbedding + +@[simp] +theorem mem_originalPuncturedFinsetOfNormalized_iff + {R : Type u} [CommRing R] [Invertible (3 : R)] + {S : Finset ↑(normalizedPuncturedSurface R)} {x : PuncturedMarkoffSurface R} : + x ∈ originalPuncturedFinsetOfNormalized S ↔ puncturedNormalizationEquiv R x ∈ S := by + classical + simp [originalPuncturedFinsetOfNormalized] + +/-- Pullback through normalization preserves the exact cardinality of every finite set. -/ +theorem originalPuncturedFinsetOfNormalized_card + {R : Type u} [CommRing R] [Invertible (3 : R)] + (S : Finset ↑(normalizedPuncturedSurface R)) : + (originalPuncturedFinsetOfNormalized S).card = S.card := by + simp [originalPuncturedFinsetOfNormalized] + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Core/Rotation.lean b/LeanPool/MarkoffModP/BGS/Markoff/Core/Rotation.lean new file mode 100644 index 0000000000..c2503ea1ad --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Core/Rotation.lean @@ -0,0 +1,109 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Core.Basic + +/-! +# The normalized Markoff rotation + +This file isolates the elementary two-dimensional linear algebra behind the fundamental +rotation. The parameter of `rho` is a normalized trace coordinate. Thus the rotation fixing an +original Markoff coordinate `x.x1` is obtained by specializing the parameter to `3 * x.x1`. +-/ + +@[expose] public section + +namespace BGS.Markoff + +universe u + +open scoped Matrix + +section + +variable {R : Type u} [CommRing R] + +/-- The normalized rotation matrix `rho(t) = [[0, 1], [-1, t]]`. -/ +def rho (t : R) : Matrix (Fin 2) (Fin 2) R := + !![0, 1; -1, t] + +/-- Every normalized rotation matrix has determinant one. -/ +@[simp] +theorem rho_det (t : R) : (rho t).det = 1 := by + simp [rho, Matrix.det_fin_two_of] + +/-- The matrix parameter is exactly the trace of the normalized rotation. -/ +@[simp] +theorem rho_trace (t : R) : (rho t).trace = t := by + simp [rho, Matrix.trace_fin_two_of] + +/-- The characteristic polynomial is `T² - tT + 1`. -/ +@[simp] +theorem rho_charpoly [Nontrivial R] (t : R) : + (rho t).charpoly = Polynomial.X ^ 2 - Polynomial.C t * Polynomial.X + 1 := by + simpa using Matrix.charpoly_fin_two (rho t) + +/-- On a coordinate pair, `rho(t)` sends `(a, b)` to `(b, t * b - a)`. -/ +@[simp] +theorem rho_mulVec (t a b : R) : rho t *ᵥ ![a, b] = ![b, t * b - a] := by + ext i + fin_cases i + · simp [rho, Matrix.mulVec, dotProduct] + · simp [rho, Matrix.mulVec, dotProduct] + ring + +/-- The normalized rotation, regarded as an element of the special linear group. -/ +def rhoSL (t : R) : Matrix.SpecialLinearGroup (Fin 2) R := + ⟨rho t, rho_det t⟩ + +@[simp] +theorem rhoSL_coe (t : R) : (rhoSL t : Matrix (Fin 2) (Fin 2) R) = rho t := + rfl + +/-- The group-theoretic order of the normalized rotation. + +By the convention of `orderOf`, this is zero when the rotation has infinite order. +-/ +noncomputable def rotationOrder (t : R) : ℕ := + orderOf (rhoSL t) + +/-- Raising the rotation to `rotationOrder` gives the identity in `SL₂`. -/ +theorem rhoSL_pow_rotationOrder (t : R) : rhoSL t ^ rotationOrder t = 1 := by + simp [rotationOrder] + +/-- Over a finite coefficient ring, every normalized rotation has positive order. -/ +theorem rotationOrder_pos [Finite R] (t : R) : 0 < rotationOrder t := by + exact (isOfFinOrder_of_finite (rhoSL t)).orderOf_pos + +/-- The two coordinates moved by the fundamental rotation fixing the first coordinate. -/ +def movingCoordinates (x : Point R) : Fin 2 → R := + ![x.x2, x.x3] + +/-- The fundamental rotation is the action of `rho(3 * x.x1)` on the moving coordinates. -/ +theorem rho_mulVec_movingCoordinates (x : Point R) : + rho (3 * x.x1) *ᵥ movingCoordinates x = movingCoordinates (rotate1 x) := by + simp [movingCoordinates, rotate1] + +/-- The normalized trace parameter for the fundamental rotation is `3 * x.x1`. -/ +theorem rho_trace_fundamentalRotation (x : Point R) : (rho (3 * x.x1)).trace = 3 * x.x1 := by + simp + +/-- Reconstruct the full fundamental rotation from the fixed coordinate and the matrix action. -/ +theorem rotate1_eq_rho (x : Point R) : + rotate1 x = + ⟨x.x1, + (rho (3 * x.x1) *ᵥ movingCoordinates x) 0, + (rho (3 * x.x1) *ᵥ movingCoordinates x) 1⟩ := by + ext + · rfl + · simp [rotate1, movingCoordinates] + · simp [rotate1, movingCoordinates] + +end + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Core/RotationTorus.lean b/LeanPool/MarkoffModP/BGS/Markoff/Core/RotationTorus.lean new file mode 100644 index 0000000000..15ec90075b --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Core/RotationTorus.lean @@ -0,0 +1,289 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.ElementaryCounts +public import LeanPool.MarkoffModP.BGS.Markoff.Core.Rotation +public import Mathlib.FieldTheory.Finite.Trace + +/-! +# Split-torus traces and normalized Markoff rotations + +This module makes explicit the elementary diagonalization used when a normalized rotation has +split characteristic polynomial. The two parabolic parameters are excluded by the mathematical +hypothesis `w ^ 2 ≠ 1`; at those parameters the matrix need not have the same order as `w`. +-/ + +@[expose] public section + +namespace BGS.Markoff + +open scoped Matrix + +section SplitTorus + +variable {F : Type*} [Field F] + +/-- The trace of the determinant-one diagonal matrix with eigenvalues `w` and `w⁻¹`. -/ +def splitTorusTrace (w : Fˣ) : F := + (w : F) + (w⁻¹ : Fˣ) + +/-- The determinant-one diagonal matrix with eigenvalues `w` and `w⁻¹`. -/ +noncomputable def splitDiagonalSL (w : Fˣ) : Matrix.SpecialLinearGroup (Fin 2) F := + Matrix.SpecialLinearGroup.diag2 (w : F) w.ne_zero + +@[simp] +theorem splitDiagonalSL_coe (w : Fˣ) : + (splitDiagonalSL w : Matrix (Fin 2) (Fin 2) F) = + !![(w : F), 0; 0, (w⁻¹ : Fˣ)] := by + simpa [splitDiagonalSL] using Matrix.SpecialLinearGroup.diag2_coe' w.ne_zero + +/-- An eigenbasis for a non-parabolic split trace. -/ +def splitEigenbasis (w : Fˣ) : Matrix (Fin 2) (Fin 2) F := + !![1, 1; (w : F), (w⁻¹ : Fˣ)] + +theorem splitEigenbasis_det (w : Fˣ) : + (splitEigenbasis w).det = (w⁻¹ : Fˣ) - (w : F) := by + simp [splitEigenbasis, Matrix.det_fin_two_of] + +theorem splitEigenbasis_det_ne_zero (w : Fˣ) (hw : (w : F) ^ 2 ≠ 1) : + (splitEigenbasis w).det ≠ 0 := by + rw [splitEigenbasis_det] + intro hdet + have hinv : ((w⁻¹ : Fˣ) : F) = (w : F) := sub_eq_zero.mp hdet + apply hw + rw [pow_two] + calc + (w : F) * (w : F) = ((w⁻¹ : Fˣ) : F) * (w : F) := by rw [hinv] + _ = 1 := by simp + +/-- The eigenbasis, regarded as an invertible matrix. -/ +noncomputable def splitEigenbasisGL (w : Fˣ) (hw : (w : F) ^ 2 ≠ 1) : + Matrix.GeneralLinearGroup (Fin 2) F := + Matrix.GeneralLinearGroup.mkOfDetNeZero (splitEigenbasis w) + (splitEigenbasis_det_ne_zero w hw) + +@[simp] +theorem splitEigenbasisGL_coe (w : Fˣ) (hw : (w : F) ^ 2 ≠ 1) : + (splitEigenbasisGL w hw : Matrix (Fin 2) (Fin 2) F) = splitEigenbasis w := + rfl + +/-- In the split eigenbasis, `rho (w + w⁻¹)` is diagonal. -/ +theorem splitEigenbasis_semiconj (w : Fˣ) (hw : (w : F) ^ 2 ≠ 1) : + SemiconjBy (splitEigenbasisGL w hw) + (Matrix.SpecialLinearGroup.toGL (splitDiagonalSL w)) + (Matrix.SpecialLinearGroup.toGL (rhoSL (splitTorusTrace w))) := by + apply Matrix.GeneralLinearGroup.ext + intro i j + fin_cases i <;> fin_cases j <;> + simp [splitEigenbasisGL, splitEigenbasis, splitDiagonalSL_coe, + splitTorusTrace, rho, Matrix.mul_apply] <;> + field_simp <;> ring + +/-- Diagonal determinant-one matrices multiply by multiplying their first eigenvalues. -/ +@[simp] +theorem splitDiagonalSL_mul (w z : Fˣ) : + splitDiagonalSL (w * z) = splitDiagonalSL w * splitDiagonalSL z := by + apply Subtype.ext + ext i j + fin_cases i <;> fin_cases j <;> + simp [splitDiagonalSL_coe, Matrix.mul_apply] + all_goals ring + +/-- Diagonal determinant-one matrices form the split-torus homomorphism into `SL₂`. -/ +noncomputable def splitDiagonalSLHom : Fˣ →* Matrix.SpecialLinearGroup (Fin 2) F where + toFun := splitDiagonalSL + map_one' := by + apply Subtype.ext + ext i j + fin_cases i <;> fin_cases j <;> simp [splitDiagonalSL_coe] + map_mul' := splitDiagonalSL_mul + +theorem splitDiagonalSLHom_injective : + Function.Injective (splitDiagonalSLHom : Fˣ → Matrix.SpecialLinearGroup (Fin 2) F) := by + intro w z h + apply Units.ext + have hentry := congrArg (fun A : Matrix.SpecialLinearGroup (Fin 2) F => + (A : Matrix (Fin 2) (Fin 2) F) 0 0) h + exact hentry + +/-- The diagonal `SL₂` element has exactly the multiplicative order of its first eigenvalue. -/ +theorem splitDiagonalSL_orderOf (w : Fˣ) : + orderOf (splitDiagonalSL w) = orderOf w := by + exact orderOf_injective splitDiagonalSLHom splitDiagonalSLHom_injective w + +/-- A non-parabolic split trace has rotation order equal to the order of either eigenvalue. -/ +theorem rotationOrder_splitTorusTrace (w : Fˣ) (hw : (w : F) ^ 2 ≠ 1) : + rotationOrder (splitTorusTrace w) = orderOf w := by + calc + rotationOrder (splitTorusTrace w) = + orderOf (Matrix.SpecialLinearGroup.toGL (rhoSL (splitTorusTrace w))) := by + rw [rotationOrder] + symm + exact orderOf_injective Matrix.SpecialLinearGroup.toGL + Matrix.SpecialLinearGroup.toGL_injective _ + _ = orderOf (Matrix.SpecialLinearGroup.toGL (splitDiagonalSL w)) := + (splitEigenbasis_semiconj w hw).orderOf_eq.symm + _ = orderOf (splitDiagonalSL w) := + orderOf_injective Matrix.SpecialLinearGroup.toGL + Matrix.SpecialLinearGroup.toGL_injective _ + _ = orderOf w := splitDiagonalSL_orderOf w + +/-- A small non-parabolic split rotation parameter belongs to the canonical bounded-order +split-trace set used by the giant-orbit count. -/ +theorem splitTorusTrace_mem_boundedOrderTraceSet_of_rotationOrder_lt + [Fintype Fˣ] [DecidableEq F] (w : Fˣ) (hw : (w : F) ^ 2 ≠ 1) (bound : ℕ) + (hsmall : rotationOrder (splitTorusTrace w) < bound) : + splitTorusTrace w ∈ boundedOrderTraceSet splitTorusTrace bound := by + rw [boundedOrderTraceSet, Finset.mem_image] + refine ⟨w, ?_, rfl⟩ + rw [elementsOfOrderLessThan, Finset.mem_filter] + exact ⟨Finset.mem_univ _, (rotationOrder_splitTorusTrace w hw) ▸ hsmall⟩ + +end SplitTorus + +section ExtensionEigenvalues + +variable {F E : Type*} [Field F] [Field E] [Algebra F E] + +/-- Diagonalization after extending scalars. This is the common kernel for both split +eigenvalues and eigenvalues in a quadratic nonsplit torus. -/ +theorem extensionEigenbasis_semiconj (t : F) (w : Eˣ) + (hw : (w : E) ^ 2 ≠ 1) (htrace : algebraMap F E t = splitTorusTrace w) : + SemiconjBy (splitEigenbasisGL w hw) + (Matrix.SpecialLinearGroup.toGL (splitDiagonalSL w)) + (Matrix.SpecialLinearGroup.mapGL E (rhoSL t)) := by + apply Matrix.GeneralLinearGroup.ext + intro i j + fin_cases i <;> fin_cases j <;> + simp [splitEigenbasisGL, splitEigenbasis, splitDiagonalSL_coe, + splitTorusTrace, rho, Matrix.mul_apply, htrace] <;> + field_simp <;> ring + +/-- If the eigenvalues of a non-parabolic normalized rotation lie in an injective scalar +extension, its rotation order is exactly the multiplicative order of either eigenvalue. -/ +theorem rotationOrder_eq_orderOf_extensionEigenvalue [FaithfulSMul F E] + (t : F) (w : Eˣ) (hw : (w : E) ^ 2 ≠ 1) + (htrace : algebraMap F E t = splitTorusTrace w) : + rotationOrder t = orderOf w := by + calc + rotationOrder t = orderOf (Matrix.SpecialLinearGroup.mapGL E (rhoSL t)) := by + rw [rotationOrder] + symm + exact orderOf_injective (Matrix.SpecialLinearGroup.mapGL E) + Matrix.SpecialLinearGroup.mapGL_injective _ + _ = orderOf (Matrix.SpecialLinearGroup.toGL (splitDiagonalSL w)) := + (extensionEigenbasis_semiconj t w hw htrace).orderOf_eq.symm + _ = orderOf (splitDiagonalSL w) := + orderOf_injective Matrix.SpecialLinearGroup.toGL + Matrix.SpecialLinearGroup.toGL_injective _ + _ = orderOf w := splitDiagonalSL_orderOf w + +/-- The scalar-extension order calculation feeds directly into the canonical bounded-order trace +set for any honestly embedded torus. In the nonsplit application, `H` is the norm-one subgroup +of a quadratic extension and `includeEigenvalue` is its subtype map. -/ +theorem extensionTrace_mem_boundedOrderTraceSet_of_rotationOrder_lt + [FaithfulSMul F E] {H : Type*} [Group H] [Fintype H] [DecidableEq F] + (includeEigenvalue : H →* Eˣ) (hinclude : Function.Injective includeEigenvalue) + (trace : H → F) (g : H) (hw : ((includeEigenvalue g : Eˣ) : E) ^ 2 ≠ 1) + (htrace : algebraMap F E (trace g) = splitTorusTrace (includeEigenvalue g)) + (bound : ℕ) (hsmall : rotationOrder (trace g) < bound) : + trace g ∈ boundedOrderTraceSet trace bound := by + rw [boundedOrderTraceSet, Finset.mem_image] + refine ⟨g, ?_, rfl⟩ + rw [elementsOfOrderLessThan, Finset.mem_filter] + refine ⟨Finset.mem_univ _, ?_⟩ + rw [rotationOrder_eq_orderOf_extensionEigenvalue (trace g) (includeEigenvalue g) hw htrace, + orderOf_injective includeEigenvalue hinclude] at hsmall + exact hsmall + +end ExtensionEigenvalues + +section QuadraticFiniteField + +variable (p : ℕ) [Fact p.Prime] + +/-- The canonical quadratic extension of `ZMod p` supplied by Mathlib. -/ +abbrev quadraticFiniteField := GaloisField p 2 + +/-- The norm-one subgroup of the multiplicative group of the quadratic finite field. -/ +noncomputable def quadraticNormOneTorus : Subgroup (quadraticFiniteField p)ˣ := + MonoidHom.ker (Units.map (Algebra.norm (ZMod p) (S := quadraticFiniteField p))) + +noncomputable instance quadraticNormOneTorusFintype : Fintype (quadraticNormOneTorus p) := + Fintype.ofFinite (quadraticNormOneTorus p) + +/-- The base-field trace on the quadratic norm-one torus. -/ +noncomputable def quadraticNormOneTrace (w : quadraticNormOneTorus p) : ZMod p := + Algebra.trace (ZMod p) (quadraticFiniteField p) + ((w : (quadraticFiniteField p)ˣ) : quadraticFiniteField p) + +/-- For a norm-one element in the quadratic extension, its field trace is the eigenvalue trace +`w + w⁻¹`. -/ +theorem algebraMap_quadraticNormOneTrace (w : quadraticNormOneTorus p) : + algebraMap (ZMod p) (quadraticFiniteField p) (quadraticNormOneTrace p w) = + splitTorusTrace (w : (quadraticFiniteField p)ˣ) := by + have hfinrank : Module.finrank (ZMod p) (quadraticFiniteField p) = 2 := + GaloisField.finrank p (by norm_num) + have htrace := FiniteField.algebraMap_trace_eq_sum_pow + (ZMod p) (quadraticFiniteField p) + ((w : (quadraticFiniteField p)ˣ) : quadraticFiniteField p) + have hnorm := FiniteField.algebraMap_norm_eq_prod_pow + (ZMod p) (quadraticFiniteField p) + ((w : (quadraticFiniteField p)ˣ) : quadraticFiniteField p) + rw [hfinrank, Nat.card_zmod] at htrace hnorm + simp only [Finset.sum_range_succ, Finset.sum_range_zero, Finset.prod_range_succ, + Finset.prod_range_zero, pow_zero, pow_one, zero_add, one_mul] at htrace hnorm + have hwNorm : Algebra.norm (ZMod p) + ((w : (quadraticFiniteField p)ˣ) : quadraticFiniteField p) = 1 := by + have hwMem := w.property + exact congrArg Units.val hwMem + rw [hwNorm, map_one] at hnorm + have hFrob : ((w : (quadraticFiniteField p)ˣ) : quadraticFiniteField p) ^ p = + (((w : (quadraticFiniteField p)ˣ) : quadraticFiniteField p)⁻¹) := by + apply (mul_eq_one_iff_eq_inv₀ + (show ((w : (quadraticFiniteField p)ˣ) : quadraticFiniteField p) ≠ 0 by + exact Units.ne_zero _)).mp + rw [mul_comm] + exact hnorm.symm + rw [quadraticNormOneTrace, htrace, hFrob] + simp [splitTorusTrace] + +/-- Away from the two parabolic eigenvalues, the normalized rotation order equals the order of +the corresponding norm-one element in the quadratic extension. -/ +theorem rotationOrder_quadraticNormOneTrace (w : quadraticNormOneTorus p) + (hw : (((w : (quadraticFiniteField p)ˣ) : quadraticFiniteField p) ^ 2) ≠ 1) : + rotationOrder (quadraticNormOneTrace p w) = orderOf w := by + calc + rotationOrder (quadraticNormOneTrace p w) = + orderOf (w : (quadraticFiniteField p)ˣ) := + rotationOrder_eq_orderOf_extensionEigenvalue + (quadraticNormOneTrace p w) (w : (quadraticFiniteField p)ˣ) hw + (algebraMap_quadraticNormOneTrace p w) + _ = orderOf w := + orderOf_injective (quadraticNormOneTorus p).subtype Subtype.coe_injective w + +/-- A small non-parabolic nonsplit rotation trace belongs to the canonical bounded-order trace +set of the quadratic norm-one torus. -/ +theorem quadraticNormOneTrace_mem_boundedOrderTraceSet_of_rotationOrder_lt + (w : quadraticNormOneTorus p) + (hw : (((w : (quadraticFiniteField p)ˣ) : quadraticFiniteField p) ^ 2) ≠ 1) + (bound : ℕ) (hsmall : rotationOrder (quadraticNormOneTrace p w) < bound) : + quadraticNormOneTrace p w ∈ boundedOrderTraceSet (quadraticNormOneTrace p) bound := by + exact extensionTrace_mem_boundedOrderTraceSet_of_rotationOrder_lt + (quadraticNormOneTorus p).subtype Subtype.coe_injective (quadraticNormOneTrace p) w hw + (algebraMap_quadraticNormOneTrace p w) bound hsmall + +/-- The nonsplit bounded-order trace set has the same crude quadratic bound used by the final +giant-orbit count. -/ +theorem quadraticNormOneTraceSet_card_le_bound_sq (bound : ℕ) : + (boundedOrderTraceSet (quadraticNormOneTrace p) bound).card ≤ bound ^ 2 := + boundedOrderTraceSet_card_le_bound_sq (quadraticNormOneTrace p) bound + +end QuadraticFiniteField + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Core/SemiringFunctor.lean b/LeanPool/MarkoffModP/BGS/Markoff/Core/SemiringFunctor.lean new file mode 100644 index 0000000000..0e570686d7 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Core/SemiringFunctor.lean @@ -0,0 +1,305 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Core.Action + +/-! +# The Markoff surface on commutative semirings + +The usual polynomial presentation by subtraction only makes sense over rings. For strong +approximation from natural-number solutions, the equation itself is the more fundamental +definition: + +`x₁² + x₂² + x₃² = 3 * x₁ * x₂ * x₃`. + +This file defines that solution type over every commutative semiring and its covariant map along +semiring homomorphisms. It also records the canonical reduction from `ℕ` to `ZMod p` and compares +the semiring definition with the existing ring-level `MarkoffSurface`. +-/ + +@[expose] public section + +open CategoryTheory + +namespace BGS + +/-- The Markoff surface, functorially evaluated on commutative semirings. -/ +def Markoff : CommSemiRingCat ⥤ Type where + obj R := {⟨x, y, z⟩ : R × R × R | x ^ 2 + y ^ 2 + z ^ 2 = 3 * x * y * z} + map f := ↾fun ⟨⟨x, y, z⟩, h⟩ ↦ ⟨⟨f.hom x, f.hom y, f.hom z⟩, by + simpa only [Set.mem_ofPred_eq, map_add, map_pow, map_mul, map_ofNat] using congrArg f.hom h⟩ + +end BGS + +namespace BGS.Markoff + +universe u v w + +open CategoryTheory + +/-- Strong approximation at modulus `p`: every Markoff solution modulo `p` is the +reduction of a natural-number solution. -/ +def StrongApproximationAt (p : ℕ) : Prop := + Function.Surjective + (BGS.Markoff.map (CommSemiRingCat.ofHom (Nat.castRingHom (ZMod p)))) + +/-- A point satisfies the Markoff equation over a commutative semiring. -/ +def IsSemiringMarkoff {R : Type u} [CommSemiring R] (x : Point R) : Prop := + x.x1 ^ 2 + x.x2 ^ 2 + x.x3 ^ 2 = 3 * x.x1 * x.x2 * x.x3 + +/-- Markoff solutions over a commutative semiring. -/ +abbrev SemiringMarkoffSurface (R : Type u) [CommSemiring R] := + {x : Point R // IsSemiringMarkoff x} + +/-- A concise name for the semiring-valued solution type of the Markoff equation. -/ +abbrev MarkoffSolutions (R : Type u) [CommSemiring R] := SemiringMarkoffSurface R + +/-- Apply a semiring homomorphism coordinatewise to a point of affine three-space. -/ +def semiringPointMap {R : Type u} {S : Type v} [CommSemiring R] [CommSemiring S] + (f : R →+* S) (x : Point R) : Point S := + ⟨f x.x1, f x.x2, f x.x3⟩ + +@[simp] +theorem semiringPointMap_x1 {R : Type u} {S : Type v} [CommSemiring R] [CommSemiring S] + (f : R →+* S) (x : Point R) : (semiringPointMap f x).x1 = f x.x1 := + rfl + +@[simp] +theorem semiringPointMap_x2 {R : Type u} {S : Type v} [CommSemiring R] [CommSemiring S] + (f : R →+* S) (x : Point R) : (semiringPointMap f x).x2 = f x.x2 := + rfl + +@[simp] +theorem semiringPointMap_x3 {R : Type u} {S : Type v} [CommSemiring R] [CommSemiring S] + (f : R →+* S) (x : Point R) : (semiringPointMap f x).x3 = f x.x3 := + rfl + +theorem isSemiringMarkoff_semiringPointMap + {R : Type u} {S : Type v} [CommSemiring R] [CommSemiring S] + (f : R →+* S) {x : Point R} (hx : IsSemiringMarkoff x) : + IsSemiringMarkoff (semiringPointMap f x) := by + simpa only [IsSemiringMarkoff, semiringPointMap, map_add, map_mul, map_pow, map_ofNat] using + congrArg f hx + +namespace SemiringMarkoffSurface + +/-- Map a Markoff solution along a homomorphism of commutative semirings. -/ +def map {R : Type u} {S : Type v} [CommSemiring R] [CommSemiring S] + (f : R →+* S) (x : SemiringMarkoffSurface R) : SemiringMarkoffSurface S := + ⟨semiringPointMap f x.1, isSemiringMarkoff_semiringPointMap f x.2⟩ + +@[simp] +theorem map_coe {R : Type u} {S : Type v} [CommSemiring R] [CommSemiring S] + (f : R →+* S) (x : SemiringMarkoffSurface R) : + (map f x : Point S) = semiringPointMap f x.1 := + rfl + +@[simp] +theorem map_x1 {R : Type u} {S : Type v} [CommSemiring R] [CommSemiring S] + (f : R →+* S) (x : SemiringMarkoffSurface R) : + (map f x).1.x1 = f x.1.x1 := + rfl + +@[simp] +theorem map_x2 {R : Type u} {S : Type v} [CommSemiring R] [CommSemiring S] + (f : R →+* S) (x : SemiringMarkoffSurface R) : + (map f x).1.x2 = f x.1.x2 := + rfl + +@[simp] +theorem map_x3 {R : Type u} {S : Type v} [CommSemiring R] [CommSemiring S] + (f : R →+* S) (x : SemiringMarkoffSurface R) : + (map f x).1.x3 = f x.1.x3 := + rfl + +@[simp] +theorem map_id {R : Type u} [CommSemiring R] (x : SemiringMarkoffSurface R) : + map (RingHom.id R) x = x := by + apply Subtype.ext + ext <;> rfl + +@[simp] +theorem map_comp {R : Type u} {S : Type v} {T : Type w} + [CommSemiring R] [CommSemiring S] [CommSemiring T] + (g : S →+* T) (f : R →+* S) (x : SemiringMarkoffSurface R) : + map (g.comp f) x = map g (map f x) := by + apply Subtype.ext + ext <;> rfl + +end SemiringMarkoffSurface + +/-- The covariant functor of Markoff solutions on commutative semirings. -/ +def markoffFunctor : CommSemiRingCat.{u} ⥤ Type u where + obj R := SemiringMarkoffSurface R + map f := ↾SemiringMarkoffSurface.map f.hom + map_id R := by + apply ConcreteCategory.hom_ext + intro x + exact SemiringMarkoffSurface.map_id x + map_comp f g := by + apply ConcreteCategory.hom_ext + intro x + exact SemiringMarkoffSurface.map_comp g.hom f.hom x + +/-- The public triple presentation of `Markoff` agrees with the structured presentation used +internally by the dynamical development. -/ +def markoffEquivSemiringMarkoffSurface (R : Type) [CommSemiring R] : + BGS.Markoff.obj (CommSemiRingCat.of R) ≃ SemiringMarkoffSurface R where + toFun x := ⟨⟨x.1.1, x.1.2.1, x.1.2.2⟩, x.2⟩ + invFun x := ⟨⟨x.1.x1, x.1.x2, x.1.x3⟩, x.2⟩ + left_inv x := Subtype.ext rfl + right_inv x := by + apply Subtype.ext + cases x.1 + rfl + +@[simp] +theorem markoffEquivSemiringMarkoffSurface_map + {R S : Type} [CommSemiring R] [CommSemiring S] + (f : R →+* S) (x : BGS.Markoff.obj (CommSemiRingCat.of R)) : + markoffEquivSemiringMarkoffSurface S + (BGS.Markoff.map (CommSemiRingCat.ofHom f) x) = + SemiringMarkoffSurface.map f (markoffEquivSemiringMarkoffSurface R x) := by + apply Subtype.ext + ext <;> rfl + +@[simp] +theorem markoffFunctor_obj (R : CommSemiRingCat.{u}) : + markoffFunctor.obj R = SemiringMarkoffSurface R := + rfl + +@[simp] +theorem markoffFunctor_map {R S : CommSemiRingCat.{u}} (f : R ⟶ S) + (x : SemiringMarkoffSurface R) : + markoffFunctor.map f x = SemiringMarkoffSurface.map f.hom x := + rfl + +/-- The origin as a Markoff solution over a commutative semiring. -/ +def semiringSurfaceOrigin (R : Type u) [CommSemiring R] : SemiringMarkoffSurface R := + ⟨origin, by simp [IsSemiringMarkoff, origin]⟩ + +/-- The distinguished positive Markoff solution `(1, 1, 1)`. -/ +def semiringSurfaceRoot (R : Type u) [CommSemiring R] : SemiringMarkoffSurface R := + ⟨⟨1, 1, 1⟩, by norm_num [IsSemiringMarkoff]⟩ + +@[simp] +theorem SemiringMarkoffSurface.map_origin + {R : Type u} {S : Type v} [CommSemiring R] [CommSemiring S] (f : R →+* S) : + SemiringMarkoffSurface.map f (semiringSurfaceOrigin R) = semiringSurfaceOrigin S := by + apply Subtype.ext + ext <;> simp [SemiringMarkoffSurface.map, semiringPointMap, semiringSurfaceOrigin, origin] + +@[simp] +theorem SemiringMarkoffSurface.map_root + {R : Type u} {S : Type v} [CommSemiring R] [CommSemiring S] (f : R →+* S) : + SemiringMarkoffSurface.map f (semiringSurfaceRoot R) = semiringSurfaceRoot S := by + apply Subtype.ext + ext <;> simp [SemiringMarkoffSurface.map, semiringPointMap, semiringSurfaceRoot] + +/-- Coordinatewise reduction of natural-number Markoff solutions modulo `p`. -/ +def markoffReduction (p : ℕ) : + SemiringMarkoffSurface ℕ → SemiringMarkoffSurface (ZMod p) := + SemiringMarkoffSurface.map (Nat.castRingHom (ZMod p)) + +/-- The public functor formulation of strong approximation agrees with the structured +reduction map used internally. -/ +theorem strongApproximationAt_iff_markoffReduction_surjective (p : ℕ) : + StrongApproximationAt p ↔ Function.Surjective (markoffReduction p) := by + constructor + · intro h y + obtain ⟨x, hx⟩ := h ((markoffEquivSemiringMarkoffSurface (ZMod p)).symm y) + refine ⟨markoffEquivSemiringMarkoffSurface ℕ x, ?_⟩ + simpa [markoffReduction] using + congrArg (markoffEquivSemiringMarkoffSurface (ZMod p)) hx + · intro h y + obtain ⟨x, hx⟩ := h (markoffEquivSemiringMarkoffSurface (ZMod p) y) + refine ⟨(markoffEquivSemiringMarkoffSurface ℕ).symm x, ?_⟩ + apply (markoffEquivSemiringMarkoffSurface (ZMod p)).injective + simpa [markoffReduction] using hx + +@[simp] +theorem markoffReduction_eq_markoffFunctor_map (p : ℕ) (x : SemiringMarkoffSurface ℕ) : + markoffReduction p x = + markoffFunctor.map (CommSemiRingCat.ofHom (Nat.castRingHom (ZMod p))) x := + rfl + +@[simp] +theorem markoffReduction_x1 (p : ℕ) (x : SemiringMarkoffSurface ℕ) : + (markoffReduction p x).1.x1 = (x.1.x1 : ZMod p) := + rfl + +@[simp] +theorem markoffReduction_x2 (p : ℕ) (x : SemiringMarkoffSurface ℕ) : + (markoffReduction p x).1.x2 = (x.1.x2 : ZMod p) := + rfl + +@[simp] +theorem markoffReduction_x3 (p : ℕ) (x : SemiringMarkoffSurface ℕ) : + (markoffReduction p x).1.x3 = (x.1.x3 : ZMod p) := + rfl + +@[simp] +theorem markoffReduction_origin (p : ℕ) : + markoffReduction p (semiringSurfaceOrigin ℕ) = semiringSurfaceOrigin (ZMod p) := + SemiringMarkoffSurface.map_origin _ + +@[simp] +theorem markoffReduction_root (p : ℕ) : + markoffReduction p (semiringSurfaceRoot ℕ) = semiringSurfaceRoot (ZMod p) := + SemiringMarkoffSurface.map_root _ + +/-- Over a commutative ring, the equation-based semiring surface agrees with the existing +zero-locus definition using `markoffPolynomial`. -/ +def semiringMarkoffSurfaceEquiv (R : Type u) [CommRing R] : + SemiringMarkoffSurface R ≃ MarkoffSurface R where + toFun x := + ⟨x.1, by + change x.1.x1 ^ 2 + x.1.x2 ^ 2 + x.1.x3 ^ 2 - + 3 * x.1.x1 * x.1.x2 * x.1.x3 = 0 + exact sub_eq_zero.mpr x.2⟩ + invFun x := + ⟨x.1, by + apply sub_eq_zero.mp + exact x.2⟩ + left_inv x := Subtype.ext rfl + right_inv x := Subtype.ext rfl + +@[simp] +theorem semiringMarkoffSurfaceEquiv_apply_coe + {R : Type u} [CommRing R] (x : SemiringMarkoffSurface R) : + ((semiringMarkoffSurfaceEquiv R x : MarkoffSurface R) : Point R) = x.1 := + rfl + +@[simp] +theorem semiringMarkoffSurfaceEquiv_symm_apply_coe + {R : Type u} [CommRing R] (x : MarkoffSurface R) : + ((semiringMarkoffSurfaceEquiv R).symm x : Point R) = x.1 := + rfl + +/-- The distinguished solution `(1, 1, 1)` on the existing ring-level Markoff surface. -/ +def surfaceRoot (R : Type u) [CommRing R] : MarkoffSurface R := + ⟨⟨1, 1, 1⟩, by norm_num [IsMarkoff, markoffPolynomial]⟩ + +@[simp] +theorem surfaceRoot_coe (R : Type u) [CommRing R] : + ((surfaceRoot R : MarkoffSurface R) : Point R) = ⟨1, 1, 1⟩ := + rfl + +@[simp] +theorem semiringMarkoffSurfaceEquiv_origin (R : Type u) [CommRing R] : + semiringMarkoffSurfaceEquiv R (semiringSurfaceOrigin R) = surfaceOrigin R := by + apply Subtype.ext + rfl + +@[simp] +theorem semiringMarkoffSurfaceEquiv_root (R : Type u) [CommRing R] : + semiringMarkoffSurfaceEquiv R (semiringSurfaceRoot R) = surfaceRoot R := by + apply Subtype.ext + rfl + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Core/Statements.lean b/LeanPool/MarkoffModP/BGS/Markoff/Core/Statements.lean new file mode 100644 index 0000000000..a66627f4a5 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Core/Statements.lean @@ -0,0 +1,91 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Core.SemiringFunctor + +/-! +# Formal statements of the main results + +This file fixes the logical meaning of the two main theorems before their proofs are attempted. +In particular, the threshold in the giant-orbit assertion may depend on `epsilon`, while the +constant in the lower bound for every orbit is absolute. +-/ + +@[expose] public section + +namespace BGS.Markoff + +/-- Punctured Markoff transitivity at a prime `p`: the Markoff group has one orbit on the +nonzero solutions modulo `p`. -/ +def PuncturedMarkoffTransitiveAt (p : ℕ) (hp : p.Prime) : Prop := + letI : Fact p.Prime := ⟨hp⟩ + ∀ x y : PuncturedMarkoffSurface (ZMod p), ∃ g : Gamma (ZMod p), g • x = y + +/-- The complement size of the orbit of `x` inside the punctured surface over `ZMod p`. -/ +noncomputable def orbitComplementCard {p : ℕ} [Fact p.Prime] + (x : PuncturedMarkoffSurface (ZMod p)) : ℕ := + (Set.univ \ puncturedGammaOrbit x).ncard + +/-- At `p`, there is an orbit whose complement has at most `p ^ epsilon` points. -/ +def HasGiantOrbitAt (p : ℕ) (hp : p.Prime) (epsilon : ℝ) : Prop := + letI : Fact p.Prime := ⟨hp⟩ + ∃ x : PuncturedMarkoffSurface (ZMod p), + (orbitComplementCard x : ℝ) ≤ Real.rpow p epsilon + +/-- A finite set containing an orbit complement bounds that complement's cardinality. -/ +theorem orbitComplementCard_le_finset_of_subset + {p : ℕ} [Fact p.Prime] (x : PuncturedMarkoffSurface (ZMod p)) + (bad : Finset (PuncturedMarkoffSurface (ZMod p))) + (hbad : Set.univ \ puncturedGammaOrbit x ⊆ (bad : Set _)) : + orbitComplementCard x ≤ bad.card := by + rw [orbitComplementCard, ← Set.ncard_coe_finset bad] + exact Set.ncard_le_ncard hbad + +/-- The final giant-orbit conclusion once the complement has been put inside a counted set. -/ +theorem hasGiantOrbitAt_of_complement_subset_finset + (p : ℕ) (hp : p.Prime) (epsilon : ℝ) + (x : PuncturedMarkoffSurface (ZMod p)) + (bad : Finset (PuncturedMarkoffSurface (ZMod p))) + (hbad : Set.univ \ puncturedGammaOrbit x ⊆ (bad : Set _)) + (hcard : (bad.card : ℝ) ≤ Real.rpow p epsilon) : + HasGiantOrbitAt p hp epsilon := by + let : Fact p.Prime := ⟨hp⟩ + refine ⟨x, ?_⟩ + have hnat := orbitComplementCard_le_finset_of_subset x bad hbad + have hreal : (orbitComplementCard x : ℝ) ≤ bad.card := by + exact_mod_cast hnat + exact hreal.trans hcard + +/-- At `p`, every punctured Markoff orbit has the asserted logarithmic lower bound. -/ +def EveryOrbitLargeAt (p : ℕ) (hp : p.Prime) (c : ℝ) : Prop := + letI : Fact p.Prime := ⟨hp⟩ + ∀ x : PuncturedMarkoffSurface (ZMod p), + c * Real.rpow (Real.log p) (1 / ((3 : ℕ) : ℝ)) ≤ (puncturedGammaOrbit x).ncard + +/-- The exact quantifier structure of Theorem 1 in arXiv:1607.01530v1. -/ +def TheoremOneStatement : Prop := + (∀ epsilon : ℝ, 0 < epsilon → + ∃ p0 : ℕ, ∀ (p : ℕ) (hp : p.Prime), p0 ≤ p → HasGiantOrbitAt p hp epsilon) ∧ + ∃ c : ℝ, 0 < c ∧ + ∃ p0 : ℕ, ∀ (p : ℕ) (hp : p.Prime), p0 ≤ p → EveryOrbitLargeAt p hp c + +/-- A prime is exceptional when strong approximation fails at that prime. -/ +def IsExceptionalPrime (p : ℕ) : Prop := + p.Prime ∧ ¬ StrongApproximationAt p + +/-- The number of exceptional primes at most `T`. -/ +noncomputable def exceptionalPrimeCount (T : ℕ) : ℕ := + {p : ℕ | p ≤ T ∧ IsExceptionalPrime p}.ncard + +/-- The exact quantifier structure of Theorem 2 in arXiv:1607.01530v1. -/ +def TheoremTwoStatement : Prop := + ∀ epsilon : ℝ, 0 < epsilon → + ∃ T0 : ℕ, ∀ T : ℕ, T0 ≤ T → + (exceptionalPrimeCount T : ℝ) ≤ Real.rpow T epsilon + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Core/TraceClassification.lean b/LeanPool/MarkoffModP/BGS/Markoff/Core/TraceClassification.lean new file mode 100644 index 0000000000..094b677925 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Core/TraceClassification.lean @@ -0,0 +1,306 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Core.RotationTorus +public import Mathlib.FieldTheory.PrimeField + +/-! +# Split and nonsplit trace classification + +This module proves the elementary representation of every normalized trace over an odd +prime field by either the split torus or the concrete norm-one torus in the canonical quadratic +extension. +-/ + +@[expose] public section + +namespace BGS.Markoff + +open scoped Polynomial + +section QuadraticExtensionSquares + +variable (p : ℕ) [Fact p.Prime] + +private theorem quadraticFiniteField_natCard : + Nat.card (quadraticFiniteField p) = p ^ 2 := + GaloisField.card p (n := 2) (by norm_num) + +/-- Every base-field scalar becomes a square in the canonical quadratic extension. -/ +theorem isSquare_algebraMap_quadraticFiniteField (hpTwo : p ≠ 2) (a : ZMod p) : + IsSquare (algebraMap (ZMod p) (quadraticFiniteField p) a) := by + let E := quadraticFiniteField p + let : Fintype E := Fintype.ofFinite _ + change IsSquare (algebraMap (ZMod p) E a) + by_cases ha : a = 0 + · subst a + exact ⟨0, by simp⟩ + have hpOddCard : Odd p := (Fact.out : p.Prime).odd_of_ne_two hpTwo + have hcharE : ringChar E ≠ 2 := by + rw [show ringChar E = p from ringChar.eq (R := E) p] + exact hpTwo + have hmap_ne : algebraMap (ZMod p) E a ≠ 0 := + (map_ne_zero (algebraMap (ZMod p) E)).2 ha + rw [FiniteField.isSquare_iff hcharE hmap_ne] + rw [show Fintype.card E = p ^ 2 by + rw [Fintype.card_eq_nat_card] + exact quadraticFiniteField_natCard p] + have hbasePow : a ^ (p - 1) = 1 := ZMod.pow_card_sub_one_eq_one ha + have hexponent : p ^ 2 / 2 = (p - 1) * ((p + 1) / 2) := by + apply Nat.eq_of_mul_eq_mul_left (by norm_num : 0 < 2) + calc + 2 * (p ^ 2 / 2) = p ^ 2 - 1 := + Nat.two_mul_odd_div_two (Nat.odd_iff.mp (Odd.pow hpOddCard)) + _ = (p - 1) * (p + 1) := by + rw [show p ^ 2 - 1 = (p + 1) * (p - 1) by + simpa using (sq_tsub_sq p 1)] + exact mul_comm _ _ + _ = (p - 1) * (2 * ((p + 1) / 2)) := by + rw [Nat.two_mul_div_two_of_even (Odd.add_one hpOddCard)] + _ = 2 * ((p - 1) * ((p + 1) / 2)) := by ring + rw [hexponent, pow_mul, ← map_pow, hbasePow, map_one, one_pow] + +end QuadraticExtensionSquares + +section TraceClassification + +variable (p : ℕ) [Fact p.Prime] + +private theorem two_ne_zero_zmod (hpTwo : p ≠ 2) : (2 : ZMod p) ≠ 0 := by + intro hzero + have hdiv : p ∣ 2 := (ZMod.natCast_eq_zero_iff 2 p).1 hzero + have hpLe : p ≤ 2 := Nat.le_of_dvd (by norm_num) hdiv + exact hpTwo (Nat.le_antisymm hpLe (Fact.out : p.Prime).two_le) + +private theorem nonparabolic_split_eigenvalue + (t : ZMod p) (ht : t ^ 2 ≠ 4) (w : (ZMod p)ˣ) + (htrace : splitTorusTrace w = t) : (w : ZMod p) ^ 2 ≠ 1 := by + intro hw + apply ht + rw [← htrace] + have hinv : ((w⁻¹ : (ZMod p)ˣ) : ZMod p) = (w : ZMod p) := by + exact Units.inv_eq_of_mul_eq_one_right (by simpa [pow_two] using hw) + change ((w : ZMod p) + ((w⁻¹ : (ZMod p)ˣ) : ZMod p)) ^ 2 = 4 + rw [hinv] + calc + ((w : ZMod p) + (w : ZMod p)) ^ 2 = 4 * (w : ZMod p) ^ 2 := by ring + _ = 4 := by rw [hw, mul_one] + +private theorem nonparabolic_extension_eigenvalue + (t : ZMod p) (ht : t ^ 2 ≠ 4) (w : (quadraticFiniteField p)ˣ) + (htrace : algebraMap (ZMod p) (quadraticFiniteField p) t = splitTorusTrace w) : + (w : quadraticFiniteField p) ^ 2 ≠ 1 := by + intro hw + apply ht + apply (algebraMap (ZMod p) (quadraticFiniteField p)).injective + rw [map_pow, map_ofNat, htrace] + have hinv : ((w⁻¹ : (quadraticFiniteField p)ˣ) : quadraticFiniteField p) = + (w : quadraticFiniteField p) := by + exact Units.inv_eq_of_mul_eq_one_right (by simpa [pow_two] using hw) + change ((w : quadraticFiniteField p) + + ((w⁻¹ : (quadraticFiniteField p)ˣ) : quadraticFiniteField p)) ^ 2 = 4 + rw [hinv] + calc + ((w : quadraticFiniteField p) + (w : quadraticFiniteField p)) ^ 2 = + 4 * (w : quadraticFiniteField p) ^ 2 := by ring + _ = 4 := by rw [hw, mul_one] + +/-- Every nonparabolic normalized trace over an odd prime field is represented by either the +split torus or the concrete norm-one torus in the canonical quadratic extension. -/ +theorem exists_split_or_quadraticNormOneTrace + (hpTwo : p ≠ 2) (t : ZMod p) (ht : t ^ 2 ≠ 4) : + (∃ w : (ZMod p)ˣ, + splitTorusTrace w = t ∧ (w : ZMod p) ^ 2 ≠ 1) ∨ + (∃ w : quadraticNormOneTorus p, + quadraticNormOneTrace p w = t ∧ + (((w : (quadraticFiniteField p)ˣ) : quadraticFiniteField p) ^ 2 ≠ 1)) := by + let d : ZMod p := t ^ 2 - 4 + have hd : d ≠ 0 := sub_ne_zero.mpr ht + have htwoF : (2 : ZMod p) ≠ 0 := two_ne_zero_zmod p hpTwo + by_cases hdsquare : IsSquare d + · obtain ⟨s, hs⟩ := hdsquare + have hsDisc : s ^ 2 = t ^ 2 - 4 := by + simpa [d, pow_two] using hs.symm + let w0 : ZMod p := (t + s) / 2 + let v0 : ZMod p := (t - s) / 2 + have hwv : w0 * v0 = 1 := by + dsimp [w0, v0] + field_simp [htwoF] + linear_combination -hsDisc + have hw0 : w0 ≠ 0 := by + intro hw + rw [hw, zero_mul] at hwv + exact zero_ne_one hwv + let w : (ZMod p)ˣ := Units.mk0 w0 hw0 + have hinv : ((w⁻¹ : (ZMod p)ˣ) : ZMod p) = v0 := + Units.inv_eq_of_mul_eq_one_right hwv + have htrace : splitTorusTrace w = t := by + change w0 + ((w⁻¹ : (ZMod p)ˣ) : ZMod p) = t + rw [hinv] + dsimp [w0, v0] + field_simp [htwoF] + ring + exact Or.inl ⟨w, htrace, nonparabolic_split_eigenvalue p t ht w htrace⟩ + · let E := quadraticFiniteField p + let : Fintype E := Fintype.ofFinite _ + obtain ⟨s, hs⟩ := isSquare_algebraMap_quadraticFiniteField p hpTwo d + have hsDiscBase : s ^ 2 = algebraMap (ZMod p) E d := by + simpa [pow_two] using hs.symm + have hsFrobeniusSquare : (s ^ p) ^ 2 = s ^ 2 := by + calc + (s ^ p) ^ 2 = s ^ (p * 2) := (pow_mul s p 2).symm + _ = s ^ (2 * p) := by rw [mul_comm] + _ = (s ^ 2) ^ p := pow_mul s 2 p + _ = (algebraMap (ZMod p) E d) ^ p := by rw [hsDiscBase] + _ = algebraMap (ZMod p) E (d ^ p) := by rw [map_pow] + _ = algebraMap (ZMod p) E d := by rw [ZMod.pow_card] + _ = s ^ 2 := hsDiscBase.symm + have hsFrobeniusCases : s ^ p = s ∨ s ^ p = -s := by + have hfactor : (s ^ p - s) * (s ^ p + s) = 0 := by + calc + (s ^ p - s) * (s ^ p + s) = (s ^ p) ^ 2 - s ^ 2 := by ring + _ = 0 := sub_eq_zero.mpr hsFrobeniusSquare + rcases mul_eq_zero.mp hfactor with h | h + · exact Or.inl (sub_eq_zero.mp h) + · exact Or.inr (eq_neg_of_add_eq_zero_left h) + have hsFrobenius : s ^ p = -s := by + rcases hsFrobeniusCases with hfixed | hneg + · exfalso + apply hdsquare + have hmem : s ∈ (⊥ : Subfield E) := + (Subfield.mem_bot_iff_pow_eq_self E p).2 hfixed + obtain ⟨n, hn⟩ := (mem_bot_iff_intCast p E).1 hmem + have hbaseSquare : d = (n : ZMod p) ^ 2 := by + apply (algebraMap (ZMod p) E).injective + calc + algebraMap (ZMod p) E d = s ^ 2 := hsDiscBase.symm + _ = (n : E) ^ 2 := by rw [hn] + _ = algebraMap (ZMod p) E ((n : ZMod p) ^ 2) := by norm_cast + exact ⟨(n : ZMod p), by simpa [pow_two] using hbaseSquare⟩ + · exact hneg + let T : E := algebraMap (ZMod p) E t + have hsDisc : s ^ 2 = T ^ 2 - 4 := by + simpa only [d, T, map_sub, map_pow, map_ofNat] using hsDiscBase + have htwoE : (2 : E) ≠ 0 := by + exact (map_ne_zero (algebraMap (ZMod p) E)).2 htwoF + let w0 : E := (T + s) / 2 + let v0 : E := (T - s) / 2 + have hwv : w0 * v0 = 1 := by + dsimp [w0, v0] + rw [div_mul_div_comm] + apply (div_eq_iff (mul_ne_zero htwoE htwoE)).2 + linear_combination -hsDisc + have hw0 : w0 ≠ 0 := by + intro hw + rw [hw, zero_mul] at hwv + exact zero_ne_one hwv + let w : Eˣ := Units.mk0 w0 hw0 + have hinv : ((w⁻¹ : Eˣ) : E) = v0 := + Units.inv_eq_of_mul_eq_one_right hwv + have htrace : splitTorusTrace w = T := by + change w0 + ((w⁻¹ : Eˣ) : E) = T + rw [hinv] + dsimp [w0, v0] + rw [← add_div] + apply (div_eq_iff htwoE).2 + ring + have hTpow : T ^ p = T := by + dsimp [T] + rw [← map_pow, ZMod.pow_card] + have htwoPow : (2 : E) ^ p = 2 := by + change (algebraMap (ZMod p) E (2 : ZMod p)) ^ p = + algebraMap (ZMod p) E (2 : ZMod p) + rw [← map_pow, ZMod.pow_card] + have hwpow : w0 ^ p = v0 := by + dsimp [w0, v0] + rw [div_pow, add_pow_char, hTpow, hsFrobenius, htwoPow] + simp [sub_eq_add_neg] + have hfinrank : Module.finrank (ZMod p) E = 2 := + GaloisField.finrank p (n := 2) (by norm_num) + have hnormFormula := FiniteField.algebraMap_norm_eq_prod_pow + (ZMod p) E w0 + rw [hfinrank, Nat.card_zmod] at hnormFormula + simp only [Finset.prod_range_succ, Finset.prod_range_zero, pow_zero, pow_one, + one_mul] at hnormFormula + have hnorm : Algebra.norm (ZMod p) w0 = 1 := by + apply (algebraMap (ZMod p) E).injective + rw [hnormFormula, hwpow, hwv, map_one] + have hwMem : w ∈ quadraticNormOneTorus p := by + rw [quadraticNormOneTorus, MonoidHom.mem_ker] + apply Units.ext + simpa [w] using hnorm + let normOneW : quadraticNormOneTorus p := ⟨w, hwMem⟩ + have hnormOneTrace : quadraticNormOneTrace p normOneW = t := by + apply (algebraMap (ZMod p) E).injective + rw [algebraMap_quadraticNormOneTrace] + exact htrace + refine Or.inr ⟨normOneW, hnormOneTrace, ?_⟩ + exact nonparabolic_extension_eigenvalue p t ht w (hnormOneTrace ▸ + algebraMap_quadraticNormOneTrace p normOneW) + +/-- The two normalized parabolic trace parameters. -/ +def normalizedParabolicTraceSet : Finset (ZMod p) := + {2, -2} + +/-- The concrete low-order trace set used for normalized Markoff rotations over `ZMod p`. -/ +noncomputable def concreteLowOrderTraceSet (bound : ℕ) : Finset (ZMod p) := + lowOrderTraceSet (normalizedParabolicTraceSet p) + (splitTorusTrace : (ZMod p)ˣ → ZMod p) (quadraticNormOneTrace p) bound + +/-- The concrete trace set has the quadratic cardinality bound needed in the giant-orbit count. -/ +theorem concreteLowOrderTraceSet_card_le (bound : ℕ) : + (concreteLowOrderTraceSet p bound).card ≤ 2 + 2 * bound ^ 2 := by + calc + (concreteLowOrderTraceSet p bound).card ≤ + (normalizedParabolicTraceSet p).card + 2 * bound ^ 2 := by + exact lowOrderTraceSet_card_le_parabolic_add_two_mul_bound_sq + (normalizedParabolicTraceSet p) (splitTorusTrace : (ZMod p)ˣ → ZMod p) + (quadraticNormOneTrace p) bound + _ ≤ 2 + 2 * bound ^ 2 := by + gcongr + exact Finset.card_le_two + +/-- A normalized trace of small rotation order lies in the concrete union of the parabolic, +split-torus, and quadratic norm-one bounded-order trace sets. -/ +theorem mem_concreteLowOrderTraceSet_of_rotationOrder_lt + (hpTwo : p ≠ 2) (t : ZMod p) (bound : ℕ) + (hsmall : rotationOrder t < bound) : + t ∈ concreteLowOrderTraceSet p bound := by + by_cases ht : t ^ 2 = 4 + · have hfactor : (t - 2) * (t + 2) = 0 := by + calc + (t - 2) * (t + 2) = t ^ 2 - 4 := by ring + _ = 0 := sub_eq_zero.mpr ht + have htCases : t = 2 ∨ t = -2 := by + rcases mul_eq_zero.mp hfactor with h | h + · exact Or.inl (sub_eq_zero.mp h) + · exact Or.inr (eq_neg_of_add_eq_zero_left h) + have hparabolic : t ∈ normalizedParabolicTraceSet p := by + rcases htCases with rfl | rfl <;> simp [normalizedParabolicTraceSet] + rw [concreteLowOrderTraceSet, lowOrderTraceSet] + exact Finset.mem_union_left _ (Finset.mem_union_left _ hparabolic) + · rcases exists_split_or_quadraticNormOneTrace p hpTwo t ht with + ⟨w, htrace, hw⟩ | ⟨w, htrace, hw⟩ + · have hsplit : splitTorusTrace w ∈ + boundedOrderTraceSet (splitTorusTrace : (ZMod p)ˣ → ZMod p) bound := + splitTorusTrace_mem_boundedOrderTraceSet_of_rotationOrder_lt w hw bound (by + simpa [htrace] using hsmall) + rw [concreteLowOrderTraceSet, lowOrderTraceSet] + rw [← htrace] + exact Finset.mem_union_left _ (Finset.mem_union_right _ hsplit) + · have hnonsplit : quadraticNormOneTrace p w ∈ + boundedOrderTraceSet (quadraticNormOneTrace p) bound := + quadraticNormOneTrace_mem_boundedOrderTraceSet_of_rotationOrder_lt p w hw bound (by + simpa [htrace] using hsmall) + rw [concreteLowOrderTraceSet, lowOrderTraceSet] + rw [← htrace] + exact Finset.mem_union_right _ hnonsplit + +end TraceClassification + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Diophantine.lean b/LeanPool/MarkoffModP/BGS/Markoff/Diophantine.lean new file mode 100644 index 0000000000..baf9c44a0d --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Diophantine.lean @@ -0,0 +1,12 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Diophantine.CoordinateCoprimeProduct +public import LeanPool.MarkoffModP.BGS.Markoff.Diophantine.CoordinateZeroPatternCounts +public import LeanPool.MarkoffModP.BGS.Markoff.Diophantine.LocalCounts +public import LeanPool.MarkoffModP.BGS.Markoff.Diophantine.PrimewiseCRT diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Diophantine/CoordinateCoprimeProduct.lean b/LeanPool/MarkoffModP/BGS/Markoff/Diophantine/CoordinateCoprimeProduct.lean new file mode 100644 index 0000000000..bf7ac736e9 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Diophantine/CoordinateCoprimeProduct.lean @@ -0,0 +1,150 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Diophantine.LocalCounts + +/-! +# Exact first-coordinate product formula + +This file formalizes the exact finite-product identity preceding the asymptotic estimate in +published Section 7. A first coordinate is coprime to the squarefree product modulus exactly +when it is nonzero in every prime factor. The carrier below records that local condition +directly; no real-valued comparison with `exp (-2 * L)` is asserted here. +-/ + +@[expose] public section + +namespace BGS.Markoff + +open Finset + +/-- Punctured Markoff points whose first coordinate is nonzero. This is definitionally the +complement of the zero-coordinate locus counted in `LocalCounts`. -/ +def puncturedMarkoffFirstCoordinateNonzero (R : Type*) [CommRing R] : + Set (PuncturedMarkoffSurface R) := + (puncturedMarkoffFirstCoordinateZero R)ᶜ + +@[simp] theorem mem_puncturedMarkoffFirstCoordinateNonzero_iff + {R : Type*} [CommRing R] (x : PuncturedMarkoffSurface R) : + x ∈ puncturedMarkoffFirstCoordinateNonzero R ↔ x.1.1.x1 ≠ 0 := by + simp [puncturedMarkoffFirstCoordinateNonzero, puncturedMarkoffFirstCoordinateZero] + +/-- Exact local numerator in published equation (97). -/ +theorem puncturedMarkoffFirstCoordinateNonzero_zmod_card_eq_of_mod_four_eq_one + (p : ℕ) [Fact p.Prime] (hpModFour : p % 4 = 1) : + Nat.card ↑(puncturedMarkoffFirstCoordinateNonzero (ZMod p)) = p ^ 2 + p + 2 := by + change (puncturedMarkoffFirstCoordinateZero (ZMod p))ᶜ.ncard = p ^ 2 + p + 2 + rw [Set.ncard_compl, ← Nat.card_coe_set_eq, + puncturedMarkoffFirstCoordinateZero_zmod_card_eq_of_mod_four_eq_one p hpModFour, + puncturedMarkoffSurface_zmod_card_eq_of_mod_four_eq_one p hpModFour] + have hpTwo : 2 ≤ p := (Fact.out : p.Prime).two_le + omega + +/-- Primewise-punctured points whose first coordinate is nonzero at every factor. -/ +def primewisePuncturedFirstCoordinateNonzero {ι : Type*} (a : ι → ℕ) : + Set (PrimewisePuncturedMarkoffSurface a) := + {x | ∀ i, x i ∈ puncturedMarkoffFirstCoordinateNonzero (ZMod (a i))} + +/-- The primewise nonzero-coordinate carrier is the product of its local subtypes. -/ +def primewisePuncturedFirstCoordinateNonzeroEquivPi {ι : Type*} (a : ι → ℕ) : + ↑(primewisePuncturedFirstCoordinateNonzero a) ≃ + ∀ i, ↑(puncturedMarkoffFirstCoordinateNonzero (ZMod (a i))) where + toFun x i := ⟨x.1 i, x.2 i⟩ + invFun x := ⟨fun i => (x i).1, fun i => (x i).2⟩ + left_inv x := by apply Subtype.ext; funext i; rfl + right_inv x := by funext i; apply Subtype.ext; rfl + +/-- Exact product numerator for points whose first coordinate is nonzero at every prime. -/ +theorem primewisePuncturedFirstCoordinateNonzero_card_eq_of_mod_four_eq_one + {ι : Type*} [Fintype ι] (a : ι → ℕ) [∀ i, Fact (a i).Prime] + (hmod : ∀ i, a i % 4 = 1) : + Nat.card ↑(primewisePuncturedFirstCoordinateNonzero a) = + ∏ i, (a i ^ 2 + a i + 2) := by + rw [Nat.card_congr (primewisePuncturedFirstCoordinateNonzeroEquivPi a), Nat.card_pi] + apply Finset.prod_congr rfl + intro i _ + exact puncturedMarkoffFirstCoordinateNonzero_zmod_card_eq_of_mod_four_eq_one + (a i) (hmod i) + +/-- First-coordinate nonvanishing pulled back to the single-residue-ring CRT presentation. -/ +def crtPrimewisePuncturedFirstCoordinateNonzero {ι : Type*} [Fintype ι] + (a : ι → ℕ) (coprime : Pairwise (Function.onFun Nat.Coprime a)) : + Set (CRTPrimewisePuncturedMarkoffSurface a coprime) := + {x | ∀ i, primewisePuncturedCRTEquiv a coprime x i ∈ + puncturedMarkoffFirstCoordinateNonzero (ZMod (a i))} + +/-- CRT restricts to the first-coordinate-nonzero carriers. -/ +noncomputable def crtPrimewisePuncturedFirstCoordinateNonzeroEquiv + {ι : Type*} [Fintype ι] (a : ι → ℕ) + (coprime : Pairwise (Function.onFun Nat.Coprime a)) : + ↑(crtPrimewisePuncturedFirstCoordinateNonzero a coprime) ≃ + ↑(primewisePuncturedFirstCoordinateNonzero a) := + (primewisePuncturedCRTEquiv a coprime).subtypeEquiv fun _ => Iff.rfl + +/-- The CRT presentation has the same exact product numerator. -/ +theorem crtPrimewisePuncturedFirstCoordinateNonzero_card_eq_of_mod_four_eq_one + {ι : Type*} [Fintype ι] (a : ι → ℕ) [∀ i, Fact (a i).Prime] + (coprime : Pairwise (Function.onFun Nat.Coprime a)) (hmod : ∀ i, a i % 4 = 1) : + Nat.card ↑(crtPrimewisePuncturedFirstCoordinateNonzero a coprime) = + ∏ i, (a i ^ 2 + a i + 2) := by + rw [Nat.card_congr (crtPrimewisePuncturedFirstCoordinateNonzeroEquiv a coprime)] + exact primewisePuncturedFirstCoordinateNonzero_card_eq_of_mod_four_eq_one a hmod + +/-- Exact rational proportion in product-numerator form. This deliberately stops before the +paper's real-valued asymptotic comparison. -/ +theorem primewisePuncturedFirstCoordinateNonzero_proportion_eq_product + {ι : Type*} [Fintype ι] (a : ι → ℕ) [∀ i, Fact (a i).Prime] + (hmod : ∀ i, a i % 4 = 1) : + (Nat.card ↑(primewisePuncturedFirstCoordinateNonzero a) : ℚ) / + Nat.card (PrimewisePuncturedMarkoffSurface a) = + ∏ i, ((a i ^ 2 + a i + 2 : ℕ) : ℚ) / (a i ^ 2 + 3 * a i : ℕ) := by + rw [primewisePuncturedFirstCoordinateNonzero_card_eq_of_mod_four_eq_one a hmod, + primewisePuncturedMarkoffSurface_card_eq_of_mod_four_eq_one a hmod] + push_cast + exact (Finset.prod_div_distrib _ _).symm + +/-- A local numerator factor is exactly one minus the zero-coordinate proportion. -/ +theorem firstCoordinateNonzero_proportion_factor_eq_one_sub + (p : ℕ) [Fact p.Prime] (hpModFour : p % 4 = 1) : + ((p ^ 2 + p + 2 : ℕ) : ℚ) / (p ^ 2 + 3 * p : ℕ) = + 1 - ((2 * p - 2 : ℕ) : ℚ) / (p ^ 2 + 3 * p : ℕ) := by + have hpTwo : 2 ≤ p := (Fact.out : p.Prime).two_le + have hsub : 2 ≤ 2 * p := by omega + have hdenNat : 0 < p ^ 2 + 3 * p := by omega + have hden : ((p ^ 2 + 3 * p : ℕ) : ℚ) ≠ 0 := by exact_mod_cast hdenNat.ne' + push_cast [Nat.cast_sub hsub] + field_simp [hden] + ring + +/-- Exact rational form of published equation (97), with one local zero-coordinate factor +removed at each prime. -/ +theorem primewisePuncturedFirstCoordinateNonzero_proportion_eq_product_one_sub + {ι : Type*} [Fintype ι] (a : ι → ℕ) [∀ i, Fact (a i).Prime] + (hmod : ∀ i, a i % 4 = 1) : + (Nat.card ↑(primewisePuncturedFirstCoordinateNonzero a) : ℚ) / + Nat.card (PrimewisePuncturedMarkoffSurface a) = + ∏ i, (1 - ((2 * a i - 2 : ℕ) : ℚ) / (a i ^ 2 + 3 * a i : ℕ)) := by + rw [primewisePuncturedFirstCoordinateNonzero_proportion_eq_product a hmod] + apply Finset.prod_congr rfl + intro i _ + exact firstCoordinateNonzero_proportion_factor_eq_one_sub (a i) (hmod i) + +/-- The same exact rational proportion on the single-residue-ring CRT carrier. -/ +theorem crtPrimewisePuncturedFirstCoordinateNonzero_proportion_eq_product_one_sub + {ι : Type*} [Fintype ι] (a : ι → ℕ) [∀ i, Fact (a i).Prime] + (coprime : Pairwise (Function.onFun Nat.Coprime a)) (hmod : ∀ i, a i % 4 = 1) : + (Nat.card ↑(crtPrimewisePuncturedFirstCoordinateNonzero a coprime) : ℚ) / + Nat.card (CRTPrimewisePuncturedMarkoffSurface a coprime) = + ∏ i, (1 - ((2 * a i - 2 : ℕ) : ℚ) / (a i ^ 2 + 3 * a i : ℕ)) := by + rw [crtPrimewisePuncturedFirstCoordinateNonzero_card_eq_of_mod_four_eq_one a coprime hmod, + crtPrimewisePuncturedMarkoffSurface_card_eq_of_mod_four_eq_one a coprime hmod] + rw [← primewisePuncturedFirstCoordinateNonzero_card_eq_of_mod_four_eq_one a hmod, + ← primewisePuncturedMarkoffSurface_card_eq_of_mod_four_eq_one a hmod] + exact primewisePuncturedFirstCoordinateNonzero_proportion_eq_product_one_sub a hmod + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Diophantine/CoordinateZeroPatternCounts.lean b/LeanPool/MarkoffModP/BGS/Markoff/Diophantine/CoordinateZeroPatternCounts.lean new file mode 100644 index 0000000000..671d85a95d --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Diophantine/CoordinateZeroPatternCounts.lean @@ -0,0 +1,114 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Diophantine.CoordinateCoprimeProduct + +/-! +# Exact coordinate-zero patterns over a squarefree modulus + +This file continues the elementary finite counting in published Section 7. It counts points +whose first coordinate vanishes at exactly a prescribed collection of prime factors. The result +is an exact finite product; no real asymptotic estimate is used. +-/ + +@[expose] public section + +namespace BGS.Markoff + +open Finset + +/-- Primewise-punctured points whose first coordinate vanishes exactly at the indices in `R`. -/ +def primewisePuncturedFirstCoordinateZeroExactlyOn + {ι : Type*} [DecidableEq ι] (a : ι → ℕ) (R : Finset ι) : + Set (PrimewisePuncturedMarkoffSurface a) := + {x | ∀ i, + x i ∈ if i ∈ R then puncturedMarkoffFirstCoordinateZero (ZMod (a i)) + else puncturedMarkoffFirstCoordinateNonzero (ZMod (a i))} + +@[simp] theorem mem_primewisePuncturedFirstCoordinateZeroExactlyOn_iff + {ι : Type*} [DecidableEq ι] {a : ι → ℕ} {R : Finset ι} + (x : PrimewisePuncturedMarkoffSurface a) : + x ∈ primewisePuncturedFirstCoordinateZeroExactlyOn a R ↔ + ∀ i, x i ∈ puncturedMarkoffFirstCoordinateZero (ZMod (a i)) ↔ i ∈ R := by + constructor + · intro hx i + specialize hx i + by_cases hi : i ∈ R + · simpa [primewisePuncturedFirstCoordinateZeroExactlyOn, hi] using hx + · have hxNonzero : + x i ∈ puncturedMarkoffFirstCoordinateNonzero (ZMod (a i)) := by + simpa [primewisePuncturedFirstCoordinateZeroExactlyOn, hi] using hx + simp only [puncturedMarkoffFirstCoordinateNonzero, Set.mem_compl_iff] at hxNonzero + exact iff_of_false hxNonzero hi + · intro hx i + by_cases hi : i ∈ R + · simpa [primewisePuncturedFirstCoordinateZeroExactlyOn, hi] using (hx i).mpr hi + · have hzero : x i ∉ puncturedMarkoffFirstCoordinateZero (ZMod (a i)) := by + intro h + exact hi ((hx i).mp h) + simpa [primewisePuncturedFirstCoordinateZeroExactlyOn, hi, + puncturedMarkoffFirstCoordinateNonzero] using hzero + +/-- An exact zero pattern is the product of the corresponding local zero and nonzero loci. -/ +def primewisePuncturedFirstCoordinateZeroExactlyOnEquivPi + {ι : Type*} [DecidableEq ι] (a : ι → ℕ) (R : Finset ι) : + ↑(primewisePuncturedFirstCoordinateZeroExactlyOn a R) ≃ + ∀ i, ↑(if i ∈ R then puncturedMarkoffFirstCoordinateZero (ZMod (a i)) + else puncturedMarkoffFirstCoordinateNonzero (ZMod (a i))) where + toFun x i := ⟨x.1 i, x.2 i⟩ + invFun x := ⟨fun i => (x i).1, fun i => (x i).2⟩ + left_inv x := by apply Subtype.ext; funext i; rfl + right_inv x := by funext i; apply Subtype.ext; rfl + +/-- Exact product count for a prescribed set `R` of zero-coordinate prime factors. -/ +theorem primewisePuncturedFirstCoordinateZeroExactlyOn_card_eq_of_mod_four_eq_one + {ι : Type*} [Fintype ι] [DecidableEq ι] (a : ι → ℕ) + [∀ i, Fact (a i).Prime] (hmod : ∀ i, a i % 4 = 1) (R : Finset ι) : + Nat.card ↑(primewisePuncturedFirstCoordinateZeroExactlyOn a R) = + ∏ i, if i ∈ R then 2 * a i - 2 else a i ^ 2 + a i + 2 := by + rw [Nat.card_congr (primewisePuncturedFirstCoordinateZeroExactlyOnEquivPi a R), + Nat.card_pi] + apply Finset.prod_congr rfl + intro i _ + by_cases hi : i ∈ R + · simp only [hi, ite_true] + exact puncturedMarkoffFirstCoordinateZero_zmod_card_eq_of_mod_four_eq_one + (a i) (hmod i) + · simp only [hi, ite_false] + exact puncturedMarkoffFirstCoordinateNonzero_zmod_card_eq_of_mod_four_eq_one + (a i) (hmod i) + +/-- The same prescribed zero pattern on the single-residue-ring CRT carrier. -/ +def crtPrimewisePuncturedFirstCoordinateZeroExactlyOn + {ι : Type*} [Fintype ι] [DecidableEq ι] (a : ι → ℕ) + (coprime : Pairwise (Function.onFun Nat.Coprime a)) (R : Finset ι) : + Set (CRTPrimewisePuncturedMarkoffSurface a coprime) := + {x | primewisePuncturedCRTEquiv a coprime x ∈ + primewisePuncturedFirstCoordinateZeroExactlyOn a R} + +/-- CRT restricts to each prescribed zero-pattern carrier. -/ +noncomputable def crtPrimewisePuncturedFirstCoordinateZeroExactlyOnEquiv + {ι : Type*} [Fintype ι] [DecidableEq ι] (a : ι → ℕ) + (coprime : Pairwise (Function.onFun Nat.Coprime a)) (R : Finset ι) : + ↑(crtPrimewisePuncturedFirstCoordinateZeroExactlyOn a coprime R) ≃ + ↑(primewisePuncturedFirstCoordinateZeroExactlyOn a R) := + (primewisePuncturedCRTEquiv a coprime).subtypeEquiv fun _ => Iff.rfl + +/-- Exact prescribed-pattern count in the CRT presentation. -/ +theorem crtPrimewisePuncturedFirstCoordinateZeroExactlyOn_card_eq_of_mod_four_eq_one + {ι : Type*} [Fintype ι] [DecidableEq ι] (a : ι → ℕ) + [∀ i, Fact (a i).Prime] (coprime : Pairwise (Function.onFun Nat.Coprime a)) + (hmod : ∀ i, a i % 4 = 1) (R : Finset ι) : + Nat.card ↑(crtPrimewisePuncturedFirstCoordinateZeroExactlyOn a coprime R) = + ∏ i, if i ∈ R then 2 * a i - 2 else a i ^ 2 + a i + 2 := by + rw [Nat.card_congr + (crtPrimewisePuncturedFirstCoordinateZeroExactlyOnEquiv a coprime R)] + exact primewisePuncturedFirstCoordinateZeroExactlyOn_card_eq_of_mod_four_eq_one + a hmod R + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Diophantine/LocalCounts.lean b/LeanPool/MarkoffModP/BGS/Markoff/Diophantine/LocalCounts.lean new file mode 100644 index 0000000000..8eb0816771 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Diophantine/LocalCounts.lean @@ -0,0 +1,512 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.FiniteField.QuadraticCharacter +public import LeanPool.MarkoffModP.BGS.Markoff.Diophantine.PrimewiseCRT +public import LeanPool.MarkoffModP.BGS.Markoff.Core.PuncturedNormalization + +/-! +# Elementary local counts on the Markoff surface + +This file proves the two exact finite-field counts used in Section 7 of the published +Bourgain--Gamburd--Sarnak paper. The full surface count is reduced to an explicit quadratic- +character sum, including the exceptional fibers at normalized traces `0`, `2`, and `-2`. +Coordinatewise normalization then transports the results back to the original Markoff surface. +-/ + +@[expose] public section + +namespace BGS.Markoff + +open Finset +open BGS.FiniteField + +variable {F : Type*} [Field F] [Fintype F] [DecidableEq F] + +private lemma quadraticChar_neg_four_eq_one + (hF : ringChar F ≠ 2) (hneg : quadraticChar F (-1) = 1) : + quadraticChar F (-4) = 1 := by + have htwo : (2 : F) ≠ 0 := Ring.two_ne_zero hF + rw [show (-4 : F) = (-1) * 2 ^ 2 by norm_num, map_mul, + hneg, quadraticChar_sq_one' htwo, one_mul] + +private lemma sum_quadraticChar_neg_four_mul_sq + (hF : ringChar F ≠ 2) (hneg : quadraticChar F (-1) = 1) : + ∑ x : F, quadraticChar F ((-4) * x ^ 2) = (Fintype.card F : ℤ) - 1 := by + have hnegFour := quadraticChar_neg_four_eq_one hF hneg + calc + ∑ x : F, quadraticChar F ((-4) * x ^ 2) = + ∑ x : F, if x = 0 then 0 else 1 := by + apply sum_congr rfl + intro x _ + by_cases hx : x = 0 + · simp [hx] + · rw [map_mul, hnegFour, one_mul, quadraticChar_sq_one' hx] + simp [hx] + _ = (Fintype.card F : ℤ) - 1 := by + rw [sum_ite] + simp only [sum_const_zero, sum_const, nsmul_eq_mul, mul_one] + have hfilter : (univ.filter fun x : F ↦ ¬x = 0) = univ.erase 0 := by + ext x + simp + rw [hfilter, card_erase_of_mem (mem_univ 0)] + rw [card_univ] + have hcard : 0 < Fintype.card F := Fintype.card_pos + omega + +private lemma quadraticChar_neg_sixteen_eq_one + (hF : ringChar F ≠ 2) (hneg : quadraticChar F (-1) = 1) : + quadraticChar F (-16) = 1 := by + have hfour : (4 : F) ≠ 0 := by + rw [show (4 : F) = 2 ^ 2 by norm_num] + exact pow_ne_zero 2 (Ring.two_ne_zero hF) + rw [show (-16 : F) = (-1) * 4 ^ 2 by norm_num, map_mul, + hneg, quadraticChar_sq_one' hfour, one_mul] + +private lemma markoffDiscriminant_inner_sum + (hF : ringChar F ≠ 2) (hneg : quadraticChar F (-1) = 1) (y : F) : + ∑ x : F, quadraticChar F ((y ^ 2 - 4) * x ^ 2 - 4 * y ^ 2) = + -quadraticChar F (y ^ 2 - 4) + + (if y = 0 then (Fintype.card F : ℤ) else 0) + + (if y ^ 2 = 4 then (Fintype.card F : ℤ) else 0) := by + have htwo : (2 : F) ≠ 0 := Ring.two_ne_zero hF + have hfour : (4 : F) ≠ 0 := by + rw [show (4 : F) = 2 ^ 2 by norm_num] + exact pow_ne_zero 2 htwo + by_cases hy : y = 0 + · subst y + have hrewrite (x : F) : + ((0 : F) ^ 2 - 4) * x ^ 2 - 4 * (0 : F) ^ 2 = (-4) * x ^ 2 := by ring + simp_rw [hrewrite] + rw [sum_quadraticChar_neg_four_mul_sq hF hneg] + have hzeroFour : (0 : F) ^ 2 ≠ 4 := by + simpa using hfour.symm + simp only [ite_true, ite_eq_right hzeroFour] + rw [show quadraticChar F ((0 : F) ^ 2 - 4) = 1 by + simpa using quadraticChar_neg_four_eq_one hF hneg] + ring + · by_cases hspecial : y ^ 2 = 4 + · have hconstant (x : F) : (y ^ 2 - 4) * x ^ 2 - 4 * y ^ 2 = (-16 : F) := by + rw [hspecial] + ring + simp_rw [hconstant, quadraticChar_neg_sixteen_eq_one hF hneg] + rw [ite_eq_right hy, ite_eq_left hspecial] + simp [hspecial] + · have hA : y ^ 2 - 4 ≠ 0 := sub_ne_zero.mpr hspecial + have hC : (4 : F) * y ^ 2 ≠ 0 := mul_ne_zero hfour (pow_ne_zero 2 hy) + rw [BGS.FiniteField.sum_quadraticChar_mul_sq_sub hF hA hC] + rw [ite_eq_right hy, ite_eq_right hspecial] + ring + +private lemma markoffDiscriminant_double_sum + (hF : ringChar F ≠ 2) (hneg : quadraticChar F (-1) = 1) : + ∑ y : F, ∑ x : F, quadraticChar F ((y ^ 2 - 4) * x ^ 2 - 4 * y ^ 2) = + 3 * (Fintype.card F : ℤ) + 1 := by + have htwo : (2 : F) ≠ 0 := Ring.two_ne_zero hF + have hfour : (4 : F) ≠ 0 := by + rw [show (4 : F) = 2 ^ 2 by norm_num] + exact pow_ne_zero 2 htwo + have hchiFour : quadraticChar F (4 : F) = 1 := by + rw [show (4 : F) = 2 ^ 2 by norm_num, quadraticChar_sq_one' htwo] + have hquadratic : + ∑ y : F, quadraticChar F (y ^ 2 - 4) = -1 := by + simpa using + (BGS.FiniteField.sum_quadraticChar_mul_sq_sub hF (A := (1 : F)) + (C := (4 : F)) one_ne_zero hfour) + have hzeroIndicator : + ∑ y : F, (if y = 0 then (Fintype.card F : ℤ) else 0) = + Fintype.card F := by + simp + have hrootCard : (univ.filter fun y : F ↦ y ^ 2 = 4).card = 2 := by + have hroots := quadraticChar_card_sqrts hF (4 : F) + rw [hchiFour] at hroots + norm_num [Set.toFinset_ofPred] at hroots + exact_mod_cast hroots + have hspecialIndicator : + ∑ y : F, (if y ^ 2 = 4 then (Fintype.card F : ℤ) else 0) = + 2 * Fintype.card F := by + rw [sum_ite] + simp only [sum_const_zero, add_zero, sum_const, nsmul_eq_mul] + rw [hrootCard] + ring + simp_rw [markoffDiscriminant_inner_sum hF hneg] + rw [sum_add_distrib, sum_add_distrib] + rw [sum_neg_distrib, hquadratic, hzeroIndicator, hspecialIndicator] + ring + +private def normalizedMarkoffThirdCoordinateEquivDiscriminantRoots + (hF : ringChar F ≠ 2) (x y : F) : + {z : F // IsNormalizedMarkoff (⟨x, y, z⟩ : NormalizedPoint F)} ≃ + {d : F // d ^ 2 = (y ^ 2 - 4) * x ^ 2 - 4 * y ^ 2} where + toFun z := ⟨2 * z.1 - x * y, by + have hz := z.2 + change x ^ 2 + y ^ 2 + z.1 ^ 2 - x * y * z.1 = 0 at hz + linear_combination 4 * hz⟩ + invFun d := ⟨(d.1 + x * y) / 2, by + change x ^ 2 + y ^ 2 + ((d.1 + x * y) / 2) ^ 2 - + x * y * ((d.1 + x * y) / 2) = 0 + have htwo : (2 : F) ≠ 0 := Ring.two_ne_zero hF + field_simp [htwo] + linear_combination d.2⟩ + left_inv z := by + apply Subtype.ext + dsimp + have htwo : (2 : F) ≠ 0 := Ring.two_ne_zero hF + field_simp [htwo] + ring + right_inv d := by + apply Subtype.ext + dsimp + have htwo : (2 : F) ≠ 0 := Ring.two_ne_zero hF + field_simp [htwo] + ring + +private def normalizedSurfaceEquivDiscriminantRoots + (hF : ringChar F ≠ 2) : + ↑(normalizedSurface F) ≃ + Σ x : F, Σ y : F, + {d : F // d ^ 2 = (y ^ 2 - 4) * x ^ 2 - 4 * y ^ 2} where + toFun u := + ⟨u.1.u1, u.1.u2, + normalizedMarkoffThirdCoordinateEquivDiscriminantRoots hF u.1.u1 u.1.u2 + ⟨u.1.u3, u.2⟩⟩ + invFun u := + ⟨⟨u.1, u.2.1, + (normalizedMarkoffThirdCoordinateEquivDiscriminantRoots hF u.1 u.2.1).symm + u.2.2⟩, + ((normalizedMarkoffThirdCoordinateEquivDiscriminantRoots hF u.1 u.2.1).symm + u.2.2).2⟩ + left_inv u := by + apply Subtype.ext + ext <;> simp + right_inv u := by + rcases u with ⟨x, y, d⟩ + change (⟨x, y, (normalizedMarkoffThirdCoordinateEquivDiscriminantRoots hF x y) + ((normalizedMarkoffThirdCoordinateEquivDiscriminantRoots hF x y).symm d)⟩ : + Σ x : F, Σ y : F, {d : F // d ^ 2 = (y ^ 2 - 4) * x ^ 2 - 4 * y ^ 2}) = _ + rw [Equiv.apply_symm_apply] + +private lemma squareRootSubtypeCard_eq_quadraticChar_add_one + (hF : ringChar F ≠ 2) (t : F) : + (Fintype.card {d : F // d ^ 2 = t} : ℤ) = quadraticChar F t + 1 := by + calc + (Fintype.card {d : F // d ^ 2 = t} : ℤ) = + ((({d : F | d ^ 2 = t} : Set F).toFinset.card : ℕ) : ℤ) := by + rw [Set.toFinset_card] + exact_mod_cast Fintype.card_congr (Equiv.refl _) + _ = quadraticChar F t + 1 := quadraticChar_card_sqrts hF t + +/-- If the field has odd characteristic and `-1` has quadratic character `1`, the normalized +Markoff surface has `q² + 3q + 1` points, including the origin. -/ +theorem normalizedSurface_card_eq_of_quadraticChar_neg_one_eq_one + (hF : ringChar F ≠ 2) (hneg : quadraticChar F (-1) = 1) : + Nat.card ↑(normalizedSurface F) = + Fintype.card F ^ 2 + 3 * Fintype.card F + 1 := by + classical + let := Fintype.ofFinite ↑(normalizedSurface F) + rw [Nat.card_eq_fintype_card] + rw [Fintype.card_congr (normalizedSurfaceEquivDiscriminantRoots hF)] + rw [Fintype.card_sigma] + simp_rw [Fintype.card_sigma] + have hroots (x y : F) : + (Fintype.card {d : F // + d ^ 2 = (y ^ 2 - 4) * x ^ 2 - 4 * y ^ 2} : ℤ) = + quadraticChar F ((y ^ 2 - 4) * x ^ 2 - 4 * y ^ 2) + 1 := by + exact squareRootSubtypeCard_eq_quadraticChar_add_one hF _ + apply Nat.cast_injective (R := ℤ) + push_cast + simp_rw [hroots] + simp_rw [sum_add_distrib] + rw [sum_comm] + rw [markoffDiscriminant_double_sum hF hneg] + simp + ring + +/-- Removing the origin from the normalized surface leaves `q² + 3q` points. -/ +theorem normalizedPuncturedSurface_card_eq_of_quadraticChar_neg_one_eq_one + (hF : ringChar F ≠ 2) (hneg : quadraticChar F (-1) = 1) : + Nat.card ↑(normalizedPuncturedSurface F) = + Fintype.card F ^ 2 + 3 * Fintype.card F := by + change (normalizedPuncturedSurface F).ncard = _ + rw [normalizedPuncturedSurface, Set.ncard_sdiff_singleton_of_mem] + · rw [← Nat.card_coe_set_eq, + normalizedSurface_card_eq_of_quadraticChar_neg_one_eq_one hF hneg] + omega + · exact isNormalizedMarkoff_origin + +/-- Published equation (95) in normalized coordinates: for prime `p ≡ 1 (mod 4)`, the +punctured surface has exactly `p² + 3p` points. -/ +theorem normalizedPuncturedSurface_zmod_card_eq_of_mod_four_eq_one + (p : ℕ) [Fact p.Prime] (hpModFour : p % 4 = 1) : + Nat.card ↑(normalizedPuncturedSurface (ZMod p)) = p ^ 2 + 3 * p := by + have hpTwo : p ≠ 2 := by + intro hp + subst p + norm_num at hpModFour + have hchar : ringChar (ZMod p) ≠ 2 := (ZMod.ringChar_zmod_n p).substr hpTwo + have hneg : quadraticChar (ZMod p) (-1) = 1 := by + rw [quadraticChar_neg_one hchar, ZMod.χ₄_nat_eq_if_mod_four, ZMod.card p, hpModFour] + simp only [ite_true] + have hpOdd : p % 2 = 1 := by omega + rw [hpOdd] + norm_num + simpa [ZMod.card p] using + normalizedPuncturedSurface_card_eq_of_quadraticChar_neg_one_eq_one hchar hneg + +private def normalizedFiber1ZeroEquivSquareRoots : + ↑(normalizedFiber1 (0 : F)) ≃ Σ y : F, {z : F // z ^ 2 = -y ^ 2} where + toFun u := ⟨u.1.u2, u.1.u3, by + have hu := u.2.1 + change u.1.u1 ^ 2 + u.1.u2 ^ 2 + u.1.u3 ^ 2 - + u.1.u1 * u.1.u2 * u.1.u3 = 0 at hu + rw [u.2.2] at hu + linear_combination hu⟩ + invFun u := ⟨⟨0, u.1, u.2.1⟩, by + constructor + · change (0 : F) ^ 2 + u.1 ^ 2 + u.2.1 ^ 2 - 0 * u.1 * u.2.1 = 0 + rw [u.2.2] + ring + · rfl⟩ + left_inv u := by + apply Subtype.ext + ext + · exact u.2.2.symm + · rfl + · rfl + right_inv u := by + rcases u with ⟨y, z⟩ + rfl + +/-- The full first-coordinate-zero fiber has `2q - 1` points; the extra point is the origin. -/ +theorem normalizedFiber1_zero_card_eq_of_quadraticChar_neg_one_eq_one + (hF : ringChar F ≠ 2) (hneg : quadraticChar F (-1) = 1) : + Nat.card ↑(normalizedFiber1 (0 : F)) = 2 * Fintype.card F - 1 := by + classical + let := Fintype.ofFinite ↑(normalizedFiber1 (0 : F)) + rw [Nat.card_eq_fintype_card] + rw [Fintype.card_congr normalizedFiber1ZeroEquivSquareRoots] + rw [Fintype.card_sigma] + apply Nat.cast_injective (R := ℤ) + push_cast + simp_rw [squareRootSubtypeCard_eq_quadraticChar_add_one hF] + have hchar (y : F) : + quadraticChar F (-y ^ 2) = if y = 0 then 0 else 1 := by + by_cases hy : y = 0 + · simp [hy] + · rw [show -y ^ 2 = (-1) * y ^ 2 by ring, map_mul, hneg, + quadraticChar_sq_one' hy, one_mul] + simp [hy] + simp_rw [hchar, sum_add_distrib] + have hfilter : (univ.filter fun y : F ↦ ¬y = 0) = univ.erase 0 := by + ext y + simp + rw [sum_ite] + simp only [sum_const_zero, sum_const, nsmul_eq_mul] + rw [hfilter, card_erase_of_mem (mem_univ 0), card_univ] + have hcard : 0 < Fintype.card F := Fintype.card_pos + omega + +/-- After removing the origin, a normalized coordinate-zero fiber has `2q - 2` points. -/ +theorem normalizedPuncturedFiber1_zero_card_eq_of_quadraticChar_neg_one_eq_one + (hF : ringChar F ≠ 2) (hneg : quadraticChar F (-1) = 1) : + Nat.card ↑(normalizedFiber1 (0 : F) \ {normalizedOrigin}) = + 2 * Fintype.card F - 2 := by + change (normalizedFiber1 (0 : F) \ {normalizedOrigin}).ncard = _ + rw [Set.ncard_sdiff_singleton_of_mem] + · rw [← Nat.card_coe_set_eq, + normalizedFiber1_zero_card_eq_of_quadraticChar_neg_one_eq_one hF hneg] + have hcard : 0 < Fintype.card F := Fintype.card_pos + omega + · exact ⟨isNormalizedMarkoff_origin, rfl⟩ + +/-- Published equation (96) for the first normalized coordinate. -/ +theorem normalizedPuncturedFiber1_zero_zmod_card_eq_of_mod_four_eq_one + (p : ℕ) [Fact p.Prime] (hpModFour : p % 4 = 1) : + Nat.card ↑(normalizedFiber1 (0 : ZMod p) \ {normalizedOrigin}) = 2 * p - 2 := by + have hpTwo : p ≠ 2 := by + intro hp + subst p + norm_num at hpModFour + have hchar : ringChar (ZMod p) ≠ 2 := (ZMod.ringChar_zmod_n p).substr hpTwo + have hneg : quadraticChar (ZMod p) (-1) = 1 := by + rw [quadraticChar_neg_one hchar, ZMod.χ₄_nat_eq_if_mod_four, ZMod.card p, hpModFour] + simp only [ite_true] + have hpOdd : p % 2 = 1 := by omega + rw [hpOdd] + norm_num + simpa [ZMod.card p] using + normalizedPuncturedFiber1_zero_card_eq_of_quadraticChar_neg_one_eq_one hchar hneg + +/-- Original-coordinate punctured Markoff points whose first coordinate vanishes. -/ +def puncturedMarkoffFirstCoordinateZero (R : Type*) [CommRing R] : + Set (PuncturedMarkoffSurface R) := + {x | x.1.1.x1 = 0} + +/-- Original-coordinate punctured Markoff points whose second coordinate vanishes. -/ +def puncturedMarkoffSecondCoordinateZero (R : Type*) [CommRing R] : + Set (PuncturedMarkoffSurface R) := + {x | x.1.1.x2 = 0} + +/-- Original-coordinate punctured Markoff points whose third coordinate vanishes. -/ +def puncturedMarkoffThirdCoordinateZero (R : Type*) [CommRing R] : + Set (PuncturedMarkoffSurface R) := + {x | x.1.1.x3 = 0} + +/-- Swapping the first two coordinates identifies their zero-coordinate loci. -/ +def puncturedMarkoffSecondCoordinateZeroEquivFirst (R : Type*) [CommRing R] : + ↑(puncturedMarkoffSecondCoordinateZero R) ≃ + ↑(puncturedMarkoffFirstCoordinateZero R) := + (swap12PuncturedPerm R).subtypeEquiv fun _ ↦ Iff.rfl + +/-- Swapping the last two coordinates and then the first two identifies the third and first +zero-coordinate loci. -/ +def puncturedMarkoffThirdCoordinateZeroEquivFirst (R : Type*) [CommRing R] : + ↑(puncturedMarkoffThirdCoordinateZero R) ≃ + ↑(puncturedMarkoffFirstCoordinateZero R) := + ((swap23PuncturedPerm R).trans (swap12PuncturedPerm R)).subtypeEquiv fun _ ↦ Iff.rfl + +private def puncturedMarkoffFirstCoordinateZeroEquivNormalized + [Invertible (3 : F)] : + ↑(puncturedMarkoffFirstCoordinateZero F) ≃ + ↑(normalizedFiber1 (0 : F) \ {normalizedOrigin}) where + toFun x := by + let u := puncturedNormalizationEquiv F x.1 + refine ⟨u.1, ⟨⟨u.2.1, ?_⟩, u.2.2⟩⟩ + rw [show (u.1 : NormalizedPoint F) = toNormalized x.1.1.1 by rfl] + change (3 : F) * x.1.1.1.x1 = 0 + rw [x.2, mul_zero] + invFun u := by + let v : ↑(normalizedPuncturedSurface F) := ⟨u.1, ⟨u.2.1.1, u.2.2⟩⟩ + let x := (puncturedNormalizationEquiv F).symm v + refine ⟨x, ?_⟩ + have hnormalize : puncturedNormalizationEquiv F x = v := + (puncturedNormalizationEquiv F).apply_symm_apply v + have hcoordinate : (3 : F) * x.1.1.x1 = 0 := by + have := congrArg (fun w : ↑(normalizedPuncturedSurface F) ↦ w.1.u1) hnormalize + simpa [v, puncturedNormalizationEquiv_coe, toNormalized] using this.trans u.2.1.2 + exact (mul_eq_zero.mp hcoordinate).resolve_left (isUnit_of_invertible (3 : F)).ne_zero + left_inv x := by + apply Subtype.ext + change (puncturedNormalizationEquiv F).symm (puncturedNormalizationEquiv F x.1) = x.1 + exact (puncturedNormalizationEquiv F).symm_apply_apply x.1 + right_inv u := by + apply Subtype.ext + change ((puncturedNormalizationEquiv F) + ((puncturedNormalizationEquiv F).symm + ⟨u.1, ⟨u.2.1.1, u.2.2⟩⟩)).1 = u.1 + rw [(puncturedNormalizationEquiv F).apply_symm_apply] + +/-- Normalization transports the coordinate-zero count to original Markoff coordinates. -/ +theorem puncturedMarkoffFirstCoordinateZero_card_eq_of_quadraticChar_neg_one_eq_one + [Invertible (3 : F)] (hF : ringChar F ≠ 2) + (hneg : quadraticChar F (-1) = 1) : + Nat.card ↑(puncturedMarkoffFirstCoordinateZero F) = + 2 * Fintype.card F - 2 := by + rw [Nat.card_congr puncturedMarkoffFirstCoordinateZeroEquivNormalized] + exact normalizedPuncturedFiber1_zero_card_eq_of_quadraticChar_neg_one_eq_one hF hneg + +/-- The second-coordinate-zero locus has the same exact local count. -/ +theorem puncturedMarkoffSecondCoordinateZero_card_eq_of_quadraticChar_neg_one_eq_one + [Invertible (3 : F)] (hF : ringChar F ≠ 2) + (hneg : quadraticChar F (-1) = 1) : + Nat.card ↑(puncturedMarkoffSecondCoordinateZero F) = + 2 * Fintype.card F - 2 := by + rw [Nat.card_congr (puncturedMarkoffSecondCoordinateZeroEquivFirst F)] + exact puncturedMarkoffFirstCoordinateZero_card_eq_of_quadraticChar_neg_one_eq_one hF hneg + +/-- The third-coordinate-zero locus has the same exact local count. -/ +theorem puncturedMarkoffThirdCoordinateZero_card_eq_of_quadraticChar_neg_one_eq_one + [Invertible (3 : F)] (hF : ringChar F ≠ 2) + (hneg : quadraticChar F (-1) = 1) : + Nat.card ↑(puncturedMarkoffThirdCoordinateZero F) = + 2 * Fintype.card F - 2 := by + rw [Nat.card_congr (puncturedMarkoffThirdCoordinateZeroEquivFirst F)] + exact puncturedMarkoffFirstCoordinateZero_card_eq_of_quadraticChar_neg_one_eq_one hF hneg + +/-- Published equation (95) for the original-coordinate punctured Markoff surface. -/ +theorem puncturedMarkoffSurface_zmod_card_eq_of_mod_four_eq_one + (p : ℕ) [Fact p.Prime] (hpModFour : p % 4 = 1) : + Nat.card (PuncturedMarkoffSurface (ZMod p)) = p ^ 2 + 3 * p := by + have hp := (Fact.out : p.Prime) + have hpThree : 3 < p := by + by_contra h + have hpLe : p ≤ 3 := by omega + have hpTwo : 2 ≤ p := hp.two_le + have hpCases : p = 2 ∨ p = 3 := by omega + rcases hpCases with rfl | rfl <;> norm_num at hpModFour + let : Invertible (3 : ZMod p) := + invertibleOfNonzero (by + intro hzero + have hdvd : p ∣ 3 := (ZMod.natCast_eq_zero_iff 3 p).mp hzero + exact (Nat.not_le_of_gt hpThree) (Nat.le_of_dvd (by norm_num) hdvd)) + rw [Nat.card_congr (puncturedNormalizationEquiv (ZMod p))] + exact normalizedPuncturedSurface_zmod_card_eq_of_mod_four_eq_one p hpModFour + +/-- The primewise-punctured carrier has the product cardinality asserted after published +equation (95). -/ +theorem primewisePuncturedMarkoffSurface_card_eq_of_mod_four_eq_one + {ι : Type*} [Fintype ι] (a : ι → ℕ) [∀ i, Fact (a i).Prime] + (hmod : ∀ i, a i % 4 = 1) : + Nat.card (PrimewisePuncturedMarkoffSurface a) = + ∏ i, (a i ^ 2 + 3 * a i) := by + rw [Nat.card_pi] + apply Finset.prod_congr rfl + intro i _ + exact puncturedMarkoffSurface_zmod_card_eq_of_mod_four_eq_one (a i) (hmod i) + +/-- The single-residue-ring CRT presentation has the same exact product cardinality. -/ +theorem crtPrimewisePuncturedMarkoffSurface_card_eq_of_mod_four_eq_one + {ι : Type*} [Fintype ι] (a : ι → ℕ) [∀ i, Fact (a i).Prime] + (coprime : Pairwise (Function.onFun Nat.Coprime a)) (hmod : ∀ i, a i % 4 = 1) : + Nat.card (CRTPrimewisePuncturedMarkoffSurface a coprime) = + ∏ i, (a i ^ 2 + 3 * a i) := by + rw [Nat.card_congr (primewisePuncturedCRTEquiv a coprime)] + exact primewisePuncturedMarkoffSurface_card_eq_of_mod_four_eq_one a hmod + +/-- Published equation (96) in original Markoff coordinates, for the first coordinate. -/ +theorem puncturedMarkoffFirstCoordinateZero_zmod_card_eq_of_mod_four_eq_one + (p : ℕ) [Fact p.Prime] (hpModFour : p % 4 = 1) : + Nat.card ↑(puncturedMarkoffFirstCoordinateZero (ZMod p)) = 2 * p - 2 := by + have hp := (Fact.out : p.Prime) + have hpThree : 3 < p := by + by_contra h + have hpLe : p ≤ 3 := by omega + have hpTwo : 2 ≤ p := hp.two_le + have hpCases : p = 2 ∨ p = 3 := by omega + rcases hpCases with rfl | rfl <;> norm_num at hpModFour + let : Invertible (3 : ZMod p) := + invertibleOfNonzero (by + intro hzero + have hdvd : p ∣ 3 := (ZMod.natCast_eq_zero_iff 3 p).mp hzero + exact (Nat.not_le_of_gt hpThree) (Nat.le_of_dvd (by norm_num) hdvd)) + have hpTwo : p ≠ 2 := by omega + have hchar : ringChar (ZMod p) ≠ 2 := (ZMod.ringChar_zmod_n p).substr hpTwo + have hneg : quadraticChar (ZMod p) (-1) = 1 := by + rw [quadraticChar_neg_one hchar, ZMod.χ₄_nat_eq_if_mod_four, ZMod.card p, hpModFour] + simp only [ite_true] + have hpOdd : p % 2 = 1 := by omega + rw [hpOdd] + norm_num + simpa [ZMod.card p] using + puncturedMarkoffFirstCoordinateZero_card_eq_of_quadraticChar_neg_one_eq_one hchar hneg + +/-- Published equation (96) for the second original Markoff coordinate. -/ +theorem puncturedMarkoffSecondCoordinateZero_zmod_card_eq_of_mod_four_eq_one + (p : ℕ) [Fact p.Prime] (hpModFour : p % 4 = 1) : + Nat.card ↑(puncturedMarkoffSecondCoordinateZero (ZMod p)) = 2 * p - 2 := by + rw [Nat.card_congr (puncturedMarkoffSecondCoordinateZeroEquivFirst (ZMod p))] + exact puncturedMarkoffFirstCoordinateZero_zmod_card_eq_of_mod_four_eq_one p hpModFour + +/-- Published equation (96) for the third original Markoff coordinate. -/ +theorem puncturedMarkoffThirdCoordinateZero_zmod_card_eq_of_mod_four_eq_one + (p : ℕ) [Fact p.Prime] (hpModFour : p % 4 = 1) : + Nat.card ↑(puncturedMarkoffThirdCoordinateZero (ZMod p)) = 2 * p - 2 := by + rw [Nat.card_congr (puncturedMarkoffThirdCoordinateZeroEquivFirst (ZMod p))] + exact puncturedMarkoffFirstCoordinateZero_zmod_card_eq_of_mod_four_eq_one p hpModFour + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Diophantine/PrimewiseCRT.lean b/LeanPool/MarkoffModP/BGS/Markoff/Diophantine/PrimewiseCRT.lean new file mode 100644 index 0000000000..0f7648b5a9 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Diophantine/PrimewiseCRT.lean @@ -0,0 +1,405 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Core.Action +public import Mathlib.Data.ZMod.QuotientRing + +/-! +# Primewise puncturing and the Chinese remainder theorem + +For a finite pairwise-coprime family of moduli, the Chinese remainder theorem identifies the +Markoff surface modulo their product with the product of the local Markoff surfaces. There are +two different punctures on these objects: + +* the naive puncture removes only the single global origin, and hence asks that *some* local + component be nonzero; +* the primewise puncture used in Section 7 of Bourgain--Gamburd--Sarnak asks that *every* local + component be nonzero. + +This file keeps those carriers distinct and proves that CRT and all five standard Markoff moves +respect the primewise carrier. No point-counting result is included here. +-/ + +@[expose] public section + +namespace BGS.Markoff + +universe u v + +open scoped Function + +/-- Apply a ring homomorphism coordinatewise to an affine point. -/ +def Point.map {R : Type u} {S : Type v} [CommRing R] [CommRing S] + (f : R →+* S) (x : Point R) : Point S := + ⟨f x.x1, f x.x2, f x.x3⟩ + +@[simp] theorem Point.map_x1 {R : Type u} {S : Type v} [CommRing R] [CommRing S] + (f : R →+* S) (x : Point R) : (x.map f).x1 = f x.x1 := rfl + +@[simp] theorem Point.map_x2 {R : Type u} {S : Type v} [CommRing R] [CommRing S] + (f : R →+* S) (x : Point R) : (x.map f).x2 = f x.x2 := rfl + +@[simp] theorem Point.map_x3 {R : Type u} {S : Type v} [CommRing R] [CommRing S] + (f : R →+* S) (x : Point R) : (x.map f).x3 = f x.x3 := rfl + +@[simp] theorem Point.map_origin {R : Type u} {S : Type v} [CommRing R] [CommRing S] + (f : R →+* S) : (origin : Point R).map f = origin := by + ext <;> simp [Point.map, origin] + +@[simp] theorem markoffPolynomial_map {R : Type u} {S : Type v} [CommRing R] [CommRing S] + (f : R →+* S) (x : Point R) : markoffPolynomial (x.map f) = f (markoffPolynomial x) := by + simp only [markoffPolynomial, Point.map, map_sub, map_add, map_mul, map_pow, map_ofNat] + +/-- A ring equivalence transports affine three-space coordinatewise. -/ +def pointRingEquiv {R : Type u} {S : Type v} [CommRing R] [CommRing S] + (e : R ≃+* S) : Point R ≃ Point S where + toFun := Point.map e + invFun := Point.map e.symm + left_inv x := by ext <;> simp [Point.map] + right_inv x := by ext <;> simp [Point.map] + +/-- A ring equivalence transports the original Markoff surface. -/ +def markoffSurfaceRingEquiv {R : Type u} {S : Type v} [CommRing R] [CommRing S] + (e : R ≃+* S) : MarkoffSurface R ≃ MarkoffSurface S where + toFun x := + ⟨Point.map e.toRingHom x.val, by + change markoffPolynomial (Point.map e.toRingHom x.val) = 0 + rw [markoffPolynomial_map, x.2, map_zero]⟩ + invFun x := + ⟨Point.map e.symm.toRingHom x.val, by + change markoffPolynomial (Point.map e.symm.toRingHom x.val) = 0 + rw [markoffPolynomial_map, x.2, map_zero]⟩ + left_inv x := by apply Subtype.ext; exact (pointRingEquiv e).left_inv x.1 + right_inv x := by apply Subtype.ext; exact (pointRingEquiv e).right_inv x.1 + +@[simp] theorem coe_markoffSurfaceRingEquiv {R : Type u} {S : Type v} + [CommRing R] [CommRing S] (e : R ≃+* S) (x : MarkoffSurface R) : + ((markoffSurfaceRingEquiv e x : MarkoffSurface S) : Point S) = + Point.map e.toRingHom x.1 := rfl + +/-- A Markoff point over a product ring is the same thing as a family of local Markoff points. -/ +def markoffSurfacePiEquiv {ι : Type*} {R : ι → Type u} [∀ i, CommRing (R i)] : + MarkoffSurface (∀ i, R i) ≃ ∀ i, MarkoffSurface (R i) where + toFun x i := + ⟨⟨x.1.x1 i, x.1.x2 i, x.1.x3 i⟩, by + exact congrFun x.2 i⟩ + invFun x := + ⟨⟨fun i => (x i).1.x1, fun i => (x i).1.x2, fun i => (x i).1.x3⟩, by + funext i + exact (x i).2⟩ + left_inv x := by apply Subtype.ext; ext i <;> rfl + right_inv x := by funext i; apply Subtype.ext; rfl + +/-- CRT on the original Markoff surface, before imposing either notion of puncture. -/ +noncomputable def markoffSurfaceCRTEquiv {ι : Type*} [Fintype ι] (a : ι → ℕ) + (coprime : Pairwise (Nat.Coprime on a)) : + MarkoffSurface (ZMod (∏ i, a i)) ≃ ∀ i, MarkoffSurface (ZMod (a i)) := + (markoffSurfaceRingEquiv (ZMod.prodEquivPi a coprime)).trans markoffSurfacePiEquiv + +@[simp] theorem markoffSurfaceCRTEquiv_coordinate_one {ι : Type*} [Fintype ι] + (a : ι → ℕ) (coprime : Pairwise (Nat.Coprime on a)) + (x : MarkoffSurface (ZMod (∏ i, a i))) (i : ι) : + ((markoffSurfaceCRTEquiv a coprime x i : MarkoffSurface (ZMod (a i))) : + Point (ZMod (a i))).x1 = + ZMod.castHom (Finset.dvd_prod_of_mem a (Finset.mem_univ i)) _ x.1.x1 := by + exact ZMod.prodEquivPi_apply a coprime x.1.x1 i + +@[simp] theorem markoffSurfaceCRTEquiv_coordinate_two {ι : Type*} [Fintype ι] + (a : ι → ℕ) (coprime : Pairwise (Nat.Coprime on a)) + (x : MarkoffSurface (ZMod (∏ i, a i))) (i : ι) : + ((markoffSurfaceCRTEquiv a coprime x i : MarkoffSurface (ZMod (a i))) : + Point (ZMod (a i))).x2 = + ZMod.castHom (Finset.dvd_prod_of_mem a (Finset.mem_univ i)) _ x.1.x2 := by + exact ZMod.prodEquivPi_apply a coprime x.1.x2 i + +@[simp] theorem markoffSurfaceCRTEquiv_coordinate_three {ι : Type*} [Fintype ι] + (a : ι → ℕ) (coprime : Pairwise (Nat.Coprime on a)) + (x : MarkoffSurface (ZMod (∏ i, a i))) (i : ι) : + ((markoffSurfaceCRTEquiv a coprime x i : MarkoffSurface (ZMod (a i))) : + Point (ZMod (a i))).x3 = + ZMod.castHom (Finset.dvd_prod_of_mem a (Finset.mem_univ i)) _ x.1.x3 := by + exact ZMod.prodEquivPi_apply a coprime x.1.x3 i + +@[simp] theorem markoffSurfaceCRTEquiv_origin {ι : Type*} [Fintype ι] + (a : ι → ℕ) (coprime : Pairwise (Nat.Coprime on a)) : + markoffSurfaceCRTEquiv a coprime (surfaceOrigin (ZMod (∏ i, a i))) = + fun i => surfaceOrigin (ZMod (a i)) := by + funext i + apply Subtype.ext + ext <;> simp [surfaceOrigin, origin] + +/-- A global point is naively punctured exactly when at least one CRT component is nonzero. -/ +theorem ne_surfaceOrigin_iff_exists_crt_ne_surfaceOrigin {ι : Type*} [Fintype ι] + (a : ι → ℕ) (coprime : Pairwise (Nat.Coprime on a)) + (x : MarkoffSurface (ZMod (∏ i, a i))) : + x ≠ surfaceOrigin (ZMod (∏ i, a i)) ↔ + ∃ i, markoffSurfaceCRTEquiv a coprime x i ≠ surfaceOrigin (ZMod (a i)) := by + constructor + · contrapose! + intro h + apply (markoffSurfaceCRTEquiv a coprime).injective + rw [markoffSurfaceCRTEquiv_origin] + funext i + exact h i + · rintro ⟨i, hi⟩ rfl + exact hi (congrFun (markoffSurfaceCRTEquiv_origin a coprime) i) + +/-- The published Section 7 carrier: every local Markoff point is punctured. -/ +abbrev PrimewisePuncturedMarkoffSurface {ι : Type*} (a : ι → ℕ) := + ∀ i, PuncturedMarkoffSurface (ZMod (a i)) + +/-- The primewise-puncture predicate on the single CRT residue ring. -/ +def IsPrimewisePunctured {ι : Type*} [Fintype ι] (a : ι → ℕ) + (coprime : Pairwise (Nat.Coprime on a)) + (x : MarkoffSurface (ZMod (∏ i, a i))) : Prop := + ∀ i, markoffSurfaceCRTEquiv a coprime x i ≠ surfaceOrigin (ZMod (a i)) + +/-- Global residue-ring presentation of the primewise-punctured carrier. -/ +abbrev CRTPrimewisePuncturedMarkoffSurface {ι : Type*} [Fintype ι] (a : ι → ℕ) + (coprime : Pairwise (Nat.Coprime on a)) := + {x : MarkoffSurface (ZMod (∏ i, a i)) // IsPrimewisePunctured a coprime x} + +/-- CRT restricted to the primewise-punctured Markoff surface. -/ +noncomputable def primewisePuncturedCRTEquiv {ι : Type*} [Fintype ι] (a : ι → ℕ) + (coprime : Pairwise (Nat.Coprime on a)) : + CRTPrimewisePuncturedMarkoffSurface a coprime ≃ PrimewisePuncturedMarkoffSurface a where + toFun x i := ⟨markoffSurfaceCRTEquiv a coprime x.1 i, x.2 i⟩ + invFun x := + ⟨(markoffSurfaceCRTEquiv a coprime).symm (fun i => (x i).1), by + intro i hi + apply (x i).2 + have heq := + congrFun ((markoffSurfaceCRTEquiv a coprime).apply_symm_apply (fun j => (x j).1)) i + exact heq.symm.trans hi⟩ + left_inv x := by + apply Subtype.ext + exact (markoffSurfaceCRTEquiv a coprime).symm_apply_apply x.1 + right_inv x := by + funext i + apply Subtype.ext + exact congrFun ((markoffSurfaceCRTEquiv a coprime).apply_symm_apply (fun j => (x j).1)) i + +/-- Every primewise-punctured global point is naively punctured, provided there is a local +factor. The converse is false in general; see `exists_naivePunctured_not_primewisePunctured`. -/ +def primewisePuncturedToNaive {ι : Type*} [Fintype ι] [Nonempty ι] (a : ι → ℕ) + (coprime : Pairwise (Nat.Coprime on a)) : + CRTPrimewisePuncturedMarkoffSurface a coprime → + PuncturedMarkoffSurface (ZMod (∏ i, a i)) := + fun x => + ⟨x.1, (ne_surfaceOrigin_iff_exists_crt_ne_surfaceOrigin a coprime x.1).2 + ⟨Classical.choice inferInstance, x.2 _⟩⟩ + +/-- The point `(1,1,1)` on the original Markoff surface. -/ +def unitMarkoffPoint (R : Type u) [CommRing R] : MarkoffSurface R := + ⟨⟨1, 1, 1⟩, by + simp only [IsMarkoff, markoffPolynomial] + ring⟩ + +theorem unitMarkoffPoint_ne_surfaceOrigin {R : Type u} [CommRing R] [Nontrivial R] : + unitMarkoffPoint R ≠ surfaceOrigin R := by + intro h + have := congrArg (fun x : MarkoffSurface R => x.1.x1) h + change (1 : R) = 0 at this + exact (one_ne_zero : (1 : R) ≠ 0) this + +/-- With two distinct factors and one nontrivial local ring, the naive puncture is strictly +larger than the primewise puncture. -/ +theorem exists_naivePunctured_not_primewisePunctured {ι : Type*} [Fintype ι] + (a : ι → ℕ) (coprime : Pairwise (Nat.Coprime on a)) {i j : ι} (hij : i ≠ j) + (hj : a j ≠ 1) : + ∃ x : PuncturedMarkoffSurface (ZMod (∏ k, a k)), + ¬ IsPrimewisePunctured a coprime x.1 := by + classical + have : Nontrivial (ZMod (a j)) := ZMod.nontrivial_iff.mpr hj + let localPoints : ∀ k, MarkoffSurface (ZMod (a k)) := + fun k => if k = i then surfaceOrigin (ZMod (a k)) else unitMarkoffPoint (ZMod (a k)) + let globalPoint := (markoffSurfaceCRTEquiv a coprime).symm localPoints + have hglobal : globalPoint ≠ surfaceOrigin (ZMod (∏ k, a k)) := by + apply (ne_surfaceOrigin_iff_exists_crt_ne_surfaceOrigin a coprime globalPoint).2 + refine ⟨j, ?_⟩ + rw [show markoffSurfaceCRTEquiv a coprime globalPoint j = localPoints j by + exact congrFun ((markoffSurfaceCRTEquiv a coprime).apply_symm_apply localPoints) j] + simp only [localPoints, ite_eq_right hij.symm] + exact unitMarkoffPoint_ne_surfaceOrigin + refine ⟨⟨globalPoint, hglobal⟩, ?_⟩ + intro hprimewise + apply hprimewise i + rw [show markoffSurfaceCRTEquiv a coprime globalPoint i = localPoints i by + exact congrFun ((markoffSurfaceCRTEquiv a coprime).apply_symm_apply localPoints) i] + simp [localPoints] + +@[simp] theorem markoffSurfaceCRTEquiv_vieta1 {ι : Type*} [Fintype ι] + (a : ι → ℕ) (coprime : Pairwise (Nat.Coprime on a)) + (x : MarkoffSurface (ZMod (∏ i, a i))) : + markoffSurfaceCRTEquiv a coprime (vieta1SurfacePerm _ x) = + fun i => vieta1SurfacePerm _ (markoffSurfaceCRTEquiv a coprime x i) := by + funext i + apply Subtype.ext + have hdiv : a i ∣ ∏ k, a k := Finset.dvd_prod_of_mem a (Finset.mem_univ i) + have hthree : (ZMod.cast (3 : ZMod (∏ k, a k)) : ZMod (a i)) = 3 := + ZMod.cast_natCast hdiv 3 + ext <;> simp [vieta1, ZMod.cast_sub hdiv, ZMod.cast_mul hdiv, hthree] + +@[simp] theorem markoffSurfaceCRTEquiv_vieta2 {ι : Type*} [Fintype ι] + (a : ι → ℕ) (coprime : Pairwise (Nat.Coprime on a)) + (x : MarkoffSurface (ZMod (∏ i, a i))) : + markoffSurfaceCRTEquiv a coprime (vieta2SurfacePerm _ x) = + fun i => vieta2SurfacePerm _ (markoffSurfaceCRTEquiv a coprime x i) := by + funext i + apply Subtype.ext + have hdiv : a i ∣ ∏ k, a k := Finset.dvd_prod_of_mem a (Finset.mem_univ i) + have hthree : (ZMod.cast (3 : ZMod (∏ k, a k)) : ZMod (a i)) = 3 := + ZMod.cast_natCast hdiv 3 + ext <;> simp [vieta2, ZMod.cast_sub hdiv, ZMod.cast_mul hdiv, hthree] + +@[simp] theorem markoffSurfaceCRTEquiv_vieta3 {ι : Type*} [Fintype ι] + (a : ι → ℕ) (coprime : Pairwise (Nat.Coprime on a)) + (x : MarkoffSurface (ZMod (∏ i, a i))) : + markoffSurfaceCRTEquiv a coprime (vieta3SurfacePerm _ x) = + fun i => vieta3SurfacePerm _ (markoffSurfaceCRTEquiv a coprime x i) := by + funext i + apply Subtype.ext + have hdiv : a i ∣ ∏ k, a k := Finset.dvd_prod_of_mem a (Finset.mem_univ i) + have hthree : (ZMod.cast (3 : ZMod (∏ k, a k)) : ZMod (a i)) = 3 := + ZMod.cast_natCast hdiv 3 + ext <;> simp [vieta3, ZMod.cast_sub hdiv, ZMod.cast_mul hdiv, hthree] + +@[simp] theorem markoffSurfaceCRTEquiv_swap12 {ι : Type*} [Fintype ι] + (a : ι → ℕ) (coprime : Pairwise (Nat.Coprime on a)) + (x : MarkoffSurface (ZMod (∏ i, a i))) : + markoffSurfaceCRTEquiv a coprime (swap12SurfacePerm _ x) = + fun i => swap12SurfacePerm _ (markoffSurfaceCRTEquiv a coprime x i) := by + funext i + apply Subtype.ext + ext <;> simp [swap12] + +@[simp] theorem markoffSurfaceCRTEquiv_swap23 {ι : Type*} [Fintype ι] + (a : ι → ℕ) (coprime : Pairwise (Nat.Coprime on a)) + (x : MarkoffSurface (ZMod (∏ i, a i))) : + markoffSurfaceCRTEquiv a coprime (swap23SurfacePerm _ x) = + fun i => swap23SurfacePerm _ (markoffSurfaceCRTEquiv a coprime x i) := by + funext i + apply Subtype.ext + ext <;> simp [swap23] + +@[simp] theorem isPrimewisePunctured_vieta1_iff {ι : Type*} [Fintype ι] + (a : ι → ℕ) (coprime : Pairwise (Nat.Coprime on a)) + (x : MarkoffSurface (ZMod (∏ i, a i))) : + IsPrimewisePunctured a coprime (vieta1SurfacePerm _ x) ↔ + IsPrimewisePunctured a coprime x := by + simp only [IsPrimewisePunctured, markoffSurfaceCRTEquiv_vieta1, + vieta1SurfacePerm_ne_origin_iff] + +@[simp] theorem isPrimewisePunctured_vieta2_iff {ι : Type*} [Fintype ι] + (a : ι → ℕ) (coprime : Pairwise (Nat.Coprime on a)) + (x : MarkoffSurface (ZMod (∏ i, a i))) : + IsPrimewisePunctured a coprime (vieta2SurfacePerm _ x) ↔ + IsPrimewisePunctured a coprime x := by + simp only [IsPrimewisePunctured, markoffSurfaceCRTEquiv_vieta2, + vieta2SurfacePerm_ne_origin_iff] + +@[simp] theorem isPrimewisePunctured_vieta3_iff {ι : Type*} [Fintype ι] + (a : ι → ℕ) (coprime : Pairwise (Nat.Coprime on a)) + (x : MarkoffSurface (ZMod (∏ i, a i))) : + IsPrimewisePunctured a coprime (vieta3SurfacePerm _ x) ↔ + IsPrimewisePunctured a coprime x := by + simp only [IsPrimewisePunctured, markoffSurfaceCRTEquiv_vieta3, + vieta3SurfacePerm_ne_origin_iff] + +@[simp] theorem isPrimewisePunctured_swap12_iff {ι : Type*} [Fintype ι] + (a : ι → ℕ) (coprime : Pairwise (Nat.Coprime on a)) + (x : MarkoffSurface (ZMod (∏ i, a i))) : + IsPrimewisePunctured a coprime (swap12SurfacePerm _ x) ↔ + IsPrimewisePunctured a coprime x := by + simp only [IsPrimewisePunctured, markoffSurfaceCRTEquiv_swap12, + swap12SurfacePerm_ne_origin_iff] + +@[simp] theorem isPrimewisePunctured_swap23_iff {ι : Type*} [Fintype ι] + (a : ι → ℕ) (coprime : Pairwise (Nat.Coprime on a)) + (x : MarkoffSurface (ZMod (∏ i, a i))) : + IsPrimewisePunctured a coprime (swap23SurfacePerm _ x) ↔ + IsPrimewisePunctured a coprime x := by + simp only [IsPrimewisePunctured, markoffSurfaceCRTEquiv_swap23, + swap23SurfacePerm_ne_origin_iff] + +/-- The first global Vieta move restricted to the primewise-punctured CRT carrier. -/ +noncomputable def vieta1CRTPrimewisePerm {ι : Type*} [Fintype ι] (a : ι → ℕ) + (coprime : Pairwise (Nat.Coprime on a)) : + Equiv.Perm (CRTPrimewisePuncturedMarkoffSurface a coprime) := + (vieta1SurfacePerm _).subtypeEquiv fun x => (isPrimewisePunctured_vieta1_iff a coprime x).symm + +/-- The second global Vieta move restricted to the primewise-punctured CRT carrier. -/ +noncomputable def vieta2CRTPrimewisePerm {ι : Type*} [Fintype ι] (a : ι → ℕ) + (coprime : Pairwise (Nat.Coprime on a)) : + Equiv.Perm (CRTPrimewisePuncturedMarkoffSurface a coprime) := + (vieta2SurfacePerm _).subtypeEquiv fun x => (isPrimewisePunctured_vieta2_iff a coprime x).symm + +/-- The third global Vieta move restricted to the primewise-punctured CRT carrier. -/ +noncomputable def vieta3CRTPrimewisePerm {ι : Type*} [Fintype ι] (a : ι → ℕ) + (coprime : Pairwise (Nat.Coprime on a)) : + Equiv.Perm (CRTPrimewisePuncturedMarkoffSurface a coprime) := + (vieta3SurfacePerm _).subtypeEquiv fun x => (isPrimewisePunctured_vieta3_iff a coprime x).symm + +/-- The first coordinate swap restricted to the primewise-punctured CRT carrier. -/ +noncomputable def swap12CRTPrimewisePerm {ι : Type*} [Fintype ι] (a : ι → ℕ) + (coprime : Pairwise (Nat.Coprime on a)) : + Equiv.Perm (CRTPrimewisePuncturedMarkoffSurface a coprime) := + (swap12SurfacePerm _).subtypeEquiv fun x => (isPrimewisePunctured_swap12_iff a coprime x).symm + +/-- The second coordinate swap restricted to the primewise-punctured CRT carrier. -/ +noncomputable def swap23CRTPrimewisePerm {ι : Type*} [Fintype ι] (a : ι → ℕ) + (coprime : Pairwise (Nat.Coprime on a)) : + Equiv.Perm (CRTPrimewisePuncturedMarkoffSurface a coprime) := + (swap23SurfacePerm _).subtypeEquiv fun x => (isPrimewisePunctured_swap23_iff a coprime x).symm + +@[simp] theorem primewisePuncturedCRTEquiv_vieta1 {ι : Type*} [Fintype ι] + (a : ι → ℕ) (coprime : Pairwise (Nat.Coprime on a)) + (x : CRTPrimewisePuncturedMarkoffSurface a coprime) : + primewisePuncturedCRTEquiv a coprime (vieta1CRTPrimewisePerm a coprime x) = + fun i => vieta1PuncturedPerm _ (primewisePuncturedCRTEquiv a coprime x i) := by + funext i + apply Subtype.ext + exact congrFun (markoffSurfaceCRTEquiv_vieta1 a coprime x.1) i + +@[simp] theorem primewisePuncturedCRTEquiv_vieta2 {ι : Type*} [Fintype ι] + (a : ι → ℕ) (coprime : Pairwise (Nat.Coprime on a)) + (x : CRTPrimewisePuncturedMarkoffSurface a coprime) : + primewisePuncturedCRTEquiv a coprime (vieta2CRTPrimewisePerm a coprime x) = + fun i => vieta2PuncturedPerm _ (primewisePuncturedCRTEquiv a coprime x i) := by + funext i + apply Subtype.ext + exact congrFun (markoffSurfaceCRTEquiv_vieta2 a coprime x.1) i + +@[simp] theorem primewisePuncturedCRTEquiv_vieta3 {ι : Type*} [Fintype ι] + (a : ι → ℕ) (coprime : Pairwise (Nat.Coprime on a)) + (x : CRTPrimewisePuncturedMarkoffSurface a coprime) : + primewisePuncturedCRTEquiv a coprime (vieta3CRTPrimewisePerm a coprime x) = + fun i => vieta3PuncturedPerm _ (primewisePuncturedCRTEquiv a coprime x i) := by + funext i + apply Subtype.ext + exact congrFun (markoffSurfaceCRTEquiv_vieta3 a coprime x.1) i + +@[simp] theorem primewisePuncturedCRTEquiv_swap12 {ι : Type*} [Fintype ι] + (a : ι → ℕ) (coprime : Pairwise (Nat.Coprime on a)) + (x : CRTPrimewisePuncturedMarkoffSurface a coprime) : + primewisePuncturedCRTEquiv a coprime (swap12CRTPrimewisePerm a coprime x) = + fun i => swap12PuncturedPerm _ (primewisePuncturedCRTEquiv a coprime x i) := by + funext i + apply Subtype.ext + exact congrFun (markoffSurfaceCRTEquiv_swap12 a coprime x.1) i + +@[simp] theorem primewisePuncturedCRTEquiv_swap23 {ι : Type*} [Fintype ι] + (a : ι → ℕ) (coprime : Pairwise (Nat.Coprime on a)) + (x : CRTPrimewisePuncturedMarkoffSurface a coprime) : + primewisePuncturedCRTEquiv a coprime (swap23CRTPrimewisePerm a coprime x) = + fun i => swap23PuncturedPerm _ (primewisePuncturedCRTEquiv a coprime x i) := by + funext i + apply Subtype.ext + exact congrFun (markoffSurfaceCRTEquiv_swap23 a coprime x.1) i + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Endgame.lean b/LeanPool/MarkoffModP/BGS/Markoff/Endgame.lean new file mode 100644 index 0000000000..afffb93a07 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Endgame.lean @@ -0,0 +1,17 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Endgame.LargeOrderToMaximal +public import LeanPool.MarkoffModP.BGS.Markoff.Endgame.Nonsplit +public import LeanPool.MarkoffModP.BGS.Markoff.Endgame.Parabolic +public import LeanPool.MarkoffModP.BGS.Markoff.Endgame.PowerCoverCounting +public import LeanPool.MarkoffModP.BGS.Markoff.Endgame.PrimitiveInclusionExclusion +public import LeanPool.MarkoffModP.BGS.Markoff.Endgame.PrimitiveOrbitWiring +public import LeanPool.MarkoffModP.BGS.Markoff.Endgame.PrimitiveTraceCount +public import LeanPool.MarkoffModP.BGS.Markoff.Endgame.WeilBoundAssumption +public import LeanPool.MarkoffModP.BGS.Markoff.Endgame.WeilFromGeneralHasse diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Endgame/LargeOrderToMaximal.lean b/LeanPool/MarkoffModP/BGS/Markoff/Endgame/LargeOrderToMaximal.lean new file mode 100644 index 0000000000..12134b5f1f --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Endgame/LargeOrderToMaximal.lean @@ -0,0 +1,115 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Endgame.Parabolic +public import LeanPool.MarkoffModP.BGS.Markoff.Opening.FiniteOrbit + +/-! +# Large order in any coordinate reaches a maximal rotation + +This packages the first-coordinate endgame with the normalized coordinate permutations and the +Markoff-component relation. +-/ + +@[expose] public section + +namespace BGS.Markoff + +noncomputable section + +/-- Three is nonzero in a prime residue field of characteristic different from three. -/ +theorem endgame_three_ne_zero_zmod_of_prime_ne_three + (p : ℕ) [Fact p.Prime] (hpThree : p ≠ 3) : (3 : ZMod p) ≠ 0 := by + intro hzero + have hpDvd : p ∣ 3 := (ZMod.natCast_eq_zero_iff 3 p).mp hzero + rcases (Nat.dvd_prime (by norm_num : Nat.Prime 3)).mp hpDvd with hpOne | hpEq + · exact (Fact.out : p.Prime).ne_one hpOne + · exact hpThree hpEq + +/-- A large first-coordinate rotation reaches a same-component point with maximal second +rotation. -/ +theorem exists_threshold_sameComponent_maximalRotation_of_large_firstCoordinate + (splitCoefficient : ℕ) + (hSplitWeil : WeightedSplitTraceWeilBoundAssumption splitCoefficient) + (nonsplitCoefficient : ℕ) + (hNonsplitWeil : SeededNonsplitTraceWeilBoundAssumption nonsplitCoefficient) + {δ : ℝ} (hδ : 0 < δ) : + ∃ threshold : ℕ, ∀ p : ℕ, threshold ≤ p → [Fact p.Prime] → ∀ hpThree : p ≠ 3, + letI : Invertible (3 : ZMod p) := + invertibleOfNonzero (endgame_three_ne_zero_zmod_of_prime_ne_three p hpThree) + ∀ x : NormalizedMarkoffSurface (ZMod p), + (p : ℝ) ^ ((1 : ℝ) / 2 + δ) ≤ rotationOrder x.1.u1 → + ∃ y : NormalizedMarkoffSurface (ZMod p), + SameNormalizedComponent x y ∧ rotationOrder y.1.u2 = p - 1 := by + obtain ⟨threshold, hthreshold⟩ := + exists_threshold_point_with_maximal_secondRotation + splitCoefficient hSplitWeil nonsplitCoefficient hNonsplitWeil hδ + refine ⟨max threshold 5, ?_⟩ + intro p hp _ hpThree + let : Invertible (3 : ZMod p) := + invertibleOfNonzero (endgame_three_ne_zero_zmod_of_prime_ne_three p hpThree) + intro x hlarge + have hpThreshold : threshold ≤ p := (le_max_left threshold 5).trans hp + let xf : ↥(normalizedFiber1 x.1.u1) := ⟨x.1, x.property, rfl⟩ + obtain ⟨n, hrotation⟩ := hthreshold p hpThreshold x.1.u1 xf hlarge + let y := (normalizedRotate1Surface^[n]) x + refine ⟨y, sameNormalizedComponent_iterate_normalizedRotate1Surface x n, ?_⟩ + rw [show y.1 = (normalizedRotate1^[n]) x.1 by + exact coe_iterate_normalizedRotate1Surface x n] + exact hrotation + +/-- Published Proposition 10: if any coordinate rotation is large, the point is connected to +a point with a maximal split rotation. -/ +theorem exists_threshold_sameComponent_maximalRotation_of_some_largeCoordinate + (splitCoefficient : ℕ) + (hSplitWeil : WeightedSplitTraceWeilBoundAssumption splitCoefficient) + (nonsplitCoefficient : ℕ) + (hNonsplitWeil : SeededNonsplitTraceWeilBoundAssumption nonsplitCoefficient) + {δ : ℝ} (hδ : 0 < δ) : + ∃ threshold : ℕ, ∀ p : ℕ, threshold ≤ p → [Fact p.Prime] → ∀ hpThree : p ≠ 3, + letI : Invertible (3 : ZMod p) := + invertibleOfNonzero (endgame_three_ne_zero_zmod_of_prime_ne_three p hpThree) + ∀ x : NormalizedMarkoffSurface (ZMod p), + ((p : ℝ) ^ ((1 : ℝ) / 2 + δ) ≤ rotationOrder x.1.u1 ∨ + (p : ℝ) ^ ((1 : ℝ) / 2 + δ) ≤ rotationOrder x.1.u2 ∨ + (p : ℝ) ^ ((1 : ℝ) / 2 + δ) ≤ rotationOrder x.1.u3) → + ∃ y : NormalizedMarkoffSurface (ZMod p), + SameNormalizedComponent x y ∧ rotationOrder y.1.u2 = p - 1 := by + obtain ⟨threshold, hfirst⟩ := + exists_threshold_sameComponent_maximalRotation_of_large_firstCoordinate + splitCoefficient hSplitWeil nonsplitCoefficient hNonsplitWeil hδ + refine ⟨threshold, ?_⟩ + intro p hp _ hpThree + let : Invertible (3 : ZMod p) := + invertibleOfNonzero (endgame_three_ne_zero_zmod_of_prime_ne_three p hpThree) + intro x hlarge + rcases hlarge with hfirstLarge | hsecondLarge | hthirdLarge + · exact hfirst p hp hpThree x hfirstLarge + · let x' := normalizedSwap12Surface x + have hx' : SameNormalizedComponent x x' := sameNormalizedComponent_swap12Surface x + have hlarge' : + (p : ℝ) ^ ((1 : ℝ) / 2 + δ) ≤ rotationOrder x'.1.u1 := by + simpa [x', normalizedSwap12, coe_normalizedSwap12Surface] using hsecondLarge + obtain ⟨y, hy, hyOrder⟩ := hfirst p hp hpThree x' hlarge' + exact ⟨y, sameNormalizedComponent_trans hx' hy, hyOrder⟩ + · let x' := normalizedSwap12Surface (normalizedSwap23Surface x) + have hx23 : SameNormalizedComponent x (normalizedSwap23Surface x) := + sameNormalizedComponent_swap23Surface x + have hx12 : SameNormalizedComponent (normalizedSwap23Surface x) x' := + sameNormalizedComponent_swap12Surface (normalizedSwap23Surface x) + have hlarge' : + (p : ℝ) ^ ((1 : ℝ) / 2 + δ) ≤ rotationOrder x'.1.u1 := by + simpa [x', normalizedSwap12, normalizedSwap23, coe_normalizedSwap12Surface, + coe_normalizedSwap23Surface] using hthirdLarge + obtain ⟨y, hy, hyOrder⟩ := hfirst p hp hpThree x' hlarge' + exact ⟨y, sameNormalizedComponent_trans + (sameNormalizedComponent_trans hx23 hx12) hy, hyOrder⟩ + +end + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Endgame/Nonsplit.lean b/LeanPool/MarkoffModP/BGS/Markoff/Endgame/Nonsplit.lean new file mode 100644 index 0000000000..f6079c0124 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Endgame/Nonsplit.lean @@ -0,0 +1,13 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Endgame.Nonsplit.CayleyParametrization +public import LeanPool.MarkoffModP.BGS.Markoff.Endgame.Nonsplit.DescendedIrreducibility +public import LeanPool.MarkoffModP.BGS.Markoff.Endgame.Nonsplit.DescendedTraceCurve +public import LeanPool.MarkoffModP.BGS.Markoff.Endgame.Nonsplit.HasseFromGeneral +public import LeanPool.MarkoffModP.BGS.Markoff.Endgame.Nonsplit.SeededCover diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Endgame/Nonsplit/CayleyParametrization.lean b/LeanPool/MarkoffModP/BGS/Markoff/Endgame/Nonsplit/CayleyParametrization.lean new file mode 100644 index 0000000000..7faf202238 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Endgame/Nonsplit/CayleyParametrization.lean @@ -0,0 +1,302 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Core.ConicParametrization +public import Mathlib.FieldTheory.IntermediateField.Adjoin.Basic + +/-! +# Cayley coordinates on the nonsplit norm-one torus + +This file gives the rational coordinate needed to descend the nonsplit end-game cover from the +quadratic finite field to `ZMod p`. A point `delta` outside the base field identifies the affine +line with the norm-one torus minus its identity by + +`z |-> (z - delta ^ p) / (z - delta)`. + +The inverse is `(w * delta - delta ^ p) / (w - 1)`. The proof records the Frobenius identities +explicitly; these are the identities used when the pulled-back trace equation is cleared of +denominators over the base field. +-/ + +@[expose] public section + +namespace BGS.Markoff + +section + +variable (p : ℕ) [Fact p.Prime] + +noncomputable local instance : Fintype (quadraticFiniteField p) := Fintype.ofFinite (quadraticFiniteField p) +noncomputable local instance : Fintype {w : quadraticNormOneTorus p // w ≠ 1} := + Fintype.ofFinite _ + +private theorem quadraticExtension_finrank : Module.finrank (ZMod p) (quadraticFiniteField p) = 2 := by + simpa using GaloisField.finrank p (n := 2) + +private theorem exists_quadraticNonbaseElement : + ∃ delta : quadraticFiniteField p, delta ∉ Set.range (algebraMap (ZMod p) (quadraticFiniteField p)) := by + classical + have hnotSurjective : ¬ Function.Surjective (algebraMap (ZMod p) (quadraticFiniteField p)) := by + intro hsurjective + have hbijective : Function.Bijective (algebraMap (ZMod p) (quadraticFiniteField p)) := + ⟨(algebraMap (ZMod p) (quadraticFiniteField p)).injective, hsurjective⟩ + have hone : Module.finrank (ZMod p) (quadraticFiniteField p) = 1 := + Algebra.finrank_eq_one_iff_bijective_algebraMap.mpr hbijective + rw [quadraticExtension_finrank p] at hone + omega + change ¬ ∀ y, ∃ x, algebraMap (ZMod p) (quadraticFiniteField p) x = y at hnotSurjective + exact Classical.not_forall.mp hnotSurjective + +/-- A chosen element of the quadratic finite field which is not defined over the base field. -/ +noncomputable def quadraticNonbaseElement : quadraticFiniteField p := + Classical.choose (show ∃ delta : quadraticFiniteField p, + delta ∉ Set.range (algebraMap (ZMod p) (quadraticFiniteField p)) from by + exact exists_quadraticNonbaseElement p) + +theorem quadraticNonbaseElement_not_mem_range : + quadraticNonbaseElement p ∉ Set.range (algebraMap (ZMod p) (quadraticFiniteField p)) := by + classical + exact Classical.choose_spec (exists_quadraticNonbaseElement p) + +private theorem quadraticExtension_card : Fintype.card (quadraticFiniteField p) = p ^ 2 := by + rw [Module.card_eq_pow_finrank (K := ZMod p), quadraticExtension_finrank p, ZMod.card] + +theorem quadraticNonbaseElement_frobenius_ne_self : + quadraticNonbaseElement p ^ p ≠ quadraticNonbaseElement p := by + intro hfixed + apply quadraticNonbaseElement_not_mem_range p + have hmem : quadraticNonbaseElement p ∈ (⊥ : Subfield (quadraticFiniteField p)) := + (Subfield.mem_bot_iff_pow_eq_self (F := quadraticFiniteField p) (p := p)).mpr hfixed + rw [mem_bot_iff_intCast p (quadraticFiniteField p)] at hmem + rcases hmem with ⟨n, hn⟩ + refine ⟨(n : ZMod p), ?_⟩ + simpa using hn + +theorem quadraticNonbaseElement_frobenius_not_mem_range : + quadraticNonbaseElement p ^ p ∉ Set.range (algebraMap (ZMod p) (quadraticFiniteField p)) := by + intro hmem + rcases hmem with ⟨z, hz⟩ + apply quadraticNonbaseElement_frobenius_ne_self p + calc + quadraticNonbaseElement p ^ p + = algebraMap (ZMod p) (quadraticFiniteField p) z := hz.symm + _ = (algebraMap (ZMod p) (quadraticFiniteField p) z) ^ p := by + symm + calc + (algebraMap (ZMod p) (quadraticFiniteField p) z) ^ p = + algebraMap (ZMod p) (quadraticFiniteField p) (z ^ p) := (map_pow _ z p).symm + _ = algebraMap (ZMod p) (quadraticFiniteField p) z := by rw [ZMod.pow_card] + _ = (quadraticNonbaseElement p ^ p) ^ p := by rw [← hz] + _ = quadraticNonbaseElement p := by + rw [← pow_mul, ← pow_two, ← quadraticExtension_card p] + exact FiniteField.pow_card _ + +private theorem algebraMap_sub_nonzero (z : ZMod p) : + algebraMap (ZMod p) (quadraticFiniteField p) z - quadraticNonbaseElement p ≠ 0 := by + rw [sub_ne_zero] + exact fun h => quadraticNonbaseElement_not_mem_range p ⟨z, h⟩ + +private theorem algebraMap_sub_frobenius_nonzero (z : ZMod p) : + algebraMap (ZMod p) (quadraticFiniteField p) z - quadraticNonbaseElement p ^ p ≠ 0 := by + rw [sub_ne_zero] + exact fun h => quadraticNonbaseElement_frobenius_not_mem_range p ⟨z, h⟩ + +/-- The Cayley fraction before it is packaged as a norm-one unit. -/ +noncomputable def quadraticCayleyValue (z : ZMod p) : quadraticFiniteField p := + (algebraMap (ZMod p) (quadraticFiniteField p) z - quadraticNonbaseElement p ^ p) / + (algebraMap (ZMod p) (quadraticFiniteField p) z - quadraticNonbaseElement p) + +theorem quadraticCayleyValue_ne_zero (z : ZMod p) : quadraticCayleyValue p z ≠ 0 := by + exact div_ne_zero (algebraMap_sub_frobenius_nonzero p z) (algebraMap_sub_nonzero p z) + +theorem quadraticNonbaseElement_frobenius_frobenius : + (quadraticNonbaseElement p ^ p) ^ p = quadraticNonbaseElement p := by + rw [← pow_mul, ← pow_two, ← quadraticExtension_card p] + exact FiniteField.pow_card _ + +theorem quadraticCayleyValue_frobenius (z : ZMod p) : + quadraticCayleyValue p z ^ p = (quadraticCayleyValue p z)⁻¹ := by + rw [quadraticCayleyValue, div_pow, sub_pow_char (R := quadraticFiniteField p), sub_pow_char (R := quadraticFiniteField p), + ← map_pow, ZMod.pow_card, quadraticNonbaseElement_frobenius_frobenius p] + rw [inv_div] + +/-- Frobenius exchanges the two linear factors occurring in the Cayley coordinate. -/ +theorem quadraticCayleyBaseFactor_frobenius (z : ZMod p) : + (algebraMap (ZMod p) (quadraticFiniteField p) z - quadraticNonbaseElement p) ^ p = + algebraMap (ZMod p) (quadraticFiniteField p) z - quadraticNonbaseElement p ^ p := by + rw [sub_pow_char (R := quadraticFiniteField p)] + calc + algebraMap (ZMod p) (quadraticFiniteField p) z ^ p - quadraticNonbaseElement p ^ p = + algebraMap (ZMod p) (quadraticFiniteField p) (z ^ p) - quadraticNonbaseElement p ^ p := by + rw [map_pow] + _ = algebraMap (ZMod p) (quadraticFiniteField p) z - quadraticNonbaseElement p ^ p := by + rw [ZMod.pow_card] + +/-- Applying Frobenius again returns the other Cayley linear factor. -/ +theorem quadraticCayleyConjugateFactor_frobenius (z : ZMod p) : + (algebraMap (ZMod p) (quadraticFiniteField p) z - quadraticNonbaseElement p ^ p) ^ p = + algebraMap (ZMod p) (quadraticFiniteField p) z - quadraticNonbaseElement p := by + rw [sub_pow_char (R := quadraticFiniteField p)] + calc + algebraMap (ZMod p) (quadraticFiniteField p) z ^ p - (quadraticNonbaseElement p ^ p) ^ p = + algebraMap (ZMod p) (quadraticFiniteField p) (z ^ p) - quadraticNonbaseElement p := by + rw [map_pow, quadraticNonbaseElement_frobenius_frobenius p] + _ = algebraMap (ZMod p) (quadraticFiniteField p) z - quadraticNonbaseElement p := by + rw [ZMod.pow_card] + +/-- The product of the conjugate Cayley factors is Frobenius-fixed, hence is a base-field +coefficient in the descended equation. -/ +theorem quadraticCayleyFactorProduct_frobenius (z : ZMod p) : + ((algebraMap (ZMod p) (quadraticFiniteField p) z - quadraticNonbaseElement p ^ p) * + (algebraMap (ZMod p) (quadraticFiniteField p) z - quadraticNonbaseElement p)) ^ p = + (algebraMap (ZMod p) (quadraticFiniteField p) z - quadraticNonbaseElement p ^ p) * + (algebraMap (ZMod p) (quadraticFiniteField p) z - quadraticNonbaseElement p) := by + rw [mul_pow, quadraticCayleyConjugateFactor_frobenius p, + quadraticCayleyBaseFactor_frobenius p, mul_comm] + +private theorem div_pow_add_inv_pow (A B : quadraticFiniteField p) (hA : A ≠ 0) (hB : B ≠ 0) (d : ℕ) : + (A / B) ^ d + ((A / B) ^ d)⁻¹ = + (A ^ (2 * d) + B ^ (2 * d)) / ((A * B) ^ d) := by + rw [Nat.mul_comm 2 d, pow_mul, pow_mul, div_pow, inv_div, mul_pow] + field_simp [pow_ne_zero d hA, pow_ne_zero d hB] + +/-- Clearing the Cayley denominator gives the symmetric numerator used for powers of a +norm-one parameter. -/ +theorem quadraticCayleyValue_pow_add_inv_pow (z : ZMod p) (d : ℕ) : + quadraticCayleyValue p z ^ d + (quadraticCayleyValue p z ^ d)⁻¹ = + ((algebraMap (ZMod p) (quadraticFiniteField p) z - quadraticNonbaseElement p ^ p) ^ (2 * d) + + (algebraMap (ZMod p) (quadraticFiniteField p) z - quadraticNonbaseElement p) ^ (2 * d)) / + (((algebraMap (ZMod p) (quadraticFiniteField p) z - quadraticNonbaseElement p ^ p) * + (algebraMap (ZMod p) (quadraticFiniteField p) z - quadraticNonbaseElement p)) ^ d) := by + exact div_pow_add_inv_pow p _ _ (algebraMap_sub_frobenius_nonzero p z) + (algebraMap_sub_nonzero p z) d + +theorem quadraticCayleyValue_ne_one (z : ZMod p) : quadraticCayleyValue p z ≠ 1 := by + intro hone + have hnumerator : + algebraMap (ZMod p) (quadraticFiniteField p) z - quadraticNonbaseElement p ^ p = + algebraMap (ZMod p) (quadraticFiniteField p) z - quadraticNonbaseElement p := by + exact (div_eq_one_iff_eq (algebraMap_sub_nonzero p z)).mp hone + exact quadraticNonbaseElement_frobenius_ne_self p (sub_right_inj.mp hnumerator) + +/-- The Cayley coordinate as a unit of the quadratic finite field. -/ +noncomputable def quadraticCayleyUnit (z : ZMod p) : (quadraticFiniteField p)ˣ := + Units.mk0 (quadraticCayleyValue p z) (quadraticCayleyValue_ne_zero p z) + +theorem quadraticCayleyUnit_norm (z : ZMod p) : + Algebra.norm (ZMod p) (quadraticCayleyUnit p z : quadraticFiniteField p) = 1 := by + apply (algebraMap (ZMod p) (quadraticFiniteField p)).injective + rw [map_one, algebraMap_quadraticNorm p] + change quadraticCayleyValue p z * quadraticCayleyValue p z ^ p = 1 + rw [quadraticCayleyValue_frobenius p] + exact mul_inv_cancel₀ (quadraticCayleyValue_ne_zero p z) + +/-- The Cayley coordinate, regarded as a point of the norm-one torus. -/ +noncomputable def quadraticCayleyPoint (z : ZMod p) : quadraticNormOneTorus p := + ⟨quadraticCayleyUnit p z, by + change Units.map (Algebra.norm (ZMod p) (S := quadraticFiniteField p)) (quadraticCayleyUnit p z) = 1 + apply Units.ext + exact quadraticCayleyUnit_norm p z⟩ + +theorem quadraticCayleyPoint_ne_one (z : ZMod p) : quadraticCayleyPoint p z ≠ 1 := by + intro h + have hval := congrArg (fun w : quadraticNormOneTorus p => + (((w : (quadraticFiniteField p)ˣ) : quadraticFiniteField p))) h + exact quadraticCayleyValue_ne_one p z (by simpa [quadraticCayleyPoint, quadraticCayleyUnit] using hval) + +/-- The base-field trace of a powered Cayley point is the cleared symmetric Cayley fraction. -/ +theorem algebraMap_quadraticNormOneTrace_quadraticCayleyPoint_pow + (z : ZMod p) (d : ℕ) : + algebraMap (ZMod p) (quadraticFiniteField p) (quadraticNormOneTrace p (quadraticCayleyPoint p z ^ d)) = + ((algebraMap (ZMod p) (quadraticFiniteField p) z - quadraticNonbaseElement p ^ p) ^ (2 * d) + + (algebraMap (ZMod p) (quadraticFiniteField p) z - quadraticNonbaseElement p) ^ (2 * d)) / + (((algebraMap (ZMod p) (quadraticFiniteField p) z - quadraticNonbaseElement p ^ p) * + (algebraMap (ZMod p) (quadraticFiniteField p) z - quadraticNonbaseElement p)) ^ d) := by + rw [algebraMap_quadraticNormOneTrace] + simpa [splitTorusTrace, quadraticCayleyPoint, quadraticCayleyUnit] using + quadraticCayleyValue_pow_add_inv_pow p z d + +/-- Solving the Cayley fraction for its base-field coordinate gives the expected inverse +fraction. -/ +theorem quadraticCayleyInverseFormula_point (z : ZMod p) : + ((quadraticCayleyValue p z * quadraticNonbaseElement p - + quadraticNonbaseElement p ^ p) / + (quadraticCayleyValue p z - 1)) = algebraMap (ZMod p) (quadraticFiniteField p) z := by + have hdelta : quadraticNonbaseElement p - quadraticNonbaseElement p ^ p ≠ 0 := + sub_ne_zero.mpr (quadraticNonbaseElement_frobenius_ne_self p).symm + rw [quadraticCayleyValue] + field_simp [algebraMap_sub_nonzero p z, algebraMap_sub_frobenius_nonzero p z, + quadraticNonbaseElement_frobenius_ne_self p, hdelta] + ring + +private theorem quadraticCayleyPoint_injective : + Function.Injective (fun z : ZMod p => + (⟨quadraticCayleyPoint p z, quadraticCayleyPoint_ne_one p z⟩ : + {w : quadraticNormOneTorus p // w ≠ 1})) := by + intro z r h + have hvalue : quadraticCayleyValue p z = quadraticCayleyValue p r := by + have htorus := congrArg Subtype.val h + have hunit := congrArg (fun w : quadraticNormOneTorus p => (w : (quadraticFiniteField p)ˣ)) htorus + exact congrArg Units.val hunit + apply (algebraMap (ZMod p) (quadraticFiniteField p)).injective + rw [← quadraticCayleyInverseFormula_point p z, + ← quadraticCayleyInverseFormula_point p r, hvalue] + +private theorem quadraticCayleyTarget_card : + Fintype.card {w : quadraticNormOneTorus p // w ≠ 1} = p := by + classical + rw [Fintype.card_subtype_compl (fun w : quadraticNormOneTorus p => w = 1)] + rw [Fintype.card_subtype_eq] + rw [Fintype.card_eq_nat_card, quadraticNormOneTorus_natCard p] + omega + +private theorem quadraticCayleyPoint_bijective : + Function.Bijective (fun z : ZMod p => + (⟨quadraticCayleyPoint p z, quadraticCayleyPoint_ne_one p z⟩ : + {w : quadraticNormOneTorus p // w ≠ 1})) := by + rw [Fintype.bijective_iff_injective_and_card] + exact ⟨quadraticCayleyPoint_injective p, by + rw [ZMod.card, quadraticCayleyTarget_card p]⟩ + +/-- Cayley coordinates identify the affine line with the norm-one torus minus its identity. -/ +noncomputable def quadraticCayleyParameterEquiv : + ZMod p ≃ {w : quadraticNormOneTorus p // w ≠ 1} := + Equiv.ofBijective (fun z => + (⟨quadraticCayleyPoint p z, quadraticCayleyPoint_ne_one p z⟩ : + {w : quadraticNormOneTorus p // w ≠ 1})) + (by exact quadraticCayleyPoint_bijective p) + +@[simp] +theorem quadraticCayleyParameterEquiv_apply (z : ZMod p) : + quadraticCayleyParameterEquiv p z = + ⟨quadraticCayleyPoint p z, quadraticCayleyPoint_ne_one p z⟩ := rfl + +/-- The inverse coordinate has the explicit fraction used in the descent calculation. -/ +theorem algebraMap_quadraticCayleyParameterEquiv_symm + (w : {w : quadraticNormOneTorus p // w ≠ 1}) : + algebraMap (ZMod p) (quadraticFiniteField p) ((quadraticCayleyParameterEquiv p).symm w) = + (((w.1 : (quadraticFiniteField p)ˣ) : quadraticFiniteField p) * quadraticNonbaseElement p - + quadraticNonbaseElement p ^ p) / + (((w.1 : (quadraticFiniteField p)ˣ) : quadraticFiniteField p) - 1) := by + have happly := (quadraticCayleyParameterEquiv p).apply_symm_apply w + have hvalue : + quadraticCayleyValue p ((quadraticCayleyParameterEquiv p).symm w) = + ((w.1 : (quadraticFiniteField p)ˣ) : quadraticFiniteField p) := by + have htorus := congrArg Subtype.val happly + change quadraticCayleyPoint p ((quadraticCayleyParameterEquiv p).symm w) = w.1 at htorus + have hunit := congrArg Subtype.val htorus + change quadraticCayleyUnit p ((quadraticCayleyParameterEquiv p).symm w) = + (w.1 : (quadraticFiniteField p)ˣ) at hunit + have h := congrArg Units.val hunit + exact h + rw [← quadraticCayleyInverseFormula_point p] + rw [hvalue] + +end + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Endgame/Nonsplit/DescendedIrreducibility.lean b/LeanPool/MarkoffModP/BGS/Markoff/Endgame/Nonsplit/DescendedIrreducibility.lean new file mode 100644 index 0000000000..ad2a2b38f0 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Endgame/Nonsplit/DescendedIrreducibility.lean @@ -0,0 +1,454 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Endgame.Nonsplit.DescendedTraceCurve +public import LeanPool.MarkoffModP.BGS.Algebra.ClearedLinearFractionalSubstitution + +/-! +# Absolute irreducibility of the descended nonsplit trace curve + +The descended coordinates are `(z, u)`, whereas the split cover uses `(u, w)`. We therefore +keep `u` as the outer polynomial variable and treat the Cayley change `w = (z-δ^p)/(z-δ)` as +an automorphism of the rational function coefficient field. +-/ + +@[expose] public section + +namespace BGS.Markoff + +noncomputable section + +open Polynomial + +/-- View a bivariate polynomial as a polynomial in coordinate `1`, with coefficients in +coordinate `0`. This is the coordinate order needed after the descended curve's `(z,u)` +coordinates are compared with the split cover's `(u,w)` coordinates. -/ +def finTwoSecondToIteratedPolynomial {K : Type*} [Field K] : + MvPolynomial (Fin 2) K ≃+* Polynomial K[X] := + (MvPolynomial.renameEquiv K (Equiv.swap (0 : Fin 2) 1)).toRingEquiv.trans + (finTwoToIteratedPolynomial (K := K)) + +@[simp] +theorem finTwoSecondToIteratedPolynomial_X_zero + {K : Type*} [Field K] : + finTwoSecondToIteratedPolynomial (K := K) (MvPolynomial.X 0) = C X := by + simp [finTwoSecondToIteratedPolynomial, MvPolynomial.renameEquiv_apply] + +@[simp] +theorem finTwoSecondToIteratedPolynomial_X_one + {K : Type*} [Field K] : + finTwoSecondToIteratedPolynomial (K := K) (MvPolynomial.X 1) = X := by + simp [finTwoSecondToIteratedPolynomial, MvPolynomial.renameEquiv_apply] + +@[simp] +theorem finTwoSecondToIteratedPolynomial_C + {K : Type*} [Field K] (r : K) : + finTwoSecondToIteratedPolynomial (K := K) (MvPolynomial.C r) = C (C r) := by + simp [finTwoSecondToIteratedPolynomial, MvPolynomial.renameEquiv_apply] + +/-- The descended coordinate-order equivalence commutes with scalar extension. -/ +theorem finTwoSecondToIteratedPolynomial_map + {K L : Type*} [Field K] [Field L] (phi : K →+* L) + (P : MvPolynomial (Fin 2) K) : + finTwoSecondToIteratedPolynomial (K := L) (MvPolynomial.map phi P) = + (finTwoSecondToIteratedPolynomial (K := K) P).map + (Polynomial.mapRingHom phi) := by + let lhs : MvPolynomial (Fin 2) K →+* L[X][X] := + (finTwoSecondToIteratedPolynomial (K := L)).toRingHom.comp + (MvPolynomial.map phi) + let rhs : MvPolynomial (Fin 2) K →+* L[X][X] := + (Polynomial.mapRingHom (Polynomial.mapRingHom phi)).comp + (finTwoSecondToIteratedPolynomial (K := K)).toRingHom + have heq : lhs = rhs := by + apply MvPolynomial.ringHom_ext + · intro r + simp [lhs, rhs, RingHom.comp_apply] + · intro i + fin_cases i <;> simp [lhs, rhs, RingHom.comp_apply] + exact DFunLike.congr_fun heq P + +theorem finTwoSecondToIteratedPolynomial_splitTraceCoverPolynomial + {K : Type*} [Field K] (alpha beta : K) (e d : ℕ) : + finTwoSecondToIteratedPolynomial + (splitTraceCoverPolynomial alpha beta e d) = + C (C alpha * X ^ e) * X ^ (2 * d) + C (C beta * X ^ e) - + C (X ^ (2 * e) + 1) * X ^ d := by + simp [splitTraceCoverPolynomial] + ring + +theorem finTwoToIteratedPolynomial_splitTraceCoverPolynomial_general + {K : Type*} [Field K] (alpha beta : K) (e d : ℕ) : + finTwoToIteratedPolynomial + (splitTraceCoverPolynomial alpha beta e d) = + monomial (2 * e) (-(X ^ d)) + + monomial e (C alpha * X ^ (2 * d) + C beta) + C (-(X ^ d)) := by + simp [splitTraceCoverPolynomial, ← C_mul_X_pow_eq_monomial] + ring + +theorem finTwoToIteratedPolynomial_splitTraceCoverPolynomial_general_natDegree + {K : Type*} [Field K] (alpha beta : K) (e d : ℕ) (he : 0 < e) : + (finTwoToIteratedPolynomial + (splitTraceCoverPolynomial alpha beta e d)).natDegree = 2 * e := by + rw [finTwoToIteratedPolynomial_splitTraceCoverPolynomial_general] + have htwoNe : 2 * e ≠ e := by omega + have heTwoNe : e ≠ 2 * e := by omega + have heNe : e ≠ 0 := by omega + have htwoZero : 2 * e ≠ 0 := by omega + have hcoeff : + (monomial (2 * e) (-(X ^ d)) + + monomial e (C alpha * X ^ (2 * d) + C beta) + C (-(X ^ d))).coeff + (2 * e) = -(X ^ d) := by + rw [coeff_add, coeff_add, coeff_monomial, ite_eq_left rfl, + coeff_monomial, ite_eq_right heTwoNe, Polynomial.coeff_C_of_ne_zero htwoZero] + simp + have hnonzero : -(X ^ d : Polynomial K) ≠ 0 := neg_ne_zero.mpr (pow_ne_zero d X_ne_zero) + apply le_antisymm + · refine (natDegree_add_le _ _).trans (max_le ?_ ?_) + · refine (natDegree_add_le _ _).trans (max_le ?_ ?_) + · exact natDegree_monomial_le _ + · exact (natDegree_monomial_le _).trans (by omega) + · simp + · exact le_natDegree_of_ne_zero (by rwa [hcoeff]) + +theorem descendedIteratedPolynomial_isPrimitive_of_isCoprime + {K : Type*} [Field K] (Q N : Polynomial K) (e : ℕ) (he : 0 < e) + (hcoprime : IsCoprime Q N) : + (monomial (2 * e) (-Q) + monomial e N + C (-Q)).IsPrimitive := by + rw [isPrimitive_iff_isUnit_of_C_dvd] + intro g hg + have hall := (C_dvd_iff_dvd_coeff g _).mp hg + have heNe : e ≠ 0 := he.ne' + have htwoNe : 2 * e ≠ e := by omega + have hcoeffZero : + (monomial (2 * e) (-Q) + monomial e N + C (-Q)).coeff 0 = -Q := by + simp [coeff_add, coeff_monomial, heNe] + have hcoeffE : + (monomial (2 * e) (-Q) + monomial e N + C (-Q)).coeff e = N := by + rw [coeff_add, coeff_add, coeff_monomial, ite_eq_right htwoNe, + coeff_monomial, ite_eq_left rfl, Polynomial.coeff_C_of_ne_zero heNe] + simp + have hgQ : g ∣ Q := by + have : g ∣ -Q := hcoeffZero ▸ hall 0 + simpa using this.neg_right + have hgN : g ∣ N := hcoeffE ▸ hall e + exact hcoprime.isUnit_of_dvd' hgQ hgN + +section DescendedFormula + +variable (p : ℕ) [Fact p.Prime] + +local notation "F" => ZMod +local notation "E" => quadraticFiniteField + +def extendedCayleyNumeratorFactor : Polynomial (E p) := + X - C (quadraticNonbaseElement p ^ p) + +def extendedCayleyDenominatorFactor : Polynomial (E p) := + X - C (quadraticNonbaseElement p) + +def extendedSeededCayleyNumerator (s : (E p)ˣ) (d : ℕ) : Polynomial (E p) := + C (s : E p) * extendedCayleyNumeratorFactor p ^ (2 * d) + + C ((s : E p) ^ p) * extendedCayleyDenominatorFactor p ^ (2 * d) + +def extendedCayleyNormFactor : Polynomial (E p) := + extendedCayleyNumeratorFactor p * extendedCayleyDenominatorFactor p + +theorem extendedCayleyNormFactor_isCoprime_extendedSeededCayleyNumerator + (s : (E p)ˣ) (d : ℕ) (hd : 0 < d) : + IsCoprime (extendedCayleyNormFactor p) + (extendedSeededCayleyNumerator p s d) := by + have hnonbase : quadraticNonbaseElement p ^ p ≠ quadraticNonbaseElement p := + quadraticNonbaseElement_frobenius_ne_self p + have hleftDifference : + quadraticNonbaseElement p ^ p - quadraticNonbaseElement p ≠ 0 := + sub_ne_zero.mpr hnonbase + have hrightDifference : + quadraticNonbaseElement p - quadraticNonbaseElement p ^ p ≠ 0 := + sub_ne_zero.mpr hnonbase.symm + have hleftEval : + (extendedSeededCayleyNumerator p s d).eval + (quadraticNonbaseElement p ^ p) ≠ 0 := by + simp [extendedSeededCayleyNumerator, extendedCayleyNumeratorFactor, + extendedCayleyDenominatorFactor, hleftDifference, + show 2 * d ≠ 0 by omega] + have hrightEval : + (extendedSeededCayleyNumerator p s d).eval + (quadraticNonbaseElement p) ≠ 0 := by + simp [extendedSeededCayleyNumerator, extendedCayleyNumeratorFactor, + extendedCayleyDenominatorFactor, hrightDifference, + show 2 * d ≠ 0 by omega] + have hleft : IsCoprime (extendedCayleyNumeratorFactor p) + (extendedSeededCayleyNumerator p s d) := by + apply (irreducible_X_sub_C (quadraticNonbaseElement p ^ p)).coprime_iff_not_dvd.mpr + rw [dvd_iff_isRoot, IsRoot] + exact hleftEval + have hright : IsCoprime (extendedCayleyDenominatorFactor p) + (extendedSeededCayleyNumerator p s d) := by + apply (irreducible_X_sub_C (quadraticNonbaseElement p)).coprime_iff_not_dvd.mpr + rw [dvd_iff_isRoot, IsRoot] + exact hrightEval + exact IsCoprime.mul_left hleft hright + +theorem finTwoSecondToIteratedPolynomial_map_univariateInFirstCoordinate + {K L : Type*} [Field K] [Field L] (phi : K →+* L) (P : Polynomial K) : + finTwoSecondToIteratedPolynomial + (MvPolynomial.map phi (univariateInFirstCoordinate P)) = C (P.map phi) := by + classical + have hmap : P.map phi = + P.support.sum fun n ↦ C (phi (P.coeff n)) * X ^ n := by + ext n + simp [coeff_map] + simp [finTwoSecondToIteratedPolynomial, univariateInFirstCoordinate, + Polynomial.sum_def, MvPolynomial.renameEquiv_apply, hmap] + +theorem finTwoSecondToIteratedPolynomial_map_seededNonsplitDescendedPolynomial + (s : (E p)ˣ) (d e : ℕ) : + finTwoSecondToIteratedPolynomial + (MvPolynomial.map (algebraMap (F p) (E p)) + (seededNonsplitDescendedPolynomial p s d e)) = + monomial (2 * e) (-(extendedCayleyNormFactor p ^ d)) + + monomial e (extendedSeededCayleyNumerator p s d) + + C (-(extendedCayleyNormFactor p ^ d)) := by + rw [seededNonsplitDescendedPolynomial] + simp only [map_sub, map_mul, map_pow, map_add, map_one, + finTwoSecondToIteratedPolynomial_map_univariateInFirstCoordinate, + map_X, finTwoSecondToIteratedPolynomial_X_one] + rw [seededCayleyTraceNumeratorPolynomial_map, quadraticCayleyNormPolynomial_map] + simp [← C_mul_X_pow_eq_monomial, extendedSeededCayleyNumerator, extendedCayleyNormFactor, + extendedCayleyNumeratorFactor, extendedCayleyDenominatorFactor, + Nat.mul_comm] + ring + +theorem cayleyTransport_splitIteratedPolynomial + {K : Type*} [Field K] (alpha beta r t : K) (e d : ℕ) (hrt : r ≠ t) + (hdet : (1 : K) * (-t) - (-r) * 1 ≠ 0) : + let phi := BGS.Algebra.ratFuncLinearFractionalEquiv + (1 : K) (-r) 1 (-t) hdet + let A : RatFunc K := RatFunc.X - RatFunc.C r + let B : RatFunc K := RatFunc.X - RatFunc.C t + let Q : Polynomial K := (X - C r) * (X - C t) + let N : Polynomial K := C alpha * (X - C r) ^ (2 * d) + + C beta * (X - C t) ^ (2 * d) + C (B ^ (2 * d)) * + ((finTwoToIteratedPolynomial + (splitTraceCoverPolynomial alpha beta e d)).map + (algebraMap K[X] (RatFunc K))).map phi.toRingHom = + (monomial (2 * e) (-(Q ^ d)) + monomial e N + C (-(Q ^ d))).map + (algebraMap K[X] (RatFunc K)) := by + have hphi (f : K[X]) : + (BGS.Algebra.ratFuncLinearFractionalEquiv + (1 : K) (-r) 1 (-t) hdet).toRingEquiv.toRingHom + (algebraMap K[X] (RatFunc K) f) = + aeval (BGS.Algebra.ratFuncLinearFractionalValue + (1 : K) (-r) 1 (-t)) f := by + change BGS.Algebra.ratFuncLinearFractionalEquiv + (1 : K) (-r) 1 (-t) hdet (algebraMap K[X] (RatFunc K) f) = _ + exact BGS.Algebra.ratFuncLinearFractionalEquiv_apply_algebraMap + (1 : K) (-r) 1 (-t) hdet f + have hconst (x : K) : + BGS.Algebra.ratFuncLinearFractionalEquiv + (1 : K) (-r) 1 (-t) hdet (RatFunc.C x) = RatFunc.C x := by + change BGS.Algebra.ratFuncLinearFractionalEquiv + (1 : K) (-r) 1 (-t) hdet (algebraMap K (RatFunc K) x) = + algebraMap K (RatFunc K) x + exact (BGS.Algebra.ratFuncLinearFractionalEquiv + (1 : K) (-r) 1 (-t) hdet).commutes x + dsimp only + rw [finTwoToIteratedPolynomial_splitTraceCoverPolynomial_general] + simp only [← C_mul_X_pow_eq_monomial, Polynomial.map_add, Polynomial.map_mul, + Polynomial.map_neg, Polynomial.map_pow, Polynomial.map_C, Polynomial.map_X] + rw [hphi] + simp [BGS.Algebra.ratFuncLinearFractionalValue, aeval_def, + eval₂_add, eval₂_sub, eval₂_mul, eval₂_pow, eval₂_C, eval₂_X, + ← C_mul_X_pow_eq_monomial] + rw [hconst, hconst] + let A : RatFunc K := RatFunc.X - RatFunc.C r + let B : RatFunc K := RatFunc.X - RatFunc.C t + let q : RatFunc K := A / B + have hqExpanded : + (RatFunc.X + -RatFunc.C r) / (RatFunc.X + -RatFunc.C t) = q := by + simp [q, A, B, sub_eq_add_neg] + have hB : RatFunc.X - RatFunc.C t ≠ (0 : RatFunc K) := by + simpa only [map_sub, RatFunc.algebraMap_X, RatFunc.algebraMap_C] using + RatFunc.algebraMap_ne_zero (X_sub_C_ne_zero t) + rw [hqExpanded] + have hqD : B ^ (2 * d) * q ^ d = (A * B) ^ d := by + have hB' : B ≠ 0 := by simpa [B] using hB + dsimp only [q] + rw [pow_mul, ← mul_pow] + congr 1 + field_simp [hB'] + have hqTwoD : B ^ (2 * d) * q ^ (2 * d) = A ^ (2 * d) := by + have hB' : B ≠ 0 := by simpa [B] using hB + dsimp only [q] + rw [← mul_pow] + congr 1 + field_simp [hB'] + have hmiddle : + B ^ (2 * d) * (RatFunc.C alpha * q ^ (2 * d) + RatFunc.C beta) = + RatFunc.C alpha * A ^ (2 * d) + RatFunc.C beta * B ^ (2 * d) := by + calc + _ = RatFunc.C alpha * (B ^ (2 * d) * q ^ (2 * d)) + + RatFunc.C beta * B ^ (2 * d) := by ring + _ = _ := by rw [hqTwoD] + have hnegative : B ^ (2 * d) * (-q ^ d) = -(A * B) ^ d := by + rw [mul_neg, hqD] + calc + _ = C (B ^ (2 * d) * (-q ^ d)) * X ^ (2 * e) + + C (B ^ (2 * d) * + (RatFunc.C alpha * q ^ (2 * d) + RatFunc.C beta)) * X ^ e + + C (B ^ (2 * d) * (-q ^ d)) := by + dsimp [B] + simp only [map_add, map_sub, map_mul, map_pow, map_neg] + ring + _ = _ := by + rw [hnegative, hmiddle] + dsimp [A, B] + simp only [map_add, map_mul, map_pow, map_sub, map_neg] + ring + +/-- Irreducibility descends through the nonsplit Cayley model after any field extension of +the quadratic splitting field. This is the algebraic core used below with an algebraic +closure as the target field. -/ +theorem map_seededNonsplitDescendedPolynomial_irreducible_of_map_splitCover + {L : Type*} [Field L] (ι : E p →+* L) (s : (E p)ˣ) (d e : ℕ) + (hd : 0 < d) (he : 0 < e) + (hcover : Irreducible + (MvPolynomial.map ι + (splitTraceCoverPolynomial (s : E p) ((s : E p) ^ p) e d))) : + Irreducible + (MvPolynomial.map (ι.comp (algebraMap (F p) (E p))) + (seededNonsplitDescendedPolynomial p s d e)) := by + let alpha : L := ι (s : E p) + let beta : L := ι ((s : E p) ^ p) + let r : L := ι (quadraticNonbaseElement p ^ p) + let t : L := ι (quadraticNonbaseElement p) + have hsplit : + MvPolynomial.map ι + (splitTraceCoverPolynomial (s : E p) ((s : E p) ^ p) e d) = + splitTraceCoverPolynomial alpha beta e d := by + simp [splitTraceCoverPolynomial, alpha, beta] + have hq : Irreducible + (finTwoToIteratedPolynomial + (splitTraceCoverPolynomial alpha beta e d)) := by + have := hcover.map (finTwoToIteratedPolynomial (K := L)) + rwa [hsplit] at this + have hqPrimitive : + (finTwoToIteratedPolynomial + (splitTraceCoverPolynomial alpha beta e d)).IsPrimitive := by + apply hq.isPrimitive + rw [finTwoToIteratedPolynomial_splitTraceCoverPolynomial_general_natDegree + alpha beta e d he] + omega + have hqFraction : Irreducible + ((finTwoToIteratedPolynomial + (splitTraceCoverPolynomial alpha beta e d)).map + (algebraMap L[X] (RatFunc L))) := + hqPrimitive.irreducible_iff_irreducible_map_fraction_map.mp hq + have hrt : r ≠ t := by + exact ι.injective.ne (quadraticNonbaseElement_frobenius_ne_self p) + have hdet : (1 : L) * (-t) - (-r) * 1 ≠ 0 := by + rw [show (1 : L) * (-t) - (-r) * 1 = r - t by ring] + exact sub_ne_zero.mpr hrt + let phi := BGS.Algebra.ratFuncLinearFractionalEquiv + (1 : L) (-r) 1 (-t) hdet + have hqTransported : Irreducible + (((finTwoToIteratedPolynomial + (splitTraceCoverPolynomial alpha beta e d)).map + (algebraMap L[X] (RatFunc L))).map phi.toRingHom) := by + exact hqFraction.map (Polynomial.mapAlgEquiv phi) + let A : RatFunc L := RatFunc.X - RatFunc.C r + let B : RatFunc L := RatFunc.X - RatFunc.C t + let Q : Polynomial L := (X - C r) * (X - C t) + let N : Polynomial L := + C alpha * (X - C r) ^ (2 * d) + C beta * (X - C t) ^ (2 * d) + let R : Polynomial L[X] := + monomial (2 * e) (-(Q ^ d)) + monomial e N + C (-(Q ^ d)) + have hB : B ≠ 0 := by + dsimp [B, t] + simpa only [map_sub, RatFunc.algebraMap_X, RatFunc.algebraMap_C] using + RatFunc.algebraMap_ne_zero (X_sub_C_ne_zero (ι (quadraticNonbaseElement p))) + have hscale : IsUnit (C (B ^ (2 * d)) : Polynomial (RatFunc L)) := by + rw [Polynomial.isUnit_C] + exact isUnit_iff_ne_zero.mpr (pow_ne_zero _ hB) + have hRFraction : Irreducible (R.map (algebraMap L[X] (RatFunc L))) := by + rw [← cayleyTransport_splitIteratedPolynomial alpha beta r t e d hrt hdet] + exact (irreducible_isUnit_mul hscale).2 hqTransported + have hcoprime : IsCoprime Q N := by + have h := (extendedCayleyNormFactor_isCoprime_extendedSeededCayleyNumerator + p s d hd).map (Polynomial.mapRingHom ι) + simpa [Q, N, alpha, beta, r, t, extendedCayleyNormFactor, + extendedSeededCayleyNumerator, extendedCayleyNumeratorFactor, + extendedCayleyDenominatorFactor] using h + have hRPrimitive : R.IsPrimitive := by + have hcoprimePow : IsCoprime (Q ^ d) N := hcoprime.pow_left + have hprimitive := + descendedIteratedPolynomial_isPrimitive_of_isCoprime (Q ^ d) N e he hcoprimePow + simpa only [R] using hprimitive + have hR : Irreducible R := + hRPrimitive.irreducible_iff_irreducible_map_fraction_map.mpr hRFraction + have hdescendedIterated : + finTwoSecondToIteratedPolynomial + (MvPolynomial.map (ι.comp (algebraMap (F p) (E p))) + (seededNonsplitDescendedPolynomial p s d e)) = R := by + rw [← MvPolynomial.map_map] + rw [finTwoSecondToIteratedPolynomial_map] + rw [finTwoSecondToIteratedPolynomial_map_seededNonsplitDescendedPolynomial] + simp [R, Q, N, alpha, beta, r, t, extendedCayleyNormFactor, + extendedSeededCayleyNumerator, extendedCayleyNumeratorFactor, + extendedCayleyDenominatorFactor] + have hback := hR.map (finTwoSecondToIteratedPolynomial (K := L)).symm + simpa [← hdescendedIterated] using hback + +/-- Absolute irreducibility of the descended nonsplit trace curve follows from absolute +irreducibility of its split cover. The proof applies the split-cover premise over the +quadratic field's algebraic closure, performs the explicit Cayley descent there, and then +uses uniqueness of algebraic closures over the base field. -/ +theorem seededNonsplitDescendedPolynomial_absolutelyIrreducible_of_splitCover + (s : (E p)ˣ) (d e : ℕ) (hd : 0 < d) (he : 0 < e) + (hcover : Irreducible + (MvPolynomial.map + (algebraMap (E p) (AlgebraicClosure (E p))) + (splitTraceCoverPolynomial (s : E p) ((s : E p) ^ p) e d))) : + Irreducible + (MvPolynomial.map + (algebraMap (F p) (AlgebraicClosure (F p))) + (seededNonsplitDescendedPolynomial p s d e)) := by + let K := AlgebraicClosure (E p) + have hdescendedOverK : Irreducible + (MvPolynomial.map + ((algebraMap (E p) K).comp (algebraMap (F p) (E p))) + (seededNonsplitDescendedPolynomial p s d e)) := by + exact map_seededNonsplitDescendedPolynomial_irreducible_of_map_splitCover + p (algebraMap (E p) K) s d e hd he hcover + let closureEquiv : K ≃ₐ[F p] AlgebraicClosure (F p) := + IsAlgClosure.equivOfAlgebraic (F p) (E p) K (AlgebraicClosure (F p)) + have hmapped := hdescendedOverK.map + (MvPolynomial.mapAlgEquiv (Fin 2) closureEquiv) + have hcomp : + (closureEquiv : K →+* AlgebraicClosure (F p)).comp + ((algebraMap (E p) K).comp (algebraMap (F p) (E p))) = + algebraMap (F p) (AlgebraicClosure (F p)) := by + ext x + simp only [RingHom.comp_apply, ← IsScalarTower.algebraMap_apply] + exact closureEquiv.commutes x + have hmapped' : Irreducible + (MvPolynomial.map + ((closureEquiv : K →+* AlgebraicClosure (F p)).comp + ((algebraMap (E p) K).comp (algebraMap (F p) (E p)))) + (seededNonsplitDescendedPolynomial p s d e)) := by + simpa only [MvPolynomial.mapAlgEquiv_apply, MvPolynomial.map_map] using hmapped + rw [hcomp] at hmapped' + exact hmapped' + +end DescendedFormula + +end + + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Endgame/Nonsplit/DescendedTraceCurve.lean b/LeanPool/MarkoffModP/BGS/Markoff/Endgame/Nonsplit/DescendedTraceCurve.lean new file mode 100644 index 0000000000..da118adef6 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Endgame/Nonsplit/DescendedTraceCurve.lean @@ -0,0 +1,735 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Endgame.Nonsplit.CayleyParametrization +public import LeanPool.MarkoffModP.BGS.Markoff.Endgame.Nonsplit.SeededCover +public import LeanPool.MarkoffModP.BGS.Markoff.Endgame.WeilBoundAssumption +public import LeanPool.MarkoffModP.BGS.External.GeneralCurveTheorems +public import Mathlib.Algebra.Polynomial.Eval.Degree + +/-! +# The descended seeded nonsplit trace curve + +The Cayley coordinate converts the seeded nonsplit equation into one polynomial equation over +the base field. This file constructs that polynomial, proves the scalar-extension formula and +its bidegree bounds, and compares its base-field solutions exactly with the original torus +solutions. Absolute irreducibility is deliberately a theorem to be proved, not an assumption. +-/ + +@[expose] public section + +namespace BGS.Markoff + +noncomputable section + +variable (p : ℕ) [Fact p.Prime] + +local notation "F" => ZMod +local notation "E" => quadraticFiniteField + +noncomputable local instance : Fintype (E p) := Fintype.ofFinite (E p) +noncomputable local instance : DecidableEq (quadraticNormOneTorus p) := Classical.decEq _ + +/-- Apply the quadratic field trace coefficientwise to a polynomial. -/ +def quadraticCoefficientTracePolynomial (P : Polynomial (E p)) : Polynomial (F p) := + P.sum fun n c => Polynomial.monomial n (Algebra.trace (F p) (E p) c) + +@[simp] +theorem quadraticCoefficientTracePolynomial_coeff (P : Polynomial (E p)) (n : ℕ) : + (quadraticCoefficientTracePolynomial p P).coeff n = + Algebra.trace (F p) (E p) (P.coeff n) := by + classical + rw [quadraticCoefficientTracePolynomial, Polynomial.coeff_sum] + simp only [Polynomial.sum_def] + by_cases hn : n ∈ P.support + · rw [Finset.sum_eq_single n] + · simp + · intro b hb hbn + rw [Polynomial.coeff_monomial, ite_eq_right hbn] + · exact fun h => (h hn).elim + · rw [Finset.sum_eq_zero] + · rw [Polynomial.notMem_support_iff.mp hn, map_zero] + · intro b hb + rw [Polynomial.coeff_monomial] + exact ite_eq_right (fun h : b = n => hn (h ▸ hb)) + +/-- After scalar extension, coefficientwise trace is `P + Frobenius(P)`. -/ +theorem quadraticCoefficientTracePolynomial_map (P : Polynomial (E p)) : + (quadraticCoefficientTracePolynomial p P).map (algebraMap (F p) (E p)) = + P + P.map (_root_.frobenius (E p) p) := by + ext n + simp [algebraMap_quadraticTrace p, frobenius_def] + +/-- The linear Cayley factor whose zero is the Frobenius conjugate of the chosen nonbase +element. -/ +def quadraticCayleyConjugateFactorPolynomial : Polynomial (E p) := + Polynomial.X - Polynomial.C (quadraticNonbaseElement p ^ p) + +/-- The seed-dependent numerator before descent. -/ +def seededCayleyTraceNumeratorPolynomial + (s : (E p)ˣ) (d : ℕ) : Polynomial (F p) := + quadraticCoefficientTracePolynomial p + (Polynomial.C (s : E p) * quadraticCayleyConjugateFactorPolynomial p ^ (2 * d)) + +theorem seededCayleyTraceNumeratorPolynomial_map (s : (E p)ˣ) (d : ℕ) : + (seededCayleyTraceNumeratorPolynomial p s d).map (algebraMap (F p) (E p)) = + Polynomial.C (s : E p) * + (Polynomial.X - Polynomial.C (quadraticNonbaseElement p ^ p)) ^ (2 * d) + + Polynomial.C ((s : E p) ^ p) * + (Polynomial.X - Polynomial.C (quadraticNonbaseElement p)) ^ (2 * d) := by + rw [seededCayleyTraceNumeratorPolynomial, quadraticCoefficientTracePolynomial_map] + rw [quadraticCayleyConjugateFactorPolynomial] + rw [Polynomial.map_mul, Polynomial.map_C, Polynomial.map_pow, + Polynomial.map_sub, Polynomial.map_X, Polynomial.map_C] + change Polynomial.C (s : E p) * + (Polynomial.X - Polynomial.C (quadraticNonbaseElement p ^ p)) ^ (2 * d) + + Polynomial.C ((s : E p) ^ p) * + (Polynomial.X - Polynomial.C ((quadraticNonbaseElement p ^ p) ^ p)) ^ (2 * d) = _ + rw [quadraticNonbaseElement_frobenius_frobenius p] + +/-- The norm of the Cayley linear factor, written directly over the base field. -/ +def quadraticCayleyNormPolynomial : Polynomial (F p) := + Polynomial.X ^ 2 - + Polynomial.C (Algebra.trace (F p) (E p) (quadraticNonbaseElement p)) * Polynomial.X + + Polynomial.C (Algebra.norm (F p) (quadraticNonbaseElement p)) + +theorem quadraticCayleyNormPolynomial_map : + (quadraticCayleyNormPolynomial p).map (algebraMap (F p) (E p)) = + (Polynomial.X - Polynomial.C (quadraticNonbaseElement p ^ p)) * + (Polynomial.X - Polynomial.C (quadraticNonbaseElement p)) := by + rw [quadraticCayleyNormPolynomial, Polynomial.map_add, Polynomial.map_sub, + Polynomial.map_mul, Polynomial.map_pow, Polynomial.map_X, Polynomial.map_C, + Polynomial.map_C, algebraMap_quadraticTrace p, algebraMap_quadraticNorm p] + rw [Polynomial.C_add, Polynomial.C_mul] + ring + +theorem algebraMap_eval_seededCayleyTraceNumeratorPolynomial + (s : (E p)ˣ) (d : ℕ) (z : F p) : + algebraMap (F p) (E p) ((seededCayleyTraceNumeratorPolynomial p s d).eval z) = + (s : E p) * + (algebraMap (F p) (E p) z - quadraticNonbaseElement p ^ p) ^ (2 * d) + + (s : E p) ^ p * + (algebraMap (F p) (E p) z - quadraticNonbaseElement p) ^ (2 * d) := by + calc + algebraMap (F p) (E p) ((seededCayleyTraceNumeratorPolynomial p s d).eval z) = + ((seededCayleyTraceNumeratorPolynomial p s d).map + (algebraMap (F p) (E p))).eval (algebraMap (F p) (E p) z) := by + rw [← Polynomial.eval₂_eq_eval_map] + exact (Polynomial.eval₂_at_apply (algebraMap (F p) (E p)) z).symm + _ = _ := by rw [seededCayleyTraceNumeratorPolynomial_map]; simp + +theorem algebraMap_eval_quadraticCayleyNormPolynomial (z : F p) : + algebraMap (F p) (E p) ((quadraticCayleyNormPolynomial p).eval z) = + (algebraMap (F p) (E p) z - quadraticNonbaseElement p ^ p) * + (algebraMap (F p) (E p) z - quadraticNonbaseElement p) := by + calc + algebraMap (F p) (E p) ((quadraticCayleyNormPolynomial p).eval z) = + ((quadraticCayleyNormPolynomial p).map + (algebraMap (F p) (E p))).eval (algebraMap (F p) (E p) z) := by + rw [← Polynomial.eval₂_eq_eval_map] + exact (Polynomial.eval₂_at_apply (algebraMap (F p) (E p)) z).symm + _ = _ := by rw [quadraticCayleyNormPolynomial_map]; simp + +/-- Embed a univariate polynomial in the first coordinate of a bivariate polynomial. -/ +def univariateInFirstCoordinate {K : Type*} [CommSemiring K] + (P : Polynomial K) : MvPolynomial (Fin 2) K := + P.sum fun n c => MvPolynomial.C c * MvPolynomial.X 0 ^ n + +@[simp] +theorem eval_univariateInFirstCoordinate {K : Type*} [CommSemiring K] + (P : Polynomial K) (x y : K) : + MvPolynomial.eval ![x, y] (univariateInFirstCoordinate P) = P.eval x := by + classical + simp [univariateInFirstCoordinate, Polynomial.sum_def, Polynomial.eval_eq_sum] + +private theorem degreeOf_finset_sum_le {K ι : Type*} [CommSemiring K] + (coordinate : Fin 2) (terms : ι → MvPolynomial (Fin 2) K) + (indices : Finset ι) (bound : ℕ) + (hterms : ∀ i ∈ indices, MvPolynomial.degreeOf coordinate (terms i) ≤ bound) : + MvPolynomial.degreeOf coordinate (∑ i ∈ indices, terms i) ≤ bound := by + classical + induction indices using Finset.induction_on with + | empty => simp + | @insert i indices hi ih => + rw [Finset.sum_insert hi] + exact (MvPolynomial.degreeOf_add_le _ _ _).trans + (max_le (hterms i (Finset.mem_insert_self i indices)) + (ih fun j hj => hterms j (Finset.mem_insert_of_mem hj))) + +theorem univariateInFirstCoordinate_degreeOf_first_le + {K : Type*} [CommSemiring K] [Nontrivial K] (P : Polynomial K) : + MvPolynomial.degreeOf (0 : Fin 2) (univariateInFirstCoordinate P) ≤ P.natDegree := by + classical + rw [univariateInFirstCoordinate, Polynomial.sum_def] + apply degreeOf_finset_sum_le (0 : Fin 2) _ P.support P.natDegree + intro n hn + calc + MvPolynomial.degreeOf (0 : Fin 2) + (MvPolynomial.C (P.coeff n) * MvPolynomial.X 0 ^ n) ≤ + MvPolynomial.degreeOf (0 : Fin 2) (MvPolynomial.C (P.coeff n)) + + MvPolynomial.degreeOf (0 : Fin 2) (MvPolynomial.X 0 ^ n) := + MvPolynomial.degreeOf_mul_le _ _ _ + _ ≤ 0 + n := by + gcongr + · rw [MvPolynomial.degreeOf_C] + · calc + MvPolynomial.degreeOf (0 : Fin 2) + (MvPolynomial.X 0 ^ n : MvPolynomial (Fin 2) K) ≤ + n * MvPolynomial.degreeOf (0 : Fin 2) (MvPolynomial.X 0) := + MvPolynomial.degreeOf_pow_le _ _ _ + _ = n := by rw [MvPolynomial.degreeOf_X]; simp + _ ≤ P.natDegree := by simpa using Polynomial.le_natDegree_of_mem_supp n hn + +theorem univariateInFirstCoordinate_degreeOf_second_le + {K : Type*} [CommSemiring K] [Nontrivial K] (P : Polynomial K) : + MvPolynomial.degreeOf (1 : Fin 2) (univariateInFirstCoordinate P) ≤ 0 := by + classical + rw [univariateInFirstCoordinate, Polynomial.sum_def] + apply degreeOf_finset_sum_le (1 : Fin 2) _ P.support 0 + intro n hn + calc + MvPolynomial.degreeOf (1 : Fin 2) + (MvPolynomial.C (P.coeff n) * MvPolynomial.X 0 ^ n) ≤ + MvPolynomial.degreeOf (1 : Fin 2) (MvPolynomial.C (P.coeff n)) + + MvPolynomial.degreeOf (1 : Fin 2) (MvPolynomial.X 0 ^ n) := + MvPolynomial.degreeOf_mul_le _ _ _ + _ ≤ 0 := by + have hpow : MvPolynomial.degreeOf (1 : Fin 2) + (MvPolynomial.X 0 ^ n : MvPolynomial (Fin 2) K) ≤ 0 := by + calc + _ ≤ n * MvPolynomial.degreeOf (1 : Fin 2) (MvPolynomial.X 0) := + MvPolynomial.degreeOf_pow_le _ _ _ + _ = 0 := by rw [MvPolynomial.degreeOf_X]; norm_num + rw [MvPolynomial.degreeOf_C] + simpa using hpow + +private theorem natDegree_linearFactor_le_one {K : Type*} [Ring K] [Nontrivial K] (a : K) : + (Polynomial.X - Polynomial.C a).natDegree ≤ 1 := + (Polynomial.natDegree_sub_le _ _).trans (by simp) + +theorem seededCayleyTraceNumeratorPolynomial_natDegree_le + (s : (E p)ˣ) (d : ℕ) : + (seededCayleyTraceNumeratorPolynomial p s d).natDegree ≤ 2 * d := by + rw [← Polynomial.natDegree_map_eq_of_injective + (algebraMap (F p) (E p)).injective, + seededCayleyTraceNumeratorPolynomial_map] + refine (Polynomial.natDegree_add_le _ _).trans (max_le ?_ ?_) + · have hlinear := natDegree_linearFactor_le_one + (quadraticNonbaseElement p ^ p) + have hpow : ((Polynomial.X - Polynomial.C (quadraticNonbaseElement p ^ p)) ^ + (2 * d)).natDegree ≤ 2 * d := + Polynomial.natDegree_pow_le.trans (by + simpa using Nat.mul_le_mul_left (2 * d) hlinear) + exact Polynomial.natDegree_mul_le.trans (by simpa using hpow) + · have hlinear := natDegree_linearFactor_le_one (quadraticNonbaseElement p) + have hpow : ((Polynomial.X - Polynomial.C (quadraticNonbaseElement p)) ^ + (2 * d)).natDegree ≤ 2 * d := + Polynomial.natDegree_pow_le.trans (by + simpa using Nat.mul_le_mul_left (2 * d) hlinear) + exact Polynomial.natDegree_mul_le.trans (by simpa using hpow) + +theorem quadraticCayleyNormPolynomial_natDegree_le : + (quadraticCayleyNormPolynomial p).natDegree ≤ 2 := by + rw [← Polynomial.natDegree_map_eq_of_injective + (algebraMap (F p) (E p)).injective, + quadraticCayleyNormPolynomial_map] + calc + _ ≤ (Polynomial.X - Polynomial.C (quadraticNonbaseElement p ^ p)).natDegree + + (Polynomial.X - Polynomial.C (quadraticNonbaseElement p)).natDegree := + Polynomial.natDegree_mul_le + _ ≤ 2 := by + have hleft := natDegree_linearFactor_le_one (quadraticNonbaseElement p ^ p) + have hright := natDegree_linearFactor_le_one (quadraticNonbaseElement p) + omega + +/-- The explicit bivariate polynomial over `ZMod p` defining the descended seeded nonsplit +cover. Coordinate `0` is the Cayley affine coordinate and coordinate `1` is the base-field +unit parameter. -/ +def seededNonsplitDescendedPolynomial (s : (E p)ˣ) (d e : ℕ) : + MvPolynomial (Fin 2) (F p) := + univariateInFirstCoordinate (seededCayleyTraceNumeratorPolynomial p s d) * + MvPolynomial.X 1 ^ e - + univariateInFirstCoordinate (quadraticCayleyNormPolynomial p) ^ d * + (MvPolynomial.X 1 ^ (2 * e) + 1) + +theorem eval_seededNonsplitDescendedPolynomial + (s : (E p)ˣ) (d e : ℕ) (z u : F p) : + MvPolynomial.eval ![z, u] (seededNonsplitDescendedPolynomial p s d e) = + (seededCayleyTraceNumeratorPolynomial p s d).eval z * u ^ e - + (quadraticCayleyNormPolynomial p).eval z ^ d * (u ^ (2 * e) + 1) := by + simp [seededNonsplitDescendedPolynomial] + +private theorem degreeOf_first_X_one_pow_le {K : Type*} [CommSemiring K] + [Nontrivial K] (n : ℕ) : + MvPolynomial.degreeOf (0 : Fin 2) + (MvPolynomial.X 1 ^ n : MvPolynomial (Fin 2) K) ≤ 0 := by + calc + _ ≤ n * MvPolynomial.degreeOf (0 : Fin 2) (MvPolynomial.X 1) := + MvPolynomial.degreeOf_pow_le _ _ _ + _ = 0 := by rw [MvPolynomial.degreeOf_X]; norm_num + +private theorem degreeOf_second_X_one_pow_le {K : Type*} [CommSemiring K] + [Nontrivial K] (n : ℕ) : + MvPolynomial.degreeOf (1 : Fin 2) + (MvPolynomial.X 1 ^ n : MvPolynomial (Fin 2) K) ≤ n := by + calc + _ ≤ n * MvPolynomial.degreeOf (1 : Fin 2) (MvPolynomial.X 1) := + MvPolynomial.degreeOf_pow_le _ _ _ + _ = n := by rw [MvPolynomial.degreeOf_X]; norm_num + +theorem seededNonsplitDescendedPolynomial_degreeOf_first_le + (s : (E p)ˣ) (d e : ℕ) : + MvPolynomial.degreeOf (0 : Fin 2) (seededNonsplitDescendedPolynomial p s d e) ≤ + 2 * d := by + rw [seededNonsplitDescendedPolynomial] + refine (MvPolynomial.degreeOf_sub_le _ _ _).trans (max_le ?_ ?_) + · refine (MvPolynomial.degreeOf_mul_le _ _ _).trans ?_ + have hnum := (univariateInFirstCoordinate_degreeOf_first_le + (seededCayleyTraceNumeratorPolynomial p s d)).trans + (seededCayleyTraceNumeratorPolynomial_natDegree_le p s d) + have hu := degreeOf_first_X_one_pow_le (K := F p) e + omega + · refine (MvPolynomial.degreeOf_mul_le _ _ _).trans ?_ + have hnormBase := (univariateInFirstCoordinate_degreeOf_first_le + (quadraticCayleyNormPolynomial p)).trans + (quadraticCayleyNormPolynomial_natDegree_le p) + have hnormPow := (MvPolynomial.degreeOf_pow_le (0 : Fin 2) + (univariateInFirstCoordinate (quadraticCayleyNormPolynomial p)) d).trans + (Nat.mul_le_mul_left d hnormBase) + have hsum := (MvPolynomial.degreeOf_add_le (0 : Fin 2) + (MvPolynomial.X 1 ^ (2 * e) : MvPolynomial (Fin 2) (F p)) 1).trans + (max_le (degreeOf_first_X_one_pow_le (K := F p) (2 * e)) (by simp)) + omega + +theorem seededNonsplitDescendedPolynomial_degreeOf_second_le + (s : (E p)ˣ) (d e : ℕ) : + MvPolynomial.degreeOf (1 : Fin 2) (seededNonsplitDescendedPolynomial p s d e) ≤ + 2 * e := by + rw [seededNonsplitDescendedPolynomial] + refine (MvPolynomial.degreeOf_sub_le _ _ _).trans (max_le ?_ ?_) + · refine (MvPolynomial.degreeOf_mul_le _ _ _).trans ?_ + have hnum := univariateInFirstCoordinate_degreeOf_second_le + (seededCayleyTraceNumeratorPolynomial p s d) + have hu := degreeOf_second_X_one_pow_le (K := F p) e + omega + · refine (MvPolynomial.degreeOf_mul_le _ _ _).trans ?_ + have hnormBase := univariateInFirstCoordinate_degreeOf_second_le + (quadraticCayleyNormPolynomial p) + have hnormPow := (MvPolynomial.degreeOf_pow_le (1 : Fin 2) + (univariateInFirstCoordinate (quadraticCayleyNormPolynomial p)) d).trans + (Nat.mul_le_mul_left d hnormBase) + have hsum := (MvPolynomial.degreeOf_add_le (1 : Fin 2) + (MvPolynomial.X 1 ^ (2 * e) : MvPolynomial (Fin 2) (F p)) 1).trans + (max_le (degreeOf_second_X_one_pow_le (K := F p) (2 * e)) (by simp)) + omega + +theorem seededNonsplitDescendedPolynomial_hasBidegreeAtMost + (s : (E p)ˣ) (d e : ℕ) : + BGS.External.HasBidegreeAtMost + (seededNonsplitDescendedPolynomial p s d e) (2 * d) (2 * e) := by + intro monomial hmonomial + exact ⟨ + (MvPolynomial.degreeOf_le_iff.mp + (seededNonsplitDescendedPolynomial_degreeOf_first_le p s d e)) monomial hmonomial, + (MvPolynomial.degreeOf_le_iff.mp + (seededNonsplitDescendedPolynomial_degreeOf_second_le p s d e)) monomial hmonomial⟩ + +private theorem clearedSeededFractionEquation_iff + {K : Type*} [Field K] (seed conjugateSeed X Y V : K) + (hX : X ≠ 0) (hY : Y ≠ 0) (hV : V ≠ 0) : + (seed * X ^ 2 + conjugateSeed * Y ^ 2) * V - X * Y * (V ^ 2 + 1) = 0 ↔ + seed * (X / Y) + conjugateSeed * (X / Y)⁻¹ = V + V⁻¹ := by + field_simp [hX, hY, hV] + constructor <;> intro h <;> linear_combination h + +private theorem clearedSeededCayleyEquation_iff + {K : Type*} [Field K] (seed conjugateSeed A B u : K) (d e : ℕ) + (hA : A ≠ 0) (hB : B ≠ 0) (hu : u ≠ 0) : + (seed * A ^ (2 * d) + conjugateSeed * B ^ (2 * d)) * u ^ e - + (A * B) ^ d * (u ^ (2 * e) + 1) = 0 ↔ + seed * (A / B) ^ d + conjugateSeed * ((A / B) ^ d)⁻¹ = + u ^ e + (u ^ e)⁻¹ := by + rw [Nat.mul_comm 2 d, pow_mul, pow_mul, Nat.mul_comm 2 e, pow_mul, + div_pow, mul_pow] + exact clearedSeededFractionEquation_iff seed conjugateSeed (A ^ d) (B ^ d) (u ^ e) + (pow_ne_zero d hA) (pow_ne_zero d hB) (pow_ne_zero e hu) + +/-- Vanishing of the descended base-field polynomial is exactly the seeded nonsplit trace +equation at the Cayley point. -/ +theorem eval_seededNonsplitDescendedPolynomial_eq_zero_iff + (k : (F p)ˣ) (s : ↑(quadraticNormFiber p k)) (d e : ℕ) + (z : F p) (u : (F p)ˣ) : + MvPolynomial.eval ![z, (u : F p)] + (seededNonsplitDescendedPolynomial p s.1 d e) = 0 ↔ + SeededNonsplitTraceCoverEquation p k s d e (quadraticCayleyPoint p z) u := by + rw [eval_seededNonsplitDescendedPolynomial] + rw [seededNonsplitTraceCoverEquation_iff_weightedSplitTraceCover] + have hmapZero : + (seededCayleyTraceNumeratorPolynomial p s.1 d).eval z * (u : F p) ^ e - + (quadraticCayleyNormPolynomial p).eval z ^ d * ((u : F p) ^ (2 * e) + 1) = 0 ↔ + algebraMap (F p) (E p) + ((seededCayleyTraceNumeratorPolynomial p s.1 d).eval z * (u : F p) ^ e - + (quadraticCayleyNormPolynomial p).eval z ^ d * + ((u : F p) ^ (2 * e) + 1)) = 0 := by + constructor + · intro h; rw [h, map_zero] + · intro h; exact (algebraMap (F p) (E p)).injective (by simpa using h) + rw [hmapZero] + simp only [map_sub, map_mul, map_pow, map_add, map_one] + rw [algebraMap_eval_seededCayleyTraceNumeratorPolynomial, + algebraMap_eval_quadraticCayleyNormPolynomial] + unfold SplitTraceCurveEquation weightedSplitTorusTrace splitTorusTrace + change + (((s.1 : E p) * + (algebraMap (F p) (E p) z - quadraticNonbaseElement p ^ p) ^ (2 * d) + + (s.1 : E p) ^ p * + (algebraMap (F p) (E p) z - quadraticNonbaseElement p) ^ (2 * d)) * + algebraMap (F p) (E p) (u : F p) ^ e - + ((algebraMap (F p) (E p) z - quadraticNonbaseElement p ^ p) * + (algebraMap (F p) (E p) z - quadraticNonbaseElement p)) ^ d * + (algebraMap (F p) (E p) (u : F p) ^ (2 * e) + 1) = 0) ↔ _ + have hA : algebraMap (F p) (E p) z - quadraticNonbaseElement p ^ p ≠ 0 := by + rw [sub_ne_zero] + exact fun h => quadraticNonbaseElement_frobenius_not_mem_range p ⟨z, h⟩ + have hB : algebraMap (F p) (E p) z - quadraticNonbaseElement p ≠ 0 := by + rw [sub_ne_zero] + exact fun h => quadraticNonbaseElement_not_mem_range p ⟨z, h⟩ + have hu : algebraMap (F p) (E p) (u : F p) ≠ 0 := + (map_ne_zero (algebraMap (F p) (E p))).mpr (Units.ne_zero u) + rw [clearedSeededCayleyEquation_iff _ _ _ _ _ d e + hA hB hu] + simp only [seededBaseUnitInQuadraticField, quadraticCayleyPoint, + quadraticCayleyUnit, Units.val_mk0, Units.val_pow_eq_pow_val, + Units.val_inv_eq_inv_val] + rfl + +/-- Base-field solutions of the descended affine equation with the second coordinate restricted +to a unit. -/ +def seededNonsplitDescendedSolutions + (s : (E p)ˣ) (d e : ℕ) : Finset (F p × (F p)ˣ) := by + classical + exact Finset.univ.filter fun z => + MvPolynomial.eval ![z.1, (z.2 : F p)] + (seededNonsplitDescendedPolynomial p s d e) = 0 + +@[simp] +theorem mem_seededNonsplitDescendedSolutions_iff + (s : (E p)ˣ) (d e : ℕ) (z : F p × (F p)ˣ) : + z ∈ seededNonsplitDescendedSolutions p s d e ↔ + MvPolynomial.eval ![z.1, (z.2 : F p)] + (seededNonsplitDescendedPolynomial p s d e) = 0 := by + classical + simp [seededNonsplitDescendedSolutions] + +/-- Seeded nonsplit solutions with the identity point removed from the norm-one torus. -/ +def seededNonsplitNonidentitySolutions + (k : (F p)ˣ) (s : ↑(quadraticNormFiber p k)) (d e : ℕ) : + Finset ({w : quadraticNormOneTorus p // w ≠ 1} × (F p)ˣ) := by + classical + exact Finset.univ.filter fun z => + SeededNonsplitTraceCoverEquation p k s d e z.1.1 z.2 + +@[simp] +theorem mem_seededNonsplitNonidentitySolutions_iff + (k : (F p)ˣ) (s : ↑(quadraticNormFiber p k)) (d e : ℕ) + (z : {w : quadraticNormOneTorus p // w ≠ 1} × (F p)ˣ) : + z ∈ seededNonsplitNonidentitySolutions p k s d e ↔ + SeededNonsplitTraceCoverEquation p k s d e z.1.1 z.2 := by + classical + simp [seededNonsplitNonidentitySolutions] + +/-- Cayley parametrization gives an exact bijection, with no multiplicity, between descended +solutions and nonidentity torus solutions. -/ +theorem seededNonsplitDescendedSolutions_card_eq_nonidentity_card + (k : (F p)ˣ) (s : ↑(quadraticNormFiber p k)) (d e : ℕ) : + (seededNonsplitDescendedSolutions p s.1 d e).card = + (seededNonsplitNonidentitySolutions p k s d e).card := by + classical + apply Finset.card_bij' + (fun z _ => ((quadraticCayleyParameterEquiv p z.1), z.2)) + (fun z _ => ((quadraticCayleyParameterEquiv p).symm z.1, z.2)) + · intro z hz + rw [mem_seededNonsplitNonidentitySolutions_iff] + change SeededNonsplitTraceCoverEquation p k s d e + (quadraticCayleyPoint p z.1) z.2 + rw [← eval_seededNonsplitDescendedPolynomial_eq_zero_iff p k s d e z.1 z.2] + exact (mem_seededNonsplitDescendedSolutions_iff p s.1 d e z).mp hz + · intro z hz + apply Prod.ext + · exact (quadraticCayleyParameterEquiv p).symm_apply_apply z.1 + · rfl + · intro z hz + apply Prod.ext + · exact (quadraticCayleyParameterEquiv p).apply_symm_apply z.1 + · rfl + · intro z hz + rw [mem_seededNonsplitDescendedSolutions_iff] + rw [eval_seededNonsplitDescendedPolynomial_eq_zero_iff p k s d e] + have hzEquation := (mem_seededNonsplitNonidentitySolutions_iff p k s d e z).mp hz + have hpoint := congrArg Subtype.val + ((quadraticCayleyParameterEquiv p).apply_symm_apply z.1) + change quadraticCayleyPoint p ((quadraticCayleyParameterEquiv p).symm z.1) = z.1.1 at hpoint + rw [hpoint] + exact hzEquation + +theorem quadraticCayleyNormPolynomial_eval_ne_zero (z : F p) : + (quadraticCayleyNormPolynomial p).eval z ≠ 0 := by + intro hzero + have hmapped := congrArg (algebraMap (F p) (E p)) hzero + rw [map_zero, algebraMap_eval_quadraticCayleyNormPolynomial] at hmapped + have hleft : algebraMap (F p) (E p) z - quadraticNonbaseElement p ^ p ≠ 0 := by + rw [sub_ne_zero] + exact fun h => quadraticNonbaseElement_frobenius_not_mem_range p ⟨z, h⟩ + have hright : algebraMap (F p) (E p) z - quadraticNonbaseElement p ≠ 0 := by + rw [sub_ne_zero] + exact fun h => quadraticNonbaseElement_not_mem_range p ⟨z, h⟩ + exact (mul_ne_zero hleft hright) hmapped + +/-- For positive exponents the descended plane curve has no affine zero with second coordinate +zero. Thus the affine Hasse--Weil count introduces no hidden `u = 0` boundary. -/ +theorem eval_seededNonsplitDescendedPolynomial_zero_second_ne_zero + (s : (E p)ˣ) (d e : ℕ) (hd : 0 < d) (he : 0 < e) (z : F p) : + MvPolynomial.eval ![z, (0 : F p)] + (seededNonsplitDescendedPolynomial p s d e) ≠ 0 := by + rw [eval_seededNonsplitDescendedPolynomial] + have he0 : e ≠ 0 := Nat.ne_of_gt he + have htwoe0 : 2 * e ≠ 0 := by omega + rw [zero_pow he0, zero_pow htwoe0] + simp only [mul_zero, zero_add, add_zero, mul_one, zero_sub, neg_ne_zero] + exact pow_ne_zero d (quadraticCayleyNormPolynomial_eval_ne_zero p z) + +private theorem affineDescendedZero_second_ne_zero + (s : (E p)ˣ) (d e : ℕ) (hd : 0 < d) (he : 0 < e) + (z : F p × F p) + (hz : z ∈ BGS.External.affinePlaneCurveZeros (F p) + (seededNonsplitDescendedPolynomial p s d e)) : z.2 ≠ 0 := by + intro hzero + have hzEval := (BGS.External.mem_affinePlaneCurveZeros_iff).mp hz + rw [hzero] at hzEval + exact eval_seededNonsplitDescendedPolynomial_zero_second_ne_zero + p s d e hd he z.1 hzEval + +/-- The general affine-plane zero set and the unit-restricted descended set have exactly the +same cardinality for positive exponents. -/ +theorem affinePlaneCurveZeros_seededNonsplitDescendedPolynomial_card_eq + (s : (E p)ˣ) (d e : ℕ) (hd : 0 < d) (he : 0 < e) : + (BGS.External.affinePlaneCurveZeros (F p) + (seededNonsplitDescendedPolynomial p s d e)).card = + (seededNonsplitDescendedSolutions p s d e).card := by + classical + apply Finset.card_bij' + (fun z hz => (z.1, Units.mk0 z.2 + (affineDescendedZero_second_ne_zero p s d e hd he z hz))) + (fun z _ => (z.1, (z.2 : F p))) + · intro z hz + rw [mem_seededNonsplitDescendedSolutions_iff] + exact (BGS.External.mem_affinePlaneCurveZeros_iff).mp hz + · intro z hz + apply Prod.ext <;> rfl + · intro z hz + apply Prod.ext + · rfl + · apply Units.ext; rfl + · intro z hz + rw [BGS.External.mem_affinePlaneCurveZeros_iff] + exact (mem_seededNonsplitDescendedSolutions_iff p s d e z).mp hz + +/-- All seeded nonsplit torus solutions, including the identity point. -/ +def seededNonsplitTraceCurveSolutions + (k : (F p)ˣ) (s : ↑(quadraticNormFiber p k)) (d e : ℕ) : + Finset (quadraticNormOneTorus p × (F p)ˣ) := by + classical + exact Finset.univ.filter fun z => + SeededNonsplitTraceCoverEquation p k s d e z.1 z.2 + +@[simp] +theorem mem_seededNonsplitTraceCurveSolutions_iff + (k : (F p)ˣ) (s : ↑(quadraticNormFiber p k)) (d e : ℕ) + (z : quadraticNormOneTorus p × (F p)ˣ) : + z ∈ seededNonsplitTraceCurveSolutions p k s d e ↔ + SeededNonsplitTraceCoverEquation p k s d e z.1 z.2 := by + classical + simp [seededNonsplitTraceCurveSolutions] + +/-- The precise omitted Cayley boundary: solutions lying above the identity of the norm-one +torus. -/ +def seededNonsplitIdentityBoundarySolutions + (k : (F p)ˣ) (s : ↑(quadraticNormFiber p k)) (d e : ℕ) : Finset (F p)ˣ := by + classical + exact Finset.univ.filter fun u => + SeededNonsplitTraceCoverEquation p k s d e 1 u + +@[simp] +theorem mem_seededNonsplitIdentityBoundarySolutions_iff + (k : (F p)ˣ) (s : ↑(quadraticNormFiber p k)) (d e : ℕ) (u : (F p)ˣ) : + u ∈ seededNonsplitIdentityBoundarySolutions p k s d e ↔ + SeededNonsplitTraceCoverEquation p k s d e 1 u := by + classical + simp [seededNonsplitIdentityBoundarySolutions] + +private theorem nonidentityFilter_card_eq + (k : (F p)ˣ) (s : ↑(quadraticNormFiber p k)) (d e : ℕ) : + ((seededNonsplitTraceCurveSolutions p k s d e).filter fun z => z.1 ≠ 1).card = + (seededNonsplitNonidentitySolutions p k s d e).card := by + classical + apply Finset.card_bij' + (fun z hz => (⟨z.1, (Finset.mem_filter.mp hz).2⟩, z.2)) + (fun z _ => (z.1.1, z.2)) + · intro z hz + apply Prod.ext <;> rfl + · intro z hz + apply Prod.ext + · apply Subtype.ext; rfl + · rfl + · intro z hz + rw [mem_seededNonsplitNonidentitySolutions_iff] + exact (mem_seededNonsplitTraceCurveSolutions_iff p k s d e z).mp + (Finset.mem_filter.mp hz).1 + · intro z hz + rw [Finset.mem_filter] + exact ⟨(mem_seededNonsplitTraceCurveSolutions_iff p k s d e _).mpr + ((mem_seededNonsplitNonidentitySolutions_iff p k s d e z).mp hz), z.1.2⟩ + +private theorem identityFilter_card_eq + (k : (F p)ˣ) (s : ↑(quadraticNormFiber p k)) (d e : ℕ) : + ((seededNonsplitTraceCurveSolutions p k s d e).filter fun z => ¬ z.1 ≠ 1).card = + (seededNonsplitIdentityBoundarySolutions p k s d e).card := by + classical + apply Finset.card_bij' + (fun z _ => z.2) + (fun u _ => (1, u)) + · intro z hz + have hzMem := Finset.mem_filter.mp hz + apply Prod.ext + · exact (not_ne_iff.mp (Finset.mem_filter.mp hz).2).symm + · rfl + · intro u hu + rfl + · intro z hz + rw [mem_seededNonsplitIdentityBoundarySolutions_iff] + have hzMem := Finset.mem_filter.mp hz + have hone : z.1 = 1 := not_ne_iff.mp hzMem.2 + simpa [hone] using + (mem_seededNonsplitTraceCurveSolutions_iff p k s d e z).mp hzMem.1 + · intro u hu + rw [Finset.mem_filter] + exact ⟨(mem_seededNonsplitTraceCurveSolutions_iff p k s d e _).mpr + ((mem_seededNonsplitIdentityBoundarySolutions_iff p k s d e u).mp hu), by simp⟩ + +/-- Exact count comparison, including the unique missing Cayley chart fiber `w = 1`. -/ +theorem seededNonsplitTraceCurveSolutions_card_eq_descended_add_identityBoundary + (k : (F p)ˣ) (s : ↑(quadraticNormFiber p k)) (d e : ℕ) : + (seededNonsplitTraceCurveSolutions p k s d e).card = + (seededNonsplitDescendedSolutions p s.1 d e).card + + (seededNonsplitIdentityBoundarySolutions p k s d e).card := by + classical + have hsplit := Finset.card_filter_add_card_filter_not + (s := seededNonsplitTraceCurveSolutions p k s d e) (fun z => z.1 ≠ 1) + rw [nonidentityFilter_card_eq p k s d e, + ← seededNonsplitDescendedSolutions_card_eq_nonidentity_card p k s d e, + identityFilter_card_eq p k s d e] at hsplit + exact hsplit.symm + +/-- The one-variable polynomial cutting out the identity Cayley boundary. -/ +def seededNonsplitIdentityBoundaryPolynomial + (s : E p) (e : ℕ) : Polynomial (F p) := + Polynomial.X ^ (2 * e) - + Polynomial.C (Algebra.trace (F p) (E p) s) * Polynomial.X ^ e + 1 + +theorem seededNonsplitIdentityBoundaryEquation_iff + (k : (F p)ˣ) (s : ↑(quadraticNormFiber p k)) (d e : ℕ) (u : (F p)ˣ) : + SeededNonsplitTraceCoverEquation p k s d e 1 u ↔ + (seededNonsplitIdentityBoundaryPolynomial p (s.1 : E p) e).eval (u : F p) = 0 := by + unfold SeededNonsplitTraceCoverEquation seededNonsplitIdentityBoundaryPolynomial + simp only [one_pow, Subgroup.coe_one, Units.val_one, mul_one, splitTorusTrace, + Units.val_pow_eq_pow_val, Units.val_inv_eq_inv_val, Polynomial.eval_add, + Polynomial.eval_sub, Polynomial.eval_mul, Polynomial.eval_pow, Polynomial.eval_X, + Polynomial.eval_C, Polynomial.eval_one] + rw [Nat.mul_comm 2 e, pow_mul] + constructor + · intro h + field_simp [Units.ne_zero u] at h + linear_combination -h + · intro h + field_simp [Units.ne_zero u] + linear_combination -h + +theorem seededNonsplitIdentityBoundaryPolynomial_ne_zero + (s : E p) (e : ℕ) (he : 0 < e) : + seededNonsplitIdentityBoundaryPolynomial p s e ≠ 0 := by + intro hzero + have hcoeff := congrArg (fun P : Polynomial (F p) => P.coeff 0) hzero + have he0 : e ≠ 0 := Nat.ne_of_gt he + have h0e : 0 ≠ e := he0.symm + have htwoe0 : 2 * e ≠ 0 := by omega + have h0twoe : 0 ≠ 2 * e := htwoe0.symm + simp [seededNonsplitIdentityBoundaryPolynomial, he0, h0e, htwoe0, h0twoe] at hcoeff + +theorem seededNonsplitIdentityBoundaryPolynomial_natDegree_le + (s : E p) (e : ℕ) : + (seededNonsplitIdentityBoundaryPolynomial p s e).natDegree ≤ 2 * e := by + unfold seededNonsplitIdentityBoundaryPolynomial + refine (Polynomial.natDegree_add_le _ _).trans (max_le ?_ (by simp)) + refine (Polynomial.natDegree_sub_le _ _).trans (max_le (by simp) ?_) + exact Polynomial.natDegree_mul_le.trans (by simp; omega) + +/-- The omitted identity fiber contributes at most `2e` points. -/ +theorem seededNonsplitIdentityBoundarySolutions_card_le + (k : (F p)ˣ) (s : ↑(quadraticNormFiber p k)) (d e : ℕ) (he : 0 < e) : + (seededNonsplitIdentityBoundarySolutions p k s d e).card ≤ 2 * e := by + classical + let P := seededNonsplitIdentityBoundaryPolynomial p (s.1 : E p) e + have hP : P ≠ 0 := seededNonsplitIdentityBoundaryPolynomial_ne_zero p _ e he + have hmaps : Set.MapsTo (fun u : (F p)ˣ => (u : F p)) + ↑(seededNonsplitIdentityBoundarySolutions p k s d e) ↑P.roots.toFinset := by + intro u hu + change (u : F p) ∈ P.roots.toFinset + rw [Multiset.mem_toFinset, Polynomial.mem_roots hP] + exact (seededNonsplitIdentityBoundaryEquation_iff p k s d e u).mp + ((mem_seededNonsplitIdentityBoundarySolutions_iff p k s d e u).mp hu) + have hinj : Set.InjOn (fun u : (F p)ˣ => (u : F p)) + ↑(seededNonsplitIdentityBoundarySolutions p k s d e) := by + intro u hu v hv huv + exact Units.ext huv + calc + _ ≤ P.roots.toFinset.card := Finset.card_le_card_of_injOn _ hmaps hinj + _ ≤ P.roots.card := Multiset.toFinset_card_le _ + _ ≤ P.natDegree := Polynomial.card_roots' P + _ ≤ 2 * e := seededNonsplitIdentityBoundaryPolynomial_natDegree_le p _ e + +/-- The generic seeded solution set is definitionally the existing-conic solution set after +specializing its norm-fiber index. -/ +theorem existingConicSeedNonsplitTraceCurveSolutions_eq_seeded + (t : F p) (ht : t ^ 2 ≠ 4) (ht0 : t ≠ 0) + (s : ↑(quadraticConicNormFiber p t ht ht0)) (d e : ℕ) : + existingConicSeedNonsplitTraceCurveSolutions p t ht ht0 s d e = + seededNonsplitTraceCurveSolutions p + (quadraticFiberProductUnit p t ht ht0) s d e := by + ext z + rw [mem_existingConicSeedNonsplitTraceCurveSolutions_iff] + erw [mem_seededNonsplitTraceCurveSolutions_iff] + rfl + +/-- Exact existing-conic count comparison with both affine boundaries exposed: `u = 0` +contributes nothing for positive exponents, while `w = 1` is the displayed boundary term. -/ +theorem existingConicSeedNonsplitTraceCurveSolutions_card_eq_affine_add_identityBoundary + (t : F p) (ht : t ^ 2 ≠ 4) (ht0 : t ≠ 0) + (s : ↑(quadraticConicNormFiber p t ht ht0)) (d e : ℕ) + (hd : 0 < d) (he : 0 < e) : + (existingConicSeedNonsplitTraceCurveSolutions p t ht ht0 s d e).card = + (BGS.External.affinePlaneCurveZeros (F p) + (seededNonsplitDescendedPolynomial p s.1 d e)).card + + (seededNonsplitIdentityBoundarySolutions p + (quadraticFiberProductUnit p t ht ht0) s d e).card := by + rw [existingConicSeedNonsplitTraceCurveSolutions_eq_seeded] + erw [seededNonsplitTraceCurveSolutions_card_eq_descended_add_identityBoundary] + rw [← affinePlaneCurveZeros_seededNonsplitDescendedPolynomial_card_eq p s.1 d e hd he] + +end + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Endgame/Nonsplit/HasseFromGeneral.lean b/LeanPool/MarkoffModP/BGS/Markoff/Endgame/Nonsplit/HasseFromGeneral.lean new file mode 100644 index 0000000000..ecd87afc86 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Endgame/Nonsplit/HasseFromGeneral.lean @@ -0,0 +1,113 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Endgame.Nonsplit.DescendedIrreducibility +public import LeanPool.MarkoffModP.BGS.Markoff.Endgame.WeilBoundAssumption + +/-! +# The nonsplit endgame estimate from the general affine Hasse--Weil theorem + +This file applies the single permitted general Hasse--Weil input to the explicit descended +plane curve. The identity point omitted by the Cayley chart is kept visible and bounded +separately; it is not folded into a specialized estimate assumption. +-/ + +@[expose] public section + +namespace BGS.Markoff + +noncomputable section + +/-- A fixed-coefficient affine Hasse--Weil bound supplies the correspondingly +fixed seeded nonsplit estimate. The coefficient `4*C + 2` records the +`(2d,2e)` bidegree and the at-most `2e` Cayley-chart boundary. -/ +theorem seededNonsplitTraceWeilBoundAssumption_of_bivariateAffineHasseWeilBound + (generalCoefficient : ℕ) + (hgeneral : BGS.External.BivariateAffineHasseWeilBound generalCoefficient) : + SeededNonsplitTraceWeilBoundAssumption (4 * generalCoefficient + 2) := by + let coefficient := 4 * generalCoefficient + 2 + change SeededNonsplitTraceWeilBoundAssumption coefficient + refine ⟨by dsimp [coefficient]; omega, ?_⟩ + intro p _ hpTwo t ht ht0 s d e hd he hirreducible + have hDescendedIrreducible := + seededNonsplitDescendedPolynomial_absolutelyIrreducible_of_splitCover + p s.1 d e hd he hirreducible + have hAffine := hgeneral (ZMod p) + (seededNonsplitDescendedPolynomial p s.1 d e) + (2 * d) (2 * e) (by omega) (by omega) + (seededNonsplitDescendedPolynomial_hasBidegreeAtMost p s.1 d e) + hDescendedIrreducible + have hCardNat := + existingConicSeedNonsplitTraceCurveSolutions_card_eq_affine_add_identityBoundary + p t ht ht0 s d e hd he + have hBoundaryNat := seededNonsplitIdentityBoundarySolutions_card_le p + (quadraticFiberProductUnit p t ht ht0) s d e he + let affineCard := + (BGS.External.affinePlaneCurveZeros (ZMod p) + (seededNonsplitDescendedPolynomial p s.1 d e)).card + let boundaryCard := + (seededNonsplitIdentityBoundarySolutions p + (quadraticFiberProductUnit p t ht ht0) s d e).card + let x : ℝ := Real.sqrt (p : ℝ) * (d : ℝ) * (e : ℝ) + have hCardReal : + ((existingConicSeedNonsplitTraceCurveSolutions + p t ht ht0 s d e).card : ℝ) = affineCard + boundaryCard := by + dsimp only [affineCard, boundaryCard] + exact_mod_cast hCardNat + have hBoundaryReal : (boundaryCard : ℝ) ≤ 2 * (e : ℝ) := by + exact_mod_cast hBoundaryNat + have hpOneNat : 1 ≤ p := (Fact.out : p.Prime).one_le + have hsqrtOne : (1 : ℝ) ≤ Real.sqrt (p : ℝ) := by + exact Real.one_le_sqrt.mpr (by exact_mod_cast hpOneNat) + have hdOne : (1 : ℝ) ≤ d := by exact_mod_cast hd + have heNonnegative : (0 : ℝ) ≤ e := by positivity + have hBoundaryAbsorb : (boundaryCard : ℝ) ≤ 2 * x := by + have hscaleOne : (1 : ℝ) ≤ Real.sqrt (p : ℝ) * (d : ℝ) := by + nlinarith + have heScale : (e : ℝ) ≤ + (Real.sqrt (p : ℝ) * (d : ℝ)) * (e : ℝ) := by + simpa only [one_mul] using + mul_le_mul_of_nonneg_right hscaleOne heNonnegative + calc + (boundaryCard : ℝ) ≤ 2 * (e : ℝ) := hBoundaryReal + _ ≤ 2 * (Real.sqrt (p : ℝ) * (d : ℝ) * (e : ℝ)) := by gcongr + _ = 2 * x := by rfl + have hAffine' : + |(affineCard : ℝ) - (p : ℝ)| ≤ + 4 * (generalCoefficient : ℝ) * x := by + dsimp only [affineCard] + rw [ZMod.card] at hAffine + norm_num only [Nat.cast_mul, Nat.cast_ofNat] at hAffine + convert hAffine using 1 <;> dsimp [x] <;> ring + rw [hCardReal] + calc + |((affineCard : ℝ) + boundaryCard) - (p : ℝ)| = + |((affineCard : ℝ) - (p : ℝ)) + boundaryCard| := by ring_nf + _ ≤ |(affineCard : ℝ) - (p : ℝ)| + |(boundaryCard : ℝ)| := abs_add_le _ _ + _ = |(affineCard : ℝ) - (p : ℝ)| + boundaryCard := by + have hbabs : |(boundaryCard : ℝ)| = boundaryCard := + abs_of_nonneg (Nat.cast_nonneg boundaryCard) + rw [hbabs] + _ ≤ 4 * (generalCoefficient : ℝ) * x + 2 * x := by gcongr + _ = (coefficient : ℝ) * Real.sqrt (p : ℝ) * (d : ℝ) * (e : ℝ) := by + dsimp [coefficient, x] + norm_num only [Nat.cast_add, Nat.cast_mul, Nat.cast_ofNat] + ring + +/-- The general affine Hasse--Weil theorem supplies the seeded nonsplit estimate. -/ +theorem exists_seededNonsplitTraceWeilBoundAssumption_of_generalHasseWeil + (hHasse : BGS.External.GeneralBivariateAffineHasseWeilTheorem) : + ∃ coefficient : ℕ, SeededNonsplitTraceWeilBoundAssumption coefficient := by + obtain ⟨generalCoefficient, _hgeneralCoefficient, hgeneral⟩ := hHasse + exact ⟨4 * generalCoefficient + 2, + seededNonsplitTraceWeilBoundAssumption_of_bivariateAffineHasseWeilBound + generalCoefficient hgeneral⟩ + +end + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Endgame/Nonsplit/SeededCover.lean b/LeanPool/MarkoffModP/BGS/Markoff/Endgame/Nonsplit/SeededCover.lean new file mode 100644 index 0000000000..a3145c10fa --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Endgame/Nonsplit/SeededCover.lean @@ -0,0 +1,219 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.TraceCurveWeights +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.Geometry +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.WeightedOddCoprimeIrreducibility + +/-! +# The seeded nonsplit endgame cover + +The endgame curve is not the trace of a bare norm-one element. A fixed seed `s` in a +nontrivial norm fibre is multiplied by the varying norm-one coordinate. After scalar extension +the two weights are `s` and `s^p`; their product is `Norm(s)`, not one. +-/ + +@[expose] public section + +namespace BGS.Markoff + +section GeneralSeed + +variable (p : ℕ) [Fact p.Prime] + +/-- A split base-field unit transported to the canonical quadratic extension. -/ +noncomputable def seededBaseUnitInQuadraticField (u : (ZMod p)ˣ) : + (quadraticFiniteField p)ˣ := + Units.map (algebraMap (ZMod p) (quadraticFiniteField p)).toMonoidHom u + +/-- The actual seeded nonsplit cover. The seed lies in the norm-`k` torsor and the varying +coordinate lies in the norm-one torus. -/ +def SeededNonsplitTraceCoverEquation (k : (ZMod p)ˣ) + (s : ↑(quadraticNormFiber p k)) (d e : ℕ) + (w : quadraticNormOneTorus p) (u : (ZMod p)ˣ) : Prop := + Algebra.trace (ZMod p) (quadraticFiniteField p) + ((s.1 : quadraticFiniteField p) * + (((w ^ d : quadraticNormOneTorus p) : (quadraticFiniteField p)ˣ) : + quadraticFiniteField p)) = + splitTorusTrace (u ^ e) + +/-- The scalar extension of the seeded trace is the weighted trace with coefficients +`alpha = s` and `beta = s^p`. -/ +theorem algebraMap_seededQuadraticTrace_eq_weightedSplitTorusTrace + (k : (ZMod p)ˣ) (s : ↑(quadraticNormFiber p k)) + (d : ℕ) (w : quadraticNormOneTorus p) : + algebraMap (ZMod p) (quadraticFiniteField p) + (Algebra.trace (ZMod p) (quadraticFiniteField p) + ((s.1 : quadraticFiniteField p) * + (((w ^ d : quadraticNormOneTorus p) : (quadraticFiniteField p)ˣ) : + quadraticFiniteField p))) = + weightedSplitTorusTrace + (s.1 : quadraticFiniteField p) + ((s.1 : quadraticFiniteField p) ^ p) + ((w : (quadraticFiniteField p)ˣ) ^ d) := by + have hwcoe : + ((((w ^ d : quadraticNormOneTorus p) : (quadraticFiniteField p)ˣ) : + quadraticFiniteField p)) = + (((w : (quadraticFiniteField p)ˣ) : quadraticFiniteField p) ^ d) := rfl + rw [algebraMap_quadraticTrace] + unfold weightedSplitTorusTrace + rw [mul_pow] + rw [quadraticNormOne_frobenius_eq_inv p (w ^ d)] + simp only [Units.val_pow_eq_pow_val, Units.val_inv_eq_inv_val] + rw [hwcoe] + +/-- The actual nonsplit cover is exactly the existing weighted split cover over the quadratic +field. The exponent order in `SplitTraceCurveEquation` is `(e,d)`. -/ +theorem seededNonsplitTraceCoverEquation_iff_weightedSplitTraceCover + (k : (ZMod p)ˣ) (s : ↑(quadraticNormFiber p k)) + (d e : ℕ) (w : quadraticNormOneTorus p) (u : (ZMod p)ˣ) : + SeededNonsplitTraceCoverEquation p k s d e w u ↔ + SplitTraceCurveEquation + (s.1 : quadraticFiniteField p) + ((s.1 : quadraticFiniteField p) ^ p) e d + (seededBaseUnitInQuadraticField p u) + (w : (quadraticFiniteField p)ˣ) := by + unfold SeededNonsplitTraceCoverEquation SplitTraceCurveEquation + have hleft := algebraMap_seededQuadraticTrace_eq_weightedSplitTorusTrace + p k s d w + constructor + · intro h + rw [← hleft, h] + simp [seededBaseUnitInQuadraticField, splitTorusTrace] + · intro h + apply (algebraMap (ZMod p) (quadraticFiniteField p)).injective + rw [hleft, h] + simp [seededBaseUnitInQuadraticField, splitTorusTrace] + +/-- The product of the scalar-extended weights is exactly the prescribed seed norm. -/ +theorem seededNonsplitWeights_mul + (k : (ZMod p)ˣ) (s : ↑(quadraticNormFiber p k)) : + (s.1 : quadraticFiniteField p) * (s.1 : quadraticFiniteField p) ^ p = + algebraMap (ZMod p) (quadraticFiniteField p) (k : ZMod p) := by + rw [quadraticNormFiber_frobenius_eq_norm_mul_inv p k s] + field_simp + +/-- A seed of norm different from one supplies exactly the coefficient hypotheses required by +the weighted split-cover irreducibility theorem. -/ +theorem seededNonsplitWeights_nondegenerate + (k : (ZMod p)ˣ) (hk : k ≠ 1) (s : ↑(quadraticNormFiber p k)) : + (s.1 : quadraticFiniteField p) ≠ 0 ∧ + (s.1 : quadraticFiniteField p) ^ p ≠ 0 ∧ + (s.1 : quadraticFiniteField p) * (s.1 : quadraticFiniteField p) ^ p ≠ 1 := by + refine ⟨Units.ne_zero s.1, pow_ne_zero p (Units.ne_zero s.1), ?_⟩ + rw [seededNonsplitWeights_mul p k s] + intro hmap + apply hk + apply Units.ext + apply (algebraMap (ZMod p) (quadraticFiniteField p)).injective + simpa using hmap + +end GeneralSeed + +section ExistingConicSeed + +variable (p : ℕ) [Fact p.Prime] + +/-- For an odd prime, the existing nonzero nonparabolic conic invariant +`kappa(t) = t^2/(t^2-4)` is not one. -/ +theorem quadraticFiberProduct_ne_one_of_prime_ne_two + (hpTwo : p ≠ 2) (t : ZMod p) (ht : t ^ 2 ≠ 4) : + quadraticFiberProduct p t ≠ 1 := by + have hfourE := four_ne_zero_quadraticFiniteField_of_prime_ne_two p hpTwo + have hfour : (4 : ZMod p) ≠ 0 := + (map_ne_zero (algebraMap (ZMod p) (quadraticFiniteField p))).mp hfourE + intro hkappa + have hden : t ^ 2 - 4 ≠ 0 := sub_ne_zero.mpr ht + have heq : t ^ 2 = 1 * (t ^ 2 - 4) := by + exact (div_eq_iff hden).mp hkappa + apply hfour + linear_combination heq + +/-- The unit indexing the existing conic norm fibre is nontrivial. -/ +theorem quadraticFiberProductUnit_ne_one + (hpTwo : p ≠ 2) (t : ZMod p) (ht : t ^ 2 ≠ 4) (ht0 : t ≠ 0) : + quadraticFiberProductUnit p t ht ht0 ≠ 1 := by + intro h + have hval := congrArg Units.val h + apply quadraticFiberProduct_ne_one_of_prime_ne_two p hpTwo t ht + change quadraticFiberProduct p t = 1 at hval + exact hval + +/-- Every seed from the existing nonsplit conic construction has nonzero weighted coefficients +whose product is the embedded invariant `kappa(t)`, and this product is not one. -/ +theorem existingConicSeed_nonsplitWeights_nondegenerate + (hpTwo : p ≠ 2) (t : ZMod p) (ht : t ^ 2 ≠ 4) (ht0 : t ≠ 0) + (s : ↑(quadraticConicNormFiber p t ht ht0)) : + (s.1 : quadraticFiniteField p) ≠ 0 ∧ + (s.1 : quadraticFiniteField p) ^ p ≠ 0 ∧ + (s.1 : quadraticFiniteField p) * (s.1 : quadraticFiniteField p) ^ p ≠ 1 := by + exact seededNonsplitWeights_nondegenerate p + (quadraticFiberProductUnit p t ht ht0) + (quadraticFiberProductUnit_ne_one p hpTwo t ht ht0) s + +/-- The corrected nonsplit cover lands in the already-proved arbitrary positive-exponent +weighted-cover theorem after quadratic scalar extension. In the polynomial convention the +base-field exponent `e` is the first exponent and the norm-one exponent `d` is the second, so +the characteristic hypothesis is required on `d`. -/ +theorem existingConicSeed_weightedCover_absolutelyIrreducible + (hpTwo : p ≠ 2) (t : ZMod p) (ht : t ^ 2 ≠ 4) (ht0 : t ≠ 0) + (s : ↥(quadraticConicNormFiber p t ht ht0)) + (d e : ℕ) (hd : 0 < d) (he : 0 < e) + (hdChar : (d : quadraticFiniteField p) ≠ 0) : + Irreducible + (MvPolynomial.map + (algebraMap (quadraticFiniteField p) (AlgebraicClosure (quadraticFiniteField p))) + (splitTraceCoverPolynomial + (s.1 : quadraticFiniteField p) + ((s.1 : quadraticFiniteField p) ^ p) e d)) := by + obtain ⟨halpha, hbeta, hproduct⟩ := + existingConicSeed_nonsplitWeights_nondegenerate p hpTwo t ht ht0 s + exact splitTraceCoverPolynomial_absolutelyIrreducible_of_positiveExponents + (s.1 : quadraticFiniteField p) ((s.1 : quadraticFiniteField p) ^ p) + halpha hbeta hproduct d e hd he hdChar + +/-- The endgame equation specialized to the seed type already constructed by the conic +parametrization module. -/ +def ExistingConicSeedNonsplitTraceCoverEquation + (t : ZMod p) (ht : t ^ 2 ≠ 4) (ht0 : t ≠ 0) + (s : ↑(quadraticConicNormFiber p t ht ht0)) + (d e : ℕ) (w : quadraticNormOneTorus p) (u : (ZMod p)ˣ) : Prop := + SeededNonsplitTraceCoverEquation p + (quadraticFiberProductUnit p t ht ht0) s d e w u + +theorem existingConicSeedNonsplitTraceCoverEquation_iff_weightedSplitTraceCover + (t : ZMod p) (ht : t ^ 2 ≠ 4) (ht0 : t ≠ 0) + (s : ↑(quadraticConicNormFiber p t ht ht0)) + (d e : ℕ) (w : quadraticNormOneTorus p) (u : (ZMod p)ˣ) : + ExistingConicSeedNonsplitTraceCoverEquation p t ht ht0 s d e w u ↔ + SplitTraceCurveEquation + (s.1 : quadraticFiniteField p) + ((s.1 : quadraticFiniteField p) ^ p) e d + (seededBaseUnitInQuadraticField p u) + (w : (quadraticFiniteField p)ˣ) := by + exact seededNonsplitTraceCoverEquation_iff_weightedSplitTraceCover p + (quadraticFiberProductUnit p t ht ht0) s d e w u + +end ExistingConicSeed + +namespace DegenerateUnseededCountermodel + +variable (p : ℕ) [Fact p.Prime] + +/-- This is the tempting but incorrect unseeded model. It is retained only to state the +degeneracy explicitly. -/ +def UnseededNormOneTraceCountermodel (d e : ℕ) + (w : quadraticNormOneTorus p) (u : (ZMod p)ˣ) : Prop := + quadraticNormOneTrace p (w ^ d) = splitTorusTrace (u ^ e) + +theorem unseededCountermodel_weights_product_eq_one : + (1 : quadraticFiniteField p) * 1 = 1 := by simp + +end DegenerateUnseededCountermodel + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Endgame/Parabolic.lean b/LeanPool/MarkoffModP/BGS/Markoff/Endgame/Parabolic.lean new file mode 100644 index 0000000000..81d7d14481 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Endgame/Parabolic.lean @@ -0,0 +1,220 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Endgame.PrimitiveOrbitWiring +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.Diagonalization +public import LeanPool.MarkoffModP.BGS.Markoff.Core.ParabolicFibers + +/-! +# The parabolic branch of the endgame + +The two parabolic fibers are affine lines. Their explicit rotation formulas make the second +coordinate run through the whole base field, so in particular through the trace of a generator +of the split torus. +-/ + +@[expose] public section + +namespace BGS.Markoff + +noncomputable section + +private theorem exists_fullOrderBaseUnit (p : ℕ) [Fact p.Prime] : + ∃ u : (ZMod p)ˣ, orderOf u = Nat.card (ZMod p)ˣ := by + obtain ⟨u, hu⟩ := IsCyclic.exists_generator (α := (ZMod p)ˣ) + exact ⟨u, orderOf_eq_card_of_forall_mem_zpowers hu⟩ + +private theorem two_ne_zero_zmod_of_prime_ne_two + (p : ℕ) [Fact p.Prime] (hpTwo : p ≠ 2) : (2 : ZMod p) ≠ 0 := by + intro hzero + have hpDvd : p ∣ 2 := (ZMod.natCast_eq_zero_iff 2 p).mp hzero + have hpLe : p ≤ 2 := Nat.le_of_dvd (by norm_num) hpDvd + exact hpTwo (Nat.le_antisymm hpLe (Fact.out : p.Prime).two_le) + +/-- Every point of the trace-`2` fiber reaches a primitive split trace in its second +coordinate. -/ +theorem exists_iterate_parabolicTwoPoint_with_primitive_secondTrace + (p : ℕ) [Fact p.Prime] (hpTwo : p ≠ 2) + (x : ↥(normalizedFiber1 (2 : ZMod p))) : + ∃ n : ℕ, ∃ u : (ZMod p)ˣ, + ((normalizedRotate1^[n]) (x : NormalizedPoint (ZMod p))).u2 = + splitTorusTrace u ∧ + orderOf u = Nat.card (ZMod p)ˣ := by + have htwo := two_ne_zero_zmod_of_prime_ne_two p hpTwo + let i : ZMod p := (x.1.u3 - x.1.u2) / 2 + have hi : i ^ 2 = -1 := by + have hsurface : + IsNormalizedMarkoff + (⟨(2 : ZMod p), x.1.u2, x.1.u3⟩ : NormalizedPoint (ZMod p)) := by + simpa [← x.property.2] using x.property.1 + have hsquare := (isNormalizedMarkoff_at_two_iff x.1.u2 x.1.u3).mp hsurface + dsimp [i] + field_simp [htwo] + linear_combination hsquare + have hx : (x : NormalizedPoint (ZMod p)) = parabolicLineAtTwo i x.1.u2 := by + ext + · exact x.property.2 + · rfl + · dsimp [parabolicLineAtTwo, i] + field_simp [htwo] + ring + have hi0 : i ≠ 0 := by + intro hzero + rw [hzero] at hi + norm_num at hi + have hstep : (2 : ZMod p) * i ≠ 0 := mul_ne_zero htwo hi0 + obtain ⟨u, huOrder⟩ := exists_fullOrderBaseUnit p + let a : ZMod p := (splitTorusTrace u - x.1.u2) / (2 * i) + let n : ℕ := a.val + have hn : (n : ZMod p) = a := by + exact ZMod.natCast_zmod_val a + refine ⟨n, u, ?_, huOrder⟩ + rw [hx, iterate_normalizedRotate1_parabolicLineAtTwo] + change x.1.u2 + (n : ZMod p) * (2 * i) = splitTorusTrace u + rw [hn] + dsimp [a] + field_simp [hstep] + ring + +/-- Every point of the trace-`-2` fiber reaches a primitive split trace in its second +coordinate. -/ +theorem exists_iterate_parabolicNegTwoPoint_with_primitive_secondTrace + (p : ℕ) [Fact p.Prime] (hpTwo : p ≠ 2) + (x : ↥(normalizedFiber1 (-2 : ZMod p))) : + ∃ n : ℕ, ∃ u : (ZMod p)ˣ, + ((normalizedRotate1^[n]) (x : NormalizedPoint (ZMod p))).u2 = + splitTorusTrace u ∧ + orderOf u = Nat.card (ZMod p)ˣ := by + have htwo := two_ne_zero_zmod_of_prime_ne_two p hpTwo + let i : ZMod p := (x.1.u3 + x.1.u2) / 2 + have hi : i ^ 2 = -1 := by + have hsurface : + IsNormalizedMarkoff + (⟨(-2 : ZMod p), x.1.u2, x.1.u3⟩ : NormalizedPoint (ZMod p)) := by + simpa [← x.property.2] using x.property.1 + have hsquare := (isNormalizedMarkoff_at_neg_two_iff x.1.u2 x.1.u3).mp hsurface + dsimp [i] + field_simp [htwo] + linear_combination hsquare + have hx : (x : NormalizedPoint (ZMod p)) = parabolicLineAtNegTwo i x.1.u2 := by + ext + · exact x.property.2 + · rfl + · dsimp [parabolicLineAtNegTwo, i] + field_simp [htwo] + ring + have hi0 : i ≠ 0 := by + intro hzero + rw [hzero] at hi + norm_num at hi + have hfour : (4 : ZMod p) ≠ 0 := by + rw [show (4 : ZMod p) = 2 * 2 by norm_num] + exact mul_ne_zero htwo htwo + have hstep : (4 : ZMod p) * i ≠ 0 := mul_ne_zero hfour hi0 + obtain ⟨u, huOrder⟩ := exists_fullOrderBaseUnit p + let a : ZMod p := (x.1.u2 - splitTorusTrace u) / (4 * i) + let k : ℕ := a.val + have hk : (k : ZMod p) = a := ZMod.natCast_zmod_val a + refine ⟨2 * k, u, ?_, huOrder⟩ + rw [hx, iterate_two_mul_normalizedRotate1_parabolicLineAtNegTwo] + change x.1.u2 - (k : ZMod p) * (4 * i) = splitTorusTrace u + rw [hk] + dsimp [a] + field_simp [hstep] + ring + +/-- Unified parabolic branch. -/ +theorem exists_iterate_parabolicPoint_with_primitive_secondTrace + (p : ℕ) [Fact p.Prime] (hpTwo : p ≠ 2) + (t : ZMod p) (ht : t ^ 2 = 4) (x : ↥(normalizedFiber1 t)) : + ∃ n : ℕ, ∃ u : (ZMod p)ˣ, + ((normalizedRotate1^[n]) (x : NormalizedPoint (ZMod p))).u2 = + splitTorusTrace u ∧ + orderOf u = Nat.card (ZMod p)ˣ := by + have htCases : t = 2 ∨ t = -2 := by + apply (sq_eq_sq_iff_eq_or_eq_neg).mp + calc + t ^ 2 = 4 := ht + _ = (2 : ZMod p) ^ 2 := by norm_num + rcases htCases with rfl | rfl + · exact exists_iterate_parabolicTwoPoint_with_primitive_secondTrace p hpTwo x + · exact exists_iterate_parabolicNegTwoPoint_with_primitive_secondTrace p hpTwo x + +/-- For primes at least five, the primitive trace reached in the parabolic branch has maximal +split rotation order `p - 1`. -/ +theorem exists_iterate_parabolicPoint_with_maximal_secondRotation + (p : ℕ) [Fact p.Prime] (hpFive : 5 ≤ p) + (t : ZMod p) (ht : t ^ 2 = 4) (x : ↥(normalizedFiber1 t)) : + ∃ n : ℕ, + rotationOrder + (((normalizedRotate1^[n]) + (x : NormalizedPoint (ZMod p))).u2) = p - 1 := by + obtain ⟨n, u, hcoordinate, huOrder⟩ := + exists_iterate_parabolicPoint_with_primitive_secondTrace p (by omega) t ht x + have hcard : Nat.card (ZMod p)ˣ = p - 1 := by + rw [Nat.card_units, Nat.card_zmod] + have huSq : (u : ZMod p) ^ 2 ≠ 1 := by + intro huPower + have huDvd : orderOf u ∣ 2 := orderOf_dvd_of_pow_eq_one <| by + apply Units.ext + exact huPower + have huLe : orderOf u ≤ 2 := Nat.le_of_dvd (by norm_num) huDvd + rw [huOrder, hcard] at huLe + omega + refine ⟨n, ?_⟩ + rw [hcoordinate, rotationOrder_splitTorusTrace u huSq, huOrder, hcard] + +/-- Full first-coordinate form of Proposition 10, including semisimple, parabolic, and the +trace-zero exclusion. -/ +theorem exists_threshold_point_with_maximal_secondRotation + (splitCoefficient : ℕ) + (hSplitWeil : WeightedSplitTraceWeilBoundAssumption splitCoefficient) + (nonsplitCoefficient : ℕ) + (hNonsplitWeil : SeededNonsplitTraceWeilBoundAssumption nonsplitCoefficient) + {δ : ℝ} (hδ : 0 < δ) : + ∃ threshold : ℕ, ∀ p : ℕ, threshold ≤ p → [Fact p.Prime] → + ∀ (t : ZMod p) (x : ↥(normalizedFiber1 t)), + (p : ℝ) ^ ((1 : ℝ) / 2 + δ) ≤ rotationOrder t → + ∃ n : ℕ, + rotationOrder + (((normalizedRotate1^[n]) + (x : NormalizedPoint (ZMod p))).u2) = p - 1 := by + obtain ⟨semisimpleThreshold, hSemisimple⟩ := + exists_threshold_nonparabolicPoint_with_maximal_secondRotation + splitCoefficient hSplitWeil nonsplitCoefficient hNonsplitWeil hδ + have hexponent : (0 : ℝ) < (1 : ℝ) / 2 + δ := by linarith + have hZeroAbsorb : + ∀ᶠ p : ℕ in Filter.atTop, + 4 < (p : ℝ) ^ ((1 : ℝ) / 2 + δ) := by + simpa using + (eventually_const_mul_rpow_lt_rpow + (C := (4 : ℝ)) (a := (0 : ℝ)) (b := (1 : ℝ) / 2 + δ) hexponent) + obtain ⟨zeroThreshold, hZeroThreshold⟩ := Filter.eventually_atTop.mp hZeroAbsorb + refine ⟨max (max semisimpleThreshold zeroThreshold) 5, ?_⟩ + intro p hp _ t x hlarge + have hpSemisimple : semisimpleThreshold ≤ p := + (le_max_left semisimpleThreshold zeroThreshold).trans + ((le_max_left (max semisimpleThreshold zeroThreshold) 5).trans hp) + have hpZero : zeroThreshold ≤ p := + (le_max_right semisimpleThreshold zeroThreshold).trans + ((le_max_left (max semisimpleThreshold zeroThreshold) 5).trans hp) + by_cases htParabolic : t ^ 2 = 4 + · exact exists_iterate_parabolicPoint_with_maximal_secondRotation + p (by omega) t htParabolic x + · have ht0 : t ≠ 0 := by + intro htZero + subst t + have horderSmall := rotationOrder_zero_le_four p + have hlargeLe : (p : ℝ) ^ ((1 : ℝ) / 2 + δ) ≤ 4 := + hlarge.trans (by exact_mod_cast horderSmall) + exact (not_lt_of_ge hlargeLe) (hZeroThreshold p hpZero) + exact hSemisimple p hpSemisimple t htParabolic ht0 x hlarge + +end + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Endgame/PowerCoverCounting.lean b/LeanPool/MarkoffModP/BGS/Markoff/Endgame/PowerCoverCounting.lean new file mode 100644 index 0000000000..3bf9acdfb5 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Endgame/PowerCoverCounting.lean @@ -0,0 +1,110 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import Mathlib.GroupTheory.SpecificGroups.Cyclic +public import Mathlib.GroupTheory.Coset.Basic + +/-! +# Exact power-cover multiplicities in the endgame + +The paper divides its trace-cover point count by the two power-map degrees. This module proves +that step exactly for finite cyclic groups: a cover solution is a target trace solution together +with one point in each power-map fiber, and every such fiber is equivalent to the corresponding +kernel. No asymptotic or geometric estimate enters this multiplicity identity. +-/ + +@[expose] public section + +namespace BGS.Markoff + +noncomputable section + +variable {G H T : Type*} [CommGroup G] [CommGroup H] + +/-- Solutions of a trace equation after applying power maps to two finite groups. -/ +def powerTraceCoverSolutions + (leftTrace : G → T) (rightTrace : H → T) (d e : ℕ) := + {z : G × H // leftTrace (z.1 ^ d) = rightTrace (z.2 ^ e)} + +/-- The corresponding equation on the two power-map images. -/ +def powerTraceRangeSolutions + (leftTrace : G → T) (rightTrace : H → T) (d e : ℕ) := + {z : (powMonoidHom d : G →* G).range × (powMonoidHom e : H →* H).range // + leftTrace z.1 = rightTrace z.2} + +/-- A power-cover solution is a target solution together with one point in each power-map fiber. -/ +def powerTraceCoverEquivSigmaFibers + (leftTrace : G → T) (rightTrace : H → T) (d e : ℕ) : + powerTraceCoverSolutions leftTrace rightTrace d e ≃ + Σ s : powerTraceRangeSolutions leftTrace rightTrace d e, + ((powMonoidHom d : G →* G) ⁻¹' {(s.1.1 : G)} : Set G) × + ((powMonoidHom e : H →* H) ⁻¹' {(s.1.2 : H)} : Set H) where + toFun z := ⟨⟨⟨⟨z.1.1 ^ d, ⟨z.1.1, by simp⟩⟩, + ⟨z.1.2 ^ e, ⟨z.1.2, by simp⟩⟩⟩, z.2⟩, + ⟨⟨z.1.1, by simp⟩, ⟨z.1.2, by simp⟩⟩⟩ + invFun w := ⟨(w.2.1.1, w.2.2.1), by + have hx : (powMonoidHom d : G →* G) w.2.1.1 = (w.1.1.1 : G) := w.2.1.2 + have hy : (powMonoidHom e : H →* H) w.2.2.1 = (w.1.1.2 : H) := w.2.2.2 + change leftTrace (w.2.1.1 ^ d) = rightTrace (w.2.2.1 ^ e) + rw [show w.2.1.1 ^ d = w.1.1.1 by exact hx, + show w.2.2.1 ^ e = w.1.1.2 by exact hy] + exact w.1.2⟩ + left_inv z := by rfl + right_inv w := by + rcases w with ⟨⟨⟨⟨sx, hsx⟩, ⟨sy, hsy⟩⟩, hs⟩, + ⟨⟨x, hx⟩, ⟨y, hy⟩⟩⟩ + simp only [Set.mem_preimage, Set.mem_singleton_iff] at hx hy + dsimp at hx hy ⊢ + subst sx + subst sy + rfl + +theorem natCard_powerMapFiber_eq_ker + [Finite G] (d : ℕ) (x : (powMonoidHom d : G →* G).range) : + Nat.card ((powMonoidHom d : G →* G) ⁻¹' {x.1} : Set G) = + Nat.card (powMonoidHom d : G →* G).ker := by + obtain ⟨a, ha⟩ := x.2 + have hset : + (powMonoidHom d : G →* G) ⁻¹' {x.1} = + (powMonoidHom d : G →* G) ⁻¹' {(powMonoidHom d) a} := by + rw [ha] + rw [hset] + exact Nat.card_congr ((powMonoidHom d : G →* G).fiberEquivKer a) + +theorem natCard_powerTraceCoverSolutions + [Finite G] [Finite H] + (leftTrace : G → T) (rightTrace : H → T) (d e : ℕ) : + Nat.card (powerTraceCoverSolutions leftTrace rightTrace d e) = + Nat.card (powMonoidHom d : G →* G).ker * + Nat.card (powMonoidHom e : H →* H).ker * + Nat.card (powerTraceRangeSolutions leftTrace rightTrace d e) := by + let : Finite (powMonoidHom d : G →* G).range := + Finite.of_injective Subtype.val Subtype.val_injective + let : Finite (powMonoidHom e : H →* H).range := + Finite.of_injective Subtype.val Subtype.val_injective + let : Finite (powerTraceRangeSolutions leftTrace rightTrace d e) := + Finite.of_injective Subtype.val Subtype.val_injective + let := Fintype.ofFinite (powerTraceRangeSolutions leftTrace rightTrace d e) + rw [Nat.card_congr (powerTraceCoverEquivSigmaFibers leftTrace rightTrace d e), + Nat.card_sigma] + simp_rw [Nat.card_prod, natCard_powerMapFiber_eq_ker] + simp [mul_comm] + +theorem natCard_powerTraceCoverSolutions_of_dvd + [Finite G] [Finite H] [IsCyclic G] [IsCyclic H] + (leftTrace : G → T) (rightTrace : H → T) (d e : ℕ) + (hd : d ∣ Nat.card G) (he : e ∣ Nat.card H) : + Nat.card (powerTraceCoverSolutions leftTrace rightTrace d e) = + d * e * Nat.card (powerTraceRangeSolutions leftTrace rightTrace d e) := by + rw [natCard_powerTraceCoverSolutions, + IsCyclic.card_powMonoidHom_ker, IsCyclic.card_powMonoidHom_ker, + Nat.gcd_eq_right_iff_dvd.mpr hd, Nat.gcd_eq_right_iff_dvd.mpr he] + +end + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Endgame/PrimitiveInclusionExclusion.lean b/LeanPool/MarkoffModP/BGS/Markoff/Endgame/PrimitiveInclusionExclusion.lean new file mode 100644 index 0000000000..5228c243d3 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Endgame/PrimitiveInclusionExclusion.lean @@ -0,0 +1,937 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Endgame.PrimitiveTraceCount +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.DivisorRange +public import Mathlib.NumberTheory.ArithmeticFunction.Moebius + +/-! +# Möbius inclusion--exclusion for primitive endgame traces + +This file formalizes published equations (35)--(36). For a fixed left power-map image and a +finite cyclic right group, it partitions trace coincidences by the exact order of the right-hand +element, applies Möbius inversion, and identifies the cumulative order-divisibility count with the +corresponding right power-map image. +-/ + +@[expose] public section + +namespace BGS.Markoff + +open scoped ArithmeticFunction.Moebius BigOperators +open Filter + +noncomputable section + +variable {G H T : Type*} [CommGroup G] [CommGroup H] + +/-- In a finite cyclic group, the image of the `d`-th power map is the kernel of the +`(card / d)`-th power map whenever `d` divides the group order. -/ +theorem powMonoidHom_range_eq_ker_complementaryExponent + [Finite H] [IsCyclic H] (d : ℕ) (hdvd : d ∣ Nat.card H) : + (powMonoidHom d : H →* H).range = + (powMonoidHom (Nat.card H / d) : H →* H).ker := by + let := Fintype.ofFinite H + apply Subgroup.eq_of_le_of_card_ge + · rintro y ⟨x, rfl⟩ + change (x ^ d) ^ (Nat.card H / d) = 1 + rw [← pow_mul, Nat.mul_div_cancel' hdvd, Nat.card_eq_fintype_card, pow_card_eq_one] + · rw [IsCyclic.card_powMonoidHom_ker, IsCyclic.card_powMonoidHom_range] + rw [Nat.gcd_eq_right (Nat.div_dvd_of_dvd hdvd)] + rw [Nat.gcd_eq_right hdvd] + +/-- In a finite cyclic group, the image of the complementary power map is exactly the cyclic +subgroup generated by the element whose order defines that complementary exponent. This is +the bridge between the endgame count, which is naturally stated on a power-map image, and the +rotation orbit, which is naturally stated as `Subgroup.zpowers w`. -/ +theorem powMonoidHom_range_eq_zpowers_of_complementaryOrder + {K : Type*} [CommGroup K] [Finite K] [IsCyclic K] (w : K) : + (powMonoidHom (Nat.card K / orderOf w) : K →* K).range = + Subgroup.zpowers w := by + let n := Nat.card K + let m := orderOf w + let e := n / m + have hn : 0 < n := Nat.card_pos + have hm : 0 < m := orderOf_pos w + have hmDvd : m ∣ n := orderOf_dvd_natCard w + have hmLe : m ≤ n := Nat.le_of_dvd hn hmDvd + have he : 0 < e := Nat.div_pos hmLe hm + have heDvd : e ∣ n := Nat.div_dvd_of_dvd hmDvd + have hComplement : n / e = m := by + apply (Nat.div_eq_iff_eq_mul_right he heDvd).2 + exact (Nat.div_mul_cancel hmDvd).symm + symm + apply Subgroup.eq_of_le_of_card_ge + · rw [Subgroup.zpowers_le] + rw [powMonoidHom_range_eq_ker_complementaryExponent (H := K) e heDvd] + change w ^ (n / e) = 1 + rw [hComplement] + exact pow_orderOf_eq_one w + · rw [Nat.card_zpowers, IsCyclic.card_powMonoidHom_range] + change n / n.gcd e ≤ m + rw [Nat.gcd_eq_right_iff_dvd.mpr heDvd, hComplement] + +/-- All trace coincidences with the left coordinate restricted to one power-map image. -/ +noncomputable def traceRelationPairs + [Finite G] [Finite H] + (leftTrace : G → T) (rightTrace : H → T) (leftExponent : ℕ) : + Finset ((powMonoidHom leftExponent : G →* G).range × H) := by + classical + letI := Fintype.ofFinite G + letI := Fintype.ofFinite H + exact Finset.univ.filter fun z => leftTrace z.1 = rightTrace z.2 + +/-- Trace coincidences whose right coordinate has one exact multiplicative order. -/ +noncomputable def traceExactOrderSolutions + [Finite G] [Finite H] + (leftTrace : G → T) (rightTrace : H → T) (leftExponent order : ℕ) : + Finset ((powMonoidHom leftExponent : G →* G).range × H) := by + classical + exact (traceRelationPairs leftTrace rightTrace leftExponent).filter fun z => + orderOf z.2 = order + +/-- Trace coincidences whose right coordinate is killed by one power. -/ +noncomputable def tracePowerKernelSolutions + [Finite G] [Finite H] + (leftTrace : G → T) (rightTrace : H → T) (leftExponent exponent : ℕ) : + Finset ((powMonoidHom leftExponent : G →* G).range × H) := by + classical + exact (traceRelationPairs leftTrace rightTrace leftExponent).filter fun z => + z.2 ^ exponent = 1 + +@[simp] +theorem mem_traceExactOrderSolutions_iff + [Finite G] [Finite H] + (leftTrace : G → T) (rightTrace : H → T) (leftExponent order : ℕ) + (z : (powMonoidHom leftExponent : G →* G).range × H) : + z ∈ traceExactOrderSolutions leftTrace rightTrace leftExponent order ↔ + leftTrace z.1 = rightTrace z.2 ∧ orderOf z.2 = order := by + classical + simp [traceExactOrderSolutions, traceRelationPairs] + +@[simp] +theorem mem_tracePowerKernelSolutions_iff + [Finite G] [Finite H] + (leftTrace : G → T) (rightTrace : H → T) (leftExponent exponent : ℕ) + (z : (powMonoidHom leftExponent : G →* G).range × H) : + z ∈ tracePowerKernelSolutions leftTrace rightTrace leftExponent exponent ↔ + leftTrace z.1 = rightTrace z.2 ∧ z.2 ^ exponent = 1 := by + classical + simp [tracePowerKernelSolutions, traceRelationPairs] + +/-- Exact-order classes partition the trace coincidences killed by the `m`-th power map. -/ +theorem sum_traceExactOrderSolutions_card_eq_tracePowerKernelSolutions_card + [Finite G] [Finite H] + (leftTrace : G → T) (rightTrace : H → T) (leftExponent m : ℕ) (hm : 0 < m) : + ∑ order ∈ m.divisors, + (traceExactOrderSolutions leftTrace rightTrace leftExponent order).card = + (tracePowerKernelSolutions leftTrace rightTrace leftExponent m).card := by + classical + simp only [traceExactOrderSolutions] + rw [Finset.sum_card_fiberwise_eq_card_filter] + apply congrArg Finset.card + ext z + simp [tracePowerKernelSolutions, Nat.mem_divisors, hm.ne', + orderOf_dvd_iff_pow_eq_one] + +/-- Möbius inversion recovers the exact-order trace count from the power-kernel counts. -/ +theorem moebius_sum_tracePowerKernelSolutions_card_eq_traceExactOrderSolutions_card + [Finite G] [Finite H] + (leftTrace : G → T) (rightTrace : H → T) (leftExponent n : ℕ) (hn : 0 < n) : + ∑ x ∈ n.divisorsAntidiagonal, + (μ x.fst : ℤ) * + (tracePowerKernelSolutions leftTrace rightTrace leftExponent x.snd).card = + (traceExactOrderSolutions leftTrace rightTrace leftExponent n).card := by + have hinversion := + (ArithmeticFunction.sum_eq_iff_sum_mul_moebius_eq + (R := ℤ) + (f := fun order => + ((traceExactOrderSolutions leftTrace rightTrace leftExponent order).card : ℤ)) + (g := fun exponent => + ((tracePowerKernelSolutions leftTrace rightTrace leftExponent exponent).card : ℤ))).mp + (fun m hm => by + exact_mod_cast + sum_traceExactOrderSolutions_card_eq_tracePowerKernelSolutions_card + leftTrace rightTrace leftExponent m hm) + exact hinversion n hn + +/-- A right power-range solution is a right power-kernel solution whenever the two subgroups are +identified. -/ +def powerTraceRangeSolutionsEquivTracePowerKernelSolutions + [Finite G] [Finite H] + (leftTrace : G → T) (rightTrace : H → T) (leftExponent rightExponent kernelExponent : ℕ) + (hsubgroup : + (powMonoidHom rightExponent : H →* H).range = + (powMonoidHom kernelExponent : H →* H).ker) : + powerTraceRangeSolutions leftTrace rightTrace leftExponent rightExponent ≃ + ↥(tracePowerKernelSolutions leftTrace rightTrace leftExponent kernelExponent) where + toFun z := ⟨(z.1.1, z.1.2.1), by + rw [mem_tracePowerKernelSolutions_iff] + refine ⟨z.2, ?_⟩ + have hzker : z.1.2.1 ∈ (powMonoidHom kernelExponent : H →* H).ker := by + rw [← hsubgroup] + exact z.1.2.2 + exact hzker⟩ + invFun z := ⟨(z.1.1, ⟨z.1.2, by + rw [hsubgroup] + exact (mem_tracePowerKernelSolutions_iff + leftTrace rightTrace leftExponent kernelExponent z.1).mp z.2 |>.2⟩), + (mem_tracePowerKernelSolutions_iff + leftTrace rightTrace leftExponent kernelExponent z.1).mp z.2 |>.1⟩ + left_inv z := by rfl + right_inv z := by rfl + +/-- Cardinal form of `powerTraceRangeSolutionsEquivTracePowerKernelSolutions`. -/ +theorem natCard_powerTraceRangeSolutions_eq_tracePowerKernelSolutions_card + [Finite G] [Finite H] + (leftTrace : G → T) (rightTrace : H → T) (leftExponent rightExponent kernelExponent : ℕ) + (hsubgroup : + (powMonoidHom rightExponent : H →* H).range = + (powMonoidHom kernelExponent : H →* H).ker) : + Nat.card (powerTraceRangeSolutions leftTrace rightTrace leftExponent rightExponent) = + (tracePowerKernelSolutions leftTrace rightTrace leftExponent kernelExponent).card := by + calc + Nat.card (powerTraceRangeSolutions leftTrace rightTrace leftExponent rightExponent) = + Nat.card ↥(tracePowerKernelSolutions leftTrace rightTrace + leftExponent kernelExponent) := + Nat.card_congr + (powerTraceRangeSolutionsEquivTracePowerKernelSolutions + leftTrace rightTrace leftExponent rightExponent kernelExponent hsubgroup) + _ = (tracePowerKernelSolutions leftTrace rightTrace + leftExponent kernelExponent).card := by + rw [Nat.card_eq_fintype_card, Fintype.card_coe] + +/-- Published equation (35): the exact-order trace count is the Möbius-weighted sum of the +counts on right power-map images. -/ +theorem moebius_sum_powerTraceRangeSolutions_card_eq_traceExactOrderSolutions_card + [Finite G] [Finite H] [IsCyclic H] + (leftTrace : G → T) (rightTrace : H → T) (leftExponent : ℕ) : + ∑ x ∈ (Nat.card H).divisorsAntidiagonal, + (μ x.fst : ℤ) * + Nat.card (powerTraceRangeSolutions + leftTrace rightTrace leftExponent x.fst) = + (traceExactOrderSolutions + leftTrace rightTrace leftExponent (Nat.card H)).card := by + rw [← moebius_sum_tracePowerKernelSolutions_card_eq_traceExactOrderSolutions_card + leftTrace rightTrace leftExponent (Nat.card H) Nat.card_pos] + apply Finset.sum_congr rfl + intro x hx + congr 1 + have hproduct := (Nat.mem_divisorsAntidiagonal.mp hx).1 + have hleftNe : x.fst ≠ 0 := Nat.left_ne_zero_of_mem_divisorsAntidiagonal hx + have hdvd : x.fst ∣ Nat.card H := ⟨x.snd, hproduct.symm⟩ + have hquotient : Nat.card H / x.fst = x.snd := by + rw [← hproduct, Nat.mul_comm x.fst x.snd, + Nat.mul_div_left x.snd (Nat.pos_of_ne_zero hleftNe)] + rw [natCard_powerTraceRangeSolutions_eq_tracePowerKernelSolutions_card + leftTrace rightTrace leftExponent x.fst x.snd] + simpa [hquotient] using + powMonoidHom_range_eq_ker_complementaryExponent (H := H) x.fst hdvd + +/-- Swapping the two coordinates preserves a power-range trace equation. -/ +def powerTraceRangeSolutionsSwapEquiv + [Finite G] [Finite H] + (leftTrace : G → T) (rightTrace : H → T) (leftExponent rightExponent : ℕ) : + powerTraceRangeSolutions leftTrace rightTrace leftExponent rightExponent ≃ + powerTraceRangeSolutions rightTrace leftTrace rightExponent leftExponent where + toFun z := ⟨(z.1.2, z.1.1), z.2.symm⟩ + invFun z := ⟨(z.1.2, z.1.1), z.2.symm⟩ + left_inv z := by rfl + right_inv z := by rfl + +theorem natCard_powerTraceRangeSolutions_swap + [Finite G] [Finite H] + (leftTrace : G → T) (rightTrace : H → T) (leftExponent rightExponent : ℕ) : + Nat.card (powerTraceRangeSolutions leftTrace rightTrace leftExponent rightExponent) = + Nat.card (powerTraceRangeSolutions rightTrace leftTrace rightExponent leftExponent) := + Nat.card_congr + (powerTraceRangeSolutionsSwapEquiv leftTrace rightTrace leftExponent rightExponent) + +/-- The number of divisor-antidiagonal pairs equals the number of divisors. -/ +theorem card_divisorsAntidiagonal_eq_card_divisors (n : ℕ) : + n.divisorsAntidiagonal.card = n.divisors.card := by + simpa only [Finset.card_eq_sum_ones] using + (Nat.sum_divisorsAntidiagonal (fun _ _ => (1 : ℕ)) (n := n)) + +/-- Summing individually bounded errors with Möbius coefficients costs at most the divisor count. -/ +theorem abs_moebius_weighted_sum_sub_le_divisors_card_mul + (n : ℕ) (count mainTerm : ℕ × ℕ → ℝ) (error : ℝ) + (hterm : ∀ x ∈ n.divisorsAntidiagonal, + |count x - mainTerm x| ≤ error) : + |(∑ x ∈ n.divisorsAntidiagonal, (μ x.fst : ℝ) * count x) - + ∑ x ∈ n.divisorsAntidiagonal, (μ x.fst : ℝ) * mainTerm x| ≤ + (n.divisors.card : ℝ) * error := by + let s := n.divisorsAntidiagonal + have hrewrite : + (∑ x ∈ s, (μ x.fst : ℝ) * count x) - + ∑ x ∈ s, (μ x.fst : ℝ) * mainTerm x = + ∑ x ∈ s, (μ x.fst : ℝ) * (count x - mainTerm x) := by + rw [← Finset.sum_sub_distrib] + apply Finset.sum_congr rfl + intro x hx + ring + rw [hrewrite] + calc + |∑ x ∈ s, (μ x.fst : ℝ) * (count x - mainTerm x)| ≤ + ∑ x ∈ s, |(μ x.fst : ℝ) * (count x - mainTerm x)| := + Finset.abs_sum_le_sum_abs _ _ + _ ≤ ∑ _x ∈ s, error := by + apply Finset.sum_le_sum + intro x hx + rw [abs_mul] + have hmu : |(μ x.fst : ℝ)| ≤ 1 := by + exact_mod_cast ArithmeticFunction.abs_moebius_le_one (n := x.fst) + calc + |(μ x.fst : ℝ)| * |count x - mainTerm x| ≤ 1 * error := + mul_le_mul hmu (hterm x hx) (abs_nonneg _) zero_le_one + _ = error := one_mul error + _ = (s.card : ℝ) * error := by simp + _ = (n.divisors.card : ℝ) * error := by + rw [card_divisorsAntidiagonal_eq_card_divisors] + +/-- Equation (36), before simplifying its main term: pointwise range-count estimates give a +divisor-count error envelope for the primitive trace count. -/ +theorem traceExactOrderSolutions_card_error_le_moebiusMain + [Finite G] [Finite H] [IsCyclic H] + (leftTrace : G → T) (rightTrace : H → T) (leftExponent : ℕ) + (mainTerm : ℕ → ℝ) (error : ℝ) + (hRange : ∀ d : ℕ, d ∣ Nat.card H → 0 < d → + |(Nat.card (powerTraceRangeSolutions + leftTrace rightTrace leftExponent d) : ℝ) - mainTerm d| ≤ error) : + |((traceExactOrderSolutions + leftTrace rightTrace leftExponent (Nat.card H)).card : ℝ) - + ∑ x ∈ (Nat.card H).divisorsAntidiagonal, + (μ x.fst : ℝ) * mainTerm x.fst| ≤ + ((Nat.card H).divisors.card : ℝ) * error := by + have hExact := + moebius_sum_powerTraceRangeSolutions_card_eq_traceExactOrderSolutions_card + leftTrace rightTrace leftExponent + have hExactReal : + ((traceExactOrderSolutions + leftTrace rightTrace leftExponent (Nat.card H)).card : ℝ) = + ∑ x ∈ (Nat.card H).divisorsAntidiagonal, + (μ x.fst : ℝ) * + (Nat.card (powerTraceRangeSolutions + leftTrace rightTrace leftExponent x.fst) : ℝ) := by + exact_mod_cast hExact.symm + rw [hExactReal] + apply abs_moebius_weighted_sum_sub_le_divisors_card_mul + (Nat.card H) + (fun x => (Nat.card (powerTraceRangeSolutions + leftTrace rightTrace leftExponent x.fst) : ℝ)) + (fun x => mainTerm x.fst) error + intro x hx + have hproduct := (Nat.mem_divisorsAntidiagonal.mp hx).1 + have hdvd : x.fst ∣ Nat.card H := ⟨x.snd, hproduct.symm⟩ + exact hRange x.fst hdvd + (Nat.pos_of_ne_zero (Nat.left_ne_zero_of_mem_divisorsAntidiagonal hx)) + +/-- A positive Möbius main term larger than the error envelope forces an actual primitive trace +solution. -/ +theorem traceExactOrderSolutions_nonempty_of_divisorsError_lt_moebiusMain + [Finite G] [Finite H] [IsCyclic H] + (leftTrace : G → T) (rightTrace : H → T) (leftExponent : ℕ) + (mainTerm : ℕ → ℝ) (error : ℝ) + (hRange : ∀ d : ℕ, d ∣ Nat.card H → 0 < d → + |(Nat.card (powerTraceRangeSolutions + leftTrace rightTrace leftExponent d) : ℝ) - mainTerm d| ≤ error) + (hpositive : + ((Nat.card H).divisors.card : ℝ) * error < + ∑ x ∈ (Nat.card H).divisorsAntidiagonal, + (μ x.fst : ℝ) * mainTerm x.fst) : + (traceExactOrderSolutions + leftTrace rightTrace leftExponent (Nat.card H)).Nonempty := by + have henvelope := traceExactOrderSolutions_card_error_le_moebiusMain + leftTrace rightTrace leftExponent mainTerm error hRange + have hcardReal : + 0 < ((traceExactOrderSolutions + leftTrace rightTrace leftExponent (Nat.card H)).card : ℝ) := by + have hlower : + (∑ x ∈ (Nat.card H).divisorsAntidiagonal, + (μ x.fst : ℝ) * mainTerm x.fst) - + ((traceExactOrderSolutions + leftTrace rightTrace leftExponent (Nat.card H)).card : ℝ) ≤ + |((traceExactOrderSolutions + leftTrace rightTrace leftExponent (Nat.card H)).card : ℝ) - + ∑ x ∈ (Nat.card H).divisorsAntidiagonal, + (μ x.fst : ℝ) * mainTerm x.fst| := by + simpa only [neg_sub] using + neg_le_abs + (((traceExactOrderSolutions + leftTrace rightTrace leftExponent (Nat.card H)).card : ℝ) - + ∑ x ∈ (Nat.card H).divisorsAntidiagonal, + (μ x.fst : ℝ) * mainTerm x.fst) + linarith + exact Finset.card_pos.mp (by exact_mod_cast hcardReal) + +/-- The common Möbius main term for a field of size `fieldCard`, a fixed power exponent, and a +primitive target group of order `groupOrder`. -/ +noncomputable def primitiveTraceMoebiusMainTerm + (groupOrder fieldCard fixedExponent : ℕ) : ℝ := + ∑ x ∈ groupOrder.divisorsAntidiagonal, + (μ x.fst : ℝ) * + ((fieldCard : ℝ) / ((x.fst : ℝ) * (fixedExponent : ℝ))) + +/-- Möbius inversion of `sum_totient`: the signed complementary-divisor sum is the totient. -/ +theorem sum_moebius_mul_complementaryDivisor_eq_totient (n : ℕ) (hn : 0 < n) : + ∑ x ∈ n.divisorsAntidiagonal, + (μ x.fst : ℤ) * (x.snd : ℤ) = (n.totient : ℤ) := by + have hsum : ∀ m : ℕ, m > 0 → + ∑ d ∈ m.divisors, (d.totient : ℤ) = (m : ℤ) := by + intro m hm + exact_mod_cast Nat.sum_totient m + exact + (ArithmeticFunction.sum_eq_iff_sum_mul_moebius_eq + (R := ℤ) + (f := fun d : ℕ => (d.totient : ℤ)) + (g := fun m : ℕ => (m : ℤ))).mp hsum n hn + +/-- Closed form of the primitive-trace Möbius main term. -/ +theorem primitiveTraceMoebiusMainTerm_eq_totient + (groupOrder fieldCard fixedExponent : ℕ) + (hgroup : 0 < groupOrder) (hfixed : 0 < fixedExponent) : + primitiveTraceMoebiusMainTerm groupOrder fieldCard fixedExponent = + (fieldCard : ℝ) * (groupOrder.totient : ℝ) / + ((fixedExponent : ℝ) * (groupOrder : ℝ)) := by + have hfixedReal : (fixedExponent : ℝ) ≠ 0 := by positivity + have hgroupReal : (groupOrder : ℝ) ≠ 0 := by positivity + unfold primitiveTraceMoebiusMainTerm + calc + (∑ x ∈ groupOrder.divisorsAntidiagonal, + (μ x.fst : ℝ) * + ((fieldCard : ℝ) / ((x.fst : ℝ) * (fixedExponent : ℝ)))) = + ∑ x ∈ groupOrder.divisorsAntidiagonal, + ((fieldCard : ℝ) / ((fixedExponent : ℝ) * (groupOrder : ℝ))) * + ((μ x.fst : ℝ) * (x.snd : ℝ)) := by + apply Finset.sum_congr rfl + intro x hx + have hproduct := (Nat.mem_divisorsAntidiagonal.mp hx).1 + have hleftNe := Nat.left_ne_zero_of_mem_divisorsAntidiagonal hx + have hleftReal : (x.fst : ℝ) ≠ 0 := by exact_mod_cast hleftNe + have hproductReal : (x.fst : ℝ) * (x.snd : ℝ) = groupOrder := by + exact_mod_cast hproduct + field_simp + rw [← hproductReal] + ring + _ = ((fieldCard : ℝ) / ((fixedExponent : ℝ) * (groupOrder : ℝ))) * + ∑ x ∈ groupOrder.divisorsAntidiagonal, + ((μ x.fst : ℝ) * (x.snd : ℝ)) := by + rw [Finset.mul_sum] + _ = ((fieldCard : ℝ) / ((fixedExponent : ℝ) * (groupOrder : ℝ))) * + (groupOrder.totient : ℝ) := by + congr 1 + exact_mod_cast sum_moebius_mul_complementaryDivisor_eq_totient + groupOrder hgroup + _ = (fieldCard : ℝ) * (groupOrder.totient : ℝ) / + ((fixedExponent : ℝ) * (groupOrder : ℝ)) := by ring + +/-- The totient times the divisor count dominates the integer itself. -/ +theorem le_totient_mul_card_divisors (n : ℕ) (hn : 0 < n) : + n ≤ n.totient * n.divisors.card := by + calc + n = ∑ d ∈ n.divisors, d.totient := (Nat.sum_totient n).symm + _ ≤ + ∑ _d ∈ n.divisors, n.totient := by + apply Finset.sum_le_sum + intro d hd + exact Nat.le_of_dvd (Nat.totient_pos.mpr hn) + (Nat.totient_dvd_of_dvd (Nat.dvd_of_mem_divisors hd)) + _ = n.totient * n.divisors.card := by + simp [Nat.mul_comm] + +/-- The elementary lower envelope for the Möbius main term used in the endgame. -/ +theorem fieldCard_div_fixed_mul_divisors_le_primitiveTraceMoebiusMainTerm + (groupOrder fieldCard fixedExponent : ℕ) + (hgroup : 0 < groupOrder) (hfixed : 0 < fixedExponent) : + (fieldCard : ℝ) / + ((fixedExponent : ℝ) * (groupOrder.divisors.card : ℝ)) ≤ + primitiveTraceMoebiusMainTerm groupOrder fieldCard fixedExponent := by + rw [primitiveTraceMoebiusMainTerm_eq_totient + groupOrder fieldCard fixedExponent hgroup hfixed] + have hdivisors : 0 < groupOrder.divisors.card := + (Nat.nonempty_divisors.mpr hgroup.ne').card_pos + have hfixedReal : (0 : ℝ) < fixedExponent := by exact_mod_cast hfixed + have hgroupReal : (0 : ℝ) < groupOrder := by exact_mod_cast hgroup + have hdivisorsReal : (0 : ℝ) < groupOrder.divisors.card := by exact_mod_cast hdivisors + have htotientBound : + (groupOrder : ℝ) ≤ + (groupOrder.totient : ℝ) * (groupOrder.divisors.card : ℝ) := by + exact_mod_cast le_totient_mul_card_divisors groupOrder hgroup + have hfieldNonnegative : (0 : ℝ) ≤ fieldCard := by positivity + have hratio : + (1 : ℝ) / (groupOrder.divisors.card : ℝ) ≤ + (groupOrder.totient : ℝ) / (groupOrder : ℝ) := by + apply (div_le_div_iff₀ hdivisorsReal hgroupReal).2 + simpa using htotientBound + have hscale : 0 ≤ (fieldCard : ℝ) / (fixedExponent : ℝ) := + div_nonneg hfieldNonnegative hfixedReal.le + calc + (fieldCard : ℝ) / + ((fixedExponent : ℝ) * (groupOrder.divisors.card : ℝ)) = + ((fieldCard : ℝ) / (fixedExponent : ℝ)) * + ((1 : ℝ) / (groupOrder.divisors.card : ℝ)) := by field_simp + _ ≤ ((fieldCard : ℝ) / (fixedExponent : ℝ)) * + ((groupOrder.totient : ℝ) / (groupOrder : ℝ)) := + mul_le_mul_of_nonneg_left hratio hscale + _ = (fieldCard : ℝ) * (groupOrder.totient : ℝ) / + ((fixedExponent : ℝ) * (groupOrder : ℝ)) := by field_simp + +/-- The explicit inequality used after the divisor bound is sufficient for primitive-trace +positivity. -/ +theorem divisorsError_lt_primitiveTraceMoebiusMainTerm_of_explicitInequality + (groupOrder fieldCard fixedExponent coefficient : ℕ) + (hgroup : 0 < groupOrder) (hfixed : 0 < fixedExponent) + (hexplicit : + (fixedExponent : ℝ) * (groupOrder.divisors.card : ℝ) ^ 2 * + ((coefficient : ℝ) * Real.sqrt (fieldCard : ℝ)) < fieldCard) : + (groupOrder.divisors.card : ℝ) * + ((coefficient : ℝ) * Real.sqrt (fieldCard : ℝ)) < + primitiveTraceMoebiusMainTerm groupOrder fieldCard fixedExponent := by + have hlower := + fieldCard_div_fixed_mul_divisors_le_primitiveTraceMoebiusMainTerm + groupOrder fieldCard fixedExponent hgroup hfixed + have hfixedReal : (0 : ℝ) < fixedExponent := by exact_mod_cast hfixed + have hdivisorsReal : (0 : ℝ) < groupOrder.divisors.card := by + exact_mod_cast (Nat.nonempty_divisors.mpr hgroup.ne').card_pos + apply lt_of_lt_of_le ?_ hlower + apply (lt_div_iff₀ (mul_pos hfixedReal hdivisorsReal)).2 + calc + (groupOrder.divisors.card : ℝ) * + ((coefficient : ℝ) * Real.sqrt (fieldCard : ℝ)) * + ((fixedExponent : ℝ) * (groupOrder.divisors.card : ℝ)) = + (fixedExponent : ℝ) * (groupOrder.divisors.card : ℝ) ^ 2 * + ((coefficient : ℝ) * Real.sqrt (fieldCard : ℝ)) := by ring + _ < fieldCard := hexplicit + +/-- Uniformly for large `p`, an orbit exponent at most `p^(1/2-δ)` satisfies the explicit +primitive-trace inequality. This is the asymptotic calculation behind the last sentence after +published equation (36). -/ +theorem eventually_endgamePrimitiveTrace_explicitInequality + (coefficient : ℕ) {δ : ℝ} (hδ : 0 < δ) : + ∀ᶠ p : ℕ in atTop, ∀ orbitExponent : ℕ, + (orbitExponent : ℝ) ≤ (p : ℝ) ^ ((1 : ℝ) / 2 - δ) → + (orbitExponent : ℝ) * ((p - 1).divisors.card : ℝ) ^ 2 * + ((coefficient : ℝ) * Real.sqrt (p : ℝ)) < p := by + let ε : ℝ := δ / 8 + have hε : 0 < ε := by dsimp [ε]; positivity + obtain ⟨divisorThreshold, hDivisorThreshold⟩ := + BGS.NumberTheory.exists_threshold_card_divisors_le_rpow hε + have hExponent : 1 - δ + 2 * ε < 1 := by + dsimp [ε] + linarith + have hDominance : + ∀ᶠ p : ℕ in atTop, + (coefficient : ℝ) * (p : ℝ) ^ (1 - δ + 2 * ε) < (p : ℝ) ^ (1 : ℝ) := + eventually_const_mul_rpow_lt_rpow hExponent + filter_upwards [hDominance, eventually_ge_atTop (divisorThreshold + 1), + eventually_ge_atTop 1] with p hDominance hpThreshold hpOne + intro orbitExponent horbit + have hpMinusThreshold : divisorThreshold ≤ p - 1 := by omega + have hDivisorRaw := hDivisorThreshold (p - 1) hpMinusThreshold + have hpRealPos : (0 : ℝ) < p := by exact_mod_cast (show 0 < p by omega) + have hpRealNonnegative : (0 : ℝ) ≤ p := hpRealPos.le + have hpMinusLe : (((p - 1 : ℕ) : ℝ)) ≤ (p : ℝ) := by exact_mod_cast Nat.sub_le p 1 + have hDivisorPower : (((p - 1 : ℕ) : ℝ)) ^ ε ≤ (p : ℝ) ^ ε := + Real.rpow_le_rpow (Nat.cast_nonneg _) hpMinusLe hε.le + have hDivisor : ((p - 1).divisors.card : ℝ) ≤ (p : ℝ) ^ ε := + hDivisorRaw.trans hDivisorPower + have hCoefficientNonnegative : (0 : ℝ) ≤ coefficient := by positivity + have hOrbitNonnegative : (0 : ℝ) ≤ orbitExponent := by positivity + have hDivisorNonnegative : (0 : ℝ) ≤ (p - 1).divisors.card := by positivity + have hPowerIdentity : + (p : ℝ) ^ ((1 : ℝ) / 2 - δ) * ((p : ℝ) ^ ε) ^ 2 * + Real.sqrt (p : ℝ) = + (p : ℝ) ^ (1 - δ + 2 * ε) := by + rw [Real.sqrt_eq_rpow] + rw [← Real.rpow_mul_natCast hpRealNonnegative ε 2] + rw [← Real.rpow_add hpRealPos, ← Real.rpow_add hpRealPos] + congr 1 + ring + calc + (orbitExponent : ℝ) * ((p - 1).divisors.card : ℝ) ^ 2 * + ((coefficient : ℝ) * Real.sqrt (p : ℝ)) = + (coefficient : ℝ) * + ((orbitExponent : ℝ) * ((p - 1).divisors.card : ℝ) ^ 2 * + Real.sqrt (p : ℝ)) := by ring + _ ≤ (coefficient : ℝ) * + ((p : ℝ) ^ ((1 : ℝ) / 2 - δ) * ((p : ℝ) ^ ε) ^ 2 * + Real.sqrt (p : ℝ)) := by + gcongr + _ = (coefficient : ℝ) * (p : ℝ) ^ (1 - δ + 2 * ε) := by + rw [hPowerIdentity] + _ < (p : ℝ) ^ (1 : ℝ) := hDominance + _ = p := by simp + +/-- Threshold form of `eventually_endgamePrimitiveTrace_explicitInequality`. -/ +theorem exists_threshold_endgamePrimitiveTrace_explicitInequality + (coefficient : ℕ) {δ : ℝ} (hδ : 0 < δ) : + ∃ threshold : ℕ, ∀ p : ℕ, threshold ≤ p → ∀ orbitExponent : ℕ, + (orbitExponent : ℝ) ≤ (p : ℝ) ^ ((1 : ℝ) / 2 - δ) → + (orbitExponent : ℝ) * ((p - 1).divisors.card : ℝ) ^ 2 * + ((coefficient : ℝ) * Real.sqrt (p : ℝ)) < p := + eventually_atTop.mp (eventually_endgamePrimitiveTrace_explicitInequality coefficient hδ) + +/-- A large orbit order gives the upper bound on its complementary power exponent used by the +primitive-trace asymptotic. -/ +theorem orbitExponent_le_rpow_of_mul_order_eq_card_sub_one + (p orbitExponent orbitOrder : ℕ) {δ : ℝ} (hp : 0 < p) + (hmul : orbitExponent * orbitOrder = p - 1) + (horder : (p : ℝ) ^ ((1 : ℝ) / 2 + δ) ≤ orbitOrder) : + (orbitExponent : ℝ) ≤ (p : ℝ) ^ ((1 : ℝ) / 2 - δ) := by + have hpRealPos : (0 : ℝ) < p := by exact_mod_cast hp + have horderPositive : (0 : ℝ) < orbitOrder := + (Real.rpow_pos_of_pos hpRealPos _).trans_le horder + have hmulReal : + (orbitExponent : ℝ) * (orbitOrder : ℝ) = ((p - 1 : ℕ) : ℝ) := by + exact_mod_cast hmul + have hproductLe : + (orbitExponent : ℝ) * (orbitOrder : ℝ) ≤ (p : ℝ) := by + rw [hmulReal] + exact_mod_cast Nat.sub_le p 1 + have horbitExponentLe : + (orbitExponent : ℝ) ≤ (p : ℝ) / (orbitOrder : ℝ) := + (le_div_iff₀ horderPositive).2 hproductLe + calc + (orbitExponent : ℝ) ≤ (p : ℝ) / (orbitOrder : ℝ) := horbitExponentLe + _ ≤ (p : ℝ) / ((p : ℝ) ^ ((1 : ℝ) / 2 + δ)) := by + exact div_le_div_of_nonneg_left (Nat.cast_nonneg p) + (Real.rpow_pos_of_pos hpRealPos _) + horder + _ = (p : ℝ) ^ (1 : ℝ) / ((p : ℝ) ^ ((1 : ℝ) / 2 + δ)) := by + rw [Real.rpow_one] + _ = (p : ℝ) ^ ((1 : ℝ) - ((1 : ℝ) / 2 + δ)) := + (Real.rpow_sub hpRealPos (1 : ℝ) ((1 : ℝ) / 2 + δ)).symm + _ = (p : ℝ) ^ ((1 : ℝ) / 2 - δ) := by + congr 1 + ring + +/-- In the nonsplit torus, whose order is `p + 1`, a large orbit gives the same complementary +exponent bound up to the harmless fixed factor two. -/ +theorem orbitExponent_le_two_mul_rpow_of_mul_order_eq_card_add_one + (p orbitExponent orbitOrder : ℕ) {δ : ℝ} (hp : 0 < p) + (hmul : orbitExponent * orbitOrder = p + 1) + (horder : (p : ℝ) ^ ((1 : ℝ) / 2 + δ) ≤ orbitOrder) : + (orbitExponent : ℝ) ≤ 2 * (p : ℝ) ^ ((1 : ℝ) / 2 - δ) := by + have hpRealPos : (0 : ℝ) < p := by exact_mod_cast hp + have horderPositive : (0 : ℝ) < orbitOrder := + (Real.rpow_pos_of_pos hpRealPos _).trans_le horder + have hmulReal : + (orbitExponent : ℝ) * (orbitOrder : ℝ) = ((p + 1 : ℕ) : ℝ) := by + exact_mod_cast hmul + have hproductLe : + (orbitExponent : ℝ) * (orbitOrder : ℝ) ≤ 2 * (p : ℝ) := by + rw [hmulReal] + exact_mod_cast (show p + 1 ≤ 2 * p by omega) + have horbitExponentLe : + (orbitExponent : ℝ) ≤ (2 * (p : ℝ)) / (orbitOrder : ℝ) := + (le_div_iff₀ horderPositive).2 hproductLe + calc + (orbitExponent : ℝ) ≤ (2 * (p : ℝ)) / (orbitOrder : ℝ) := horbitExponentLe + _ ≤ (2 * (p : ℝ)) / ((p : ℝ) ^ ((1 : ℝ) / 2 + δ)) := by + exact div_le_div_of_nonneg_left (by positivity) + (Real.rpow_pos_of_pos hpRealPos _) horder + _ = 2 * ((p : ℝ) / ((p : ℝ) ^ ((1 : ℝ) / 2 + δ))) := by ring + _ = 2 * ((p : ℝ) ^ ((1 : ℝ) / 2 - δ)) := by + congr 1 + calc + (p : ℝ) / ((p : ℝ) ^ ((1 : ℝ) / 2 + δ)) = + (p : ℝ) ^ (1 : ℝ) / + ((p : ℝ) ^ ((1 : ℝ) / 2 + δ)) := by rw [Real.rpow_one] + _ = (p : ℝ) ^ ((1 : ℝ) - ((1 : ℝ) / 2 + δ)) := + (Real.rpow_sub hpRealPos (1 : ℝ) ((1 : ℝ) / 2 + δ)).symm + _ = (p : ℝ) ^ ((1 : ℝ) / 2 - δ) := by + congr 1 + ring + +/-- Nonsplit threshold form: a complementary exponent in the norm-one torus of order `p + 1` +satisfies the same primitive-trace inequality for all sufficiently large `p`. -/ +theorem exists_threshold_endgamePrimitiveTrace_explicitInequality_of_largeNonsplitOrder + (coefficient : ℕ) {δ : ℝ} (hδ : 0 < δ) : + ∃ threshold : ℕ, ∀ p : ℕ, threshold ≤ p → + ∀ orbitExponent orbitOrder : ℕ, + orbitExponent * orbitOrder = p + 1 → + (p : ℝ) ^ ((1 : ℝ) / 2 + δ) ≤ orbitOrder → + (orbitExponent : ℝ) * ((p - 1).divisors.card : ℝ) ^ 2 * + ((coefficient : ℝ) * Real.sqrt (p : ℝ)) < p := by + have hhalfδ : 0 < δ / 2 := by linarith + obtain ⟨inequalityThreshold, hInequality⟩ := + exists_threshold_endgamePrimitiveTrace_explicitInequality coefficient hhalfδ + have hexponents : (1 : ℝ) / 2 - δ < (1 : ℝ) / 2 - δ / 2 := by linarith + have hAbsorb : + ∀ᶠ p : ℕ in atTop, + 2 * (p : ℝ) ^ ((1 : ℝ) / 2 - δ) < + (p : ℝ) ^ ((1 : ℝ) / 2 - δ / 2) := + eventually_const_mul_rpow_lt_rpow hexponents + obtain ⟨absorbThreshold, hAbsorbThreshold⟩ := eventually_atTop.mp hAbsorb + refine ⟨max (max inequalityThreshold absorbThreshold) 1, ?_⟩ + intro p hp orbitExponent orbitOrder hmul horder + have hpInequality : inequalityThreshold ≤ p := + (le_max_left inequalityThreshold absorbThreshold).trans + ((le_max_left (max inequalityThreshold absorbThreshold) 1).trans hp) + have hpAbsorb : absorbThreshold ≤ p := + (le_max_right inequalityThreshold absorbThreshold).trans + ((le_max_left (max inequalityThreshold absorbThreshold) 1).trans hp) + have hpPositive : 0 < p := by omega + apply hInequality p hpInequality orbitExponent + exact (orbitExponent_le_two_mul_rpow_of_mul_order_eq_card_add_one + p orbitExponent orbitOrder hpPositive hmul horder).trans + (hAbsorbThreshold p hpAbsorb).le + +/-- Threshold form directly in terms of the large orbit order and its complementary exponent. -/ +theorem exists_threshold_endgamePrimitiveTrace_explicitInequality_of_largeOrder + (coefficient : ℕ) {δ : ℝ} (hδ : 0 < δ) : + ∃ threshold : ℕ, ∀ p : ℕ, threshold ≤ p → + ∀ orbitExponent orbitOrder : ℕ, + orbitExponent * orbitOrder = p - 1 → + (p : ℝ) ^ ((1 : ℝ) / 2 + δ) ≤ orbitOrder → + (orbitExponent : ℝ) * ((p - 1).divisors.card : ℝ) ^ 2 * + ((coefficient : ℝ) * Real.sqrt (p : ℝ)) < p := by + obtain ⟨threshold, hthreshold⟩ := + exists_threshold_endgamePrimitiveTrace_explicitInequality coefficient hδ + refine ⟨max threshold 1, ?_⟩ + intro p hp orbitExponent orbitOrder hmul horder + have hpThreshold : threshold ≤ p := (le_max_left threshold 1).trans hp + have hpPositive : 0 < p := by omega + exact hthreshold p hpThreshold orbitExponent + (orbitExponent_le_rpow_of_mul_order_eq_card_sub_one + p orbitExponent orbitOrder hpPositive hmul horder) + +/-- A numerical main-term domination criterion turns a point-count envelope into nonemptiness. -/ +theorem finset_nonempty_of_card_error_le_and_error_lt_main + {α : Type*} (s : Finset α) (mainTerm error : ℝ) + (henvelope : |(s.card : ℝ) - mainTerm| ≤ error) + (hpositive : error < mainTerm) : s.Nonempty := by + apply Finset.card_pos.mp + have hlower : mainTerm - (s.card : ℝ) ≤ |(s.card : ℝ) - mainTerm| := by + simpa only [neg_sub] using neg_le_abs ((s.card : ℝ) - mainTerm) + have hcardReal : (0 : ℝ) < s.card := by linarith + exact_mod_cast hcardReal + +section SplitApplication + +/-- Split trace coincidences with the orbit coordinate in the fixed power image and the other +coordinate primitive in the full base-field multiplicative group. -/ +abbrev splitPrimitiveTraceSolutions + (p : ℕ) [Fact p.Prime] + (alpha beta : ZMod p) (orbitExponent : ℕ) := + traceExactOrderSolutions + (weightedSplitTorusTrace alpha beta) + (splitTorusTrace : (ZMod p)ˣ → ZMod p) + orbitExponent (Nat.card (ZMod p)ˣ) + +/-- Published equation (36) for the split branch, with every error and multiplicity supplied by +the preceding formal interfaces. -/ +theorem splitPrimitiveTraceSolutions_card_error_le_of_weilBoundAssumption + (p : ℕ) [Fact p.Prime] + (coefficient : ℕ) (hWeil : WeightedSplitTraceWeilBoundAssumption coefficient) + (alpha beta : ZMod p) (orbitExponent : ℕ) + (halpha : alpha ≠ 0) (hbeta : beta ≠ 0) (hnondegenerate : alpha * beta ≠ 1) + (horbitPositive : 0 < orbitExponent) + (horbitChar : (orbitExponent : ZMod p) ≠ 0) + (horbitDvd : orbitExponent ∣ Nat.card (ZMod p)ˣ) : + |((splitPrimitiveTraceSolutions p alpha beta orbitExponent).card : ℝ) - + primitiveTraceMoebiusMainTerm + (Nat.card (ZMod p)ˣ) p orbitExponent| ≤ + ((Nat.card (ZMod p)ˣ).divisors.card : ℝ) * + ((coefficient : ℝ) * Real.sqrt (p : ℝ)) := by + have hRange : ∀ d : ℕ, d ∣ Nat.card (ZMod p)ˣ → 0 < d → + |(Nat.card (powerTraceRangeSolutions + (weightedSplitTorusTrace alpha beta) + (splitTorusTrace : (ZMod p)ˣ → ZMod p) orbitExponent d) : ℝ) - + (p : ℝ) / ((d : ℝ) * (orbitExponent : ℝ))| ≤ + (coefficient : ℝ) * Real.sqrt (p : ℝ) := by + intro d hdvd hd + have hestimate := + splitTracePowerRangeSolutions_count_error_le_of_weilBoundAssumption + (ZMod p) coefficient hWeil alpha beta d orbitExponent + halpha hbeta hnondegenerate hd horbitPositive horbitChar hdvd horbitDvd + rw [natCard_powerTraceRangeSolutions_swap + (weightedSplitTorusTrace alpha beta) + (splitTorusTrace : (ZMod p)ˣ → ZMod p) orbitExponent d] + simpa [ZMod.card] using hestimate + simpa [splitPrimitiveTraceSolutions, primitiveTraceMoebiusMainTerm] using + traceExactOrderSolutions_card_error_le_moebiusMain + (weightedSplitTorusTrace alpha beta) + (splitTorusTrace : (ZMod p)ˣ → ZMod p) + orbitExponent + (fun d => (p : ℝ) / ((d : ℝ) * (orbitExponent : ℝ))) + ((coefficient : ℝ) * Real.sqrt (p : ℝ)) hRange + +/-- Once the explicit Möbius main term dominates the accumulated Weil errors, an actual split +primitive trace pair exists. -/ +theorem splitPrimitiveTraceSolutions_nonempty_of_moebiusMain_gt_divisorsError + (p : ℕ) [Fact p.Prime] + (coefficient : ℕ) (hWeil : WeightedSplitTraceWeilBoundAssumption coefficient) + (alpha beta : ZMod p) (orbitExponent : ℕ) + (halpha : alpha ≠ 0) (hbeta : beta ≠ 0) (hnondegenerate : alpha * beta ≠ 1) + (horbitPositive : 0 < orbitExponent) + (horbitChar : (orbitExponent : ZMod p) ≠ 0) + (horbitDvd : orbitExponent ∣ Nat.card (ZMod p)ˣ) + (hmain : + ((Nat.card (ZMod p)ˣ).divisors.card : ℝ) * + ((coefficient : ℝ) * Real.sqrt (p : ℝ)) < + primitiveTraceMoebiusMainTerm + (Nat.card (ZMod p)ˣ) p orbitExponent) : + (splitPrimitiveTraceSolutions p alpha beta orbitExponent).Nonempty := by + apply finset_nonempty_of_card_error_le_and_error_lt_main + (splitPrimitiveTraceSolutions p alpha beta orbitExponent) + (primitiveTraceMoebiusMainTerm (Nat.card (ZMod p)ˣ) p orbitExponent) + (((Nat.card (ZMod p)ˣ).divisors.card : ℝ) * + ((coefficient : ℝ) * Real.sqrt (p : ℝ))) + · exact splitPrimitiveTraceSolutions_card_error_le_of_weilBoundAssumption + p coefficient hWeil alpha beta orbitExponent halpha hbeta hnondegenerate + horbitPositive horbitChar horbitDvd + · exact hmain + +/-- The fully numerical split inclusion--exclusion criterion produces a primitive trace pair. -/ +theorem exists_splitPrimitiveTracePair_of_explicitInequality + (p : ℕ) [Fact p.Prime] + (coefficient : ℕ) (hWeil : WeightedSplitTraceWeilBoundAssumption coefficient) + (alpha beta : ZMod p) (orbitExponent : ℕ) + (halpha : alpha ≠ 0) (hbeta : beta ≠ 0) (hnondegenerate : alpha * beta ≠ 1) + (horbitPositive : 0 < orbitExponent) + (horbitChar : (orbitExponent : ZMod p) ≠ 0) + (horbitDvd : orbitExponent ∣ Nat.card (ZMod p)ˣ) + (hexplicit : + (orbitExponent : ℝ) * ((Nat.card (ZMod p)ˣ).divisors.card : ℝ) ^ 2 * + ((coefficient : ℝ) * Real.sqrt (p : ℝ)) < p) : + ∃ z : (powMonoidHom orbitExponent : (ZMod p)ˣ →* (ZMod p)ˣ).range × (ZMod p)ˣ, + weightedSplitTorusTrace alpha beta z.1 = splitTorusTrace z.2 ∧ + orderOf z.2 = Nat.card (ZMod p)ˣ := by + have hmain := + divisorsError_lt_primitiveTraceMoebiusMainTerm_of_explicitInequality + (Nat.card (ZMod p)ˣ) p orbitExponent coefficient + Nat.card_pos horbitPositive hexplicit + obtain ⟨z, hz⟩ := + splitPrimitiveTraceSolutions_nonempty_of_moebiusMain_gt_divisorsError + p coefficient hWeil alpha beta orbitExponent halpha hbeta hnondegenerate + horbitPositive horbitChar horbitDvd hmain + exact ⟨z, (mem_traceExactOrderSolutions_iff + (weightedSplitTorusTrace alpha beta) + (splitTorusTrace : (ZMod p)ˣ → ZMod p) + orbitExponent (Nat.card (ZMod p)ˣ) z).mp hz⟩ + +end SplitApplication + +section NonsplitApplication + +/-- Corrected seeded nonsplit trace coincidences with primitive base-field right coordinate. -/ +abbrev existingConicSeedNonsplitPrimitiveTraceSolutions + (p : ℕ) [Fact p.Prime] + (t : ZMod p) (ht : t ^ 2 ≠ 4) (ht0 : t ≠ 0) + (s : ↥(quadraticConicNormFiber p t ht ht0)) + (orbitExponent : ℕ) := + traceExactOrderSolutions + (existingConicSeedNonsplitTorusTrace p t ht ht0 s) + (splitTorusTrace : (ZMod p)ˣ → ZMod p) + orbitExponent (Nat.card (ZMod p)ˣ) + +/-- Published equation (36) for the corrected seeded nonsplit branch. -/ +theorem existingConicSeedNonsplitPrimitiveTraceSolutions_card_error_le_of_weilBoundAssumption + (p : ℕ) [Fact p.Prime] + (coefficient : ℕ) (hWeil : SeededNonsplitTraceWeilBoundAssumption coefficient) + (hpTwo : p ≠ 2) + (t : ZMod p) (ht : t ^ 2 ≠ 4) (ht0 : t ≠ 0) + (s : ↥(quadraticConicNormFiber p t ht ht0)) + (orbitExponent : ℕ) (horbitPositive : 0 < orbitExponent) + (horbitChar : (orbitExponent : quadraticFiniteField p) ≠ 0) + (horbitDvd : orbitExponent ∣ Nat.card (quadraticNormOneTorus p)) : + |((existingConicSeedNonsplitPrimitiveTraceSolutions + p t ht ht0 s orbitExponent).card : ℝ) - + primitiveTraceMoebiusMainTerm + (Nat.card (ZMod p)ˣ) p orbitExponent| ≤ + ((Nat.card (ZMod p)ˣ).divisors.card : ℝ) * + ((coefficient : ℝ) * Real.sqrt (p : ℝ)) := by + have hRange : ∀ e : ℕ, e ∣ Nat.card (ZMod p)ˣ → 0 < e → + |(Nat.card (powerTraceRangeSolutions + (existingConicSeedNonsplitTorusTrace p t ht ht0 s) + (splitTorusTrace : (ZMod p)ˣ → ZMod p) orbitExponent e) : ℝ) - + (p : ℝ) / ((e : ℝ) * (orbitExponent : ℝ))| ≤ + (coefficient : ℝ) * Real.sqrt (p : ℝ) := by + intro e hedvd he + have hestimate := + existingConicSeedNonsplitPowerRangeSolutions_count_error_le_of_weilBoundAssumption + p coefficient hWeil hpTwo t ht ht0 s orbitExponent e + horbitPositive he horbitChar horbitDvd hedvd + simpa [mul_comm] using hestimate + simpa [existingConicSeedNonsplitPrimitiveTraceSolutions, + primitiveTraceMoebiusMainTerm] using + traceExactOrderSolutions_card_error_le_moebiusMain + (existingConicSeedNonsplitTorusTrace p t ht ht0 s) + (splitTorusTrace : (ZMod p)ˣ → ZMod p) + orbitExponent + (fun e => (p : ℝ) / ((e : ℝ) * (orbitExponent : ℝ))) + ((coefficient : ℝ) * Real.sqrt (p : ℝ)) hRange + +/-- Numerical main-term domination produces an actual primitive base-field trace pair in the +corrected nonsplit branch. -/ +theorem existingConicSeedNonsplitPrimitiveTraceSolutions_nonempty_of_moebiusMain_gt_divisorsError + (p : ℕ) [Fact p.Prime] + (coefficient : ℕ) (hWeil : SeededNonsplitTraceWeilBoundAssumption coefficient) + (hpTwo : p ≠ 2) + (t : ZMod p) (ht : t ^ 2 ≠ 4) (ht0 : t ≠ 0) + (s : ↥(quadraticConicNormFiber p t ht ht0)) + (orbitExponent : ℕ) (horbitPositive : 0 < orbitExponent) + (horbitChar : (orbitExponent : quadraticFiniteField p) ≠ 0) + (horbitDvd : orbitExponent ∣ Nat.card (quadraticNormOneTorus p)) + (hmain : + ((Nat.card (ZMod p)ˣ).divisors.card : ℝ) * + ((coefficient : ℝ) * Real.sqrt (p : ℝ)) < + primitiveTraceMoebiusMainTerm + (Nat.card (ZMod p)ˣ) p orbitExponent) : + (existingConicSeedNonsplitPrimitiveTraceSolutions + p t ht ht0 s orbitExponent).Nonempty := by + apply finset_nonempty_of_card_error_le_and_error_lt_main + (existingConicSeedNonsplitPrimitiveTraceSolutions + p t ht ht0 s orbitExponent) + (primitiveTraceMoebiusMainTerm (Nat.card (ZMod p)ˣ) p orbitExponent) + (((Nat.card (ZMod p)ˣ).divisors.card : ℝ) * + ((coefficient : ℝ) * Real.sqrt (p : ℝ))) + · exact + existingConicSeedNonsplitPrimitiveTraceSolutions_card_error_le_of_weilBoundAssumption + p coefficient hWeil hpTwo t ht ht0 s orbitExponent + horbitPositive horbitChar horbitDvd + · exact hmain + +/-- The fully numerical nonsplit inclusion--exclusion criterion produces a primitive base-field +trace pair on the corrected seeded norm-one orbit. -/ +theorem exists_existingConicSeedNonsplitPrimitiveTracePair_of_explicitInequality + (p : ℕ) [Fact p.Prime] + (coefficient : ℕ) (hWeil : SeededNonsplitTraceWeilBoundAssumption coefficient) + (hpTwo : p ≠ 2) + (t : ZMod p) (ht : t ^ 2 ≠ 4) (ht0 : t ≠ 0) + (s : ↥(quadraticConicNormFiber p t ht ht0)) + (orbitExponent : ℕ) (horbitPositive : 0 < orbitExponent) + (horbitChar : (orbitExponent : quadraticFiniteField p) ≠ 0) + (horbitDvd : orbitExponent ∣ Nat.card (quadraticNormOneTorus p)) + (hexplicit : + (orbitExponent : ℝ) * ((Nat.card (ZMod p)ˣ).divisors.card : ℝ) ^ 2 * + ((coefficient : ℝ) * Real.sqrt (p : ℝ)) < p) : + ∃ z : (powMonoidHom orbitExponent : + quadraticNormOneTorus p →* quadraticNormOneTorus p).range × (ZMod p)ˣ, + existingConicSeedNonsplitTorusTrace p t ht ht0 s z.1 = splitTorusTrace z.2 ∧ + orderOf z.2 = Nat.card (ZMod p)ˣ := by + have hmain := + divisorsError_lt_primitiveTraceMoebiusMainTerm_of_explicitInequality + (Nat.card (ZMod p)ˣ) p orbitExponent coefficient + Nat.card_pos horbitPositive hexplicit + obtain ⟨z, hz⟩ := + existingConicSeedNonsplitPrimitiveTraceSolutions_nonempty_of_moebiusMain_gt_divisorsError + p coefficient hWeil hpTwo t ht ht0 s orbitExponent + horbitPositive horbitChar horbitDvd hmain + exact ⟨z, (mem_traceExactOrderSolutions_iff + (existingConicSeedNonsplitTorusTrace p t ht ht0 s) + (splitTorusTrace : (ZMod p)ˣ → ZMod p) + orbitExponent (Nat.card (ZMod p)ˣ) z).mp hz⟩ + +end NonsplitApplication + +end + + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Endgame/PrimitiveOrbitWiring.lean b/LeanPool/MarkoffModP/BGS/Markoff/Endgame/PrimitiveOrbitWiring.lean new file mode 100644 index 0000000000..77154013c1 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Endgame/PrimitiveOrbitWiring.lean @@ -0,0 +1,433 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Endgame.PrimitiveInclusionExclusion +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.MoveWiring + +/-! +# Transporting primitive trace pairs back to rotation orbits + +The endgame count returns an element of a complementary power-map image. The rotation +parametrizations use the cyclic subgroup generated by the rotation eigenvalue. This file +proves the exact transport between those two representations in the split and nonsplit cases. +-/ + +@[expose] public section + +namespace BGS.Markoff + +noncomputable section + +theorem complementaryExponent_pos + {G : Type*} [Group G] [Finite G] (w : G) : + 0 < Nat.card G / orderOf w := by + exact Nat.div_pos (Nat.le_of_dvd Nat.card_pos (orderOf_dvd_natCard w)) (orderOf_pos w) + +theorem complementaryExponent_dvd_natCard + {G : Type*} [Group G] [Finite G] (w : G) : + Nat.card G / orderOf w ∣ Nat.card G := + Nat.div_dvd_of_dvd (orderOf_dvd_natCard w) + +theorem splitComplementaryExponent_cast_ne_zero + (p : ℕ) [Fact p.Prime] (w : (ZMod p)ˣ) : + ((Nat.card (ZMod p)ˣ / orderOf w : ℕ) : ZMod p) ≠ 0 := by + intro hzero + have hpDvd := (CharP.cast_eq_zero_iff (ZMod p) p _).mp hzero + have hcard : Nat.card (ZMod p)ˣ = p - 1 := by + rw [Nat.card_units, Nat.card_zmod] + rw [hcard] at hpDvd + have heDvd := complementaryExponent_dvd_natCard w + rw [hcard] at heDvd + have hpSub : p ∣ p - 1 := hpDvd.trans heDvd + have hpPrime : p.Prime := Fact.out + have hpTwo : 2 ≤ p := hpPrime.two_le + exact (Nat.not_dvd_of_pos_of_lt (by omega) (by omega)) hpSub + +theorem nonsplitComplementaryExponent_cast_ne_zero + (p : ℕ) [Fact p.Prime] (w : quadraticNormOneTorus p) : + ((Nat.card (quadraticNormOneTorus p) / orderOf w : ℕ) : + quadraticFiniteField p) ≠ 0 := by + intro hzero + have hpDvd := (CharP.cast_eq_zero_iff (quadraticFiniteField p) p _).mp hzero + rw [quadraticNormOneTorus_natCard] at hpDvd + have heDvd := complementaryExponent_dvd_natCard w + rw [quadraticNormOneTorus_natCard] at heDvd + have hpAdd : p ∣ p + 1 := hpDvd.trans heDvd + have hpOne : p ∣ 1 := by + apply (Nat.dvd_add_iff_left (dvd_refl p)).mpr + simpa [add_comm] using hpAdd + exact (Fact.out : p.Prime).ne_one (Nat.dvd_one.mp hpOne) + +/-- A point in the complementary power-map image is reached by a natural power of the element +whose order defines the complementary exponent. -/ +theorem exists_pow_eq_of_mem_complementaryPowerRange + {G : Type*} [CommGroup G] [Finite G] [IsCyclic G] + (w : G) + (h : (powMonoidHom (Nat.card G / orderOf w) : G →* G).range) : + ∃ n : ℕ, w ^ n = h.1 := by + have hhZpowers : h.1 ∈ Subgroup.zpowers w := by + rw [← powMonoidHom_range_eq_zpowers_of_complementaryOrder w] + exact h.2 + have hhPowers : h.1 ∈ Submonoid.powers w := + mem_powers_iff_mem_zpowers.mpr hhZpowers + exact (Submonoid.mem_powers_iff h.1 w).mp hhPowers + +/-- Split transport: every parameter returned by the primitive count is an actual forward +iterate of the starting split-fiber point. -/ +theorem exists_iterate_splitFiberPoint_eq_of_mem_complementaryPowerRange + {F : Type*} [Field F] [Finite F] [IsCyclic Fˣ] + (w s : Fˣ) + (h : (powMonoidHom (Nat.card Fˣ / orderOf w) : Fˣ →* Fˣ).range) : + ∃ n : ℕ, + (normalizedRotate1^[n]) (splitFiberPoint w s) = + splitFiberPoint w (s * h.1) := by + obtain ⟨n, hn⟩ := exists_pow_eq_of_mem_complementaryPowerRange w h + refine ⟨n, ?_⟩ + rw [iterate_normalizedRotate1_splitFiberPoint, hn] + +/-- The split primitive-count theorem, with its power-image output transported all the way to +an actual forward rotation iterate. Only the explicit Weil estimate and its arithmetic +hypotheses remain as inputs. -/ +theorem exists_iterate_splitFiberPoint_with_primitive_secondTrace + (p : ℕ) [Fact p.Prime] + (coefficient : ℕ) (hWeil : WeightedSplitTraceWeilBoundAssumption coefficient) + (hpTwo : p ≠ 2) (w s : (ZMod p)ˣ) + (hw : (w : ZMod p) ^ 2 ≠ 1) + (htrace : splitTorusTrace w ≠ 0) + (horbitPositive : 0 < Nat.card (ZMod p)ˣ / orderOf w) + (horbitChar : ((Nat.card (ZMod p)ˣ / orderOf w : ℕ) : ZMod p) ≠ 0) + (horbitDvd : Nat.card (ZMod p)ˣ / orderOf w ∣ Nat.card (ZMod p)ˣ) + (hexplicit : + ((Nat.card (ZMod p)ˣ / orderOf w : ℕ) : ℝ) * + ((Nat.card (ZMod p)ˣ).divisors.card : ℝ) ^ 2 * + ((coefficient : ℝ) * Real.sqrt (p : ℝ)) < p) : + ∃ n : ℕ, ∃ u : (ZMod p)ˣ, + ((normalizedRotate1^[n]) (splitFiberPoint w s)).u2 = splitTorusTrace u ∧ + orderOf u = Nat.card (ZMod p)ˣ := by + let orbitExponent := Nat.card (ZMod p)ˣ / orderOf w + let alpha : ZMod p := s + let beta : ZMod p := splitFiberProduct w * ((s⁻¹ : (ZMod p)ˣ) : ZMod p) + have ht : splitTorusTrace w ^ 2 ≠ 4 := by + apply sub_ne_zero.mp + rw [splitTorusTrace_sq_sub_four] + exact pow_ne_zero 2 (splitEigenvalueDifference_ne_zero w hw) + have hproductNe : splitFiberProduct w ≠ 1 := by + simpa [splitFiberProduct, quadraticFiberProduct] using + quadraticFiberProduct_ne_one_of_prime_ne_two p hpTwo (splitTorusTrace w) ht + have halpha : alpha ≠ 0 := Units.ne_zero s + have hbeta : beta ≠ 0 := by + exact mul_ne_zero (splitFiberProduct_ne_zero w hw htrace) (Units.ne_zero s⁻¹) + have hnondegenerate : alpha * beta ≠ 1 := by + change (s : ZMod p) * + (splitFiberProduct w * ((s⁻¹ : (ZMod p)ˣ) : ZMod p)) ≠ 1 + rw [splitFiberOrbit_weights_mul] + exact hproductNe + obtain ⟨z, hzTrace, hzOrder⟩ := + exists_splitPrimitiveTracePair_of_explicitInequality + p coefficient hWeil alpha beta orbitExponent halpha hbeta hnondegenerate + horbitPositive horbitChar horbitDvd (by simpa [orbitExponent] using hexplicit) + obtain ⟨n, hn⟩ := + exists_iterate_splitFiberPoint_eq_of_mem_complementaryPowerRange w s z.1 + refine ⟨n, z.2, ?_, hzOrder⟩ + rw [hn, splitFiberOrbit_secondCoordinate_eq_weightedSplitTorusTrace] + exact hzTrace + +/-- Nonsplit transport: every norm-one parameter returned by the seeded primitive count is an +actual forward iterate of the starting point on the base-field conic. -/ +theorem exists_iterate_quadraticNormFiberPoint_eq_of_mem_complementaryPowerRange + (p : ℕ) [Fact p.Prime] + (t : ZMod p) (ht : t ^ 2 ≠ 4) (ht0 : t ≠ 0) + (w : quadraticNormOneTorus p) (htrace : quadraticNormOneTrace p w = t) + (s : ↥(quadraticConicNormFiber p t ht ht0)) + (h : (powMonoidHom + (Nat.card (quadraticNormOneTorus p) / orderOf w) : + quadraticNormOneTorus p →* quadraticNormOneTorus p).range) : + ∃ n : ℕ, + (normalizedRotate1^[n]) (quadraticNormFiberPoint p t ht ht0 w s) = + quadraticNormFiberPoint p t ht ht0 w + (quadraticNormFiberMulNormOne p + (quadraticFiberProductUnit p t ht ht0) s h.1) := by + obtain ⟨n, hn⟩ := exists_pow_eq_of_mem_complementaryPowerRange w h + refine ⟨n, ?_⟩ + rw [iterate_normalizedRotate1_quadraticNormFiberPoint p t ht ht0 w htrace, hn] + +/-- The seeded trace counted in the nonsplit endgame is exactly the second coordinate of the +corresponding point in the base-field conic parametrization. -/ +theorem existingConicSeedNonsplitTorusTrace_eq_quadraticNormFiberPoint_u2 + (p : ℕ) [Fact p.Prime] + (t : ZMod p) (ht : t ^ 2 ≠ 4) (ht0 : t ≠ 0) + (w : quadraticNormOneTorus p) (htrace : quadraticNormOneTrace p w = t) + (s : ↥(quadraticConicNormFiber p t ht ht0)) + (h : quadraticNormOneTorus p) : + existingConicSeedNonsplitTorusTrace p t ht ht0 s h = + (quadraticNormFiberPoint p t ht ht0 w + (quadraticNormFiberMulNormOne p + (quadraticFiberProductUnit p t ht ht0) s h)).u2 := by + let r := quadraticNormFiberMulNormOne p + (quadraticFiberProductUnit p t ht ht0) s h + apply (algebraMap (ZMod p) (quadraticFiniteField p)).injective + have hpoint := algebraMap_quadraticNormFiberPoint p t ht ht0 w htrace r + have hu2 := congrArg NormalizedPoint.u2 hpoint + change algebraMap (ZMod p) (quadraticFiniteField p) + (quadraticNormFiberPoint p t ht ht0 w r).u2 = + (splitFiberPoint (w : (quadraticFiniteField p)ˣ) r.1).u2 at hu2 + rw [hu2] + rw [existingConicSeedNonsplitTorusTrace, algebraMap_quadraticTrace] + change (r.1 : quadraticFiniteField p) + (r.1 : quadraticFiniteField p) ^ p = + (splitFiberPoint (w : (quadraticFiniteField p)ˣ) r.1).u2 + rw [quadraticNormFiber_frobenius_eq_norm_mul_inv p + (quadraticFiberProductUnit p t ht ht0) r] + simp only [splitFiberPoint] + congr 1 + rw [show ((quadraticFiberProductUnit p t ht ht0 : (ZMod p)ˣ) : ZMod p) = + quadraticFiberProduct p t by rfl] + rw [show algebraMap (ZMod p) (quadraticFiniteField p) + (quadraticFiberProduct p t) = + splitFiberProduct (w : (quadraticFiniteField p)ˣ) by + rw [splitFiberProduct, ← htrace, quadraticFiberProduct, map_div₀, map_sub, + map_pow, map_ofNat, algebraMap_quadraticNormOneTrace]] + simp only [Units.val_inv_eq_inv_val] + +/-- The corrected nonsplit primitive-count theorem, transported to an actual forward iterate +on the base-field conic. -/ +theorem exists_iterate_quadraticNormFiberPoint_with_primitive_secondTrace + (p : ℕ) [Fact p.Prime] + (coefficient : ℕ) (hWeil : SeededNonsplitTraceWeilBoundAssumption coefficient) + (hpTwo : p ≠ 2) + (t : ZMod p) (ht : t ^ 2 ≠ 4) (ht0 : t ≠ 0) + (w : quadraticNormOneTorus p) (htrace : quadraticNormOneTrace p w = t) + (s : ↥(quadraticConicNormFiber p t ht ht0)) + (horbitPositive : + 0 < Nat.card (quadraticNormOneTorus p) / orderOf w) + (horbitChar : + ((Nat.card (quadraticNormOneTorus p) / orderOf w : ℕ) : + quadraticFiniteField p) ≠ 0) + (horbitDvd : + Nat.card (quadraticNormOneTorus p) / orderOf w ∣ + Nat.card (quadraticNormOneTorus p)) + (hexplicit : + ((Nat.card (quadraticNormOneTorus p) / orderOf w : ℕ) : ℝ) * + ((Nat.card (ZMod p)ˣ).divisors.card : ℝ) ^ 2 * + ((coefficient : ℝ) * Real.sqrt (p : ℝ)) < p) : + ∃ n : ℕ, ∃ u : (ZMod p)ˣ, + ((normalizedRotate1^[n]) + (quadraticNormFiberPoint p t ht ht0 w s)).u2 = splitTorusTrace u ∧ + orderOf u = Nat.card (ZMod p)ˣ := by + let orbitExponent := Nat.card (quadraticNormOneTorus p) / orderOf w + obtain ⟨z, hzTrace, hzOrder⟩ := + exists_existingConicSeedNonsplitPrimitiveTracePair_of_explicitInequality + p coefficient hWeil hpTwo t ht ht0 s orbitExponent + horbitPositive horbitChar horbitDvd (by simpa [orbitExponent] using hexplicit) + obtain ⟨n, hn⟩ := + exists_iterate_quadraticNormFiberPoint_eq_of_mem_complementaryPowerRange + p t ht ht0 w htrace s z.1 + refine ⟨n, z.2, ?_, hzOrder⟩ + rw [hn, ← existingConicSeedNonsplitTorusTrace_eq_quadraticNormFiberPoint_u2 + p t ht ht0 w htrace s z.1] + exact hzTrace + +/-- Uniform large-order split endgame, still expressed in the explicit split-fiber +parametrization. -/ +theorem exists_threshold_splitFiberPoint_with_primitive_secondTrace + (coefficient : ℕ) (hWeil : WeightedSplitTraceWeilBoundAssumption coefficient) + {δ : ℝ} (hδ : 0 < δ) : + ∃ threshold : ℕ, ∀ p : ℕ, threshold ≤ p → [Fact p.Prime] → + ∀ (w s : (ZMod p)ˣ), + (w : ZMod p) ^ 2 ≠ 1 → splitTorusTrace w ≠ 0 → + (p : ℝ) ^ ((1 : ℝ) / 2 + δ) ≤ orderOf w → + ∃ n : ℕ, ∃ u : (ZMod p)ˣ, + ((normalizedRotate1^[n]) (splitFiberPoint w s)).u2 = splitTorusTrace u ∧ + orderOf u = Nat.card (ZMod p)ˣ := by + obtain ⟨threshold, hthreshold⟩ := + exists_threshold_endgamePrimitiveTrace_explicitInequality_of_largeOrder + coefficient hδ + refine ⟨max threshold 3, ?_⟩ + intro p hp _ w s hw htrace hlarge + have hpThreshold : threshold ≤ p := (le_max_left threshold 3).trans hp + have hpTwo : p ≠ 2 := by omega + have hcard : Nat.card (ZMod p)ˣ = p - 1 := by + rw [Nat.card_units, Nat.card_zmod] + have hmul := Nat.div_mul_cancel (orderOf_dvd_natCard w) + rw [hcard] at hmul + have hexplicit := hthreshold p hpThreshold + ((p - 1) / orderOf w) (orderOf w) hmul hlarge + have hexplicit' : + ((Nat.card (ZMod p)ˣ / orderOf w : ℕ) : ℝ) * + ((Nat.card (ZMod p)ˣ).divisors.card : ℝ) ^ 2 * + ((coefficient : ℝ) * Real.sqrt (p : ℝ)) < p := by + rw [hcard] + exact hexplicit + exact exists_iterate_splitFiberPoint_with_primitive_secondTrace + p coefficient hWeil hpTwo w s hw htrace + (complementaryExponent_pos w) + (splitComplementaryExponent_cast_ne_zero p w) + (complementaryExponent_dvd_natCard w) hexplicit' + +/-- Uniform large-order nonsplit endgame in the corrected seeded conic parametrization. -/ +theorem exists_threshold_quadraticNormFiberPoint_with_primitive_secondTrace + (coefficient : ℕ) (hWeil : SeededNonsplitTraceWeilBoundAssumption coefficient) + {δ : ℝ} (hδ : 0 < δ) : + ∃ threshold : ℕ, ∀ p : ℕ, threshold ≤ p → [Fact p.Prime] → + ∀ (t : ZMod p) (ht : t ^ 2 ≠ 4) (ht0 : t ≠ 0) + (w : quadraticNormOneTorus p), + quadraticNormOneTrace p w = t → + ∀ s : ↥(quadraticConicNormFiber p t ht ht0), + (p : ℝ) ^ ((1 : ℝ) / 2 + δ) ≤ orderOf w → + ∃ n : ℕ, ∃ u : (ZMod p)ˣ, + ((normalizedRotate1^[n]) + (quadraticNormFiberPoint p t ht ht0 w s)).u2 = splitTorusTrace u ∧ + orderOf u = Nat.card (ZMod p)ˣ := by + obtain ⟨threshold, hthreshold⟩ := + exists_threshold_endgamePrimitiveTrace_explicitInequality_of_largeNonsplitOrder + coefficient hδ + refine ⟨max threshold 3, ?_⟩ + intro p hp _ t ht ht0 w htrace s hlarge + have hpThreshold : threshold ≤ p := (le_max_left threshold 3).trans hp + have hpTwo : p ≠ 2 := by omega + have hmul := Nat.div_mul_cancel (orderOf_dvd_natCard w) + rw [quadraticNormOneTorus_natCard] at hmul + have hexplicit := hthreshold p hpThreshold + ((p + 1) / orderOf w) (orderOf w) hmul hlarge + have hcardUnits : Nat.card (ZMod p)ˣ = p - 1 := by + rw [Nat.card_units, Nat.card_zmod] + have hexplicit' : + ((Nat.card (quadraticNormOneTorus p) / orderOf w : ℕ) : ℝ) * + ((Nat.card (ZMod p)ˣ).divisors.card : ℝ) ^ 2 * + ((coefficient : ℝ) * Real.sqrt (p : ℝ)) < p := by + rw [quadraticNormOneTorus_natCard, hcardUnits] + exact hexplicit + exact exists_iterate_quadraticNormFiberPoint_with_primitive_secondTrace + p coefficient hWeil hpTwo t ht ht0 w htrace s + (complementaryExponent_pos w) + (nonsplitComplementaryExponent_cast_ne_zero p w) + (complementaryExponent_dvd_natCard w) hexplicit' + +/-- The missing classified witness bridge: an arbitrary point on a nonzero nonparabolic fiber +is represented by the explicit split or nonsplit conic parametrization attached to the +eigenvalue supplied by trace classification. -/ +theorem exists_split_or_nonsplitFiberParameter + (p : ℕ) [Fact p.Prime] (hpTwo : p ≠ 2) + (t : ZMod p) (ht : t ^ 2 ≠ 4) (ht0 : t ≠ 0) + (x : ↥(normalizedFiber1 t)) : + (∃ (w : (ZMod p)ˣ), splitTorusTrace w = t ∧ + (w : ZMod p) ^ 2 ≠ 1 ∧ ∃ s : (ZMod p)ˣ, + splitFiberPoint w s = (x : NormalizedPoint (ZMod p))) ∨ + (∃ (w : quadraticNormOneTorus p), quadraticNormOneTrace p w = t ∧ + (((w : (quadraticFiniteField p)ˣ) : quadraticFiniteField p) ^ 2 ≠ 1) ∧ + ∃ s : ↥(quadraticConicNormFiber p t ht ht0), + quadraticNormFiberPoint p t ht ht0 w s = + (x : NormalizedPoint (ZMod p))) := by + rcases exists_split_or_quadraticNormOneTrace p hpTwo t ht with + ⟨w, htrace, hw⟩ | ⟨w, htrace, hw⟩ + · let xw : ↥(normalizedFiber1 (splitTorusTrace w)) := + ⟨x.1, x.property.1, by simpa [htrace] using x.property.2⟩ + let s := (splitFiberEquiv w hw (by simpa [htrace] using ht0)).symm xw + have hx : splitFiberPoint w s = (x : NormalizedPoint (ZMod p)) := + congrArg Subtype.val + ((splitFiberEquiv w hw (by simpa [htrace] using ht0)).apply_symm_apply xw) + exact Or.inl ⟨w, htrace, hw, s, hx⟩ + · let s := (quadraticNormFiberEquiv p t ht ht0 w htrace hw).symm x + have hx : quadraticNormFiberPoint p t ht ht0 w s = + (x : NormalizedPoint (ZMod p)) := + congrArg Subtype.val + ((quadraticNormFiberEquiv p t ht ht0 w htrace hw).apply_symm_apply x) + exact Or.inr ⟨w, htrace, hw, s, hx⟩ + +/-- Classified semisimple endgame: every nonzero nonparabolic normalized Markoff point with a +large first-coordinate rotation reaches a point whose second coordinate is the trace of a +primitive base-field unit. -/ +theorem exists_threshold_nonparabolicPoint_with_primitive_secondTrace + (splitCoefficient : ℕ) + (hSplitWeil : WeightedSplitTraceWeilBoundAssumption splitCoefficient) + (nonsplitCoefficient : ℕ) + (hNonsplitWeil : SeededNonsplitTraceWeilBoundAssumption nonsplitCoefficient) + {δ : ℝ} (hδ : 0 < δ) : + ∃ threshold : ℕ, ∀ p : ℕ, threshold ≤ p → [Fact p.Prime] → + ∀ (t : ZMod p) (ht : t ^ 2 ≠ 4) (ht0 : t ≠ 0) + (x : ↥(normalizedFiber1 t)), + (p : ℝ) ^ ((1 : ℝ) / 2 + δ) ≤ rotationOrder t → + ∃ n : ℕ, ∃ u : (ZMod p)ˣ, + ((normalizedRotate1^[n]) (x : NormalizedPoint (ZMod p))).u2 = + splitTorusTrace u ∧ + orderOf u = Nat.card (ZMod p)ˣ := by + obtain ⟨splitThreshold, hSplitThreshold⟩ := + exists_threshold_splitFiberPoint_with_primitive_secondTrace + splitCoefficient hSplitWeil hδ + obtain ⟨nonsplitThreshold, hNonsplitThreshold⟩ := + exists_threshold_quadraticNormFiberPoint_with_primitive_secondTrace + nonsplitCoefficient hNonsplitWeil hδ + refine ⟨max (max splitThreshold nonsplitThreshold) 3, ?_⟩ + intro p hp _ t ht ht0 x hlarge + have hpSplit : splitThreshold ≤ p := + (le_max_left splitThreshold nonsplitThreshold).trans + ((le_max_left (max splitThreshold nonsplitThreshold) 3).trans hp) + have hpNonsplit : nonsplitThreshold ≤ p := + (le_max_right splitThreshold nonsplitThreshold).trans + ((le_max_left (max splitThreshold nonsplitThreshold) 3).trans hp) + have hpTwo : p ≠ 2 := by omega + rcases exists_split_or_nonsplitFiberParameter p hpTwo t ht ht0 x with + ⟨w, htrace, hw, s, hx⟩ | ⟨w, htrace, hw, s, hx⟩ + · + have horder : rotationOrder t = orderOf w := by + rw [← htrace, rotationOrder_splitTorusTrace w hw] + obtain ⟨n, u, hcoordinate, huOrder⟩ := + hSplitThreshold p hpSplit w s hw (by simpa [htrace] using ht0) + (by simpa [horder] using hlarge) + refine ⟨n, u, ?_, huOrder⟩ + rw [← hx] + exact hcoordinate + · + have horder : rotationOrder t = orderOf w := by + rw [← htrace, rotationOrder_quadraticNormOneTrace p w hw] + obtain ⟨n, u, hcoordinate, huOrder⟩ := + hNonsplitThreshold p hpNonsplit t ht ht0 w htrace s + (by simpa [horder] using hlarge) + refine ⟨n, u, ?_, huOrder⟩ + rw [← hx] + exact hcoordinate + +/-- Proposition 10 for the nonparabolic branches, stated directly as maximal matrix rotation +order in the newly reached second coordinate. -/ +theorem exists_threshold_nonparabolicPoint_with_maximal_secondRotation + (splitCoefficient : ℕ) + (hSplitWeil : WeightedSplitTraceWeilBoundAssumption splitCoefficient) + (nonsplitCoefficient : ℕ) + (hNonsplitWeil : SeededNonsplitTraceWeilBoundAssumption nonsplitCoefficient) + {δ : ℝ} (hδ : 0 < δ) : + ∃ threshold : ℕ, ∀ p : ℕ, threshold ≤ p → [Fact p.Prime] → + ∀ (t : ZMod p) (ht : t ^ 2 ≠ 4) (ht0 : t ≠ 0) + (x : ↥(normalizedFiber1 t)), + (p : ℝ) ^ ((1 : ℝ) / 2 + δ) ≤ rotationOrder t → + ∃ n : ℕ, + rotationOrder + (((normalizedRotate1^[n]) + (x : NormalizedPoint (ZMod p))).u2) = p - 1 := by + obtain ⟨threshold, hthreshold⟩ := + exists_threshold_nonparabolicPoint_with_primitive_secondTrace + splitCoefficient hSplitWeil nonsplitCoefficient hNonsplitWeil hδ + refine ⟨max threshold 5, ?_⟩ + intro p hp _ t ht ht0 x hlarge + have hpThreshold : threshold ≤ p := (le_max_left threshold 5).trans hp + obtain ⟨n, u, hcoordinate, huOrder⟩ := + hthreshold p hpThreshold t ht ht0 x hlarge + have hcard : Nat.card (ZMod p)ˣ = p - 1 := by + rw [Nat.card_units, Nat.card_zmod] + have huSq : (u : ZMod p) ^ 2 ≠ 1 := by + intro huPower + have huDvd : orderOf u ∣ 2 := orderOf_dvd_of_pow_eq_one <| by + apply Units.ext + exact huPower + have huLe : orderOf u ≤ 2 := Nat.le_of_dvd (by norm_num) huDvd + rw [huOrder, hcard] at huLe + omega + refine ⟨n, ?_⟩ + rw [hcoordinate, rotationOrder_splitTorusTrace u huSq, huOrder, hcard] + +end + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Endgame/PrimitiveTraceCount.lean b/LeanPool/MarkoffModP/BGS/Markoff/Endgame/PrimitiveTraceCount.lean new file mode 100644 index 0000000000..21e582d8f1 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Endgame/PrimitiveTraceCount.lean @@ -0,0 +1,219 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Endgame.WeilBoundAssumption +public import LeanPool.MarkoffModP.BGS.Markoff.Endgame.PowerCoverCounting + +/-! +# Endgame point estimates after quotienting by the power maps + +The Weil interfaces count points on the power-cover curves. The paper's inclusion--exclusion +argument instead counts solutions on the two power-map images. This file connects those two +levels exactly. It proves the source's division by `d * e`, then divides the point-count error by +the same positive factor to obtain the uniform `O(sqrt q)` error used in equations (34)--(36). + +Both split and corrected seeded nonsplit branches are covered. The nonsplit equivalence uses the +actual base-field solution finset on the norm-one torus; it never replaces that finset by all +quadratic-field points. +-/ + +@[expose] public section + +namespace BGS.Markoff + +noncomputable section + +/-- Dividing an exact `d * e`-sheeted cover count divides its Weil error by the same factor. -/ +theorem rangeCount_error_le_of_coverCount_error_and_exactMultiplicity + (coverCount rangeCount fieldCard coefficient d e : ℕ) + (hd : 0 < d) (he : 0 < e) + (hcover : coverCount = d * e * rangeCount) + (herror : + |(coverCount : ℝ) - (fieldCard : ℝ)| ≤ + (coefficient : ℝ) * Real.sqrt (fieldCard : ℝ) * (d : ℝ) * (e : ℝ)) : + |(rangeCount : ℝ) - + (fieldCard : ℝ) / ((d : ℝ) * (e : ℝ))| ≤ + (coefficient : ℝ) * Real.sqrt (fieldCard : ℝ) := by + have hdReal : (0 : ℝ) < d := by exact_mod_cast hd + have heReal : (0 : ℝ) < e := by exact_mod_cast he + have hdeReal : (0 : ℝ) < (d : ℝ) * (e : ℝ) := mul_pos hdReal heReal + have hcoverReal : + (coverCount : ℝ) = (d : ℝ) * (e : ℝ) * (rangeCount : ℝ) := by + exact_mod_cast hcover + rw [hcoverReal] at herror + have hidentity : + (rangeCount : ℝ) - (fieldCard : ℝ) / ((d : ℝ) * (e : ℝ)) = + (((d : ℝ) * (e : ℝ) * (rangeCount : ℝ) - (fieldCard : ℝ)) / + ((d : ℝ) * (e : ℝ))) := by + field_simp + rw [hidentity, abs_div, abs_of_pos hdeReal] + apply (div_le_iff₀ hdeReal).2 + simpa [mul_assoc] using herror + +section Split + +variable (K : Type) [Field K] [Fintype K] [DecidableEq K] + +/-- Solutions on the two power-map images for the weighted split trace equation. -/ +abbrev splitTracePowerRangeSolutions + (alpha beta : K) (d e : ℕ) := + powerTraceRangeSolutions + (splitTorusTrace : Kˣ → K) (weightedSplitTorusTrace alpha beta) d e + +/-- The finite-set model of the split trace cover is definitionally the same equation as the +generic two-power cover, up to reversing the displayed equality. -/ +def splitTraceCurveSolutionsEquivPowerTraceCoverSolutions + (alpha beta : K) (d e : ℕ) : + ↥(splitTraceCurveSolutions K alpha beta d e) ≃ + powerTraceCoverSolutions + (splitTorusTrace : Kˣ → K) (weightedSplitTorusTrace alpha beta) d e where + toFun z := ⟨z.1, (mem_splitTraceCurveSolutions_iff K alpha beta d e z.1).mp z.2 |>.symm⟩ + invFun z := ⟨z.1, + (mem_splitTraceCurveSolutions_iff K alpha beta d e z.1).mpr z.2.symm⟩ + left_inv z := by rfl + right_inv z := by rfl + +/-- Exact source equation (32) for the split trace cover. -/ +theorem splitTraceCurveSolutions_card_eq_mul_natCard_powerTraceRangeSolutions + (alpha beta : K) (d e : ℕ) + (hdvd : d ∣ Nat.card Kˣ) (hedvd : e ∣ Nat.card Kˣ) : + (splitTraceCurveSolutions K alpha beta d e).card = + d * e * Nat.card (splitTracePowerRangeSolutions K alpha beta d e) := by + calc + (splitTraceCurveSolutions K alpha beta d e).card = + Nat.card ↥(splitTraceCurveSolutions K alpha beta d e) := by + rw [Nat.card_eq_fintype_card] + exact (Fintype.card_coe _).symm + _ = Nat.card + (powerTraceCoverSolutions + (splitTorusTrace : Kˣ → K) (weightedSplitTorusTrace alpha beta) d e) := + Nat.card_congr + (splitTraceCurveSolutionsEquivPowerTraceCoverSolutions K alpha beta d e) + _ = d * e * Nat.card (splitTracePowerRangeSolutions K alpha beta d e) := + natCard_powerTraceCoverSolutions_of_dvd + (splitTorusTrace : Kˣ → K) (weightedSplitTorusTrace alpha beta) d e hdvd hedvd + +/-- Equation (34) for a concrete weighted split trace cover, derived from the explicit Weil +assumption only after Lean proves the cover's absolute irreducibility. -/ +theorem splitTracePowerRangeSolutions_count_error_le_of_weilBoundAssumption + (coefficient : ℕ) (hWeil : WeightedSplitTraceWeilBoundAssumption coefficient) + (alpha beta : K) (d e : ℕ) + (halpha : alpha ≠ 0) (hbeta : beta ≠ 0) (hnondegenerate : alpha * beta ≠ 1) + (hd : 0 < d) (he : 0 < e) (heChar : (e : K) ≠ 0) + (hdvd : d ∣ Nat.card Kˣ) (hedvd : e ∣ Nat.card Kˣ) : + |(Nat.card (splitTracePowerRangeSolutions K alpha beta d e) : ℝ) - + (Fintype.card K : ℝ) / ((d : ℝ) * (e : ℝ))| ≤ + (coefficient : ℝ) * Real.sqrt (Fintype.card K : ℝ) := by + apply rangeCount_error_le_of_coverCount_error_and_exactMultiplicity + (splitTraceCurveSolutions K alpha beta d e).card + (Nat.card (splitTracePowerRangeSolutions K alpha beta d e)) + (Fintype.card K) coefficient d e hd he + (splitTraceCurveSolutions_card_eq_mul_natCard_powerTraceRangeSolutions + K alpha beta d e hdvd hedvd) + exact splitTraceCurveSolutions_count_error_le_of_weilBoundAssumption_and_positiveExponents + K coefficient hWeil alpha beta d e halpha hbeta hnondegenerate hd he heChar + +end Split + +section Nonsplit + +variable (p : ℕ) [Fact p.Prime] + +/-- The unpowered left trace in the corrected seeded nonsplit equation. -/ +def existingConicSeedNonsplitTorusTrace + (t : ZMod p) (ht : t ^ 2 ≠ 4) (ht0 : t ≠ 0) + (s : ↥(quadraticConicNormFiber p t ht ht0)) + (w : quadraticNormOneTorus p) : ZMod p := + Algebra.trace (ZMod p) (quadraticFiniteField p) + ((s.1 : quadraticFiniteField p) * + ((w : (quadraticFiniteField p)ˣ) : quadraticFiniteField p)) + +/-- Solutions on the two power-map images for the corrected seeded nonsplit equation. -/ +abbrev existingConicSeedNonsplitPowerRangeSolutions + (t : ZMod p) (ht : t ^ 2 ≠ 4) (ht0 : t ≠ 0) + (s : ↥(quadraticConicNormFiber p t ht ht0)) (d e : ℕ) := + powerTraceRangeSolutions + (existingConicSeedNonsplitTorusTrace p t ht ht0 s) + (splitTorusTrace : (ZMod p)ˣ → ZMod p) d e + +/-- The corrected nonsplit solution finset is exactly the corresponding generic two-power +cover over the norm-one torus and the base-field unit group. -/ +def existingConicSeedNonsplitTraceCurveSolutionsEquivPowerTraceCoverSolutions + (t : ZMod p) (ht : t ^ 2 ≠ 4) (ht0 : t ≠ 0) + (s : ↥(quadraticConicNormFiber p t ht ht0)) (d e : ℕ) : + ↥(existingConicSeedNonsplitTraceCurveSolutions p t ht ht0 s d e) ≃ + powerTraceCoverSolutions + (existingConicSeedNonsplitTorusTrace p t ht ht0 s) + (splitTorusTrace : (ZMod p)ˣ → ZMod p) d e where + toFun z := ⟨z.1, by + have hz := + (mem_existingConicSeedNonsplitTraceCurveSolutions_iff + p t ht ht0 s d e z.1).mp z.2 + exact hz⟩ + invFun z := ⟨z.1, + (mem_existingConicSeedNonsplitTraceCurveSolutions_iff + p t ht ht0 s d e z.1).mpr z.2⟩ + left_inv z := by rfl + right_inv z := by rfl + +/-- Exact source equation (32) for the corrected seeded nonsplit trace cover. -/ +theorem existingConicSeedNonsplitTraceCurveSolutions_card_eq_mul_natCard_powerTraceRangeSolutions + (t : ZMod p) (ht : t ^ 2 ≠ 4) (ht0 : t ≠ 0) + (s : ↥(quadraticConicNormFiber p t ht ht0)) (d e : ℕ) + (hdvd : d ∣ Nat.card (quadraticNormOneTorus p)) + (hedvd : e ∣ Nat.card (ZMod p)ˣ) : + (existingConicSeedNonsplitTraceCurveSolutions p t ht ht0 s d e).card = + d * e * Nat.card + (existingConicSeedNonsplitPowerRangeSolutions p t ht ht0 s d e) := by + calc + (existingConicSeedNonsplitTraceCurveSolutions p t ht ht0 s d e).card = + Nat.card ↥(existingConicSeedNonsplitTraceCurveSolutions p t ht ht0 s d e) := by + rw [Nat.card_eq_fintype_card] + exact (Fintype.card_coe _).symm + _ = Nat.card + (powerTraceCoverSolutions + (existingConicSeedNonsplitTorusTrace p t ht ht0 s) + (splitTorusTrace : (ZMod p)ˣ → ZMod p) d e) := + Nat.card_congr + (existingConicSeedNonsplitTraceCurveSolutionsEquivPowerTraceCoverSolutions + p t ht ht0 s d e) + _ = d * e * Nat.card + (existingConicSeedNonsplitPowerRangeSolutions p t ht ht0 s d e) := + natCard_powerTraceCoverSolutions_of_dvd + (existingConicSeedNonsplitTorusTrace p t ht ht0 s) + (splitTorusTrace : (ZMod p)ˣ → ZMod p) d e hdvd hedvd + +/-- Equation (34) for the corrected seeded nonsplit cover. Its main term is `p / (d * e)` +because the counted solution set is over the base field. -/ +theorem existingConicSeedNonsplitPowerRangeSolutions_count_error_le_of_weilBoundAssumption + (coefficient : ℕ) (hWeil : SeededNonsplitTraceWeilBoundAssumption coefficient) + (hpTwo : p ≠ 2) + (t : ZMod p) (ht : t ^ 2 ≠ 4) (ht0 : t ≠ 0) + (s : ↥(quadraticConicNormFiber p t ht ht0)) (d e : ℕ) + (hd : 0 < d) (he : 0 < e) (hdChar : (d : quadraticFiniteField p) ≠ 0) + (hdvd : d ∣ Nat.card (quadraticNormOneTorus p)) + (hedvd : e ∣ Nat.card (ZMod p)ˣ) : + |(Nat.card + (existingConicSeedNonsplitPowerRangeSolutions p t ht ht0 s d e) : ℝ) - + (p : ℝ) / ((d : ℝ) * (e : ℝ))| ≤ + (coefficient : ℝ) * Real.sqrt (p : ℝ) := by + apply rangeCount_error_le_of_coverCount_error_and_exactMultiplicity + (existingConicSeedNonsplitTraceCurveSolutions p t ht ht0 s d e).card + (Nat.card (existingConicSeedNonsplitPowerRangeSolutions p t ht ht0 s d e)) + p coefficient d e hd he + (existingConicSeedNonsplitTraceCurveSolutions_card_eq_mul_natCard_powerTraceRangeSolutions + p t ht ht0 s d e hdvd hedvd) + exact + existingConicSeedNonsplitTraceCurveSolutions_count_error_le_of_weilBoundAssumption_and_positiveExponents + coefficient hWeil p hpTwo t ht ht0 s d e hd he hdChar + +end Nonsplit + +end + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Endgame/WeilBoundAssumption.lean b/LeanPool/MarkoffModP/BGS/Markoff/Endgame/WeilBoundAssumption.lean new file mode 100644 index 0000000000..e2c61edd33 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Endgame/WeilBoundAssumption.lean @@ -0,0 +1,198 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.WeightedOddCoprimeIrreducibility +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.Boundary +public import LeanPool.MarkoffModP.BGS.Markoff.Endgame.Nonsplit.SeededCover +public import Mathlib.Analysis.SpecialFunctions.Pow.Real + +/-! +# The explicit endgame Weil-bound assumption + +The paper's endgame needs a point estimate for the weighted split trace covers + +`alpha * (x^d + x^(-d)) = beta * (y^e + y^(-e))`. + +The project accepts each relevant affine Hasse--Weil specialization as an ordinary theorem +parameter. It is not a Lean axiom, a `sorry`, a typeclass, or a structure field. The constant is +fixed before the finite field, the weights, and the covering exponents are chosen, so the +interface expresses the uniformity required by Theorem 1. + +The assumption does not assert that a concrete Markoff trace cover is geometrically irreducible. +That hypothesis remains visible. The application theorem at the end of this file discharges it +using the in-repository absolute-irreducibility proof. + +Constructing a smooth projective normalization, bounding its genus and boundary, and applying the +classical projective Hasse--Weil theorem is one route to proving this assumption. Those objects +are intentionally not part of the downstream interface: they belong to a proof of the accepted +external theorem, not to each use of it. +-/ + +@[expose] public section + +namespace BGS.Markoff + +noncomputable section + +/-- The uniform weighted split trace-cover estimate accepted by the endgame. + +`coefficient` is independent of the finite field, weights, and covering exponents. Every +algebraic hypothesis needed to apply the estimate to a concrete cover is an explicit argument. +In particular, absolute irreducibility is stated as irreducibility after scalar extension to the +algebraic closure. -/ +def WeightedSplitTraceWeilBoundAssumption (coefficient : ℕ) : Prop := + 0 < coefficient ∧ + ∀ (K : Type) [Field K] [Fintype K] [DecidableEq K] + (alpha beta : K) (d e : ℕ), + alpha ≠ 0 → + beta ≠ 0 → + alpha * beta ≠ 1 → + 0 < d → + 0 < e → + Irreducible + (MvPolynomial.map (algebraMap K (AlgebraicClosure K)) + (splitTraceCoverPolynomial alpha beta d e)) → + |((splitTraceCurveSolutions K alpha beta d e).card : ℝ) - + (Fintype.card K : ℝ)| ≤ + (coefficient : ℝ) * Real.sqrt (Fintype.card K : ℝ) * + (d : ℝ) * (e : ℝ) + +variable (K : Type) [Field K] [Fintype K] [DecidableEq K] + +/-- Apply the accepted Weil estimate after supplying the concrete cover's absolute +irreducibility. This theorem is the raw interface adapter; the next theorem proves that +irreducibility from the trace-cover hypotheses used in the paper. -/ +theorem splitTraceCurveSolutions_count_error_le_of_weilBoundAssumption + (coefficient : ℕ) (hWeil : WeightedSplitTraceWeilBoundAssumption coefficient) + (alpha beta : K) (d e : ℕ) + (halpha : alpha ≠ 0) (hbeta : beta ≠ 0) (hnondegenerate : alpha * beta ≠ 1) + (hd : 0 < d) (he : 0 < e) + (hirreducible : + Irreducible + (MvPolynomial.map (algebraMap K (AlgebraicClosure K)) + (splitTraceCoverPolynomial alpha beta d e))) : + |((splitTraceCurveSolutions K alpha beta d e).card : ℝ) - + (Fintype.card K : ℝ)| ≤ + (coefficient : ℝ) * Real.sqrt (Fintype.card K : ℝ) * + (d : ℝ) * (e : ℝ) := + hWeil.2 K alpha beta d e halpha hbeta hnondegenerate hd he hirreducible + +/-- The endgame-ready point estimate for a concrete weighted trace cover. + +The only unproved mathematical input is `hWeil`. Lean proves the required absolute +irreducibility from nonzero/nondegenerate weights, positive exponents, and the condition that the +second covering exponent is nonzero in the ground field. For the paper's split endgame this last +condition follows because the exponent divides the prime-to-characteristic torus order. -/ +theorem splitTraceCurveSolutions_count_error_le_of_weilBoundAssumption_and_positiveExponents + (coefficient : ℕ) (hWeil : WeightedSplitTraceWeilBoundAssumption coefficient) + (alpha beta : K) (d e : ℕ) + (halpha : alpha ≠ 0) (hbeta : beta ≠ 0) (hnondegenerate : alpha * beta ≠ 1) + (hd : 0 < d) (he : 0 < e) (heChar : (e : K) ≠ 0) : + |((splitTraceCurveSolutions K alpha beta d e).card : ℝ) - + (Fintype.card K : ℝ)| ≤ + (coefficient : ℝ) * Real.sqrt (Fintype.card K : ℝ) * + (d : ℝ) * (e : ℝ) := by + apply splitTraceCurveSolutions_count_error_le_of_weilBoundAssumption + K coefficient hWeil alpha beta d e halpha hbeta hnondegenerate hd he + exact splitTraceCoverPolynomial_absolutelyIrreducible_of_positiveExponents + alpha beta halpha hbeta hnondegenerate e d he hd heChar + +/-! ## The seeded nonsplit branch -/ + +/-- Solutions of the paper's corrected nonsplit endgame equation on the norm-one torus and the +base-field multiplicative group. Keeping this finite set over `ZMod p`, rather than replacing it +by all quadratic-field points of the scalar-extended split curve, preserves the actual count +needed by Theorem 1. -/ +noncomputable def existingConicSeedNonsplitTraceCurveSolutions + (p : ℕ) [Fact p.Prime] + (t : ZMod p) (ht : t ^ 2 ≠ 4) (ht0 : t ≠ 0) + (s : ↥(quadraticConicNormFiber p t ht ht0)) + (d e : ℕ) : Finset (quadraticNormOneTorus p × (ZMod p)ˣ) := by + classical + exact Finset.univ.filter fun z => + ExistingConicSeedNonsplitTraceCoverEquation p t ht ht0 s d e z.1 z.2 + +@[simp] +theorem mem_existingConicSeedNonsplitTraceCurveSolutions_iff + (p : ℕ) [Fact p.Prime] + (t : ZMod p) (ht : t ^ 2 ≠ 4) (ht0 : t ≠ 0) + (s : ↥(quadraticConicNormFiber p t ht ht0)) + (d e : ℕ) (z : quadraticNormOneTorus p × (ZMod p)ˣ) : + z ∈ existingConicSeedNonsplitTraceCurveSolutions p t ht ht0 s d e ↔ + ExistingConicSeedNonsplitTraceCoverEquation p t ht ht0 s d e z.1 z.2 := by + classical + simp [existingConicSeedNonsplitTraceCurveSolutions] + +/-- The uniform affine Weil estimate accepted for the seeded nonsplit endgame family. + +The conclusion counts the base-field solution set above, not every point of the scalar-extended +curve over the quadratic field. The explicit irreducibility premise is the polynomial statement +already proved for the scalar extension of the corrected seeded equation. -/ +def SeededNonsplitTraceWeilBoundAssumption (coefficient : ℕ) : Prop := + 0 < coefficient ∧ + ∀ (p : ℕ) [Fact p.Prime], + p ≠ 2 → + ∀ (t : ZMod p) (ht : t ^ 2 ≠ 4) (ht0 : t ≠ 0) + (s : ↥(quadraticConicNormFiber p t ht ht0)) (d e : ℕ), + 0 < d → + 0 < e → + Irreducible + (MvPolynomial.map + (algebraMap (quadraticFiniteField p) + (AlgebraicClosure (quadraticFiniteField p))) + (splitTraceCoverPolynomial + (s.1 : quadraticFiniteField p) + ((s.1 : quadraticFiniteField p) ^ p) e d)) → + |((existingConicSeedNonsplitTraceCurveSolutions + p t ht ht0 s d e).card : ℝ) - (p : ℝ)| ≤ + (coefficient : ℝ) * Real.sqrt (p : ℝ) * (d : ℝ) * (e : ℝ) + +/-- Apply the accepted nonsplit Weil estimate after supplying the scalar-extended cover's +absolute irreducibility. -/ +theorem existingConicSeedNonsplitTraceCurveSolutions_count_error_le_of_weilBoundAssumption + (coefficient : ℕ) (hWeil : SeededNonsplitTraceWeilBoundAssumption coefficient) + (p : ℕ) [Fact p.Prime] (hpTwo : p ≠ 2) + (t : ZMod p) (ht : t ^ 2 ≠ 4) (ht0 : t ≠ 0) + (s : ↥(quadraticConicNormFiber p t ht ht0)) + (d e : ℕ) (hd : 0 < d) (he : 0 < e) + (hirreducible : + Irreducible + (MvPolynomial.map + (algebraMap (quadraticFiniteField p) + (AlgebraicClosure (quadraticFiniteField p))) + (splitTraceCoverPolynomial + (s.1 : quadraticFiniteField p) + ((s.1 : quadraticFiniteField p) ^ p) e d))) : + |((existingConicSeedNonsplitTraceCurveSolutions + p t ht ht0 s d e).card : ℝ) - (p : ℝ)| ≤ + (coefficient : ℝ) * Real.sqrt (p : ℝ) * (d : ℝ) * (e : ℝ) := + hWeil.2 p hpTwo t ht ht0 s d e hd he hirreducible + +/-- The endgame-ready point estimate for the corrected seeded nonsplit cover. + +As in the split adapter, the only external input is `hWeil`. Lean supplies the +scalar-extended absolute irreducibility theorem from the actual conic seed and the visible +prime-to-characteristic condition on the norm-one covering exponent. -/ +theorem existingConicSeedNonsplitTraceCurveSolutions_count_error_le_of_weilBoundAssumption_and_positiveExponents + (coefficient : ℕ) (hWeil : SeededNonsplitTraceWeilBoundAssumption coefficient) + (p : ℕ) [Fact p.Prime] (hpTwo : p ≠ 2) + (t : ZMod p) (ht : t ^ 2 ≠ 4) (ht0 : t ≠ 0) + (s : ↥(quadraticConicNormFiber p t ht ht0)) + (d e : ℕ) (hd : 0 < d) (he : 0 < e) + (hdChar : (d : quadraticFiniteField p) ≠ 0) : + |((existingConicSeedNonsplitTraceCurveSolutions + p t ht ht0 s d e).card : ℝ) - (p : ℝ)| ≤ + (coefficient : ℝ) * Real.sqrt (p : ℝ) * (d : ℝ) * (e : ℝ) := by + apply existingConicSeedNonsplitTraceCurveSolutions_count_error_le_of_weilBoundAssumption + coefficient hWeil p hpTwo t ht ht0 s d e hd he + exact existingConicSeed_weightedCover_absolutelyIrreducible + p hpTwo t ht ht0 s d e hd he hdChar + +end + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Endgame/WeilFromGeneralHasse.lean b/LeanPool/MarkoffModP/BGS/Markoff/Endgame/WeilFromGeneralHasse.lean new file mode 100644 index 0000000000..e68f2ead07 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Endgame/WeilFromGeneralHasse.lean @@ -0,0 +1,231 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.External.GeneralCurveTheorems +public import LeanPool.MarkoffModP.BGS.Markoff.Endgame.WeilBoundAssumption +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.Boundary + +/-! +# Applying the general affine Hasse--Weil theorem to split trace covers +-/ + +@[expose] public section + +namespace BGS.Markoff + +noncomputable section + +variable {K : Type*} [Field K] + +private theorem degreeOf_first_monomial_le + (c : K) (a b : ℕ) : + MvPolynomial.degreeOf (0 : Fin 2) + (MvPolynomial.C c * MvPolynomial.X 0 ^ a * MvPolynomial.X 1 ^ b) ≤ a := by + calc + _ ≤ MvPolynomial.degreeOf (0 : Fin 2) + (MvPolynomial.C c * MvPolynomial.X 0 ^ a) + + MvPolynomial.degreeOf (0 : Fin 2) (MvPolynomial.X 1 ^ b) := + MvPolynomial.degreeOf_mul_le _ _ _ + _ ≤ (MvPolynomial.degreeOf (0 : Fin 2) (MvPolynomial.C c) + + MvPolynomial.degreeOf (0 : Fin 2) (MvPolynomial.X 0 ^ a)) + + MvPolynomial.degreeOf (0 : Fin 2) (MvPolynomial.X 1 ^ b) := by + gcongr + exact MvPolynomial.degreeOf_mul_le _ _ _ + _ ≤ a := by + have ha : MvPolynomial.degreeOf (0 : Fin 2) + (MvPolynomial.X 0 ^ a : MvPolynomial (Fin 2) K) ≤ a := by + calc + _ ≤ a * MvPolynomial.degreeOf (0 : Fin 2) (MvPolynomial.X 0) := + MvPolynomial.degreeOf_pow_le _ _ _ + _ = a := by rw [MvPolynomial.degreeOf_X]; norm_num + have hb : MvPolynomial.degreeOf (0 : Fin 2) + (MvPolynomial.X 1 ^ b : MvPolynomial (Fin 2) K) ≤ 0 := by + calc + _ ≤ b * MvPolynomial.degreeOf (0 : Fin 2) (MvPolynomial.X 1) := + MvPolynomial.degreeOf_pow_le _ _ _ + _ = 0 := by rw [MvPolynomial.degreeOf_X]; norm_num + rw [MvPolynomial.degreeOf_C] + omega + +private theorem degreeOf_second_monomial_le + (c : K) (a b : ℕ) : + MvPolynomial.degreeOf (1 : Fin 2) + (MvPolynomial.C c * MvPolynomial.X 0 ^ a * MvPolynomial.X 1 ^ b) ≤ b := by + calc + _ ≤ MvPolynomial.degreeOf (1 : Fin 2) + (MvPolynomial.C c * MvPolynomial.X 0 ^ a) + + MvPolynomial.degreeOf (1 : Fin 2) (MvPolynomial.X 1 ^ b) := + MvPolynomial.degreeOf_mul_le _ _ _ + _ ≤ (MvPolynomial.degreeOf (1 : Fin 2) (MvPolynomial.C c) + + MvPolynomial.degreeOf (1 : Fin 2) (MvPolynomial.X 0 ^ a)) + + MvPolynomial.degreeOf (1 : Fin 2) (MvPolynomial.X 1 ^ b) := by + gcongr + exact MvPolynomial.degreeOf_mul_le _ _ _ + _ ≤ b := by + have ha : MvPolynomial.degreeOf (1 : Fin 2) + (MvPolynomial.X 0 ^ a : MvPolynomial (Fin 2) K) ≤ 0 := by + calc + _ ≤ a * MvPolynomial.degreeOf (1 : Fin 2) (MvPolynomial.X 0) := + MvPolynomial.degreeOf_pow_le _ _ _ + _ = 0 := by rw [MvPolynomial.degreeOf_X]; norm_num + have hb : MvPolynomial.degreeOf (1 : Fin 2) + (MvPolynomial.X 1 ^ b : MvPolynomial (Fin 2) K) ≤ b := by + calc + _ ≤ b * MvPolynomial.degreeOf (1 : Fin 2) (MvPolynomial.X 1) := + MvPolynomial.degreeOf_pow_le _ _ _ + _ = b := by rw [MvPolynomial.degreeOf_X]; norm_num + rw [MvPolynomial.degreeOf_C] + omega + +theorem splitTraceCoverPolynomial_degreeOf_first_le + (alpha beta : K) (d e : ℕ) : + MvPolynomial.degreeOf (0 : Fin 2) + (splitTraceCoverPolynomial alpha beta d e) ≤ 2 * d := by + unfold splitTraceCoverPolynomial + refine (MvPolynomial.degreeOf_sub_le _ _ _).trans (max_le ?_ ?_) + · refine (MvPolynomial.degreeOf_sub_le _ _ _).trans (max_le ?_ ?_) + · refine (MvPolynomial.degreeOf_add_le _ _ _).trans (max_le ?_ ?_) + · exact (degreeOf_first_monomial_le alpha d (2 * e)).trans + (show d ≤ 2 * d by omega) + · simpa using + (degreeOf_first_monomial_le beta d 0).trans + (show d ≤ 2 * d by omega) + · simpa using + (degreeOf_first_monomial_le (1 : K) (2 * d) e) + · simpa using + (degreeOf_first_monomial_le (1 : K) 0 e).trans + (show 0 ≤ 2 * d by omega) + +theorem splitTraceCoverPolynomial_degreeOf_second_le + (alpha beta : K) (d e : ℕ) : + MvPolynomial.degreeOf (1 : Fin 2) + (splitTraceCoverPolynomial alpha beta d e) ≤ 2 * e := by + unfold splitTraceCoverPolynomial + refine (MvPolynomial.degreeOf_sub_le _ _ _).trans (max_le ?_ ?_) + · refine (MvPolynomial.degreeOf_sub_le _ _ _).trans (max_le ?_ ?_) + · refine (MvPolynomial.degreeOf_add_le _ _ _).trans (max_le ?_ ?_) + · exact degreeOf_second_monomial_le alpha d (2 * e) + · simpa using + (degreeOf_second_monomial_le beta d 0).trans + (show 0 ≤ 2 * e by omega) + · simpa using + (degreeOf_second_monomial_le (1 : K) (2 * d) e).trans + (show e ≤ 2 * e by omega) + · simpa using + (degreeOf_second_monomial_le (1 : K) 0 e).trans + (show e ≤ 2 * e by omega) + +theorem splitTraceCoverPolynomial_hasBidegreeAtMost + (alpha beta : K) (d e : ℕ) : + BGS.External.HasBidegreeAtMost + (splitTraceCoverPolynomial alpha beta d e) (2 * d) (2 * e) := by + intro monomial hmonomial + exact ⟨ + (MvPolynomial.degreeOf_le_iff.mp + (splitTraceCoverPolynomial_degreeOf_first_le alpha beta d e)) + monomial hmonomial, + (MvPolynomial.degreeOf_le_iff.mp + (splitTraceCoverPolynomial_degreeOf_second_le alpha beta d e)) + monomial hmonomial⟩ + +/-- A fixed-coefficient affine Hasse--Weil bound supplies the correspondingly +fixed split trace estimate. -/ +theorem weightedSplitTraceWeilBoundAssumption_of_bivariateAffineHasseWeilBound + (generalCoefficient : ℕ) + (hgeneral : BGS.External.BivariateAffineHasseWeilBound generalCoefficient) : + WeightedSplitTraceWeilBoundAssumption (4 * generalCoefficient + 1) := by + let coefficient := 4 * generalCoefficient + 1 + change WeightedSplitTraceWeilBoundAssumption coefficient + refine ⟨by dsimp [coefficient]; omega, ?_⟩ + intro K _ _ _ alpha beta d e halpha hbeta hnondegenerate hd he hirreducible + have hAffine := hgeneral K (splitTraceCoverPolynomial alpha beta d e) + (2 * d) (2 * e) (by omega) (by omega) + (splitTraceCoverPolynomial_hasBidegreeAtMost alpha beta d e) hirreducible + have hcardNat : + (BGS.External.affinePlaneCurveZeros K + (splitTraceCoverPolynomial alpha beta d e)).card = + (splitTraceCurveSolutions K alpha beta d e).card + 1 := by + calc + (BGS.External.affinePlaneCurveZeros K + (splitTraceCoverPolynomial alpha beta d e)).card = + (affineSplitTraceCoverZeros K alpha beta d e).card := by rfl + _ = (torusSplitTraceCoverZeros K alpha beta d e).card + 1 := + affineSplitTraceCoverZeros_card_eq_torus_card_add_one + K alpha beta d e hd he hbeta + _ = (splitTraceCurveSolutions K alpha beta d e).card + 1 := by + rw [torusSplitTraceCoverZeros_card_eq_splitTraceCurveSolutions_card] + have hcardReal : + ((BGS.External.affinePlaneCurveZeros K + (splitTraceCoverPolynomial alpha beta d e)).card : ℝ) = + (splitTraceCurveSolutions K alpha beta d e).card + 1 := by + exact_mod_cast hcardNat + let x : ℝ := Real.sqrt (Fintype.card K : ℝ) * (d : ℝ) * (e : ℝ) + have hcardOne : (1 : ℝ) ≤ (Fintype.card K : ℝ) := by + have hcardPositive : 0 < Fintype.card K := + Fintype.card_pos_iff.mpr ⟨(0 : K)⟩ + exact_mod_cast hcardPositive + have hsqrtOne : (1 : ℝ) ≤ Real.sqrt (Fintype.card K : ℝ) := + Real.one_le_sqrt.mpr hcardOne + have hdOne : (1 : ℝ) ≤ d := by exact_mod_cast hd + have heOne : (1 : ℝ) ≤ e := by exact_mod_cast he + have hxOne : (1 : ℝ) ≤ x := by + dsimp [x] + calc + (1 : ℝ) = 1 * 1 * 1 := by ring + _ ≤ Real.sqrt (Fintype.card K : ℝ) * d * e := by gcongr + have hAffine' : + |((BGS.External.affinePlaneCurveZeros K + (splitTraceCoverPolynomial alpha beta d e)).card : ℝ) - + (Fintype.card K : ℝ)| ≤ + 4 * (generalCoefficient : ℝ) * x := by + norm_num only [Nat.cast_mul, Nat.cast_ofNat] at hAffine + convert hAffine using 1 <;> dsimp [x] <;> ring + have herrorIdentity : + ((splitTraceCurveSolutions K alpha beta d e).card : ℝ) - + (Fintype.card K : ℝ) = + (((BGS.External.affinePlaneCurveZeros K + (splitTraceCoverPolynomial alpha beta d e)).card : ℝ) - + (Fintype.card K : ℝ)) - 1 := by + rw [hcardReal] + ring + rw [herrorIdentity] + calc + |(((BGS.External.affinePlaneCurveZeros K + (splitTraceCoverPolynomial alpha beta d e)).card : ℝ) - + (Fintype.card K : ℝ)) - 1| ≤ + |((BGS.External.affinePlaneCurveZeros K + (splitTraceCoverPolynomial alpha beta d e)).card : ℝ) - + (Fintype.card K : ℝ)| + 1 := by + simpa using abs_sub + (((BGS.External.affinePlaneCurveZeros K + (splitTraceCoverPolynomial alpha beta d e)).card : ℝ) - + (Fintype.card K : ℝ)) (1 : ℝ) + _ ≤ 4 * (generalCoefficient : ℝ) * x + 1 := by gcongr + _ ≤ (4 * (generalCoefficient : ℝ) + 1) * x := by + nlinarith [hxOne] + _ = (coefficient : ℝ) * Real.sqrt (Fintype.card K : ℝ) * + (d : ℝ) * (e : ℝ) := by + dsimp [coefficient, x] + norm_num only [Nat.cast_add, Nat.cast_mul, Nat.cast_one, Nat.cast_ofNat] + ring + +/-- The general affine Hasse--Weil theorem supplies the uniform split trace +estimate. Absolute irreducibility remains an explicit premise of the target +interface and the unique affine boundary point is absorbed into the uniform +coefficient. -/ +theorem exists_weightedSplitTraceWeilBoundAssumption_of_generalHasseWeil + (hHasse : BGS.External.GeneralBivariateAffineHasseWeilTheorem) : + ∃ coefficient : ℕ, WeightedSplitTraceWeilBoundAssumption coefficient := by + obtain ⟨generalCoefficient, _hgeneralCoefficient, hgeneral⟩ := hHasse + exact ⟨4 * generalCoefficient + 1, + weightedSplitTraceWeilBoundAssumption_of_bivariateAffineHasseWeilBound + generalCoefficient hgeneral⟩ + +end + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/ExplicitEndgame.lean b/LeanPool/MarkoffModP/BGS/Markoff/ExplicitEndgame.lean new file mode 100644 index 0000000000..08cff05f72 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/ExplicitEndgame.lean @@ -0,0 +1,343 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.ExplicitEstimates +public import LeanPool.MarkoffModP.BGS.Markoff.ExplicitNumericCertificates +public import LeanPool.MarkoffModP.BGS.Markoff.Endgame.PrimitiveOrbitWiring +public import LeanPool.MarkoffModP.BGS.Markoff.Cage.Connectivity + +/-! +# Explicit endgame and cage connectivity + +This file separates the finite-prime endgame wiring from its closed numerical +certificates. The structural lemmas below consume the exact primitive-trace +inequalities at a fixed prime; the final wrappers discharge those inequalities +from `explicitStrongApproximationCutoff`. +-/ + +@[expose] public section + +namespace BGS.Markoff + +noncomputable section + +/-- The fixed-prime semisimple endgame. Its only numerical inputs are the +two displayed primitive-trace inequalities, with the fixed coefficients `33` +and `34` already obtained from the coefficient-`8` affine Hasse--Weil bound. -/ +theorem exists_iterate_nonparabolicPoint_with_maximal_secondRotation_of_explicitInequalities + (p : ℕ) [Fact p.Prime] (hpFive : 5 ≤ p) + (t : ZMod p) (ht : t ^ 2 ≠ 4) (ht0 : t ≠ 0) + (x : ↑(normalizedFiber1 t)) + (hSplitExplicit : ∀ orbitExponent orbitOrder : ℕ, + orbitExponent * orbitOrder = p - 1 → + (p : ℝ) ^ (5 / 6 : ℝ) ≤ orbitOrder → + (orbitExponent : ℝ) * (((p - 1).divisors.card : ℕ) : ℝ) ^ 2 * + ((33 : ℝ) * Real.sqrt (p : ℝ)) < p) + (hNonsplitExplicit : ∀ orbitExponent orbitOrder : ℕ, + orbitExponent * orbitOrder = p + 1 → + (p : ℝ) ^ (5 / 6 : ℝ) ≤ orbitOrder → + (orbitExponent : ℝ) * (((p - 1).divisors.card : ℕ) : ℝ) ^ 2 * + ((34 : ℝ) * Real.sqrt (p : ℝ)) < p) + (hlarge : (p : ℝ) ^ (5 / 6 : ℝ) ≤ rotationOrder t) : + ∃ n : ℕ, + rotationOrder + (((normalizedRotate1^[n]) + (x : NormalizedPoint (ZMod p))).u2) = p - 1 := by + have hpTwo : p ≠ 2 := by omega + rcases exists_split_or_nonsplitFiberParameter p hpTwo t ht ht0 x with + ⟨w, htrace, hw, s, hx⟩ | ⟨w, htrace, hw, s, hx⟩ + · have horder : rotationOrder t = orderOf w := by + rw [← htrace, rotationOrder_splitTorusTrace w hw] + have hcard : Nat.card (ZMod p)ˣ = p - 1 := by + rw [Nat.card_units, Nat.card_zmod] + have hmul := Nat.div_mul_cancel (orderOf_dvd_natCard w) + rw [hcard] at hmul + have hexplicit := hSplitExplicit + ((p - 1) / orderOf w) (orderOf w) hmul (by simpa [horder] using hlarge) + obtain ⟨n, u, hcoordinate, huOrder⟩ := + exists_iterate_splitFiberPoint_with_primitive_secondTrace + p 33 weightedSplitTraceWeilBoundAssumption_thirtyThree hpTwo w s hw + (by simpa [htrace] using ht0) + (complementaryExponent_pos w) + (splitComplementaryExponent_cast_ne_zero p w) + (complementaryExponent_dvd_natCard w) (by + rw [hcard] + exact hexplicit) + have huSq : (u : ZMod p) ^ 2 ≠ 1 := by + intro huPower + have huDvd : orderOf u ∣ 2 := orderOf_dvd_of_pow_eq_one <| by + apply Units.ext + exact huPower + have huLe : orderOf u ≤ 2 := Nat.le_of_dvd (by norm_num) huDvd + rw [huOrder, hcard] at huLe + omega + refine ⟨n, ?_⟩ + rw [← hx, hcoordinate, rotationOrder_splitTorusTrace u huSq, huOrder, hcard] + · have horder : rotationOrder t = orderOf w := by + rw [← htrace, rotationOrder_quadraticNormOneTrace p w hw] + have hmul := Nat.div_mul_cancel (orderOf_dvd_natCard w) + rw [quadraticNormOneTorus_natCard] at hmul + have hcard : Nat.card (ZMod p)ˣ = p - 1 := by + rw [Nat.card_units, Nat.card_zmod] + have hexplicit := hNonsplitExplicit + ((p + 1) / orderOf w) (orderOf w) hmul (by simpa [horder] using hlarge) + obtain ⟨n, u, hcoordinate, huOrder⟩ := + exists_iterate_quadraticNormFiberPoint_with_primitive_secondTrace + p 34 seededNonsplitTraceWeilBoundAssumption_thirtyFour hpTwo + t ht ht0 w htrace s + (complementaryExponent_pos w) + (nonsplitComplementaryExponent_cast_ne_zero p w) + (complementaryExponent_dvd_natCard w) (by + rw [quadraticNormOneTorus_natCard, hcard] + exact hexplicit) + have huSq : (u : ZMod p) ^ 2 ≠ 1 := by + intro huPower + have huDvd : orderOf u ∣ 2 := orderOf_dvd_of_pow_eq_one <| by + apply Units.ext + exact huPower + have huLe : orderOf u ≤ 2 := Nat.le_of_dvd (by norm_num) huDvd + rw [huOrder, hcard] at huLe + omega + refine ⟨n, ?_⟩ + rw [← hx, hcoordinate, rotationOrder_splitTorusTrace u huSq, huOrder, hcard] + +/-- Fixed-prime first-coordinate endgame, including the parabolic branch and +the trace-zero exclusion. -/ +theorem exists_iterate_point_with_maximal_secondRotation_of_explicitInequalities + (p : ℕ) [Fact p.Prime] (hpFive : 5 ≤ p) + (t : ZMod p) (x : ↑(normalizedFiber1 t)) + (hSplitExplicit : ∀ orbitExponent orbitOrder : ℕ, + orbitExponent * orbitOrder = p - 1 → + (p : ℝ) ^ (5 / 6 : ℝ) ≤ orbitOrder → + (orbitExponent : ℝ) * (((p - 1).divisors.card : ℕ) : ℝ) ^ 2 * + ((33 : ℝ) * Real.sqrt (p : ℝ)) < p) + (hNonsplitExplicit : ∀ orbitExponent orbitOrder : ℕ, + orbitExponent * orbitOrder = p + 1 → + (p : ℝ) ^ (5 / 6 : ℝ) ≤ orbitOrder → + (orbitExponent : ℝ) * (((p - 1).divisors.card : ℕ) : ℝ) ^ 2 * + ((34 : ℝ) * Real.sqrt (p : ℝ)) < p) + (hzero : 4 < (p : ℝ) ^ (5 / 6 : ℝ)) + (hlarge : (p : ℝ) ^ (5 / 6 : ℝ) ≤ rotationOrder t) : + ∃ n : ℕ, + rotationOrder + (((normalizedRotate1^[n]) + (x : NormalizedPoint (ZMod p))).u2) = p - 1 := by + by_cases htParabolic : t ^ 2 = 4 + · exact exists_iterate_parabolicPoint_with_maximal_secondRotation + p hpFive t htParabolic x + · have ht0 : t ≠ 0 := by + intro htZero + subst t + have horderSmall := rotationOrder_zero_le_four p + have hlargeLe : (p : ℝ) ^ (5 / 6 : ℝ) ≤ 4 := + hlarge.trans (by exact_mod_cast horderSmall) + exact (not_lt_of_ge hlargeLe) hzero + exact exists_iterate_nonparabolicPoint_with_maximal_secondRotation_of_explicitInequalities + p hpFive t htParabolic ht0 x hSplitExplicit hNonsplitExplicit hlarge + +/-- The pointwise primitive cage relation converted into the fiber bridge +used by cage connectivity. -/ +theorem exists_splitMaximalFiberBridge_of_explicitInequality + (p : ℕ) [Fact p.Prime] (hpFive : 5 ≤ p) + (hexplicit : + (((p - 1).divisors.card : ℕ) : ℝ) ^ 2 * + ((100522 : ℝ) * Real.sqrt (p : ℝ)) < p) + (axis other : NormalizedCoordinateAxis) (xi eta : ZMod p) + (hxi : IsSplitMaximalTrace p xi) (heta : IsSplitMaximalTrace p eta) : + ∃ middle : NormalizedCoordinateAxis, ∃ y : ZMod p, + middle ≠ axis ∧ middle ≠ other ∧ IsSplitMaximalTrace p y ∧ + NormalizedFibersMeet + (normalizedFiberAt axis xi) (normalizedFiberAt middle y) ∧ + NormalizedFibersMeet + (normalizedFiberAt other eta) (normalizedFiberAt middle y) := by + obtain ⟨u, huRelation, huOrder⟩ := + exists_primitive_cageMiddleUnit_of_explicitInequality + 100522 cageWitnessPointEstimate_oneHundredThousandFiveHundredTwentyTwo + p hpFive axis other xi eta hxi heta (by + have hcard : Nat.card (ZMod p)ˣ = p - 1 := by + rw [Nat.card_units, Nat.card_zmod] + rw [hcard] + exact hexplicit) + have hcard : Nat.card (ZMod p)ˣ = p - 1 := by + rw [Nat.card_units, Nat.card_zmod] + have huSq : (u : ZMod p) ^ 2 ≠ 1 := by + intro huPower + have huDvd : orderOf u ∣ 2 := orderOf_dvd_of_pow_eq_one <| by + apply Units.ext + exact huPower + have huLe : orderOf u ≤ 2 := Nat.le_of_dvd (by norm_num) huDvd + rw [huOrder, hcard] at huLe + omega + refine ⟨cageBridgeAxis axis other, splitTorusTrace u, + cageBridgeAxis_ne_left axis other, cageBridgeAxis_ne_right axis other, ?_, + huRelation.1, huRelation.2⟩ + rw [IsSplitMaximalTrace, rotationOrder_splitTorusTrace u huSq, huOrder, hcard] + +/-- Pointwise connectivity of the selected cage from its closed numerical +inequality. -/ +theorem splitCage_connected_of_explicitInequality + (p : ℕ) [Fact p.Prime] [Invertible (3 : ZMod p)] (hpSeven : 7 ≤ p) + (hexplicit : + (((p - 1).divisors.card : ℕ) : ℝ) ^ 2 * + ((100522 : ℝ) * Real.sqrt (p : ℝ)) < p) + (x y : NormalizedMarkoffSurface (ZMod p)) + (hxCage : IsInSplitCage p x) (hyCage : IsInSplitCage p y) : + SameNormalizedComponent x y := by + rcases hxCage with ⟨axis, hxi⟩ + rcases hyCage with ⟨other, heta⟩ + let xi := normalizedCoordinateAt axis x.1 + let eta := normalizedCoordinateAt other y.1 + obtain ⟨middle, z, hmiddleAxis, hmiddleOther, hzMax, hxMeet, hyMeet⟩ := + exists_splitMaximalFiberBridge_of_explicitInequality + p (by omega) hexplicit axis other xi eta hxi heta + rcases hxMeet with ⟨px, hpxAxis, hpxMiddle⟩ + rcases hyMeet with ⟨py, hpyOther, hpyMiddle⟩ + let pxs : NormalizedMarkoffSurface (ZMod p) := + ⟨px, isNormalizedMarkoff_of_mem_normalizedFiberAt hpxAxis⟩ + let pys : NormalizedMarkoffSurface (ZMod p) := + ⟨py, isNormalizedMarkoff_of_mem_normalizedFiberAt hpyOther⟩ + have hxFiber : x.1 ∈ normalizedFiberAt axis xi := + mem_normalizedFiberAt_coordinate axis x + have hyFiber : y.1 ∈ normalizedFiberAt other eta := + mem_normalizedFiberAt_coordinate other y + have hxpx : SameNormalizedComponent x pxs := + sameNormalizedComponent_of_mem_same_splitMaximalFiber + p hpSeven axis xi hxi x pxs hxFiber hpxAxis + have hpxpy : SameNormalizedComponent pxs pys := + sameNormalizedComponent_of_mem_same_splitMaximalFiber + p hpSeven middle z hzMax pxs pys hpxMiddle hpyMiddle + have hypy : SameNormalizedComponent y pys := + sameNormalizedComponent_of_mem_same_splitMaximalFiber + p hpSeven other eta heta y pys hyFiber hpyOther + exact sameNormalizedComponent_trans hxpx + (sameNormalizedComponent_trans hpxpy (sameNormalizedComponent_symm hypy)) + +private theorem explicitCutoff_seven_le + {p : ℕ} [Fact p.Prime] + (hp : explicitStrongApproximationCutoff ≤ p) : 7 ≤ p := by + have hpOne : (1 : ℝ) ≤ p := by + exact_mod_cast (explicitCutoff_gt_one.trans_le hp).le + have hrootLe : (p : ℝ) ^ (1 / 8 : ℝ) ≤ p := by + simpa using Real.rpow_le_self_of_one_le hpOne (by norm_num : (1 / 8 : ℝ) ≤ 1) + have hfiveRoot : (5 : ℝ) < (p : ℝ) ^ (1 / 8 : ℝ) := + small_fixed_lt_rpow_one_div_eight_of_explicitCutoff hp (by norm_num) + have hfive : 5 < p := by + exact_mod_cast hfiveRoot.trans_le hrootLe + have hpSix : p ≠ 6 := by + intro hpEq + subst p + have hprime : Nat.Prime 6 := Fact.out + norm_num at hprime + omega + +/-- At the closed cutoff, the first-coordinate endgame reaches a maximal +split rotation with no residual numerical or geometric assumptions. -/ +theorem exists_explicit_sameComponent_maximalRotation_of_large_firstCoordinate + {p : ℕ} [Fact p.Prime] [Invertible (3 : ZMod p)] + (hp : explicitStrongApproximationCutoff ≤ p) + (x : NormalizedMarkoffSurface (ZMod p)) + (hlarge : (p : ℝ) ^ (5 / 6 : ℝ) ≤ rotationOrder x.1.u1) : + ∃ y : NormalizedMarkoffSurface (ZMod p), + SameNormalizedComponent x y ∧ rotationOrder y.1.u2 = p - 1 := by + let xf : ↑(normalizedFiber1 x.1.u1) := ⟨x.1, x.property, rfl⟩ + obtain ⟨n, hrotation⟩ := + exists_iterate_point_with_maximal_secondRotation_of_explicitInequalities + p ((by norm_num : 5 ≤ 7).trans (explicitCutoff_seven_le hp)) x.1.u1 xf + (fun orbitExponent orbitOrder hmul horder ↦ + explicit_endgamePrimitiveTrace_explicitInequality_of_card_sub_one + hp hmul horder (by norm_num)) + (fun orbitExponent orbitOrder hmul horder ↦ + explicit_endgamePrimitiveTrace_explicitInequality_of_card_add_one + hp hmul horder (by norm_num)) + (explicit_four_lt_rpow_five_div_six hp) hlarge + let y := (normalizedRotate1Surface^[n]) x + refine ⟨y, sameNormalizedComponent_iterate_normalizedRotate1Surface x n, ?_⟩ + rw [show y.1 = (normalizedRotate1^[n]) x.1 by + exact coe_iterate_normalizedRotate1Surface x n] + exact hrotation + +/-- First-coordinate form of the explicit large-order-to-cage endgame. -/ +theorem exists_explicit_sameComponent_splitCage_of_large_firstCoordinate + {p : ℕ} [Fact p.Prime] [Invertible (3 : ZMod p)] + (hp : explicitStrongApproximationCutoff ≤ p) + (x : NormalizedMarkoffSurface (ZMod p)) + (hlarge : (p : ℝ) ^ (5 / 6 : ℝ) ≤ rotationOrder x.1.u1) : + ∃ y : NormalizedMarkoffSurface (ZMod p), + SameNormalizedComponent x y ∧ IsInSplitCage p y := by + obtain ⟨y, hxy, hyOrder⟩ := + exists_explicit_sameComponent_maximalRotation_of_large_firstCoordinate hp x hlarge + exact ⟨y, hxy, .second, hyOrder⟩ + +/-- If one of the three coordinate rotations is explicitly large, the point +reaches the selected split cage. -/ +theorem exists_explicit_sameComponent_splitCage_of_some_largeCoordinate + {p : ℕ} [Fact p.Prime] [Invertible (3 : ZMod p)] + (hp : explicitStrongApproximationCutoff ≤ p) + (x : NormalizedMarkoffSurface (ZMod p)) + (hlarge : + (p : ℝ) ^ (5 / 6 : ℝ) ≤ rotationOrder x.1.u1 ∨ + (p : ℝ) ^ (5 / 6 : ℝ) ≤ rotationOrder x.1.u2 ∨ + (p : ℝ) ^ (5 / 6 : ℝ) ≤ rotationOrder x.1.u3) : + ∃ y : NormalizedMarkoffSurface (ZMod p), + SameNormalizedComponent x y ∧ IsInSplitCage p y := by + rcases hlarge with hfirst | hsecond | hthird + · exact exists_explicit_sameComponent_splitCage_of_large_firstCoordinate hp x hfirst + · let x' := normalizedSwap12Surface x + have hx' : SameNormalizedComponent x x' := sameNormalizedComponent_swap12Surface x + have hlarge' : + (p : ℝ) ^ (5 / 6 : ℝ) ≤ rotationOrder x'.1.u1 := by + simpa [x', normalizedSwap12, coe_normalizedSwap12Surface] using hsecond + obtain ⟨y, hy, hyOrder⟩ := + exists_explicit_sameComponent_maximalRotation_of_large_firstCoordinate hp x' hlarge' + exact ⟨y, sameNormalizedComponent_trans hx' hy, .second, hyOrder⟩ + · let x' := normalizedSwap12Surface (normalizedSwap23Surface x) + have hx23 : SameNormalizedComponent x (normalizedSwap23Surface x) := + sameNormalizedComponent_swap23Surface x + have hx12 : SameNormalizedComponent (normalizedSwap23Surface x) x' := + sameNormalizedComponent_swap12Surface (normalizedSwap23Surface x) + have hlarge' : + (p : ℝ) ^ (5 / 6 : ℝ) ≤ rotationOrder x'.1.u1 := by + simpa [x', normalizedSwap12, normalizedSwap23, coe_normalizedSwap12Surface, + coe_normalizedSwap23Surface] using hthird + obtain ⟨y, hy, hyOrder⟩ := + exists_explicit_sameComponent_maximalRotation_of_large_firstCoordinate hp x' hlarge' + exact ⟨y, sameNormalizedComponent_trans + (sameNormalizedComponent_trans hx23 hx12) hy, .second, hyOrder⟩ + +/-- The selected split cage is connected at the closed cutoff. -/ +theorem explicit_splitCage_connected + {p : ℕ} [Fact p.Prime] [Invertible (3 : ZMod p)] + (hp : explicitStrongApproximationCutoff ≤ p) + (x y : NormalizedMarkoffSurface (ZMod p)) + (hx : IsInSplitCage p x) (hy : IsInSplitCage p y) : + SameNormalizedComponent x y := by + exact splitCage_connected_of_explicitInequality p (explicitCutoff_seven_le hp) + (explicit_cageWitness_explicitInequality hp (by norm_num)) x y hx hy + +/-- A large-order point is in the component of any chosen base point of the +selected split cage. This is the endgame statement consumed by the maximal +bad-orbit argument. -/ +theorem explicit_sameNormalizedComponent_of_largeOrder_to_splitCage + {p : ℕ} [Fact p.Prime] [Invertible (3 : ZMod p)] + (hp : explicitStrongApproximationCutoff ≤ p) + (base x : NormalizedMarkoffSurface (ZMod p)) + (hbase : IsInSplitCage p base) + (hlarge : + (p : ℝ) ^ (5 / 6 : ℝ) ≤ rotationOrder x.1.u1 ∨ + (p : ℝ) ^ (5 / 6 : ℝ) ≤ rotationOrder x.1.u2 ∨ + (p : ℝ) ^ (5 / 6 : ℝ) ≤ rotationOrder x.1.u3) : + SameNormalizedComponent base x := by + obtain ⟨y, hxy, hy⟩ := + exists_explicit_sameComponent_splitCage_of_some_largeCoordinate hp x hlarge + exact sameNormalizedComponent_trans + (explicit_splitCage_connected hp base y hbase hy) + (sameNormalizedComponent_symm hxy) + +end + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/ExplicitEstimates.lean b/LeanPool/MarkoffModP/BGS/Markoff/ExplicitEstimates.lean new file mode 100644 index 0000000000..f9947c6676 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/ExplicitEstimates.lean @@ -0,0 +1,59 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.HasseWeil.GeneralBivariateAffineHasseWeil +public import LeanPool.MarkoffModP.BGS.Markoff.Endgame.WeilFromGeneralHasse +public import LeanPool.MarkoffModP.BGS.Markoff.Endgame.Nonsplit.HasseFromGeneral +public import LeanPool.MarkoffModP.BGS.Markoff.Cage.EstimateFromPlane +public import LeanPool.MarkoffModP.BGS.Markoff.Cage.PlaneHasseWeil + +/-! +# Fixed point-count estimates for explicit strong approximation + +The general affine Hasse--Weil theorem in this repository has coefficient +`8`. This file records, without existentially choosing any constants, the +four numerical specializations used by the explicit Markoff argument. +-/ + +@[expose] public section + +namespace BGS.Markoff + +noncomputable section + +/-- The fixed split trace estimate obtained from affine coefficient `8`. -/ +theorem weightedSplitTraceWeilBoundAssumption_thirtyThree : + WeightedSplitTraceWeilBoundAssumption 33 := by + simpa using + weightedSplitTraceWeilBoundAssumption_of_bivariateAffineHasseWeilBound 8 + BGS.HasseWeil.bivariateAffineHasseWeilBound_eight + +/-- The fixed nonsplit trace estimate obtained from affine coefficient `8`. -/ +theorem seededNonsplitTraceWeilBoundAssumption_thirtyFour : + SeededNonsplitTraceWeilBoundAssumption 34 := by + simpa using + seededNonsplitTraceWeilBoundAssumption_of_bivariateAffineHasseWeilBound 8 + BGS.HasseWeil.bivariateAffineHasseWeilBound_eight + +/-- The fixed cage-plane estimate obtained from affine coefficient `8`. -/ +theorem cagePlanePointEstimate_twoHundredFiftySix : + CagePlanePointEstimate 256 := by + simpa using + cagePlanePointEstimate_of_bivariateAffineHasseWeilBound 8 + BGS.HasseWeil.bivariateAffineHasseWeilBound_eight + +/-- The resulting fixed cage-witness estimate. -/ +theorem cageWitnessPointEstimate_oneHundredThousandFiveHundredTwentyTwo : + CageWitnessPointEstimate 100522 := by + simpa using + cageWitnessPointEstimate_of_cagePlanePointEstimate 256 + cagePlanePointEstimate_twoHundredFiftySix + +end + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/ExplicitNumericCertificates.lean b/LeanPool/MarkoffModP/BGS/Markoff/ExplicitNumericCertificates.lean new file mode 100644 index 0000000000..18f9acbcb1 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/ExplicitNumericCertificates.lean @@ -0,0 +1,600 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.ExplicitNumerics + +/-! +# Numerical certificates for the explicit strong-approximation cutoff + +This file packages the closed real-power and natural-power calculations used +by the explicit middle game, endgame, cage, and small-order argument. +-/ + +@[expose] public section + +namespace BGS.Markoff + +open scoped Topology + +/-! The certificates for the first explicit record remain available for +comparison, but the canonical declarations below use the ninth-moment cutoff. -/ +namespace Legacy + +private theorem fixed_pow_thirtyTwo_le_explicitDivisorConstant_of_le_32_pow + {fixed : ℕ} (hfixed : fixed ≤ 32 ^ 32) : + fixed ^ 32 ≤ BGS.NumberTheory.explicitDivisorConstant := by + rw [BGS.NumberTheory.explicitDivisorConstant_eq] + calc + fixed ^ 32 ≤ (32 ^ 32) ^ 32 := Nat.pow_le_pow_left hfixed 32 + _ ≤ (32 ^ 32) ^ (2 ^ 32) := + pow_le_pow_right₀ (by norm_num) (by norm_num) + +private theorem explicit_prime_one_lt + {p : ℕ} (hp : explicitStrongApproximationCutoff ≤ p) : + (1 : ℝ) < p := by + exact_mod_cast explicitCutoff_gt_one.trans_le hp + +private theorem rpow_lt_self_of_exponent_lt_one + {p : ℕ} (hp : explicitStrongApproximationCutoff ≤ p) + {a : ℝ} (ha : a < 1) : + (p : ℝ) ^ a < p := by + simpa only [Real.rpow_one] using + Real.rpow_lt_rpow_of_exponent_lt (explicit_prime_one_lt hp) ha + +/-- At the explicit cutoff, the all-divisors Corvaja--Zannier estimate obeys +both finite size conditions throughout the range +`p^(7/32) < currentOrder < p^(25/32)`. -/ +theorem explicit_middleGame_corvajaZannier_sizeBounds + {p currentOrder : ℕ} (hp : explicitStrongApproximationCutoff ≤ p) + (hLower : (p : ℝ) ^ (7 / 32 : ℝ) < currentOrder) + (hUpper : (currentOrder : ℝ) < (p : ℝ) ^ (25 / 32 : ℝ)) : + (corvajaZannierCorollaryTwoSafeCoefficient * + ((p - 1).divisors.card + (p + 1).divisors.card)) ^ 3 < currentOrder ∧ + corvajaZannierCorollaryTwoSafeCoefficient * + ((p - 1).divisors.card + (p + 1).divisors.card) * currentOrder < p := by + let A : ℕ := corvajaZannierCorollaryTwoSafeCoefficient * + ((p - 1).divisors.card + (p + 1).divisors.card) + have hpRealPos : (0 : ℝ) < p := (explicit_prime_one_lt hp).trans' zero_lt_one + have hpRealNonneg : (0 : ℝ) ≤ p := hpRealPos.le + have hA : (A : ℝ) ≤ 144 * (p : ℝ) ^ (2 / 32 : ℝ) := by + dsimp [A] + convert explicit_corvajaZannier_divisor_term_le hp using 1 <;> norm_num + have h144cube : (144 ^ 3 : ℝ) < (p : ℝ) ^ (1 / 32 : ℝ) := + by + have h := fixed_lt_rpow_one_div_thirtyTwo_of_explicitCutoff hp + (fixed_pow_thirtyTwo_le_explicitDivisorConstant_of_le_32_pow + (fixed := 144 ^ 3) (by norm_num)) + norm_num at h ⊢ + exact h + have h144 : (144 : ℝ) < (p : ℝ) ^ (1 / 32 : ℝ) := + fixed_lt_rpow_one_div_thirtyTwo_of_explicitCutoff hp + (fixed_pow_thirtyTwo_le_explicitDivisorConstant_of_le_32_pow + (fixed := 144) (by norm_num)) + have hCubePower : + (144 * (p : ℝ) ^ (2 / 32 : ℝ)) ^ 3 = + 144 ^ 3 * (p : ℝ) ^ (6 / 32 : ℝ) := by + rw [mul_pow, ← Real.rpow_mul_natCast hpRealNonneg (2 / 32 : ℝ) 3] + congr 2 + norm_num + have hCube : (A : ℝ) ^ 3 < (currentOrder : ℝ) := by + calc + (A : ℝ) ^ 3 ≤ (144 * (p : ℝ) ^ (2 / 32 : ℝ)) ^ 3 := by + exact pow_le_pow_left₀ (Nat.cast_nonneg A) hA 3 + _ = 144 ^ 3 * (p : ℝ) ^ (6 / 32 : ℝ) := hCubePower + _ < (p : ℝ) ^ (1 / 32 : ℝ) * + (p : ℝ) ^ (6 / 32 : ℝ) := by + exact mul_lt_mul_of_pos_right h144cube + (Real.rpow_pos_of_pos hpRealPos _) + _ = (p : ℝ) ^ (7 / 32 : ℝ) := by + rw [← Real.rpow_add hpRealPos] + congr 1 + norm_num + _ < currentOrder := hLower + have hLinear : (A : ℝ) * currentOrder < p := by + calc + (A : ℝ) * currentOrder ≤ + (144 * (p : ℝ) ^ (2 / 32 : ℝ)) * currentOrder := by + exact mul_le_mul_of_nonneg_right hA (Nat.cast_nonneg currentOrder) + _ < (144 * (p : ℝ) ^ (2 / 32 : ℝ)) * + (p : ℝ) ^ (25 / 32 : ℝ) := by + exact mul_lt_mul_of_pos_left hUpper + (mul_pos (by norm_num) (Real.rpow_pos_of_pos hpRealPos _)) + _ = 144 * ((p : ℝ) ^ (2 / 32 : ℝ) * + (p : ℝ) ^ (25 / 32 : ℝ)) := by ring + _ < (p : ℝ) ^ (1 / 32 : ℝ) * + ((p : ℝ) ^ (2 / 32 : ℝ) * + (p : ℝ) ^ (25 / 32 : ℝ)) := by + exact mul_lt_mul_of_pos_right h144 + (mul_pos (Real.rpow_pos_of_pos hpRealPos _) + (Real.rpow_pos_of_pos hpRealPos _)) + _ = (p : ℝ) ^ (28 / 32 : ℝ) := by + rw [← Real.rpow_add hpRealPos, ← Real.rpow_add hpRealPos] + congr 1 + norm_num + _ < p := rpow_lt_self_of_exponent_lt_one hp (by norm_num) + constructor + · exact_mod_cast hCube + · exact_mod_cast hLinear + +/-- The primitive-inclusion--exclusion error is strictly smaller than its +main term for an exponent at most `2*p^(9/32)` and every coefficient at most +`34`. -/ +theorem explicit_endgamePrimitiveTrace_explicitInequality + {p orbitExponent coefficient : ℕ} + (hp : explicitStrongApproximationCutoff ≤ p) + (horbit : (orbitExponent : ℝ) ≤ 2 * (p : ℝ) ^ (9 / 32 : ℝ)) + (hcoefficient : coefficient ≤ 34) : + (orbitExponent : ℝ) * ((p - 1).divisors.card : ℝ) ^ 2 * + ((coefficient : ℝ) * Real.sqrt (p : ℝ)) < p := by + have hpRealPos : (0 : ℝ) < p := (explicit_prime_one_lt hp).trans' zero_lt_one + have hdivisorSum := explicit_divisor_sum_le_three_mul_rpow hp + have hdivisor : ((p - 1).divisors.card : ℝ) ≤ + 3 * (p : ℝ) ^ (2 / 32 : ℝ) := by + norm_num only [Nat.cast_add] at hdivisorSum + have hle : ((p - 1).divisors.card : ℝ) ≤ + ((p - 1).divisors.card : ℝ) + ((p + 1).divisors.card : ℝ) := by + exact le_add_of_nonneg_right (Nat.cast_nonneg _) + calc + ((p - 1).divisors.card : ℝ) ≤ + ((p - 1).divisors.card : ℝ) + ((p + 1).divisors.card : ℝ) := hle + _ ≤ 3 * (p : ℝ) ^ (1 / 16 : ℝ) := hdivisorSum + _ = 3 * (p : ℝ) ^ (2 / 32 : ℝ) := by norm_num + have hfixed : (2 * 3 ^ 2 * 34 : ℝ) < + (p : ℝ) ^ (1 / 32 : ℝ) := + by + have h := fixed_lt_rpow_one_div_thirtyTwo_of_explicitCutoff hp + (fixed_pow_thirtyTwo_le_explicitDivisorConstant_of_le_32_pow + (fixed := 2 * 3 ^ 2 * 34) (by norm_num)) + norm_num at h ⊢ + exact h + have hsqrt : Real.sqrt (p : ℝ) = (p : ℝ) ^ (16 / 32 : ℝ) := by + rw [Real.sqrt_eq_rpow] + congr 1 + norm_num + calc + (orbitExponent : ℝ) * ((p - 1).divisors.card : ℝ) ^ 2 * + ((coefficient : ℝ) * Real.sqrt (p : ℝ)) ≤ + (2 * (p : ℝ) ^ (9 / 32 : ℝ)) * + (3 * (p : ℝ) ^ (2 / 32 : ℝ)) ^ 2 * + (34 * Real.sqrt (p : ℝ)) := by + gcongr + exact_mod_cast hcoefficient + _ = (2 * 3 ^ 2 * 34) * + ((p : ℝ) ^ (9 / 32 : ℝ) * + ((p : ℝ) ^ (2 / 32 : ℝ)) ^ 2 * + (p : ℝ) ^ (16 / 32 : ℝ)) := by rw [hsqrt]; ring + _ = (2 * 3 ^ 2 * 34) * (p : ℝ) ^ (29 / 32 : ℝ) := by + rw [← Real.rpow_mul_natCast hpRealPos.le (2 / 32 : ℝ) 2, + ← Real.rpow_add hpRealPos, ← Real.rpow_add hpRealPos] + congr 2 + norm_num + _ < (p : ℝ) ^ (1 / 32 : ℝ) * + (p : ℝ) ^ (29 / 32 : ℝ) := by + exact mul_lt_mul_of_pos_right hfixed (Real.rpow_pos_of_pos hpRealPos _) + _ = (p : ℝ) ^ (30 / 32 : ℝ) := by + rw [← Real.rpow_add hpRealPos] + congr 1 + norm_num + _ < p := rpow_lt_self_of_exponent_lt_one hp (by norm_num) + +/-- Split-torus form of the explicit primitive-trace certificate. -/ +theorem explicit_endgamePrimitiveTrace_explicitInequality_of_card_sub_one + {p orbitExponent orbitOrder coefficient : ℕ} + (hp : explicitStrongApproximationCutoff ≤ p) + (hmul : orbitExponent * orbitOrder = p - 1) + (horder : (p : ℝ) ^ (23 / 32 : ℝ) ≤ orbitOrder) + (hcoefficient : coefficient ≤ 34) : + (orbitExponent : ℝ) * ((p - 1).divisors.card : ℝ) ^ 2 * + ((coefficient : ℝ) * Real.sqrt (p : ℝ)) < p := by + apply explicit_endgamePrimitiveTrace_explicitInequality hp ?_ hcoefficient + have hpNat : 0 < p := by + exact Nat.zero_lt_one.trans (explicitCutoff_gt_one.trans_le hp) + have horder' : (p : ℝ) ^ ((1 : ℝ) / 2 + 7 / 32) ≤ orbitOrder := by + convert horder using 1 <;> norm_num + have horbit := orbitExponent_le_rpow_of_mul_order_eq_card_sub_one + p orbitExponent orbitOrder hpNat hmul horder' + calc + (orbitExponent : ℝ) ≤ (p : ℝ) ^ ((1 : ℝ) / 2 - 7 / 32) := horbit + _ = (p : ℝ) ^ (9 / 32 : ℝ) := by norm_num + _ ≤ 2 * (p : ℝ) ^ (9 / 32 : ℝ) := by + have hnonneg : (0 : ℝ) ≤ (p : ℝ) ^ (9 / 32 : ℝ) := + Real.rpow_nonneg (Nat.cast_nonneg p) _ + linarith + +/-- Nonsplit-torus form of the explicit primitive-trace certificate. -/ +theorem explicit_endgamePrimitiveTrace_explicitInequality_of_card_add_one + {p orbitExponent orbitOrder coefficient : ℕ} + (hp : explicitStrongApproximationCutoff ≤ p) + (hmul : orbitExponent * orbitOrder = p + 1) + (horder : (p : ℝ) ^ (23 / 32 : ℝ) ≤ orbitOrder) + (hcoefficient : coefficient ≤ 34) : + (orbitExponent : ℝ) * ((p - 1).divisors.card : ℝ) ^ 2 * + ((coefficient : ℝ) * Real.sqrt (p : ℝ)) < p := by + apply explicit_endgamePrimitiveTrace_explicitInequality hp ?_ hcoefficient + have hpNat : 0 < p := by + exact Nat.zero_lt_one.trans (explicitCutoff_gt_one.trans_le hp) + have horder' : (p : ℝ) ^ ((1 : ℝ) / 2 + 7 / 32) ≤ orbitOrder := by + convert horder using 1 <;> norm_num + have horbit := orbitExponent_le_two_mul_rpow_of_mul_order_eq_card_add_one + p orbitExponent orbitOrder hpNat hmul horder' + convert horbit using 1 <;> norm_num + +/-- The trace-zero order bound `4` lies below the explicit endgame threshold. -/ +theorem explicit_four_lt_rpow_twentyThree_div_thirtyTwo + {p : ℕ} (hp : explicitStrongApproximationCutoff ≤ p) : + (4 : ℝ) < (p : ℝ) ^ (23 / 32 : ℝ) := by + have hfour : (4 : ℝ) < (p : ℝ) ^ (1 / 32 : ℝ) := + small_fixed_lt_rpow_one_div_thirtyTwo_of_explicitCutoff hp (by norm_num) + have hpOne := explicit_prime_one_lt hp + exact hfour.trans (Real.rpow_lt_rpow_of_exponent_lt hpOne (by norm_num)) + +/-- The middle-game lower threshold also dominates the order-four exceptional +case. -/ +theorem explicit_four_lt_rpow_seven_div_thirtyTwo + {p : ℕ} (hp : explicitStrongApproximationCutoff ≤ p) : + (4 : ℝ) < (p : ℝ) ^ (7 / 32 : ℝ) := by + have hfour : (4 : ℝ) < (p : ℝ) ^ (1 / 32 : ℝ) := + small_fixed_lt_rpow_one_div_thirtyTwo_of_explicitCutoff hp (by norm_num) + have hpOne := explicit_prime_one_lt hp + exact hfour.trans (Real.rpow_lt_rpow_of_exponent_lt hpOne (by norm_num)) + +/-- The coefficient `100522` cage error is dominated by `p` at the explicit +cutoff. -/ +theorem explicit_cageWitness_explicitInequality + {p coefficient : ℕ} (hp : explicitStrongApproximationCutoff ≤ p) + (hcoefficient : coefficient ≤ 100522) : + ((p - 1).divisors.card : ℝ) ^ 2 * + ((coefficient : ℝ) * Real.sqrt (p : ℝ)) < p := by + have hpRealPos : (0 : ℝ) < p := (explicit_prime_one_lt hp).trans' zero_lt_one + have hdivisorSum := explicit_divisor_sum_le_three_mul_rpow hp + have hdivisor : ((p - 1).divisors.card : ℝ) ≤ + 3 * (p : ℝ) ^ (2 / 32 : ℝ) := by + norm_num only [Nat.cast_add] at hdivisorSum + have hle : ((p - 1).divisors.card : ℝ) ≤ + ((p - 1).divisors.card : ℝ) + ((p + 1).divisors.card : ℝ) := by + exact le_add_of_nonneg_right (Nat.cast_nonneg _) + calc + ((p - 1).divisors.card : ℝ) ≤ + ((p - 1).divisors.card : ℝ) + ((p + 1).divisors.card : ℝ) := hle + _ ≤ 3 * (p : ℝ) ^ (1 / 16 : ℝ) := hdivisorSum + _ = 3 * (p : ℝ) ^ (2 / 32 : ℝ) := by norm_num + have hfixed : (3 ^ 2 * 100522 : ℝ) < + (p : ℝ) ^ (1 / 32 : ℝ) := + by + have h := fixed_lt_rpow_one_div_thirtyTwo_of_explicitCutoff hp + (fixed_pow_thirtyTwo_le_explicitDivisorConstant_of_le_32_pow + (fixed := 3 ^ 2 * 100522) (by norm_num)) + norm_num at h ⊢ + exact h + have hsqrt : Real.sqrt (p : ℝ) = (p : ℝ) ^ (16 / 32 : ℝ) := by + rw [Real.sqrt_eq_rpow] + congr 1 + norm_num + calc + ((p - 1).divisors.card : ℝ) ^ 2 * + ((coefficient : ℝ) * Real.sqrt (p : ℝ)) ≤ + (3 * (p : ℝ) ^ (2 / 32 : ℝ)) ^ 2 * + (100522 * Real.sqrt (p : ℝ)) := by + gcongr + exact_mod_cast hcoefficient + _ = (3 ^ 2 * 100522) * + (((p : ℝ) ^ (2 / 32 : ℝ)) ^ 2 * + (p : ℝ) ^ (16 / 32 : ℝ)) := by rw [hsqrt]; ring + _ = (3 ^ 2 * 100522) * (p : ℝ) ^ (20 / 32 : ℝ) := by + rw [← Real.rpow_mul_natCast hpRealPos.le (2 / 32 : ℝ) 2, + ← Real.rpow_add hpRealPos] + congr 2 + norm_num + _ < (p : ℝ) ^ (1 / 32 : ℝ) * + (p : ℝ) ^ (20 / 32 : ℝ) := by + exact mul_lt_mul_of_pos_right hfixed (Real.rpow_pos_of_pos hpRealPos _) + _ = (p : ℝ) ^ (21 / 32 : ℝ) := by + rw [← Real.rpow_add hpRealPos] + congr 1 + norm_num + _ < p := rpow_lt_self_of_exponent_lt_one hp (by norm_num) + +/-- The elementary low-order count cannot contain a nonempty orbit whose +cardinality is divisible by `p` once `d ≤ p^(7/32)`. -/ +theorem explicit_lowOrder_contradiction + {p d : ℕ} (hp : explicitStrongApproximationCutoff ≤ p) + (hpLe : p ≤ 32 * d ^ 4) + (hd : (d : ℝ) ≤ (p : ℝ) ^ (7 / 32 : ℝ)) : False := by + have hpRealPos : (0 : ℝ) < p := (explicit_prime_one_lt hp).trans' zero_lt_one + have hfixed : (32 : ℝ) < (p : ℝ) ^ (1 / 32 : ℝ) := + small_fixed_lt_rpow_one_div_thirtyTwo_of_explicitCutoff hp (by norm_num) + have hpLeReal : (p : ℝ) ≤ 32 * (d : ℝ) ^ 4 := by exact_mod_cast hpLe + have hbound : (32 : ℝ) * (d : ℝ) ^ 4 < p := by + calc + (32 : ℝ) * (d : ℝ) ^ 4 ≤ + 32 * ((p : ℝ) ^ (7 / 32 : ℝ)) ^ 4 := by + gcongr + _ < (p : ℝ) ^ (1 / 32 : ℝ) * + ((p : ℝ) ^ (7 / 32 : ℝ)) ^ 4 := by + exact mul_lt_mul_of_pos_right hfixed (pow_pos (Real.rpow_pos_of_pos hpRealPos _) _) + _ = (p : ℝ) ^ (29 / 32 : ℝ) := by + rw [← Real.rpow_mul_natCast hpRealPos.le (7 / 32 : ℝ) 4, + ← Real.rpow_add hpRealPos] + congr 1 + norm_num + _ < p := rpow_lt_self_of_exponent_lt_one hp (by norm_num) + exact (not_lt_of_ge hpLeReal) hbound + +/-- Variant of `explicit_lowOrder_contradiction` for the `d + 1` cutoff used +when maximality turns a strict order bound into a finite-set inclusion. -/ +theorem explicit_lowOrder_contradiction_512 + {p d : ℕ} (hp : explicitStrongApproximationCutoff ≤ p) + (hpLe : p ≤ 512 * d ^ 4) + (hd : (d : ℝ) ≤ (p : ℝ) ^ (7 / 32 : ℝ)) : False := by + have hpRealPos : (0 : ℝ) < p := (explicit_prime_one_lt hp).trans' zero_lt_one + have hfixed : (512 : ℝ) < (p : ℝ) ^ (1 / 32 : ℝ) := + small_fixed_lt_rpow_one_div_thirtyTwo_of_explicitCutoff hp (by norm_num) + have hpLeReal : (p : ℝ) ≤ 512 * (d : ℝ) ^ 4 := by exact_mod_cast hpLe + have hbound : (512 : ℝ) * (d : ℝ) ^ 4 < p := by + calc + (512 : ℝ) * (d : ℝ) ^ 4 ≤ + 512 * ((p : ℝ) ^ (7 / 32 : ℝ)) ^ 4 := by + gcongr + _ < (p : ℝ) ^ (1 / 32 : ℝ) * + ((p : ℝ) ^ (7 / 32 : ℝ)) ^ 4 := by + exact mul_lt_mul_of_pos_right hfixed (pow_pos (Real.rpow_pos_of_pos hpRealPos _) _) + _ = (p : ℝ) ^ (29 / 32 : ℝ) := by + rw [← Real.rpow_mul_natCast hpRealPos.le (7 / 32 : ℝ) 4, + ← Real.rpow_add hpRealPos] + congr 1 + norm_num + _ < p := rpow_lt_self_of_exponent_lt_one hp (by norm_num) + exact (not_lt_of_ge hpLeReal) hbound + +end Legacy + +private theorem explicit_prime_one_lt + {p : ℕ} (hp : explicitStrongApproximationCutoff ≤ p) : + (1 : ℝ) < p := by + exact_mod_cast explicitCutoff_gt_one.trans_le hp + +private theorem rpow_lt_self_of_exponent_lt_one + {p : ℕ} (hp : explicitStrongApproximationCutoff ≤ p) + {a : ℝ} (ha : a < 1) : + (p : ℝ) ^ a < p := by + simpa only [Real.rpow_one] using + Real.rpow_lt_rpow_of_exponent_lt (explicit_prime_one_lt hp) ha + +/-- Below the five-sixths threshold, the coefficient-48 divisor term times +the current order is strictly smaller than `p`. -/ +theorem explicit_middleGame_corvajaZannier_linear_of_lt_fiveSixths + {p currentOrder : ℕ} (hp : explicitStrongApproximationCutoff ≤ p) + (hUpper : (currentOrder : ℝ) < (p : ℝ) ^ (5 / 6 : ℝ)) : + corvajaZannierCorollaryTwoSafeCoefficient * + ((p - 1).divisors.card + (p + 1).divisors.card) * currentOrder < p := by + let A : ℕ := corvajaZannierCorollaryTwoSafeCoefficient * + ((p - 1).divisors.card + (p + 1).divisors.card) + have hpRealPos : (0 : ℝ) < p := (explicit_prime_one_lt hp).trans' zero_lt_one + have hA : (A : ℝ) < (p : ℝ) ^ (1 / 6 : ℝ) := by + simpa [A] using explicit_corvajaZannier_divisor_term_lt_rpow_one_div_six hp + have hLinearPower : (p : ℝ) ^ (1 / 6 : ℝ) * + (p : ℝ) ^ (5 / 6 : ℝ) = (p : ℝ) := by + rw [← Real.rpow_add hpRealPos] + norm_num + have hLinear : (A : ℝ) * currentOrder < p := by + calc + (A : ℝ) * currentOrder ≤ + (p : ℝ) ^ (1 / 6 : ℝ) * currentOrder := + mul_le_mul_of_nonneg_right hA.le (Nat.cast_nonneg currentOrder) + _ < (p : ℝ) ^ (1 / 6 : ℝ) * (p : ℝ) ^ (5 / 6 : ℝ) := + mul_lt_mul_of_pos_left hUpper (Real.rpow_pos_of_pos hpRealPos _) + _ = (p : ℝ) := hLinearPower + exact_mod_cast hLinear + +/-- Assembly-facing alias for the five-sixths middle-game certificate. -/ +theorem explicit_middleGame_corvajaZannier_linearBound + {p currentOrder : ℕ} (hp : explicitStrongApproximationCutoff ≤ p) + (hUpper : (currentOrder : ℝ) < (p : ℝ) ^ (5 / 6 : ℝ)) : + corvajaZannierCorollaryTwoSafeCoefficient * + ((p - 1).divisors.card + (p + 1).divisors.card) * currentOrder < p := + explicit_middleGame_corvajaZannier_linear_of_lt_fiveSixths hp hUpper + +/-- Primitive-trace inclusion--exclusion at exponent at most `2*p^(1/6)`. -/ +theorem explicit_endgamePrimitiveTrace_explicitInequality + {p orbitExponent coefficient : ℕ} + (hp : explicitStrongApproximationCutoff ≤ p) + (horbit : (orbitExponent : ℝ) ≤ 2 * (p : ℝ) ^ (1 / 6 : ℝ)) + (hcoefficient : coefficient ≤ 34) : + (orbitExponent : ℝ) * ((p - 1).divisors.card : ℝ) ^ 2 * + ((coefficient : ℝ) * Real.sqrt (p : ℝ)) < p := by + let T := (p - 1).divisors.card + (p + 1).divisors.card + have hpRealPos : (0 : ℝ) < p := (explicit_prime_one_lt hp).trans' zero_lt_one + have hdivisor : ((p - 1).divisors.card : ℝ) ≤ (T : ℝ) := by + exact_mod_cast (show (p - 1).divisors.card ≤ T by + dsimp [T] + omega) + have hweighted : (68 : ℝ) * (T : ℝ) ^ 2 < + (p : ℝ) ^ (1 / 3 : ℝ) := by + simpa [T] using explicit_weighted_divisor_sum_sq_lt_rpow_one_div_three hp + calc + (orbitExponent : ℝ) * ((p - 1).divisors.card : ℝ) ^ 2 * + ((coefficient : ℝ) * Real.sqrt (p : ℝ)) ≤ + (2 * (p : ℝ) ^ (1 / 6 : ℝ)) * (T : ℝ) ^ 2 * + (34 * Real.sqrt (p : ℝ)) := by + gcongr + exact_mod_cast hcoefficient + _ = (68 * (T : ℝ) ^ 2) * + ((p : ℝ) ^ (1 / 6 : ℝ) * Real.sqrt (p : ℝ)) := by ring + _ < (p : ℝ) ^ (1 / 3 : ℝ) * + ((p : ℝ) ^ (1 / 6 : ℝ) * Real.sqrt (p : ℝ)) := by + exact mul_lt_mul_of_pos_right hweighted <| + mul_pos (Real.rpow_pos_of_pos hpRealPos _) (Real.sqrt_pos.2 hpRealPos) + _ = (p : ℝ) := by + rw [Real.sqrt_eq_rpow, ← Real.rpow_add hpRealPos, + ← Real.rpow_add hpRealPos] + norm_num + +/-- Split-torus form of the improved primitive-trace certificate. -/ +theorem explicit_endgamePrimitiveTrace_explicitInequality_of_card_sub_one + {p orbitExponent orbitOrder coefficient : ℕ} + (hp : explicitStrongApproximationCutoff ≤ p) + (hmul : orbitExponent * orbitOrder = p - 1) + (horder : (p : ℝ) ^ (5 / 6 : ℝ) ≤ orbitOrder) + (hcoefficient : coefficient ≤ 34) : + (orbitExponent : ℝ) * ((p - 1).divisors.card : ℝ) ^ 2 * + ((coefficient : ℝ) * Real.sqrt (p : ℝ)) < p := by + apply explicit_endgamePrimitiveTrace_explicitInequality hp ?_ hcoefficient + have hpNat : 0 < p := Nat.zero_lt_one.trans (explicitCutoff_gt_one.trans_le hp) + have horbit := orbitExponent_le_rpow_of_mul_order_eq_card_sub_one + p orbitExponent orbitOrder (δ := (1 / 3 : ℝ)) hpNat hmul (by + convert horder using 1 <;> norm_num) + calc + (orbitExponent : ℝ) ≤ (p : ℝ) ^ (1 / 6 : ℝ) := by + convert horbit using 1 <;> norm_num + _ ≤ 2 * (p : ℝ) ^ (1 / 6 : ℝ) := by + nlinarith [Real.rpow_nonneg (Nat.cast_nonneg p) (1 / 6 : ℝ)] + +/-- Nonsplit-torus form of the improved primitive-trace certificate. -/ +theorem explicit_endgamePrimitiveTrace_explicitInequality_of_card_add_one + {p orbitExponent orbitOrder coefficient : ℕ} + (hp : explicitStrongApproximationCutoff ≤ p) + (hmul : orbitExponent * orbitOrder = p + 1) + (horder : (p : ℝ) ^ (5 / 6 : ℝ) ≤ orbitOrder) + (hcoefficient : coefficient ≤ 34) : + (orbitExponent : ℝ) * ((p - 1).divisors.card : ℝ) ^ 2 * + ((coefficient : ℝ) * Real.sqrt (p : ℝ)) < p := by + apply explicit_endgamePrimitiveTrace_explicitInequality hp ?_ hcoefficient + have hpNat : 0 < p := Nat.zero_lt_one.trans (explicitCutoff_gt_one.trans_le hp) + have horbit := orbitExponent_le_two_mul_rpow_of_mul_order_eq_card_add_one + p orbitExponent orbitOrder (δ := (1 / 3 : ℝ)) hpNat hmul (by + convert horder using 1 <;> norm_num) + convert horbit using 1 <;> norm_num + +/-- The trace-zero order bound lies below the improved endgame threshold. -/ +theorem explicit_four_lt_rpow_five_div_six + {p : ℕ} (hp : explicitStrongApproximationCutoff ≤ p) : + (4 : ℝ) < (p : ℝ) ^ (5 / 6 : ℝ) := by + have hfour : (4 : ℝ) < (p : ℝ) ^ (1 / 8 : ℝ) := + small_fixed_lt_rpow_one_div_eight_of_explicitCutoff hp (by norm_num) + exact hfour.trans <| + Real.rpow_lt_rpow_of_exponent_lt (explicit_prime_one_lt hp) (by norm_num) + +/-- The coefficient-`100522` cage error is dominated by `p`. -/ +theorem explicit_cageWitness_explicitInequality + {p coefficient : ℕ} (hp : explicitStrongApproximationCutoff ≤ p) + (hcoefficient : coefficient ≤ 100522) : + ((p - 1).divisors.card : ℝ) ^ 2 * + ((coefficient : ℝ) * Real.sqrt (p : ℝ)) < p := by + have hpRealPos : (0 : ℝ) < p := (explicit_prime_one_lt hp).trans' zero_lt_one + have hpRealNonneg : (0 : ℝ) ≤ p := hpRealPos.le + have hsum := explicit_divisor_sum_lt_rpow_one_div_eight hp + have hdivisor : ((p - 1).divisors.card : ℝ) ≤ + (p : ℝ) ^ (1 / 8 : ℝ) := by + norm_num only [Nat.cast_add] at hsum + exact (le_add_of_nonneg_right (Nat.cast_nonneg _)).trans hsum.le + have hfixed : (100522 : ℝ) < (p : ℝ) ^ (1 / 8 : ℝ) := + small_fixed_lt_rpow_one_div_eight_of_explicitCutoff hp (by norm_num) + have hsqrt : Real.sqrt (p : ℝ) = (p : ℝ) ^ (4 / 8 : ℝ) := by + rw [Real.sqrt_eq_rpow] + congr 1 + norm_num + have hpower : ((p : ℝ) ^ (1 / 8 : ℝ)) ^ 2 * Real.sqrt (p : ℝ) = + (p : ℝ) ^ (6 / 8 : ℝ) := by + rw [hsqrt, ← Real.rpow_mul_natCast hpRealNonneg, ← Real.rpow_add hpRealPos] + congr 1 + norm_num + calc + ((p - 1).divisors.card : ℝ) ^ 2 * + ((coefficient : ℝ) * Real.sqrt (p : ℝ)) ≤ + ((p : ℝ) ^ (1 / 8 : ℝ)) ^ 2 * + (100522 * Real.sqrt (p : ℝ)) := by + gcongr + exact_mod_cast hcoefficient + _ = 100522 * (p : ℝ) ^ (6 / 8 : ℝ) := by rw [← hpower]; ring + _ < (p : ℝ) ^ (1 / 8 : ℝ) * (p : ℝ) ^ (6 / 8 : ℝ) := by + exact mul_lt_mul_of_pos_right hfixed (Real.rpow_pos_of_pos hpRealPos _) + _ = (p : ℝ) ^ (7 / 8 : ℝ) := by + rw [← Real.rpow_add hpRealPos] + congr 1 + norm_num + _ < p := rpow_lt_self_of_exponent_lt_one hp (by norm_num) + +/-- A divisor-sensitive small-order set large enough to contain a nonempty +`p`-divisible orbit forces the Corvaja--Zannier cube below the maximal order. -/ +theorem explicit_lowOrder_forces_corvajaZannier_cube + {p d : ℕ} (hp : explicitStrongApproximationCutoff ≤ p) + (hdPos : 0 < d) + (hpLe : p ≤ 2 * (2 + d * + ((p - 1).divisors.card + (p + 1).divisors.card)) ^ 2) : + (corvajaZannierCorollaryTwoSafeCoefficient * + ((p - 1).divisors.card + (p + 1).divisors.card)) ^ 3 < d := by + let T := (p - 1).divisors.card + (p + 1).divisors.card + let B := 48 ^ 3 + 1 + have hpTwo : 2 ≤ p := by + have := explicitCutoff_gt_one.trans_le hp + omega + have hminusNonempty : (p - 1).divisors.Nonempty := + (Nat.nonempty_divisors).2 (by omega) + have hplusNonempty : (p + 1).divisors.Nonempty := + (Nat.nonempty_divisors).2 (by omega) + have hTtwo : 2 ≤ T := by + have hm : 0 < (p - 1).divisors.card := Finset.card_pos.mpr hminusNonempty + have hp' : 0 < (p + 1).divisors.card := Finset.card_pos.mpr hplusNonempty + dsimp [T] + omega + have hTfour : 2 ≤ T ^ 4 := by + calc + 2 ≤ T := hTtwo + _ = T * 1 := by ring + _ ≤ T * T ^ 3 := by + gcongr + exact Nat.one_le_pow 3 T (by omega) + _ = T ^ 4 := by ring + change (48 * T) ^ 3 < d + by_contra hcube + have hdUpper : d ≤ (48 * T) ^ 3 := by omega + have hinner : 2 + d * T ≤ B * T ^ 4 := by + calc + 2 + d * T ≤ T ^ 4 + d * T := Nat.add_le_add_right hTfour _ + _ ≤ T ^ 4 + (48 * T) ^ 3 * T := by gcongr + _ = B * T ^ 4 := by dsimp [B]; ring + have hpLeCoarse : p ≤ 2 * B ^ 2 * T ^ 8 := by + calc + p ≤ 2 * (2 + d * T) ^ 2 := by simpa [T] using hpLe + _ ≤ 2 * (B * T ^ 4) ^ 2 := by gcongr + _ = 2 * B ^ 2 * T ^ 8 := by ring + have hmoment : T ^ 9 ≤ explicitDivisorMomentConstant * p := by + simpa [T] using explicit_divisor_sum_pow_nine_le hpTwo + have hpPowLe : p ^ 9 ≤ + (2 ^ 9 * B ^ 18 * explicitDivisorMomentConstant ^ 8) * p ^ 8 := by + calc + p ^ 9 ≤ (2 * B ^ 2 * T ^ 8) ^ 9 := Nat.pow_le_pow_left hpLeCoarse _ + _ = 2 ^ 9 * B ^ 18 * (T ^ 9) ^ 8 := by ring + _ ≤ 2 ^ 9 * B ^ 18 * + (explicitDivisorMomentConstant * p) ^ 8 := by gcongr + _ = (2 ^ 9 * B ^ 18 * explicitDivisorMomentConstant ^ 8) * p ^ 8 := by + ring + have hconstant : + 2 ^ 9 * B ^ 18 * explicitDivisorMomentConstant ^ 8 < p := by + simpa [B] using explicitCutoff_constant_lt hp + have hstrict : + (2 ^ 9 * B ^ 18 * explicitDivisorMomentConstant ^ 8) * p ^ 8 < + p ^ 9 := by + calc + (2 ^ 9 * B ^ 18 * explicitDivisorMomentConstant ^ 8) * p ^ 8 < + p * p ^ 8 := + mul_lt_mul_of_pos_right hconstant (pow_pos (by omega) 8) + _ = p ^ 9 := by ring + exact (not_lt_of_ge hpPowLe) hstrict + +/-- Assembly-facing alias for the divisor-sensitive cube certificate. -/ +theorem explicit_lowOrder_divisorSensitive_cube + {p d : ℕ} (hp : explicitStrongApproximationCutoff ≤ p) + (hdPos : 0 < d) + (hpLe : p ≤ 2 * (2 + d * + ((p - 1).divisors.card + (p + 1).divisors.card)) ^ 2) : + (corvajaZannierCorollaryTwoSafeCoefficient * + ((p - 1).divisors.card + (p + 1).divisors.card)) ^ 3 < d := + explicit_lowOrder_forces_corvajaZannier_cube hp hdPos hpLe + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/ExplicitNumerics.lean b/LeanPool/MarkoffModP/BGS/Markoff/ExplicitNumerics.lean new file mode 100644 index 0000000000..ce1db82d09 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/ExplicitNumerics.lean @@ -0,0 +1,405 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.NumberTheory.ExplicitDivisorBound +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.DivisorRange +public import LeanPool.MarkoffModP.BGS.Markoff.Endgame.PrimitiveInclusionExclusion + +/-! +# Closed numerical bounds for explicit strong approximation + +All constants in this file are closed natural-number expressions. In +particular, no witness is extracted from an eventual or asymptotic theorem. +-/ + +@[expose] public section + +namespace BGS.Markoff + +open scoped Topology + +/-! The first explicit record is retained in a namespace for comparison. -/ +namespace Legacy + +/-- Sealed data for the deliberately conservative project cutoff. -/ +@[irreducible] noncomputable def explicitStrongApproximationCutoffData : + {n : ℕ // n = BGS.NumberTheory.explicitDivisorConstant + 1} := + ⟨BGS.NumberTheory.explicitDivisorConstant + 1, rfl⟩ + +/-- The deliberately conservative project cutoff. It is not the primorial +constant from arXiv:2308.07579. -/ +noncomputable def explicitStrongApproximationCutoff : ℕ := + explicitStrongApproximationCutoffData.1 + +theorem explicitStrongApproximationCutoff_eq : + explicitStrongApproximationCutoff = + BGS.NumberTheory.explicitDivisorConstant + 1 := + explicitStrongApproximationCutoffData.2 + +private theorem fixedNumeral_pow_thirtyTwo_le_explicitDivisorConstant : + 100522 ^ 32 ≤ BGS.NumberTheory.explicitDivisorConstant := by + rw [BGS.NumberTheory.explicitDivisorConstant_eq] + calc + 100522 ^ 32 ≤ (32 ^ 32) ^ 32 := + Nat.pow_le_pow_left (by norm_num) 32 + _ ≤ (32 ^ 32) ^ (2 ^ 32) := + pow_le_pow_right₀ (by norm_num) (by norm_num) + +theorem explicitCutoff_gt_one : 1 < explicitStrongApproximationCutoff := by + have hconstant : 0 < BGS.NumberTheory.explicitDivisorConstant := + BGS.NumberTheory.explicitDivisorConstant_pos + rw [explicitStrongApproximationCutoff_eq] + exact Nat.succ_lt_succ hconstant + +private theorem explicitCutoff_constant_lt + {p : ℕ} (hp : explicitStrongApproximationCutoff ≤ p) : + BGS.NumberTheory.explicitDivisorConstant < p := by + rw [explicitStrongApproximationCutoff_eq] at hp + exact (Nat.lt_succ_self _).trans_le hp + +theorem fixed_lt_rpow_one_div_thirtyTwo_of_explicitCutoff + {p fixed : ℕ} (hp : explicitStrongApproximationCutoff ≤ p) + (hfixed : fixed ^ 32 ≤ BGS.NumberTheory.explicitDivisorConstant) : + (fixed : ℝ) < (p : ℝ) ^ (1 / 32 : ℝ) := by + have hpPos : 0 < p := + Nat.zero_lt_one.trans (explicitCutoff_gt_one.trans_le hp) + have hpNonnegative : (0 : ℝ) ≤ p := by positivity + have hpowNat : fixed ^ 32 < p := + hfixed.trans_lt (explicitCutoff_constant_lt hp) + have hpowReal : + (fixed : ℝ) ^ 32 < (p : ℝ) := by + exact_mod_cast hpowNat + have hrootPow : ((p : ℝ) ^ (1 / 32 : ℝ)) ^ 32 = (p : ℝ) := by + calc + ((p : ℝ) ^ (1 / 32 : ℝ)) ^ 32 = + (p : ℝ) ^ ((1 / 32 : ℝ) * 32) := + (Real.rpow_mul_natCast hpNonnegative (1 / 32 : ℝ) 32).symm + _ = (p : ℝ) := by norm_num + apply lt_of_pow_lt_pow_left₀ 32 (Real.rpow_nonneg hpNonnegative _) + rw [hrootPow] + exact hpowReal + +theorem small_fixed_lt_rpow_one_div_thirtyTwo_of_explicitCutoff + {p fixed : ℕ} (hp : explicitStrongApproximationCutoff ≤ p) + (hfixed : fixed ≤ 100522) : + (fixed : ℝ) < (p : ℝ) ^ (1 / 32 : ℝ) := + fixed_lt_rpow_one_div_thirtyTwo_of_explicitCutoff hp + ((Nat.pow_le_pow_left hfixed 32).trans + fixedNumeral_pow_thirtyTwo_le_explicitDivisorConstant) + +private theorem explicitDivisorConstant_le_pred + {p : ℕ} (hp : explicitStrongApproximationCutoff ≤ p) : + BGS.NumberTheory.explicitDivisorConstant ≤ p - 1 := by + have hconstant := explicitCutoff_constant_lt hp + omega + +private theorem explicitDivisorConstant_le_succ + {p : ℕ} (hp : explicitStrongApproximationCutoff ≤ p) : + BGS.NumberTheory.explicitDivisorConstant ≤ p + 1 := by + have hconstant := explicitCutoff_constant_lt hp + omega + +/-- Both divisor counts occurring in the all-divisors Corvaja--Zannier +union bound are controlled by one sixteenth root of `p`. -/ +theorem explicit_divisor_sum_le_three_mul_rpow + {p : ℕ} (hp : explicitStrongApproximationCutoff ≤ p) : + (((p - 1).divisors.card + (p + 1).divisors.card : ℕ) : ℝ) ≤ + 3 * (p : ℝ) ^ (1 / 16 : ℝ) := by + have hpOne : 1 ≤ p := (explicitCutoff_gt_one.trans_le hp).le + have hpNonnegative : (0 : ℝ) ≤ p := by positivity + have hminusRaw := BGS.NumberTheory.card_divisors_le_rpow_one_div_sixteen + (p - 1) (explicitDivisorConstant_le_pred hp) + have hminusBase : (((p - 1 : ℕ) : ℝ) : ℝ) ≤ (p : ℝ) := by + exact_mod_cast Nat.sub_le p 1 + have hminus : ((p - 1).divisors.card : ℝ) ≤ + (p : ℝ) ^ (1 / 16 : ℝ) := + hminusRaw.trans (Real.rpow_le_rpow (Nat.cast_nonneg _) hminusBase (by norm_num)) + have hplusRaw := BGS.NumberTheory.card_divisors_le_rpow_one_div_sixteen + (p + 1) (explicitDivisorConstant_le_succ hp) + have hplusBase : (((p + 1 : ℕ) : ℝ) : ℝ) ≤ 2 * (p : ℝ) := by + exact_mod_cast (show p + 1 ≤ 2 * p by omega) + have htwo : (2 : ℝ) ^ (1 / 16 : ℝ) ≤ 2 := + Real.rpow_le_self_of_one_le (by norm_num) (by norm_num) + have hplus : ((p + 1).divisors.card : ℝ) ≤ + 2 * (p : ℝ) ^ (1 / 16 : ℝ) := by + calc + ((p + 1).divisors.card : ℝ) ≤ (((p + 1 : ℕ) : ℝ) : ℝ) ^ (1 / 16 : ℝ) := + hplusRaw + _ ≤ (2 * (p : ℝ)) ^ (1 / 16 : ℝ) := + Real.rpow_le_rpow (Nat.cast_nonneg _) hplusBase (by norm_num) + _ = (2 : ℝ) ^ (1 / 16 : ℝ) * (p : ℝ) ^ (1 / 16 : ℝ) := by + rw [Real.mul_rpow (by norm_num) hpNonnegative] + _ ≤ 2 * (p : ℝ) ^ (1 / 16 : ℝ) := by gcongr + norm_num only [Nat.cast_add] + linarith + +/-- The coefficient-48 all-divisors term used by the middle game. -/ +theorem explicit_corvajaZannier_divisor_term_le + {p : ℕ} (hp : explicitStrongApproximationCutoff ≤ p) : + ((corvajaZannierCorollaryTwoSafeCoefficient * + ((p - 1).divisors.card + (p + 1).divisors.card) : ℕ) : ℝ) ≤ + 144 * (p : ℝ) ^ (1 / 16 : ℝ) := by + have h := explicit_divisor_sum_le_three_mul_rpow hp + norm_num [corvajaZannierCorollaryTwoSafeCoefficient] at h ⊢ + linarith + +end Legacy + +/-! ## Ninth-moment adaptive cutoff -/ + +/-- The coefficient in the simultaneous ninth-moment bound for the divisor +counts of `p - 1` and `p + 1`. -/ +@[irreducible] def explicitDivisorMomentConstantData : + {n : ℕ // n = 2 ^ 9 * (9 ^ 9) ^ (2 ^ 9)} := + ⟨2 ^ 9 * (9 ^ 9) ^ (2 ^ 9), rfl⟩ + +def explicitDivisorMomentConstant : ℕ := + explicitDivisorMomentConstantData.1 + +theorem explicitDivisorMomentConstant_eq : + explicitDivisorMomentConstant = 2 ^ 9 * (9 ^ 9) ^ (2 ^ 9) := + explicitDivisorMomentConstantData.2 + +theorem explicitDivisorMomentConstant_pos : + 0 < explicitDivisorMomentConstant := by + rw [explicitDivisorMomentConstant_eq] + positivity + +/-- Sealed data for the improved project cutoff. -/ +@[irreducible] noncomputable def explicitStrongApproximationCutoffData : + {n : ℕ // n = + 2 ^ 9 * (48 ^ 3 + 1) ^ 18 * explicitDivisorMomentConstant ^ 8 + 1} := + ⟨2 ^ 9 * (48 ^ 3 + 1) ^ 18 * explicitDivisorMomentConstant ^ 8 + 1, rfl⟩ + +/-- The explicit project cutoff. It is deliberately different from the +primorial constant in arXiv:2308.07579. -/ +noncomputable def explicitStrongApproximationCutoff : ℕ := + explicitStrongApproximationCutoffData.1 + +theorem explicitStrongApproximationCutoff_eq : + explicitStrongApproximationCutoff = + 2 ^ 9 * (48 ^ 3 + 1) ^ 18 * explicitDivisorMomentConstant ^ 8 + 1 := + explicitStrongApproximationCutoffData.2 + +theorem explicitCutoff_gt_one : 1 < explicitStrongApproximationCutoff := by + rw [explicitStrongApproximationCutoff_eq] + exact Nat.succ_lt_succ <| + Nat.mul_pos (Nat.mul_pos (by positivity) (by positivity)) + (pow_pos explicitDivisorMomentConstant_pos _) + +theorem explicitCutoff_constant_lt + {p : ℕ} (hp : explicitStrongApproximationCutoff ≤ p) : + 2 ^ 9 * (48 ^ 3 + 1) ^ 18 * explicitDivisorMomentConstant ^ 8 < p := by + rw [explicitStrongApproximationCutoff_eq] at hp + omega + +/-- The elementary factorization estimate, specialized to the simultaneous +ninth moment needed below. -/ +theorem explicit_divisor_sum_pow_nine_le + {p : ℕ} (hp : 2 ≤ p) : + ((p - 1).divisors.card + (p + 1).divisors.card) ^ 9 ≤ + explicitDivisorMomentConstant * p := by + have hminusNe : p - 1 ≠ 0 := by omega + have hplusNe : p + 1 ≠ 0 := by omega + have hminus := BGS.NumberTheory.card_divisors_pow_le_explicit_constant_mul + 9 (by norm_num) (p - 1) hminusNe + have hplus := BGS.NumberTheory.card_divisors_pow_le_explicit_constant_mul + 9 (by norm_num) (p + 1) hplusNe + calc + ((p - 1).divisors.card + (p + 1).divisors.card) ^ 9 ≤ + 2 ^ (9 - 1) * + ((p - 1).divisors.card ^ 9 + (p + 1).divisors.card ^ 9) := + add_pow_le (Nat.zero_le _) (Nat.zero_le _) 9 + _ ≤ 2 ^ (9 - 1) * (((9 ^ 9) ^ (2 ^ 9) * (p - 1)) + + ((9 ^ 9) ^ (2 ^ 9) * (p + 1))) := by + gcongr + _ = explicitDivisorMomentConstant * p := by + let D := (9 ^ 9) ^ (2 ^ 9) + have hsub : p - 1 + (p + 1) = 2 * p := by omega + rw [explicitDivisorMomentConstant_eq] + change 2 ^ (9 - 1) * (D * (p - 1) + D * (p + 1)) = + (2 ^ 9 * D) * p + calc + 2 ^ (9 - 1) * (D * (p - 1) + D * (p + 1)) = + 2 ^ 8 * D * (p - 1 + (p + 1)) := by norm_num; ring + _ = 2 ^ 8 * D * (2 * p) := by rw [hsub] + _ = (2 ^ 9 * D) * p := by norm_num; ring + +private theorem explicitDivisorMomentConstant_pow_two_le_pow_eight : + explicitDivisorMomentConstant ^ 2 ≤ explicitDivisorMomentConstant ^ 8 := + Nat.pow_le_pow_right explicitDivisorMomentConstant_pos (by norm_num) + +/-- The complete coefficient-48 divisor term lies below the sixth root of +`p`. This is the linear middle-game estimate used up to order `p^(5/6)`. -/ +theorem explicit_corvajaZannier_divisor_term_lt_rpow_one_div_six + {p : ℕ} (hp : explicitStrongApproximationCutoff ≤ p) : + (corvajaZannierCorollaryTwoSafeCoefficient * + ((p - 1).divisors.card + (p + 1).divisors.card) : ℕ) < + (p : ℝ) ^ (1 / 6 : ℝ) := by + let T := (p - 1).divisors.card + (p + 1).divisors.card + have hpTwo : 2 ≤ p := by + have hcutoffTwo : 2 ≤ explicitStrongApproximationCutoff := + explicitCutoff_gt_one + omega + have hmoment : T ^ 9 ≤ explicitDivisorMomentConstant * p := + explicit_divisor_sum_pow_nine_le hpTwo + have hcoefficient : + 48 ^ 18 * explicitDivisorMomentConstant ^ 2 ≤ + 2 ^ 9 * (48 ^ 3 + 1) ^ 18 * explicitDivisorMomentConstant ^ 8 := by + exact Nat.mul_le_mul (by norm_num) + explicitDivisorMomentConstant_pow_two_le_pow_eight + have hconstant := explicitCutoff_constant_lt hp + have hpowNat : (48 * T) ^ 18 < p ^ 3 := by + calc + (48 * T) ^ 18 = 48 ^ 18 * (T ^ 9) ^ 2 := by + rw [mul_pow] + congr 1 + rw [show (18 : ℕ) = 9 * 2 by norm_num, pow_mul] + _ ≤ 48 ^ 18 * (explicitDivisorMomentConstant * p) ^ 2 := by gcongr + _ = (48 ^ 18 * explicitDivisorMomentConstant ^ 2) * p ^ 2 := by + rw [mul_pow] + ring + _ ≤ (2 ^ 9 * (48 ^ 3 + 1) ^ 18 * + explicitDivisorMomentConstant ^ 8) * p ^ 2 := + Nat.mul_le_mul_right _ hcoefficient + _ < p * p ^ 2 := by gcongr + _ = p ^ 3 := by ring + have hpNonnegative : (0 : ℝ) ≤ p := by positivity + have hpowReal : ((48 * T : ℕ) : ℝ) ^ 18 < (p : ℝ) ^ 3 := by + exact_mod_cast hpowNat + have hrootPow : (((p : ℝ) ^ (1 / 6 : ℝ)) ^ 18 = (p : ℝ) ^ 3) := by + calc + ((p : ℝ) ^ (1 / 6 : ℝ)) ^ 18 = + (p : ℝ) ^ ((1 / 6 : ℝ) * 18) := + (Real.rpow_mul_natCast hpNonnegative (1 / 6 : ℝ) 18).symm + _ = (p : ℝ) ^ 3 := by norm_num + norm_num only [corvajaZannierCorollaryTwoSafeCoefficient] + change ((48 * T : ℕ) : ℝ) < (p : ℝ) ^ (1 / 6 : ℝ) + apply lt_of_pow_lt_pow_left₀ 18 (Real.rpow_nonneg hpNonnegative _) + rw [hrootPow] + exact hpowReal + +/-- The weighted square of the simultaneous divisor count lies below the +one-third power needed by the primitive endgame. -/ +theorem explicit_weighted_divisor_sum_sq_lt_rpow_one_div_three + {p : ℕ} (hp : explicitStrongApproximationCutoff ≤ p) : + ((68 * ((p - 1).divisors.card + (p + 1).divisors.card) ^ 2 : ℕ) : ℝ) < + (p : ℝ) ^ (1 / 3 : ℝ) := by + let T := (p - 1).divisors.card + (p + 1).divisors.card + have hpTwo : 2 ≤ p := by + have hcutoffTwo : 2 ≤ explicitStrongApproximationCutoff := + explicitCutoff_gt_one + omega + have hmoment : T ^ 9 ≤ explicitDivisorMomentConstant * p := + explicit_divisor_sum_pow_nine_le hpTwo + have hcoefficient : + 68 ^ 9 * explicitDivisorMomentConstant ^ 2 ≤ + 2 ^ 9 * (48 ^ 3 + 1) ^ 18 * explicitDivisorMomentConstant ^ 8 := by + exact Nat.mul_le_mul (by norm_num) + explicitDivisorMomentConstant_pow_two_le_pow_eight + have hconstant := explicitCutoff_constant_lt hp + have hpowNat : (68 * T ^ 2) ^ 9 < p ^ 3 := by + calc + (68 * T ^ 2) ^ 9 = 68 ^ 9 * (T ^ 9) ^ 2 := by ring + _ ≤ 68 ^ 9 * (explicitDivisorMomentConstant * p) ^ 2 := by gcongr + _ = (68 ^ 9 * explicitDivisorMomentConstant ^ 2) * p ^ 2 := by + rw [mul_pow] + ring + _ ≤ (2 ^ 9 * (48 ^ 3 + 1) ^ 18 * + explicitDivisorMomentConstant ^ 8) * p ^ 2 := + Nat.mul_le_mul_right _ hcoefficient + _ < p * p ^ 2 := by gcongr + _ = p ^ 3 := by ring + have hpNonnegative : (0 : ℝ) ≤ p := by positivity + have hpowReal : ((68 * T ^ 2 : ℕ) : ℝ) ^ 9 < (p : ℝ) ^ 3 := by + exact_mod_cast hpowNat + have hrootPow : (((p : ℝ) ^ (1 / 3 : ℝ)) ^ 9 = (p : ℝ) ^ 3) := by + calc + ((p : ℝ) ^ (1 / 3 : ℝ)) ^ 9 = + (p : ℝ) ^ ((1 / 3 : ℝ) * 9) := + (Real.rpow_mul_natCast hpNonnegative (1 / 3 : ℝ) 9).symm + _ = (p : ℝ) ^ 3 := by norm_num + change ((68 * T ^ 2 : ℕ) : ℝ) < (p : ℝ) ^ (1 / 3 : ℝ) + apply lt_of_pow_lt_pow_left₀ 9 (Real.rpow_nonneg hpNonnegative _) + rw [hrootPow] + exact hpowReal + +/-- The simultaneous divisor count itself remains below the eighth root of +`p`; this sharper unweighted estimate is retained for the cage. -/ +theorem explicit_divisor_sum_lt_rpow_one_div_eight + {p : ℕ} (hp : explicitStrongApproximationCutoff ≤ p) : + (((p - 1).divisors.card + (p + 1).divisors.card : ℕ) : ℝ) < + (p : ℝ) ^ (1 / 8 : ℝ) := by + let T := (p - 1).divisors.card + (p + 1).divisors.card + have hpTwo : 2 ≤ p := by + have hcutoffTwo : 2 ≤ explicitStrongApproximationCutoff := + explicitCutoff_gt_one + omega + have hmoment : T ^ 9 ≤ explicitDivisorMomentConstant * p := + explicit_divisor_sum_pow_nine_le hpTwo + have hcoefficient : explicitDivisorMomentConstant ^ 8 ≤ + 2 ^ 9 * (48 ^ 3 + 1) ^ 18 * explicitDivisorMomentConstant ^ 8 := by + have hfactor : 1 ≤ 2 ^ 9 * (48 ^ 3 + 1) ^ 18 := by norm_num + simpa only [one_mul] using + Nat.mul_le_mul_right (explicitDivisorMomentConstant ^ 8) hfactor + have hconstant := explicitCutoff_constant_lt hp + have hpowNat : T ^ 72 < p ^ 9 := by + calc + T ^ 72 = (T ^ 9) ^ 8 := by + rw [show (72 : ℕ) = 9 * 8 by norm_num, pow_mul] + _ ≤ (explicitDivisorMomentConstant * p) ^ 8 := by gcongr + _ = explicitDivisorMomentConstant ^ 8 * p ^ 8 := by rw [mul_pow] + _ ≤ (2 ^ 9 * (48 ^ 3 + 1) ^ 18 * + explicitDivisorMomentConstant ^ 8) * p ^ 8 := + Nat.mul_le_mul_right _ hcoefficient + _ < p * p ^ 8 := by gcongr + _ = p ^ 9 := by ring + have hpNonnegative : (0 : ℝ) ≤ p := by positivity + have hpowReal : (T : ℝ) ^ 72 < (p : ℝ) ^ 9 := by exact_mod_cast hpowNat + have hrootPow : (((p : ℝ) ^ (1 / 8 : ℝ)) ^ 72 = (p : ℝ) ^ 9) := by + calc + ((p : ℝ) ^ (1 / 8 : ℝ)) ^ 72 = + (p : ℝ) ^ ((1 / 8 : ℝ) * 72) := + (Real.rpow_mul_natCast hpNonnegative (1 / 8 : ℝ) 72).symm + _ = (p : ℝ) ^ 9 := by norm_num + change (T : ℝ) < (p : ℝ) ^ (1 / 8 : ℝ) + apply lt_of_pow_lt_pow_left₀ 72 (Real.rpow_nonneg hpNonnegative _) + rw [hrootPow] + exact hpowReal + +/-- Every fixed coefficient used by the explicit proof is also below the +eighth root of `p`. -/ +theorem small_fixed_lt_rpow_one_div_eight_of_explicitCutoff + {p fixed : ℕ} (hp : explicitStrongApproximationCutoff ≤ p) + (hfixed : fixed ≤ 100522) : + (fixed : ℝ) < (p : ℝ) ^ (1 / 8 : ℝ) := by + have hmomentOne : 1 ≤ explicitDivisorMomentConstant ^ 8 := + Nat.one_le_pow _ _ explicitDivisorMomentConstant_pos + have hfixedPower : 100522 ^ 8 ≤ + 2 ^ 9 * (48 ^ 3 + 1) ^ 18 * explicitDivisorMomentConstant ^ 8 := by + have hnumeric : 100522 ^ 8 ≤ 2 ^ 9 * (48 ^ 3 + 1) ^ 18 := by norm_num + simpa only [mul_one] using Nat.mul_le_mul hnumeric hmomentOne + have hpowNat : fixed ^ 8 < p := by + calc + fixed ^ 8 ≤ 100522 ^ 8 := Nat.pow_le_pow_left hfixed _ + _ ≤ 2 ^ 9 * (48 ^ 3 + 1) ^ 18 * explicitDivisorMomentConstant ^ 8 := + hfixedPower + _ < p := explicitCutoff_constant_lt hp + have hpNonnegative : (0 : ℝ) ≤ p := by positivity + have hpowReal : (fixed : ℝ) ^ 8 < (p : ℝ) := by exact_mod_cast hpowNat + have hrootPow : ((p : ℝ) ^ (1 / 8 : ℝ)) ^ 8 = (p : ℝ) := by + calc + ((p : ℝ) ^ (1 / 8 : ℝ)) ^ 8 = + (p : ℝ) ^ ((1 / 8 : ℝ) * 8) := + (Real.rpow_mul_natCast hpNonnegative (1 / 8 : ℝ) 8).symm + _ = (p : ℝ) := by norm_num + apply lt_of_pow_lt_pow_left₀ 8 (Real.rpow_nonneg hpNonnegative _) + rw [hrootPow] + exact hpowReal + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Incidence.lean b/LeanPool/MarkoffModP/BGS/Markoff/Incidence.lean new file mode 100644 index 0000000000..6ab8db740e --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Incidence.lean @@ -0,0 +1,14 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Incidence.CoordinateRing +public import LeanPool.MarkoffModP.BGS.Markoff.Incidence.Counterexamples +public import LeanPool.MarkoffModP.BGS.Markoff.Incidence.Fibers +public import LeanPool.MarkoffModP.BGS.Markoff.Incidence.Geometry +public import LeanPool.MarkoffModP.BGS.Markoff.Incidence.NormalizedGraph +public import LeanPool.MarkoffModP.BGS.Markoff.Incidence.PointCount diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Incidence/CoordinateRing.lean b/LeanPool/MarkoffModP/BGS/Markoff/Incidence/CoordinateRing.lean new file mode 100644 index 0000000000..e3c29e57df --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Incidence/CoordinateRing.lean @@ -0,0 +1,863 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Incidence.Fibers +public import Mathlib.FieldTheory.KummerPolynomial +public import Mathlib.RingTheory.TensorProduct.MvPolynomial +public import Mathlib.RingTheory.TensorProduct.Quotient + +/-! +# Geometric integrality of the incidence auxiliary coordinate ring + +This module proves the missing coordinate-ring algebra by an explicit base change and rank-four +biquadratic normal form. Every declaration is proved; there are no placeholder axioms. +-/ + +@[expose] public section + +namespace BGS.Markoff + +open MvPolynomial +open scoped TensorProduct + +noncomputable section + +universe u v + +variable (K : Type u) [Field K] +variable (L : Type v) [Field L] [Algebra K L] + +/-- The explicit two-equation ideal after extending coefficients from `K` to `L`. -/ +def incidenceAuxBaseChangeIdeal (a b : K) : Ideal (MvPolynomial (Fin 3) L) := + Ideal.span + {MvPolynomial.map (algebraMap K L) (incidenceAuxPolynomial1 a), + MvPolynomial.map (algebraMap K L) (incidenceAuxPolynomial2 b)} + +lemma incidenceAuxBaseChangeIdeal_eq_map (a b : K) : + incidenceAuxBaseChangeIdeal K L a b = + (incidenceAuxIdeal a b).map + (MvPolynomial.map (σ := Fin 3) (algebraMap K L)) := by + simp only [incidenceAuxBaseChangeIdeal, incidenceAuxIdeal, Ideal.map_span, + Set.image_insert_eq, Set.image_singleton] + +lemma incidenceAuxBaseChangeIdeal_eq_incidenceAuxIdeal (a b : K) : + incidenceAuxBaseChangeIdeal K L a b = + incidenceAuxIdeal (algebraMap K L a) (algebraMap K L b) := by + simp [incidenceAuxBaseChangeIdeal, incidenceAuxIdeal, incidenceAuxPolynomial1, + incidenceAuxPolynomial2, map_sub, map_mul, map_pow, map_ofNat] + +lemma algebraTensorAlgEquiv_comp_includeRight : + (MvPolynomial.algebraTensorAlgEquiv (σ := Fin 3) K L).toRingHom.comp + (Algebra.TensorProduct.includeRight (R := K) (A := L)).toRingHom = + MvPolynomial.map (σ := Fin 3) (algebraMap K L) := by + apply MvPolynomial.ringHom_ext + · intro r + simp [RingHom.comp_apply] + · intro i + simp [RingHom.comp_apply] + +/-- Base change commutes with the explicit presentation of the incidence auxiliary curve. -/ +noncomputable def incidenceAuxCoordinateRingBaseChangeEquiv (a b : K) : + L ⊗[K] IncidenceAuxCoordinateRing K a b ≃ₐ[L] + MvPolynomial (Fin 3) L ⧸ incidenceAuxBaseChangeIdeal K L a b := + (Algebra.TensorProduct.tensorQuotientEquiv + (R := K) L (MvPolynomial (Fin 3) K) L (incidenceAuxIdeal a b)).trans + (Ideal.quotientEquivAlg + ((incidenceAuxIdeal a b).map + (Algebra.TensorProduct.includeRight (R := K) (A := L)).toRingHom) + (incidenceAuxBaseChangeIdeal K L a b) + (MvPolynomial.algebraTensorAlgEquiv (σ := Fin 3) K L) + (by + rw [incidenceAuxBaseChangeIdeal_eq_map] + rw [Ideal.map_map] + congr 1 + exact (algebraTensorAlgEquiv_comp_includeRight K L).symm)) + +/-- Base change identifies the original coordinate ring with the same two equations over the +larger coefficient field. -/ +noncomputable def incidenceAuxCoordinateRingBaseChangeExplicitEquiv (a b : K) : + L ⊗[K] IncidenceAuxCoordinateRing K a b ≃ₐ[L] + IncidenceAuxCoordinateRing L (algebraMap K L a) (algebraMap K L b) := + (incidenceAuxCoordinateRingBaseChangeEquiv K L a b).trans + (Ideal.quotientEquivAlgOfEq L + (incidenceAuxBaseChangeIdeal_eq_incidenceAuxIdeal K L a b)) + +/-- The monic quadratic used to adjoin a square root of an element. -/ +def adjoinSquarePolynomial {R : Type*} [CommRing R] (f : R) : Polynomial R := + Polynomial.X ^ 2 - Polynomial.C f + +lemma adjoinSquarePolynomial_monic {R : Type*} [CommRing R] (f : R) : + (adjoinSquarePolynomial f).Monic := by + exact Polynomial.monic_X_pow_sub_C f (by norm_num) + +lemma adjoinSquarePolynomial_natDegree {R : Type*} [Nontrivial R] [CommRing R] (f : R) : + (adjoinSquarePolynomial f).natDegree = 2 := by + simp [adjoinSquarePolynomial] + +lemma adjoinSquareRoot_sq {R : Type*} [CommRing R] (f : R) : + (AdjoinRoot.root (adjoinSquarePolynomial f)) ^ 2 = + algebraMap R (AdjoinRoot (adjoinSquarePolynomial f)) f := by + have h := AdjoinRoot.eval₂_root (adjoinSquarePolynomial f) + rw [adjoinSquarePolynomial, Polynomial.eval₂_sub, Polynomial.eval₂_pow, + Polynomial.eval₂_X, Polynomial.eval₂_C, sub_eq_zero] at h + exact h + +lemma adjoinSquarePolynomial_irreducible_of_not_isSquare + {F : Type*} [Field F] {f : F} (hf : ¬ IsSquare f) : + Irreducible (adjoinSquarePolynomial f) := by + apply X_pow_sub_C_irreducible_of_prime Nat.prime_two + intro z hz + apply hf + exact ⟨z, by simpa [pow_two] using hz.symm⟩ + +/-- In a quadratic extension generated by `sqrt f`, a base-field element `g` can become a +square only if `g` or `f * g` was already a square. -/ +lemma not_isSquare_algebraMap_adjoinSquare_of_independent + {F : Type*} [Field F] (h2 : (2 : F) ≠ 0) {f g : F} + (hf : ¬ IsSquare f) (hg : ¬ IsSquare g) (hfg : ¬ IsSquare (f * g)) : + ¬ IsSquare + (algebraMap F (AdjoinRoot (adjoinSquarePolynomial f)) g) := by + let q : Polynomial F := adjoinSquarePolynomial f + have hqIrreducible : Irreducible q := + adjoinSquarePolynomial_irreducible_of_not_isSquare hf + let : Fact (Irreducible q) := ⟨hqIrreducible⟩ + change ¬ IsSquare (algebraMap F (AdjoinRoot q) g) + have hqMonic : q.Monic := by simpa [q] using adjoinSquarePolynomial_monic f + have hqNatDegree : q.natDegree = 2 := by + simpa [q] using adjoinSquarePolynomial_natDegree f + let b : Module.Basis (Fin 2) F (AdjoinRoot q) := + (AdjoinRoot.powerBasis' hqMonic).basis.reindex (finCongr hqNatDegree) + rintro ⟨z, hzSquare⟩ + let x : F := b.repr z 0 + let y : F := b.repr z 1 + have hb0 : b 0 = 1 := by + simp only [b, Module.Basis.reindex_apply, PowerBasis.coe_basis] + change AdjoinRoot.root q ^ 0 = 1 + exact pow_zero _ + have hb1 : b 1 = AdjoinRoot.root q := by + simp only [b, Module.Basis.reindex_apply, PowerBasis.coe_basis] + change AdjoinRoot.root q ^ 1 = AdjoinRoot.root q + exact pow_one _ + have hz : z = algebraMap F (AdjoinRoot q) x + + algebraMap F (AdjoinRoot q) y * AdjoinRoot.root q := by + have hsum := b.sum_repr z + rw [Fin.sum_univ_two] at hsum + simpa [hb0, hb1, x, y, Algebra.smul_def] using hsum.symm + have hroot : (AdjoinRoot.root q) ^ 2 = algebraMap F (AdjoinRoot q) f := by + simpa [q] using adjoinSquareRoot_sq f + have hexpand : + algebraMap F (AdjoinRoot q) g = + algebraMap F (AdjoinRoot q) (x * x + y * y * f) + + algebraMap F (AdjoinRoot q) (2 * x * y) * AdjoinRoot.root q := by + rw [hzSquare, hz] + calc + (algebraMap F (AdjoinRoot q) x + + algebraMap F (AdjoinRoot q) y * AdjoinRoot.root q) * + (algebraMap F (AdjoinRoot q) x + + algebraMap F (AdjoinRoot q) y * AdjoinRoot.root q) = + algebraMap F (AdjoinRoot q) x * algebraMap F (AdjoinRoot q) x + + 2 * algebraMap F (AdjoinRoot q) x * algebraMap F (AdjoinRoot q) y * + AdjoinRoot.root q + + algebraMap F (AdjoinRoot q) y * algebraMap F (AdjoinRoot q) y * + (AdjoinRoot.root q) ^ 2 := by ring + _ = _ := by + rw [hroot] + simp only [map_add, map_mul, map_ofNat] + ring + have hbasisExpression : + g • b 0 = (x * x + y * y * f) • b 0 + (2 * x * y) • b 1 := by + simpa [hb0, hb1, Algebra.smul_def] using hexpand + have hconstant := congrArg (b.coord 0) hbasisExpression + have hlinear := congrArg (b.coord 1) hbasisExpression + have hgExpression : g = x * x + y * y * f := by + simpa using hconstant + have hxy : x * y = 0 := by + have htwoXY : (2 : F) * (x * y) = 0 := by + simpa [mul_assoc] using hlinear.symm + exact (mul_eq_zero.mp htwoXY).resolve_left h2 + rcases mul_eq_zero.mp hxy with hx | hy + · apply hfg + refine ⟨y * f, ?_⟩ + rw [hgExpression, hx] + ring + · apply hg + refine ⟨x, ?_⟩ + rw [hgExpression, hy] + ring + +/-- Extend coefficients in a quadratic `AdjoinRoot` presentation. -/ +def adjoinSquareMap {R S : Type*} [CommRing R] [CommRing S] + (φ : R →+* S) (f : R) : + AdjoinRoot (adjoinSquarePolynomial f) →+* + AdjoinRoot (adjoinSquarePolynomial (φ f)) := + AdjoinRoot.map φ (adjoinSquarePolynomial f) (adjoinSquarePolynomial (φ f)) + (by simp [adjoinSquarePolynomial]) + +/-- Extending coefficients in a monic quadratic presentation preserves injectivity. -/ +lemma adjoinSquareMap_injective {R S : Type*} [CommRing R] [CommRing S] + [Nontrivial R] [Nontrivial S] (φ : R →+* S) (hφ : Function.Injective φ) (f : R) : + Function.Injective (adjoinSquareMap φ f) := by + let qR : Polynomial R := adjoinSquarePolynomial f + let qS : Polynomial S := adjoinSquarePolynomial (φ f) + have hqRMonic : qR.Monic := by simpa [qR] using adjoinSquarePolynomial_monic f + have hqSMonic : qS.Monic := by simpa [qS] using adjoinSquarePolynomial_monic (φ f) + have hqRNatDegree : qR.natDegree = 2 := by + simpa [qR] using adjoinSquarePolynomial_natDegree f + have hqSNatDegree : qS.natDegree = 2 := by + simpa [qS] using adjoinSquarePolynomial_natDegree (φ f) + let bR : Module.Basis (Fin 2) R (AdjoinRoot qR) := + (AdjoinRoot.powerBasis' hqRMonic).basis.reindex (finCongr hqRNatDegree) + let bS : Module.Basis (Fin 2) S (AdjoinRoot qS) := + (AdjoinRoot.powerBasis' hqSMonic).basis.reindex (finCongr hqSNatDegree) + have hbR0 : bR 0 = 1 := by + simp only [bR, Module.Basis.reindex_apply, PowerBasis.coe_basis] + change AdjoinRoot.root qR ^ 0 = 1 + exact pow_zero _ + have hbR1 : bR 1 = AdjoinRoot.root qR := by + simp only [bR, Module.Basis.reindex_apply, PowerBasis.coe_basis] + change AdjoinRoot.root qR ^ 1 = AdjoinRoot.root qR + exact pow_one _ + have hbS0 : bS 0 = 1 := by + simp only [bS, Module.Basis.reindex_apply, PowerBasis.coe_basis] + change AdjoinRoot.root qS ^ 0 = 1 + exact pow_zero _ + have hbS1 : bS 1 = AdjoinRoot.root qS := by + simp only [bS, Module.Basis.reindex_apply, PowerBasis.coe_basis] + change AdjoinRoot.root qS ^ 1 = AdjoinRoot.root qS + exact pow_one _ + rw [injective_iff_map_eq_zero] + intro z hzMap + let x : R := bR.repr z 0 + let y : R := bR.repr z 1 + have hz : z = algebraMap R (AdjoinRoot qR) x + + algebraMap R (AdjoinRoot qR) y * AdjoinRoot.root qR := by + have hsum := bR.sum_repr z + rw [Fin.sum_univ_two] at hsum + simpa [hbR0, hbR1, x, y, Algebra.smul_def] using hsum.symm + have htarget : + algebraMap S (AdjoinRoot qS) (φ x) + + algebraMap S (AdjoinRoot qS) (φ y) * AdjoinRoot.root qS = 0 := by + rw [hz] at hzMap + simpa [adjoinSquareMap, AdjoinRoot.map, qR, qS] using hzMap + have hbasisTarget : φ x • bS 0 + φ y • bS 1 = 0 := by + simpa [hbS0, hbS1, Algebra.smul_def] using htarget + have hxMap := congrArg (bS.coord 0) hbasisTarget + have hyMap := congrArg (bS.coord 1) hbasisTarget + have hx : x = 0 := hφ (by simpa using hxMap) + have hy : y = 0 := hφ (by simpa using hyMap) + rw [hz, hx, hy] + simp + +/-- Adjoin the first branch square root over the polynomial ring in the `y`-coordinate. -/ +abbrev IncidenceFirstQuadraticRing (a : L) := + AdjoinRoot (adjoinSquarePolynomial (incidenceBranchPolynomial a)) + +noncomputable local instance incidenceFirstQuadraticRing_nontrivial (a : L) : + Nontrivial (IncidenceFirstQuadraticRing L a) := + AdjoinRoot.nontrivial _ (by + rw [Polynomial.degree_eq_natDegree (adjoinSquarePolynomial_monic _).ne_zero, + adjoinSquarePolynomial_natDegree] + norm_num) + +/-- Over the first quadratic cover, adjoin the second branch square root. -/ +def incidenceSecondQuadraticPolynomial (a b : L) : + Polynomial (IncidenceFirstQuadraticRing L a) := + adjoinSquarePolynomial + (algebraMap (Polynomial L) (IncidenceFirstQuadraticRing L a) + (incidenceBranchPolynomial b)) + +/-- The iterated quadratic algebra with generators satisfying the two incidence equations. -/ +abbrev IncidenceBiquadraticRing (a b : L) := + AdjoinRoot (incidenceSecondQuadraticPolynomial L a b) + +/-- The first quadratic extension after passing from `L[y]` to its rational function field. -/ +abbrev IncidenceFirstQuadraticRatFuncRing (a : L) := + AdjoinRoot + (adjoinSquarePolynomial + (algebraMap (Polynomial L) (RatFunc L) (incidenceBranchPolynomial a))) + +noncomputable local instance incidenceFirstQuadraticRatFuncRing_nontrivial (a : L) : + Nontrivial (IncidenceFirstQuadraticRatFuncRing L a) := + AdjoinRoot.nontrivial _ (by + rw [Polynomial.degree_eq_natDegree (adjoinSquarePolynomial_monic _).ne_zero, + adjoinSquarePolynomial_natDegree] + norm_num) + +/-- Extend the first quadratic cover from `L[y]` to `L(y)`. -/ +def incidenceFirstQuadraticToRatFunc (a : L) : + IncidenceFirstQuadraticRing L a →+* IncidenceFirstQuadraticRatFuncRing L a := + adjoinSquareMap (algebraMap (Polynomial L) (RatFunc L)) + (incidenceBranchPolynomial a) + +lemma incidenceFirstQuadraticToRatFunc_algebraMap (a : L) (r : Polynomial L) : + incidenceFirstQuadraticToRatFunc L a + (algebraMap (Polynomial L) (IncidenceFirstQuadraticRing L a) r) = + algebraMap (RatFunc L) (IncidenceFirstQuadraticRatFuncRing L a) + (algebraMap (Polynomial L) (RatFunc L) r) := by + simp [incidenceFirstQuadraticToRatFunc, adjoinSquareMap, AdjoinRoot.map] + +/-- The second quadratic polynomial over the first rational-function-field extension. -/ +def incidenceSecondQuadraticRatFuncPolynomial (a b : L) : + Polynomial (IncidenceFirstQuadraticRatFuncRing L a) := + adjoinSquarePolynomial + (incidenceFirstQuadraticToRatFunc L a + (algebraMap (Polynomial L) (IncidenceFirstQuadraticRing L a) + (incidenceBranchPolynomial b))) + +/-- The biquadratic field presentation over `L(y)`. Field instances are installed below from +the two irreducibility proofs. -/ +abbrev IncidenceBiquadraticRatFuncRing (a b : L) := + AdjoinRoot (incidenceSecondQuadraticRatFuncPolynomial L a b) + +/-- Extend both successive quadratic presentations from `L[y]` to `L(y)`. -/ +def incidenceBiquadraticToRatFunc (a b : L) : + IncidenceBiquadraticRing L a b →+* IncidenceBiquadraticRatFuncRing L a b := + adjoinSquareMap (incidenceFirstQuadraticToRatFunc L a) + (algebraMap (Polynomial L) (IncidenceFirstQuadraticRing L a) + (incidenceBranchPolynomial b)) + +lemma incidenceFirstQuadraticToRatFunc_injective (a : L) : + Function.Injective (incidenceFirstQuadraticToRatFunc L a) := by + exact adjoinSquareMap_injective _ + (FaithfulSMul.algebraMap_injective (Polynomial L) (RatFunc L)) _ + +lemma incidenceBiquadraticToRatFunc_injective (a b : L) : + Function.Injective (incidenceBiquadraticToRatFunc L a b) := by + exact adjoinSquareMap_injective _ (incidenceFirstQuadraticToRatFunc_injective L a) _ + +/-- The rational-function-field biquadratic presentation is a domain when the three square +classes supplied by the branch-polynomial calculation are nontrivial. -/ +theorem incidenceBiquadraticRatFuncRing_isDomain + (h2 : (2 : L) ≠ 0) {a b : L} + (ha : a ≠ 0) (hb : b ≠ 0) + (hA : 9 * a ^ 2 - 4 ≠ 0) (hB : 9 * b ^ 2 - 4 ≠ 0) + (hab : a ^ 2 ≠ b ^ 2) : + IsDomain (IncidenceBiquadraticRatFuncRing L a b) := by + obtain ⟨hf, hg, hfg⟩ := + incidenceBranchSquareClasses_independent_ratFunc h2 ha hb hA hB hab + have h2RatFunc : (2 : RatFunc L) ≠ 0 := by + intro hzero + apply h2 + apply FaithfulSMul.algebraMap_injective L (RatFunc L) + simpa only [map_ofNat, map_zero] using hzero + let : Fact + (Irreducible + (adjoinSquarePolynomial + (algebraMap (Polynomial L) (RatFunc L) (incidenceBranchPolynomial a)))) := + ⟨adjoinSquarePolynomial_irreducible_of_not_isSquare hf⟩ + have hsecondNotSquare : + ¬ IsSquare + (incidenceFirstQuadraticToRatFunc L a + (algebraMap (Polynomial L) (IncidenceFirstQuadraticRing L a) + (incidenceBranchPolynomial b))) := by + rw [incidenceFirstQuadraticToRatFunc_algebraMap] + apply not_isSquare_algebraMap_adjoinSquare_of_independent h2RatFunc hf hg + simpa only [map_mul] using hfg + let : Fact (Irreducible (incidenceSecondQuadraticRatFuncPolynomial L a b)) := + ⟨adjoinSquarePolynomial_irreducible_of_not_isSquare hsecondNotSquare⟩ + let : Field (IncidenceBiquadraticRatFuncRing L a b) := AdjoinRoot.instField + infer_instance + +/-- The rank-four algebra over `L[y]` is a domain because it injects into the preceding +biquadratic field presentation. -/ +theorem incidenceBiquadraticRing_isDomain + (h2 : (2 : L) ≠ 0) {a b : L} + (ha : a ≠ 0) (hb : b ≠ 0) + (hA : 9 * a ^ 2 - 4 ≠ 0) (hB : 9 * b ^ 2 - 4 ≠ 0) + (hab : a ^ 2 ≠ b ^ 2) : + IsDomain (IncidenceBiquadraticRing L a b) := by + let : IsDomain (IncidenceBiquadraticRatFuncRing L a b) := + incidenceBiquadraticRatFuncRing_isDomain L h2 ha hb hA hB hab + exact (incidenceBiquadraticToRatFunc_injective L a b).isDomain + (incidenceBiquadraticToRatFunc L a b) + +lemma incidenceSecondQuadraticPolynomial_monic (a b : L) : + (incidenceSecondQuadraticPolynomial L a b).Monic := by + exact adjoinSquarePolynomial_monic _ + +lemma incidenceSecondQuadraticPolynomial_natDegree (a b : L) : + (incidenceSecondQuadraticPolynomial L a b).natDegree = 2 := by + exact adjoinSquarePolynomial_natDegree _ + +/-- The canonical product basis of the two successive monic quadratic extensions. -/ +noncomputable def incidenceBiquadraticTowerBasis (a b : L) : + Module.Basis + (Fin (adjoinSquarePolynomial (incidenceBranchPolynomial a)).natDegree × + Fin (incidenceSecondQuadraticPolynomial L a b).natDegree) + (Polynomial L) (IncidenceBiquadraticRing L a b) := + (AdjoinRoot.powerBasis' (adjoinSquarePolynomial_monic + (incidenceBranchPolynomial a))).basis.smulTower + (AdjoinRoot.powerBasis' (incidenceSecondQuadraticPolynomial_monic L a b)).basis + +/-- The unreduced two-equation algebra has the expected rank four over `L[y]`. -/ +theorem incidenceBiquadraticRing_finrank (a b : L) : + Module.finrank (Polynomial L) (IncidenceBiquadraticRing L a b) = 4 := by + rw [Module.finrank_eq_card_basis (incidenceBiquadraticTowerBasis L a b)] + simp [adjoinSquarePolynomial_natDegree, incidenceSecondQuadraticPolynomial_natDegree] + +lemma incidenceFirstQuadraticRoot_sq (a : L) : + (AdjoinRoot.root + (adjoinSquarePolynomial (incidenceBranchPolynomial a))) ^ 2 = + algebraMap (Polynomial L) (IncidenceFirstQuadraticRing L a) + (incidenceBranchPolynomial a) := by + exact adjoinSquareRoot_sq _ + +lemma incidenceSecondQuadraticRoot_sq (a b : L) : + (AdjoinRoot.root (incidenceSecondQuadraticPolynomial L a b)) ^ 2 = + algebraMap (IncidenceFirstQuadraticRing L a) (IncidenceBiquadraticRing L a b) + (algebraMap (Polynomial L) (IncidenceFirstQuadraticRing L a) + (incidenceBranchPolynomial b)) := by + exact adjoinSquareRoot_sq _ + +/-- The `y`-coordinate in the iterated quadratic presentation. -/ +def incidenceBiquadraticY (a b : L) : IncidenceBiquadraticRing L a b := + algebraMap (Polynomial L) (IncidenceBiquadraticRing L a b) Polynomial.X + +/-- The first square-root coordinate in the iterated quadratic presentation. -/ +def incidenceBiquadraticLambda (a b : L) : IncidenceBiquadraticRing L a b := + algebraMap (IncidenceFirstQuadraticRing L a) (IncidenceBiquadraticRing L a b) + (AdjoinRoot.root (adjoinSquarePolynomial (incidenceBranchPolynomial a))) + +/-- The second square-root coordinate in the iterated quadratic presentation. -/ +def incidenceBiquadraticMu (a b : L) : IncidenceBiquadraticRing L a b := + AdjoinRoot.root (incidenceSecondQuadraticPolynomial L a b) + +/-- Evaluate the three-variable incidence presentation in the iterated quadratic algebra. -/ +def incidenceAuxAevalToBiquadratic (a b : L) : + MvPolynomial (Fin 3) L →ₐ[L] IncidenceBiquadraticRing L a b := + MvPolynomial.aeval ![incidenceBiquadraticY L a b, + incidenceBiquadraticLambda L a b, incidenceBiquadraticMu L a b] + +lemma incidenceAuxAevalToBiquadratic_polynomial1 (a b : L) : + incidenceAuxAevalToBiquadratic L a b (incidenceAuxPolynomial1 a) = 0 := by + simp only [incidenceAuxAevalToBiquadratic, incidenceAuxPolynomial1, map_sub, map_mul, + map_pow, MvPolynomial.aeval_C, MvPolynomial.aeval_X] + change + ((algebraMap L (IncidenceBiquadraticRing L a b)) 9 * + (algebraMap L (IncidenceBiquadraticRing L a b)) a ^ 2 - + (algebraMap L (IncidenceBiquadraticRing L a b)) 4) * + (incidenceBiquadraticY L a b) ^ 2 - + (incidenceBiquadraticLambda L a b) ^ 2 - + (algebraMap L (IncidenceBiquadraticRing L a b)) 4 * + (algebraMap L (IncidenceBiquadraticRing L a b)) a ^ 2 = 0 + rw [show (incidenceBiquadraticLambda L a b) ^ 2 = + algebraMap (Polynomial L) (IncidenceBiquadraticRing L a b) + (incidenceBranchPolynomial a) by + simp only [incidenceBiquadraticLambda] + rw [← map_pow, incidenceFirstQuadraticRoot_sq] + exact IsScalarTower.algebraMap_apply (Polynomial L) + (IncidenceFirstQuadraticRing L a) (IncidenceBiquadraticRing L a b) _] + simp only [incidenceBiquadraticY, incidenceBranchPolynomial] + simp [map_sub, map_mul, map_pow, + IsScalarTower.algebraMap_apply L (Polynomial L) (IncidenceBiquadraticRing L a b)] + +lemma incidenceAuxAevalToBiquadratic_polynomial2 (a b : L) : + incidenceAuxAevalToBiquadratic L a b (incidenceAuxPolynomial2 b) = 0 := by + simp only [incidenceAuxAevalToBiquadratic, incidenceAuxPolynomial2, map_sub, map_mul, + map_pow, MvPolynomial.aeval_C, MvPolynomial.aeval_X] + change + ((algebraMap L (IncidenceBiquadraticRing L a b)) 9 * + (algebraMap L (IncidenceBiquadraticRing L a b)) b ^ 2 - + (algebraMap L (IncidenceBiquadraticRing L a b)) 4) * + (incidenceBiquadraticY L a b) ^ 2 - + (incidenceBiquadraticMu L a b) ^ 2 - + (algebraMap L (IncidenceBiquadraticRing L a b)) 4 * + (algebraMap L (IncidenceBiquadraticRing L a b)) b ^ 2 = 0 + rw [show (incidenceBiquadraticMu L a b) ^ 2 = + algebraMap (Polynomial L) (IncidenceBiquadraticRing L a b) + (incidenceBranchPolynomial b) by + simp only [incidenceBiquadraticMu] + rw [incidenceSecondQuadraticRoot_sq] + exact IsScalarTower.algebraMap_apply (Polynomial L) + (IncidenceFirstQuadraticRing L a) (IncidenceBiquadraticRing L a b) _] + simp only [incidenceBiquadraticY, incidenceBranchPolynomial] + simp [map_sub, map_mul, map_pow, + IsScalarTower.algebraMap_apply L (Polynomial L) (IncidenceBiquadraticRing L a b)] + +lemma incidenceAuxIdeal_le_aevalToBiquadratic_ker (a b : L) : + incidenceAuxIdeal a b ≤ + RingHom.ker (incidenceAuxAevalToBiquadratic L a b).toRingHom := by + rw [incidenceAuxIdeal, Ideal.span_le] + rintro p (rfl | hp) + · exact incidenceAuxAevalToBiquadratic_polynomial1 L a b + · rw [Set.mem_singleton_iff.mp hp] + exact incidenceAuxAevalToBiquadratic_polynomial2 L a b + +/-- The canonical map from the explicit coordinate-ring quotient to the iterated quadratic +normal form. -/ +def incidenceAuxCoordinateRingToBiquadratic (a b : L) : + IncidenceAuxCoordinateRing L a b →ₐ[L] IncidenceBiquadraticRing L a b := + Ideal.Quotient.liftₐ (incidenceAuxIdeal a b) + (incidenceAuxAevalToBiquadratic L a b) + (fun _p hp => incidenceAuxIdeal_le_aevalToBiquadratic_ker L a b hp) + +lemma incidenceBiquadraticY_mem_aeval_range (a b : L) : + incidenceBiquadraticY L a b ∈ (incidenceAuxAevalToBiquadratic L a b).range := by + refine ⟨MvPolynomial.X 0, ?_⟩ + simp [incidenceAuxAevalToBiquadratic] + +lemma incidenceBiquadraticLambda_mem_aeval_range (a b : L) : + incidenceBiquadraticLambda L a b ∈ + (incidenceAuxAevalToBiquadratic L a b).range := by + refine ⟨MvPolynomial.X 1, ?_⟩ + simp [incidenceAuxAevalToBiquadratic] + +lemma incidenceBiquadraticMu_mem_aeval_range (a b : L) : + incidenceBiquadraticMu L a b ∈ (incidenceAuxAevalToBiquadratic L a b).range := by + refine ⟨MvPolynomial.X 2, ?_⟩ + simp [incidenceAuxAevalToBiquadratic] + +lemma polynomialAlgebraMap_mem_incidenceAevalRange (a b : L) (r : Polynomial L) : + algebraMap (Polynomial L) (IncidenceBiquadraticRing L a b) r ∈ + (incidenceAuxAevalToBiquadratic L a b).range := by + induction r using Polynomial.induction_on' with + | add p q hp hq => + rw [map_add] + exact Subalgebra.add_mem _ hp hq + | monomial n c => + have hy := incidenceBiquadraticY_mem_aeval_range L a b + have hc := (incidenceAuxAevalToBiquadratic L a b).range.algebraMap_mem c + rw [← Polynomial.C_mul_X_pow_eq_monomial, map_mul, map_pow] + simpa [incidenceBiquadraticY, + IsScalarTower.algebraMap_apply L (Polynomial L) (IncidenceBiquadraticRing L a b)] + using Subalgebra.mul_mem _ hc (Subalgebra.pow_mem _ hy n) + +lemma firstQuadraticAlgebraMap_mem_incidenceAevalRange (a b : L) + (s : IncidenceFirstQuadraticRing L a) : + algebraMap (IncidenceFirstQuadraticRing L a) (IncidenceBiquadraticRing L a b) s ∈ + (incidenceAuxAevalToBiquadratic L a b).range := by + induction s using AdjoinRoot.induction_on with + | ih p => + induction p using Polynomial.induction_on' with + | add p q hp hq => + simpa only [map_add] using Subalgebra.add_mem _ hp hq + | monomial n r => + have hr := polynomialAlgebraMap_mem_incidenceAevalRange L a b r + have hlambda := incidenceBiquadraticLambda_mem_aeval_range L a b + have heq : + algebraMap (IncidenceFirstQuadraticRing L a) + (IncidenceBiquadraticRing L a b) + (AdjoinRoot.mk + (adjoinSquarePolynomial (incidenceBranchPolynomial a)) + (Polynomial.monomial n r)) = + algebraMap (Polynomial L) (IncidenceBiquadraticRing L a b) r * + (incidenceBiquadraticLambda L a b) ^ n := by + rw [← AdjoinRoot.aeval_eq, ← Polynomial.C_mul_X_pow_eq_monomial] + simp [incidenceBiquadraticLambda, + IsScalarTower.algebraMap_apply (Polynomial L) + (IncidenceFirstQuadraticRing L a) (IncidenceBiquadraticRing L a b)] + rw [heq] + exact Subalgebra.mul_mem _ hr (Subalgebra.pow_mem _ hlambda n) + +lemma incidenceAuxAevalToBiquadratic_surjective (a b : L) : + Function.Surjective (incidenceAuxAevalToBiquadratic L a b) := by + rw [← AlgHom.range_eq_top] + apply Algebra.eq_top_iff.mpr + intro t + induction t using AdjoinRoot.induction_on with + | ih p => + induction p using Polynomial.induction_on' with + | add p q hp hq => + simpa only [map_add] using Subalgebra.add_mem _ hp hq + | monomial n s => + have hs := firstQuadraticAlgebraMap_mem_incidenceAevalRange L a b s + have hmu := incidenceBiquadraticMu_mem_aeval_range L a b + have heq : + AdjoinRoot.mk (incidenceSecondQuadraticPolynomial L a b) + (Polynomial.monomial n s) = + algebraMap (IncidenceFirstQuadraticRing L a) + (IncidenceBiquadraticRing L a b) s * + (incidenceBiquadraticMu L a b) ^ n := by + rw [← AdjoinRoot.aeval_eq, ← Polynomial.C_mul_X_pow_eq_monomial] + simp [incidenceBiquadraticMu] + rw [heq] + exact Subalgebra.mul_mem _ hs (Subalgebra.pow_mem _ hmu n) + +lemma incidenceAuxCoordinateRingToBiquadratic_surjective (a b : L) : + Function.Surjective (incidenceAuxCoordinateRingToBiquadratic L a b) := by + intro t + obtain ⟨p, rfl⟩ := incidenceAuxAevalToBiquadratic_surjective L a b t + exact ⟨Ideal.Quotient.mk (incidenceAuxIdeal a b) p, rfl⟩ + +/-- The class of one of the three coordinate variables in the auxiliary coordinate ring. -/ +def incidenceAuxCoordinateClass (a b : L) (i : Fin 3) : + IncidenceAuxCoordinateRing L a b := + Ideal.Quotient.mk (incidenceAuxIdeal a b) (MvPolynomial.X i) + +/-- The polynomial algebra in `y` maps to the auxiliary coordinate ring by sending `X` to the +class of the `y`-coordinate. -/ +def incidenceAuxPolynomialAlgebraMap (a b : L) : + Polynomial L →ₐ[L] IncidenceAuxCoordinateRing L a b := + Polynomial.aeval (incidenceAuxCoordinateClass L a b 0) + +lemma incidenceAuxPolynomial1_class_eq_zero (a b : L) : + Ideal.Quotient.mk (incidenceAuxIdeal a b) (incidenceAuxPolynomial1 a) = 0 := by + rw [Ideal.Quotient.eq_zero_iff_mem] + exact Ideal.subset_span (by simp) + +lemma incidenceAuxPolynomial2_class_eq_zero (a b : L) : + Ideal.Quotient.mk (incidenceAuxIdeal a b) (incidenceAuxPolynomial2 b) = 0 := by + rw [Ideal.Quotient.eq_zero_iff_mem] + exact Ideal.subset_span (by simp) + +lemma incidenceAuxLambdaClass_sq (a b : L) : + (incidenceAuxCoordinateClass L a b 1) ^ 2 = + incidenceAuxPolynomialAlgebraMap L a b (incidenceBranchPolynomial a) := by + have h := incidenceAuxPolynomial1_class_eq_zero L a b + simp only [incidenceAuxPolynomial1, map_sub, map_mul, map_pow] at h + simp only [incidenceAuxPolynomialAlgebraMap, incidenceBranchPolynomial, + map_sub, map_mul, map_pow, Polynomial.aeval_C, Polynomial.aeval_X] + change + (incidenceAuxCoordinateClass L a b 1) ^ 2 = + ((algebraMap L (IncidenceAuxCoordinateRing L a b)) 9 * + (algebraMap L (IncidenceAuxCoordinateRing L a b)) a ^ 2 - + (algebraMap L (IncidenceAuxCoordinateRing L a b)) 4) * + (incidenceAuxCoordinateClass L a b 0) ^ 2 - + (algebraMap L (IncidenceAuxCoordinateRing L a b)) 4 * + (algebraMap L (IncidenceAuxCoordinateRing L a b)) a ^ 2 + change + ((algebraMap L (IncidenceAuxCoordinateRing L a b)) 9 * + (algebraMap L (IncidenceAuxCoordinateRing L a b)) a ^ 2 - + (algebraMap L (IncidenceAuxCoordinateRing L a b)) 4) * + (incidenceAuxCoordinateClass L a b 0) ^ 2 - + (incidenceAuxCoordinateClass L a b 1) ^ 2 - + (algebraMap L (IncidenceAuxCoordinateRing L a b)) 4 * + (algebraMap L (IncidenceAuxCoordinateRing L a b)) a ^ 2 = 0 at h + linear_combination -h + +lemma incidenceAuxMuClass_sq (a b : L) : + (incidenceAuxCoordinateClass L a b 2) ^ 2 = + incidenceAuxPolynomialAlgebraMap L a b (incidenceBranchPolynomial b) := by + have h := incidenceAuxPolynomial2_class_eq_zero L a b + simp only [incidenceAuxPolynomial2, map_sub, map_mul, map_pow] at h + simp only [incidenceAuxPolynomialAlgebraMap, incidenceBranchPolynomial, + map_sub, map_mul, map_pow, Polynomial.aeval_C, Polynomial.aeval_X] + change + (incidenceAuxCoordinateClass L a b 2) ^ 2 = + ((algebraMap L (IncidenceAuxCoordinateRing L a b)) 9 * + (algebraMap L (IncidenceAuxCoordinateRing L a b)) b ^ 2 - + (algebraMap L (IncidenceAuxCoordinateRing L a b)) 4) * + (incidenceAuxCoordinateClass L a b 0) ^ 2 - + (algebraMap L (IncidenceAuxCoordinateRing L a b)) 4 * + (algebraMap L (IncidenceAuxCoordinateRing L a b)) b ^ 2 + change + ((algebraMap L (IncidenceAuxCoordinateRing L a b)) 9 * + (algebraMap L (IncidenceAuxCoordinateRing L a b)) b ^ 2 - + (algebraMap L (IncidenceAuxCoordinateRing L a b)) 4) * + (incidenceAuxCoordinateClass L a b 0) ^ 2 - + (incidenceAuxCoordinateClass L a b 2) ^ 2 - + (algebraMap L (IncidenceAuxCoordinateRing L a b)) 4 * + (algebraMap L (IncidenceAuxCoordinateRing L a b)) b ^ 2 = 0 at h + linear_combination -h + +/-- Map the first quadratic extension back to the explicit coordinate ring. -/ +def incidenceFirstQuadraticToAuxCoordinateRing (a b : L) : + IncidenceFirstQuadraticRing L a →ₐ[L] IncidenceAuxCoordinateRing L a b := + AdjoinRoot.liftAlgHom + (adjoinSquarePolynomial (incidenceBranchPolynomial a)) + (incidenceAuxPolynomialAlgebraMap L a b) + (incidenceAuxCoordinateClass L a b 1) + (by + simp [adjoinSquarePolynomial, incidenceAuxLambdaClass_sq]) + +/-- Map the iterated quadratic normal form back to the explicit coordinate ring. -/ +def incidenceBiquadraticToAuxCoordinateRing (a b : L) : + IncidenceBiquadraticRing L a b →ₐ[L] IncidenceAuxCoordinateRing L a b := + AdjoinRoot.liftAlgHom + (incidenceSecondQuadraticPolynomial L a b) + (incidenceFirstQuadraticToAuxCoordinateRing L a b) + (incidenceAuxCoordinateClass L a b 2) + (by + simp only [incidenceSecondQuadraticPolynomial, adjoinSquarePolynomial, + Polynomial.eval₂_sub, Polynomial.eval₂_pow, Polynomial.eval₂_X, + Polynomial.eval₂_C] + rw [incidenceAuxMuClass_sq] + change + incidenceAuxPolynomialAlgebraMap L a b (incidenceBranchPolynomial b) - + incidenceFirstQuadraticToAuxCoordinateRing L a b + (AdjoinRoot.of + (adjoinSquarePolynomial (incidenceBranchPolynomial a)) + (incidenceBranchPolynomial b)) = 0 + rw [incidenceFirstQuadraticToAuxCoordinateRing, AdjoinRoot.liftAlgHom_of] + exact sub_self _) + +@[simp] +lemma incidenceAuxCoordinateRingToBiquadratic_coordinateClass (a b : L) (i : Fin 3) : + incidenceAuxCoordinateRingToBiquadratic L a b + (incidenceAuxCoordinateClass L a b i) = + ![incidenceBiquadraticY L a b, incidenceBiquadraticLambda L a b, + incidenceBiquadraticMu L a b] i := by + change incidenceAuxAevalToBiquadratic L a b (X i) = _ + simp [incidenceAuxAevalToBiquadratic] + +@[simp] +lemma incidenceBiquadraticToAuxCoordinateRing_y (a b : L) : + incidenceBiquadraticToAuxCoordinateRing L a b (incidenceBiquadraticY L a b) = + incidenceAuxCoordinateClass L a b 0 := by + rw [incidenceBiquadraticY, + IsScalarTower.algebraMap_apply (Polynomial L) (IncidenceFirstQuadraticRing L a) + (IncidenceBiquadraticRing L a b)] + simp [incidenceBiquadraticToAuxCoordinateRing, + incidenceFirstQuadraticToAuxCoordinateRing, incidenceAuxPolynomialAlgebraMap] + +@[simp] +lemma incidenceBiquadraticToAuxCoordinateRing_lambda (a b : L) : + incidenceBiquadraticToAuxCoordinateRing L a b + (incidenceBiquadraticLambda L a b) = + incidenceAuxCoordinateClass L a b 1 := by + simp [incidenceBiquadraticToAuxCoordinateRing, incidenceBiquadraticLambda, + incidenceFirstQuadraticToAuxCoordinateRing] + +@[simp] +lemma incidenceBiquadraticToAuxCoordinateRing_mu (a b : L) : + incidenceBiquadraticToAuxCoordinateRing L a b (incidenceBiquadraticMu L a b) = + incidenceAuxCoordinateClass L a b 2 := by + simp [incidenceBiquadraticToAuxCoordinateRing, incidenceBiquadraticMu] + +lemma incidenceBiquadraticToAux_comp_auxToBiquadratic (a b : L) : + (incidenceBiquadraticToAuxCoordinateRing L a b).comp + (incidenceAuxCoordinateRingToBiquadratic L a b) = + AlgHom.id L (IncidenceAuxCoordinateRing L a b) := by + apply Ideal.Quotient.algHom_ext L + apply MvPolynomial.algHom_ext + intro i + fin_cases i + · change incidenceBiquadraticToAuxCoordinateRing L a b + (incidenceAuxCoordinateRingToBiquadratic L a b + (incidenceAuxCoordinateClass L a b 0)) = incidenceAuxCoordinateClass L a b 0 + rw [incidenceAuxCoordinateRingToBiquadratic_coordinateClass] + exact incidenceBiquadraticToAuxCoordinateRing_y L a b + · change incidenceBiquadraticToAuxCoordinateRing L a b + (incidenceAuxCoordinateRingToBiquadratic L a b + (incidenceAuxCoordinateClass L a b 1)) = incidenceAuxCoordinateClass L a b 1 + rw [incidenceAuxCoordinateRingToBiquadratic_coordinateClass] + exact incidenceBiquadraticToAuxCoordinateRing_lambda L a b + · change incidenceBiquadraticToAuxCoordinateRing L a b + (incidenceAuxCoordinateRingToBiquadratic L a b + (incidenceAuxCoordinateClass L a b 2)) = incidenceAuxCoordinateClass L a b 2 + rw [incidenceAuxCoordinateRingToBiquadratic_coordinateClass] + exact incidenceBiquadraticToAuxCoordinateRing_mu L a b + +lemma incidenceAuxToBiquadratic_comp_biquadraticToAux (a b : L) : + (incidenceAuxCoordinateRingToBiquadratic L a b).comp + (incidenceBiquadraticToAuxCoordinateRing L a b) = + AlgHom.id L (IncidenceBiquadraticRing L a b) := by + apply AdjoinRoot.algHom_ext' + · apply AdjoinRoot.algHom_ext' + · apply Polynomial.algHom_ext + change incidenceAuxCoordinateRingToBiquadratic L a b + (incidenceBiquadraticToAuxCoordinateRing L a b + (algebraMap (IncidenceFirstQuadraticRing L a) + (IncidenceBiquadraticRing L a b) + (algebraMap (Polynomial L) (IncidenceFirstQuadraticRing L a) Polynomial.X))) = _ + rw [show algebraMap (IncidenceFirstQuadraticRing L a) + (IncidenceBiquadraticRing L a b) + (algebraMap (Polynomial L) (IncidenceFirstQuadraticRing L a) Polynomial.X) = + incidenceBiquadraticY L a b by + exact (IsScalarTower.algebraMap_apply (Polynomial L) + (IncidenceFirstQuadraticRing L a) (IncidenceBiquadraticRing L a b) _).symm] + rw [incidenceBiquadraticToAuxCoordinateRing_y] + rw [incidenceAuxCoordinateRingToBiquadratic_coordinateClass] + exact IsScalarTower.algebraMap_apply (Polynomial L) + (IncidenceFirstQuadraticRing L a) (IncidenceBiquadraticRing L a b) _ + · change incidenceAuxCoordinateRingToBiquadratic L a b + (incidenceBiquadraticToAuxCoordinateRing L a b + (incidenceBiquadraticLambda L a b)) = incidenceBiquadraticLambda L a b + rw [incidenceBiquadraticToAuxCoordinateRing_lambda] + rw [incidenceAuxCoordinateRingToBiquadratic_coordinateClass] + simp + · change incidenceAuxCoordinateRingToBiquadratic L a b + (incidenceBiquadraticToAuxCoordinateRing L a b + (incidenceBiquadraticMu L a b)) = incidenceBiquadraticMu L a b + rw [incidenceBiquadraticToAuxCoordinateRing_mu] + rw [incidenceAuxCoordinateRingToBiquadratic_coordinateClass] + simp + +/-- The two-equation coordinate quotient is exactly the rank-four iterated quadratic algebra. -/ +noncomputable def incidenceAuxCoordinateRingEquivBiquadratic (a b : L) : + IncidenceAuxCoordinateRing L a b ≃ₐ[L] IncidenceBiquadraticRing L a b := + AlgEquiv.ofAlgHom + (incidenceAuxCoordinateRingToBiquadratic L a b) + (incidenceBiquadraticToAuxCoordinateRing L a b) + (incidenceAuxToBiquadratic_comp_biquadraticToAux L a b) + (incidenceBiquadraticToAux_comp_auxToBiquadratic L a b) + +/-- The explicit two-equation coordinate quotient is a domain under the off-diagonal +nondegeneracy hypotheses. -/ +theorem incidenceAuxCoordinateRing_isDomain + (h2 : (2 : L) ≠ 0) {a b : L} + (ha : a ≠ 0) (hb : b ≠ 0) + (hA : 9 * a ^ 2 - 4 ≠ 0) (hB : 9 * b ^ 2 - 4 ≠ 0) + (hab : a ^ 2 ≠ b ^ 2) : + IsDomain (IncidenceAuxCoordinateRing L a b) := by + let : IsDomain (IncidenceBiquadraticRing L a b) := + incidenceBiquadraticRing_isDomain L h2 ha hb hA hB hab + exact (incidenceAuxCoordinateRingEquivBiquadratic L a b).injective.isDomain + (incidenceAuxCoordinateRingEquivBiquadratic L a b).toRingEquiv.toRingHom + +/-- The actual geometric-integrality statement follows after explicit scalar extension to the +algebraic closure; no irreducibility assertion is hidden in a structure field. -/ +theorem incidenceAuxGeometricallyIntegral_of_nondegenerate + {K : Type*} [Field K] (h2 : (2 : K) ≠ 0) {a b : K} + (ha : a ≠ 0) (hb : b ≠ 0) + (hA : 9 * a ^ 2 - 4 ≠ 0) (hB : 9 * b ^ 2 - 4 ≠ 0) + (hab : a ^ 2 ≠ b ^ 2) : + IncidenceAuxGeometricallyIntegral a b := by + let L := AlgebraicClosure K + have hmapNeZero {x : K} (hx : x ≠ 0) : algebraMap K L x ≠ 0 := by + intro hzero + apply hx + apply FaithfulSMul.algebraMap_injective K L + simpa only [map_zero] using hzero + have h2L : (2 : L) ≠ 0 := by + simpa only [map_ofNat] using hmapNeZero h2 + have haL : algebraMap K L a ≠ 0 := hmapNeZero ha + have hbL : algebraMap K L b ≠ 0 := hmapNeZero hb + have hAL : 9 * (algebraMap K L a) ^ 2 - 4 ≠ 0 := by + simpa only [map_sub, map_mul, map_pow, map_ofNat] using hmapNeZero hA + have hBL : 9 * (algebraMap K L b) ^ 2 - 4 ≠ 0 := by + simpa only [map_sub, map_mul, map_pow, map_ofNat] using hmapNeZero hB + have habL : (algebraMap K L a) ^ 2 ≠ (algebraMap K L b) ^ 2 := by + intro heq + apply hab + apply FaithfulSMul.algebraMap_injective K L + simpa only [map_pow] using heq + let : IsDomain + (IncidenceAuxCoordinateRing L (algebraMap K L a) (algebraMap K L b)) := + incidenceAuxCoordinateRing_isDomain L h2L haL hbL hAL hBL habL + exact (incidenceAuxCoordinateRingBaseChangeExplicitEquiv K L a b).injective.isDomain + (incidenceAuxCoordinateRingBaseChangeExplicitEquiv K L a b).toRingEquiv.toRingHom + +/-- Specialization to the paper's admissible off-diagonal coordinates. The threshold `3` only +excludes characteristic two; no large-prime estimate is used in this geometric step. -/ +theorem incidenceAux_offDiagonal_geometricallyIntegral : + ∃ p0 : ℕ, ∀ (p : ℕ) (hp : p.Prime), p0 ≤ p → + IncidenceAuxOffDiagonalGeometryAt p hp := by + refine ⟨3, ?_⟩ + intro p hp hpLarge + let : Fact p.Prime := ⟨hp⟩ + intro a b ha hb hab + apply incidenceAuxGeometricallyIntegral_of_nondegenerate + · exact two_ne_zero_zmod (by omega) + · exact ha.1 + · exact hb.1 + · intro hzero + apply ha.2 + calc + (3 * a) ^ 2 = 9 * a ^ 2 := by ring + _ = 4 := sub_eq_zero.mp hzero + · intro hzero + apply hb.2 + calc + (3 * b) ^ 2 = 9 * b ^ 2 := by ring + _ = 4 := sub_eq_zero.mp hzero + · exact hab + +end + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Incidence/Counterexamples.lean b/LeanPool/MarkoffModP/BGS/Markoff/Incidence/Counterexamples.lean new file mode 100644 index 0000000000..a2795970d3 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Incidence/Counterexamples.lean @@ -0,0 +1,60 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Incidence.Fibers + +/-! +# Small-prime counterexamples to the printed incidence threshold + +These kernel-checked examples show that the paper's claim for every prime `p > 10` is false for +the exact admissible auxiliary-point statement used by its diameter-two argument. +-/ + +@[expose] public section + +namespace BGS.Markoff + +local instance {p : ℕ} [Fact p.Prime] (a : ZMod p) : + Decidable (IsAdmissibleCoordinate a) := by + unfold IsAdmissibleCoordinate + infer_instance + +local instance {K : Type*} [Field K] [DecidableEq K] (a b y lambda mu : K) : + Decidable (IncidenceAux a b y lambda mu) := by + unfold IncidenceAux + infer_instance + +section Prime13 + +local instance : Fact (Nat.Prime 13) := ⟨by norm_num⟩ + +theorem no_admissible_incidenceAux_point_at_thirteen : + IsAdmissibleCoordinate (1 : ZMod 13) ∧ + IsAdmissibleCoordinate (4 : ZMod 13) ∧ + (1 : ZMod 13) ^ 2 ≠ (4 : ZMod 13) ^ 2 ∧ + ¬ ∃ y lambda mu : ZMod 13, + IsAdmissibleCoordinate y ∧ IncidenceAux 1 4 y lambda mu := by + decide + +end Prime13 + +section Prime17 + +local instance : Fact (Nat.Prime 17) := ⟨by norm_num⟩ + +theorem no_admissible_incidenceAux_point_at_seventeen : + IsAdmissibleCoordinate (1 : ZMod 17) ∧ + IsAdmissibleCoordinate (6 : ZMod 17) ∧ + (1 : ZMod 17) ^ 2 ≠ (6 : ZMod 17) ^ 2 ∧ + ¬ ∃ y lambda mu : ZMod 17, + IsAdmissibleCoordinate y ∧ IncidenceAux 1 6 y lambda mu := by + decide + +end Prime17 + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Incidence/Fibers.lean b/LeanPool/MarkoffModP/BGS/Markoff/Incidence/Fibers.lean new file mode 100644 index 0000000000..e7173a4718 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Incidence/Fibers.lean @@ -0,0 +1,430 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.FiniteField.QuadraticCharacter +public import LeanPool.MarkoffModP.BGS.Markoff.Core.Basic +public import LeanPool.MarkoffModP.BGS.Markoff.Incidence.Geometry +public import LeanPool.MarkoffModP.BGS.Markoff.Incidence.PointCount + +/-! +# Incidence of Markoff conic fibers + +This file formalizes the algebra behind Proposition 6 of Bourgain--Gamburd--Sarnak. Geometric +integrality is proved in `BGS.Markoff.IncidenceCoordinateRing`; the independent Hasse point-count +gap is isolated in `BGS.FiniteField.EllipticCharacterSum`. +-/ + +@[expose] public section + +namespace BGS.Markoff + +universe u + +variable {F : Type u} [Field F] + +/-- The Markoff fiber obtained by fixing the first coordinate. -/ +def fiber1 (a : F) : Set (Point F) := + {x | IsMarkoff x ∧ x.x1 = a} + +/-- The Markoff fiber obtained by fixing the second coordinate. -/ +def fiber2 (a : F) : Set (Point F) := + {x | IsMarkoff x ∧ x.x2 = a} + +/-- The Markoff fiber obtained by fixing the third coordinate. -/ +def fiber3 (a : F) : Set (Point F) := + {x | IsMarkoff x ∧ x.x3 = a} + +/-- Two fibers meet when their set-theoretic intersection is nonempty. -/ +def FibersMeet (s t : Set (Point F)) : Prop := + (s ∩ t).Nonempty + +/-- +The affine auxiliary equations used in the paper to find one third-coordinate fiber meeting +the fibers with first-coordinate value `a` and second-coordinate value `b`. +-/ +def IncidenceAux (a b y lambda mu : F) : Prop := + (9 * a ^ 2 - 4) * y ^ 2 - lambda ^ 2 = 4 * a ^ 2 ∧ + (9 * b ^ 2 - 4) * y ^ 2 - mu ^ 2 = 4 * b ^ 2 + +open MvPolynomial +open scoped TensorProduct + +noncomputable section + +/-- The first equation of the auxiliary curve, with variables `(y, lambda, mu)`. -/ +def incidenceAuxPolynomial1 {K : Type u} [Field K] (a : K) : + MvPolynomial (Fin 3) K := + C (9 * a ^ 2 - 4) * X 0 ^ 2 - X 1 ^ 2 - C (4 * a ^ 2) + +/-- The second equation of the auxiliary curve, with variables `(y, lambda, mu)`. -/ +def incidenceAuxPolynomial2 {K : Type u} [Field K] (b : K) : + MvPolynomial (Fin 3) K := + C (9 * b ^ 2 - 4) * X 0 ^ 2 - X 2 ^ 2 - C (4 * b ^ 2) + +/-- The ideal cutting out the affine auxiliary curve from Proposition 6. -/ +def incidenceAuxIdeal {K : Type u} [Field K] (a b : K) : + Ideal (MvPolynomial (Fin 3) K) := + Ideal.span {incidenceAuxPolynomial1 a, incidenceAuxPolynomial2 b} + +/-- The affine coordinate ring of the auxiliary curve. -/ +abbrev IncidenceAuxCoordinateRing (K : Type u) [Field K] (a b : K) := + MvPolynomial (Fin 3) K ⧸ incidenceAuxIdeal a b + +/-- The actual geometric-integrality condition required before applying a Weil bound. -/ +def IncidenceAuxGeometricallyIntegral {K : Type u} [Field K] (a b : K) : Prop := + IsDomain (AlgebraicClosure K ⊗[K] IncidenceAuxCoordinateRing K a b) + +end + +@[simp] +theorem eval_incidenceAuxPolynomial1_vec + {K : Type u} [Field K] (a y lambda mu : K) : + aeval ![y, lambda, mu] (incidenceAuxPolynomial1 a) = + (9 * a ^ 2 - 4) * y ^ 2 - lambda ^ 2 - 4 * a ^ 2 := by + simp [incidenceAuxPolynomial1] + +@[simp] +theorem eval_incidenceAuxPolynomial2_vec + {K : Type u} [Field K] (b y lambda mu : K) : + aeval ![y, lambda, mu] (incidenceAuxPolynomial2 b) = + (9 * b ^ 2 - 4) * y ^ 2 - mu ^ 2 - 4 * b ^ 2 := by + simp [incidenceAuxPolynomial2] + +/-- The coordinate-ring equations are exactly the two scalar equations used in the incidence +argument. -/ +theorem incidenceAux_iff_aeval_eq_zero + {K : Type u} [Field K] (a b y lambda mu : K) : + IncidenceAux a b y lambda mu ↔ + aeval ![y, lambda, mu] (incidenceAuxPolynomial1 a) = 0 ∧ + aeval ![y, lambda, mu] (incidenceAuxPolynomial2 b) = 0 := by + simp [IncidenceAux, sub_eq_zero] + +/-- A chosen root of the quadratic defining the intersection of two coordinate fibers. -/ +def conicRoot (a y discriminantRoot : F) : F := + (3 * a * y + discriminantRoot) / 2 + +lemma markoffPolynomial_conicRoot + (h2 : (2 : F) ≠ 0) {a y discriminantRoot : F} + (h : (9 * a ^ 2 - 4) * y ^ 2 - discriminantRoot ^ 2 = 4 * a ^ 2) : + markoffPolynomial ⟨a, conicRoot a y discriminantRoot, y⟩ = 0 := by + have h4 : (4 : F) ≠ 0 := by + intro h4 + apply (mul_ne_zero h2 h2) + calc + (2 : F) * 2 = 4 := by norm_num + _ = 0 := h4 + calc + markoffPolynomial ⟨a, conicRoot a y discriminantRoot, y⟩ = + -(((9 * a ^ 2 - 4) * y ^ 2 - discriminantRoot ^ 2) - 4 * a ^ 2) / 4 := by + simp only [markoffPolynomial, conicRoot] + field_simp [h2, h4] + ring + _ = 0 := by rw [h]; simp + +lemma point_mem_fiber1_inter_fiber3 + (h2 : (2 : F) ≠ 0) {a y discriminantRoot : F} + (h : (9 * a ^ 2 - 4) * y ^ 2 - discriminantRoot ^ 2 = 4 * a ^ 2) : + ⟨a, conicRoot a y discriminantRoot, y⟩ ∈ fiber1 a ∩ fiber3 y := by + constructor + · exact ⟨markoffPolynomial_conicRoot h2 h, rfl⟩ + · exact ⟨markoffPolynomial_conicRoot h2 h, rfl⟩ + +lemma point_mem_fiber2_inter_fiber3 + (h2 : (2 : F) ≠ 0) {b y discriminantRoot : F} + (h : (9 * b ^ 2 - 4) * y ^ 2 - discriminantRoot ^ 2 = 4 * b ^ 2) : + ⟨conicRoot b y discriminantRoot, b, y⟩ ∈ fiber2 b ∩ fiber3 y := by + have hmarkoff : IsMarkoff ⟨conicRoot b y discriminantRoot, b, y⟩ := by + change markoffPolynomial (swap12 ⟨b, conicRoot b y discriminantRoot, y⟩) = 0 + rw [markoffPolynomial_swap12] + exact markoffPolynomial_conicRoot h2 h + constructor + · exact ⟨hmarkoff, rfl⟩ + · exact ⟨hmarkoff, rfl⟩ + +theorem incidenceAux_implies_common_fiber + (h2 : (2 : F) ≠ 0) {a b y lambda mu : F} + (h : IncidenceAux a b y lambda mu) : + FibersMeet (fiber1 a) (fiber3 y) ∧ FibersMeet (fiber2 b) (fiber3 y) := by + refine ⟨?_, ?_⟩ + · exact ⟨_, point_mem_fiber1_inter_fiber3 h2 h.1⟩ + · exact ⟨_, point_mem_fiber2_inter_fiber3 h2 h.2⟩ + +/-- A point on the auxiliary curve gives a common fiber, while retaining any extra predicate +required of its `y`-coordinate. -/ +theorem incidenceAux_exists_implies_common_fiber_with + (h2 : (2 : F) ≠ 0) {P : F → Prop} {a b : F} + (h : ∃ y lambda mu, P y ∧ IncidenceAux a b y lambda mu) : + ∃ y, P y ∧ FibersMeet (fiber1 a) (fiber3 y) ∧ + FibersMeet (fiber2 b) (fiber3 y) := by + obtain ⟨y, lambda, mu, hy, haux⟩ := h + exact ⟨y, hy, incidenceAux_implies_common_fiber h2 haux⟩ + +/-- On the diagonal `a² = b²`, one equation supplies both auxiliary square roots. -/ +theorem diagonal_incidenceAux_of_firstEquation + {a b y lambda : F} (hab : a ^ 2 = b ^ 2) + (h : (9 * a ^ 2 - 4) * y ^ 2 - lambda ^ 2 = 4 * a ^ 2) : + IncidenceAux a b y lambda lambda := by + refine ⟨h, ?_⟩ + simpa only [← hab] using h + +/-- Combine the diagonal and off-diagonal point-existence problems. -/ +theorem auxPointExists_of_diagonal_offDiagonal {P : F → Prop} + (hdiag : ∀ a : F, P a → + ∃ y lambda, P y ∧ + (9 * a ^ 2 - 4) * y ^ 2 - lambda ^ 2 = 4 * a ^ 2) + (hoff : ∀ a b : F, P a → P b → a ^ 2 ≠ b ^ 2 → + ∃ y lambda mu, P y ∧ IncidenceAux a b y lambda mu) : + ∀ a b : F, P a → P b → + ∃ y lambda mu, P y ∧ IncidenceAux a b y lambda mu := by + intro a b ha hb + by_cases hab : a ^ 2 = b ^ 2 + · obtain ⟨y, lambda, hy, heq⟩ := hdiag a ha + exact ⟨y, lambda, lambda, hy, diagonal_incidenceAux_of_firstEquation hab heq⟩ + · exact hoff a b ha hb hab + +/-- Coordinates retained as vertices of the paper's incidence graph. -/ +def IsAdmissibleCoordinate {p : ℕ} (a : ZMod p) : Prop := + a ≠ 0 ∧ (3 * a) ^ 2 ≠ 4 + +/-- The three first-coordinate values excluded from the incidence graph. -/ +def forbiddenIntermediateCoordinates (p : ℕ) [Fact p.Prime] : Finset (ZMod p) := + {0, 2 / 3, -(2 / 3)} + +theorem forbiddenIntermediateCoordinates_card_le_three + (p : ℕ) [Fact p.Prime] : (forbiddenIntermediateCoordinates p).card ≤ 3 := by + exact Finset.card_le_three + +/-- A natural number smaller than the modulus remains nonzero in `ZMod p`. -/ +theorem natCast_ne_zero_zmod_of_pos_of_lt + {n p : ℕ} (hn : 0 < n) (hnp : n < p) : (n : ZMod p) ≠ 0 := by + intro hzero + have hdvd : p ∣ n := (ZMod.natCast_eq_zero_iff n p).mp hzero + exact (Nat.not_le_of_gt hnp) (Nat.le_of_dvd hn hdvd) + +/-- Outside the three forbidden values, a coordinate is admissible. -/ +theorem admissible_of_not_mem_forbiddenIntermediateCoordinates + {p : ℕ} [Fact p.Prime] (h3 : (3 : ZMod p) ≠ 0) {y : ZMod p} + (hy : y ∉ forbiddenIntermediateCoordinates p) : IsAdmissibleCoordinate y := by + constructor + · intro hzero + exact hy (by simp [forbiddenIntermediateCoordinates, hzero]) + · intro hsquare + have hsquare' : (3 * y) ^ 2 = (2 : ZMod p) ^ 2 := by + calc + (3 * y) ^ 2 = 4 := hsquare + _ = (2 : ZMod p) ^ 2 := by norm_num + rcases sq_eq_sq_iff_eq_or_eq_neg.mp hsquare' with hpositive | hnegative + · have hyvalue : y = 2 / 3 := + (eq_div_iff h3).2 (by simpa [mul_comm] using hpositive) + exact hy (by simp [forbiddenIntermediateCoordinates, hyvalue]) + · have hyvalue : y = -(2 / 3) := by + rw [← neg_div] + exact (eq_div_iff h3).2 (by simpa [mul_comm] using hnegative) + exact hy (by simp [forbiddenIntermediateCoordinates, hyvalue]) + +/-- The exact auxiliary-point conclusion, including the condition that the new fiber remains a +vertex of the incidence graph. -/ +def IncidenceAuxPointAt (p : ℕ) (hp : p.Prime) : Prop := + letI : Fact p.Prime := ⟨hp⟩ + ∀ a b : ZMod p, + IsAdmissibleCoordinate a → + IsAdmissibleCoordinate b → + ∃ y lambda mu : ZMod p, + IsAdmissibleCoordinate y ∧ IncidenceAux a b y lambda mu + +/-- The common-fiber conclusion actually needed for the diameter-two incidence argument. -/ +def IncidenceBridgeAt (p : ℕ) (hp : p.Prime) : Prop := + letI : Fact p.Prime := ⟨hp⟩ + ∀ a b : ZMod p, + IsAdmissibleCoordinate a → + IsAdmissibleCoordinate b → + ∃ y : ZMod p, + IsAdmissibleCoordinate y ∧ + FibersMeet (fiber1 a) (fiber3 y) ∧ FibersMeet (fiber2 b) (fiber3 y) + +/-- +The diagonal finite-field point problem suppressed in line 661 of the paper. + +Besides finding an affine conic point, the proof must avoid the three possible forbidden +coordinates `y = 0, ±2/3`. +-/ +theorem incidenceAux_diagonal_point : + ∃ p0 : ℕ, ∀ (p : ℕ) (_hp : p.Prime), p0 ≤ p → + ∀ a : ZMod p, IsAdmissibleCoordinate a → + ∃ y lambda : ZMod p, + IsAdmissibleCoordinate y ∧ + (9 * a ^ 2 - 4) * y ^ 2 - lambda ^ 2 = 4 * a ^ 2 := by + refine ⟨11, ?_⟩ + intro p hp hpLarge a ha + let : Fact p.Prime := ⟨hp⟩ + have h3lt : 3 < p := by omega + have h4lt : 4 < p := by omega + have h3 : (3 : ZMod p) ≠ 0 := + natCast_ne_zero_zmod_of_pos_of_lt (by norm_num) h3lt + have h4 : (4 : ZMod p) ≠ 0 := + natCast_ne_zero_zmod_of_pos_of_lt (by norm_num) h4lt + have hchar : ringChar (ZMod p) ≠ 2 := by + rw [ZMod.ringChar_zmod_n] + omega + have hcard : 8 ≤ Fintype.card (ZMod p) := by + rw [ZMod.card] + omega + have hA : (9 * a ^ 2 - 4 : ZMod p) ≠ 0 := by + intro hzero + apply ha.2 + calc + (3 * a) ^ 2 = 9 * a ^ 2 := by ring + _ = 4 := sub_eq_zero.mp hzero + have hC : (4 * a ^ 2 : ZMod p) ≠ 0 := by + exact mul_ne_zero h4 (pow_ne_zero 2 ha.1) + obtain ⟨y, hy, lambda, hlambda⟩ := + BGS.FiniteField.exists_quadratic_conic_point_away_from_three + hchar hcard hA hC (forbiddenIntermediateCoordinates p) + (forbiddenIntermediateCoordinates_card_le_three p) + refine ⟨y, lambda, admissible_of_not_mem_forbiddenIntermediateCoordinates h3 hy, ?_⟩ + linear_combination -hlambda + +/-- +The geometric-integrality assertion needed in the off-diagonal case. + +The paper merely calls the affine curve irreducible. A Weil argument needs geometric +integrality of an appropriate model, and the assertion still requires a proof. +-/ +def IncidenceAuxOffDiagonalGeometryAt (p : ℕ) (hp : p.Prime) : Prop := + letI : Fact p.Prime := ⟨hp⟩ + ∀ a b : ZMod p, + IsAdmissibleCoordinate a → IsAdmissibleCoordinate b → a ^ 2 ≠ b ^ 2 → + IncidenceAuxGeometricallyIntegral a b + +/-- The off-diagonal auxiliary-point statement reduced to the explicit elliptic character sum. -/ +def IncidenceAuxOffDiagonalPointAt (p : ℕ) (hp : p.Prime) : Prop := + letI : Fact p.Prime := ⟨hp⟩ + ∀ a b : ZMod p, + IsAdmissibleCoordinate a → IsAdmissibleCoordinate b → a ^ 2 ≠ b ^ 2 → + ∃ y lambda mu : ZMod p, + IsAdmissibleCoordinate y ∧ IncidenceAux a b y lambda mu + +/-- Optional Legendre Hasse premise for the incidence-diameter route. The +selected Theorem 1 proof does not use this route. -/ +def ZModLegendrePointCardHasseBound : Prop := + ∀ (p : ℕ) [Fact p.Prime], + BGS.FiniteField.LegendrePointCardHasseBound (ZMod p) + +/-- +The off-diagonal auxiliary point follows from the narrow Hasse bound for +`Y² = X (X - u) (X - v)`. This direct route does not pretend that geometric integrality alone +contains the missing genus and point-count estimates. +-/ +theorem incidenceAux_offDiagonal_point + (hHasse : ZModLegendrePointCardHasseBound) : + ∃ p0 : ℕ, ∀ (p : ℕ) (_hp : p.Prime), p0 ≤ p → + IncidenceAuxOffDiagonalPointAt p _hp := by + refine ⟨29, ?_⟩ + intro p hp hpLarge a b ha hb hab + let : Fact p.Prime := ⟨hp⟩ + have h3lt : 3 < p := by omega + have h4lt : 4 < p := by omega + have h16lt : 16 < p := by omega + have h3 : (3 : ZMod p) ≠ 0 := + natCast_ne_zero_zmod_of_pos_of_lt (by norm_num) h3lt + have h4 : (4 : ZMod p) ≠ 0 := + natCast_ne_zero_zmod_of_pos_of_lt (by norm_num) h4lt + have h16 : (16 : ZMod p) ≠ 0 := + natCast_ne_zero_zmod_of_pos_of_lt (by norm_num) h16lt + have hchar : ringChar (ZMod p) ≠ 2 := by + rw [ZMod.ringChar_zmod_n] + omega + have hcard : 26 ≤ Fintype.card (ZMod p) := by + rw [ZMod.card] + omega + have hA : (9 * a ^ 2 - 4 : ZMod p) ≠ 0 := by + intro hzero + apply ha.2 + calc + (3 * a) ^ 2 = 9 * a ^ 2 := by ring + _ = 4 := sub_eq_zero.mp hzero + have hB : (9 * b ^ 2 - 4 : ZMod p) ≠ 0 := by + intro hzero + apply hb.2 + calc + (3 * b) ^ 2 = 9 * b ^ 2 := by ring + _ = 4 := sub_eq_zero.mp hzero + have hC : (4 * a ^ 2 : ZMod p) ≠ 0 := + mul_ne_zero h4 (pow_ne_zero 2 ha.1) + have hD : (4 * b ^ 2 : ZMod p) ≠ 0 := + mul_ne_zero h4 (pow_ne_zero 2 hb.1) + have hcross : + (9 * a ^ 2 - 4) * (4 * b ^ 2) ≠ (9 * b ^ 2 - 4) * (4 * a ^ 2) := by + intro h + have hzero : (16 : ZMod p) * (a ^ 2 - b ^ 2) = 0 := by + calc + (16 : ZMod p) * (a ^ 2 - b ^ 2) = + (9 * a ^ 2 - 4) * (4 * b ^ 2) - + (9 * b ^ 2 - 4) * (4 * a ^ 2) := by ring + _ = 0 := sub_eq_zero.mpr h + exact (mul_ne_zero h16 (sub_ne_zero.mpr hab)) hzero + obtain ⟨y, hy, lambda, mu, hlambda, hmu⟩ := + exists_auxiliary_triple_away_from_three (hHasse p) hchar hcard hA hB hC hD hcross + (forbiddenIntermediateCoordinates p) (forbiddenIntermediateCoordinates_card_le_three p) + refine ⟨y, lambda, mu, + admissible_of_not_mem_forbiddenIntermediateCoordinates h3 hy, ?_, ?_⟩ + · dsimp [branchValue] at hlambda + linear_combination -hlambda + · dsimp [branchValue] at hmu + linear_combination -hmu + +/-- For all sufficiently large primes, the explicit auxiliary equations have an admissible +solution for every pair of admissible coordinates. -/ +theorem incidenceAuxPoint_eventually + (hHasse : ZModLegendrePointCardHasseBound) : + ∃ p0 : ℕ, ∀ (p : ℕ) (hp : p.Prime), p0 ≤ p → IncidenceAuxPointAt p hp := by + obtain ⟨pDiag, hDiag⟩ := incidenceAux_diagonal_point + obtain ⟨pOff, hOff⟩ := incidenceAux_offDiagonal_point hHasse + refine ⟨pDiag + pOff, ?_⟩ + intro p hp hpLarge + let : Fact p.Prime := ⟨hp⟩ + exact auxPointExists_of_diagonal_offDiagonal + (hDiag p hp (by omega)) (hOff p hp (by omega)) + +/-- A prime larger than two has `2 ≠ 0` in its prime field. -/ +theorem two_ne_zero_zmod {p : ℕ} (hp : 2 < p) : (2 : ZMod p) ≠ 0 := by + exact natCast_ne_zero_zmod_of_pos_of_lt (by norm_num) hp + +/-- An admissible solution of the auxiliary equations gives the required graph bridge. -/ +theorem incidenceBridgeAt_of_auxPoint + (p : ℕ) (hp : p.Prime) (h2 : (2 : ZMod p) ≠ 0) + (haux : IncidenceAuxPointAt p hp) : IncidenceBridgeAt p hp := by + let : Fact p.Prime := ⟨hp⟩ + intro a b ha hb + exact incidenceAux_exists_implies_common_fiber_with h2 (haux a b ha hb) + +/-- The bridge is a consequence of the exposed point-existence problems, not an assumption. -/ +theorem incidenceBridge_eventually + (hHasse : ZModLegendrePointCardHasseBound) : + ∃ p0 : ℕ, ∀ (p : ℕ) (hp : p.Prime), p0 ≤ p → IncidenceBridgeAt p hp := by + obtain ⟨pAux, hAux⟩ := incidenceAuxPoint_eventually hHasse + refine ⟨3 + pAux, ?_⟩ + intro p hp hpLarge + exact incidenceBridgeAt_of_auxPoint p hp (two_ne_zero_zmod (by omega)) + (hAux p hp (by omega)) + +/-- The bridge specialized to primes congruent to three modulo four. -/ +theorem incidenceBridge_mod_three + (hHasse : ZModLegendrePointCardHasseBound) : + ∃ p0 : ℕ, ∀ (p : ℕ) (hp : p.Prime), p0 ≤ p → p % 4 = 3 → IncidenceBridgeAt p hp := by + obtain ⟨p0, h⟩ := incidenceBridge_eventually hHasse + exact ⟨p0, fun p hp hpLarge _ => h p hp hpLarge⟩ + +/-- The admissible-fiber bridge specialized to primes congruent to one modulo four. -/ +theorem incidenceBridge_mod_one_admissible + (hHasse : ZModLegendrePointCardHasseBound) : + ∃ p0 : ℕ, ∀ (p : ℕ) (hp : p.Prime), p0 ≤ p → p % 4 = 1 → IncidenceBridgeAt p hp := by + obtain ⟨p0, h⟩ := incidenceBridge_eventually hHasse + exact ⟨p0, fun p hp hpLarge _ => h p hp hpLarge⟩ + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Incidence/Geometry.lean b/LeanPool/MarkoffModP/BGS/Markoff/Incidence/Geometry.lean new file mode 100644 index 0000000000..a295d1b00b --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Incidence/Geometry.lean @@ -0,0 +1,181 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Core.Basic + +/-! +# Square classes for the incidence auxiliary curve + +This file proves the polynomial and rational-function-field algebra behind geometric integrality +of the off-diagonal incidence curve. The remaining coordinate-ring normal-form argument is +stated separately in `BGS.Markoff.Incidence`. +-/ + +@[expose] public section + +namespace BGS.Markoff + +open Polynomial + +noncomputable section + +variable {K : Type*} [Field K] + +/-- A nonunit squarefree element of a UFD does not become a square in its fraction field. -/ +lemma not_isSquare_algebraMap_of_squarefree_not_isUnit + {R Q : Type*} [CommRing R] [IsDomain R] [UniqueFactorizationMonoid R] + [Field Q] [Algebra R Q] [IsFractionRing R Q] + {f : R} (hsq : Squarefree f) (hf : ¬ IsUnit f) : + ¬ IsSquare (algebraMap R Q f) := by + rintro ⟨x, hx⟩ + obtain ⟨a, b, hab, hrepr⟩ := IsFractionRing.exists_reduced_fraction R x + have hbQ : algebraMap R Q (b : R) ≠ 0 := + IsFractionRing.to_map_ne_zero_of_mem_nonZeroDivisors b.2 + have hmap : + algebraMap R Q (f * (b : R) ^ 2) = algebraMap R Q (a ^ 2) := by + simp only [map_mul, map_pow] + rw [hx, ← hrepr, IsFractionRing.mk'_eq_div] + field_simp [hbQ] + have heq : f * (b : R) ^ 2 = a ^ 2 := + FaithfulSMul.algebraMap_injective R Q hmap + have hfa2 : f ∣ a ^ 2 := ⟨(b : R) ^ 2, heq.symm⟩ + have hfa : f ∣ a := (hsq.dvd_pow_iff_dvd (by norm_num : (2 : ℕ) ≠ 0)).mp hfa2 + obtain ⟨c, hac⟩ := hfa + have heq2 : (b : R) ^ 2 = f * c ^ 2 := by + apply mul_left_cancel₀ hsq.ne_zero + calc + f * (b : R) ^ 2 = a ^ 2 := heq + _ = (f * c) ^ 2 := by rw [hac] + _ = f * (f * c ^ 2) := by ring + have hfb2 : f ∣ (b : R) ^ 2 := ⟨c ^ 2, heq2⟩ + have hfb : f ∣ (b : R) := + (hsq.dvd_pow_iff_dvd (by norm_num : (2 : ℕ) ≠ 0)).mp hfb2 + exact hf (hab ⟨c, hac⟩ hfb) + +/-- The twofold-cover polynomial whose square root is the auxiliary `lambda` coordinate. -/ +def incidenceBranchPolynomial (a : K) : K[X] := + C (9 * a ^ 2 - 4) * X ^ 2 - C (4 * a ^ 2) + +lemma incidenceBranchPolynomial_natDegree {a : K} (hA : 9 * a ^ 2 - 4 ≠ 0) : + (incidenceBranchPolynomial a).natDegree = 2 := by + rw [incidenceBranchPolynomial, natDegree_sub_C, + natDegree_C_mul_X_pow 2 (9 * a ^ 2 - 4) hA] + +lemma incidenceBranchPolynomial_not_isUnit {a : K} (hA : 9 * a ^ 2 - 4 ≠ 0) : + ¬ IsUnit (incidenceBranchPolynomial a) := + not_isUnit_of_natDegree_pos _ <| by + rw [incidenceBranchPolynomial_natDegree hA] + norm_num + +/-- The branch polynomials for two parameters have an explicit constant Bezout combination. -/ +lemma incidenceBranchPolynomial_linearCombination (a b : K) : + C (9 * b ^ 2 - 4) * incidenceBranchPolynomial a - + C (9 * a ^ 2 - 4) * incidenceBranchPolynomial b = + C (16 * (a ^ 2 - b ^ 2)) := by + simp only [incidenceBranchPolynomial] + ring_nf + rw [← C_mul, ← C_neg, ← C_mul, ← C_add] + congr 1 + ring + +/-- Away from characteristic two, distinct parameter squares give coprime branch polynomials. -/ +lemma incidenceBranchPolynomial_isCoprime + (h2 : (2 : K) ≠ 0) {a b : K} (hab : a ^ 2 ≠ b ^ 2) : + IsCoprime (incidenceBranchPolynomial a) (incidenceBranchPolynomial b) := by + have h16 : (16 : K) ≠ 0 := by + rw [show (16 : K) = 2 ^ 4 by norm_num] + exact pow_ne_zero 4 h2 + have hc : (16 * (a ^ 2 - b ^ 2) : K) ≠ 0 := + mul_ne_zero h16 (sub_ne_zero.mpr hab) + let c : K := 16 * (a ^ 2 - b ^ 2) + refine ⟨C c⁻¹ * C (9 * b ^ 2 - 4), -(C c⁻¹ * C (9 * a ^ 2 - 4)), ?_⟩ + calc + (C c⁻¹ * C (9 * b ^ 2 - 4)) * incidenceBranchPolynomial a + + -(C c⁻¹ * C (9 * a ^ 2 - 4)) * incidenceBranchPolynomial b = + C c⁻¹ * + (C (9 * b ^ 2 - 4) * incidenceBranchPolynomial a - + C (9 * a ^ 2 - 4) * incidenceBranchPolynomial b) := by ring + _ = C c⁻¹ * C c := by rw [incidenceBranchPolynomial_linearCombination] + _ = 1 := by rw [← C_mul, inv_mul_cancel₀ hc, map_one] + +/-- Each branch polynomial is separable under exactly the nondegeneracy hypotheses used in the +incidence graph. -/ +lemma incidenceBranchPolynomial_separable + (h2 : (2 : K) ≠ 0) {a : K} (ha : a ≠ 0) (hA : 9 * a ^ 2 - 4 ≠ 0) : + (incidenceBranchPolynomial a).Separable := by + have h4 : (4 : K) ≠ 0 := by + rw [show (4 : K) = 2 ^ 2 by norm_num] + exact pow_ne_zero 2 h2 + have hquot : (4 * a ^ 2 / (9 * a ^ 2 - 4) : K) ≠ 0 := + div_ne_zero (mul_ne_zero h4 (pow_ne_zero 2 ha)) hA + have hsep : + (X ^ 2 - C (4 * a ^ 2 / (9 * a ^ 2 - 4)) : K[X]).Separable := + separable_X_pow_sub_C _ h2 hquot + have hunit : IsUnit (C (9 * a ^ 2 - 4) : K[X]) := + isUnit_C.mpr (isUnit_iff_ne_zero.mpr hA) + have heq : + incidenceBranchPolynomial a = + C (9 * a ^ 2 - 4) * + (X ^ 2 - C (4 * a ^ 2 / (9 * a ^ 2 - 4))) := by + simp only [incidenceBranchPolynomial, mul_sub] + rw [← C_mul] + rw [mul_div_cancel₀ (4 * a ^ 2) hA] + rw [heq] + exact hsep.unit_mul hunit + +/-- The product has no repeated irreducible factor. This is the polynomial shadow of the +independence of the two quadratic square classes. -/ +lemma incidenceBranchPolynomial_product_squarefree + (h2 : (2 : K) ≠ 0) {a b : K} + (ha : a ≠ 0) (hb : b ≠ 0) + (hA : 9 * a ^ 2 - 4 ≠ 0) (hB : 9 * b ^ 2 - 4 ≠ 0) + (hab : a ^ 2 ≠ b ^ 2) : + Squarefree (incidenceBranchPolynomial a * incidenceBranchPolynomial b) := by + exact ((incidenceBranchPolynomial_separable h2 ha hA).mul + (incidenceBranchPolynomial_separable h2 hb hB) + (incidenceBranchPolynomial_isCoprime h2 hab)).squarefree + +/-- The three nonzero elements of the span of the two branch square classes are nonsquares in the +rational function field. Equivalently, the two classes are linearly independent over `ZMod 2`. -/ +lemma incidenceBranchSquareClasses_independent_ratFunc + (h2 : (2 : K) ≠ 0) {a b : K} + (ha : a ≠ 0) (hb : b ≠ 0) + (hA : 9 * a ^ 2 - 4 ≠ 0) (hB : 9 * b ^ 2 - 4 ≠ 0) + (hab : a ^ 2 ≠ b ^ 2) : + ¬ IsSquare (algebraMap K[X] (RatFunc K) (incidenceBranchPolynomial a)) ∧ + ¬ IsSquare (algebraMap K[X] (RatFunc K) (incidenceBranchPolynomial b)) ∧ + ¬ IsSquare (algebraMap K[X] (RatFunc K) + (incidenceBranchPolynomial a * incidenceBranchPolynomial b)) := by + have hsqA := (incidenceBranchPolynomial_separable h2 ha hA).squarefree + have hsqB := (incidenceBranchPolynomial_separable h2 hb hB).squarefree + have hsqAB := incidenceBranchPolynomial_product_squarefree h2 ha hb hA hB hab + refine ⟨not_isSquare_algebraMap_of_squarefree_not_isUnit hsqA + (incidenceBranchPolynomial_not_isUnit hA), + not_isSquare_algebraMap_of_squarefree_not_isUnit hsqB + (incidenceBranchPolynomial_not_isUnit hB), ?_⟩ + apply not_isSquare_algebraMap_of_squarefree_not_isUnit hsqAB + intro hunit + exact incidenceBranchPolynomial_not_isUnit hA (IsUnit.mul_iff.mp hunit).1 + +/-- Equality of the squared branch locations forces equality of the parameter squares. -/ +lemma incidenceBranchLocation_injective + (h2 : (2 : K) ≠ 0) {a b : K} + (h : a ^ 2 * (9 * b ^ 2 - 4) = b ^ 2 * (9 * a ^ 2 - 4)) : + a ^ 2 = b ^ 2 := by + have h4 : (4 : K) ≠ 0 := by + rw [show (4 : K) = 2 ^ 2 by norm_num] + exact pow_ne_zero 2 h2 + apply (mul_left_cancel₀ h4) + calc + 4 * a ^ 2 = -(a ^ 2 * (9 * b ^ 2 - 4) - 9 * a ^ 2 * b ^ 2) := by ring + _ = -(b ^ 2 * (9 * a ^ 2 - 4) - 9 * a ^ 2 * b ^ 2) := by rw [h] + _ = 4 * b ^ 2 := by ring + +end + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Incidence/NormalizedGraph.lean b/LeanPool/MarkoffModP/BGS/Markoff/Incidence/NormalizedGraph.lean new file mode 100644 index 0000000000..251ac21490 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Incidence/NormalizedGraph.lean @@ -0,0 +1,700 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Incidence.Fibers +public import LeanPool.MarkoffModP.BGS.Markoff.Core.ParabolicFibers + +/-! +# The normalized incidence graph and its parabolic vertices + +The published proof of Proposition 8 dismisses the case `p ≡ 1 (mod 4)` as simpler +because of the parabolic lines. This file records the missing argument without folding +normalized trace coordinates back into the original Markoff coordinates. + +The key fact is stronger than mere connectivity: after choosing `i² = -1`, a fiber whose +normalized coordinate is `2` or `-2` meets every fiber on either different coordinate axis. +-/ + +@[expose] public section + +namespace BGS.Markoff + +universe u + +/-- The three coordinate axes used to index normalized conic fibers. -/ +inductive NormalizedCoordinateAxis + | first + | second + | third + deriving DecidableEq, Repr + +instance : Fintype NormalizedCoordinateAxis where + elems := {.first, .second, .third} + complete x := by cases x <;> simp + +/-- A normalized conic fiber, indexed without identifying normalized and original coordinates. -/ +def normalizedFiberAt {R : Type u} [CommRing R] : + NormalizedCoordinateAxis → R → Set (NormalizedPoint R) + | .first, a => normalizedFiber1 a + | .second, a => normalizedFiber2 a + | .third, a => normalizedFiber3 a + +/-- The action of swapping the first two coordinates on axis labels. -/ +def normalizedSwap12Axis : NormalizedCoordinateAxis → NormalizedCoordinateAxis + | .first => .second + | .second => .first + | .third => .third + +/-- The action of swapping the last two coordinates on axis labels. -/ +def normalizedSwap23Axis : NormalizedCoordinateAxis → NormalizedCoordinateAxis + | .first => .first + | .second => .third + | .third => .second + +theorem normalizedSwap12_mem_fiberAt + {R : Type u} [CommRing R] {axis : NormalizedCoordinateAxis} {a : R} + {x : NormalizedPoint R} (hx : x ∈ normalizedFiberAt axis a) : + normalizedSwap12 x ∈ normalizedFiberAt (normalizedSwap12Axis axis) a := by + rcases axis with _ | _ | _ + all_goals + refine ⟨?_, hx.2⟩ + change normalizedPolynomial (normalizedSwap12 x) = 0 + rw [normalizedPolynomial_swap12] + exact hx.1 + +theorem normalizedSwap23_mem_fiberAt + {R : Type u} [CommRing R] {axis : NormalizedCoordinateAxis} {a : R} + {x : NormalizedPoint R} (hx : x ∈ normalizedFiberAt axis a) : + normalizedSwap23 x ∈ normalizedFiberAt (normalizedSwap23Axis axis) a := by + rcases axis with _ | _ | _ + all_goals + refine ⟨?_, hx.2⟩ + change normalizedPolynomial (normalizedSwap23 x) = 0 + rw [normalizedPolynomial_swap23] + exact hx.1 + +/-- Two normalized conic fibers meet when their set-theoretic intersection is nonempty. -/ +def NormalizedFibersMeet {R : Type u} (s t : Set (NormalizedPoint R)) : Prop := + (s ∩ t).Nonempty + +theorem normalizedFibersMeet_comm {R : Type u} {s t : Set (NormalizedPoint R)} : + NormalizedFibersMeet s t ↔ NormalizedFibersMeet t s := by + simp only [NormalizedFibersMeet, Set.inter_comm] + +/-- Coordinate swapping transports a meeting of normalized fibers. -/ +theorem normalizedFibersMeet_swap12 + {R : Type u} [CommRing R] + {axis other : NormalizedCoordinateAxis} {a b : R} + (h : NormalizedFibersMeet (normalizedFiberAt axis a) (normalizedFiberAt other b)) : + NormalizedFibersMeet + (normalizedFiberAt (normalizedSwap12Axis axis) a) + (normalizedFiberAt (normalizedSwap12Axis other) b) := by + rcases h with ⟨x, hx, hy⟩ + exact ⟨normalizedSwap12 x, normalizedSwap12_mem_fiberAt hx, + normalizedSwap12_mem_fiberAt hy⟩ + +/-- Swapping the last two coordinates transports a meeting of normalized fibers. -/ +theorem normalizedFibersMeet_swap23 + {R : Type u} [CommRing R] + {axis other : NormalizedCoordinateAxis} {a b : R} + (h : NormalizedFibersMeet (normalizedFiberAt axis a) (normalizedFiberAt other b)) : + NormalizedFibersMeet + (normalizedFiberAt (normalizedSwap23Axis axis) a) + (normalizedFiberAt (normalizedSwap23Axis other) b) := by + rcases h with ⟨x, hx, hy⟩ + exact ⟨normalizedSwap23 x, normalizedSwap23_mem_fiberAt hx, + normalizedSwap23_mem_fiberAt hy⟩ + +/-- The intrinsic normalized-coordinate condition for a parabolic trace. -/ +def IsNormalizedParabolicCoordinate {R : Type u} [OfNat R 4] [Pow R ℕ] + (a : R) : Prop := + a ^ 2 = 4 + +/-- The normalized coordinates excluded by the existing admissible-incidence argument. -/ +def IsNormalizedExceptionalCoordinate {R : Type u} [OfNat R 0] [OfNat R 4] [Pow R ℕ] + (a : R) : Prop := + a = 0 ∨ IsNormalizedParabolicCoordinate a + +/-- Divide a normalized trace coordinate by three without identifying its type with an +original Markoff coordinate. -/ +def unscaleNormalizedCoordinate {R : Type u} [CommRing R] [Invertible (3 : R)] + (u : R) : R := + ⅟(3 : R) * u + +@[simp] +theorem three_mul_unscaleNormalizedCoordinate + {R : Type u} [CommRing R] [Invertible (3 : R)] (u : R) : + 3 * unscaleNormalizedCoordinate u = u := by + simp [unscaleNormalizedCoordinate, ← mul_assoc] + +@[simp] +theorem unscaleNormalizedCoordinate_three_mul + {R : Type u} [CommRing R] [Invertible (3 : R)] (a : R) : + unscaleNormalizedCoordinate (3 * a) = a := by + simp [unscaleNormalizedCoordinate, ← mul_assoc] + +/-- Original-coordinate admissibility is exactly the complement of the zero and parabolic +normalized trace values. -/ +theorem isAdmissibleCoordinate_unscaleNormalizedCoordinate_iff + {p : ℕ} [Fact p.Prime] [Invertible (3 : ZMod p)] (u : ZMod p) : + IsAdmissibleCoordinate (unscaleNormalizedCoordinate u) ↔ + ¬ IsNormalizedExceptionalCoordinate u := by + rw [show (¬ IsNormalizedExceptionalCoordinate u) ↔ + u ≠ 0 ∧ ¬ IsNormalizedParabolicCoordinate u by + simp [IsNormalizedExceptionalCoordinate]] + simp only [IsAdmissibleCoordinate, IsNormalizedParabolicCoordinate, + three_mul_unscaleNormalizedCoordinate] + constructor + · rintro ⟨hu, hsquare⟩ + refine ⟨?_, hsquare⟩ + intro hzero + apply hu + simp [hzero, unscaleNormalizedCoordinate] + · rintro ⟨hu, hsquare⟩ + refine ⟨?_, hsquare⟩ + intro hzero + apply hu + calc + u = 3 * unscaleNormalizedCoordinate u := + (three_mul_unscaleNormalizedCoordinate u).symm + _ = 0 := by rw [hzero, mul_zero] + +/-- Scaling a meeting of an original first-axis and third-axis fiber gives the corresponding +meeting in normalized trace coordinates. -/ +theorem normalizedFibersMeet_fiber1_fiber3_of_original + {R : Type u} [Field R] [Invertible (3 : R)] {a c : R} + (h : FibersMeet (fiber1 a) (fiber3 c)) : + NormalizedFibersMeet (normalizedFiber1 (3 * a)) (normalizedFiber3 (3 * c)) := by + rcases h with ⟨x, hx1, hx3⟩ + have hsurface : IsNormalizedMarkoff (toNormalized x) := + (isNormalizedMarkoff_toNormalized_iff x).2 hx1.1 + exact ⟨toNormalized x, + ⟨hsurface, by simp [toNormalized, hx1.2]⟩, + ⟨hsurface, by simp [toNormalized, hx3.2]⟩⟩ + +/-- Scaling a meeting of an original second-axis and third-axis fiber gives the corresponding +meeting in normalized trace coordinates. -/ +theorem normalizedFibersMeet_fiber2_fiber3_of_original + {R : Type u} [Field R] [Invertible (3 : R)] {b c : R} + (h : FibersMeet (fiber2 b) (fiber3 c)) : + NormalizedFibersMeet (normalizedFiber2 (3 * b)) (normalizedFiber3 (3 * c)) := by + rcases h with ⟨x, hx2, hx3⟩ + have hsurface : IsNormalizedMarkoff (toNormalized x) := + (isNormalizedMarkoff_toNormalized_iff x).2 hx2.1 + exact ⟨toNormalized x, + ⟨hsurface, by simp [toNormalized, hx2.2]⟩, + ⟨hsurface, by simp [toNormalized, hx3.2]⟩⟩ + +/-- The normalized, type-distinct form of the existing admissible bridge for the first two +axes. -/ +def NormalizedAdmissibleBridgeAt (p : ℕ) (hp : p.Prime) : Prop := + letI : Fact p.Prime := ⟨hp⟩ + ∀ u v : ZMod p, + ¬ IsNormalizedExceptionalCoordinate u → + ¬ IsNormalizedExceptionalCoordinate v → + ∃ w : ZMod p, + ¬ IsNormalizedExceptionalCoordinate w ∧ + NormalizedFibersMeet (normalizedFiber1 u) (normalizedFiber3 w) ∧ + NormalizedFibersMeet (normalizedFiber2 v) (normalizedFiber3 w) + +/-- Transport the proved original-coordinate admissible bridge through the explicit scaling +equivalence. -/ +theorem normalizedAdmissibleBridgeAt_of_incidenceBridgeAt + (p : ℕ) (hp : p.Prime) [Invertible (3 : ZMod p)] + (hbridge : IncidenceBridgeAt p hp) : NormalizedAdmissibleBridgeAt p hp := by + let : Fact p.Prime := ⟨hp⟩ + intro u v hu hv + let a := unscaleNormalizedCoordinate u + let b := unscaleNormalizedCoordinate v + have ha : IsAdmissibleCoordinate a := + (isAdmissibleCoordinate_unscaleNormalizedCoordinate_iff u).2 hu + have hb : IsAdmissibleCoordinate b := + (isAdmissibleCoordinate_unscaleNormalizedCoordinate_iff v).2 hv + obtain ⟨c, hc, hac, hbc⟩ := hbridge a b ha hb + have hw : ¬ IsNormalizedExceptionalCoordinate (3 * c) := by + apply (isAdmissibleCoordinate_unscaleNormalizedCoordinate_iff (3 * c)).1 + simpa using hc + refine ⟨3 * c, hw, ?_, ?_⟩ + · simpa [a] using normalizedFibersMeet_fiber1_fiber3_of_original hac + · simpa [b] using normalizedFibersMeet_fiber2_fiber3_of_original hbc + +/-- The normalized admissible bridge for primes congruent to one modulo four. -/ +theorem normalizedAdmissibleBridge_mod_one + (hHasse : ZModLegendrePointCardHasseBound) : + ∃ p0 : ℕ, ∀ (p : ℕ) (hp : p.Prime), p0 ≤ p → p % 4 = 1 → + NormalizedAdmissibleBridgeAt p hp := by + obtain ⟨p0, hbridge⟩ := incidenceBridge_mod_one_admissible hHasse + refine ⟨p0, ?_⟩ + intro p hp hpLarge hmod + let : Fact p.Prime := ⟨hp⟩ + have hpThree : 3 < p := by + by_contra h + have hpLe : p ≤ 3 := by omega + have hpTwo : 2 ≤ p := hp.two_le + have hpCases : p = 2 ∨ p = 3 := by omega + rcases hpCases with rfl | rfl <;> norm_num at hmod + let : Invertible (3 : ZMod p) := + invertibleOfNonzero (natCast_ne_zero_zmod_of_pos_of_lt (by norm_num) hpThree) + exact normalizedAdmissibleBridgeAt_of_incidenceBridgeAt p hp + (hbridge p hp hpLarge hmod) + +/-- The graph-level admissible bridge, with coordinate permutations made explicit. -/ +def NormalizedAdmissibleGraphBridgeAt (p : ℕ) (hp : p.Prime) : Prop := + letI : Fact p.Prime := ⟨hp⟩ + ∀ (axis other : NormalizedCoordinateAxis) (u v : ZMod p), + ¬ IsNormalizedExceptionalCoordinate u → + ¬ IsNormalizedExceptionalCoordinate v → + ∃ middle : NormalizedCoordinateAxis, ∃ w : ZMod p, + middle ≠ axis ∧ middle ≠ other ∧ + NormalizedFibersMeet (normalizedFiberAt axis u) (normalizedFiberAt middle w) ∧ + NormalizedFibersMeet (normalizedFiberAt other v) (normalizedFiberAt middle w) + +/-- The fixed-axis admissible bridge implies the full graph-level bridge. Every coordinate +permutation is applied to the actual intersection witness. -/ +theorem normalizedAdmissibleGraphBridgeAt_of_fixedAxes + {p : ℕ} {hp : p.Prime} + (hbridge : NormalizedAdmissibleBridgeAt p hp) : + NormalizedAdmissibleGraphBridgeAt p hp := by + let : Fact p.Prime := ⟨hp⟩ + intro axis other u v hu hv + rcases axis with _ | _ | _ <;> rcases other with _ | _ | _ + · obtain ⟨w, hw, h13, h23⟩ := hbridge u v hu hv + refine ⟨.third, w, by decide, by decide, h13, ?_⟩ + simpa [normalizedSwap12Axis] using + normalizedFibersMeet_swap12 (axis := .second) (other := .third) h23 + · obtain ⟨w, hw, h13, h23⟩ := hbridge u v hu hv + exact ⟨.third, w, by decide, by decide, h13, h23⟩ + · obtain ⟨w, hw, h13, h23⟩ := hbridge u v hu hv + refine ⟨.second, w, by decide, by decide, ?_, ?_⟩ + · simpa [normalizedSwap23Axis] using + normalizedFibersMeet_swap23 (axis := .first) (other := .third) h13 + · simpa [normalizedSwap23Axis] using + normalizedFibersMeet_swap23 (axis := .second) (other := .third) h23 + · obtain ⟨w, hw, h13, h23⟩ := hbridge v u hv hu + exact ⟨.third, w, by decide, by decide, h23, h13⟩ + · obtain ⟨w, hw, h13, h23⟩ := hbridge u v hu hv + refine ⟨.third, w, by decide, by decide, ?_, h23⟩ + simpa [normalizedSwap12Axis] using + normalizedFibersMeet_swap12 (axis := .first) (other := .third) h13 + · obtain ⟨w, hw, h13, h23⟩ := hbridge u v hu hv + refine ⟨.first, w, by decide, by decide, ?_, ?_⟩ + · simpa [normalizedSwap12Axis, normalizedSwap23Axis] using + normalizedFibersMeet_swap12 (axis := .first) (other := .second) + (normalizedFibersMeet_swap23 (axis := .first) (other := .third) h13) + · simpa [normalizedSwap12Axis, normalizedSwap23Axis] using + normalizedFibersMeet_swap12 (axis := .third) (other := .second) + (normalizedFibersMeet_swap23 (axis := .second) (other := .third) h23) + · obtain ⟨w, hw, h13, h23⟩ := hbridge v u hv hu + refine ⟨.second, w, by decide, by decide, ?_, ?_⟩ + · simpa [normalizedSwap23Axis] using + normalizedFibersMeet_swap23 (axis := .second) (other := .third) h23 + · simpa [normalizedSwap23Axis] using + normalizedFibersMeet_swap23 (axis := .first) (other := .third) h13 + · obtain ⟨w, hw, h13, h23⟩ := hbridge v u hv hu + refine ⟨.first, w, by decide, by decide, ?_, ?_⟩ + · simpa [normalizedSwap12Axis, normalizedSwap23Axis] using + normalizedFibersMeet_swap12 (axis := .third) (other := .second) + (normalizedFibersMeet_swap23 (axis := .second) (other := .third) h23) + · simpa [normalizedSwap12Axis, normalizedSwap23Axis] using + normalizedFibersMeet_swap12 (axis := .first) (other := .second) + (normalizedFibersMeet_swap23 (axis := .first) (other := .third) h13) + · obtain ⟨w, hw, h13, h23⟩ := hbridge u v hu hv + refine ⟨.first, w, by decide, by decide, ?_, ?_⟩ + · simpa [normalizedSwap12Axis, normalizedSwap23Axis] using + normalizedFibersMeet_swap12 (axis := .third) (other := .second) + (normalizedFibersMeet_swap23 (axis := .second) (other := .third) + (normalizedFibersMeet_swap12 (axis := .first) (other := .third) h13)) + · simpa [normalizedSwap12Axis, normalizedSwap23Axis] using + normalizedFibersMeet_swap12 (axis := .third) (other := .second) + (normalizedFibersMeet_swap23 (axis := .second) (other := .third) h23) + +/-- The graph-level admissible bridge for all sufficiently large primes congruent to one modulo +four. -/ +theorem normalizedAdmissibleGraphBridge_mod_one + (hHasse : ZModLegendrePointCardHasseBound) : + ∃ p0 : ℕ, ∀ (p : ℕ) (hp : p.Prime), p0 ≤ p → p % 4 = 1 → + NormalizedAdmissibleGraphBridgeAt p hp := by + obtain ⟨p0, hbridge⟩ := normalizedAdmissibleBridge_mod_one hHasse + exact ⟨p0, fun p hp hpLarge hmod => + normalizedAdmissibleGraphBridgeAt_of_fixedAxes (hbridge p hp hpLarge hmod)⟩ + +private theorem parabolic_eq_two_or_neg_two + {R : Type u} [CommRing R] [NoZeroDivisors R] {a : R} + (ha : IsNormalizedParabolicCoordinate a) : a = 2 ∨ a = -2 := by + apply sq_eq_sq_iff_eq_or_eq_neg.mp + calc + a ^ 2 = 4 := ha + _ = (2 : R) ^ 2 := by norm_num + +/-- The trace-`2` fiber on the first axis meets every second-axis fiber. -/ +theorem normalizedFiber1_two_meets_fiber2 + {R : Type u} [CommRing R] [NoZeroDivisors R] (i b : R) (hi : i ^ 2 = -1) : + NormalizedFibersMeet (normalizedFiber1 (2 : R)) (normalizedFiber2 b) := by + let x := parabolicLineAtTwo i b + have hx : IsNormalizedMarkoff x := by + change IsNormalizedMarkoff (⟨2, b, b + 2 * i⟩ : NormalizedPoint R) + rw [isNormalizedMarkoff_at_two_iff_on_parabolic_lines hi] + exact Or.inl rfl + exact ⟨x, ⟨hx, rfl⟩, ⟨hx, rfl⟩⟩ + +/-- The trace-`-2` fiber on the first axis meets every second-axis fiber. -/ +theorem normalizedFiber1_neg_two_meets_fiber2 + {R : Type u} [CommRing R] [NoZeroDivisors R] (i b : R) (hi : i ^ 2 = -1) : + NormalizedFibersMeet (normalizedFiber1 (-2 : R)) (normalizedFiber2 b) := by + let x := parabolicLineAtNegTwo i b + have hx : IsNormalizedMarkoff x := by + change IsNormalizedMarkoff (⟨-2, b, -b + 2 * i⟩ : NormalizedPoint R) + rw [isNormalizedMarkoff_at_neg_two_iff_on_parabolic_lines hi] + exact Or.inl rfl + exact ⟨x, ⟨hx, rfl⟩, ⟨hx, rfl⟩⟩ + +/-- A parabolic first-axis fiber meets every second-axis fiber. -/ +theorem normalizedFiber1_parabolic_meets_fiber2 + {R : Type u} [CommRing R] [NoZeroDivisors R] + (i : R) (hi : i ^ 2 = -1) {a : R} (ha : IsNormalizedParabolicCoordinate a) + (b : R) : + NormalizedFibersMeet (normalizedFiber1 a) (normalizedFiber2 b) := by + rcases parabolic_eq_two_or_neg_two ha with rfl | rfl + · exact normalizedFiber1_two_meets_fiber2 i b hi + · exact normalizedFiber1_neg_two_meets_fiber2 i b hi + +/-- The trace-`2` fiber on the first axis meets every third-axis fiber. -/ +theorem normalizedFiber1_two_meets_fiber3 + {R : Type u} [CommRing R] [NoZeroDivisors R] (i c : R) (hi : i ^ 2 = -1) : + NormalizedFibersMeet (normalizedFiber1 (2 : R)) (normalizedFiber3 c) := by + let x := parabolicLineAtTwo i (c - 2 * i) + have hx : IsNormalizedMarkoff x := by + change IsNormalizedMarkoff + (⟨2, c - 2 * i, (c - 2 * i) + 2 * i⟩ : NormalizedPoint R) + rw [isNormalizedMarkoff_at_two_iff_on_parabolic_lines hi] + exact Or.inl rfl + refine ⟨x, ⟨hx, rfl⟩, hx, ?_⟩ + simp [x, parabolicLineAtTwo] + +/-- The trace-`-2` fiber on the first axis meets every third-axis fiber. -/ +theorem normalizedFiber1_neg_two_meets_fiber3 + {R : Type u} [CommRing R] [NoZeroDivisors R] (i c : R) (hi : i ^ 2 = -1) : + NormalizedFibersMeet (normalizedFiber1 (-2 : R)) (normalizedFiber3 c) := by + let x := parabolicLineAtNegTwo i (2 * i - c) + have hx : IsNormalizedMarkoff x := by + change IsNormalizedMarkoff + (⟨-2, 2 * i - c, -(2 * i - c) + 2 * i⟩ : NormalizedPoint R) + rw [isNormalizedMarkoff_at_neg_two_iff_on_parabolic_lines hi] + exact Or.inl rfl + refine ⟨x, ⟨hx, rfl⟩, hx, ?_⟩ + simp [x, parabolicLineAtNegTwo] + +/-- A parabolic first-axis fiber meets every third-axis fiber. -/ +theorem normalizedFiber1_parabolic_meets_fiber3 + {R : Type u} [CommRing R] [NoZeroDivisors R] + (i : R) (hi : i ^ 2 = -1) {a : R} (ha : IsNormalizedParabolicCoordinate a) + (c : R) : + NormalizedFibersMeet (normalizedFiber1 a) (normalizedFiber3 c) := by + rcases parabolic_eq_two_or_neg_two ha with rfl | rfl + · exact normalizedFiber1_two_meets_fiber3 i c hi + · exact normalizedFiber1_neg_two_meets_fiber3 i c hi + +/-- When `i² = -1`, the zero fiber on the first axis meets every second-axis fiber. -/ +theorem normalizedFiber1_zero_meets_fiber2 + {R : Type u} [CommRing R] (i b : R) (hi : i ^ 2 = -1) : + NormalizedFibersMeet (normalizedFiber1 (0 : R)) (normalizedFiber2 b) := by + let x : NormalizedPoint R := ⟨0, b, i * b⟩ + have hx : IsNormalizedMarkoff x := by + simp only [IsNormalizedMarkoff, normalizedPolynomial, x] + rw [mul_pow, hi] + ring + exact ⟨x, ⟨hx, rfl⟩, ⟨hx, rfl⟩⟩ + +/-- When `i² = -1`, the zero fiber on the first axis meets every third-axis fiber. -/ +theorem normalizedFiber1_zero_meets_fiber3 + {R : Type u} [CommRing R] (i c : R) (hi : i ^ 2 = -1) : + NormalizedFibersMeet (normalizedFiber1 (0 : R)) (normalizedFiber3 c) := by + let x : NormalizedPoint R := ⟨0, i * c, c⟩ + have hx : IsNormalizedMarkoff x := by + simp only [IsNormalizedMarkoff, normalizedPolynomial, x] + rw [mul_pow, hi] + ring + exact ⟨x, ⟨hx, rfl⟩, ⟨hx, rfl⟩⟩ + +/-- A parabolic fiber on any axis meets every fiber on a different axis. -/ +theorem normalizedParabolicFiber_meets_distinctAxis + {R : Type u} [CommRing R] [NoZeroDivisors R] + (i : R) (hi : i ^ 2 = -1) + {axis other : NormalizedCoordinateAxis} (haxis : axis ≠ other) + {a : R} (ha : IsNormalizedParabolicCoordinate a) (b : R) : + NormalizedFibersMeet (normalizedFiberAt axis a) (normalizedFiberAt other b) := by + rcases axis with _ | _ | _ <;> rcases other with _ | _ | _ + · exact (haxis rfl).elim + · exact normalizedFiber1_parabolic_meets_fiber2 i hi ha b + · exact normalizedFiber1_parabolic_meets_fiber3 i hi ha b + · -- Swap the first two coordinates in a first/second-axis witness. + rcases normalizedFiber1_parabolic_meets_fiber2 i hi ha b with ⟨x, hx1, hx2⟩ + let y := normalizedSwap12 x + have hy : IsNormalizedMarkoff y := by + change normalizedPolynomial (normalizedSwap12 x) = 0 + rw [normalizedPolynomial_swap12] + exact hx1.1 + exact ⟨y, ⟨hy, hx1.2⟩, ⟨hy, hx2.2⟩⟩ + · exact (haxis rfl).elim + · -- Swap the first two coordinates in the preceding first/third-axis witness. + rcases normalizedFiber1_parabolic_meets_fiber3 i hi ha b with ⟨x, hx1, hx3⟩ + let y := normalizedSwap12 x + have hy : IsNormalizedMarkoff y := by + change normalizedPolynomial (normalizedSwap12 x) = 0 + rw [normalizedPolynomial_swap12] + exact hx1.1 + exact ⟨y, ⟨hy, hx1.2⟩, ⟨hy, hx3.2⟩⟩ + · -- Swap the first and third coordinates in a first/third-axis witness. + rcases normalizedFiber1_parabolic_meets_fiber3 i hi ha b with ⟨x, hx1, hx3⟩ + let y := normalizedSwap12 (normalizedSwap23 (normalizedSwap12 x)) + have hy : IsNormalizedMarkoff y := by + change normalizedPolynomial (normalizedSwap12 (normalizedSwap23 (normalizedSwap12 x))) = 0 + rw [normalizedPolynomial_swap12, normalizedPolynomial_swap23, + normalizedPolynomial_swap12] + exact hx1.1 + exact ⟨y, ⟨hy, hx1.2⟩, ⟨hy, hx3.2⟩⟩ + · -- Swap the first and third coordinates in a first/second-axis witness. + rcases normalizedFiber1_parabolic_meets_fiber2 i hi ha b with ⟨x, hx1, hx2⟩ + let y := normalizedSwap12 (normalizedSwap23 (normalizedSwap12 x)) + have hy : IsNormalizedMarkoff y := by + change normalizedPolynomial (normalizedSwap12 (normalizedSwap23 (normalizedSwap12 x))) = 0 + rw [normalizedPolynomial_swap12, normalizedPolynomial_swap23, + normalizedPolynomial_swap12] + exact hx1.1 + exact ⟨y, ⟨hy, hx1.2⟩, ⟨hy, hx2.2⟩⟩ + · exact (haxis rfl).elim + +/-- A zero-coordinate fiber meets every fiber on a different axis when `-1` is a square. -/ +theorem normalizedZeroFiber_meets_distinctAxis + {R : Type u} [CommRing R] + (i : R) (hi : i ^ 2 = -1) + {axis other : NormalizedCoordinateAxis} (haxis : axis ≠ other) (b : R) : + NormalizedFibersMeet (normalizedFiberAt axis 0) (normalizedFiberAt other b) := by + rcases axis with _ | _ | _ <;> rcases other with _ | _ | _ + · exact (haxis rfl).elim + · exact normalizedFiber1_zero_meets_fiber2 i b hi + · exact normalizedFiber1_zero_meets_fiber3 i b hi + · rcases normalizedFiber1_zero_meets_fiber2 i b hi with ⟨x, hx1, hx2⟩ + let y := normalizedSwap12 x + have hy : IsNormalizedMarkoff y := by + change normalizedPolynomial (normalizedSwap12 x) = 0 + rw [normalizedPolynomial_swap12] + exact hx1.1 + exact ⟨y, ⟨hy, hx1.2⟩, ⟨hy, hx2.2⟩⟩ + · exact (haxis rfl).elim + · rcases normalizedFiber1_zero_meets_fiber3 i b hi with ⟨x, hx1, hx3⟩ + let y := normalizedSwap12 x + have hy : IsNormalizedMarkoff y := by + change normalizedPolynomial (normalizedSwap12 x) = 0 + rw [normalizedPolynomial_swap12] + exact hx1.1 + exact ⟨y, ⟨hy, hx1.2⟩, ⟨hy, hx3.2⟩⟩ + · rcases normalizedFiber1_zero_meets_fiber3 i b hi with ⟨x, hx1, hx3⟩ + let y := normalizedSwap12 (normalizedSwap23 (normalizedSwap12 x)) + have hy : IsNormalizedMarkoff y := by + change normalizedPolynomial (normalizedSwap12 (normalizedSwap23 (normalizedSwap12 x))) = 0 + rw [normalizedPolynomial_swap12, normalizedPolynomial_swap23, + normalizedPolynomial_swap12] + exact hx1.1 + exact ⟨y, ⟨hy, hx1.2⟩, ⟨hy, hx3.2⟩⟩ + · rcases normalizedFiber1_zero_meets_fiber2 i b hi with ⟨x, hx1, hx2⟩ + let y := normalizedSwap12 (normalizedSwap23 (normalizedSwap12 x)) + have hy : IsNormalizedMarkoff y := by + change normalizedPolynomial (normalizedSwap12 (normalizedSwap23 (normalizedSwap12 x))) = 0 + rw [normalizedPolynomial_swap12, normalizedPolynomial_swap23, + normalizedPolynomial_swap12] + exact hx1.1 + exact ⟨y, ⟨hy, hx1.2⟩, ⟨hy, hx2.2⟩⟩ + · exact (haxis rfl).elim + +/-- Every coordinate excluded by admissibility meets every fiber on a different axis when +`-1` is a square. -/ +theorem normalizedExceptionalFiber_meets_distinctAxis + {R : Type u} [CommRing R] [NoZeroDivisors R] + (i : R) (hi : i ^ 2 = -1) + {axis other : NormalizedCoordinateAxis} (haxis : axis ≠ other) + {a : R} (ha : IsNormalizedExceptionalCoordinate a) (b : R) : + NormalizedFibersMeet (normalizedFiberAt axis a) (normalizedFiberAt other b) := by + rcases ha with rfl | ha + · exact normalizedZeroFiber_meets_distinctAxis i hi haxis b + · exact normalizedParabolicFiber_meets_distinctAxis i hi haxis ha b + +/-- If one vertex is parabolic and the other vertex is on the same axis, any point of the +other fiber supplies a common neighbor on either different axis. -/ +theorem normalizedParabolicFiber_commonNeighbor_sameAxis + {R : Type u} [CommRing R] [NoZeroDivisors R] + (i : R) (hi : i ^ 2 = -1) (axis other : NormalizedCoordinateAxis) + (haxis : axis ≠ other) {a b : R} (ha : IsNormalizedParabolicCoordinate a) + (hb : (normalizedFiberAt axis b).Nonempty) : + ∃ c : R, + NormalizedFibersMeet (normalizedFiberAt axis a) (normalizedFiberAt other c) ∧ + NormalizedFibersMeet (normalizedFiberAt axis b) (normalizedFiberAt other c) := by + rcases hb with ⟨x, hx⟩ + rcases axis with _ | _ | _ <;> rcases other with _ | _ | _ + · exact (haxis rfl).elim + · refine ⟨x.u2, normalizedParabolicFiber_meets_distinctAxis i hi haxis ha x.u2, ?_⟩ + exact ⟨x, hx, ⟨hx.1, rfl⟩⟩ + · refine ⟨x.u3, normalizedParabolicFiber_meets_distinctAxis i hi haxis ha x.u3, ?_⟩ + exact ⟨x, hx, ⟨hx.1, rfl⟩⟩ + · refine ⟨x.u1, normalizedParabolicFiber_meets_distinctAxis i hi haxis ha x.u1, ?_⟩ + exact ⟨x, hx, ⟨hx.1, rfl⟩⟩ + · exact (haxis rfl).elim + · refine ⟨x.u3, normalizedParabolicFiber_meets_distinctAxis i hi haxis ha x.u3, ?_⟩ + exact ⟨x, hx, ⟨hx.1, rfl⟩⟩ + · refine ⟨x.u1, normalizedParabolicFiber_meets_distinctAxis i hi haxis ha x.u1, ?_⟩ + exact ⟨x, hx, ⟨hx.1, rfl⟩⟩ + · refine ⟨x.u2, normalizedParabolicFiber_meets_distinctAxis i hi haxis ha x.u2, ?_⟩ + exact ⟨x, hx, ⟨hx.1, rfl⟩⟩ + · exact (haxis rfl).elim + +/-- A deterministic choice of an axis different from each of two supplied axes. -/ +def normalizedBridgeAxis : + NormalizedCoordinateAxis → NormalizedCoordinateAxis → NormalizedCoordinateAxis + | .first, .first => .second + | .first, .second => .third + | .first, .third => .second + | .second, .first => .third + | .second, .second => .first + | .second, .third => .first + | .third, .first => .second + | .third, .second => .first + | .third, .third => .first + +theorem normalizedBridgeAxis_ne_left (axis other : NormalizedCoordinateAxis) : + normalizedBridgeAxis axis other ≠ axis := by + cases axis <;> cases other <;> decide + +theorem normalizedBridgeAxis_ne_right (axis other : NormalizedCoordinateAxis) : + normalizedBridgeAxis axis other ≠ other := by + cases axis <;> cases other <;> decide + +/-- A nonempty fiber meets some fiber on every different axis: use the corresponding +coordinate of a point already in the first fiber. -/ +theorem normalizedFiber_meets_some_fiber_on_distinctAxis + {R : Type u} [CommRing R] + {axis other : NormalizedCoordinateAxis} (haxis : axis ≠ other) {b : R} + (hb : (normalizedFiberAt axis b).Nonempty) : + ∃ c : R, NormalizedFibersMeet (normalizedFiberAt axis b) (normalizedFiberAt other c) := by + rcases hb with ⟨x, hx⟩ + rcases axis with _ | _ | _ <;> rcases other with _ | _ | _ + · exact (haxis rfl).elim + · exact ⟨x.u2, x, hx, ⟨hx.1, rfl⟩⟩ + · exact ⟨x.u3, x, hx, ⟨hx.1, rfl⟩⟩ + · exact ⟨x.u1, x, hx, ⟨hx.1, rfl⟩⟩ + · exact (haxis rfl).elim + · exact ⟨x.u3, x, hx, ⟨hx.1, rfl⟩⟩ + · exact ⟨x.u1, x, hx, ⟨hx.1, rfl⟩⟩ + · exact ⟨x.u2, x, hx, ⟨hx.1, rfl⟩⟩ + · exact (haxis rfl).elim + +/-- The complete parabolic bridge suppressed by the published proof. + +For a parabolic vertex on `axis` and any nonempty vertex on `other`, this produces a common +neighbor on an axis different from both. Thus all interactions involving a parabolic vertex +have graph distance at most two; no admissibility hypothesis is imposed on the other vertex. -/ +theorem normalizedParabolicFiber_has_commonNeighbor + {R : Type u} [CommRing R] [NoZeroDivisors R] + (i : R) (hi : i ^ 2 = -1) + (axis other : NormalizedCoordinateAxis) {a b : R} + (ha : IsNormalizedParabolicCoordinate a) + (hb : (normalizedFiberAt other b).Nonempty) : + ∃ middle : NormalizedCoordinateAxis, ∃ c : R, + middle ≠ axis ∧ middle ≠ other ∧ + NormalizedFibersMeet (normalizedFiberAt axis a) (normalizedFiberAt middle c) ∧ + NormalizedFibersMeet (normalizedFiberAt other b) (normalizedFiberAt middle c) := by + let middle := normalizedBridgeAxis axis other + have hleft : middle ≠ axis := normalizedBridgeAxis_ne_left axis other + have hright : middle ≠ other := normalizedBridgeAxis_ne_right axis other + obtain ⟨c, hc⟩ := normalizedFiber_meets_some_fiber_on_distinctAxis hright.symm hb + exact ⟨middle, c, hleft, hright, + normalizedParabolicFiber_meets_distinctAxis i hi hleft.symm ha c, hc⟩ + +/-- The same graph-level bridge for every coordinate omitted by the admissible argument, +including the zero-coordinate lines that also occur when `-1` is a square. -/ +theorem normalizedExceptionalFiber_has_commonNeighbor + {R : Type u} [CommRing R] [NoZeroDivisors R] + (i : R) (hi : i ^ 2 = -1) + (axis other : NormalizedCoordinateAxis) {a b : R} + (ha : IsNormalizedExceptionalCoordinate a) + (hb : (normalizedFiberAt other b).Nonempty) : + ∃ middle : NormalizedCoordinateAxis, ∃ c : R, + middle ≠ axis ∧ middle ≠ other ∧ + NormalizedFibersMeet (normalizedFiberAt axis a) (normalizedFiberAt middle c) ∧ + NormalizedFibersMeet (normalizedFiberAt other b) (normalizedFiberAt middle c) := by + let middle := normalizedBridgeAxis axis other + have hleft : middle ≠ axis := normalizedBridgeAxis_ne_left axis other + have hright : middle ≠ other := normalizedBridgeAxis_ne_right axis other + obtain ⟨c, hc⟩ := normalizedFiber_meets_some_fiber_on_distinctAxis hright.symm hb + exact ⟨middle, c, hleft, hright, + normalizedExceptionalFiber_meets_distinctAxis i hi hleft.symm ha c, hc⟩ + +/-- For primes congruent to one modulo four, every parabolic incidence vertex has a common +neighbor with every nonempty incidence vertex, uniformly over all coordinate axes. -/ +theorem normalizedParabolicIncidenceBridge_mod_one + (p : ℕ) [Fact p.Prime] (hmod : p % 4 = 1) : + ∀ (axis other : NormalizedCoordinateAxis) {a b : ZMod p}, + IsNormalizedParabolicCoordinate a → + (normalizedFiberAt other b).Nonempty → + ∃ middle : NormalizedCoordinateAxis, ∃ c : ZMod p, + middle ≠ axis ∧ middle ≠ other ∧ + NormalizedFibersMeet (normalizedFiberAt axis a) (normalizedFiberAt middle c) ∧ + NormalizedFibersMeet (normalizedFiberAt other b) (normalizedFiberAt middle c) := by + obtain ⟨i, hi, _, _⟩ := exists_parabolic_line_decomposition_of_mod_four_eq_one p hmod + intro axis other a b ha hb + exact normalizedParabolicFiber_has_commonNeighbor i hi axis other ha hb + +/-- At primes congruent to one modulo four, the zero and parabolic fibers omitted by the +admissible incidence argument all have distance at most two from every nonempty fiber. -/ +theorem normalizedExceptionalIncidenceBridge_mod_one + (p : ℕ) [Fact p.Prime] (hmod : p % 4 = 1) : + ∀ (axis other : NormalizedCoordinateAxis) {a b : ZMod p}, + IsNormalizedExceptionalCoordinate a → + (normalizedFiberAt other b).Nonempty → + ∃ middle : NormalizedCoordinateAxis, ∃ c : ZMod p, + middle ≠ axis ∧ middle ≠ other ∧ + NormalizedFibersMeet (normalizedFiberAt axis a) (normalizedFiberAt middle c) ∧ + NormalizedFibersMeet (normalizedFiberAt other b) (normalizedFiberAt middle c) := by + obtain ⟨i, hi, _, _⟩ := exists_parabolic_line_decomposition_of_mod_four_eq_one p hmod + intro axis other a b ha hb + exact normalizedExceptionalFiber_has_commonNeighbor i hi axis other ha hb + +/-- A full-surface fiber bridge. This does not yet remove the normalized origin from +intersection witnesses, so it is intentionally not called the punctured incidence graph. -/ +def NormalizedFullSurfaceFiberBridgeAt (p : ℕ) (hp : p.Prime) : Prop := + letI : Fact p.Prime := ⟨hp⟩ + ∀ (axis other : NormalizedCoordinateAxis) (u v : ZMod p), + (normalizedFiberAt axis u).Nonempty → + (normalizedFiberAt other v).Nonempty → + ∃ middle : NormalizedCoordinateAxis, ∃ w : ZMod p, + middle ≠ axis ∧ middle ≠ other ∧ + NormalizedFibersMeet (normalizedFiberAt axis u) (normalizedFiberAt middle w) ∧ + NormalizedFibersMeet (normalizedFiberAt other v) (normalizedFiberAt middle w) + +/-- The complete incidence bridge for sufficiently large primes congruent to one modulo four. +The proof combines the transported admissible bridge with the separately proved zero and +parabolic line geometry. -/ +theorem normalizedFullSurfaceFiberBridge_mod_one + (hHasse : ZModLegendrePointCardHasseBound) : + ∃ p0 : ℕ, ∀ (p : ℕ) (hp : p.Prime), p0 ≤ p → p % 4 = 1 → + NormalizedFullSurfaceFiberBridgeAt p hp := by + obtain ⟨p0, hadmissible⟩ := normalizedAdmissibleGraphBridge_mod_one hHasse + refine ⟨p0, ?_⟩ + intro p hp hpLarge hmod + let : Fact p.Prime := ⟨hp⟩ + obtain ⟨i, hi, _, _⟩ := exists_parabolic_line_decomposition_of_mod_four_eq_one p hmod + have hgood := hadmissible p hp hpLarge hmod + intro axis other u v huNonempty hvNonempty + by_cases hu : IsNormalizedExceptionalCoordinate u + · exact normalizedExceptionalFiber_has_commonNeighbor i hi axis other hu hvNonempty + · by_cases hv : IsNormalizedExceptionalCoordinate v + · obtain ⟨middle, w, hmiddleOther, hmiddleAxis, hvMeet, huMeet⟩ := + normalizedExceptionalFiber_has_commonNeighbor i hi other axis hv huNonempty + exact ⟨middle, w, hmiddleAxis, hmiddleOther, huMeet, hvMeet⟩ + · exact hgood axis other u v hu hv + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Incidence/PointCount.lean b/LeanPool/MarkoffModP/BGS/Markoff/Incidence/PointCount.lean new file mode 100644 index 0000000000..a3d85901ec --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Incidence/PointCount.lean @@ -0,0 +1,368 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Core.Basic +public import LeanPool.MarkoffModP.BGS.FiniteField.EllipticCharacterSum +public import LeanPool.MarkoffModP.BGS.FiniteField.QuadraticCharacter + +/-! +# Point-count algebra for the incidence auxiliary curve + +This file reduces the off-diagonal auxiliary-curve count to the exact Hasse character sum exposed +in `BGS.FiniteField.EllipticCharacterSum`. +-/ + +@[expose] public section + +namespace BGS.Markoff + +open Finset + +variable {F : Type*} [Field F] [Fintype F] [DecidableEq F] + +/-- The number of square roots of `t`, regarded as an integer. -/ +def squareRootCount (t : F) : ℤ := + ((univ.filter fun x : F ↦ x ^ 2 = t).card : ℕ) + +theorem squareRootCount_eq_quadraticChar_add_one + (hF : ringChar F ≠ 2) (t : F) : + squareRootCount t = quadraticChar F t + 1 := by + simpa [squareRootCount, Set.toFinset_ofPred] using quadraticChar_card_sqrts hF t + +/-- The generic quadratic branch value occurring in each auxiliary equation. -/ +def branchValue (A C y : F) : F := + A * y ^ 2 - C + +/-- The weighted number of affine triples `(y, lambda, mu)` on two quadratic branches. -/ +def auxiliaryTripleCount (A B C D : F) : ℤ := + ∑ y : F, squareRootCount (branchValue A C y) * squareRootCount (branchValue B D y) + +/-- Exact character expansion of the number of affine auxiliary triples. -/ +theorem auxiliaryTripleCount_eq + (hF : ringChar F ≠ 2) {A B C D : F} + (hA : A ≠ 0) (hB : B ≠ 0) (hC : C ≠ 0) (hD : D ≠ 0) : + auxiliaryTripleCount A B C D = + (Fintype.card F : ℤ) - quadraticChar F A - quadraticChar F B + + ∑ y : F, quadraticChar F (branchValue A C y * branchValue B D y) := by + let chi := quadraticChar F + calc + auxiliaryTripleCount A B C D = + ∑ y : F, (chi (branchValue A C y) + 1) * (chi (branchValue B D y) + 1) := by + apply sum_congr rfl + intro y _ + rw [squareRootCount_eq_quadraticChar_add_one hF, + squareRootCount_eq_quadraticChar_add_one hF] + _ = ∑ y : F, + (chi (branchValue A C y * branchValue B D y) + + chi (branchValue A C y) + chi (branchValue B D y) + 1) := by + apply sum_congr rfl + intro y _ + rw [map_mul] + ring + _ = (∑ y : F, chi (branchValue A C y * branchValue B D y)) + + (∑ y : F, chi (branchValue A C y)) + + (∑ y : F, chi (branchValue B D y)) + ∑ _y : F, 1 := by + simp_rw [sum_add_distrib] + _ = (∑ y : F, chi (branchValue A C y * branchValue B D y)) - + chi A - chi B + (Fintype.card F : ℤ) := by + rw [show (∑ y : F, chi (branchValue A C y)) = -chi A by + simpa [chi, branchValue] using + BGS.FiniteField.sum_quadraticChar_mul_sq_sub hF hA hC] + rw [show (∑ y : F, chi (branchValue B D y)) = -chi B by + simpa [chi, branchValue] using + BGS.FiniteField.sum_quadraticChar_mul_sq_sub hF hB hD] + simp + ring + _ = (Fintype.card F : ℤ) - chi A - chi B + + ∑ y : F, chi (branchValue A C y * branchValue B D y) := by ring + +/-- A quadratic with two distinct roots has character sum minus the character of its leading +coefficient. -/ +theorem sum_quadraticChar_two_linear_factors + (hF : ringChar F ≠ 2) {A B C D : F} + (hA : A ≠ 0) (hB : B ≠ 0) (hcross : A * D ≠ B * C) : + ∑ x : F, quadraticChar F ((A * x - C) * (B * x - D)) = + -quadraticChar F (A * B) := by + let L : F := A * B + let center : F := (A * D + B * C) / (2 * L) + let constantTerm : F := (A * D - B * C) ^ 2 / (4 * L) + have h2 : (2 : F) ≠ 0 := Ring.two_ne_zero hF + have h4 : (4 : F) ≠ 0 := by + rw [show (4 : F) = 2 ^ 2 by norm_num] + exact pow_ne_zero 2 h2 + have hL : L ≠ 0 := mul_ne_zero hA hB + have hconstant : constantTerm ≠ 0 := by + exact div_ne_zero (pow_ne_zero 2 (sub_ne_zero.mpr hcross)) (mul_ne_zero h4 hL) + let e : F ≃ F := Equiv.addRight center + calc + ∑ x : F, quadraticChar F ((A * x - C) * (B * x - D)) = + ∑ x : F, quadraticChar F ((A * (e x) - C) * (B * (e x) - D)) := by + exact (e.sum_comp fun x ↦ quadraticChar F ((A * x - C) * (B * x - D))).symm + _ = ∑ x : F, quadraticChar F (L * x ^ 2 - constantTerm) := by + apply sum_congr rfl + intro x _ + congr 1 + dsimp [e, center, constantTerm, L] + field_simp [h2, hA, hB] + ring + _ = -quadraticChar F L := + BGS.FiniteField.sum_quadraticChar_mul_sq_sub hF hL hconstant + _ = -quadraticChar F (A * B) := rfl + +/-- Replacing the square variable in the quartic trace sum by a free variable produces the cubic +trace sum, including the correction at infinity. -/ +theorem quarticTrace_add_leadingChar_eq_cubicTrace + (hF : ringChar F ≠ 2) {A B C D : F} + (hA : A ≠ 0) (hB : B ≠ 0) (hcross : A * D ≠ B * C) : + (∑ y : F, quadraticChar F (branchValue A C y * branchValue B D y)) + + quadraticChar F (A * B) = + ∑ x : F, quadraticChar F (x * (A * x - C) * (B * x - D)) := by + let chi := quadraticChar F + have hsquareMap := + BGS.FiniteField.sum_comp_sq_eq_sum_quadraticChar_add_one hF + (fun x : F ↦ chi ((A * x - C) * (B * x - D))) + have hquadratic := sum_quadraticChar_two_linear_factors hF hA hB hcross + calc + (∑ y : F, chi (branchValue A C y * branchValue B D y)) + chi (A * B) = + (∑ y : F, chi ((A * y ^ 2 - C) * (B * y ^ 2 - D))) + chi (A * B) := by + simp only [branchValue] + _ = (∑ x : F, (chi x + 1) * chi ((A * x - C) * (B * x - D))) + + chi (A * B) := by rw [hsquareMap] + _ = (∑ x : F, + (chi (x * (A * x - C) * (B * x - D)) + + chi ((A * x - C) * (B * x - D)))) + chi (A * B) := by + congr 1 + apply sum_congr rfl + intro x _ + rw [add_mul, one_mul, ← map_mul, mul_assoc] + _ = (∑ x : F, chi (x * (A * x - C) * (B * x - D))) + + (∑ x : F, chi ((A * x - C) * (B * x - D))) + chi (A * B) := by + rw [sum_add_distrib] + _ = ∑ x : F, chi (x * (A * x - C) * (B * x - D)) := by + rw [hquadratic] + ring + +/-- Scaling `X = A * B * x` turns the cubic trace polynomial into the monic cubic with roots +`0`, `B * C`, and `A * D`. -/ +theorem cubicTrace_eq_monicCubicTrace + {A B C D : F} (hA : A ≠ 0) (hB : B ≠ 0) : + (∑ x : F, quadraticChar F (x * (A * x - C) * (B * x - D))) = + ∑ X : F, quadraticChar F (X * (X - B * C) * (X - A * D)) := by + let chi := quadraticChar F + have hAB : A * B ≠ 0 := mul_ne_zero hA hB + let e : F ≃ F := Equiv.mulLeft₀ (A * B) hAB + calc + (∑ x : F, chi (x * (A * x - C) * (B * x - D))) = + ∑ x : F, chi ((e x) * ((e x) - B * C) * ((e x) - A * D)) := by + apply sum_congr rfl + intro x _ + have hpoly : + (e x) * ((e x) - B * C) * ((e x) - A * D) = + (A * B) ^ 2 * (x * (A * x - C) * (B * x - D)) := by + change + (A * B * x) * (A * B * x - B * C) * (A * B * x - A * D) = + (A * B) ^ 2 * (x * (A * x - C) * (B * x - D)) + ring + rw [hpoly] + conv_rhs => rw [map_mul, quadraticChar_sq_one' hAB, one_mul] + _ = ∑ X : F, chi (X * (X - B * C) * (X - A * D)) := + e.sum_comp (fun X ↦ chi (X * (X - B * C) * (X - A * D))) + +/-- The quartic trace, including its leading-coefficient correction, is exactly the character +trace of the monic cubic model. -/ +theorem quarticTrace_add_leadingChar_eq_monicCubicTrace + (hF : ringChar F ≠ 2) {A B C D : F} + (hA : A ≠ 0) (hB : B ≠ 0) (hcross : A * D ≠ B * C) : + (∑ y : F, quadraticChar F (branchValue A C y * branchValue B D y)) + + quadraticChar F (A * B) = + ∑ X : F, quadraticChar F (X * (X - B * C) * (X - A * D)) := by + rw [quarticTrace_add_leadingChar_eq_cubicTrace hF hA hB hcross, + cubicTrace_eq_monicCubicTrace hA hB] + +/-- The monic Weierstrass model obtained from the cubic trace sum. Its equation is +`Y^2 = X * (X - u) * (X - v)`. -/ +def auxiliaryEllipticCurve (u v : F) : WeierstrassCurve F := + ⟨0, -(u + v), 0, u * v, 0⟩ + +omit [Fintype F] [DecidableEq F] in +theorem auxiliaryEllipticCurve_equation_iff (u v x y : F) : + (auxiliaryEllipticCurve u v).toAffine.Equation x y ↔ + y ^ 2 = x * (x - u) * (x - v) := by + rw [WeierstrassCurve.Affine.equation_iff] + simp only [auxiliaryEllipticCurve, zero_mul, add_zero] + ring_nf + +omit [Fintype F] [DecidableEq F] in +theorem auxiliaryEllipticCurve_delta (u v : F) : + (auxiliaryEllipticCurve u v).Δ = 16 * u ^ 2 * v ^ 2 * (u - v) ^ 2 := by + simp only [auxiliaryEllipticCurve, WeierstrassCurve.Δ, WeierstrassCurve.b₂, + WeierstrassCurve.b₄, WeierstrassCurve.b₆, WeierstrassCurve.b₈] + ring + +omit [Fintype F] [DecidableEq F] in +theorem auxiliaryEllipticCurve_delta_ne_zero + (hF : ringChar F ≠ 2) {u v : F} (hu : u ≠ 0) (hv : v ≠ 0) (huv : u ≠ v) : + (auxiliaryEllipticCurve u v).Δ ≠ 0 := by + have h2 : (2 : F) ≠ 0 := Ring.two_ne_zero hF + have h16 : (16 : F) ≠ 0 := by + rw [show (16 : F) = 2 ^ 4 by norm_num] + exact pow_ne_zero 4 h2 + rw [auxiliaryEllipticCurve_delta] + exact mul_ne_zero (mul_ne_zero (mul_ne_zero h16 (pow_ne_zero 2 hu)) (pow_ne_zero 2 hv)) + (pow_ne_zero 2 (sub_ne_zero.mpr huv)) + +omit [Fintype F] [DecidableEq F] in +theorem auxiliaryEllipticCurve_isElliptic + (hF : ringChar F ≠ 2) {u v : F} (hu : u ≠ 0) (hv : v ≠ 0) (huv : u ≠ v) : + (auxiliaryEllipticCurve u v).IsElliptic := + ⟨isUnit_iff_ne_zero.mpr (auxiliaryEllipticCurve_delta_ne_zero hF hu hv huv)⟩ + +omit [Fintype F] [DecidableEq F] in +/-- The cubic model associated to two distinct quadratic branches is elliptic. -/ +theorem auxiliaryEllipticCurve_branches_delta_ne_zero + (hF : ringChar F ≠ 2) {A B C D : F} + (hA : A ≠ 0) (hB : B ≠ 0) (hC : C ≠ 0) (hD : D ≠ 0) + (hcross : A * D ≠ B * C) : + (auxiliaryEllipticCurve (B * C) (A * D)).Δ ≠ 0 := + auxiliaryEllipticCurve_delta_ne_zero hF (mul_ne_zero hB hC) (mul_ne_zero hA hD) + (Ne.symm hcross) + +omit [Fintype F] [DecidableEq F] in +theorem auxiliaryEllipticCurve_branches_isElliptic + (hF : ringChar F ≠ 2) {A B C D : F} + (hA : A ≠ 0) (hB : B ≠ 0) (hC : C ≠ 0) (hD : D ≠ 0) + (hcross : A * D ≠ B * C) : + (auxiliaryEllipticCurve (B * C) (A * D)).IsElliptic := + auxiliaryEllipticCurve_isElliptic hF (mul_ne_zero hB hC) (mul_ne_zero hA hD) + (Ne.symm hcross) + +/-- The Weierstrass curve attached to the two Markoff auxiliary branches. -/ +def markoffAuxiliaryEllipticCurve (a b : F) : WeierstrassCurve F := + auxiliaryEllipticCurve + ((9 * b ^ 2 - 4) * (4 * a ^ 2)) + ((9 * a ^ 2 - 4) * (4 * b ^ 2)) + +omit [Fintype F] [DecidableEq F] in +/-- Admissibility and the off-diagonal condition make the Markoff cubic model elliptic. -/ +theorem markoffAuxiliaryEllipticCurve_delta_ne_zero + (hF : ringChar F ≠ 2) {a b : F} + (ha : a ≠ 0) (hb : b ≠ 0) + (hA : 9 * a ^ 2 - 4 ≠ 0) (hB : 9 * b ^ 2 - 4 ≠ 0) + (hab : a ^ 2 ≠ b ^ 2) : + (markoffAuxiliaryEllipticCurve a b).Δ ≠ 0 := by + have h2 : (2 : F) ≠ 0 := Ring.two_ne_zero hF + have h4 : (4 : F) ≠ 0 := by + rw [show (4 : F) = 2 ^ 2 by norm_num] + exact pow_ne_zero 2 h2 + have hC : (4 * a ^ 2 : F) ≠ 0 := mul_ne_zero h4 (pow_ne_zero 2 ha) + have hD : (4 * b ^ 2 : F) ≠ 0 := mul_ne_zero h4 (pow_ne_zero 2 hb) + have h16 : (16 : F) ≠ 0 := by + rw [show (16 : F) = 2 ^ 4 by norm_num] + exact pow_ne_zero 4 h2 + have hcross : + (9 * a ^ 2 - 4) * (4 * b ^ 2) ≠ (9 * b ^ 2 - 4) * (4 * a ^ 2) := by + intro h + have hzero : (16 : F) * (a ^ 2 - b ^ 2) = 0 := by + calc + (16 : F) * (a ^ 2 - b ^ 2) = + (9 * a ^ 2 - 4) * (4 * b ^ 2) - + (9 * b ^ 2 - 4) * (4 * a ^ 2) := by ring + _ = 0 := sub_eq_zero.mpr h + exact (mul_ne_zero h16 (sub_ne_zero.mpr hab)) hzero + simpa only [markoffAuxiliaryEllipticCurve] using + auxiliaryEllipticCurve_branches_delta_ne_zero hF hA hB hC hD hcross + +theorem squareRootCount_nonnegative (t : F) : 0 ≤ squareRootCount t := by + simp [squareRootCount] + +theorem squareRootCount_le_two (hF : ringChar F ≠ 2) (t : F) : + squareRootCount t ≤ 2 := by + rw [squareRootCount_eq_quadraticChar_add_one hF] + by_cases ht : t = 0 + · simp [ht] + · rcases quadraticChar_dichotomy ht with h | h <;> rw [h] <;> norm_num + +theorem squareRootCount_eq_zero_of_no_root {t : F} (h : ¬ ∃ x : F, x ^ 2 = t) : + squareRootCount t = 0 := by + change (((univ.filter fun x : F ↦ x ^ 2 = t).card : ℕ) : ℤ) = 0 + norm_cast + rw [card_eq_zero, filter_eq_empty_iff] + intro x _ hx + exact h ⟨x, hx⟩ + +/-- The exact Hasse input makes the total number of affine auxiliary triples exceed the twelve +triples that can lie above three forbidden first coordinates. -/ +theorem twelve_lt_auxiliaryTripleCount + (hHasse : BGS.FiniteField.LegendrePointCardHasseBound F) + (hF : ringChar F ≠ 2) (hcard : 26 ≤ Fintype.card F) + {A B C D : F} (hA : A ≠ 0) (hB : B ≠ 0) (hC : C ≠ 0) (hD : D ≠ 0) + (hcross : A * D ≠ B * C) : + 12 < auxiliaryTripleCount A B C D := by + have hu : B * C ≠ 0 := mul_ne_zero hB hC + have hv : A * D ≠ 0 := mul_ne_zero hA hD + have huv : B * C ≠ A * D := Ne.symm hcross + have htrace := BGS.FiniteField.fifteen_sub_card_lt_ellipticCubicCharacterSum + hHasse hF hcard hu hv huv + have hquartic := quarticTrace_add_leadingChar_eq_monicCubicTrace + hF hA hB hcross + have hcount := auxiliaryTripleCount_eq hF hA hB hC hD + have hchiA : quadraticChar F A ≤ 1 := by + rcases quadraticChar_dichotomy hA with h | h <;> omega + have hchiB : quadraticChar F B ≤ 1 := by + rcases quadraticChar_dichotomy hB with h | h <;> omega + have hchiAB : quadraticChar F (A * B) ≤ 1 := by + rcases quadraticChar_dichotomy (mul_ne_zero hA hB) with h | h <;> omega + dsimp [BGS.FiniteField.ellipticCubicCharacterSum] at htrace + omega + +/-- Hasse's bound for the explicit elliptic model yields an auxiliary point away from any three +forbidden first coordinates. -/ +theorem exists_auxiliary_triple_away_from_three + (hHasse : BGS.FiniteField.LegendrePointCardHasseBound F) + (hF : ringChar F ≠ 2) (hcard : 26 ≤ Fintype.card F) + {A B C D : F} (hA : A ≠ 0) (hB : B ≠ 0) (hC : C ≠ 0) (hD : D ≠ 0) + (hcross : A * D ≠ B * C) (bad : Finset F) (hbad : bad.card ≤ 3) : + ∃ y, y ∉ bad ∧ ∃ lambda mu, + lambda ^ 2 = branchValue A C y ∧ mu ^ 2 = branchValue B D y := by + classical + let term (y : F) : ℤ := + squareRootCount (branchValue A C y) * squareRootCount (branchValue B D y) + have htermNonnegative (y : F) : 0 ≤ term y := + mul_nonneg (squareRootCount_nonnegative _) (squareRootCount_nonnegative _) + have htermLeFour (y : F) : term y ≤ 4 := by + dsimp [term] + nlinarith [squareRootCount_nonnegative (branchValue A C y), + squareRootCount_nonnegative (branchValue B D y), + squareRootCount_le_two hF (branchValue A C y), + squareRootCount_le_two hF (branchValue B D y)] + by_contra hExists + have hzeroOutside (y : F) (hy : y ∉ bad) : term y = 0 := by + by_cases hfirst : ∃ lambda : F, lambda ^ 2 = branchValue A C y + · have hsecond : ¬ ∃ mu : F, mu ^ 2 = branchValue B D y := by + rintro ⟨mu, hmu⟩ + obtain ⟨lambda, hlambda⟩ := hfirst + exact hExists ⟨y, hy, lambda, mu, hlambda, hmu⟩ + simp [term, squareRootCount_eq_zero_of_no_root hsecond] + · simp [term, squareRootCount_eq_zero_of_no_root hfirst] + have hrestrict : ∑ y ∈ bad, term y = ∑ y : F, term y := by + apply sum_subset (subset_univ bad) + intro y _ hy + exact hzeroOutside y hy + have hupper : ∑ y : F, term y ≤ 12 := by + rw [← hrestrict] + calc + ∑ y ∈ bad, term y ≤ ∑ _y ∈ bad, (4 : ℤ) := + sum_le_sum fun y _ ↦ htermLeFour y + _ = (bad.card : ℤ) * 4 := by simp + _ ≤ 12 := by exact_mod_cast Nat.mul_le_mul_right 4 hbad + have hlower : 12 < ∑ y : F, term y := by + simpa [auxiliaryTripleCount, term] using + twelve_lt_auxiliaryTripleCount hHasse hF hcard hA hB hC hD hcross + omega + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame.lean b/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame.lean new file mode 100644 index 0000000000..cb4f7cfa38 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame.lean @@ -0,0 +1,26 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.WeightedTraceBound +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.CorvajaZannierEscape +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.CorvajaZannierFromGeneral +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.CorvajaZannierGeometry +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.CorvajaZannierSeparability +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.CorvajaZannierSourceBound +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.CorvajaZannierStep +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.CosetTraceEquation +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.Diagonalization +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.DivisorRange +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.MoveWiring +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.OrderEscape +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.ParabolicEscape +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.RightSubgroups +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.TraceCurveWeights +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.TraceEquation +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.UnionBound +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.WeightedTraceEquation diff --git a/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/CorvajaZannierEscape.lean b/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/CorvajaZannierEscape.lean new file mode 100644 index 0000000000..2ed6f72040 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/CorvajaZannierEscape.lean @@ -0,0 +1,73 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.Diagonalization +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.WeightedTraceBound +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.TraceCurveWeights + +/-! +# Feeding the geometric Corvaja--Zannier estimate into a Markoff move + +This module connects the weighted torsion-intersection bound to the already completed middle-game +order-escape chain. The actual weighted trace curve's admissibility is proved from its Markoff +coefficients. + +Given those premises, Lean returns a natural iterate of the Markoff rotation with strictly larger +neighboring rotation order. No independent weighted-finset estimate remains between the cited +curve theorem and the dynamical conclusion. +-/ + +@[expose] public section + +namespace BGS.Markoff + +/-- The uniform weighted-trace bound, after Lean verifies every concrete diagonalized Markoff +trace curve, produces an actual middle-game order-increasing iterate. -/ +theorem exists_iterate_with_larger_secondRotationOrder_of_weightedTraceBound + (p : ℕ) [Fact p.Prime] [Fintype (quadraticFiniteField p)] (hpTwo : p ≠ 2) + (delta : ℝ) (hdelta : delta ≤ (1 : ℝ) / 2) + (x : NormalizedPoint (ZMod p)) (hx : IsNormalizedMarkoff x) + (hnonzero : x.u1 ≠ 0) (hnonparabolic : x.u1 ^ 2 ≠ 4) + (hbelowEndgame : + (rotationOrder x.u1 : ℝ) < (p : ℝ) ^ ((1 : ℝ) / 2 + delta)) + (hcube : + (corvajaZannierCorollaryTwoSafeCoefficient * + ((p - 1).divisors.card + (p + 1).divisors.card)) ^ 3 < + rotationOrder x.u1) + (hlinear : + corvajaZannierCorollaryTwoSafeCoefficient * + ((p - 1).divisors.card + (p + 1).divisors.card) * + rotationOrder x.u1 < p) + (hBound : WeightedTraceTorsionIntersectionBound p (quadraticFiniteField p)) : + ∃ n : ℕ, + rotationOrder x.u1 < rotationOrder ((normalizedRotate1^[n]) x).u2 := by + apply exists_iterate_with_larger_secondRotationOrder_of_nonzero_nonparabolic + p hpTwo delta hdelta x hx hnonzero hnonparabolic hbelowEndgame hcube hlinear + intro w s hw hpoint _hnondegenerate d hd + let alpha : quadraticFiniteField p := s + let beta : quadraticFiniteField p := + splitFiberProduct w * ((s⁻¹ : (quadraticFiniteField p)ˣ) : quadraticFiniteField p) + let H₁ : Subgroup (quadraticFiniteField p)ˣ := Subgroup.zpowers w + let H₂ : Subgroup (quadraticFiniteField p)ˣ := middleGameRightSubgroup p d + have hadmissible : WeightedTraceCurveIsCorvajaZannierAdmissible alpha beta := by + simpa [alpha, beta] using + diagonalizedFiber_weightedTraceCurve_isCorvajaZannierAdmissible + p hpTwo x hnonzero w s hw hpoint + have hbound := + weightedTraceEquationSolutions_card_cast_le_of_weightedTraceBound + p (quadraticFiniteField p) hBound alpha beta H₁ H₂ hadmissible + have htrace : + algebraMap (ZMod p) (quadraticFiniteField p) x.u1 = splitTorusTrace w := + congrArg NormalizedPoint.u1 hpoint + have horder : orderOf w = rotationOrder x.u1 := by + rw [← rotationOrder_eq_orderOf_extensionEigenvalue x.u1 w hw htrace] + have hleftCard : Nat.card H₁ = rotationOrder x.u1 := by + rw [Nat.card_zpowers, horder] + simpa [alpha, beta, H₁, H₂, hleftCard] using hbound + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/CorvajaZannierFromGeneral.lean b/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/CorvajaZannierFromGeneral.lean new file mode 100644 index 0000000000..dc2748c1b1 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/CorvajaZannierFromGeneral.lean @@ -0,0 +1,137 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.External.GeneralCurveTheorems +public import LeanPool.MarkoffModP.BGS.Markoff.Endgame.WeilFromGeneralHasse +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.WeightedTraceBound +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.WeightedIrreducibility +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.WeightedNotSubtorus +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.GeneralCorvajaZannier + +/-! +# Applying general Corvaja--Zannier to the weighted trace curve +-/ + +@[expose] public section + +namespace BGS.Markoff + +noncomputable section + +variable {K : Type*} [Field K] + +theorem weightedTraceTorusClosurePolynomial_pderiv_first_ne_zero + (alpha beta : K) (hbeta : beta ≠ 0) : + MvPolynomial.pderiv 0 + (weightedTraceTorusClosurePolynomial alpha beta) ≠ 0 := by + rw [weightedTraceTorusClosurePolynomial, ite_eq_right hbeta] + intro hzero + have heval := congrArg + (MvPolynomial.eval ![(0 : K), (0 : K)]) hzero + simp [splitTraceCoverPolynomial] at heval + exact hbeta heval + +theorem weightedTraceTorusClosurePolynomial_pderiv_second_ne_zero + (alpha beta : K) (hbeta : beta ≠ 0) : + MvPolynomial.pderiv 1 + (weightedTraceTorusClosurePolynomial alpha beta) ≠ 0 := by + rw [weightedTraceTorusClosurePolynomial, ite_eq_right hbeta] + intro hzero + have heval := congrArg + (MvPolynomial.eval ![(0 : K), (0 : K)]) hzero + simp [splitTraceCoverPolynomial] at heval + +theorem weightedTraceCurveNotSubtorusTranslate_general + (alpha beta : K) (hbeta : beta ≠ 0) + (hnot : WeightedTraceCurveNotSubtorusTranslate alpha beta) : + BGS.External.TorusCurveNotSubtorusTranslate + (weightedTraceTorusClosurePolynomial alpha beta) := by + intro a b hab c + obtain ⟨x, y, hcurve, hcharacter⟩ := hnot a b hab c + refine ⟨x, y, ?_, hcharacter⟩ + rw [map_weightedTraceTorusClosurePolynomial_of_beta_ne_zero + (algebraMap K (AlgebraicClosure K)) alpha beta hbeta] + exact (eval_weightedTraceTorusClosurePolynomial_eq_zero_iff + (algebraMap K (AlgebraicClosure K) alpha) + (algebraMap K (AlgebraicClosure K) beta) x y).2 hcurve + +theorem weightedTraceTorusClosurePolynomial_hasBidegreeAtMost + (alpha beta : K) (hbeta : beta ≠ 0) : + BGS.External.HasBidegreeAtMost + (weightedTraceTorusClosurePolynomial alpha beta) 2 2 := by + rw [weightedTraceTorusClosurePolynomial, ite_eq_right hbeta] + simpa using splitTraceCoverPolynomial_hasBidegreeAtMost alpha beta 1 1 + +theorem weightedTraceCurve_isGeneralCorvajaZannierPlaneCurve + (alpha beta : K) (hadmissible : + WeightedTraceCurveIsCorvajaZannierAdmissible alpha beta) : + BGS.External.IsCorvajaZannierPlaneCurve + (weightedTraceTorusClosurePolynomial alpha beta) := by + refine ⟨hadmissible.2.2.2.1, + weightedTraceCurveNotSubtorusTranslate_general + alpha beta hadmissible.2.1 hadmissible.2.2.2.2, + weightedTraceTorusClosurePolynomial_pderiv_first_ne_zero + alpha beta hadmissible.2.1, + weightedTraceTorusClosurePolynomial_pderiv_second_ne_zero + alpha beta hadmissible.2.1⟩ + +section Finite + +variable [Fintype K] [DecidableEq K] + +theorem generalTorusTorsionIntersection_weightedTrace_eq + (alpha beta : K) (leftOrder rightOrder : ℕ) : + BGS.External.torusCurveTorsionIntersection K + (weightedTraceTorusClosurePolynomial alpha beta) rightOrder leftOrder = + weightedTraceCurveTorsionIntersection alpha beta leftOrder rightOrder := by + ext z + rw [BGS.External.mem_torusCurveTorsionIntersection_iff, + mem_weightedTraceCurveTorsionIntersection_iff, + eval_weightedTraceTorusClosurePolynomial_eq_zero_iff] + tauto + +end Finite + +/-- The weighted-trace estimate is a proved application of the one general +Corvaja--Zannier plane-curve theorem. -/ +theorem corvajaZannierWeightedTraceBound_of_generalTheorem + (hGeneral : BGS.External.GeneralCorvajaZannierPlaneCurveTheorem) + (p : ℕ) [Fact p.Prime] + (K : Type) [Field K] [Fintype K] [DecidableEq K] [CharP K p] : + WeightedTraceTorsionIntersectionBound p K := by + intro alpha beta leftOrder rightOrder hadmissible + hleftPositive hrightPositive hleftPrime hrightPrime + have hsource := hGeneral p K + (weightedTraceTorusClosurePolynomial alpha beta) + 2 2 rightOrder leftOrder (by norm_num) (by norm_num) + (weightedTraceTorusClosurePolynomial_hasBidegreeAtMost + alpha beta hadmissible.2.1) + (weightedTraceCurve_isGeneralCorvajaZannierPlaneCurve + alpha beta hadmissible) + hrightPositive hleftPositive hrightPrime hleftPrime + rw [generalTorusTorsionIntersection_weightedTrace_eq] at hsource + rw [show BGS.External.planeTorusEulerCharacteristicBound 2 2 = 8 by + norm_num [BGS.External.planeTorusEulerCharacteristicBound]] at hsource + exact hsource.trans <| by + simpa [corvajaZannierTraceUpperBound, + mul_comm, mul_left_comm, mul_assoc] using + (corvajaZannierCorollaryTwoNumericalBound_bidegree_two_euler_eight_le + p rightOrder leftOrder) + +/-- The weighted-trace Corvaja--Zannier estimate, obtained by instantiating +the unconditional general plane-curve theorem proved in this repository. -/ +theorem corvajaZannierWeightedTraceBound + (p : ℕ) [Fact p.Prime] + (K : Type) [Field K] [Fintype K] [DecidableEq K] [CharP K p] : + WeightedTraceTorsionIntersectionBound p K := + corvajaZannierWeightedTraceBound_of_generalTheorem + BGS.CorvajaZannier.generalCorvajaZannierPlaneCurveTheorem p K + +end + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/CorvajaZannierGeometry.lean b/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/CorvajaZannierGeometry.lean new file mode 100644 index 0000000000..9912790cb0 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/CorvajaZannierGeometry.lean @@ -0,0 +1,196 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.WeightedTraceEquation +public import Mathlib.FieldTheory.IsAlgClosed.Basic + +/-! +# The geometric Corvaja--Zannier interface for the middle game + +Corvaja--Zannier, JEMS 15 (2013), Corollary 2, bounds torsion points on an +absolutely irreducible curve in a two-dimensional torus which is not a translate of a +subtorus. The actual Markoff middle-game finset consists of solutions of + +`alpha * h + beta * h⁻¹ = k + k⁻¹`, with `h ∈ H₁` and `k ∈ H₂`. + +This module embeds that finset into the exact geometric torsion intersection of the +weighted trace curve. It keeps all hypotheses of the cited result visible. In particular, +`alpha * beta ≠ 1` is not silently identified with absolute irreducibility or with the +non-subtorus condition. + +The constant `20` printed in the Markoff paper is not the direct specialization of +Corvaja--Zannier Corollary 2. For the `(2,2)` trace curve, the `12 d₁ d₂ / p` term alone +gives `48 m₁ m₂ / p`. Accordingly the source-backed envelope in this module has constant +`48`; obtaining `20` requires a separate argument. +-/ + +@[expose] public section + +namespace BGS.Markoff + +section GeometricCurve + +variable {K : Type*} [Field K] + +/-- The affine closure polynomial of the weighted trace curve after removing the boundary +monomial which appears when `beta = 0`. Variable `0` is the right trace parameter `k` and +variable `1` is the left parameter `h`. + +Removing this monomial is essential: Corvaja--Zannier concerns the curve in the torus, not +the extra coordinate-axis component introduced by clearing denominators. -/ +noncomputable def weightedTraceTorusClosurePolynomial (alpha beta : K) : + MvPolynomial (Fin 2) K := by + classical + exact if beta = 0 then + MvPolynomial.C alpha * MvPolynomial.X 0 * MvPolynomial.X 1 - + MvPolynomial.X 0 ^ 2 - 1 + else + splitTraceCoverPolynomial alpha beta 1 1 + +/-- On nonzero coordinates, the reduced affine polynomial cuts out exactly the weighted +trace equation. -/ +theorem eval_weightedTraceTorusClosurePolynomial_eq_zero_iff + (alpha beta : K) (k h : Kˣ) : + MvPolynomial.eval ![(k : K), (h : K)] + (weightedTraceTorusClosurePolynomial alpha beta) = 0 ↔ + weightedSplitTorusTrace alpha beta h = splitTorusTrace k := by + by_cases hbeta : beta = 0 + · subst beta + simp only [weightedTraceTorusClosurePolynomial, ite_eq_left, map_sub, map_mul, + MvPolynomial.eval_C, MvPolynomial.eval_X, Matrix.cons_val_zero, + Matrix.cons_val_one, map_pow, map_one, weightedSplitTorusTrace, + splitTorusTrace, zero_mul, add_zero, Units.val_inv_eq_inv_val] + have hk : (k : K) ≠ 0 := Units.ne_zero k + field_simp [hk] + constructor <;> intro heq <;> linear_combination heq + · rw [weightedTraceTorusClosurePolynomial, ite_eq_right hbeta] + simpa [SplitTraceCurveEquation] using + eval_splitTraceCoverPolynomial_eq_zero_iff alpha beta 1 1 k h + +/-- Absolute irreducibility of the actual torus closure, expressed as irreducibility after +base change to an algebraic closure. This is a proposition, not a typeclass. -/ +def WeightedTraceCurveAbsolutelyIrreducible (alpha beta : K) : Prop := + Irreducible + (MvPolynomial.map (algebraMap K (AlgebraicClosure K)) + (weightedTraceTorusClosurePolynomial alpha beta)) + +/-- Exact geometric non-specialness: over an algebraic closure, no nontrivial character is +constant on the whole weighted trace curve. For an irreducible curve in `G_m^2`, this is +equivalent to not being a translate of a one-dimensional subtorus. -/ +def WeightedTraceCurveNotSubtorusTranslate (alpha beta : K) : Prop := + ∀ (a b : ℤ), (a ≠ 0 ∨ b ≠ 0) → + ∀ c : (AlgebraicClosure K)ˣ, + ∃ k h : (AlgebraicClosure K)ˣ, + weightedSplitTorusTrace + (algebraMap K (AlgebraicClosure K) alpha) + (algebraMap K (AlgebraicClosure K) beta) h = + splitTorusTrace k ∧ + k ^ a * h ^ b ≠ c + +/-- The concrete curve hypotheses needed by the weighted-trace specialization of +Corvaja--Zannier Corollary 2. Both weights are nonzero, the curve is nondegenerate and +absolutely irreducible, and it is not a translate of a subtorus. These conditions are +kept separate from the external cardinal estimate. -/ +def WeightedTraceCurveIsCorvajaZannierAdmissible (alpha beta : K) : Prop := + alpha ≠ 0 ∧ + beta ≠ 0 ∧ + alpha * beta ≠ 1 ∧ + WeightedTraceCurveAbsolutelyIrreducible alpha beta ∧ + WeightedTraceCurveNotSubtorusTranslate alpha beta + +end GeometricCurve + +section FiniteTorsionIntersection + +variable {E : Type*} [Field E] [Fintype E] + +/-- The geometric torsion intersection to which Corvaja--Zannier Corollary 2 applies. +Coordinates are ordered `(k, h)` to match `splitTraceCoverPolynomial`. -/ +noncomputable def weightedTraceCurveTorsionIntersection + (alpha beta : E) (leftOrder rightOrder : ℕ) : Finset (Eˣ × Eˣ) := by + classical + exact Finset.univ.filter fun z ↦ + weightedSplitTorusTrace alpha beta z.2 = splitTorusTrace z.1 ∧ + z.2 ^ leftOrder = 1 ∧ z.1 ^ rightOrder = 1 + +@[simp] +theorem mem_weightedTraceCurveTorsionIntersection_iff + (alpha beta : E) (leftOrder rightOrder : ℕ) (z : Eˣ × Eˣ) : + z ∈ weightedTraceCurveTorsionIntersection alpha beta leftOrder rightOrder ↔ + weightedSplitTorusTrace alpha beta z.2 = splitTorusTrace z.1 ∧ + z.2 ^ leftOrder = 1 ∧ z.1 ^ rightOrder = 1 := by + classical + simp [weightedTraceCurveTorsionIntersection] + +/-- The same intersection stated with the explicit affine closure polynomial. This is the +line-level bridge from the finite set to the algebraic curve consumed by Corollary 2. -/ +theorem mem_weightedTraceCurveTorsionIntersection_iff_polynomial + (alpha beta : E) (leftOrder rightOrder : ℕ) (z : Eˣ × Eˣ) : + z ∈ weightedTraceCurveTorsionIntersection alpha beta leftOrder rightOrder ↔ + MvPolynomial.eval ![(z.1 : E), (z.2 : E)] + (weightedTraceTorusClosurePolynomial alpha beta) = 0 ∧ + z.2 ^ leftOrder = 1 ∧ z.1 ^ rightOrder = 1 := by + rw [mem_weightedTraceCurveTorsionIntersection_iff, + eval_weightedTraceTorusClosurePolynomial_eq_zero_iff] + +/-- Swap a subgroup solution into the geometric coordinate order `(k, h)`. -/ +def weightedTraceSubgroupSolutionToCurvePoint + (H₁ H₂ : Subgroup Eˣ) : H₁ × H₂ → Eˣ × Eˣ := + fun z ↦ ((z.2 : Eˣ), (z.1 : Eˣ)) + +omit [Fintype E] in +theorem weightedTraceSubgroupSolutionToCurvePoint_injective + (H₁ H₂ : Subgroup Eˣ) : + Function.Injective (weightedTraceSubgroupSolutionToCurvePoint H₁ H₂) := by + intro x y hxy + apply Prod.ext + · apply Subtype.ext + exact congrArg Prod.snd hxy + · apply Subtype.ext + exact congrArg Prod.fst hxy + +/-- Every actual subgroup solution gives a point in the corresponding geometric torsion +intersection. The subgroup cardinalities become the two root-of-unity exponents by +Lagrange's theorem. -/ +theorem weightedTraceSubgroupSolutionToCurvePoint_mem_torsionIntersection + (alpha beta : E) (H₁ H₂ : Subgroup Eˣ) (z : H₁ × H₂) + (hz : z ∈ weightedTraceEquationSolutions alpha beta H₁ H₂) : + weightedTraceSubgroupSolutionToCurvePoint H₁ H₂ z ∈ + weightedTraceCurveTorsionIntersection alpha beta (Nat.card H₁) (Nat.card H₂) := by + let := Fintype.ofFinite H₁ + let := Fintype.ofFinite H₂ + rw [mem_weightedTraceCurveTorsionIntersection_iff] + refine ⟨mem_weightedTraceEquationSolutions_iff.mp hz, ?_, ?_⟩ + · have hpow : z.1 ^ Fintype.card H₁ = 1 := pow_card_eq_one + have hval := congrArg (fun u : H₁ ↦ (u : Eˣ)) hpow + change ((z.1 : Eˣ) ^ Fintype.card H₁) = 1 at hval + simpa only [weightedTraceSubgroupSolutionToCurvePoint, + Fintype.card_eq_nat_card] using hval + · have hpow : z.2 ^ Fintype.card H₂ = 1 := pow_card_eq_one + have hval := congrArg (fun u : H₂ ↦ (u : Eˣ)) hpow + change ((z.2 : Eˣ) ^ Fintype.card H₂) = 1 at hval + simpa only [weightedTraceSubgroupSolutionToCurvePoint, + Fintype.card_eq_nat_card] using hval + +/-- The actual weighted solution count is bounded by the exact geometric torsion +intersection count. This theorem contains no Corvaja--Zannier assumption. -/ +theorem weightedTraceEquationSolutions_card_le_curveTorsionIntersection + (alpha beta : E) (H₁ H₂ : Subgroup Eˣ) : + (weightedTraceEquationSolutions alpha beta H₁ H₂).card ≤ + (weightedTraceCurveTorsionIntersection alpha beta + (Nat.card H₁) (Nat.card H₂)).card := by + classical + exact Finset.card_le_card_of_injOn + (weightedTraceSubgroupSolutionToCurvePoint H₁ H₂) + (fun z hz ↦ weightedTraceSubgroupSolutionToCurvePoint_mem_torsionIntersection + alpha beta H₁ H₂ z hz) + (weightedTraceSubgroupSolutionToCurvePoint_injective H₁ H₂).injOn + +end FiniteTorsionIntersection + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/CorvajaZannierSeparability.lean b/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/CorvajaZannierSeparability.lean new file mode 100644 index 0000000000..953f1722a9 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/CorvajaZannierSeparability.lean @@ -0,0 +1,130 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.CorvajaZannierGeometry +public import Mathlib.FieldTheory.Separable +public import Mathlib.RingTheory.Derivation.Basic + +/-! +# Prime-to-characteristic torsion exponents for Corvaja--Zannier + +Corvaja--Zannier, Theorem 2, assumes that the two rational functions have nonzero +differentials. In Corollary 2 those functions are coordinate powers whose exponents are +the orders of the two root-of-unity groups. The source suppresses the resulting +prime-to-characteristic check. + +For the actual Markoff application, both exponents are cardinalities of subgroups of the +multiplicative group of a finite field. This file proves that they are prime to the +characteristic, that the associated root-of-unity polynomials are separable, and that +raising a nonzero coordinate with nonzero differential to either exponent preserves a +nonzero differential. Thus inseparability is not part of the remaining +Corvaja--Zannier wall. +-/ + +@[expose] public section + +namespace BGS.Markoff + +open Polynomial + +section FiniteFieldSubgroupOrders + +variable {E : Type*} [Field E] [Fintype E] + +/-- The order of a multiplicative subgroup of a finite field is prime to the field +characteristic. This is the hidden separability check in the passage from +Corvaja--Zannier Theorem 2 to Corollary 2. -/ +theorem characteristic_not_dvd_multiplicativeSubgroup_natCard + (p : ℕ) [Fact p.Prime] [CharP E p] (H : Subgroup Eˣ) : + ¬ p ∣ Nat.card H := by + have hHdiv : Nat.card H ∣ Nat.card Eˣ := H.card_subgroup_dvd_card + intro hpH + have hpUnits : p ∣ Nat.card Eˣ := hpH.trans hHdiv + rcases FiniteField.card E p with ⟨n, -, hcard⟩ + have hpE : p ∣ Nat.card E := by + rw [← Fintype.card_eq_nat_card, hcard] + exact dvd_pow_self p n.ne_zero + have hdiff : Nat.card E - Nat.card Eˣ = 1 := by + rw [Nat.card_eq_card_units_add_one E] + omega + have hpOne : p ∣ 1 := by + rw [← hdiff] + exact Nat.dvd_sub hpE hpUnits + exact (Fact.out : p.Prime).not_dvd_one hpOne + +/-- Both exponents occurring in the exact weighted torsion intersection are prime to the +characteristic. -/ +theorem weightedTraceCurveTorsionIntersection_orders_primeToCharacteristic + (p : ℕ) [Fact p.Prime] [CharP E p] (H₁ H₂ : Subgroup Eˣ) : + ¬ p ∣ Nat.card H₁ ∧ ¬ p ∣ Nat.card H₂ := + ⟨characteristic_not_dvd_multiplicativeSubgroup_natCard p H₁, + characteristic_not_dvd_multiplicativeSubgroup_natCard p H₂⟩ + +/-- The root-of-unity polynomial attached to an actual finite-field subgroup has no +inseparable multiplicity. -/ +theorem multiplicativeSubgroup_torsionPolynomial_separable + (p : ℕ) [Fact p.Prime] [CharP E p] (H : Subgroup Eˣ) : + (Polynomial.X ^ Nat.card H - 1 : E[X]).Separable := by + simpa only [Polynomial.C_1] using + Polynomial.separable_X_pow_sub_C' p (Nat.card H) (1 : E) + (characteristic_not_dvd_multiplicativeSubgroup_natCard p H) one_ne_zero + +/-- The two torsion equations defining the exact geometric intersection are reduced. -/ +theorem weightedTraceCurveTorsionIntersection_torsionPolynomials_separable + (p : ℕ) [Fact p.Prime] [CharP E p] (H₁ H₂ : Subgroup Eˣ) : + (Polynomial.X ^ Nat.card H₁ - 1 : E[X]).Separable ∧ + (Polynomial.X ^ Nat.card H₂ - 1 : E[X]).Separable := + ⟨multiplicativeSubgroup_torsionPolynomial_separable p H₁, + multiplicativeSubgroup_torsionPolynomial_separable p H₂⟩ + +end FiniteFieldSubgroupOrders + +section NonzeroDifferentials + +variable {k L M : Type*} [CommRing k] [Field L] [AddCommGroup M] [Module L M] + [Algebra k L] [Module k M] + +/-- A prime-to-characteristic power of a nonzero function with nonzero differential +again has nonzero differential. This is the exact derivation calculation used when +Corvaja--Zannier Theorem 2 is specialized to root-of-unity exponents. -/ +theorem derivation_pow_ne_zero + (D : Derivation k L M) (x : L) (n : ℕ) + (hn : (n : L) ≠ 0) (hx : x ≠ 0) (hDx : D x ≠ 0) : + D (x ^ n) ≠ 0 := by + rw [D.leibniz_pow] + rw [← Nat.cast_smul_eq_nsmul L, smul_smul] + exact smul_ne_zero (mul_ne_zero hn (pow_ne_zero _ hx)) hDx + +/-- Actual finite-field subgroup orders satisfy the nonzero-differential condition after +transport to any function field of the same characteristic. -/ +theorem multiplicativeSubgroup_order_pow_has_nonzeroDifferential + {E : Type*} [Field E] [Fintype E] + (p : ℕ) [Fact p.Prime] [CharP E p] [CharP L p] + (H : Subgroup Eˣ) (D : Derivation k L M) (x : L) + (hx : x ≠ 0) (hDx : D x ≠ 0) : + D (x ^ Nat.card H) ≠ 0 := by + apply derivation_pow_ne_zero D x (Nat.card H) + · rw [ne_eq, CharP.cast_eq_zero_iff L p] + exact characteristic_not_dvd_multiplicativeSubgroup_natCard p H + · exact hx + · exact hDx + +/-- The two coordinate powers in Corvaja--Zannier Corollary 2 retain nonzero +differentials for the exact pair of subgroup orders used in the Markoff middle game. -/ +theorem weightedTraceCurveTorsionIntersection_coordinatePowers_haveNonzeroDifferentials + {E : Type*} [Field E] [Fintype E] + (p : ℕ) [Fact p.Prime] [CharP E p] [CharP L p] + (H₁ H₂ : Subgroup Eˣ) (D : Derivation k L M) (x y : L) + (hx : x ≠ 0) (hy : y ≠ 0) (hDx : D x ≠ 0) (hDy : D y ≠ 0) : + D (x ^ Nat.card H₁) ≠ 0 ∧ D (y ^ Nat.card H₂) ≠ 0 := + ⟨multiplicativeSubgroup_order_pow_has_nonzeroDifferential p H₁ D x hx hDx, + multiplicativeSubgroup_order_pow_has_nonzeroDifferential p H₂ D y hy hDy⟩ + +end NonzeroDifferentials + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/CorvajaZannierSourceBound.lean b/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/CorvajaZannierSourceBound.lean new file mode 100644 index 0000000000..4ecd54308d --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/CorvajaZannierSourceBound.lean @@ -0,0 +1,120 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.UnionBound + +/-! +# The source-faithful Corvaja--Zannier numerical specialization + +Corvaja--Zannier, Corollary 2, gives a torsion-intersection bound for a curve of +bidegree `(d₁, d₂)` and Euler characteristic `χ`. This file records its printed +right-hand side and proves that the specialization `(d₁, d₂, χ) = (2, 2, 4)` is +dominated by the coefficient-`48` envelope used by the Markoff middle game. + +This is only the numerical specialization. It does not postulate or prove the geometric +torsion-intersection estimate. +-/ + +@[expose] public section + +namespace BGS.Markoff + +noncomputable section + +/-- The numerical right-hand side printed in Corvaja--Zannier, Corollary 2. -/ +def corvajaZannierCorollaryTwoNumericalBound + (p leftOrder rightOrder firstDegree secondDegree : ℕ) (eulerCharacteristic : ℝ) : ℝ := + max + (3 * (2 * ((leftOrder * rightOrder * firstDegree * secondDegree : ℕ) : ℝ) * + eulerCharacteristic) ^ ((1 : ℝ) / 3)) + (12 * ((leftOrder * rightOrder * firstDegree * secondDegree : ℕ) : ℝ) / p) + +private lemma thirtyTwo_rpow_one_third_le_sixteen : + (32 : ℝ) ^ ((1 : ℝ) / 3) ≤ 16 := by + have hpow : (4096 : ℝ) ^ ((1 : ℝ) / 3) = 16 := by + rw [show (4096 : ℝ) = 16 ^ (3 : ℕ) by norm_num] + convert Real.pow_rpow_inv_natCast (by norm_num : (0 : ℝ) ≤ 16) + (by norm_num : (3 : ℕ) ≠ 0) using 1 + all_goals norm_num + rw [← hpow] + exact Real.rpow_le_rpow (by norm_num) (by norm_num) (by norm_num) + +private lemma sixtyFour_rpow_one_third_eq_four : + (64 : ℝ) ^ ((1 : ℝ) / 3) = 4 := by + rw [show (64 : ℝ) = 4 ^ (3 : ℕ) by norm_num] + convert Real.pow_rpow_inv_natCast (by norm_num : (0 : ℝ) ≤ 4) + (by norm_num : (3 : ℕ) ≠ 0) using 1 + all_goals norm_num + +/-- The exact `(2,2)` and Euler-characteristic-four specialization used by the +Markoff middle game is dominated by the source-faithful coefficient `48`. -/ +theorem corvajaZannierCorollaryTwoNumericalBound_bidegree_two_euler_four_le + (p leftOrder rightOrder : ℕ) : + corvajaZannierCorollaryTwoNumericalBound p leftOrder rightOrder 2 2 4 ≤ + corvajaZannierTraceUpperBound p leftOrder rightOrder := by + let x : ℝ := (leftOrder * rightOrder : ℕ) + have hx : 0 ≤ x := by positivity + have hroot : 0 ≤ x ^ ((1 : ℝ) / 3) := Real.rpow_nonneg hx _ + have hfirst : 3 * (32 * x) ^ ((1 : ℝ) / 3) ≤ 48 * x ^ ((1 : ℝ) / 3) := by + rw [Real.mul_rpow (by norm_num : (0 : ℝ) ≤ 32) hx] + have hproduct : + 0 ≤ (16 - (32 : ℝ) ^ ((1 : ℝ) / 3)) * x ^ ((1 : ℝ) / 3) := + mul_nonneg (sub_nonneg.mpr thirtyTwo_rpow_one_third_le_sixteen) hroot + nlinarith + unfold corvajaZannierCorollaryTwoNumericalBound corvajaZannierTraceUpperBound + simp only [corvajaZannierCorollaryTwoSafeCoefficient] + have hdegrees : + ((leftOrder * rightOrder * 2 * 2 : ℕ) : ℝ) = 4 * x := by + simp [x] + ring + rw [hdegrees] + ring_nf + apply max_le + · have h := hfirst.trans + (mul_le_mul_of_nonneg_left + (le_max_left (x ^ ((1 : ℝ) / 3)) (x / p)) (by norm_num)) + simpa [x, div_eq_mul_inv, mul_comm, mul_left_comm, mul_assoc] using h + · have h := mul_le_mul_of_nonneg_left + (le_max_right (x ^ ((1 : ℝ) / 3)) (x / p)) (by norm_num : (0 : ℝ) ≤ 48) + simpa [x, div_eq_mul_inv, mul_comm, mul_left_comm, mul_assoc] using h + +/-- The degree-only Euler-characteristic bound `χ ≤ 2 d₁ d₂` gives `χ = 8` +at bidegree `(2,2)`. This slightly weaker but genuinely general specialization +is still dominated by the coefficient-`48` envelope used downstream. -/ +theorem corvajaZannierCorollaryTwoNumericalBound_bidegree_two_euler_eight_le + (p leftOrder rightOrder : ℕ) : + corvajaZannierCorollaryTwoNumericalBound p leftOrder rightOrder 2 2 8 ≤ + corvajaZannierTraceUpperBound p leftOrder rightOrder := by + let x : ℝ := (leftOrder * rightOrder : ℕ) + have hx : 0 ≤ x := by positivity + have hroot : 0 ≤ x ^ ((1 : ℝ) / 3) := Real.rpow_nonneg hx _ + have hfirst : 3 * (64 * x) ^ ((1 : ℝ) / 3) ≤ + 48 * x ^ ((1 : ℝ) / 3) := by + rw [Real.mul_rpow (by norm_num : (0 : ℝ) ≤ 64) hx, + sixtyFour_rpow_one_third_eq_four] + nlinarith + unfold corvajaZannierCorollaryTwoNumericalBound corvajaZannierTraceUpperBound + simp only [corvajaZannierCorollaryTwoSafeCoefficient] + have hdegrees : + ((leftOrder * rightOrder * 2 * 2 : ℕ) : ℝ) = 4 * x := by + simp [x] + ring + rw [hdegrees] + ring_nf + apply max_le + · have h := hfirst.trans + (mul_le_mul_of_nonneg_left + (le_max_left (x ^ ((1 : ℝ) / 3)) (x / p)) (by norm_num)) + simpa [x, div_eq_mul_inv, mul_comm, mul_left_comm, mul_assoc] using h + · have h := mul_le_mul_of_nonneg_left + (le_max_right (x ^ ((1 : ℝ) / 3)) (x / p)) (by norm_num : (0 : ℝ) ≤ 48) + simpa [x, div_eq_mul_inv, mul_comm, mul_left_comm, mul_assoc] using h + +end + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/CorvajaZannierStep.lean b/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/CorvajaZannierStep.lean new file mode 100644 index 0000000000..efdf45e15f --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/CorvajaZannierStep.lean @@ -0,0 +1,263 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.UnionBound + +/-! +# The Corvaja--Zannier middle-game escape step + +This module connects the published Corvaja--Zannier estimate to the already formalized +bad-order union. The deep estimate remains an explicit hypothesis about the actual +trace-equation solution sets. Two details that are easy to lose in an abstract union bound +are kept in the statement: + +* `sigma != 1`, as required in equation (62) of the published paper; +* the subgroup indexed by `d` must actually have cardinality `d`. + +The theorem below reduces the paper-specific order-increase step to one visible numerical +inequality. It does not postulate the Corvaja--Zannier theorem. +-/ + +@[expose] public section + +namespace BGS.Markoff + +variable {E : Type*} [Field E] [Fintype E] + +/-- A common Corvaja--Zannier bound for every candidate order not exceeding the current order. -/ +noncomputable def corvajaZannierCurrentOrderEnvelope + (p currentOrder : ℕ) : ℝ := + corvajaZannierCorollaryTwoSafeCoefficient * max + (((currentOrder * currentOrder : ℕ) : ℝ) ^ ((1 : ℝ) / 3)) + (((currentOrder * currentOrder : ℕ) : ℝ) / p) + +/-- Replacing a candidate right order by the current left order only enlarges the quoted +Corvaja--Zannier bound. -/ +theorem corvajaZannierTraceUpperBound_le_currentOrderEnvelope + (p currentOrder d : ℕ) (hd : d ≤ currentOrder) : + corvajaZannierTraceUpperBound p currentOrder d ≤ + corvajaZannierCurrentOrderEnvelope p currentOrder := by + have hmulNat : currentOrder * d ≤ currentOrder * currentOrder := + Nat.mul_le_mul_left currentOrder hd + have hmul : (((currentOrder * d : ℕ) : ℝ)) ≤ + (((currentOrder * currentOrder : ℕ) : ℝ)) := by + exact_mod_cast hmulNat + unfold corvajaZannierTraceUpperBound corvajaZannierCurrentOrderEnvelope + apply mul_le_mul_of_nonneg_left _ (by norm_num) + exact max_le_max + (Real.rpow_le_rpow (by positivity) hmul (by norm_num)) + (div_le_div_of_nonneg_right hmul (Nat.cast_nonneg p)) + +/-- The summed Corvaja--Zannier expression is bounded by the divisor count times the common +current-order envelope. -/ +theorem middleGameCorvajaZannierSum_le_divisorCount_mul_envelope + (p currentOrder : ℕ) : + (∑ d ∈ middleGameCandidateOrders p currentOrder, + corvajaZannierTraceUpperBound p currentOrder d) ≤ + (((p - 1).divisors.card + (p + 1).divisors.card : ℕ) : ℝ) * + corvajaZannierCurrentOrderEnvelope p currentOrder := by + classical + calc + (∑ d ∈ middleGameCandidateOrders p currentOrder, + corvajaZannierTraceUpperBound p currentOrder d) ≤ + ∑ _d ∈ middleGameCandidateOrders p currentOrder, + corvajaZannierCurrentOrderEnvelope p currentOrder := by + exact Finset.sum_le_sum fun d hd ↦ + corvajaZannierTraceUpperBound_le_currentOrderEnvelope p currentOrder d + (mem_middleGameCandidateOrders_iff.mp hd).1 + _ = ((middleGameCandidateOrders p currentOrder).card : ℝ) * + corvajaZannierCurrentOrderEnvelope p currentOrder := by + simp + _ ≤ (((p - 1).divisors.card + (p + 1).divisors.card : ℕ) : ℝ) * + corvajaZannierCurrentOrderEnvelope p currentOrder := by + apply mul_le_mul_of_nonneg_right _ (by + unfold corvajaZannierCurrentOrderEnvelope + positivity) + exact_mod_cast middleGameCandidateOrders_card_le p currentOrder + +/-- Two elementary natural-number inequalities imply that the entire divisor-counted +Corvaja--Zannier envelope is smaller than the current order. Writing +`D = tau(p - 1) + tau(p + 1)`, these are exactly + +* `(48 D)^3 < currentOrder` for the cube-root term, and +* `48 D * currentOrder < p` for the term divided by `p`. + +Thus the remaining asymptotic work is reduced to the proved subpolynomial divisor bound and +the chosen middle-game range for `currentOrder`. -/ +theorem divisorCount_mul_corvajaZannierEnvelope_lt_currentOrder + (p currentOrder : ℕ) (hcurrentOrder : 0 < currentOrder) + (hcube : + (corvajaZannierCorollaryTwoSafeCoefficient * + ((p - 1).divisors.card + (p + 1).divisors.card)) ^ 3 < currentOrder) + (hlinear : + corvajaZannierCorollaryTwoSafeCoefficient * + ((p - 1).divisors.card + (p + 1).divisors.card) * currentOrder < p) : + (((p - 1).divisors.card + (p + 1).divisors.card : ℕ) : ℝ) * + corvajaZannierCurrentOrderEnvelope p currentOrder < + (currentOrder : ℝ) := by + let divisorCount : ℕ := (p - 1).divisors.card + (p + 1).divisors.card + let coefficient : ℝ := corvajaZannierCorollaryTwoSafeCoefficient * divisorCount + have horderPos : (0 : ℝ) < currentOrder := by exact_mod_cast hcurrentOrder + have horderNonneg : (0 : ℝ) ≤ currentOrder := horderPos.le + have hcoefficientNonneg : 0 ≤ coefficient := by + dsimp [coefficient] + positivity + have hcubeReal : coefficient ^ (3 : ℕ) < (currentOrder : ℝ) := by + dsimp [coefficient, divisorCount] + exact_mod_cast hcube + have hcoefficientRoot : + coefficient < (currentOrder : ℝ) ^ ((1 : ℝ) / 3) := by + have h := (Real.lt_rpow_inv_iff_of_pos hcoefficientNonneg horderNonneg + (by norm_num : (0 : ℝ) < 3)).2 + have h' : coefficient < (currentOrder : ℝ) ^ (3 : ℝ)⁻¹ := + h (by simpa [Real.rpow_natCast] using hcubeReal) + simpa only [one_div] using h' + have hrootPositive : + 0 < (((currentOrder * currentOrder : ℕ) : ℝ) ^ ((1 : ℝ) / 3)) := by + positivity + have hcubeRootIdentity : + (currentOrder : ℝ) ^ ((1 : ℝ) / 3) * + (((currentOrder * currentOrder : ℕ) : ℝ) ^ ((1 : ℝ) / 3)) = + (currentOrder : ℝ) := by + rw [Nat.cast_mul] + rw [← Real.mul_rpow horderNonneg (mul_nonneg horderNonneg horderNonneg)] + convert Real.pow_rpow_inv_natCast horderNonneg + (by norm_num : (3 : ℕ) ≠ 0) using 1 + all_goals ring_nf + have hrootTerm : + coefficient * (((currentOrder * currentOrder : ℕ) : ℝ) ^ ((1 : ℝ) / 3)) < + (currentOrder : ℝ) := by + calc + coefficient * (((currentOrder * currentOrder : ℕ) : ℝ) ^ ((1 : ℝ) / 3)) < + (currentOrder : ℝ) ^ ((1 : ℝ) / 3) * + (((currentOrder * currentOrder : ℕ) : ℝ) ^ ((1 : ℝ) / 3)) := + mul_lt_mul_of_pos_right hcoefficientRoot hrootPositive + _ = (currentOrder : ℝ) := hcubeRootIdentity + have hlinearReal : coefficient * (currentOrder : ℝ) < (p : ℝ) := by + dsimp [coefficient, divisorCount] + exact_mod_cast hlinear + have hpPos : (0 : ℝ) < p := by + have : 0 < p := by omega + exact_mod_cast this + have hquotientTerm : + coefficient * (((currentOrder * currentOrder : ℕ) : ℝ) / (p : ℝ)) < + (currentOrder : ℝ) := by + have hratio : coefficient * (currentOrder : ℝ) / (p : ℝ) < 1 := + (div_lt_one hpPos).2 hlinearReal + calc + coefficient * (((currentOrder * currentOrder : ℕ) : ℝ) / (p : ℝ)) = + (coefficient * (currentOrder : ℝ) / (p : ℝ)) * (currentOrder : ℝ) := by + rw [Nat.cast_mul] + ring + _ < 1 * (currentOrder : ℝ) := mul_lt_mul_of_pos_right hratio horderPos + _ = (currentOrder : ℝ) := one_mul _ + calc + (((p - 1).divisors.card + (p + 1).divisors.card : ℕ) : ℝ) * + corvajaZannierCurrentOrderEnvelope p currentOrder = + coefficient * max + (((currentOrder * currentOrder : ℕ) : ℝ) ^ ((1 : ℝ) / 3)) + (((currentOrder * currentOrder : ℕ) : ℝ) / (p : ℝ)) := by + simp only [corvajaZannierCurrentOrderEnvelope] + dsimp [coefficient, divisorCount] + ring + _ = max + (coefficient * (((currentOrder * currentOrder : ℕ) : ℝ) ^ ((1 : ℝ) / 3))) + (coefficient * (((currentOrder * currentOrder : ℕ) : ℝ) / (p : ℝ))) := + mul_max_of_nonneg _ _ hcoefficientNonneg + _ < (currentOrder : ℝ) := max_lt hrootTerm hquotientTerm + +/-- The paper's middle-game pigeonhole step, now fed by the real-valued Corvaja--Zannier +estimate. The estimate is stated using the actual subgroup cardinality, and `hrightOrder` +performs the indispensable identification of that cardinality with the divisor `d` indexing the +union. + +The sole remaining numerical premise is exactly the inequality needed after summing over all +candidate orders. -/ +theorem exists_left_element_escaping_of_corvajaZannierEstimate + (p : ℕ) (sigma : E) (H₁ : Subgroup Eˣ) + (rightSubgroup : ℕ → Subgroup Eˣ) + (hrightOrder : ∀ d ∈ middleGameCandidateOrders p (Nat.card H₁), + Nat.card (rightSubgroup d) = d) + (hCZ : sigma ≠ 1 → + ∀ d ∈ middleGameCandidateOrders p (Nat.card H₁), + ((traceEquationSolutions sigma H₁ (rightSubgroup d)).card : ℝ) ≤ + corvajaZannierTraceUpperBound p (Nat.card H₁) + (Nat.card (rightSubgroup d))) + (hsigma : sigma ≠ 1) + (hsmall : + (((p - 1).divisors.card + (p + 1).divisors.card : ℕ) : ℝ) * + corvajaZannierCurrentOrderEnvelope p (Nat.card H₁) < + (Nat.card H₁ : ℝ)) : + ∃ h₁ : H₁, ∀ d ∈ middleGameCandidateOrders p (Nat.card H₁), + ∀ h₂ : rightSubgroup d, + twistedUnitTrace sigma h₁ ≠ twistedUnitTrace 1 h₂ := by + classical + let orders := middleGameCandidateOrders p (Nat.card H₁) + let bad := badOrderTraceSupport sigma H₁ orders rightSubgroup + have hCZIndexed : ∀ d ∈ orders, + ((traceEquationSolutions sigma H₁ (rightSubgroup d)).card : ℝ) ≤ + corvajaZannierTraceUpperBound p (Nat.card H₁) d := by + intro d hd + have hd' : d ∈ middleGameCandidateOrders p (Nat.card H₁) := by + simpa [orders] using hd + have hEstimate := hCZ hsigma d hd' + rw [hrightOrder d hd'] at hEstimate + exact hEstimate + have hbadReal : (bad.card : ℝ) < (Nat.card H₁ : ℝ) := by + calc + (bad.card : ℝ) ≤ + ∑ d ∈ orders, corvajaZannierTraceUpperBound p (Nat.card H₁) d := by + exact badOrderTraceSupport_card_cast_le_sum sigma H₁ orders rightSubgroup _ hCZIndexed + _ ≤ (((p - 1).divisors.card + (p + 1).divisors.card : ℕ) : ℝ) * + corvajaZannierCurrentOrderEnvelope p (Nat.card H₁) := by + simpa [orders] using + middleGameCorvajaZannierSum_le_divisorCount_mul_envelope p (Nat.card H₁) + _ < (Nat.card H₁ : ℝ) := hsmall + have hbad : bad.card < Nat.card H₁ := by exact_mod_cast hbadReal + have hexists : ∃ h₁ : H₁, h₁ ∉ bad := by + by_contra hall + push Not at hall + have hle : (Finset.univ : Finset H₁).card ≤ bad.card := + Finset.card_le_card fun h₁ _ ↦ hall h₁ + rw [Finset.card_univ, Fintype.card_eq_nat_card] at hle + exact (Nat.not_le_of_lt hbad) hle + obtain ⟨h₁, hh₁⟩ := hexists + refine ⟨h₁, ?_⟩ + intro d hd h₂ heq + apply hh₁ + exact mem_badOrderTraceSupport_iff.mpr ⟨d, by simpa [orders] using hd, h₂, heq⟩ + +/-- A fully finite version of the paper's Corvaja--Zannier order-escape step. Apart from the +deep estimate itself, its hypotheses are natural-number cardinality and size inequalities. -/ +theorem exists_left_element_escaping_of_corvajaZannierEstimate_and_sizeBounds + (p : ℕ) (sigma : E) (H₁ : Subgroup Eˣ) + (rightSubgroup : ℕ → Subgroup Eˣ) + (hrightOrder : ∀ d ∈ middleGameCandidateOrders p (Nat.card H₁), + Nat.card (rightSubgroup d) = d) + (hCZ : sigma ≠ 1 → + ∀ d ∈ middleGameCandidateOrders p (Nat.card H₁), + ((traceEquationSolutions sigma H₁ (rightSubgroup d)).card : ℝ) ≤ + corvajaZannierTraceUpperBound p (Nat.card H₁) + (Nat.card (rightSubgroup d))) + (hsigma : sigma ≠ 1) + (hcurrentOrder : 0 < Nat.card H₁) + (hcube : + (corvajaZannierCorollaryTwoSafeCoefficient * + ((p - 1).divisors.card + (p + 1).divisors.card)) ^ 3 < Nat.card H₁) + (hlinear : + corvajaZannierCorollaryTwoSafeCoefficient * + ((p - 1).divisors.card + (p + 1).divisors.card) * Nat.card H₁ < p) : + ∃ h₁ : H₁, ∀ d ∈ middleGameCandidateOrders p (Nat.card H₁), + ∀ h₂ : rightSubgroup d, + twistedUnitTrace sigma h₁ ≠ twistedUnitTrace 1 h₂ := by + exact exists_left_element_escaping_of_corvajaZannierEstimate p sigma H₁ rightSubgroup + hrightOrder hCZ hsigma + (divisorCount_mul_corvajaZannierEnvelope_lt_currentOrder p (Nat.card H₁) + hcurrentOrder hcube hlinear) + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/CosetTraceEquation.lean b/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/CosetTraceEquation.lean new file mode 100644 index 0000000000..b2272b2003 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/CosetTraceEquation.lean @@ -0,0 +1,128 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.WeightedTraceEquation + +/-! +# The coset form of the middle-game trace equation + +For a general point on a Markoff rotation fiber, the moving torus parameter is not a subgroup +element but an element of a multiplicative coset. This module records the exact change of +variables from the weighted equation + +`alpha * h + beta * h⁻¹ = k + k⁻¹` + +to the paper's twisted equation + +`g + (alpha * beta) * g⁻¹ = k + k⁻¹`, + +where `g` ranges over the coset `alpha * H₁`. In particular, this change of variables does not +turn the coset into a subgroup. Any Corvaja--Zannier input used for an arbitrary starting point +must therefore cover these multiplicative cosets. +-/ + +@[expose] public section + +namespace BGS.Markoff + +variable {E : Type*} [Field E] [Fintype E] + +/-- Regard a nonzero scalar as a unit. -/ +def scalarUnit (alpha : E) (halpha : alpha ≠ 0) : Eˣ := Units.mk0 alpha halpha + +/-- The left coset of `H` obtained by multiplying by the nonzero scalar `alpha`. -/ +noncomputable def scaledLeftCoset + (alpha : E) (halpha : alpha ≠ 0) (H : Subgroup Eˣ) : Finset Eˣ := by + classical + exact Finset.univ.image fun h : H ↦ scalarUnit alpha halpha * (h : Eˣ) + +@[simp] +theorem mem_scaledLeftCoset_iff + (alpha : E) (halpha : alpha ≠ 0) (H : Subgroup Eˣ) (g : Eˣ) : + g ∈ scaledLeftCoset alpha halpha H ↔ + ∃ h : H, scalarUnit alpha halpha * (h : Eˣ) = g := by + classical + simp [scaledLeftCoset] + +/-- Scale the left coordinate of a pair by `alpha`. -/ +def scaleLeftPair + (alpha : E) (halpha : alpha ≠ 0) (H₁ H₂ : Subgroup Eˣ) : + H₁ × H₂ → Eˣ × H₂ := + fun h ↦ (scalarUnit alpha halpha * (h.1 : Eˣ), h.2) + +omit [Fintype E] in +theorem scaleLeftPair_injective + (alpha : E) (halpha : alpha ≠ 0) (H₁ H₂ : Subgroup Eˣ) : + Function.Injective (scaleLeftPair alpha halpha H₁ H₂) := by + intro x y hxy + apply Prod.ext + · apply Subtype.ext + apply Units.ext + have hfirst := congrArg (fun z : Eˣ × H₂ ↦ (z.1 : E)) hxy + simpa [scaleLeftPair, scalarUnit] using + (mul_left_cancel₀ halpha hfirst) + · simpa [scaleLeftPair] using congrArg Prod.snd hxy + +omit [Fintype E] in +/-- The weighted and coset equations agree pointwise after the change of variables +`g = alpha * h`. -/ +theorem weightedSplitTorusTrace_eq_twistedUnitTrace_scaled + (alpha beta : E) (halpha : alpha ≠ 0) (h : Eˣ) : + weightedSplitTorusTrace alpha beta h = + twistedUnitTrace (alpha * beta) (scalarUnit alpha halpha * h) := by + simp only [weightedSplitTorusTrace, twistedUnitTrace, scalarUnit, Units.val_mul, + Units.val_mk0, Units.val_inv_eq_inv_val] + field_simp [halpha, Units.ne_zero h] + +/-- The actual solution finset, transported to the multiplicative coset in the left variable. -/ +noncomputable def cosetTraceEquationSolutionsOfWeights + (alpha beta : E) (halpha : alpha ≠ 0) (H₁ H₂ : Subgroup Eˣ) : + Finset (Eˣ × H₂) := by + classical + exact (weightedTraceEquationSolutions alpha beta H₁ H₂).image + (scaleLeftPair alpha halpha H₁ H₂) + +@[simp] +theorem mem_cosetTraceEquationSolutionsOfWeights_iff + (alpha beta : E) (halpha : alpha ≠ 0) (H₁ H₂ : Subgroup Eˣ) + (g : Eˣ × H₂) : + g ∈ cosetTraceEquationSolutionsOfWeights alpha beta halpha H₁ H₂ ↔ + g.1 ∈ scaledLeftCoset alpha halpha H₁ ∧ + twistedUnitTrace (alpha * beta) g.1 = splitTorusTrace g.2 := by + classical + constructor + · intro hg + rw [cosetTraceEquationSolutionsOfWeights, Finset.mem_image] at hg + obtain ⟨h, hh, rfl⟩ := hg + constructor + · exact (mem_scaledLeftCoset_iff alpha halpha H₁ _).2 ⟨h.1, rfl⟩ + · change twistedUnitTrace (alpha * beta) + (scalarUnit alpha halpha * (h.1 : Eˣ)) = splitTorusTrace h.2 + rw [← weightedSplitTorusTrace_eq_twistedUnitTrace_scaled alpha beta halpha h.1] + exact mem_weightedTraceEquationSolutions_iff.mp hh + · rintro ⟨hcoset, hequation⟩ + obtain ⟨h₁, hh₁⟩ := + (mem_scaledLeftCoset_iff alpha halpha H₁ g.1).mp hcoset + rw [cosetTraceEquationSolutionsOfWeights, Finset.mem_image] + refine ⟨(h₁, g.2), ?_, ?_⟩ + · apply mem_weightedTraceEquationSolutions_iff.mpr + rw [weightedSplitTorusTrace_eq_twistedUnitTrace_scaled alpha beta halpha h₁] + simpa [hh₁] using hequation + · exact Prod.ext hh₁ (Subtype.ext rfl) + +/-- Scaling the left variable is injective, so the weighted subgroup equation and its exact +coset form have the same number of solutions. -/ +theorem cosetTraceEquationSolutionsOfWeights_card + (alpha beta : E) (halpha : alpha ≠ 0) (H₁ H₂ : Subgroup Eˣ) : + (cosetTraceEquationSolutionsOfWeights alpha beta halpha H₁ H₂).card = + (weightedTraceEquationSolutions alpha beta H₁ H₂).card := by + classical + exact Finset.card_image_of_injective _ + (scaleLeftPair_injective alpha halpha H₁ H₂) + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/Diagonalization.lean b/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/Diagonalization.lean new file mode 100644 index 0000000000..88523ebe87 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/Diagonalization.lean @@ -0,0 +1,156 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.OrderEscape + +/-! +# Diagonalizing an arbitrary nonzero nonparabolic Markoff fiber + +This module closes the algebraic interface required by the weighted middle-game order escape. +Every normalized Markoff point whose fixed coordinate is nonzero and nonparabolic becomes an +explicit `splitFiberPoint w s` after scalar extension to the canonical quadratic field. + +The trace-zero fiber is excluded explicitly. Its conic is singular and the existing +`splitFiberEquiv` / `quadraticNormFiberEquiv` APIs correctly require nonzero trace; no false torus +parametrization is introduced for that branch. +-/ + +@[expose] public section + +namespace BGS.Markoff + +/-- The singular trace-zero rotation has order at most four. This keeps the trace-zero fiber +outside every middle-game range whose current order is greater than four, without pretending +that its singular conic is a torus. -/ +theorem rotationOrder_zero_le_four + (p : ℕ) [Fact p.Prime] : rotationOrder (0 : ZMod p) ≤ 4 := by + rw [rotationOrder] + apply orderOf_le_of_pow_eq_one (by norm_num) + apply Matrix.SpecialLinearGroup.ext + intro i j + change (rho (0 : ZMod p) ^ 4) i j = (1 : Matrix (Fin 2) (Fin 2) (ZMod p)) i j + fin_cases i <;> fin_cases j <;> + norm_num [rhoSL, rho, pow_succ, Matrix.mul_apply, Fin.sum_univ_two] + +/-- Scalar extension carries the explicit split fiber parametrization to the corresponding +parametrization over the quadratic field. -/ +theorem algebraMapNormalizedPoint_splitFiberPoint + (p : ℕ) [Fact p.Prime] (w s : (ZMod p)ˣ) : + algebraMapNormalizedPoint p (splitFiberPoint w s) = + splitFiberPoint + (Units.map (algebraMap (ZMod p) (quadraticFiniteField p)).toMonoidHom w) + (Units.map (algebraMap (ZMod p) (quadraticFiniteField p)).toMonoidHom s) := by + let phi := algebraMap (ZMod p) (quadraticFiniteField p) + let mapUnit : (ZMod p)ˣ →* (quadraticFiniteField p)ˣ := Units.map phi.toMonoidHom + have htrace : phi (splitTorusTrace w) = splitTorusTrace (mapUnit w) := by + rw [splitTorusTrace, splitTorusTrace, map_add] + rfl + have hproduct : phi (splitFiberProduct w) = splitFiberProduct (mapUnit w) := by + rw [splitFiberProduct, splitFiberProduct, map_div₀, map_sub, map_pow, map_ofNat, htrace] + ext + · exact htrace + · change phi ((s : ZMod p) + splitFiberProduct w * ((s⁻¹ : (ZMod p)ˣ) : ZMod p)) = _ + rw [map_add, map_mul, hproduct] + rfl + · change phi ((s : ZMod p) * (w : ZMod p) + + splitFiberProduct w * ((s⁻¹ : (ZMod p)ˣ) : ZMod p) * + ((w⁻¹ : (ZMod p)ˣ) : ZMod p)) = _ + rw [map_add, map_mul, map_mul, map_mul, hproduct] + rfl + +/-- Every normalized nonzero nonparabolic fiber point admits the diagonalized scalar-extension +presentation consumed by `exists_iterate_with_larger_secondRotationOrder_of_diagonalizedFiber`. -/ +theorem exists_diagonalizedFiberPoint_of_nonzero_nonparabolic + (p : ℕ) [Fact p.Prime] (hpTwo : p ≠ 2) + (x : NormalizedPoint (ZMod p)) (hx : IsNormalizedMarkoff x) + (hnonzero : x.u1 ≠ 0) (hnonparabolic : x.u1 ^ 2 ≠ 4) : + ∃ w s : (quadraticFiniteField p)ˣ, + (w : quadraticFiniteField p) ^ 2 ≠ 1 ∧ + algebraMapNormalizedPoint p x = splitFiberPoint w s := by + rcases exists_split_or_quadraticNormOneTrace p hpTwo x.u1 hnonparabolic with + ⟨w, htrace, hw⟩ | ⟨w, htrace, hw⟩ + · let xp : ↑(normalizedFiber1 (splitTorusTrace w)) := + ⟨x, hx, htrace.symm⟩ + have htraceNonzero : splitTorusTrace w ≠ 0 := by + rw [htrace] + exact hnonzero + let s : (ZMod p)ˣ := (splitFiberEquiv w hw htraceNonzero).symm xp + have hsPoint : splitFiberPoint w s = x := + congrArg Subtype.val ((splitFiberEquiv w hw htraceNonzero).apply_symm_apply xp) + let embedding : (ZMod p)ˣ →* (quadraticFiniteField p)ˣ := + Units.map (algebraMap (ZMod p) (quadraticFiniteField p)).toMonoidHom + let extensionW : (quadraticFiniteField p)ˣ := embedding w + let extensionS : (quadraticFiniteField p)ˣ := embedding s + have hExtensionW : (extensionW : quadraticFiniteField p) ^ 2 ≠ 1 := by + intro hpower + apply hw + apply (algebraMap (ZMod p) (quadraticFiniteField p)).injective + rw [map_pow, map_one] + exact hpower + refine ⟨extensionW, extensionS, hExtensionW, ?_⟩ + calc + algebraMapNormalizedPoint p x = + algebraMapNormalizedPoint p (splitFiberPoint w s) := by rw [hsPoint] + _ = splitFiberPoint extensionW extensionS := by + exact algebraMapNormalizedPoint_splitFiberPoint p w s + · let xp : ↑(normalizedFiber1 x.u1) := ⟨x, hx, rfl⟩ + let s := (quadraticNormFiberEquiv p x.u1 hnonparabolic hnonzero w htrace hw).symm xp + have hsPoint : quadraticNormFiberPoint p x.u1 hnonparabolic hnonzero w s = x := + congrArg Subtype.val + ((quadraticNormFiberEquiv p x.u1 hnonparabolic hnonzero w htrace hw).apply_symm_apply xp) + refine ⟨(w : (quadraticFiniteField p)ˣ), s.1, hw, ?_⟩ + calc + algebraMapNormalizedPoint p x = + algebraMapNormalizedPoint p + (quadraticNormFiberPoint p x.u1 hnonparabolic hnonzero w s) := by rw [hsPoint] + _ = splitFiberPoint (w : (quadraticFiniteField p)ˣ) s.1 := + algebraMap_quadraticNormFiberPoint p x.u1 hnonparabolic hnonzero w htrace s + +/-- Complete nonzero nonparabolic middle-game order escape. All algebraic and combinatorial +wiring is discharged internally. The only deep hypothesis is the weighted Corvaja--Zannier +estimate, stated uniformly for whichever split or norm-one diagonalization the point has. -/ +theorem exists_iterate_with_larger_secondRotationOrder_of_nonzero_nonparabolic + (p : ℕ) [Fact p.Prime] [Fintype (quadraticFiniteField p)] (hpTwo : p ≠ 2) + (delta : ℝ) (hdelta : delta ≤ (1 : ℝ) / 2) + (x : NormalizedPoint (ZMod p)) (hx : IsNormalizedMarkoff x) + (hnonzero : x.u1 ≠ 0) (hnonparabolic : x.u1 ^ 2 ≠ 4) + (hbelowEndgame : + (rotationOrder x.u1 : ℝ) < (p : ℝ) ^ ((1 : ℝ) / 2 + delta)) + (hcube : + (corvajaZannierCorollaryTwoSafeCoefficient * + ((p - 1).divisors.card + (p + 1).divisors.card)) ^ 3 < + rotationOrder x.u1) + (hlinear : + corvajaZannierCorollaryTwoSafeCoefficient * + ((p - 1).divisors.card + (p + 1).divisors.card) * + rotationOrder x.u1 < p) + (hCZ : + ∀ (w s : (quadraticFiniteField p)ˣ), + (w : quadraticFiniteField p) ^ 2 ≠ 1 → + algebraMapNormalizedPoint p x = splitFiberPoint w s → + (s : quadraticFiniteField p) * + (splitFiberProduct w * ((s⁻¹ : (quadraticFiniteField p)ˣ) : + quadraticFiniteField p)) ≠ 1 → + ∀ d ∈ middleGameCandidateOrders p (rotationOrder x.u1), + ((weightedTraceEquationSolutions + (s : quadraticFiniteField p) + (splitFiberProduct w * ((s⁻¹ : (quadraticFiniteField p)ˣ) : + quadraticFiniteField p)) + (Subgroup.zpowers w) (middleGameRightSubgroup p d)).card : ℝ) ≤ + corvajaZannierTraceUpperBound p (rotationOrder x.u1) + (Nat.card (middleGameRightSubgroup p d))) : + ∃ n : ℕ, + rotationOrder x.u1 < rotationOrder ((normalizedRotate1^[n]) x).u2 := by + obtain ⟨w, s, hw, hpoint⟩ := + exists_diagonalizedFiberPoint_of_nonzero_nonparabolic + p hpTwo x hx hnonzero hnonparabolic + exact exists_iterate_with_larger_secondRotationOrder_of_diagonalizedFiber + p hpTwo delta hdelta x w s hw hpoint hbelowEndgame hcube hlinear + (hCZ w s hw hpoint) + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/DivisorRange.lean b/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/DivisorRange.lean new file mode 100644 index 0000000000..66c8ae6c58 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/DivisorRange.lean @@ -0,0 +1,194 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.CorvajaZannierStep + +/-! +# Divisor estimates in the middle-game range + +Choose eventual thresholds where divisor counts satisfy the real-power bounds required by the +middle-game argument. +-/ + +@[expose] public section + +namespace BGS.Markoff + +open Filter +open scoped Topology + +theorem eventually_const_mul_rpow_lt_rpow + {C a b : ℝ} (hab : a < b) : + ∀ᶠ n : ℕ in atTop, C * (n : ℝ) ^ a < (n : ℝ) ^ b := by + have hExponent : 0 < b - a := sub_pos.mpr hab + have hEventuallyConstant : + ∀ᶠ n : ℕ in atTop, C < (n : ℝ) ^ (b - a) := + ((tendsto_rpow_atTop hExponent).comp tendsto_natCast_atTop_atTop).eventually + (eventually_gt_atTop C) + filter_upwards [hEventuallyConstant, eventually_gt_atTop 0] with n hC hn + have hnRealPos : (0 : ℝ) < n := by exact_mod_cast hn + calc + C * (n : ℝ) ^ a < (n : ℝ) ^ (b - a) * (n : ℝ) ^ a := + mul_lt_mul_of_pos_right hC (Real.rpow_pos_of_pos hnRealPos _) + _ = (n : ℝ) ^ b := by + rw [← Real.rpow_add hnRealPos] + congr 1 + ring + +theorem exists_threshold_middleGameDivisorCount_le_two_mul_rpow + {ε : ℝ} (hε : 0 < ε) : + ∃ threshold : ℕ, ∀ p : ℕ, threshold ≤ p → + (((p - 1).divisors.card + (p + 1).divisors.card : ℕ) : ℝ) ≤ + 2 * ((p + 1 : ℕ) : ℝ) ^ ε := by + obtain ⟨N, hN⟩ := BGS.NumberTheory.exists_threshold_card_divisors_le_rpow hε + refine ⟨N + 1, ?_⟩ + intro p hp + have hpMinus : N ≤ p - 1 := by omega + have hpPlus : N ≤ p + 1 := by omega + have hMinus := hN (p - 1) hpMinus + have hPlus := hN (p + 1) hpPlus + have hBase : (((p - 1 : ℕ) : ℝ)) ≤ (((p + 1 : ℕ) : ℝ)) := by + exact_mod_cast (show p - 1 ≤ p + 1 by omega) + have hPower : (((p - 1 : ℕ) : ℝ)) ^ ε ≤ (((p + 1 : ℕ) : ℝ)) ^ ε := + Real.rpow_le_rpow (Nat.cast_nonneg _) hBase hε.le + have hPlus' : ((p + 1).divisors.card : ℝ) ≤ ((p : ℝ) + 1) ^ ε := by + simpa only [Nat.cast_add, Nat.cast_one] using hPlus + have hPower' : (((p - 1 : ℕ) : ℝ)) ^ ε ≤ ((p : ℝ) + 1) ^ ε := by + simpa only [Nat.cast_add, Nat.cast_one] using hPower + norm_num only [Nat.cast_add, Nat.cast_one] + calc + ((p - 1).divisors.card : ℝ) + ((p + 1).divisors.card : ℝ) ≤ + (((p - 1 : ℕ) : ℝ)) ^ ε + ((p : ℝ) + 1) ^ ε := + add_le_add hMinus hPlus' + _ ≤ ((p : ℝ) + 1) ^ ε + ((p : ℝ) + 1) ^ ε := + add_le_add hPower' (le_refl _) + _ = 2 * ((p : ℝ) + 1) ^ ε := by ring + +theorem eventually_corvajaZannierDivisorCount_le_rpow + {ε : ℝ} (hε : 0 < ε) : + ∀ᶠ p : ℕ in atTop, + (corvajaZannierCorollaryTwoSafeCoefficient * + ((p - 1).divisors.card + (p + 1).divisors.card) : ℝ) ≤ + ((2 * corvajaZannierCorollaryTwoSafeCoefficient : ℕ) * (2 : ℝ) ^ ε) * + (p : ℝ) ^ ε := by + obtain ⟨threshold, hthreshold⟩ := + exists_threshold_middleGameDivisorCount_le_two_mul_rpow hε + filter_upwards [eventually_ge_atTop threshold, eventually_ge_atTop 1] with p hp hpOne + have hdivisor := hthreshold p hp + have hpCast : (0 : ℝ) ≤ p := Nat.cast_nonneg p + have hbase : (((p + 1 : ℕ) : ℝ)) ≤ 2 * (p : ℝ) := by + norm_num only [Nat.cast_add, Nat.cast_one] + exact_mod_cast (show p + 1 ≤ 2 * p by omega) + have hpower : (((p + 1 : ℕ) : ℝ)) ^ ε ≤ (2 * (p : ℝ)) ^ ε := + Real.rpow_le_rpow (Nat.cast_nonneg _) hbase hε.le + calc + (corvajaZannierCorollaryTwoSafeCoefficient * + ((p - 1).divisors.card + (p + 1).divisors.card) : ℝ) = + corvajaZannierCorollaryTwoSafeCoefficient * + (((p - 1).divisors.card + (p + 1).divisors.card : ℕ) : ℝ) := by + norm_num + _ ≤ corvajaZannierCorollaryTwoSafeCoefficient * + (2 * (((p + 1 : ℕ) : ℝ)) ^ ε) := + mul_le_mul_of_nonneg_left hdivisor (by + simp [corvajaZannierCorollaryTwoSafeCoefficient]) + _ ≤ corvajaZannierCorollaryTwoSafeCoefficient * + (2 * (2 * (p : ℝ)) ^ ε) := by gcongr + _ = ((2 * corvajaZannierCorollaryTwoSafeCoefficient : ℕ) * (2 : ℝ) ^ ε) * + (p : ℝ) ^ ε := by + rw [Real.mul_rpow (by norm_num : (0 : ℝ) ≤ 2) hpCast] + norm_num [corvajaZannierCorollaryTwoSafeCoefficient] + ring + +/-- Throughout the genuine middle range, the two finite inequalities needed by the +Corvaja--Zannier escape theorem eventually hold uniformly in the current order. -/ +theorem eventually_middleGame_corvajaZannier_sizeBounds + {δ : ℝ} (hδ : 0 < δ) : + ∀ᶠ p : ℕ in atTop, ∀ currentOrder : ℕ, + (p : ℝ) ^ δ < currentOrder → + (currentOrder : ℝ) < (p : ℝ) ^ (1 - δ) → + (corvajaZannierCorollaryTwoSafeCoefficient * + ((p - 1).divisors.card + (p + 1).divisors.card)) ^ 3 < currentOrder ∧ + corvajaZannierCorollaryTwoSafeCoefficient * + ((p - 1).divisors.card + (p + 1).divisors.card) * currentOrder < p := by + let ε : ℝ := δ / 6 + let C : ℝ := + (2 * corvajaZannierCorollaryTwoSafeCoefficient : ℕ) * (2 : ℝ) ^ ε + have hε : 0 < ε := by dsimp [ε]; positivity + have hThreeε : 3 * ε < δ := by dsimp [ε]; linarith + have hLinearExponent : 1 - δ + ε < 1 := by dsimp [ε]; linarith + have hDivisor := eventually_corvajaZannierDivisorCount_le_rpow hε + have hCubeDominance : + ∀ᶠ p : ℕ in atTop, C ^ 3 * (p : ℝ) ^ (3 * ε) < (p : ℝ) ^ δ := + eventually_const_mul_rpow_lt_rpow hThreeε + have hLinearDominance : + ∀ᶠ p : ℕ in atTop, C * (p : ℝ) ^ (1 - δ + ε) < (p : ℝ) ^ (1 : ℝ) := + eventually_const_mul_rpow_lt_rpow hLinearExponent + filter_upwards [hDivisor, hCubeDominance, hLinearDominance, + eventually_ge_atTop 1] with p hDivisor hCubeDominance hLinearDominance hpOne + intro currentOrder hLower hUpper + have hpRealPos : (0 : ℝ) < p := by exact_mod_cast (show 0 < p by omega) + have hpRealNonneg : (0 : ℝ) ≤ p := hpRealPos.le + have hCPos : 0 < C := by + dsimp [C] + simp only [corvajaZannierCorollaryTwoSafeCoefficient] + positivity + have hCurrentNonneg : (0 : ℝ) ≤ currentOrder := Nat.cast_nonneg currentOrder + have hCoeffNonneg : + (0 : ℝ) ≤ corvajaZannierCorollaryTwoSafeCoefficient * + ((p - 1).divisors.card + (p + 1).divisors.card) := by + simp only [corvajaZannierCorollaryTwoSafeCoefficient] + positivity + have hPowerIdentity : + (C * (p : ℝ) ^ ε) ^ 3 = C ^ 3 * (p : ℝ) ^ (3 * ε) := by + rw [mul_pow] + rw [← Real.rpow_mul_natCast hpRealNonneg ε 3] + congr 2 + ring + have hCubeReal : + (((corvajaZannierCorollaryTwoSafeCoefficient * + ((p - 1).divisors.card + (p + 1).divisors.card)) ^ 3 : ℕ) : ℝ) < + (currentOrder : ℝ) := by + calc + (((corvajaZannierCorollaryTwoSafeCoefficient * + ((p - 1).divisors.card + (p + 1).divisors.card)) ^ 3 : ℕ) : ℝ) = + (corvajaZannierCorollaryTwoSafeCoefficient * + ((p - 1).divisors.card + (p + 1).divisors.card) : ℝ) ^ 3 := by + norm_num + _ ≤ (C * (p : ℝ) ^ ε) ^ 3 := + pow_le_pow_left₀ hCoeffNonneg hDivisor 3 + _ = C ^ 3 * (p : ℝ) ^ (3 * ε) := hPowerIdentity + _ < (p : ℝ) ^ δ := hCubeDominance + _ < (currentOrder : ℝ) := hLower + have hLinearIdentity : + (C * (p : ℝ) ^ ε) * (p : ℝ) ^ (1 - δ) = + C * (p : ℝ) ^ (1 - δ + ε) := by + rw [mul_assoc, ← Real.rpow_add hpRealPos] + congr 2 + ring + have hLinearReal : + (((corvajaZannierCorollaryTwoSafeCoefficient * + ((p - 1).divisors.card + (p + 1).divisors.card) * currentOrder : ℕ) : ℝ)) < + (p : ℝ) := by + calc + (((corvajaZannierCorollaryTwoSafeCoefficient * + ((p - 1).divisors.card + (p + 1).divisors.card) * currentOrder : ℕ) : ℝ)) = + (corvajaZannierCorollaryTwoSafeCoefficient * + ((p - 1).divisors.card + (p + 1).divisors.card) : ℝ) * + (currentOrder : ℝ) := by norm_num + _ ≤ (C * (p : ℝ) ^ ε) * (currentOrder : ℝ) := + mul_le_mul_of_nonneg_right hDivisor hCurrentNonneg + _ < (C * (p : ℝ) ^ ε) * (p : ℝ) ^ (1 - δ) := + mul_lt_mul_of_pos_left hUpper (mul_pos hCPos (Real.rpow_pos_of_pos hpRealPos _)) + _ = C * (p : ℝ) ^ (1 - δ + ε) := hLinearIdentity + _ < (p : ℝ) ^ (1 : ℝ) := hLinearDominance + _ = (p : ℝ) := by simp + constructor + · exact_mod_cast hCubeReal + · exact_mod_cast hLinearReal + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/EulerSevenPairedCorvajaZannierBound.lean b/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/EulerSevenPairedCorvajaZannierBound.lean new file mode 100644 index 0000000000..c5f7e4fc63 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/EulerSevenPairedCorvajaZannierBound.lean @@ -0,0 +1,126 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.WeightedTraceEulerSevenBound +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.RightInversionPairing +public import Mathlib.Tactic + +/-! +# Right-inversion pairing with Euler budget seven + +For bidegree `(2,2)` and Euler budget `7`, the source cube-root branch is +`3 * (56mn)^(1/3)`. Right-coordinate inversion divides the nonparabolic +support by two. The resulting root coefficient has cube + +`((3/2) * 56^(1/3))^3 = 189`. + +The quotient-by-characteristic coefficient remains exactly `24`. +-/ + +@[expose] public section + +namespace BGS.Markoff + +noncomputable section + +/-- The exact right-inversion-paired χ≤7 numerical bound. -/ +def pairedEulerSevenCorvajaZannierTraceUpperBound + (p leftOrder rightOrder : ℕ) : ℝ := + max + ((3 / 2 : ℝ) * + (56 * ((leftOrder * rightOrder : ℕ) : ℝ)) ^ ((1 : ℝ) / 3)) + (24 * (((leftOrder * rightOrder : ℕ) : ℝ) / p)) + +/-- The source χ≤7 bound is exactly twice the paired bound. -/ +theorem + corvajaZannierCorollaryTwoNumericalBound_bidegree_two_euler_seven_eq_twice_paired + (p leftOrder rightOrder : ℕ) : + corvajaZannierCorollaryTwoNumericalBound + p leftOrder rightOrder 2 2 7 = + 2 * pairedEulerSevenCorvajaZannierTraceUpperBound + p leftOrder rightOrder := by + let x : ℝ := ((leftOrder * rightOrder : ℕ) : ℝ) + have horders : + (((leftOrder * rightOrder * 2 * 2 : ℕ) : ℝ)) = 4 * x := by + simp [x] + ring + unfold corvajaZannierCorollaryTwoNumericalBound + pairedEulerSevenCorvajaZannierTraceUpperBound + rw [horders] + rw [mul_max_of_nonneg _ _ (by norm_num : (0 : ℝ) ≤ 2)] + rw [show 2 * (4 * x) * 7 = 56 * x by ring] + dsimp only [x] + congr 1 <;> ring + +/-- The weighted-trace χ≤7 theorem combined with right inversion gives the +exact nonparabolic left-support estimate whose root coefficient cubes to +`189`. -/ +theorem + weightedTraceEquationNonparabolicLeftSupport_card_cast_le_pairedEulerSeven + (p : ℕ) [Fact p.Prime] + (E : Type*) [Field E] [Fintype E] [DecidableEq E] [CharP E p] + (alpha beta : E) (Hleft Hright : Subgroup Eˣ) + (hadmissible : WeightedTraceCurveIsCorvajaZannierAdmissible alpha beta) : + ((weightedTraceEquationNonparabolicLeftSupport + alpha beta Hleft Hright).card : ℝ) ≤ + pairedEulerSevenCorvajaZannierTraceUpperBound + p (Nat.card Hleft) (Nat.card Hright) := by + obtain ⟨hleftPositive, hrightPositive, hleftPrime, hrightPrime⟩ := + multiplicativeSubgroups_satisfy_weightedTraceBoundOrderHypotheses + p E Hleft Hright + have hsource := + weightedTraceTorsionIntersection_card_cast_le_eulerSeven + (p := p) alpha beta hadmissible + (Nat.card Hright) (Nat.card Hleft) + hrightPositive hleftPositive hrightPrime hleftPrime + rw [generalTorusTorsionIntersection_weightedTrace_eq] at hsource + have hsolutions : + ((weightedTraceEquationSolutions alpha beta Hleft Hright).card : ℝ) ≤ + corvajaZannierCorollaryTwoNumericalBound + p (Nat.card Hleft) (Nat.card Hright) 2 2 7 := by + calc + ((weightedTraceEquationSolutions alpha beta Hleft Hright).card : ℝ) ≤ + ((weightedTraceCurveTorsionIntersection alpha beta + (Nat.card Hleft) (Nat.card Hright)).card : ℝ) := by + exact_mod_cast + weightedTraceEquationSolutions_card_le_curveTorsionIntersection + alpha beta Hleft Hright + _ ≤ corvajaZannierCorollaryTwoNumericalBound + p (Nat.card Hright) (Nat.card Hleft) 2 2 7 := hsource + _ = corvajaZannierCorollaryTwoNumericalBound + p (Nat.card Hleft) (Nat.card Hright) 2 2 7 := by + unfold corvajaZannierCorollaryTwoNumericalBound + congr 1 <;> simp [Nat.mul_comm] + have hpaired : + 2 * ((weightedTraceEquationNonparabolicLeftSupport + alpha beta Hleft Hright).card : ℝ) ≤ + ((weightedTraceEquationSolutions alpha beta Hleft Hright).card : ℝ) := by + exact_mod_cast + two_mul_weightedTraceEquationNonparabolicLeftSupport_card_le_solutions + alpha beta Hleft Hright + have htwice : + 2 * ((weightedTraceEquationNonparabolicLeftSupport + alpha beta Hleft Hright).card : ℝ) ≤ + 2 * pairedEulerSevenCorvajaZannierTraceUpperBound + p (Nat.card Hleft) (Nat.card Hright) := by + calc + 2 * ((weightedTraceEquationNonparabolicLeftSupport + alpha beta Hleft Hright).card : ℝ) ≤ + ((weightedTraceEquationSolutions + alpha beta Hleft Hright).card : ℝ) := hpaired + _ ≤ corvajaZannierCorollaryTwoNumericalBound + p (Nat.card Hleft) (Nat.card Hright) 2 2 7 := hsolutions + _ = 2 * pairedEulerSevenCorvajaZannierTraceUpperBound + p (Nat.card Hleft) (Nat.card Hright) := by + rw [ + corvajaZannierCorollaryTwoNumericalBound_bidegree_two_euler_seven_eq_twice_paired] + nlinarith + +end + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/EulerSevenPairedMaximalDivisorCorvajaZannierEscape.lean b/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/EulerSevenPairedMaximalDivisorCorvajaZannierEscape.lean new file mode 100644 index 0000000000..631417a0e2 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/EulerSevenPairedMaximalDivisorCorvajaZannierEscape.lean @@ -0,0 +1,61 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.Diagonalization +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.EulerSevenPairedMaximalDivisorOrderEscape +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.TraceCurveWeights + +/-! +# Unconditional Euler-seven paired maximal-divisor middle-game escape + +The exact support-index and Euler-characteristic calculation improves the +paired cube condition from `(6 * K)^3 < d` to `189 * K^3 < d`. +-/ + +@[expose] public section + +namespace BGS.Markoff + +/-- Diagonalize a nonzero nonparabolic fiber and apply the exact +Euler-seven paired maximal-order escape theorem. -/ +theorem + exists_iterate_with_larger_secondRotationOrder_of_nonzero_nonparabolic_eulerSevenPairedMaximalOrders + (p : ℕ) [Fact p.Prime] [Fintype (quadraticFiniteField p)] + (hpTwo : p ≠ 2) + (delta : ℝ) (hdelta : delta ≤ (1 : ℝ) / 2) + (x : NormalizedPoint (ZMod p)) (hx : IsNormalizedMarkoff x) + (hnonzero : x.u1 ≠ 0) (hnonparabolic : x.u1 ^ 2 ≠ 4) + (hbelowEndgame : + (rotationOrder x.u1 : ℝ) < + (p : ℝ) ^ ((1 : ℝ) / 2 + delta)) + (hcube : + 189 * + (middleGameMaximalOrders p (rotationOrder x.u1)).card ^ 3 < + rotationOrder x.u1) + (hlinear : + 24 * (middleGameMaximalOrders p (rotationOrder x.u1)).card * + rotationOrder x.u1 < p) : + ∃ n : ℕ, + rotationOrder x.u1 < + rotationOrder ((normalizedRotate1^[n]) x).u2 := by + obtain ⟨w, s, hw, hpoint⟩ := + exists_diagonalizedFiberPoint_of_nonzero_nonparabolic + p hpTwo x hx hnonzero hnonparabolic + have hadmissible : + WeightedTraceCurveIsCorvajaZannierAdmissible + (s : quadraticFiniteField p) + (splitFiberProduct w * + ((s⁻¹ : (quadraticFiniteField p)ˣ) : quadraticFiniteField p)) := + diagonalizedFiber_weightedTraceCurve_isCorvajaZannierAdmissible + p hpTwo x hnonzero w s hw hpoint + exact + exists_iterate_with_larger_secondRotationOrder_of_diagonalizedFiber_eulerSevenPairedMaximalOrders + p hpTwo delta hdelta x w s hw hpoint hadmissible + hbelowEndgame hcube hlinear + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/EulerSevenPairedMaximalDivisorCorvajaZannierStep.lean b/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/EulerSevenPairedMaximalDivisorCorvajaZannierStep.lean new file mode 100644 index 0000000000..6ed9a032dc --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/EulerSevenPairedMaximalDivisorCorvajaZannierStep.lean @@ -0,0 +1,250 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.MaximalDivisorNonparabolicOrderCover +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.NonparabolicUnionBound +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.EulerSevenPairedCorvajaZannierBound +public import Mathlib.Tactic + +/-! +# Euler-seven paired escape over maximal candidate orders + +The exact χ≤7 paired bound gives two sufficient inequalities: + +* `189 * K^3 < currentOrder`; +* `24 * K * currentOrder < p`. + +Here `K` is the number of divisibility-maximal candidate orders. The first +coefficient is exact: it is the cube of the paired χ≤7 root coefficient. +-/ + +@[expose] public section + +namespace BGS.Markoff + +noncomputable section + +variable {E : Type*} [Field E] [Fintype E] + +private theorem rpow_one_third_cube_eulerSeven {x : ℝ} (hx : 0 ≤ x) : + (x ^ ((1 : ℝ) / 3)) ^ (3 : ℕ) = x := by + rw [← Real.rpow_mul_natCast hx] + norm_num + +/-- A common χ≤7 paired bound for every candidate right order at most the +current left order. -/ +def pairedEulerSevenCurrentOrderEnvelope + (p currentOrder : ℕ) : ℝ := + max + ((3 / 2 : ℝ) * + (56 * ((currentOrder * currentOrder : ℕ) : ℝ)) ^ + ((1 : ℝ) / 3)) + (24 * (((currentOrder * currentOrder : ℕ) : ℝ) / p)) + +theorem pairedEulerSevenTraceUpperBound_le_currentOrderEnvelope + (p currentOrder d : ℕ) (hd : d ≤ currentOrder) : + pairedEulerSevenCorvajaZannierTraceUpperBound p currentOrder d ≤ + pairedEulerSevenCurrentOrderEnvelope p currentOrder := by + have hmulNat : currentOrder * d ≤ currentOrder * currentOrder := + Nat.mul_le_mul_left currentOrder hd + have hmul : (((currentOrder * d : ℕ) : ℝ)) ≤ + (((currentOrder * currentOrder : ℕ) : ℝ)) := by + exact_mod_cast hmulNat + unfold pairedEulerSevenCorvajaZannierTraceUpperBound + pairedEulerSevenCurrentOrderEnvelope + exact max_le_max + (mul_le_mul_of_nonneg_left + (Real.rpow_le_rpow + (by positivity : (0 : ℝ) ≤ 56 * ((currentOrder * d : ℕ) : ℝ)) + (mul_le_mul_of_nonneg_left hmul (by norm_num)) + (by norm_num)) + (by norm_num)) + (mul_le_mul_of_nonneg_left + (div_le_div_of_nonneg_right hmul (Nat.cast_nonneg p)) + (by norm_num)) + +theorem + middleGameMaximalPairedEulerSevenSum_le_card_mul_envelope + (p currentOrder : ℕ) (hp : 1 < p) : + (∑ d ∈ middleGameMaximalOrders p currentOrder, + pairedEulerSevenCorvajaZannierTraceUpperBound + p currentOrder d) ≤ + ((middleGameMaximalOrders p currentOrder).card : ℝ) * + pairedEulerSevenCurrentOrderEnvelope p currentOrder := by + classical + calc + (∑ d ∈ middleGameMaximalOrders p currentOrder, + pairedEulerSevenCorvajaZannierTraceUpperBound + p currentOrder d) ≤ + ∑ _d ∈ middleGameMaximalOrders p currentOrder, + pairedEulerSevenCurrentOrderEnvelope p currentOrder := by + exact Finset.sum_le_sum fun d hd ↦ + pairedEulerSevenTraceUpperBound_le_currentOrderEnvelope + p currentOrder d + (mem_middleGameCandidateOrders_iff.mp + (middleGameMaximalOrders_subset_candidateOrders hp hd)).1 + _ = ((middleGameMaximalOrders p currentOrder).card : ℝ) * + pairedEulerSevenCurrentOrderEnvelope p currentOrder := by + simp + +/-- The exact coefficient-`189` cube condition and the coefficient-`24` +linear condition make the whole maximal-order envelope smaller than the +current order. -/ +theorem orderCount_mul_pairedEulerSevenEnvelope_lt_currentOrder + (p currentOrder orderCount : ℕ) + (hcurrentOrder : 0 < currentOrder) + (hcube : 189 * orderCount ^ 3 < currentOrder) + (hlinear : 24 * orderCount * currentOrder < p) : + (orderCount : ℝ) * + pairedEulerSevenCurrentOrderEnvelope p currentOrder < + (currentOrder : ℝ) := by + let rootTerm : ℝ := + (orderCount : ℝ) * ((3 / 2 : ℝ) * + (56 * ((currentOrder * currentOrder : ℕ) : ℝ)) ^ + ((1 : ℝ) / 3)) + let linearCoefficient : ℝ := 24 * orderCount + have horderPos : (0 : ℝ) < currentOrder := by + exact_mod_cast hcurrentOrder + have hradicand : + (0 : ℝ) ≤ + 56 * ((currentOrder * currentOrder : ℕ) : ℝ) := by + positivity + have hrootCube : + ((56 * ((currentOrder * currentOrder : ℕ) : ℝ)) ^ + ((1 : ℝ) / 3)) ^ (3 : ℕ) = + 56 * ((currentOrder * currentOrder : ℕ) : ℝ) := + rpow_one_third_cube_eulerSeven hradicand + have hrootTermCube : + rootTerm ^ 3 = + 189 * (orderCount : ℝ) ^ 3 * (currentOrder : ℝ) ^ 2 := by + dsimp only [rootTerm] + rw [mul_pow, mul_pow, hrootCube] + push_cast + ring + have hcubeScaledNat : + 189 * orderCount ^ 3 * currentOrder ^ 2 < + currentOrder ^ 3 := by + have h := + Nat.mul_lt_mul_of_pos_right hcube + (show 0 < currentOrder ^ 2 from Nat.pow_pos hcurrentOrder) + simpa [pow_succ, mul_assoc] using h + have hcubeScaled : + 189 * (orderCount : ℝ) ^ 3 * (currentOrder : ℝ) ^ 2 < + (currentOrder : ℝ) ^ 3 := by + exact_mod_cast hcubeScaledNat + have hrootTerm : rootTerm < (currentOrder : ℝ) := by + apply lt_of_pow_lt_pow_left₀ 3 (Nat.cast_nonneg currentOrder) + rw [hrootTermCube] + exact hcubeScaled + have hlinearReal : + linearCoefficient * (currentOrder : ℝ) < (p : ℝ) := by + dsimp only [linearCoefficient] + exact_mod_cast hlinear + have hpPos : (0 : ℝ) < p := by + have : 0 < p := by omega + exact_mod_cast this + have hquotientTerm : + linearCoefficient * + (((currentOrder * currentOrder : ℕ) : ℝ) / (p : ℝ)) < + (currentOrder : ℝ) := by + have hratio : + linearCoefficient * (currentOrder : ℝ) / (p : ℝ) < 1 := + (div_lt_one hpPos).2 hlinearReal + calc + linearCoefficient * + (((currentOrder * currentOrder : ℕ) : ℝ) / (p : ℝ)) = + (linearCoefficient * (currentOrder : ℝ) / (p : ℝ)) * + (currentOrder : ℝ) := by + rw [Nat.cast_mul] + ring + _ < 1 * (currentOrder : ℝ) := + mul_lt_mul_of_pos_right hratio horderPos + _ = (currentOrder : ℝ) := one_mul _ + calc + (orderCount : ℝ) * + pairedEulerSevenCurrentOrderEnvelope p currentOrder = + max rootTerm + (linearCoefficient * + (((currentOrder * currentOrder : ℕ) : ℝ) / (p : ℝ))) := by + rw [pairedEulerSevenCurrentOrderEnvelope, + mul_max_of_nonneg _ _ (Nat.cast_nonneg orderCount)] + dsimp only [rootTerm, linearCoefficient] + push_cast + congr 1 <;> ring + _ < (currentOrder : ℝ) := max_lt hrootTerm hquotientTerm + +/-- Finite nonparabolic escape over maximal candidate orders with the exact +χ≤7 cube coefficient `189`. -/ +theorem exists_left_element_escaping_nonparabolic_maximalOrders_eulerSeven + (p : ℕ) [Fact p.Prime] + (E : Type*) [Field E] [Fintype E] [DecidableEq E] [CharP E p] + (alpha beta : E) (Hleft : Subgroup Eˣ) + (rightSubgroup : ℕ → Subgroup Eˣ) + (hrightOrder : + ∀ d ∈ middleGameMaximalOrders p (Nat.card Hleft), + Nat.card (rightSubgroup d) = d) + (hadmissible : + WeightedTraceCurveIsCorvajaZannierAdmissible alpha beta) + (hcurrentOrder : 0 < Nat.card Hleft) + (hp : 1 < p) + (hcube : + 189 * (middleGameMaximalOrders p (Nat.card Hleft)).card ^ 3 < + Nat.card Hleft) + (hlinear : + 24 * (middleGameMaximalOrders p (Nat.card Hleft)).card * + Nat.card Hleft < p) : + ∃ hleft : Hleft, + ∀ d ∈ middleGameMaximalOrders p (Nat.card Hleft), + ∀ hright : rightSubgroup d, + ((hright : Eˣ) ^ 2) ≠ 1 → + weightedSplitTorusTrace alpha beta hleft ≠ + splitTorusTrace hright := by + classical + let orders := middleGameMaximalOrders p (Nat.card Hleft) + let bound : ℕ → ℝ := + fun d ↦ pairedEulerSevenCorvajaZannierTraceUpperBound + p (Nat.card Hleft) d + have hbound : + ∀ d ∈ orders, + ((weightedTraceEquationNonparabolicLeftSupport + alpha beta Hleft (rightSubgroup d)).card : ℝ) ≤ bound d := by + intro d hd + have hd' : d ∈ middleGameMaximalOrders p (Nat.card Hleft) := by + simpa [orders] using hd + have h := + weightedTraceEquationNonparabolicLeftSupport_card_cast_le_pairedEulerSeven + p E alpha beta Hleft (rightSubgroup d) hadmissible + rw [hrightOrder d hd'] at h + simpa [bound] using h + have hsmall : (∑ d ∈ orders, bound d) < (Nat.card Hleft : ℝ) := by + calc + (∑ d ∈ orders, bound d) = + ∑ d ∈ middleGameMaximalOrders p (Nat.card Hleft), + pairedEulerSevenCorvajaZannierTraceUpperBound + p (Nat.card Hleft) d := by + simp [orders, bound] + _ ≤ ((middleGameMaximalOrders p (Nat.card Hleft)).card : ℝ) * + pairedEulerSevenCurrentOrderEnvelope + p (Nat.card Hleft) := + middleGameMaximalPairedEulerSevenSum_le_card_mul_envelope + p (Nat.card Hleft) hp + _ < (Nat.card Hleft : ℝ) := + orderCount_mul_pairedEulerSevenEnvelope_lt_currentOrder + p (Nat.card Hleft) + (middleGameMaximalOrders p (Nat.card Hleft)).card + hcurrentOrder hcube hlinear + obtain ⟨hleft, hleftEscapes⟩ := + exists_left_element_escaping_nonparabolic_orders_of_sum_bound + alpha beta Hleft orders rightSubgroup bound hbound hsmall + refine ⟨hleft, ?_⟩ + intro d hd hright hrightSq + exact hleftEscapes d (by simpa [orders] using hd) hright hrightSq + +end + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/EulerSevenPairedMaximalDivisorOrderEscape.lean b/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/EulerSevenPairedMaximalDivisorOrderEscape.lean new file mode 100644 index 0000000000..2e22b8ad96 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/EulerSevenPairedMaximalDivisorOrderEscape.lean @@ -0,0 +1,133 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.MaximalDivisorOrderEscape +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.EulerSevenPairedMaximalDivisorCorvajaZannierStep + +/-! +# Euler-seven paired nonparabolic order escape + +This is the diagonalized-fiber wiring for the exact cube condition +`189*K^3 < currentOrder`. +-/ + +@[expose] public section + +namespace BGS.Markoff + +theorem + exists_iterate_with_larger_secondRotationOrder_of_diagonalizedFiber_eulerSevenPairedMaximalOrders + (p : ℕ) [Fact p.Prime] [Fintype (quadraticFiniteField p)] + (hpTwo : p ≠ 2) + (delta : ℝ) (hdelta : delta ≤ (1 : ℝ) / 2) + (x : NormalizedPoint (ZMod p)) + (w s : (quadraticFiniteField p)ˣ) + (hw : (w : quadraticFiniteField p) ^ 2 ≠ 1) + (hpoint : algebraMapNormalizedPoint p x = splitFiberPoint w s) + (hadmissible : + WeightedTraceCurveIsCorvajaZannierAdmissible + (s : quadraticFiniteField p) + (splitFiberProduct w * + ((s⁻¹ : (quadraticFiniteField p)ˣ) : quadraticFiniteField p))) + (hbelowEndgame : + (rotationOrder x.u1 : ℝ) < + (p : ℝ) ^ ((1 : ℝ) / 2 + delta)) + (hcube : + 189 * + (middleGameMaximalOrders p (rotationOrder x.u1)).card ^ 3 < + rotationOrder x.u1) + (hlinear : + 24 * (middleGameMaximalOrders p (rotationOrder x.u1)).card * + rotationOrder x.u1 < p) : + ∃ n : ℕ, + rotationOrder x.u1 < + rotationOrder ((normalizedRotate1^[n]) x).u2 := by + classical + let alpha : quadraticFiniteField p := s + let beta : quadraticFiniteField p := + splitFiberProduct w * + ((s⁻¹ : (quadraticFiniteField p)ˣ) : quadraticFiniteField p) + let Hleft : Subgroup (quadraticFiniteField p)ˣ := Subgroup.zpowers w + have htrace : + algebraMap (ZMod p) (quadraticFiniteField p) x.u1 = + splitTorusTrace w := + congrArg NormalizedPoint.u1 hpoint + have horder : orderOf w = rotationOrder x.u1 := by + rw [← rotationOrder_eq_orderOf_extensionEigenvalue x.u1 w hw htrace] + have hleftCard : Nat.card Hleft = rotationOrder x.u1 := by + rw [Nat.card_zpowers, horder] + have hp : 1 < p := (Fact.out : p.Prime).one_lt + have hcurrentOrder : 0 < Nat.card Hleft := by + rw [hleftCard] + exact rotationOrder_pos x.u1 + have hrightOrder : + ∀ d ∈ middleGameMaximalOrders p (Nat.card Hleft), + Nat.card (middleGameRightSubgroup p d) = d := by + intro d hd + exact middleGameMaximalOrder_rightSubgroup_natCard + p (Nat.card Hleft) d hp hd + have hcube' : + 189 * + (middleGameMaximalOrders p (Nat.card Hleft)).card ^ 3 < + Nat.card Hleft := by + rw [hleftCard] + exact hcube + have hlinear' : + 24 * (middleGameMaximalOrders p (Nat.card Hleft)).card * + Nat.card Hleft < p := by + rw [hleftCard] + exact hlinear + obtain ⟨h, hEscapes⟩ := + exists_left_element_escaping_nonparabolic_maximalOrders_eulerSeven + p (quadraticFiniteField p) alpha beta Hleft + (fun d ↦ middleGameRightSubgroup p d) + hrightOrder (by simpa [alpha, beta] using hadmissible) + hcurrentOrder hp hcube' hlinear' + obtain ⟨n, hn⟩ := exists_iterate_splitFiberPoint_eq_mul_zpowers w s h + refine ⟨n, ?_⟩ + let y := (normalizedRotate1^[n]) x + have hyPoint : algebraMapNormalizedPoint p y = + splitFiberPoint w (s * (h : (quadraticFiniteField p)ˣ)) := by + calc + algebraMapNormalizedPoint p y = + (normalizedRotate1^[n]) (algebraMapNormalizedPoint p x) := + algebraMapNormalizedPoint_iterate_normalizedRotate1 p n x + _ = (normalizedRotate1^[n]) (splitFiberPoint w s) := by rw [hpoint] + _ = splitFiberPoint w + (s * (h : (quadraticFiniteField p)ˣ)) := hn + apply lt_of_not_ge + intro hsmall + have hnonparabolicY : y.u2 ^ 2 ≠ 4 := by + intro hparabolic + have hcases := + (normalizedTrace_sq_eq_four_iff_parabolic p y.u2).mp hparabolic + have hthreshold := + endgamePowerThreshold_le_rotationOrder_of_parabolicTrace + p hpTwo delta hdelta y.u2 hcases + have hsmallReal : + (rotationOrder y.u2 : ℝ) ≤ (rotationOrder x.u1 : ℝ) := by + exact_mod_cast hsmall + exact (not_le_of_gt hbelowEndgame) (hthreshold.trans hsmallReal) + obtain ⟨m, hm, hright, hrightTrace, hrightSq⟩ := + exists_middleGameMaximalOrder_nonparabolic_trace + p (rotationOrder x.u1) hpTwo hp y.u2 hnonparabolicY hsmall + have hm' : m ∈ middleGameMaximalOrders p (Nat.card Hleft) := by + rw [hleftCard] + exact hm + apply hEscapes m hm' hright hrightSq + have hyCoordinate := congrArg NormalizedPoint.u2 hyPoint + change algebraMap (ZMod p) (quadraticFiniteField p) y.u2 = + (splitFiberPoint w + (s * (h : (quadraticFiniteField p)ˣ))).u2 at hyCoordinate + rw [splitFiberOrbit_secondCoordinate_eq_weightedSplitTorusTrace] + at hyCoordinate + change weightedSplitTorusTrace alpha beta h = splitTorusTrace hright + rw [← hrightTrace] + simpa [alpha, beta] using hyCoordinate.symm + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/MaximalDivisorCorvajaZannierEscape.lean b/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/MaximalDivisorCorvajaZannierEscape.lean new file mode 100644 index 0000000000..fe1c8d821c --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/MaximalDivisorCorvajaZannierEscape.lean @@ -0,0 +1,123 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.Diagonalization +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.MaximalDivisorOrderEscape +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.TraceCurveWeights +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.WeightedTraceBound + +/-! +# Feeding the weighted trace bound into maximal-divisor escape + +The general Corvaja--Zannier theorem already provides a uniform estimate for +all finite multiplicative subgroups. This adapter applies it only to the +divisibility-maximal right subgroups required by the improved middle game. +-/ + +@[expose] public section + +namespace BGS.Markoff + +/-- Diagonalize a nonzero nonparabolic fiber and apply the maximal-order +escape theorem. -/ +theorem exists_iterate_with_larger_secondRotationOrder_of_nonzero_nonparabolic_maximalOrders + (p : ℕ) [Fact p.Prime] [Fintype (quadraticFiniteField p)] + (hpTwo : p ≠ 2) + (delta : ℝ) (hdelta : delta ≤ (1 : ℝ) / 2) + (x : NormalizedPoint (ZMod p)) (hx : IsNormalizedMarkoff x) + (hnonzero : x.u1 ≠ 0) (hnonparabolic : x.u1 ^ 2 ≠ 4) + (hbelowEndgame : + (rotationOrder x.u1 : ℝ) < (p : ℝ) ^ ((1 : ℝ) / 2 + delta)) + (hcube : + (corvajaZannierCorollaryTwoSafeCoefficient * + (middleGameMaximalOrders p (rotationOrder x.u1)).card) ^ 3 < + rotationOrder x.u1) + (hlinear : + corvajaZannierCorollaryTwoSafeCoefficient * + (middleGameMaximalOrders p (rotationOrder x.u1)).card * + rotationOrder x.u1 < p) + (hCZ : + ∀ (w s : (quadraticFiniteField p)ˣ), + (w : quadraticFiniteField p) ^ 2 ≠ 1 → + algebraMapNormalizedPoint p x = splitFiberPoint w s → + (s : quadraticFiniteField p) * + (splitFiberProduct w * ((s⁻¹ : (quadraticFiniteField p)ˣ) : + quadraticFiniteField p)) ≠ 1 → + ∀ d ∈ middleGameMaximalOrders p (rotationOrder x.u1), + ((weightedTraceEquationSolutions + (s : quadraticFiniteField p) + (splitFiberProduct w * ((s⁻¹ : (quadraticFiniteField p)ˣ) : + quadraticFiniteField p)) + (Subgroup.zpowers w) (middleGameRightSubgroup p d)).card : ℝ) ≤ + corvajaZannierTraceUpperBound p (rotationOrder x.u1) + (Nat.card (middleGameRightSubgroup p d))) : + ∃ n : ℕ, + rotationOrder x.u1 < + rotationOrder ((normalizedRotate1^[n]) x).u2 := by + obtain ⟨w, s, hw, hpoint⟩ := + exists_diagonalizedFiberPoint_of_nonzero_nonparabolic + p hpTwo x hx hnonzero hnonparabolic + exact + exists_iterate_with_larger_secondRotationOrder_of_diagonalizedFiber_maximalOrders + p hpTwo delta hdelta x w s hw hpoint hbelowEndgame hcube hlinear + (hCZ w s hw hpoint) + +/-- The in-repository weighted torsion-intersection theorem supplies every +maximal-order estimate needed by the improved escape step. -/ +theorem exists_iterate_with_larger_secondRotationOrder_of_weightedTraceBound_maximalOrders + (p : ℕ) [Fact p.Prime] [Fintype (quadraticFiniteField p)] + (hpTwo : p ≠ 2) + (delta : ℝ) (hdelta : delta ≤ (1 : ℝ) / 2) + (x : NormalizedPoint (ZMod p)) (hx : IsNormalizedMarkoff x) + (hnonzero : x.u1 ≠ 0) (hnonparabolic : x.u1 ^ 2 ≠ 4) + (hbelowEndgame : + (rotationOrder x.u1 : ℝ) < (p : ℝ) ^ ((1 : ℝ) / 2 + delta)) + (hcube : + (corvajaZannierCorollaryTwoSafeCoefficient * + (middleGameMaximalOrders p (rotationOrder x.u1)).card) ^ 3 < + rotationOrder x.u1) + (hlinear : + corvajaZannierCorollaryTwoSafeCoefficient * + (middleGameMaximalOrders p (rotationOrder x.u1)).card * + rotationOrder x.u1 < p) + (hBound : + WeightedTraceTorsionIntersectionBound p (quadraticFiniteField p)) : + ∃ n : ℕ, + rotationOrder x.u1 < + rotationOrder ((normalizedRotate1^[n]) x).u2 := by + apply + exists_iterate_with_larger_secondRotationOrder_of_nonzero_nonparabolic_maximalOrders + p hpTwo delta hdelta x hx hnonzero hnonparabolic hbelowEndgame + hcube hlinear + intro w s hw hpoint _hnondegenerate d _hd + let alpha : quadraticFiniteField p := s + let beta : quadraticFiniteField p := + splitFiberProduct w * + ((s⁻¹ : (quadraticFiniteField p)ˣ) : quadraticFiniteField p) + let Hleft : Subgroup (quadraticFiniteField p)ˣ := Subgroup.zpowers w + let Hright : Subgroup (quadraticFiniteField p)ˣ := + middleGameRightSubgroup p d + have hadmissible : + WeightedTraceCurveIsCorvajaZannierAdmissible alpha beta := by + simpa [alpha, beta] using + diagonalizedFiber_weightedTraceCurve_isCorvajaZannierAdmissible + p hpTwo x hnonzero w s hw hpoint + have hbound := + weightedTraceEquationSolutions_card_cast_le_of_weightedTraceBound + p (quadraticFiniteField p) hBound alpha beta Hleft Hright hadmissible + have htrace : + algebraMap (ZMod p) (quadraticFiniteField p) x.u1 = + splitTorusTrace w := + congrArg NormalizedPoint.u1 hpoint + have horder : orderOf w = rotationOrder x.u1 := by + rw [← rotationOrder_eq_orderOf_extensionEigenvalue x.u1 w hw htrace] + have hleftCard : Nat.card Hleft = rotationOrder x.u1 := by + rw [Nat.card_zpowers, horder] + simpa [alpha, beta, Hleft, Hright, hleftCard] using hbound + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/MaximalDivisorCorvajaZannierStep.lean b/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/MaximalDivisorCorvajaZannierStep.lean new file mode 100644 index 0000000000..57b07bc265 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/MaximalDivisorCorvajaZannierStep.lean @@ -0,0 +1,242 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.MaximalDivisorOrderCover + +/-! +# Corvaja--Zannier escape over maximal candidate orders + +The published middle-game union runs over every candidate divisor of `p - 1` +or `p + 1`. Divisibility monotonicity of roots-of-unity subgroups shows that +it is enough to run the union over `middleGameMaximalOrders`: every smaller +candidate subgroup is contained in one of these maximal subgroups. + +This file performs the finite union and its numerical reduction. The deep +Corvaja--Zannier estimate remains an explicit hypothesis about the actual +weighted trace-equation solution sets. +-/ + +@[expose] public section + +namespace BGS.Markoff + +variable {E : Type*} [Field E] [Fintype E] + +/-- The Corvaja--Zannier sum over maximal candidate orders is bounded by the +number of those orders times the common current-order envelope. -/ +theorem middleGameMaximalCorvajaZannierSum_le_card_mul_envelope + (p currentOrder : ℕ) (hp : 1 < p) : + (∑ d ∈ middleGameMaximalOrders p currentOrder, + corvajaZannierTraceUpperBound p currentOrder d) ≤ + ((middleGameMaximalOrders p currentOrder).card : ℝ) * + corvajaZannierCurrentOrderEnvelope p currentOrder := by + classical + calc + (∑ d ∈ middleGameMaximalOrders p currentOrder, + corvajaZannierTraceUpperBound p currentOrder d) ≤ + ∑ _d ∈ middleGameMaximalOrders p currentOrder, + corvajaZannierCurrentOrderEnvelope p currentOrder := by + exact Finset.sum_le_sum fun d hd ↦ + corvajaZannierTraceUpperBound_le_currentOrderEnvelope p currentOrder d + (mem_middleGameCandidateOrders_iff.mp + (middleGameMaximalOrders_subset_candidateOrders hp hd)).1 + _ = ((middleGameMaximalOrders p currentOrder).card : ℝ) * + corvajaZannierCurrentOrderEnvelope p currentOrder := by + simp + +/-- A generic version of the two elementary inequalities controlling the +Corvaja--Zannier envelope. It is deliberately parameterized by the number of +orders in the union, so the maximal-divisor cover can use its much smaller +cardinality. + +Writing `K` for `orderCount`, the hypotheses are + +* `(48 K)^3 < currentOrder`; +* `48 K * currentOrder < p`. +-/ +theorem orderCount_mul_corvajaZannierEnvelope_lt_currentOrder + (p currentOrder orderCount : ℕ) + (hcurrentOrder : 0 < currentOrder) + (hcube : + (corvajaZannierCorollaryTwoSafeCoefficient * orderCount) ^ 3 < + currentOrder) + (hlinear : + corvajaZannierCorollaryTwoSafeCoefficient * orderCount * + currentOrder < p) : + (orderCount : ℝ) * + corvajaZannierCurrentOrderEnvelope p currentOrder < + (currentOrder : ℝ) := by + let coefficient : ℕ := + corvajaZannierCorollaryTwoSafeCoefficient * orderCount + have horderPos : (0 : ℝ) < currentOrder := by + exact_mod_cast hcurrentOrder + have horderNonneg : (0 : ℝ) ≤ currentOrder := horderPos.le + have hcoefficientNonneg : (0 : ℝ) ≤ coefficient := by positivity + have hcubeReal : (coefficient : ℝ) ^ (3 : ℕ) < + (currentOrder : ℝ) := by + dsimp [coefficient] + exact_mod_cast hcube + have hcoefficientRoot : + (coefficient : ℝ) < (currentOrder : ℝ) ^ ((1 : ℝ) / 3) := by + have h := (Real.lt_rpow_inv_iff_of_pos hcoefficientNonneg horderNonneg + (by norm_num : (0 : ℝ) < 3)).2 + have h' : (coefficient : ℝ) < + (currentOrder : ℝ) ^ (3 : ℝ)⁻¹ := + h (by simpa [Real.rpow_natCast] using hcubeReal) + simpa only [one_div] using h' + have hrootPositive : + 0 < (((currentOrder * currentOrder : ℕ) : ℝ) ^ + ((1 : ℝ) / 3)) := by + positivity + have hcubeRootIdentity : + (currentOrder : ℝ) ^ ((1 : ℝ) / 3) * + (((currentOrder * currentOrder : ℕ) : ℝ) ^ + ((1 : ℝ) / 3)) = + (currentOrder : ℝ) := by + rw [Nat.cast_mul] + rw [← Real.mul_rpow horderNonneg + (mul_nonneg horderNonneg horderNonneg)] + convert Real.pow_rpow_inv_natCast horderNonneg + (by norm_num : (3 : ℕ) ≠ 0) using 1 + all_goals ring_nf + have hrootTerm : + (coefficient : ℝ) * + (((currentOrder * currentOrder : ℕ) : ℝ) ^ + ((1 : ℝ) / 3)) < + (currentOrder : ℝ) := by + calc + (coefficient : ℝ) * + (((currentOrder * currentOrder : ℕ) : ℝ) ^ + ((1 : ℝ) / 3)) < + (currentOrder : ℝ) ^ ((1 : ℝ) / 3) * + (((currentOrder * currentOrder : ℕ) : ℝ) ^ + ((1 : ℝ) / 3)) := + mul_lt_mul_of_pos_right hcoefficientRoot hrootPositive + _ = (currentOrder : ℝ) := hcubeRootIdentity + have hlinearReal : + (coefficient : ℝ) * (currentOrder : ℝ) < (p : ℝ) := by + dsimp [coefficient] + exact_mod_cast hlinear + have hpPos : (0 : ℝ) < p := by + have : 0 < p := by omega + exact_mod_cast this + have hquotientTerm : + (coefficient : ℝ) * + (((currentOrder * currentOrder : ℕ) : ℝ) / (p : ℝ)) < + (currentOrder : ℝ) := by + have hratio : + (coefficient : ℝ) * (currentOrder : ℝ) / (p : ℝ) < 1 := + (div_lt_one hpPos).2 hlinearReal + calc + (coefficient : ℝ) * + (((currentOrder * currentOrder : ℕ) : ℝ) / (p : ℝ)) = + ((coefficient : ℝ) * (currentOrder : ℝ) / (p : ℝ)) * + (currentOrder : ℝ) := by + push_cast + ring + _ < 1 * (currentOrder : ℝ) := + mul_lt_mul_of_pos_right hratio horderPos + _ = (currentOrder : ℝ) := one_mul _ + calc + (orderCount : ℝ) * + corvajaZannierCurrentOrderEnvelope p currentOrder = + (coefficient : ℝ) * max + ((((currentOrder * currentOrder : ℕ) : ℝ) ^ + ((1 : ℝ) / 3))) + ((((currentOrder * currentOrder : ℕ) : ℝ) / (p : ℝ))) := by + simp only [corvajaZannierCurrentOrderEnvelope] + dsimp [coefficient] + push_cast + ring + _ = max + ((coefficient : ℝ) * + (((currentOrder * currentOrder : ℕ) : ℝ) ^ + ((1 : ℝ) / 3))) + ((coefficient : ℝ) * + (((currentOrder * currentOrder : ℕ) : ℝ) / (p : ℝ))) := + mul_max_of_nonneg _ _ hcoefficientNonneg + _ < (currentOrder : ℝ) := max_lt hrootTerm hquotientTerm + +/-- The finite weighted Corvaja--Zannier escape step over maximal candidate +orders only. -/ +theorem exists_left_element_escaping_of_weightedCorvajaZannierEstimate_maximalOrders + (p : ℕ) (alpha beta : E) (Hleft : Subgroup Eˣ) + (rightSubgroup : ℕ → Subgroup Eˣ) + (hrightOrder : + ∀ d ∈ middleGameMaximalOrders p (Nat.card Hleft), + Nat.card (rightSubgroup d) = d) + (hCZ : alpha * beta ≠ 1 → + ∀ d ∈ middleGameMaximalOrders p (Nat.card Hleft), + ((weightedTraceEquationSolutions alpha beta Hleft + (rightSubgroup d)).card : ℝ) ≤ + corvajaZannierTraceUpperBound p (Nat.card Hleft) + (Nat.card (rightSubgroup d))) + (hnondegenerate : alpha * beta ≠ 1) + (hcurrentOrder : 0 < Nat.card Hleft) + (hp : 1 < p) + (hcube : + (corvajaZannierCorollaryTwoSafeCoefficient * + (middleGameMaximalOrders p (Nat.card Hleft)).card) ^ 3 < + Nat.card Hleft) + (hlinear : + corvajaZannierCorollaryTwoSafeCoefficient * + (middleGameMaximalOrders p (Nat.card Hleft)).card * + Nat.card Hleft < p) : + ∃ hleft : Hleft, + ∀ d ∈ middleGameMaximalOrders p (Nat.card Hleft), + ∀ hright : rightSubgroup d, + weightedSplitTorusTrace alpha beta hleft ≠ + splitTorusTrace hright := by + classical + let orders := middleGameMaximalOrders p (Nat.card Hleft) + let bad := + weightedBadOrderTraceSupport alpha beta Hleft orders rightSubgroup + have hCZIndexed : ∀ d ∈ orders, + ((weightedTraceEquationSolutions alpha beta Hleft + (rightSubgroup d)).card : ℝ) ≤ + corvajaZannierTraceUpperBound p (Nat.card Hleft) d := by + intro d hd + have hd' : d ∈ middleGameMaximalOrders p (Nat.card Hleft) := by + simpa [orders] using hd + have hEstimate := hCZ hnondegenerate d hd' + rw [hrightOrder d hd'] at hEstimate + exact hEstimate + have hbadReal : (bad.card : ℝ) < (Nat.card Hleft : ℝ) := by + calc + (bad.card : ℝ) ≤ + ∑ d ∈ orders, + corvajaZannierTraceUpperBound p (Nat.card Hleft) d := by + exact weightedBadOrderTraceSupport_card_cast_le_sum + alpha beta Hleft orders rightSubgroup _ hCZIndexed + _ ≤ ((middleGameMaximalOrders p (Nat.card Hleft)).card : ℝ) * + corvajaZannierCurrentOrderEnvelope p (Nat.card Hleft) := by + simpa [orders] using + middleGameMaximalCorvajaZannierSum_le_card_mul_envelope + p (Nat.card Hleft) hp + _ < (Nat.card Hleft : ℝ) := + orderCount_mul_corvajaZannierEnvelope_lt_currentOrder + p (Nat.card Hleft) + (middleGameMaximalOrders p (Nat.card Hleft)).card + hcurrentOrder hcube hlinear + have hbad : bad.card < Nat.card Hleft := by + exact_mod_cast hbadReal + have hexists : ∃ hleft : Hleft, hleft ∉ bad := by + by_contra hall + push Not at hall + have hle : (Finset.univ : Finset Hleft).card ≤ bad.card := + Finset.card_le_card fun hleft _ ↦ hall hleft + rw [Finset.card_univ, Fintype.card_eq_nat_card] at hle + exact (Nat.not_le_of_lt hbad) hle + obtain ⟨hleft, hleftNotBad⟩ := hexists + refine ⟨hleft, ?_⟩ + intro d hd hright heq + apply hleftNotBad + exact mem_weightedBadOrderTraceSupport_iff.mpr + ⟨d, by simpa [orders] using hd, hright, heq⟩ + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/MaximalDivisorNonparabolicOrderCover.lean b/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/MaximalDivisorNonparabolicOrderCover.lean new file mode 100644 index 0000000000..7ca9bb8950 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/MaximalDivisorNonparabolicOrderCover.lean @@ -0,0 +1,66 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.MaximalDivisorOrderCover + +/-! +# Nonparabolic witnesses in maximal right-order subgroups + +The maximal-divisor cover already represents every bounded nonparabolic trace +inside a divisibility-maximal right subgroup. This module records the extra +fact needed for inversion pairing: the representing eigenvalue is not fixed +by inversion. +-/ + +@[expose] public section + +namespace BGS.Markoff + +/-- A square-one eigenvalue has parabolic split trace. -/ +theorem splitTorusTrace_sq_eq_four_of_sq_eq_one + {K : Type*} [Field K] (h : Kˣ) (hsq : h ^ 2 = 1) : + (splitTorusTrace h) ^ 2 = 4 := by + have hinv : h = h⁻¹ := by + apply (mul_eq_one_iff_eq_inv.mp) + simpa only [pow_two] using hsq + have hinvValue : ((h⁻¹ : Kˣ) : K) = (h : K) := by + exact congrArg (fun u : Kˣ ↦ (u : K)) hinv.symm + have hsqValue : (h : K) ^ 2 = 1 := by + exact congrArg (fun u : Kˣ ↦ (u : K)) hsq + unfold splitTorusTrace + rw [hinvValue] + calc + ((h : K) + (h : K)) ^ 2 = 4 * (h : K) ^ 2 := by ring + _ = 4 := by rw [hsqValue, mul_one] + +/-- Every bounded nonparabolic trace is represented in a maximal candidate +right subgroup by a non-two-torsion eigenvalue. -/ +theorem exists_middleGameMaximalOrder_nonparabolic_trace + (p currentOrder : ℕ) [Fact p.Prime] + (hpTwo : p ≠ 2) (hp : 1 < p) + (t : ZMod p) (hnonparabolic : t ^ 2 ≠ 4) + (hsmall : rotationOrder t ≤ currentOrder) : + ∃ m ∈ middleGameMaximalOrders p currentOrder, + ∃ h₂ : middleGameRightSubgroup p m, + algebraMap (ZMod p) (quadraticFiniteField p) t = + splitTorusTrace h₂ ∧ + (((h₂ : (quadraticFiniteField p)ˣ) ^ 2) ≠ 1) := by + obtain ⟨m, hm, h₂, htrace⟩ := + exists_middleGameMaximalOrder_trace_of_nonparabolic + p currentOrder hpTwo hp t hnonparabolic hsmall + refine ⟨m, hm, h₂, htrace, ?_⟩ + intro hsq + apply hnonparabolic + apply (algebraMap (ZMod p) (quadraticFiniteField p)).injective + have htraceSq : + (splitTorusTrace (h₂ : (quadraticFiniteField p)ˣ)) ^ 2 = 4 := + splitTorusTrace_sq_eq_four_of_sq_eq_one + (h₂ : (quadraticFiniteField p)ˣ) hsq + simpa only [map_pow, map_ofNat, htrace] using htraceSq + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/MaximalDivisorOrderCover.lean b/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/MaximalDivisorOrderCover.lean new file mode 100644 index 0000000000..27a3c9b1a6 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/MaximalDivisorOrderCover.lean @@ -0,0 +1,106 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.OrderEscape +public import LeanPool.MarkoffModP.BGS.NumberTheory.MaximalDivisorBounds + +/-! +# Maximal candidate orders in the Markoff middle game + +Every ordinary candidate order divides a divisibility-maximal candidate, and +the canonical roots-of-unity subgroups are monotone under that divisibility. +Hence the Corvaja--Zannier union only needs maximal orders. +-/ + +@[expose] public section + +namespace BGS.Markoff + +open BGS.NumberTheory + +def middleGameMaximalOrders (p currentOrder : ℕ) : Finset ℕ := + maximalDivisorsBelow (p - 1) (currentOrder + 1) ∪ + maximalDivisorsBelow (p + 1) (currentOrder + 1) + +theorem middleGameMaximalOrders_card_le + (p currentOrder : ℕ) : + (middleGameMaximalOrders p currentOrder).card ≤ + (maximalDivisorsBelow (p - 1) (currentOrder + 1)).card + + (maximalDivisorsBelow (p + 1) (currentOrder + 1)).card := + Finset.card_union_le _ _ + +theorem middleGameMaximalOrders_subset_candidateOrders + {p currentOrder : ℕ} (hp : 1 < p) : + middleGameMaximalOrders p currentOrder ⊆ + middleGameCandidateOrders p currentOrder := by + intro m hm + rw [middleGameMaximalOrders, Finset.mem_union] at hm + rw [mem_middleGameCandidateOrders_iff] + rcases hm with hm | hm + · have hdata := mem_maximalDivisorsBelow_iff.mp hm + refine ⟨by omega, Or.inl ?_⟩ + exact ⟨(Nat.mem_divisors.mp hdata.1).1, by omega⟩ + · have hdata := mem_maximalDivisorsBelow_iff.mp hm + exact ⟨by omega, Or.inr (Nat.mem_divisors.mp hdata.1).1⟩ + +theorem exists_dvd_middleGameMaximalOrder + {p currentOrder d : ℕ} (hp : 1 < p) + (hd : d ∈ middleGameCandidateOrders p currentOrder) : + ∃ m ∈ middleGameMaximalOrders p currentOrder, d ∣ m := by + have hdbound : d < currentOrder + 1 := + Nat.lt_succ_of_le (mem_middleGameCandidateOrders_iff.mp hd).1 + rcases (mem_middleGameCandidateOrders_iff.mp hd).2 with hminus | hplus + · obtain ⟨m, hm, hdm⟩ := + exists_dvd_maximalDivisorBelow hminus.2 hminus.1 hdbound + exact ⟨m, by + rw [middleGameMaximalOrders, Finset.mem_union] + exact Or.inl hm, hdm⟩ + · obtain ⟨m, hm, hdm⟩ := + exists_dvd_maximalDivisorBelow (by omega : p + 1 ≠ 0) hplus hdbound + exact ⟨m, by + rw [middleGameMaximalOrders, Finset.mem_union] + exact Or.inr hm, hdm⟩ + +theorem middleGameRightSubgroup_mono + (p d m : ℕ) [Fact p.Prime] (hdm : d ∣ m) : + middleGameRightSubgroup p d ≤ middleGameRightSubgroup p m := by + intro u hu + rw [mem_middleGameRightSubgroup_iff_pow_eq_one] at hu ⊢ + obtain ⟨k, rfl⟩ := hdm + rw [pow_mul, hu, one_pow] + +theorem exists_middleGameMaximalOrder_trace_of_nonparabolic + (p currentOrder : ℕ) [Fact p.Prime] + (hpTwo : p ≠ 2) (hp : 1 < p) + (t : ZMod p) (hnonparabolic : t ^ 2 ≠ 4) + (hsmall : rotationOrder t ≤ currentOrder) : + ∃ m ∈ middleGameMaximalOrders p currentOrder, + ∃ h₂ : middleGameRightSubgroup p m, + algebraMap (ZMod p) (quadraticFiniteField p) t = + splitTorusTrace h₂ := by + have hd : + rotationOrder t ∈ middleGameCandidateOrders p currentOrder := + rotationOrder_mem_middleGameCandidateOrders_of_nonparabolic + p currentOrder hpTwo t hnonparabolic hsmall + obtain ⟨m, hm, horderDvd⟩ := + exists_dvd_middleGameMaximalOrder hp hd + obtain ⟨h₂, htrace⟩ := + exists_middleGameRightSubgroup_trace_of_nonparabolic_rotationOrder + p (rotationOrder t) hpTwo t hnonparabolic rfl + let h₂max : middleGameRightSubgroup p m := + ⟨h₂, middleGameRightSubgroup_mono p (rotationOrder t) m horderDvd h₂.2⟩ + exact ⟨m, hm, h₂max, htrace⟩ + +theorem middleGameMaximalOrder_rightSubgroup_natCard + (p currentOrder m : ℕ) [Fact p.Prime] (hp : 1 < p) + (hm : m ∈ middleGameMaximalOrders p currentOrder) : + Nat.card (middleGameRightSubgroup p m) = m := + middleGameRightSubgroup_natCard p currentOrder m + (middleGameMaximalOrders_subset_candidateOrders hp hm) + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/MaximalDivisorOrderEscape.lean b/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/MaximalDivisorOrderEscape.lean new file mode 100644 index 0000000000..2eaba74132 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/MaximalDivisorOrderEscape.lean @@ -0,0 +1,148 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.MaximalDivisorCorvajaZannierStep + +/-! +# Nonparabolic order escape using maximal divisors + +This is the geometric middle-game step with the maximal-divisor cover wired +all the way through. The Corvaja--Zannier hypothesis and both numerical +inequalities are required only for divisibility-maximal candidate orders. +-/ + +@[expose] public section + +namespace BGS.Markoff + +/-- Complete nonparabolic order escape from a diagonalized fiber, with the +Corvaja--Zannier union restricted to maximal candidate orders. -/ +theorem exists_iterate_with_larger_secondRotationOrder_of_diagonalizedFiber_maximalOrders + (p : ℕ) [Fact p.Prime] [Fintype (quadraticFiniteField p)] + (hpTwo : p ≠ 2) + (delta : ℝ) (hdelta : delta ≤ (1 : ℝ) / 2) + (x : NormalizedPoint (ZMod p)) + (w s : (quadraticFiniteField p)ˣ) + (hw : (w : quadraticFiniteField p) ^ 2 ≠ 1) + (hpoint : algebraMapNormalizedPoint p x = splitFiberPoint w s) + (hbelowEndgame : + (rotationOrder x.u1 : ℝ) < (p : ℝ) ^ ((1 : ℝ) / 2 + delta)) + (hcube : + (corvajaZannierCorollaryTwoSafeCoefficient * + (middleGameMaximalOrders p (rotationOrder x.u1)).card) ^ 3 < + rotationOrder x.u1) + (hlinear : + corvajaZannierCorollaryTwoSafeCoefficient * + (middleGameMaximalOrders p (rotationOrder x.u1)).card * + rotationOrder x.u1 < p) + (hCZ : + (s : quadraticFiniteField p) * + (splitFiberProduct w * ((s⁻¹ : (quadraticFiniteField p)ˣ) : + quadraticFiniteField p)) ≠ 1 → + ∀ d ∈ middleGameMaximalOrders p (rotationOrder x.u1), + ((weightedTraceEquationSolutions + (s : quadraticFiniteField p) + (splitFiberProduct w * ((s⁻¹ : (quadraticFiniteField p)ˣ) : + quadraticFiniteField p)) + (Subgroup.zpowers w) (middleGameRightSubgroup p d)).card : ℝ) ≤ + corvajaZannierTraceUpperBound p (rotationOrder x.u1) + (Nat.card (middleGameRightSubgroup p d))) : + ∃ n : ℕ, + rotationOrder x.u1 < + rotationOrder ((normalizedRotate1^[n]) x).u2 := by + let alpha : quadraticFiniteField p := s + let beta : quadraticFiniteField p := + splitFiberProduct w * + ((s⁻¹ : (quadraticFiniteField p)ˣ) : quadraticFiniteField p) + let Hleft : Subgroup (quadraticFiniteField p)ˣ := Subgroup.zpowers w + have htrace : + algebraMap (ZMod p) (quadraticFiniteField p) x.u1 = + splitTorusTrace w := + congrArg NormalizedPoint.u1 hpoint + have horder : orderOf w = rotationOrder x.u1 := by + rw [← rotationOrder_eq_orderOf_extensionEigenvalue x.u1 w hw htrace] + have hleftCard : Nat.card Hleft = rotationOrder x.u1 := by + rw [Nat.card_zpowers, horder] + have hp : 1 < p := (Fact.out : p.Prime).one_lt + have hfour : (4 : quadraticFiniteField p) ≠ 0 := by + exact (map_ne_zero + (algebraMap (ZMod p) (quadraticFiniteField p))).mpr (by + intro hzero + have hpDvd : p ∣ 4 := (ZMod.natCast_eq_zero_iff 4 p).mp hzero + have hpPrime := (Fact.out : p.Prime) + have hpDvdPow : p ∣ 2 ^ 2 := by simpa using hpDvd + have hpDvdTwo : p ∣ 2 := hpPrime.dvd_of_dvd_pow hpDvdPow + have hpLeTwo : p ≤ 2 := Nat.le_of_dvd (by norm_num) hpDvdTwo + exact hpTwo (Nat.le_antisymm hpLeTwo hpPrime.two_le)) + have hnondegenerate : alpha * beta ≠ 1 := by + rw [show alpha * beta = splitFiberProduct w by + exact splitFiberOrbit_weights_mul w s] + exact splitFiberProduct_ne_one_of_four_ne_zero w hfour + have hcurrentOrder : 0 < Nat.card Hleft := by + rw [hleftCard] + exact rotationOrder_pos x.u1 + have hrightOrder : + ∀ d ∈ middleGameMaximalOrders p (Nat.card Hleft), + Nat.card (middleGameRightSubgroup p d) = d := by + intro d hd + exact middleGameMaximalOrder_rightSubgroup_natCard + p (Nat.card Hleft) d hp hd + have hCZ' : alpha * beta ≠ 1 → + ∀ d ∈ middleGameMaximalOrders p (Nat.card Hleft), + ((weightedTraceEquationSolutions alpha beta Hleft + (middleGameRightSubgroup p d)).card : ℝ) ≤ + corvajaZannierTraceUpperBound p (Nat.card Hleft) + (Nat.card (middleGameRightSubgroup p d)) := by + intro _ d hd + simpa [alpha, beta, Hleft, hleftCard] using + hCZ hnondegenerate d (by simpa [hleftCard] using hd) + obtain ⟨h, hEscapes⟩ := + exists_left_element_escaping_of_weightedCorvajaZannierEstimate_maximalOrders + p alpha beta Hleft (fun d ↦ middleGameRightSubgroup p d) + hrightOrder hCZ' hnondegenerate hcurrentOrder hp + (by simpa [hleftCard] using hcube) + (by simpa [hleftCard] using hlinear) + obtain ⟨n, hn⟩ := exists_iterate_splitFiberPoint_eq_mul_zpowers w s h + refine ⟨n, ?_⟩ + let y := (normalizedRotate1^[n]) x + have hyPoint : algebraMapNormalizedPoint p y = + splitFiberPoint w (s * (h : (quadraticFiniteField p)ˣ)) := by + calc + algebraMapNormalizedPoint p y = + (normalizedRotate1^[n]) (algebraMapNormalizedPoint p x) := + algebraMapNormalizedPoint_iterate_normalizedRotate1 p n x + _ = (normalizedRotate1^[n]) (splitFiberPoint w s) := by rw [hpoint] + _ = splitFiberPoint w + (s * (h : (quadraticFiniteField p)ˣ)) := hn + apply lt_of_not_ge + intro hsmall + have hnonparabolicY : y.u2 ^ 2 ≠ 4 := by + intro hparabolic + have hcases := + (normalizedTrace_sq_eq_four_iff_parabolic p y.u2).mp hparabolic + have hthreshold := + endgamePowerThreshold_le_rotationOrder_of_parabolicTrace + p hpTwo delta hdelta y.u2 hcases + have hsmallReal : + (rotationOrder y.u2 : ℝ) ≤ (rotationOrder x.u1 : ℝ) := by + exact_mod_cast hsmall + exact (not_le_of_gt hbelowEndgame) (hthreshold.trans hsmallReal) + obtain ⟨m, hm, hright, hrightTrace⟩ := + exists_middleGameMaximalOrder_trace_of_nonparabolic + p (rotationOrder x.u1) hpTwo hp y.u2 hnonparabolicY hsmall + apply hEscapes m (by simpa [hleftCard] using hm) hright + have hyCoordinate := congrArg NormalizedPoint.u2 hyPoint + change algebraMap (ZMod p) (quadraticFiniteField p) y.u2 = + (splitFiberPoint w + (s * (h : (quadraticFiniteField p)ˣ))).u2 at hyCoordinate + rw [splitFiberOrbit_secondCoordinate_eq_weightedSplitTorusTrace] at hyCoordinate + change weightedSplitTorusTrace alpha beta h = splitTorusTrace hright + rw [← hrightTrace] + simpa [alpha, beta] using hyCoordinate.symm + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/MoveWiring.lean b/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/MoveWiring.lean new file mode 100644 index 0000000000..605d17d6b8 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/MoveWiring.lean @@ -0,0 +1,188 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Core.ConicParametrization +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.CorvajaZannierStep +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.Geometry + +/-! +# Wiring the middle-game trace escape to Markoff moves + +The orbit of a split fiber point with parameter `s` is parametrized by the coset +`s * Subgroup.zpowers w`. Its second coordinate is therefore a *scaled* twisted trace, not +the unscaled subgroup trace used in `MiddleGameCorvajaZannierStep`. The first two theorems make +this discrepancy explicit. + +For the distinguished parameter `s = 1`, the scaling disappears. The final theorem wires the +existing Corvaja--Zannier escape theorem all the way to a point in the same rotation orbit whose +second coordinate has strictly larger rotation order. Its remaining `htraceCoverage` hypothesis +states the separate split/nonsplit classification interface that must be constructed for the +chosen family of right subgroups. +-/ + +@[expose] public section + +namespace BGS.Markoff + +variable {E : Type*} [Field E] + +/-- The exact second-coordinate formula on a translated split rotation orbit. The factor `s` +and the replacement of `splitFiberProduct w` by `splitFiberProduct w / s^2` are indispensable. -/ +theorem splitFiberOrbit_secondCoordinate_eq_scaledTwistedTrace + (w s h : Eˣ) : + (splitFiberPoint w (s * h)).u2 = + (s : E) * twistedUnitTrace + (splitFiberProduct w / (s : E) ^ 2) h := by + simp only [splitFiberPoint, twistedUnitTrace] + change (s : E) * h + + splitFiberProduct w * (((s * h)⁻¹ : Eˣ) : E) = + (s : E) * + ((h : E) + (splitFiberProduct w / (s : E) ^ 2) * ((h⁻¹ : Eˣ) : E)) + simp only [Units.val_mul, Units.val_inv_eq_inv_val] + field_simp [Units.ne_zero s, Units.ne_zero h] + +/-- Source-faithful weighted form of the orbit-coordinate identity. Here +`alpha = s`, `beta = splitFiberProduct w / s`, and hence `alpha * beta` is the invariant +`splitFiberProduct w`. This is the correct subgroup equation for an arbitrary starting point; +it avoids incorrectly replacing a coset by a subgroup. -/ +theorem splitFiberOrbit_secondCoordinate_eq_weightedSplitTorusTrace + (w s h : Eˣ) : + (splitFiberPoint w (s * h)).u2 = + weightedSplitTorusTrace (s : E) + (splitFiberProduct w * ((s⁻¹ : Eˣ) : E)) h := by + rw [splitFiberOrbit_secondCoordinate_eq_scaledTwistedTrace] + simp only [twistedUnitTrace, weightedSplitTorusTrace, Units.val_inv_eq_inv_val] + field_simp [Units.ne_zero s] + +/-- The product of the two weights in the preceding identity is exactly the fiber invariant. +Thus the paper's nondegeneracy condition is `alpha * beta != 1`. -/ +theorem splitFiberOrbit_weights_mul (w s : Eˣ) : + (s : E) * (splitFiberProduct w * ((s⁻¹ : Eˣ) : E)) = splitFiberProduct w := by + simp only [Units.val_inv_eq_inv_val] + field_simp [Units.ne_zero s] + +/-- Every translated parameter `s * h` with `h` in the cyclic subgroup generated by `w` is an +actual forward iterate of the normalized Markoff rotation through `splitFiberPoint w s`. -/ +theorem exists_iterate_splitFiberPoint_eq_mul_zpowers + [Finite E] (w s : Eˣ) (h : Subgroup.zpowers w) : + ∃ n : ℕ, + (normalizedRotate1^[n]) (splitFiberPoint w s) = + splitFiberPoint w (s * (h : Eˣ)) := by + have hhPowers : (h : Eˣ) ∈ Submonoid.powers w := + mem_powers_iff_mem_zpowers.mpr h.property + obtain ⟨n, hn⟩ := (Submonoid.mem_powers_iff (h : Eˣ) w).mp hhPowers + refine ⟨n, ?_⟩ + rw [iterate_normalizedRotate1_splitFiberPoint] + congr 1 + exact congrArg (fun u : Eˣ ↦ s * u) hn + +/-- At the base parameter `1`, the orbit-coordinate formula is exactly the unscaled trace +equation used by the Corvaja--Zannier counting module. -/ +theorem splitFiberBaseOrbit_secondCoordinate_eq_twistedUnitTrace + (w : Eˣ) (h : Subgroup.zpowers w) : + (splitFiberPoint w (h : Eˣ)).u2 = + twistedUnitTrace (splitFiberProduct w) (h : Eˣ) := by + simpa using splitFiberOrbit_secondCoordinate_eq_scaledTwistedTrace w 1 (h : Eˣ) + +section NonsplitFiber + +variable (p : ℕ) [Fact p.Prime] + +/-- The nonsplit conic parametrization has the same translated-coset obstruction after scalar +extension to the quadratic field. This is the exact formula that an eventual coset form of the +Corvaja--Zannier estimate must consume. -/ +theorem algebraMap_quadraticNormFiberOrbit_secondCoordinate_eq_scaledTwistedTrace + (t : ZMod p) (ht : t ^ 2 ≠ 4) (ht0 : t ≠ 0) + (w : quadraticNormOneTorus p) (htrace : quadraticNormOneTrace p w = t) + (s : ↑(quadraticConicNormFiber p t ht ht0)) + (h : quadraticNormOneTorus p) : + algebraMap (ZMod p) (quadraticFiniteField p) + (quadraticNormFiberPoint p t ht ht0 w + (quadraticNormFiberMulNormOne p + (quadraticFiberProductUnit p t ht ht0) s h)).u2 = + (s.1 : quadraticFiniteField p) * + twistedUnitTrace + (splitFiberProduct (w : (quadraticFiniteField p)ˣ) / + (s.1 : quadraticFiniteField p) ^ 2) + (h : (quadraticFiniteField p)ˣ) := by + have hpoint := algebraMap_quadraticNormFiberPoint p t ht ht0 w htrace + (quadraticNormFiberMulNormOne p (quadraticFiberProductUnit p t ht ht0) s h) + have hcoordinate := congrArg NormalizedPoint.u2 hpoint + change algebraMap (ZMod p) (quadraticFiniteField p) + (quadraticNormFiberPoint p t ht ht0 w + (quadraticNormFiberMulNormOne p + (quadraticFiberProductUnit p t ht ht0) s h)).u2 = + (splitFiberPoint (w : (quadraticFiniteField p)ˣ) + (s.1 * (h : (quadraticFiniteField p)ˣ))).u2 at hcoordinate + rw [hcoordinate] + exact splitFiberOrbit_secondCoordinate_eq_scaledTwistedTrace + (w : (quadraticFiniteField p)ˣ) s.1 (h : (quadraticFiniteField p)ˣ) + +end NonsplitFiber + +section FiniteSplitField + +variable [Fintype E] + +/-- The Corvaja--Zannier escape, specialized to the cyclic subgroup generated by the current +split eigenvalue, produces an actual Markoff rotation iterate whose second-coordinate order is +strictly larger. + +`htraceCoverage` is not the deep Corvaja--Zannier bound. It is the still-missing concrete +classification assertion that every trace of order at most the current order is represented in +the chosen indexed right subgroup. Keeping it explicit prevents the split and norm-one torus +cases from being conflated. -/ +theorem exists_splitFiberBaseOrbitPoint_with_larger_secondRotationOrder + (p : ℕ) (w : Eˣ) + (rightSubgroup : ℕ → Subgroup Eˣ) + (hrightOrder : + ∀ d ∈ middleGameCandidateOrders p (Nat.card (Subgroup.zpowers w)), + Nat.card (rightSubgroup d) = d) + (hCZ : splitFiberProduct w ≠ 1 → + ∀ d ∈ middleGameCandidateOrders p (Nat.card (Subgroup.zpowers w)), + ((traceEquationSolutions (splitFiberProduct w) (Subgroup.zpowers w) + (rightSubgroup d)).card : ℝ) ≤ + corvajaZannierTraceUpperBound p (Nat.card (Subgroup.zpowers w)) + (Nat.card (rightSubgroup d))) + (hsigma : splitFiberProduct w ≠ 1) + (hcurrentOrder : 0 < Nat.card (Subgroup.zpowers w)) + (hcube : + (corvajaZannierCorollaryTwoSafeCoefficient * + ((p - 1).divisors.card + (p + 1).divisors.card)) ^ 3 < + Nat.card (Subgroup.zpowers w)) + (hlinear : + corvajaZannierCorollaryTwoSafeCoefficient * + ((p - 1).divisors.card + (p + 1).divisors.card) * + Nat.card (Subgroup.zpowers w) < p) + (htraceCoverage : + ∀ t : E, rotationOrder t ≤ Nat.card (Subgroup.zpowers w) → + ∃ d ∈ middleGameCandidateOrders p (Nat.card (Subgroup.zpowers w)), + ∃ h₂ : rightSubgroup d, t = twistedUnitTrace 1 h₂) : + ∃ h : Subgroup.zpowers w, + Nat.card (Subgroup.zpowers w) < + rotationOrder (splitFiberPoint w (h : Eˣ)).u2 ∧ + ∃ n : ℕ, + (normalizedRotate1^[n]) (splitFiberPoint w 1) = + splitFiberPoint w (h : Eˣ) := by + obtain ⟨h, hEscapes⟩ := + exists_left_element_escaping_of_corvajaZannierEstimate_and_sizeBounds + p (splitFiberProduct w) (Subgroup.zpowers w) rightSubgroup + hrightOrder hCZ hsigma hcurrentOrder hcube hlinear + refine ⟨h, ?_, ?_⟩ + · apply lt_of_not_ge + intro hsmall + obtain ⟨d, hd, h₂, htrace⟩ := + htraceCoverage (splitFiberPoint w (h : Eˣ)).u2 hsmall + exact hEscapes d hd h₂ <| by + rw [← htrace] + exact (splitFiberBaseOrbit_secondCoordinate_eq_twistedUnitTrace w h).symm + · simpa using exists_iterate_splitFiberPoint_eq_mul_zpowers w 1 h + +end FiniteSplitField + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/NonparabolicUnionBound.lean b/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/NonparabolicUnionBound.lean new file mode 100644 index 0000000000..569f81ddbf --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/NonparabolicUnionBound.lean @@ -0,0 +1,112 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.RightInversionPairing + +/-! +# Finite unions of nonparabolic trace supports + +The middle game only needs to exclude right traces coming from nonparabolic +coordinates: a parabolic target already lies above the endgame threshold. +This module packages that logical split before any numerical estimate is +inserted. In particular, the inversion-pairing factor can be applied to each +right subgroup without counting its two fixed points. +-/ + +@[expose] public section + +namespace BGS.Markoff + +variable {E : Type*} [Field E] [Fintype E] + +/-- Left elements meeting a nonparabolic point in one of a finite family of +right subgroups. -/ +noncomputable def weightedNonparabolicBadOrderTraceSupport + (alpha beta : E) (Hleft : Subgroup Eˣ) (orders : Finset ℕ) + (rightSubgroup : ℕ → Subgroup Eˣ) : Finset Hleft := by + classical + exact orders.biUnion fun d ↦ + weightedTraceEquationNonparabolicLeftSupport + alpha beta Hleft (rightSubgroup d) + +@[simp] +theorem mem_weightedNonparabolicBadOrderTraceSupport_iff + {alpha beta : E} {Hleft : Subgroup Eˣ} {orders : Finset ℕ} + {rightSubgroup : ℕ → Subgroup Eˣ} {hleft : Hleft} : + hleft ∈ weightedNonparabolicBadOrderTraceSupport + alpha beta Hleft orders rightSubgroup ↔ + ∃ d ∈ orders, ∃ hright : rightSubgroup d, + weightedSplitTorusTrace alpha beta hleft = + splitTorusTrace hright ∧ + ((hright : Eˣ) ^ 2) ≠ 1 := by + classical + simp [weightedNonparabolicBadOrderTraceSupport] + +/-- Bounds on the individual nonparabolic left supports sum over an arbitrary +finite family of candidate right subgroups. -/ +theorem weightedNonparabolicBadOrderTraceSupport_card_cast_le_sum + (alpha beta : E) (Hleft : Subgroup Eˣ) (orders : Finset ℕ) + (rightSubgroup : ℕ → Subgroup Eˣ) (bound : ℕ → ℝ) + (hbound : ∀ d ∈ orders, + ((weightedTraceEquationNonparabolicLeftSupport + alpha beta Hleft (rightSubgroup d)).card : ℝ) ≤ bound d) : + ((weightedNonparabolicBadOrderTraceSupport + alpha beta Hleft orders rightSubgroup).card : ℝ) ≤ + ∑ d ∈ orders, bound d := by + classical + calc + ((weightedNonparabolicBadOrderTraceSupport + alpha beta Hleft orders rightSubgroup).card : ℝ) ≤ + ∑ d ∈ orders, + ((weightedTraceEquationNonparabolicLeftSupport + alpha beta Hleft (rightSubgroup d)).card : ℝ) := by + exact_mod_cast (Finset.card_biUnion_le : + (weightedNonparabolicBadOrderTraceSupport + alpha beta Hleft orders rightSubgroup).card ≤ + ∑ d ∈ orders, + (weightedTraceEquationNonparabolicLeftSupport + alpha beta Hleft (rightSubgroup d)).card) + _ ≤ ∑ d ∈ orders, bound d := Finset.sum_le_sum hbound + +/-- If the summed nonparabolic support bound is smaller than the left +subgroup, one left element avoids every nonparabolic candidate trace. -/ +theorem exists_left_element_escaping_nonparabolic_orders_of_sum_bound + (alpha beta : E) (Hleft : Subgroup Eˣ) (orders : Finset ℕ) + (rightSubgroup : ℕ → Subgroup Eˣ) (bound : ℕ → ℝ) + (hbound : ∀ d ∈ orders, + ((weightedTraceEquationNonparabolicLeftSupport + alpha beta Hleft (rightSubgroup d)).card : ℝ) ≤ bound d) + (hsmall : (∑ d ∈ orders, bound d) < Nat.card Hleft) : + ∃ hleft : Hleft, ∀ d ∈ orders, ∀ hright : rightSubgroup d, + ((hright : Eˣ) ^ 2) ≠ 1 → + weightedSplitTorusTrace alpha beta hleft ≠ + splitTorusTrace hright := by + classical + let bad := + weightedNonparabolicBadOrderTraceSupport + alpha beta Hleft orders rightSubgroup + have hbadReal : (bad.card : ℝ) < (Nat.card Hleft : ℝ) := + (weightedNonparabolicBadOrderTraceSupport_card_cast_le_sum + alpha beta Hleft orders rightSubgroup bound hbound).trans_lt hsmall + have hbad : bad.card < Nat.card Hleft := by + exact_mod_cast hbadReal + have hexists : ∃ hleft : Hleft, hleft ∉ bad := by + by_contra hall + push Not at hall + have hle : (Finset.univ : Finset Hleft).card ≤ bad.card := + Finset.card_le_card fun hleft _ ↦ hall hleft + rw [Finset.card_univ, Fintype.card_eq_nat_card] at hle + exact (Nat.not_le_of_lt hbad) hle + obtain ⟨hleft, hleftNotBad⟩ := hexists + refine ⟨hleft, ?_⟩ + intro d hd hright hrightSq heq + apply hleftNotBad + exact mem_weightedNonparabolicBadOrderTraceSupport_iff.mpr + ⟨d, hd, hright, heq, hrightSq⟩ + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/OrderEscape.lean b/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/OrderEscape.lean new file mode 100644 index 0000000000..aedbe2c13d --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/OrderEscape.lean @@ -0,0 +1,192 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.MoveWiring +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.ParabolicEscape +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.RightSubgroups +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.WeightedTraceEquation + +/-! +# The nonparabolic middle-game order-escape step + +This module composes the weighted finite escape, the concrete roots-of-unity right subgroups, +the split/nonsplit trace classification, and the weighted coset coordinate identity. The only +deep input is the weighted Corvaja--Zannier cardinal estimate on the actual solution finsets. +-/ + +@[expose] public section + +namespace BGS.Markoff + +/-- Scalar extension commutes with every iterate of the normalized rotation. -/ +theorem algebraMapNormalizedPoint_iterate_normalizedRotate1 + (p n : ℕ) [Fact p.Prime] (x : NormalizedPoint (ZMod p)) : + algebraMapNormalizedPoint p ((normalizedRotate1^[n]) x) = + (normalizedRotate1^[n]) (algebraMapNormalizedPoint p x) := by + induction n with + | zero => rfl + | succ n ih => + rw [Function.iterate_succ_apply', Function.iterate_succ_apply', + algebraMapNormalizedPoint_normalizedRotate1, ih] + +/-- A nonparabolic trace whose rotation order is at most `currentOrder` has a candidate order +dividing `p - 1` or `p + 1`. -/ +theorem rotationOrder_mem_middleGameCandidateOrders_of_nonparabolic + (p currentOrder : ℕ) [Fact p.Prime] (hpTwo : p ≠ 2) + (t : ZMod p) (hnonparabolic : t ^ 2 ≠ 4) + (hsmall : rotationOrder t ≤ currentOrder) : + rotationOrder t ∈ middleGameCandidateOrders p currentOrder := by + have hpMinus : p - 1 ≠ 0 := by + have hpLower := (Fact.out : p.Prime).two_le + omega + rcases exists_split_or_quadraticNormOneTrace p hpTwo t hnonparabolic with + ⟨w, htrace, hw⟩ | ⟨w, htrace, hw⟩ + · have horder : orderOf w = rotationOrder t := by + rw [← rotationOrder_splitTorusTrace w hw, htrace] + have hdvd : rotationOrder t ∣ p - 1 := by + rw [← horder] + simpa [ZMod.card_units_eq_totient, Nat.totient_prime (Fact.out : p.Prime)] using + orderOf_dvd_natCard w + exact mem_middleGameCandidateOrders_iff.mpr + ⟨hsmall, Or.inl ⟨hdvd, hpMinus⟩⟩ + · have horder : orderOf w = rotationOrder t := by + rw [← rotationOrder_quadraticNormOneTrace p w hw, htrace] + have hdvd : rotationOrder t ∣ p + 1 := by + rw [← horder, ← quadraticNormOneTorus_natCard p] + exact orderOf_dvd_natCard w + exact mem_middleGameCandidateOrders_iff.mpr ⟨hsmall, Or.inr hdvd⟩ + +/-- The split-fiber invariant is never one in odd characteristic. -/ +theorem splitFiberProduct_ne_one_of_four_ne_zero + {E : Type*} [Field E] (w : Eˣ) (hfour : (4 : E) ≠ 0) : + splitFiberProduct w ≠ 1 := by + intro hone + by_cases hdenom : splitTorusTrace w ^ 2 - 4 = 0 + · simp [splitFiberProduct, hdenom] at hone + · rw [splitFiberProduct] at hone + field_simp [hdenom] at hone + exact hfour (by linear_combination hone) + +/-- Complete nonparabolic order escape from a diagonalized presentation of the current fiber. + +The numeric hypotheses are the already-isolated finite middle-game range. `hCZ` is the sole +deep premise: the weighted Corvaja--Zannier estimate for the actual cyclic left subgroup and the +canonical right subgroups. -/ +theorem exists_iterate_with_larger_secondRotationOrder_of_diagonalizedFiber + (p : ℕ) [Fact p.Prime] [Fintype (quadraticFiniteField p)] (hpTwo : p ≠ 2) + (delta : ℝ) (hdelta : delta ≤ (1 : ℝ) / 2) + (x : NormalizedPoint (ZMod p)) + (w s : (quadraticFiniteField p)ˣ) + (hw : (w : quadraticFiniteField p) ^ 2 ≠ 1) + (hpoint : algebraMapNormalizedPoint p x = splitFiberPoint w s) + (hbelowEndgame : + (rotationOrder x.u1 : ℝ) < (p : ℝ) ^ ((1 : ℝ) / 2 + delta)) + (hcube : + (corvajaZannierCorollaryTwoSafeCoefficient * + ((p - 1).divisors.card + (p + 1).divisors.card)) ^ 3 < + rotationOrder x.u1) + (hlinear : + corvajaZannierCorollaryTwoSafeCoefficient * + ((p - 1).divisors.card + (p + 1).divisors.card) * + rotationOrder x.u1 < p) + (hCZ : + (s : quadraticFiniteField p) * + (splitFiberProduct w * ((s⁻¹ : (quadraticFiniteField p)ˣ) : + quadraticFiniteField p)) ≠ 1 → + ∀ d ∈ middleGameCandidateOrders p (rotationOrder x.u1), + ((weightedTraceEquationSolutions + (s : quadraticFiniteField p) + (splitFiberProduct w * ((s⁻¹ : (quadraticFiniteField p)ˣ) : + quadraticFiniteField p)) + (Subgroup.zpowers w) (middleGameRightSubgroup p d)).card : ℝ) ≤ + corvajaZannierTraceUpperBound p (rotationOrder x.u1) + (Nat.card (middleGameRightSubgroup p d))) : + ∃ n : ℕ, + rotationOrder x.u1 < rotationOrder ((normalizedRotate1^[n]) x).u2 := by + let alpha : quadraticFiniteField p := s + let beta : quadraticFiniteField p := + splitFiberProduct w * ((s⁻¹ : (quadraticFiniteField p)ˣ) : quadraticFiniteField p) + let H₁ : Subgroup (quadraticFiniteField p)ˣ := Subgroup.zpowers w + have htrace : + algebraMap (ZMod p) (quadraticFiniteField p) x.u1 = splitTorusTrace w := + congrArg NormalizedPoint.u1 hpoint + have horder : orderOf w = rotationOrder x.u1 := by + rw [← rotationOrder_eq_orderOf_extensionEigenvalue x.u1 w hw htrace] + have hleftCard : Nat.card H₁ = rotationOrder x.u1 := by + rw [Nat.card_zpowers, horder] + have hfour : (4 : quadraticFiniteField p) ≠ 0 := by + exact (map_ne_zero (algebraMap (ZMod p) (quadraticFiniteField p))).mpr (by + intro hzero + have hpDvd : p ∣ 4 := (ZMod.natCast_eq_zero_iff 4 p).mp hzero + have hpPrime := (Fact.out : p.Prime) + have hpDvdPow : p ∣ 2 ^ 2 := by simpa using hpDvd + have hpDvdTwo : p ∣ 2 := hpPrime.dvd_of_dvd_pow hpDvdPow + have hpLeTwo : p ≤ 2 := Nat.le_of_dvd (by norm_num) hpDvdTwo + exact hpTwo (Nat.le_antisymm hpLeTwo hpPrime.two_le)) + have hnondegenerate : alpha * beta ≠ 1 := by + rw [show alpha * beta = splitFiberProduct w by + exact splitFiberOrbit_weights_mul w s] + exact splitFiberProduct_ne_one_of_four_ne_zero w hfour + have hcurrentOrder : 0 < Nat.card H₁ := by + rw [hleftCard] + exact rotationOrder_pos x.u1 + have hrightOrder : + ∀ d ∈ middleGameCandidateOrders p (Nat.card H₁), + Nat.card (middleGameRightSubgroup p d) = d := by + intro d hd + exact middleGameRightSubgroup_natCard p (Nat.card H₁) d hd + have hCZ' : alpha * beta ≠ 1 → + ∀ d ∈ middleGameCandidateOrders p (Nat.card H₁), + ((weightedTraceEquationSolutions alpha beta H₁ + (middleGameRightSubgroup p d)).card : ℝ) ≤ + corvajaZannierTraceUpperBound p (Nat.card H₁) + (Nat.card (middleGameRightSubgroup p d)) := by + intro _ d hd + simpa [alpha, beta, H₁, hleftCard] using + hCZ hnondegenerate d (by simpa [hleftCard] using hd) + obtain ⟨h, hEscapes⟩ := + exists_left_element_escaping_of_weightedCorvajaZannierEstimate_and_sizeBounds + p alpha beta H₁ (fun d ↦ middleGameRightSubgroup p d) + hrightOrder hCZ' hnondegenerate + hcurrentOrder (by simpa [hleftCard] using hcube) (by simpa [hleftCard] using hlinear) + obtain ⟨n, hn⟩ := exists_iterate_splitFiberPoint_eq_mul_zpowers w s h + refine ⟨n, ?_⟩ + let y := (normalizedRotate1^[n]) x + have hyPoint : algebraMapNormalizedPoint p y = + splitFiberPoint w (s * (h : (quadraticFiniteField p)ˣ)) := by + calc + algebraMapNormalizedPoint p y = + (normalizedRotate1^[n]) (algebraMapNormalizedPoint p x) := + algebraMapNormalizedPoint_iterate_normalizedRotate1 p n x + _ = (normalizedRotate1^[n]) (splitFiberPoint w s) := by rw [hpoint] + _ = splitFiberPoint w (s * (h : (quadraticFiniteField p)ˣ)) := hn + apply lt_of_not_ge + intro hsmall + have hnonparabolicY : y.u2 ^ 2 ≠ 4 := by + intro hparabolic + have hcases := (normalizedTrace_sq_eq_four_iff_parabolic p y.u2).mp hparabolic + have hthreshold := endgamePowerThreshold_le_rotationOrder_of_parabolicTrace + p hpTwo delta hdelta y.u2 hcases + have hsmallReal : (rotationOrder y.u2 : ℝ) ≤ (rotationOrder x.u1 : ℝ) := by + exact_mod_cast hsmall + exact (not_le_of_gt hbelowEndgame) (hthreshold.trans hsmallReal) + have hd := rotationOrder_mem_middleGameCandidateOrders_of_nonparabolic + p (rotationOrder x.u1) hpTwo y.u2 hnonparabolicY hsmall + obtain ⟨h₂, h₂trace⟩ := + exists_middleGameRightSubgroup_trace_of_nonparabolic_rotationOrder + p (rotationOrder y.u2) hpTwo y.u2 hnonparabolicY rfl + apply hEscapes (rotationOrder y.u2) (by simpa [hleftCard] using hd) h₂ + have hyCoordinate := congrArg NormalizedPoint.u2 hyPoint + change algebraMap (ZMod p) (quadraticFiniteField p) y.u2 = + (splitFiberPoint w (s * (h : (quadraticFiniteField p)ˣ))).u2 at hyCoordinate + rw [splitFiberOrbit_secondCoordinate_eq_weightedSplitTorusTrace] at hyCoordinate + change weightedSplitTorusTrace alpha beta h = splitTorusTrace h₂ + rw [← h₂trace] + simpa [alpha, beta] using hyCoordinate.symm + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/PairedCorvajaZannierBound.lean b/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/PairedCorvajaZannierBound.lean new file mode 100644 index 0000000000..fbe67677a2 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/PairedCorvajaZannierBound.lean @@ -0,0 +1,147 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.CorvajaZannierFromGeneral +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.RightInversionPairing + +/-! +# The sharp Corvaja--Zannier bound after right-inversion pairing + +The unconditional general plane-curve theorem specializes at bidegree `(2, 2)` +to Euler-characteristic bound `8`. Its two numerical branches are + +* `12 * (leftOrder * rightOrder)^(1/3)`, and +* `48 * leftOrder * rightOrder / p`. + +Right-coordinate inversion pairs all solutions whose right coordinate is not +two-torsion. Dividing the exact source bound by two therefore gives +coefficients `6` and `24` for the nonparabolic left support. + +No genus-one or Euler-characteristic-`3` assertion is used here. +-/ + +@[expose] public section + +namespace BGS.Markoff + +noncomputable section + +/-- The exact coefficient improvement obtained by pairing the two +right-coordinate inverses before taking the left support. -/ +def pairedCorvajaZannierTraceUpperBound + (p leftOrder rightOrder : ℕ) : ℝ := + max + (6 * (((leftOrder * rightOrder : ℕ) : ℝ) ^ ((1 : ℝ) / 3))) + (24 * (((leftOrder * rightOrder : ℕ) : ℝ) / p)) + +private lemma sixtyFour_rpow_one_third_eq_four : + (64 : ℝ) ^ ((1 : ℝ) / 3) = 4 := by + rw [show (64 : ℝ) = 4 ^ (3 : ℕ) by norm_num] + convert Real.pow_rpow_inv_natCast (by norm_num : (0 : ℝ) ≤ 4) + (by norm_num : (3 : ℕ) ≠ 0) using 1 + all_goals norm_num + +/-- At bidegree `(2,2)` and the unconditional Euler bound `8`, the +source-faithful Corvaja--Zannier right-hand side is exactly twice the paired +bound. Keeping this equality explicit prevents the cube-root branch from +being weakened to the older coefficient-`48` envelope before pairing. -/ +theorem corvajaZannierCorollaryTwoNumericalBound_bidegree_two_euler_eight_eq_twice_paired + (p leftOrder rightOrder : ℕ) : + corvajaZannierCorollaryTwoNumericalBound + p leftOrder rightOrder 2 2 8 = + 2 * pairedCorvajaZannierTraceUpperBound + p leftOrder rightOrder := by + let x : ℝ := ((leftOrder * rightOrder : ℕ) : ℝ) + have hx : 0 ≤ x := by positivity + unfold corvajaZannierCorollaryTwoNumericalBound + pairedCorvajaZannierTraceUpperBound + have horders : + (((leftOrder * rightOrder * 2 * 2 : ℕ) : ℝ)) = 4 * x := by + simp [x] + ring + rw [horders] + rw [show 2 * (4 * x) * 8 = (64 : ℝ) * x by ring] + rw [Real.mul_rpow (by norm_num : (0 : ℝ) ≤ 64) hx, + sixtyFour_rpow_one_third_eq_four] + rw [mul_max_of_nonneg _ _ (by norm_num : (0 : ℝ) ≤ 2)] + congr 1 <;> ring + +/-- The unconditional bidegree-`(2,2)`, Euler-bound-`8` +Corvaja--Zannier theorem, combined with right inversion, gives the sharp +nonparabolic left-support estimate + +`max (6 * (|H₁| |H₂|)^(1/3), 24 * |H₁| |H₂| / p)`. +-/ +theorem weightedTraceEquationNonparabolicLeftSupport_card_cast_le_pairedCorvajaZannier + (p : ℕ) [Fact p.Prime] + (E : Type) [Field E] [Fintype E] [DecidableEq E] [CharP E p] + (alpha beta : E) (H₁ H₂ : Subgroup Eˣ) + (hadmissible : WeightedTraceCurveIsCorvajaZannierAdmissible alpha beta) : + ((weightedTraceEquationNonparabolicLeftSupport + alpha beta H₁ H₂).card : ℝ) ≤ + pairedCorvajaZannierTraceUpperBound + p (Nat.card H₁) (Nat.card H₂) := by + obtain ⟨hleftPositive, hrightPositive, hleftPrime, hrightPrime⟩ := + multiplicativeSubgroups_satisfy_weightedTraceBoundOrderHypotheses + p E H₁ H₂ + have hsource := + BGS.CorvajaZannier.generalCorvajaZannierPlaneCurveTheorem + p E (weightedTraceTorusClosurePolynomial alpha beta) + 2 2 (Nat.card H₂) (Nat.card H₁) + (by norm_num) (by norm_num) + (weightedTraceTorusClosurePolynomial_hasBidegreeAtMost + alpha beta hadmissible.2.1) + (weightedTraceCurve_isGeneralCorvajaZannierPlaneCurve + alpha beta hadmissible) + hrightPositive hleftPositive hrightPrime hleftPrime + rw [generalTorusTorsionIntersection_weightedTrace_eq] at hsource + rw [show BGS.External.planeTorusEulerCharacteristicBound 2 2 = 8 by + norm_num [BGS.External.planeTorusEulerCharacteristicBound]] at hsource + have hsolutions : + ((weightedTraceEquationSolutions alpha beta H₁ H₂).card : ℝ) ≤ + corvajaZannierCorollaryTwoNumericalBound + p (Nat.card H₂) (Nat.card H₁) 2 2 8 := by + calc + ((weightedTraceEquationSolutions alpha beta H₁ H₂).card : ℝ) ≤ + ((weightedTraceCurveTorsionIntersection alpha beta + (Nat.card H₁) (Nat.card H₂)).card : ℝ) := by + exact_mod_cast + weightedTraceEquationSolutions_card_le_curveTorsionIntersection + alpha beta H₁ H₂ + _ ≤ corvajaZannierCorollaryTwoNumericalBound + p (Nat.card H₂) (Nat.card H₁) 2 2 8 := hsource + have hpaired : + 2 * ((weightedTraceEquationNonparabolicLeftSupport + alpha beta H₁ H₂).card : ℝ) ≤ + ((weightedTraceEquationSolutions alpha beta H₁ H₂).card : ℝ) := by + exact_mod_cast + two_mul_weightedTraceEquationNonparabolicLeftSupport_card_le_solutions + alpha beta H₁ H₂ + have htwice : + 2 * ((weightedTraceEquationNonparabolicLeftSupport + alpha beta H₁ H₂).card : ℝ) ≤ + 2 * pairedCorvajaZannierTraceUpperBound + p (Nat.card H₁) (Nat.card H₂) := by + calc + 2 * ((weightedTraceEquationNonparabolicLeftSupport + alpha beta H₁ H₂).card : ℝ) ≤ + ((weightedTraceEquationSolutions alpha beta H₁ H₂).card : ℝ) := + hpaired + _ ≤ corvajaZannierCorollaryTwoNumericalBound + p (Nat.card H₂) (Nat.card H₁) 2 2 8 := hsolutions + _ = 2 * pairedCorvajaZannierTraceUpperBound + p (Nat.card H₁) (Nat.card H₂) := by + rw [ + corvajaZannierCorollaryTwoNumericalBound_bidegree_two_euler_eight_eq_twice_paired] + unfold pairedCorvajaZannierTraceUpperBound + congr 1 <;> simp [Nat.mul_comm] + nlinarith + +end + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/PairedMaximalDivisorCorvajaZannierEscape.lean b/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/PairedMaximalDivisorCorvajaZannierEscape.lean new file mode 100644 index 0000000000..3610e127ac --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/PairedMaximalDivisorCorvajaZannierEscape.lean @@ -0,0 +1,63 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.Diagonalization +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.PairedMaximalDivisorOrderEscape +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.TraceCurveWeights + +/-! +# Unconditional paired maximal-divisor middle-game escape + +The weighted trace curve arising from a diagonalized nonzero nonparabolic +Markoff fiber is admissible for the in-repository general Corvaja--Zannier +theorem. Thus the paired maximal-order escape applies with no additional +geometric hypothesis. +-/ + +@[expose] public section + +namespace BGS.Markoff + +/-- Diagonalize a nonzero nonparabolic fiber and apply the unconditional +paired maximal-order escape theorem. -/ +theorem + exists_iterate_with_larger_secondRotationOrder_of_nonzero_nonparabolic_pairedMaximalOrders + (p : ℕ) [Fact p.Prime] [Fintype (quadraticFiniteField p)] + (hpTwo : p ≠ 2) + (delta : ℝ) (hdelta : delta ≤ (1 : ℝ) / 2) + (x : NormalizedPoint (ZMod p)) (hx : IsNormalizedMarkoff x) + (hnonzero : x.u1 ≠ 0) (hnonparabolic : x.u1 ^ 2 ≠ 4) + (hbelowEndgame : + (rotationOrder x.u1 : ℝ) < + (p : ℝ) ^ ((1 : ℝ) / 2 + delta)) + (hcube : + (6 * + (middleGameMaximalOrders p (rotationOrder x.u1)).card) ^ 3 < + rotationOrder x.u1) + (hlinear : + 24 * (middleGameMaximalOrders p (rotationOrder x.u1)).card * + rotationOrder x.u1 < p) : + ∃ n : ℕ, + rotationOrder x.u1 < + rotationOrder ((normalizedRotate1^[n]) x).u2 := by + obtain ⟨w, s, hw, hpoint⟩ := + exists_diagonalizedFiberPoint_of_nonzero_nonparabolic + p hpTwo x hx hnonzero hnonparabolic + have hadmissible : + WeightedTraceCurveIsCorvajaZannierAdmissible + (s : quadraticFiniteField p) + (splitFiberProduct w * + ((s⁻¹ : (quadraticFiniteField p)ˣ) : quadraticFiniteField p)) := + diagonalizedFiber_weightedTraceCurve_isCorvajaZannierAdmissible + p hpTwo x hnonzero w s hw hpoint + exact + exists_iterate_with_larger_secondRotationOrder_of_diagonalizedFiber_pairedMaximalOrders + p hpTwo delta hdelta x w s hw hpoint hadmissible + hbelowEndgame hcube hlinear + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/PairedMaximalDivisorCorvajaZannierStep.lean b/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/PairedMaximalDivisorCorvajaZannierStep.lean new file mode 100644 index 0000000000..60f58639e5 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/PairedMaximalDivisorCorvajaZannierStep.lean @@ -0,0 +1,259 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.MaximalDivisorNonparabolicOrderCover +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.NonparabolicUnionBound +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.PairedCorvajaZannierBound + +/-! +# Paired Corvaja--Zannier escape over maximal candidate orders + +Right-coordinate inversion halves the unconditional bidegree-`(2,2)` +Corvaja--Zannier estimate on the nonparabolic support. Combining that factor +with the maximal-divisor cover gives two separate sufficient inequalities: + +* `(6 * K)^3 < currentOrder` for the cube-root branch; +* `24 * K * currentOrder < p` for the branch divided by `p`, + +where `K` is the number of divisibility-maximal candidate orders. + +No Euler-characteristic improvement is used in this module. +-/ + +@[expose] public section + +namespace BGS.Markoff + +noncomputable section + +variable {E : Type*} [Field E] [Fintype E] + +/-- A common paired Corvaja--Zannier bound for every right order at most the +current left order. -/ +def pairedCorvajaZannierCurrentOrderEnvelope + (p currentOrder : ℕ) : ℝ := + max + (6 * (((currentOrder * currentOrder : ℕ) : ℝ) ^ ((1 : ℝ) / 3))) + (24 * (((currentOrder * currentOrder : ℕ) : ℝ) / p)) + +/-- Replacing a candidate right order by the current left order enlarges both +branches of the paired bound. -/ +theorem pairedCorvajaZannierTraceUpperBound_le_currentOrderEnvelope + (p currentOrder d : ℕ) (hd : d ≤ currentOrder) : + pairedCorvajaZannierTraceUpperBound p currentOrder d ≤ + pairedCorvajaZannierCurrentOrderEnvelope p currentOrder := by + have hmulNat : currentOrder * d ≤ currentOrder * currentOrder := + Nat.mul_le_mul_left currentOrder hd + have hmul : (((currentOrder * d : ℕ) : ℝ)) ≤ + (((currentOrder * currentOrder : ℕ) : ℝ)) := by + exact_mod_cast hmulNat + unfold pairedCorvajaZannierTraceUpperBound + pairedCorvajaZannierCurrentOrderEnvelope + exact max_le_max + (mul_le_mul_of_nonneg_left + (Real.rpow_le_rpow (by positivity) hmul (by norm_num)) + (by norm_num)) + (mul_le_mul_of_nonneg_left + (div_le_div_of_nonneg_right hmul (Nat.cast_nonneg p)) + (by norm_num)) + +/-- The paired bounds over the maximal candidate orders are controlled by the +number of those orders times the common current-order envelope. -/ +theorem middleGameMaximalPairedCorvajaZannierSum_le_card_mul_envelope + (p currentOrder : ℕ) (hp : 1 < p) : + (∑ d ∈ middleGameMaximalOrders p currentOrder, + pairedCorvajaZannierTraceUpperBound p currentOrder d) ≤ + ((middleGameMaximalOrders p currentOrder).card : ℝ) * + pairedCorvajaZannierCurrentOrderEnvelope p currentOrder := by + classical + calc + (∑ d ∈ middleGameMaximalOrders p currentOrder, + pairedCorvajaZannierTraceUpperBound p currentOrder d) ≤ + ∑ _d ∈ middleGameMaximalOrders p currentOrder, + pairedCorvajaZannierCurrentOrderEnvelope p currentOrder := by + exact Finset.sum_le_sum fun d hd ↦ + pairedCorvajaZannierTraceUpperBound_le_currentOrderEnvelope + p currentOrder d + (mem_middleGameCandidateOrders_iff.mp + (middleGameMaximalOrders_subset_candidateOrders hp hd)).1 + _ = ((middleGameMaximalOrders p currentOrder).card : ℝ) * + pairedCorvajaZannierCurrentOrderEnvelope p currentOrder := by + simp + +/-- The two coefficient-sensitive natural-number inequalities imply that the +whole paired maximal-order envelope is smaller than the current order. -/ +theorem orderCount_mul_pairedCorvajaZannierEnvelope_lt_currentOrder + (p currentOrder orderCount : ℕ) + (hcurrentOrder : 0 < currentOrder) + (hcube : (6 * orderCount) ^ 3 < currentOrder) + (hlinear : 24 * orderCount * currentOrder < p) : + (orderCount : ℝ) * + pairedCorvajaZannierCurrentOrderEnvelope p currentOrder < + (currentOrder : ℝ) := by + let rootCoefficient : ℝ := 6 * orderCount + let linearCoefficient : ℝ := 24 * orderCount + have horderPos : (0 : ℝ) < currentOrder := by + exact_mod_cast hcurrentOrder + have horderNonneg : (0 : ℝ) ≤ currentOrder := horderPos.le + have hrootCoefficientNonneg : 0 ≤ rootCoefficient := by + dsimp [rootCoefficient] + positivity + have hlinearCoefficientNonneg : 0 ≤ linearCoefficient := by + dsimp [linearCoefficient] + positivity + have hcubeReal : + rootCoefficient ^ (3 : ℕ) < (currentOrder : ℝ) := by + dsimp [rootCoefficient] + exact_mod_cast hcube + have hrootCoefficient : + rootCoefficient < (currentOrder : ℝ) ^ ((1 : ℝ) / 3) := by + have h := (Real.lt_rpow_inv_iff_of_pos hrootCoefficientNonneg + horderNonneg (by norm_num : (0 : ℝ) < 3)).2 + have h' : + rootCoefficient < (currentOrder : ℝ) ^ (3 : ℝ)⁻¹ := + h (by simpa [Real.rpow_natCast] using hcubeReal) + simpa only [one_div] using h' + have hrootPositive : + 0 < (((currentOrder * currentOrder : ℕ) : ℝ) ^ + ((1 : ℝ) / 3)) := by + positivity + have hcubeRootIdentity : + (currentOrder : ℝ) ^ ((1 : ℝ) / 3) * + (((currentOrder * currentOrder : ℕ) : ℝ) ^ + ((1 : ℝ) / 3)) = + (currentOrder : ℝ) := by + rw [Nat.cast_mul] + rw [← Real.mul_rpow horderNonneg + (mul_nonneg horderNonneg horderNonneg)] + convert Real.pow_rpow_inv_natCast horderNonneg + (by norm_num : (3 : ℕ) ≠ 0) using 1 + all_goals ring_nf + have hrootTerm : + rootCoefficient * + (((currentOrder * currentOrder : ℕ) : ℝ) ^ + ((1 : ℝ) / 3)) < + (currentOrder : ℝ) := by + calc + rootCoefficient * + (((currentOrder * currentOrder : ℕ) : ℝ) ^ + ((1 : ℝ) / 3)) < + (currentOrder : ℝ) ^ ((1 : ℝ) / 3) * + (((currentOrder * currentOrder : ℕ) : ℝ) ^ + ((1 : ℝ) / 3)) := + mul_lt_mul_of_pos_right hrootCoefficient hrootPositive + _ = (currentOrder : ℝ) := hcubeRootIdentity + have hlinearReal : + linearCoefficient * (currentOrder : ℝ) < (p : ℝ) := by + dsimp [linearCoefficient] + exact_mod_cast hlinear + have hpPos : (0 : ℝ) < p := by + have : 0 < p := by omega + exact_mod_cast this + have hquotientTerm : + linearCoefficient * + (((currentOrder * currentOrder : ℕ) : ℝ) / (p : ℝ)) < + (currentOrder : ℝ) := by + have hratio : + linearCoefficient * (currentOrder : ℝ) / (p : ℝ) < 1 := + (div_lt_one hpPos).2 hlinearReal + calc + linearCoefficient * + (((currentOrder * currentOrder : ℕ) : ℝ) / (p : ℝ)) = + (linearCoefficient * (currentOrder : ℝ) / (p : ℝ)) * + (currentOrder : ℝ) := by + rw [Nat.cast_mul] + ring + _ < 1 * (currentOrder : ℝ) := + mul_lt_mul_of_pos_right hratio horderPos + _ = (currentOrder : ℝ) := one_mul _ + calc + (orderCount : ℝ) * + pairedCorvajaZannierCurrentOrderEnvelope p currentOrder = + max + (rootCoefficient * + (((currentOrder * currentOrder : ℕ) : ℝ) ^ + ((1 : ℝ) / 3))) + (linearCoefficient * + (((currentOrder * currentOrder : ℕ) : ℝ) / (p : ℝ))) := by + rw [pairedCorvajaZannierCurrentOrderEnvelope, + mul_max_of_nonneg _ _ (Nat.cast_nonneg orderCount)] + dsimp [rootCoefficient, linearCoefficient] + push_cast + congr 1 <;> ring + _ < (currentOrder : ℝ) := max_lt hrootTerm hquotientTerm + +/-- The finite nonparabolic escape theorem over maximal candidate orders. +The Corvaja--Zannier estimate is supplied by the in-repository general +bidegree-`(2,2)` theorem and right-inversion pairing. -/ +theorem exists_left_element_escaping_nonparabolic_maximalOrders + (p : ℕ) [Fact p.Prime] + (E : Type) [Field E] [Fintype E] [DecidableEq E] [CharP E p] + (alpha beta : E) (Hleft : Subgroup Eˣ) + (rightSubgroup : ℕ → Subgroup Eˣ) + (hrightOrder : + ∀ d ∈ middleGameMaximalOrders p (Nat.card Hleft), + Nat.card (rightSubgroup d) = d) + (hadmissible : + WeightedTraceCurveIsCorvajaZannierAdmissible alpha beta) + (hcurrentOrder : 0 < Nat.card Hleft) + (hp : 1 < p) + (hcube : + (6 * (middleGameMaximalOrders p (Nat.card Hleft)).card) ^ 3 < + Nat.card Hleft) + (hlinear : + 24 * (middleGameMaximalOrders p (Nat.card Hleft)).card * + Nat.card Hleft < p) : + ∃ hleft : Hleft, + ∀ d ∈ middleGameMaximalOrders p (Nat.card Hleft), + ∀ hright : rightSubgroup d, + ((hright : Eˣ) ^ 2) ≠ 1 → + weightedSplitTorusTrace alpha beta hleft ≠ + splitTorusTrace hright := by + classical + let orders := middleGameMaximalOrders p (Nat.card Hleft) + let bound : ℕ → ℝ := + fun d ↦ pairedCorvajaZannierTraceUpperBound p (Nat.card Hleft) d + have hbound : + ∀ d ∈ orders, + ((weightedTraceEquationNonparabolicLeftSupport + alpha beta Hleft (rightSubgroup d)).card : ℝ) ≤ bound d := by + intro d hd + have hd' : d ∈ middleGameMaximalOrders p (Nat.card Hleft) := by + simpa [orders] using hd + have h := + weightedTraceEquationNonparabolicLeftSupport_card_cast_le_pairedCorvajaZannier + p E alpha beta Hleft (rightSubgroup d) hadmissible + rw [hrightOrder d hd'] at h + simpa [bound] using h + have hsmall : (∑ d ∈ orders, bound d) < (Nat.card Hleft : ℝ) := by + calc + (∑ d ∈ orders, bound d) = + ∑ d ∈ middleGameMaximalOrders p (Nat.card Hleft), + pairedCorvajaZannierTraceUpperBound + p (Nat.card Hleft) d := by + simp [orders, bound] + _ ≤ ((middleGameMaximalOrders p (Nat.card Hleft)).card : ℝ) * + pairedCorvajaZannierCurrentOrderEnvelope + p (Nat.card Hleft) := + middleGameMaximalPairedCorvajaZannierSum_le_card_mul_envelope + p (Nat.card Hleft) hp + _ < (Nat.card Hleft : ℝ) := + orderCount_mul_pairedCorvajaZannierEnvelope_lt_currentOrder + p (Nat.card Hleft) + (middleGameMaximalOrders p (Nat.card Hleft)).card + hcurrentOrder hcube hlinear + obtain ⟨hleft, hleftEscapes⟩ := + exists_left_element_escaping_nonparabolic_orders_of_sum_bound + alpha beta Hleft orders rightSubgroup bound hbound hsmall + refine ⟨hleft, ?_⟩ + intro d hd hright hrightSq + exact hleftEscapes d (by simpa [orders] using hd) hright hrightSq + +end + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/PairedMaximalDivisorOrderEscape.lean b/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/PairedMaximalDivisorOrderEscape.lean new file mode 100644 index 0000000000..814c2ad88d --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/PairedMaximalDivisorOrderEscape.lean @@ -0,0 +1,138 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.MaximalDivisorOrderEscape +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.PairedMaximalDivisorCorvajaZannierStep + +/-! +# Paired nonparabolic order escape using maximal divisors + +This is the geometric diagonalized-fiber step for the paired maximal-order +union. A hypothetical bounded target coordinate is first shown to be +nonparabolic. Its trace is then represented by a non-two-torsion element of +a maximal candidate subgroup, exactly the kind of witness excluded by the +paired finite escape theorem. +-/ + +@[expose] public section + +namespace BGS.Markoff + +/-- Complete order escape from a diagonalized fiber under the paired +coefficient conditions `(6*K)^3 < currentOrder` and +`24*K*currentOrder < p`. -/ +theorem + exists_iterate_with_larger_secondRotationOrder_of_diagonalizedFiber_pairedMaximalOrders + (p : ℕ) [Fact p.Prime] [Fintype (quadraticFiniteField p)] + (hpTwo : p ≠ 2) + (delta : ℝ) (hdelta : delta ≤ (1 : ℝ) / 2) + (x : NormalizedPoint (ZMod p)) + (w s : (quadraticFiniteField p)ˣ) + (hw : (w : quadraticFiniteField p) ^ 2 ≠ 1) + (hpoint : algebraMapNormalizedPoint p x = splitFiberPoint w s) + (hadmissible : + WeightedTraceCurveIsCorvajaZannierAdmissible + (s : quadraticFiniteField p) + (splitFiberProduct w * + ((s⁻¹ : (quadraticFiniteField p)ˣ) : quadraticFiniteField p))) + (hbelowEndgame : + (rotationOrder x.u1 : ℝ) < + (p : ℝ) ^ ((1 : ℝ) / 2 + delta)) + (hcube : + (6 * + (middleGameMaximalOrders p (rotationOrder x.u1)).card) ^ 3 < + rotationOrder x.u1) + (hlinear : + 24 * (middleGameMaximalOrders p (rotationOrder x.u1)).card * + rotationOrder x.u1 < p) : + ∃ n : ℕ, + rotationOrder x.u1 < + rotationOrder ((normalizedRotate1^[n]) x).u2 := by + classical + let alpha : quadraticFiniteField p := s + let beta : quadraticFiniteField p := + splitFiberProduct w * + ((s⁻¹ : (quadraticFiniteField p)ˣ) : quadraticFiniteField p) + let Hleft : Subgroup (quadraticFiniteField p)ˣ := Subgroup.zpowers w + have htrace : + algebraMap (ZMod p) (quadraticFiniteField p) x.u1 = + splitTorusTrace w := + congrArg NormalizedPoint.u1 hpoint + have horder : orderOf w = rotationOrder x.u1 := by + rw [← rotationOrder_eq_orderOf_extensionEigenvalue x.u1 w hw htrace] + have hleftCard : Nat.card Hleft = rotationOrder x.u1 := by + rw [Nat.card_zpowers, horder] + have hp : 1 < p := (Fact.out : p.Prime).one_lt + have hcurrentOrder : 0 < Nat.card Hleft := by + rw [hleftCard] + exact rotationOrder_pos x.u1 + have hrightOrder : + ∀ d ∈ middleGameMaximalOrders p (Nat.card Hleft), + Nat.card (middleGameRightSubgroup p d) = d := by + intro d hd + exact middleGameMaximalOrder_rightSubgroup_natCard + p (Nat.card Hleft) d hp hd + have hcube' : + (6 * (middleGameMaximalOrders p (Nat.card Hleft)).card) ^ 3 < + Nat.card Hleft := by + rw [hleftCard] + exact hcube + have hlinear' : + 24 * (middleGameMaximalOrders p (Nat.card Hleft)).card * + Nat.card Hleft < p := by + rw [hleftCard] + exact hlinear + obtain ⟨h, hEscapes⟩ := + exists_left_element_escaping_nonparabolic_maximalOrders + p (quadraticFiniteField p) alpha beta Hleft + (fun d ↦ middleGameRightSubgroup p d) + hrightOrder (by simpa [alpha, beta] using hadmissible) + hcurrentOrder hp hcube' hlinear' + obtain ⟨n, hn⟩ := exists_iterate_splitFiberPoint_eq_mul_zpowers w s h + refine ⟨n, ?_⟩ + let y := (normalizedRotate1^[n]) x + have hyPoint : algebraMapNormalizedPoint p y = + splitFiberPoint w (s * (h : (quadraticFiniteField p)ˣ)) := by + calc + algebraMapNormalizedPoint p y = + (normalizedRotate1^[n]) (algebraMapNormalizedPoint p x) := + algebraMapNormalizedPoint_iterate_normalizedRotate1 p n x + _ = (normalizedRotate1^[n]) (splitFiberPoint w s) := by rw [hpoint] + _ = splitFiberPoint w + (s * (h : (quadraticFiniteField p)ˣ)) := hn + apply lt_of_not_ge + intro hsmall + have hnonparabolicY : y.u2 ^ 2 ≠ 4 := by + intro hparabolic + have hcases := + (normalizedTrace_sq_eq_four_iff_parabolic p y.u2).mp hparabolic + have hthreshold := + endgamePowerThreshold_le_rotationOrder_of_parabolicTrace + p hpTwo delta hdelta y.u2 hcases + have hsmallReal : + (rotationOrder y.u2 : ℝ) ≤ (rotationOrder x.u1 : ℝ) := by + exact_mod_cast hsmall + exact (not_le_of_gt hbelowEndgame) (hthreshold.trans hsmallReal) + obtain ⟨m, hm, hright, hrightTrace, hrightSq⟩ := + exists_middleGameMaximalOrder_nonparabolic_trace + p (rotationOrder x.u1) hpTwo hp y.u2 hnonparabolicY hsmall + have hm' : m ∈ middleGameMaximalOrders p (Nat.card Hleft) := by + rw [hleftCard] + exact hm + apply hEscapes m hm' hright hrightSq + have hyCoordinate := congrArg NormalizedPoint.u2 hyPoint + change algebraMap (ZMod p) (quadraticFiniteField p) y.u2 = + (splitFiberPoint w + (s * (h : (quadraticFiniteField p)ˣ))).u2 at hyCoordinate + rw [splitFiberOrbit_secondCoordinate_eq_weightedSplitTorusTrace] + at hyCoordinate + change weightedSplitTorusTrace alpha beta h = splitTorusTrace hright + rw [← hrightTrace] + simpa [alpha, beta] using hyCoordinate.symm + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/ParabolicEscape.lean b/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/ParabolicEscape.lean new file mode 100644 index 0000000000..6fd2574df4 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/ParabolicEscape.lean @@ -0,0 +1,124 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Core.ConicParametrization +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.RightSubgroups + +/-! +# The parabolic middle-game branch + +The weighted Corvaja--Zannier argument is only needed for semisimple coordinate traces. +The two parabolic traces have exact rotation orders `p` and `2 * p`, already beyond every +endgame threshold `p ^ (1 / 2 + delta)` with `delta <= 1 / 2`. + +For primes congruent to one modulo four, this module also connects the explicit affine-line +parametrizations to the concrete rotation cycles through every point on the two parabolic fibers. +For primes congruent to three modulo four those fibers are empty by the existing results in +`ParabolicFibers`. +-/ + +@[expose] public section + +namespace BGS.Markoff + +/-- Every endgame power threshold with exponent at most one is bounded by `p`. -/ +theorem endgamePowerThreshold_le_prime + (p : ℕ) [Fact p.Prime] (delta : ℝ) (hdelta : delta ≤ (1 : ℝ) / 2) : + (p : ℝ) ^ ((1 : ℝ) / 2 + delta) ≤ (p : ℝ) := by + have hp : (1 : ℝ) ≤ p := by + exact_mod_cast (Fact.out : p.Prime).one_le + calc + (p : ℝ) ^ ((1 : ℝ) / 2 + delta) ≤ (p : ℝ) ^ (1 : ℝ) := + Real.rpow_le_rpow_of_exponent_le hp (by linarith) + _ = (p : ℝ) := Real.rpow_one _ + +/-- The trace-`2` rotation already meets the endgame power threshold. -/ +theorem endgamePowerThreshold_le_rotationOrder_two + (p : ℕ) [Fact p.Prime] (delta : ℝ) (hdelta : delta ≤ (1 : ℝ) / 2) : + (p : ℝ) ^ ((1 : ℝ) / 2 + delta) ≤ + (rotationOrder (2 : ZMod p) : ℝ) := by + rw [rotationOrder_two p] + exact endgamePowerThreshold_le_prime p delta hdelta + +/-- The trace-`-2` rotation has order `2 * p`, hence also meets the endgame threshold. -/ +theorem endgamePowerThreshold_le_rotationOrder_neg_two + (p : ℕ) [Fact p.Prime] (hpTwo : p ≠ 2) + (delta : ℝ) (hdelta : delta ≤ (1 : ℝ) / 2) : + (p : ℝ) ^ ((1 : ℝ) / 2 + delta) ≤ + (rotationOrder (-2 : ZMod p) : ℝ) := by + rw [rotationOrder_neg_two p hpTwo] + have hthreshold := endgamePowerThreshold_le_prime p delta hdelta + exact hthreshold.trans (by + exact_mod_cast (show p ≤ 2 * p by omega)) + +/-- Unified parabolic branch: either normalized parabolic trace is already in the endgame +large-order range. -/ +theorem endgamePowerThreshold_le_rotationOrder_of_parabolicTrace + (p : ℕ) [Fact p.Prime] (hpTwo : p ≠ 2) + (delta : ℝ) (hdelta : delta ≤ (1 : ℝ) / 2) + (t : ZMod p) (ht : t = 2 ∨ t = -2) : + (p : ℝ) ^ ((1 : ℝ) / 2 + delta) ≤ (rotationOrder t : ℝ) := by + rcases ht with rfl | rfl + · exact endgamePowerThreshold_le_rotationOrder_two p delta hdelta + · exact endgamePowerThreshold_le_rotationOrder_neg_two p hpTwo delta hdelta + +/-- Every point on the normalized trace-`2` fiber for `p = 1 mod 4` has a rotation cycle of +exactly `p` points. -/ +theorem normalizedRotationCycle_card_of_mem_fiber_two + (p : ℕ) [Fact p.Prime] (hpTwo : p ≠ 2) (hmod : p % 4 = 1) + (x : NormalizedPoint (ZMod p)) (hx : x ∈ normalizedFiber1 (2 : ZMod p)) : + (normalizedRotationCycle (2 : ZMod p) x).card = p := by + obtain ⟨i, hi, hfiberTwo, _⟩ := + exists_parabolic_line_decomposition_of_mod_four_eq_one p hmod + rw [hfiberTwo] at hx + rcases hx with ⟨s, rfl⟩ | ⟨s, rfl⟩ + · simpa [rotationOrder_two p] using + normalizedRotationCycle_card_parabolicLineAtTwo p hpTwo i s hi + · have hnegI : (-i) ^ 2 = -(1 : ZMod p) := by simpa using hi + simpa [rotationOrder_two p] using + normalizedRotationCycle_card_parabolicLineAtTwo p hpTwo (-i) s hnegI + +/-- Every point on the normalized trace-`-2` fiber for `p = 1 mod 4` has a rotation cycle of +exactly `2 * p` points. -/ +theorem normalizedRotationCycle_card_of_mem_fiber_neg_two + (p : ℕ) [Fact p.Prime] (hpTwo : p ≠ 2) (hmod : p % 4 = 1) + (x : NormalizedPoint (ZMod p)) (hx : x ∈ normalizedFiber1 (-2 : ZMod p)) : + (normalizedRotationCycle (-2 : ZMod p) x).card = 2 * p := by + obtain ⟨i, hi, _, hfiberNegTwo⟩ := + exists_parabolic_line_decomposition_of_mod_four_eq_one p hmod + rw [hfiberNegTwo] at hx + rcases hx with ⟨s, rfl⟩ | ⟨s, rfl⟩ + · simpa [rotationOrder_neg_two p hpTwo] using + normalizedRotationCycle_card_parabolicLineAtNegTwo p hpTwo i s hi + · have hnegI : (-i) ^ 2 = -(1 : ZMod p) := by simpa using hi + simpa [rotationOrder_neg_two p hpTwo] using + normalizedRotationCycle_card_parabolicLineAtNegTwo p hpTwo (-i) s hnegI + +/-- The exact trace-`2` cycle through any fiber point meets the endgame power threshold. -/ +theorem endgamePowerThreshold_le_parabolicFiberTwo_cycleCard + (p : ℕ) [Fact p.Prime] (hpTwo : p ≠ 2) (hmod : p % 4 = 1) + (delta : ℝ) (hdelta : delta ≤ (1 : ℝ) / 2) + (x : NormalizedPoint (ZMod p)) (hx : x ∈ normalizedFiber1 (2 : ZMod p)) : + (p : ℝ) ^ ((1 : ℝ) / 2 + delta) ≤ + ((normalizedRotationCycle (2 : ZMod p) x).card : ℝ) := by + rw [normalizedRotationCycle_card_of_mem_fiber_two p hpTwo hmod x hx] + exact endgamePowerThreshold_le_prime p delta hdelta + +/-- The exact trace-`-2` cycle through any fiber point meets the endgame power threshold. -/ +theorem endgamePowerThreshold_le_parabolicFiberNegTwo_cycleCard + (p : ℕ) [Fact p.Prime] (hpTwo : p ≠ 2) (hmod : p % 4 = 1) + (delta : ℝ) (hdelta : delta ≤ (1 : ℝ) / 2) + (x : NormalizedPoint (ZMod p)) (hx : x ∈ normalizedFiber1 (-2 : ZMod p)) : + (p : ℝ) ^ ((1 : ℝ) / 2 + delta) ≤ + ((normalizedRotationCycle (-2 : ZMod p) x).card : ℝ) := by + rw [normalizedRotationCycle_card_of_mem_fiber_neg_two p hpTwo hmod x hx] + have hthreshold := endgamePowerThreshold_le_prime p delta hdelta + exact hthreshold.trans (by + exact_mod_cast (show p ≤ 2 * p by omega)) + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/RightInversionPairing.lean b/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/RightInversionPairing.lean new file mode 100644 index 0000000000..ddd997795a --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/RightInversionPairing.lean @@ -0,0 +1,167 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.WeightedTraceEquation + +/-! +# The right-coordinate inversion pairing + +The right-hand trace in the weighted middle-game equation is invariant under +inversion. Away from the two-torsion points, every solution therefore occurs +with a distinct partner having the same left coordinate. This gives a genuine +factor of two for the nonparabolic left support, while leaving the existing +parabolic escape branch responsible for the two fixed points. +-/ + +@[expose] public section + +namespace BGS.Markoff + +variable {E : Type*} [Field E] [Fintype E] + +omit [Fintype E] in +/-- The ordinary split trace is invariant under inversion. -/ +theorem splitTorusTrace_right_inv (h : Eˣ) : + splitTorusTrace h⁻¹ = splitTorusTrace h := by + simp only [splitTorusTrace, Units.val_inv_eq_inv_val, inv_inv] + exact add_comm _ _ + +/-- Inverting the right coordinate preserves every weighted trace-equation +solution and leaves its left coordinate unchanged. -/ +theorem weightedTraceEquationSolutions_right_inv_mem + {alpha beta : E} {H₁ H₂ : Subgroup Eˣ} {z : H₁ × H₂} + (hz : z ∈ weightedTraceEquationSolutions alpha beta H₁ H₂) : + (z.1, z.2⁻¹) ∈ weightedTraceEquationSolutions alpha beta H₁ H₂ := by + rw [mem_weightedTraceEquationSolutions_iff] at hz ⊢ + change weightedSplitTorusTrace alpha beta (z.1 : Eˣ) = + splitTorusTrace ((z.2 : Eˣ)⁻¹) + rw [splitTorusTrace_right_inv] + exact hz + +omit [Fintype E] in +/-- A subgroup element whose square is not one is distinct from its inverse. -/ +theorem subgroupElement_ne_inv_of_sq_ne_one + {H : Subgroup Eˣ} (h : H) (hsq : ((h : Eˣ) ^ 2) ≠ 1) : + h ≠ h⁻¹ := by + intro hinv + apply hsq + have hinv' : (h : Eˣ) = ((h⁻¹ : H) : Eˣ) := + congrArg (fun u : H ↦ (u : Eˣ)) hinv + calc + (h : Eˣ) ^ 2 = (h : Eˣ) * (h : Eˣ) := pow_two _ + _ = (h : Eˣ) * ((h⁻¹ : H) : Eˣ) := congrArg ((h : Eˣ) * ·) hinv' + _ = 1 := by simp + +/-- The nonparabolic part of a weighted trace-equation solution set. -/ +noncomputable def weightedTraceEquationNonparabolicSolutions + (alpha beta : E) (H₁ H₂ : Subgroup Eˣ) : Finset (H₁ × H₂) := by + classical + exact (weightedTraceEquationSolutions alpha beta H₁ H₂).filter fun z ↦ + ((z.2 : Eˣ) ^ 2) ≠ 1 + +@[simp] +theorem mem_weightedTraceEquationNonparabolicSolutions_iff + {alpha beta : E} {H₁ H₂ : Subgroup Eˣ} {z : H₁ × H₂} : + z ∈ weightedTraceEquationNonparabolicSolutions alpha beta H₁ H₂ ↔ + z ∈ weightedTraceEquationSolutions alpha beta H₁ H₂ ∧ + ((z.2 : Eˣ) ^ 2) ≠ 1 := by + classical + simp [weightedTraceEquationNonparabolicSolutions] + +/-- Left elements occurring in a nonparabolic weighted solution. -/ +noncomputable def weightedTraceEquationNonparabolicLeftSupport + (alpha beta : E) (H₁ H₂ : Subgroup Eˣ) : Finset H₁ := by + classical + exact + (weightedTraceEquationNonparabolicSolutions alpha beta H₁ H₂).image Prod.fst + +@[simp] +theorem mem_weightedTraceEquationNonparabolicLeftSupport_iff + {alpha beta : E} {H₁ H₂ : Subgroup Eˣ} {h₁ : H₁} : + h₁ ∈ weightedTraceEquationNonparabolicLeftSupport alpha beta H₁ H₂ ↔ + ∃ h₂ : H₂, + weightedSplitTorusTrace alpha beta h₁ = splitTorusTrace h₂ ∧ + ((h₂ : Eˣ) ^ 2) ≠ 1 := by + classical + simp only [weightedTraceEquationNonparabolicLeftSupport, Finset.mem_image] + constructor + · rintro ⟨z, hz, rfl⟩ + rw [mem_weightedTraceEquationNonparabolicSolutions_iff] at hz + exact ⟨z.2, mem_weightedTraceEquationSolutions_iff.mp hz.1, hz.2⟩ + · rintro ⟨h₂, heq, hsq⟩ + exact ⟨(h₁, h₂), mem_weightedTraceEquationNonparabolicSolutions_iff.mpr + ⟨mem_weightedTraceEquationSolutions_iff.mpr heq, hsq⟩, rfl⟩ + +/-- Every fiber of the nonparabolic right-inversion quotient has at least two +points. Consequently twice the left-support cardinality is bounded by the +full Corvaja--Zannier solution count. -/ +theorem two_mul_weightedTraceEquationNonparabolicLeftSupport_card_le_solutions + (alpha beta : E) (H₁ H₂ : Subgroup Eˣ) : + 2 * (weightedTraceEquationNonparabolicLeftSupport + alpha beta H₁ H₂).card ≤ + (weightedTraceEquationSolutions alpha beta H₁ H₂).card := by + classical + let solutions := + weightedTraceEquationSolutions alpha beta H₁ H₂ + let nonparabolic := + weightedTraceEquationNonparabolicSolutions alpha beta H₁ H₂ + have hfiber : + ∀ h₁ ∈ nonparabolic.image Prod.fst, + 2 ≤ (nonparabolic.filter fun z ↦ Prod.fst z = h₁).card := by + intro h₁ hh₁ + obtain ⟨z, hz, rfl⟩ := Finset.mem_image.mp hh₁ + have hzData : + z ∈ solutions ∧ ((z.2 : Eˣ) ^ 2) ≠ 1 := by + simpa [nonparabolic, solutions] using + (mem_weightedTraceEquationNonparabolicSolutions_iff.mp hz) + have hzInvSolutions : + (z.1, z.2⁻¹) ∈ solutions := by + simpa [solutions] using + weightedTraceEquationSolutions_right_inv_mem hzData.1 + have hzInvSq : ((((z.2⁻¹ : H₂) : Eˣ) ^ 2) ≠ 1) := by + intro h + apply hzData.2 + have h' := congrArg Inv.inv h + simpa using h' + have hzInv : + (z.1, z.2⁻¹) ∈ nonparabolic := by + rw [show nonparabolic = + weightedTraceEquationNonparabolicSolutions alpha beta H₁ H₂ by rfl, + mem_weightedTraceEquationNonparabolicSolutions_iff] + exact ⟨by simpa [solutions] using hzInvSolutions, hzInvSq⟩ + have hne : z ≠ (z.1, z.2⁻¹) := by + intro h + exact subgroupElement_ne_inv_of_sq_ne_one z.2 hzData.2 + (congrArg Prod.snd h) + have hsubset : + ({z, (z.1, z.2⁻¹)} : Finset (H₁ × H₂)) ⊆ + nonparabolic.filter fun w ↦ Prod.fst w = z.1 := by + intro w hw + simp only [Finset.mem_insert, Finset.mem_singleton] at hw + rw [Finset.mem_filter] + rcases hw with rfl | rfl + · exact ⟨hz, rfl⟩ + · exact ⟨hzInv, rfl⟩ + have hcard := Finset.card_le_card hsubset + simpa [hne] using hcard + have hpaired : + 2 * (nonparabolic.image Prod.fst).card ≤ nonparabolic.card := + Finset.mul_card_image_le_card nonparabolic 2 hfiber + calc + 2 * (weightedTraceEquationNonparabolicLeftSupport + alpha beta H₁ H₂).card = + 2 * (nonparabolic.image Prod.fst).card := by + rfl + _ ≤ nonparabolic.card := hpaired + _ ≤ solutions.card := by + exact Finset.card_le_card fun z hz ↦ by + exact + (mem_weightedTraceEquationNonparabolicSolutions_iff.mp + (by simpa [nonparabolic] using hz)).1 + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/RightSubgroups.lean b/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/RightSubgroups.lean new file mode 100644 index 0000000000..f1c35a1a21 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/RightSubgroups.lean @@ -0,0 +1,193 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.WeightedTraceEquation +public import LeanPool.MarkoffModP.BGS.Markoff.Core.TraceClassification +public import Mathlib.RingTheory.RootsOfUnity.PrimitiveRoots + +/-! +# Concrete right subgroups for the middle game + +All split and nonsplit semisimple eigenvalues are placed in the common quadratic extension. +For a candidate order `d`, the right subgroup is the subgroup of `d`-th roots of unity in that +extension. Candidate divisibility by `p - 1` or `p + 1` implies that this subgroup has exactly +`d` elements. + +Parabolic traces are deliberately excluded from the representation theorem: their rotation +orders are `p` or `2 * p`, not semisimple torus orders dividing `p - 1` or `p + 1`. +-/ + +@[expose] public section + +namespace BGS.Markoff + +/-- The canonical right subgroup of order `d` inside the common quadratic extension. -/ +noncomputable def middleGameRightSubgroup (p d : ℕ) [Fact p.Prime] : + Subgroup (quadraticFiniteField p)ˣ := + rootsOfUnity d (quadraticFiniteField p) + +theorem mem_middleGameRightSubgroup_iff_pow_eq_one + (p d : ℕ) [Fact p.Prime] (u : (quadraticFiniteField p)ˣ) : + u ∈ middleGameRightSubgroup p d ↔ u ^ d = 1 := by + exact mem_rootsOfUnity d u + +/-- Every element whose multiplicative order is `d` belongs to the canonical right subgroup. -/ +theorem mem_middleGameRightSubgroup_of_orderOf_eq + (p d : ℕ) [Fact p.Prime] (u : (quadraticFiniteField p)ˣ) + (hu : orderOf u = d) : + u ∈ middleGameRightSubgroup p d := by + rw [mem_middleGameRightSubgroup_iff_pow_eq_one, ← hu] + exact pow_orderOf_eq_one u + +/-- Candidate divisibility by `p - 1` or `p + 1` implies divisibility by the order of the +multiplicative group of the quadratic extension. -/ +theorem middleGameCandidateOrder_dvd_quadraticUnitsCard + (p currentOrder d : ℕ) [Fact p.Prime] + (hd : d ∈ middleGameCandidateOrders p currentOrder) : + d ∣ Nat.card (quadraticFiniteField p)ˣ := by + have hfieldCard : Nat.card (quadraticFiniteField p) = p ^ 2 := + GaloisField.card p (n := 2) (by norm_num) + have hunitsCard : Nat.card (quadraticFiniteField p)ˣ = p ^ 2 - 1 := by + rw [Nat.card_units, hfieldCard] + rw [hunitsCard] + have hfactor : p ^ 2 - 1 = (p + 1) * (p - 1) := by + simpa using (sq_tsub_sq p 1) + rw [hfactor] + rcases (mem_middleGameCandidateOrders_iff.mp hd).2 with hminus | hplus + · exact dvd_mul_of_dvd_right hminus.1 (p + 1) + · exact dvd_mul_of_dvd_left hplus (p - 1) + +/-- The canonical right subgroup indexed by a candidate order has exactly that cardinality. -/ +theorem middleGameRightSubgroup_natCard + (p currentOrder d : ℕ) [Fact p.Prime] + (hd : d ∈ middleGameCandidateOrders p currentOrder) : + Nat.card (middleGameRightSubgroup p d) = d := by + let E := quadraticFiniteField p + let : Fintype E := Fintype.ofFinite E + have hdvd : d ∣ Nat.card Eˣ := + middleGameCandidateOrder_dvd_quadraticUnitsCard p currentOrder d hd + have hdpos : 0 < d := Nat.pos_of_dvd_of_pos hdvd Nat.card_pos + let : NeZero d := ⟨hdpos.ne'⟩ + obtain ⟨g, hg⟩ := IsCyclic.exists_ofOrder_eq_natCard (α := Eˣ) + let zeta : Eˣ := g ^ (orderOf g / d) + have horder : orderOf zeta = d := by + apply orderOf_pow_orderOf_div + · rw [hg] + exact Nat.card_pos.ne' + · rwa [hg] + have hprimitive : IsPrimitiveRoot zeta d := IsPrimitiveRoot.iff_orderOf.mpr horder + exact hprimitive.card_rootsOfUnity' + +/-- A split eigenvalue of rotation order `d`, embedded in the quadratic extension, lies in the +canonical right subgroup and has the required reciprocal trace. -/ +theorem exists_middleGameRightSubgroup_trace_of_split + (p d : ℕ) [Fact p.Prime] + (t : ZMod p) (w : (ZMod p)ˣ) + (htrace : splitTorusTrace w = t) + (hw : (w : ZMod p) ^ 2 ≠ 1) + (hrotation : rotationOrder t = d) : + ∃ h₂ : middleGameRightSubgroup p d, + algebraMap (ZMod p) (quadraticFiniteField p) t = splitTorusTrace h₂ := by + let embedding : (ZMod p)ˣ →* (quadraticFiniteField p)ˣ := + Units.map (algebraMap (ZMod p) (quadraticFiniteField p)).toMonoidHom + let u : (quadraticFiniteField p)ˣ := embedding w + have horder : orderOf w = d := by + rw [← rotationOrder_splitTorusTrace w hw, htrace] + exact hrotation + have hupow : u ^ d = 1 := by + calc + u ^ d = embedding (w ^ d) := (map_pow embedding w d).symm + _ = embedding 1 := by rw [← horder, pow_orderOf_eq_one] + _ = 1 := map_one embedding + let h₂ : middleGameRightSubgroup p d := + ⟨u, (mem_middleGameRightSubgroup_iff_pow_eq_one p d u).mpr hupow⟩ + refine ⟨h₂, ?_⟩ + rw [← htrace] + change algebraMap (ZMod p) (quadraticFiniteField p) (splitTorusTrace w) = + splitTorusTrace (embedding w) + rw [splitTorusTrace, splitTorusTrace, map_add] + rfl + +/-- A nonsplit norm-one eigenvalue of rotation order `d` lies in the same canonical quadratic +right subgroup and represents the scalar-extended base-field trace. -/ +theorem exists_middleGameRightSubgroup_trace_of_nonsplit + (p d : ℕ) [Fact p.Prime] + (t : ZMod p) (w : quadraticNormOneTorus p) + (htrace : quadraticNormOneTrace p w = t) + (hw : (((w : (quadraticFiniteField p)ˣ) : quadraticFiniteField p) ^ 2 ≠ 1)) + (hrotation : rotationOrder t = d) : + ∃ h₂ : middleGameRightSubgroup p d, + algebraMap (ZMod p) (quadraticFiniteField p) t = splitTorusTrace h₂ := by + let u : (quadraticFiniteField p)ˣ := w + have horder : orderOf w = d := by + rw [← rotationOrder_quadraticNormOneTrace p w hw, htrace] + exact hrotation + have hwpow : w ^ d = 1 := by + rw [← horder] + exact pow_orderOf_eq_one w + have hupow : u ^ d = 1 := by + exact congrArg Subtype.val hwpow + let h₂ : middleGameRightSubgroup p d := + ⟨u, (mem_middleGameRightSubgroup_iff_pow_eq_one p d u).mpr hupow⟩ + refine ⟨h₂, ?_⟩ + rw [← htrace] + exact algebraMap_quadraticNormOneTrace p w + +/-- Every nonparabolic normalized trace of rotation order `d` is represented in the canonical +right subgroup. The hypothesis `t^2 != 4` is the explicit boundary separating this theorem +from the parabolic orders `p` and `2 * p`. -/ +theorem exists_middleGameRightSubgroup_trace_of_nonparabolic_rotationOrder + (p d : ℕ) [Fact p.Prime] (hpTwo : p ≠ 2) + (t : ZMod p) (hnonparabolic : t ^ 2 ≠ 4) + (hrotation : rotationOrder t = d) : + ∃ h₂ : middleGameRightSubgroup p d, + algebraMap (ZMod p) (quadraticFiniteField p) t = splitTorusTrace h₂ := by + rcases exists_split_or_quadraticNormOneTrace p hpTwo t hnonparabolic with + ⟨w, htrace, hw⟩ | ⟨w, htrace, hw⟩ + · exact exists_middleGameRightSubgroup_trace_of_split + p d t w htrace hw hrotation + · exact exists_middleGameRightSubgroup_trace_of_nonsplit + p d t w htrace hw hrotation + +/-- Over a prime field, the equation `t^2 = 4` is exactly the explicit parabolic alternative +`t = 2` or `t = -2`. -/ +theorem normalizedTrace_sq_eq_four_iff_parabolic + (p : ℕ) [Fact p.Prime] (t : ZMod p) : + t ^ 2 = 4 ↔ t = 2 ∨ t = -2 := by + constructor + · intro ht + have hfactor : (t - 2) * (t + 2) = 0 := by + calc + (t - 2) * (t + 2) = t ^ 2 - 4 := by ring + _ = 0 := sub_eq_zero.mpr ht + rcases mul_eq_zero.mp hfactor with h | h + · exact Or.inl (sub_eq_zero.mp h) + · exact Or.inr (eq_neg_of_add_eq_zero_left h) + · rintro (rfl | rfl) <;> ring + +/-- Complete candidate-order classification. The canonical right subgroup always has exact +cardinality `d`; a trace of rotation order `d` is either one of the two parabolic parameters or +is represented by a reciprocal trace in that subgroup. -/ +theorem middleGameRightSubgroup_exactCard_and_traceClassification + (p currentOrder d : ℕ) [Fact p.Prime] (hpTwo : p ≠ 2) + (hd : d ∈ middleGameCandidateOrders p currentOrder) + (t : ZMod p) (hrotation : rotationOrder t = d) : + Nat.card (middleGameRightSubgroup p d) = d ∧ + (t = 2 ∨ t = -2 ∨ + ∃ h₂ : middleGameRightSubgroup p d, + algebraMap (ZMod p) (quadraticFiniteField p) t = splitTorusTrace h₂) := by + refine ⟨middleGameRightSubgroup_natCard p currentOrder d hd, ?_⟩ + by_cases hparabolic : t ^ 2 = 4 + · rcases (normalizedTrace_sq_eq_four_iff_parabolic p t).mp hparabolic with h | h + · exact Or.inl h + · exact Or.inr (Or.inl h) + · exact Or.inr (Or.inr + (exists_middleGameRightSubgroup_trace_of_nonparabolic_rotationOrder + p d hpTwo t hparabolic hrotation)) + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/TraceCurveWeights.lean b/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/TraceCurveWeights.lean new file mode 100644 index 0000000000..ca387fddad --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/TraceCurveWeights.lean @@ -0,0 +1,109 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.OrderEscape +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.WeightedIrreducibility +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.WeightedNotSubtorus + +/-! +# Nondegeneracy of the actual middle-game trace-curve coefficients + +The geometric Corvaja--Zannier theorem needs more than a formal weighted equation. This module +proves that the two weights coming from every nonzero nonparabolic Markoff fiber are nonzero and +that their product is not one. These are the exact coefficient hypotheses used by the subsequent +absolute-irreducibility and non-subtorus proofs. +-/ + +@[expose] public section + +namespace BGS.Markoff + +/-- The explicit nonzero and nondegeneracy conditions imply every geometric +Corvaja--Zannier admissibility condition for the weighted trace curve. -/ +theorem weightedTraceCurve_isCorvajaZannierAdmissible_of_nondegenerateWeights + {K : Type*} [Field K] (alpha beta : K) + (halpha : alpha ≠ 0) (hbeta : beta ≠ 0) + (hnondegenerate : alpha * beta ≠ 1) : + WeightedTraceCurveIsCorvajaZannierAdmissible alpha beta := by + apply weightedTraceCurve_isCorvajaZannierAdmissible_of_absoluteIrreducible + alpha beta halpha hbeta hnondegenerate + exact weightedTraceCurve_absolutelyIrreducible + alpha beta halpha hbeta hnondegenerate + +/-- The two weighted trace coefficients attached to a nonzero split-fiber trace are both nonzero, +and their product is the nondegenerate fiber invariant. -/ +theorem splitFiberOrbit_weightedTraceCoefficients_nondegenerate + {E : Type*} [Field E] (w s : Eˣ) + (hw : (w : E) ^ 2 ≠ 1) (htrace : splitTorusTrace w ≠ 0) + (hfour : (4 : E) ≠ 0) : + (s : E) ≠ 0 ∧ + splitFiberProduct w * ((s⁻¹ : Eˣ) : E) ≠ 0 ∧ + (s : E) * (splitFiberProduct w * ((s⁻¹ : Eˣ) : E)) ≠ 1 := by + refine ⟨Units.ne_zero s, ?_, ?_⟩ + · exact mul_ne_zero (splitFiberProduct_ne_zero w hw htrace) (Units.ne_zero (s⁻¹)) + · rw [splitFiberOrbit_weights_mul] + exact splitFiberProduct_ne_one_of_four_ne_zero w hfour + +/-- Four remains nonzero in the canonical quadratic extension of an odd prime field. -/ +theorem four_ne_zero_quadraticFiniteField_of_prime_ne_two + (p : ℕ) [Fact p.Prime] (hpTwo : p ≠ 2) : + (4 : quadraticFiniteField p) ≠ 0 := by + apply (map_ne_zero (algebraMap (ZMod p) (quadraticFiniteField p))).mpr + intro hzero + have hpDvd : p ∣ 4 := (ZMod.natCast_eq_zero_iff 4 p).mp hzero + have hpPrime := (Fact.out : p.Prime) + have hpDvdPow : p ∣ 2 ^ 2 := by simpa using hpDvd + have hpDvdTwo : p ∣ 2 := hpPrime.dvd_of_dvd_pow hpDvdPow + have hpLeTwo : p ≤ 2 := Nat.le_of_dvd (by norm_num) hpDvdTwo + exact hpTwo (Nat.le_antisymm hpLeTwo hpPrime.two_le) + +/-- Concrete nondegeneracy for every diagonalized presentation of a nonzero nonparabolic +normalized Markoff fiber. -/ +theorem diagonalizedFiber_weightedTraceCoefficients_nondegenerate + (p : ℕ) [Fact p.Prime] (hpTwo : p ≠ 2) + (x : NormalizedPoint (ZMod p)) (hnonzero : x.u1 ≠ 0) + (w s : (quadraticFiniteField p)ˣ) + (hw : (w : quadraticFiniteField p) ^ 2 ≠ 1) + (hpoint : algebraMapNormalizedPoint p x = splitFiberPoint w s) : + (s : quadraticFiniteField p) ≠ 0 ∧ + splitFiberProduct w * ((s⁻¹ : (quadraticFiniteField p)ˣ) : + quadraticFiniteField p) ≠ 0 ∧ + (s : quadraticFiniteField p) * + (splitFiberProduct w * ((s⁻¹ : (quadraticFiniteField p)ˣ) : + quadraticFiniteField p)) ≠ 1 := by + have htraceEq : + algebraMap (ZMod p) (quadraticFiniteField p) x.u1 = splitTorusTrace w := + congrArg NormalizedPoint.u1 hpoint + have htrace : splitTorusTrace w ≠ 0 := by + rw [← htraceEq] + exact (map_ne_zero (algebraMap (ZMod p) (quadraticFiniteField p))).mpr hnonzero + exact splitFiberOrbit_weightedTraceCoefficients_nondegenerate + w s hw htrace (four_ne_zero_quadraticFiniteField_of_prime_ne_two p hpTwo) + +/-- Every actual diagonalized nonzero nonparabolic Markoff fiber supplies a +Corvaja--Zannier-admissible weighted trace curve; this is no longer an +independent geometric premise of the order-escape theorem. -/ +theorem diagonalizedFiber_weightedTraceCurve_isCorvajaZannierAdmissible + (p : ℕ) [Fact p.Prime] (hpTwo : p ≠ 2) + (x : NormalizedPoint (ZMod p)) (hnonzero : x.u1 ≠ 0) + (w s : (quadraticFiniteField p)ˣ) + (hw : (w : quadraticFiniteField p) ^ 2 ≠ 1) + (hpoint : algebraMapNormalizedPoint p x = splitFiberPoint w s) : + WeightedTraceCurveIsCorvajaZannierAdmissible + (s : quadraticFiniteField p) + (splitFiberProduct w * ((s⁻¹ : (quadraticFiniteField p)ˣ) : + quadraticFiniteField p)) := by + obtain ⟨halpha, hbeta, hnondegenerate⟩ := + diagonalizedFiber_weightedTraceCoefficients_nondegenerate + p hpTwo x hnonzero w s hw hpoint + exact weightedTraceCurve_isCorvajaZannierAdmissible_of_nondegenerateWeights + (s : quadraticFiniteField p) + (splitFiberProduct w * ((s⁻¹ : (quadraticFiniteField p)ˣ) : + quadraticFiniteField p)) halpha hbeta hnondegenerate + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/TraceEquation.lean b/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/TraceEquation.lean new file mode 100644 index 0000000000..b8440f6649 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/TraceEquation.lean @@ -0,0 +1,144 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Core.TraceClassification + +/-! +# The middle-game trace equation + +This module gives the exact finite solution set for equation (41) and proves the elementary +quadratic-fiber bound used when one subgroup is small. The genuinely deep uniform power-saving +estimate remains a separate Blueprint input. +-/ + +@[expose] public section + +namespace BGS.Markoff + +open Polynomial + +variable {E : Type*} [Field E] [Fintype E] + +/-- The twisted eigenvalue trace `h + sigma / h`. -/ +noncomputable def twistedUnitTrace (sigma : E) (h : Eˣ) : E := + (h : E) + sigma * (h⁻¹ : Eˣ) + +/-- The possible left-hand elements above one fixed right-hand trace. -/ +noncomputable def traceEquationLeftFiber + (sigma : E) (H₁ : Subgroup Eˣ) (h₂ : Eˣ) : Finset H₁ := by + classical + exact Finset.univ.filter fun h₁ => + twistedUnitTrace sigma h₁ = twistedUnitTrace 1 h₂ + +/-- Solutions of the middle-game trace equation inside two finite subgroups. -/ +noncomputable def traceEquationSolutions + (sigma : E) (H₁ H₂ : Subgroup Eˣ) : Finset (H₁ × H₂) := by + classical + exact Finset.univ.biUnion fun h₂ : H₂ => + (traceEquationLeftFiber sigma H₁ h₂).image fun h₁ => (h₁, h₂) + +@[simp] +theorem mem_traceEquationSolutions_iff + {sigma : E} {H₁ H₂ : Subgroup Eˣ} {h : H₁ × H₂} : + h ∈ traceEquationSolutions sigma H₁ H₂ ↔ + twistedUnitTrace sigma h.1 = twistedUnitTrace 1 h.2 := by + classical + constructor + · intro hh + rw [traceEquationSolutions, Finset.mem_biUnion] at hh + obtain ⟨h₂, _, hh⟩ := hh + obtain ⟨h₁, hh₁, heq⟩ := Finset.mem_image.mp hh + have hfirst : h₁ = h.1 := congrArg Prod.fst heq + have hsecond : h₂ = h.2 := congrArg Prod.snd heq + simpa [traceEquationLeftFiber, hfirst, hsecond] using hh₁ + · intro hh + rw [traceEquationSolutions, Finset.mem_biUnion] + refine ⟨h.2, Finset.mem_univ _, ?_⟩ + exact Finset.mem_image.mpr + ⟨h.1, by simpa [traceEquationLeftFiber] using hh, rfl⟩ + +/-- After one trace value is fixed, the other unit satisfies a monic quadratic. -/ +noncomputable def twistedTracePolynomial (sigma trace : E) : E[X] := + X ^ 2 - C trace * X + C sigma + +omit [Fintype E] in +theorem twistedTracePolynomial_monic (sigma trace : E) : + (twistedTracePolynomial sigma trace).Monic := by + exact (isMonicOfDegree_sub_add_two trace sigma).monic + +omit [Fintype E] in +@[simp] +theorem twistedTracePolynomial_natDegree (sigma trace : E) : + (twistedTracePolynomial sigma trace).natDegree = 2 := by + exact (isMonicOfDegree_sub_add_two trace sigma).natDegree_eq + +omit [Fintype E] in +theorem eval_twistedTracePolynomial_eq_zero_iff + (sigma trace : E) (h : Eˣ) : + (twistedTracePolynomial sigma trace).eval (h : E) = 0 ↔ + twistedUnitTrace sigma h = trace := by + have hh : (h : E) ≠ 0 := Units.ne_zero h + simp only [twistedTracePolynomial, eval_add, eval_sub, eval_pow, eval_X, eval_mul, + eval_C] + rw [show twistedUnitTrace sigma h = (h : E) + sigma * (h : E)⁻¹ by + simp [twistedUnitTrace]] + constructor <;> intro heq + · apply (mul_left_cancel₀ hh) + field_simp [hh] + linear_combination heq + · field_simp [hh] at heq + linear_combination heq + +/-- For a fixed right-hand trace, at most two elements of the left subgroup solve the equation. -/ +theorem traceEquationLeftFiber_card_le_two + (sigma : E) (H₁ : Subgroup Eˣ) (h₂ : Eˣ) : + (traceEquationLeftFiber sigma H₁ h₂).card ≤ 2 := by + classical + let f := twistedTracePolynomial sigma (twistedUnitTrace 1 h₂) + have hf : f ≠ 0 := (twistedTracePolynomial_monic sigma _).ne_zero + let rootEmbedding : ↥(traceEquationLeftFiber sigma H₁ h₂) ↪ ↥f.roots.toFinset := + { toFun := fun h₁ => ⟨((h₁.1 : Eˣ) : E), by + rw [Multiset.mem_toFinset, Polynomial.mem_roots hf] + apply (eval_twistedTracePolynomial_eq_zero_iff sigma _ h₁.1).2 + simpa only [traceEquationLeftFiber, Finset.mem_filter, Finset.mem_univ, true_and] + using h₁.2⟩ + inj' := by + intro x y hxy + apply Subtype.ext + apply Subtype.ext + apply Units.ext + exact congrArg Subtype.val hxy } + have hcard : + (traceEquationLeftFiber sigma H₁ h₂).card ≤ f.roots.toFinset.card := by + simpa only [Fintype.card_coe] using + Fintype.card_le_of_injective rootEmbedding rootEmbedding.injective + calc + (traceEquationLeftFiber sigma H₁ h₂).card ≤ f.roots.toFinset.card := hcard + _ ≤ f.roots.card := Multiset.toFinset_card_le _ + _ ≤ f.natDegree := Polynomial.card_roots' f + _ = 2 := twistedTracePolynomial_natDegree sigma _ + +/-- The elementary bounded-right-subgroup estimate: every right element has at most two lifts. -/ +theorem traceEquationSolutions_card_le_two_mul_right + (sigma : E) (H₁ H₂ : Subgroup Eˣ) : + (traceEquationSolutions sigma H₁ H₂).card ≤ 2 * Nat.card H₂ := by + classical + unfold traceEquationSolutions + calc + (Finset.univ.biUnion fun h₂ : H₂ => + (traceEquationLeftFiber sigma H₁ h₂).image fun h₁ => (h₁, h₂)).card ≤ + Finset.univ.card * 2 := by + apply Finset.card_biUnion_le_card_mul + intro h₂ _ + exact Finset.card_image_le.trans + (traceEquationLeftFiber_card_le_two sigma H₁ h₂) + _ = 2 * Nat.card H₂ := by + rw [Finset.card_univ, Fintype.card_eq_nat_card] + omega + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/UnionBound.lean b/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/UnionBound.lean new file mode 100644 index 0000000000..44ea0511e5 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/UnionBound.lean @@ -0,0 +1,252 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.TraceEquation +public import LeanPool.MarkoffModP.BGS.NumberTheory.DivisorBound + +/-! +# The middle-game bad-order union + +The published middle game considers, for a left rotation group `H₁`, every possible right +rotation order `d ≤ |H₁|` dividing `p - 1` or `p + 1`. A power-saving estimate for the +trace equation bounds the left elements that can meet a right subgroup of each such order. The +divisor bound then makes the union of all those exceptional left elements smaller than `H₁`. + +This file formalizes that finite combinatorial wiring. It deliberately does not postulate the +Corvaja--Zannier estimate: the estimate appears below as an ordinary theorem hypothesis on the +actual trace-equation solution finsets. +-/ + +@[expose] public section + +namespace BGS.Markoff + +/-- Candidate right rotation orders in the middle game: divisors of `p - 1` or `p + 1` that do +not exceed the current left rotation order. -/ +def middleGameCandidateOrders (p currentOrder : ℕ) : Finset ℕ := + ((p - 1).divisors ∪ (p + 1).divisors).filter fun d ↦ d ≤ currentOrder + +theorem mem_middleGameCandidateOrders_iff {p currentOrder d : ℕ} : + d ∈ middleGameCandidateOrders p currentOrder ↔ + d ≤ currentOrder ∧ (d ∣ p - 1 ∧ p - 1 ≠ 0 ∨ d ∣ p + 1) := by + simp only [middleGameCandidateOrders, Finset.mem_filter, Finset.mem_union, + Nat.mem_divisors] + constructor + · rintro ⟨hd, hle⟩ + refine ⟨hle, ?_⟩ + rcases hd with hd | hd + · exact Or.inl hd + · exact Or.inr hd.1 + · rintro ⟨hle, hd⟩ + refine ⟨?_, hle⟩ + rcases hd with hd | hd + · exact Or.inl hd + · exact Or.inr ⟨hd, by omega⟩ + +/-- There are no more candidate orders than the sum of the two divisor counts. -/ +theorem middleGameCandidateOrders_card_le (p currentOrder : ℕ) : + (middleGameCandidateOrders p currentOrder).card ≤ + (p - 1).divisors.card + (p + 1).divisors.card := by + calc + (middleGameCandidateOrders p currentOrder).card ≤ + ((p - 1).divisors ∪ (p + 1).divisors).card := + Finset.card_le_card (Finset.filter_subset _ _) + _ ≤ (p - 1).divisors.card + (p + 1).divisors.card := Finset.card_union_le _ _ + +/-- The proved subpolynomial divisor estimate controls both possible torus orders at once. This +is the analytic input needed after taking the finite union over candidate right rotation orders. -/ +theorem exists_threshold_middleGameCandidateOrders_card_le_two_mul_rpow + {ε : ℝ} (hε : 0 < ε) : + ∃ threshold : ℕ, ∀ p currentOrder : ℕ, threshold ≤ p → + ((middleGameCandidateOrders p currentOrder).card : ℝ) ≤ + 2 * ((p + 1 : ℕ) : ℝ) ^ ε := by + obtain ⟨N, hN⟩ := BGS.NumberTheory.exists_threshold_card_divisors_le_rpow hε + refine ⟨N + 1, ?_⟩ + intro p currentOrder hp + have hpMinus : N ≤ p - 1 := by omega + have hpPlus : N ≤ p + 1 := by omega + have hMinus := hN (p - 1) hpMinus + have hPlus := hN (p + 1) hpPlus + have hCandidate : + ((middleGameCandidateOrders p currentOrder).card : ℝ) ≤ + (((p - 1).divisors.card + (p + 1).divisors.card : ℕ) : ℝ) := by + exact_mod_cast middleGameCandidateOrders_card_le p currentOrder + have hBase : (((p - 1 : ℕ) : ℝ)) ≤ (((p + 1 : ℕ) : ℝ)) := by + exact_mod_cast (show p - 1 ≤ p + 1 by omega) + have hPower : (((p - 1 : ℕ) : ℝ)) ^ ε ≤ (((p + 1 : ℕ) : ℝ)) ^ ε := + Real.rpow_le_rpow (Nat.cast_nonneg _) hBase hε.le + calc + ((middleGameCandidateOrders p currentOrder).card : ℝ) ≤ + (((p - 1).divisors.card + (p + 1).divisors.card : ℕ) : ℝ) := hCandidate + _ = ((p - 1).divisors.card : ℝ) + ((p + 1).divisors.card : ℝ) := by + norm_num + _ ≤ (((p - 1 : ℕ) : ℝ)) ^ ε + (((p + 1 : ℕ) : ℝ)) ^ ε := + add_le_add hMinus hPlus + _ ≤ (((p + 1 : ℕ) : ℝ)) ^ ε + (((p + 1 : ℕ) : ℝ)) ^ ε := + add_le_add hPower (le_refl _) + _ = 2 * (((p + 1 : ℕ) : ℝ)) ^ ε := by ring + +variable {E : Type*} [Field E] [Fintype E] + +/-- Left elements of `H₁` occurring in the trace equation with some element of `H₂`. -/ +noncomputable def traceEquationLeftSupport + (sigma : E) (H₁ H₂ : Subgroup Eˣ) : Finset H₁ := by + classical + exact (traceEquationSolutions sigma H₁ H₂).image Prod.fst + +@[simp] +theorem mem_traceEquationLeftSupport_iff + {sigma : E} {H₁ H₂ : Subgroup Eˣ} {h₁ : H₁} : + h₁ ∈ traceEquationLeftSupport sigma H₁ H₂ ↔ + ∃ h₂ : H₂, twistedUnitTrace sigma h₁ = twistedUnitTrace 1 h₂ := by + classical + simp only [traceEquationLeftSupport, Finset.mem_image] + constructor + · rintro ⟨h, hh, rfl⟩ + exact ⟨h.2, (mem_traceEquationSolutions_iff.mp hh)⟩ + · rintro ⟨h₂, heq⟩ + exact ⟨(h₁, h₂), mem_traceEquationSolutions_iff.mpr heq, rfl⟩ + +/-- Projection to the left coordinate cannot increase the number of trace-equation solutions. -/ +theorem traceEquationLeftSupport_card_le_solutions + (sigma : E) (H₁ H₂ : Subgroup Eˣ) : + (traceEquationLeftSupport sigma H₁ H₂).card ≤ + (traceEquationSolutions sigma H₁ H₂).card := by + classical + exact Finset.card_image_le + +/-- The safe coefficient obtained from Corvaja--Zannier, Corollary 2, after specializing its +explicit constants to the middle-game trace curve. -/ +def corvajaZannierCorollaryTwoSafeCoefficient : ℕ := 48 + +/-- The numerical right-hand side of the Corvaja--Zannier trace estimate used in the published +paper, with the source-justified safe coefficient from Corollary 2 kept explicit. -/ +noncomputable def corvajaZannierTraceUpperBound + (p leftOrder rightOrder : ℕ) : ℝ := + corvajaZannierCorollaryTwoSafeCoefficient * max + (((leftOrder * rightOrder : ℕ) : ℝ) ^ ((1 : ℝ) / 3)) + (((leftOrder * rightOrder : ℕ) : ℝ) / p) + +/-- All left elements that meet at least one member of a supplied family of right subgroups. -/ +noncomputable def badOrderTraceSupport + (sigma : E) (H₁ : Subgroup Eˣ) (orders : Finset ℕ) + (rightSubgroup : ℕ → Subgroup Eˣ) : Finset H₁ := by + classical + exact orders.biUnion fun d ↦ traceEquationLeftSupport sigma H₁ (rightSubgroup d) + +@[simp] +theorem mem_badOrderTraceSupport_iff + {sigma : E} {H₁ : Subgroup Eˣ} {orders : Finset ℕ} + {rightSubgroup : ℕ → Subgroup Eˣ} {h₁ : H₁} : + h₁ ∈ badOrderTraceSupport sigma H₁ orders rightSubgroup ↔ + ∃ d ∈ orders, ∃ h₂ : rightSubgroup d, + twistedUnitTrace sigma h₁ = twistedUnitTrace 1 h₂ := by + classical + simp [badOrderTraceSupport] + +/-- A uniform bound for each trace-equation solution set gives the expected finite-union bound. -/ +theorem badOrderTraceSupport_card_le + (sigma : E) (H₁ : Subgroup Eˣ) (orders : Finset ℕ) + (rightSubgroup : ℕ → Subgroup Eˣ) (bound : ℕ) + (hbound : ∀ d ∈ orders, + (traceEquationSolutions sigma H₁ (rightSubgroup d)).card ≤ bound) : + (badOrderTraceSupport sigma H₁ orders rightSubgroup).card ≤ orders.card * bound := by + classical + unfold badOrderTraceSupport + apply Finset.card_biUnion_le_card_mul + intro d hd + exact (traceEquationLeftSupport_card_le_solutions sigma H₁ (rightSubgroup d)).trans + (hbound d hd) + +/-- A nonuniform real-valued estimate for the individual trace equations sums over the candidate +orders. This form accepts the quoted Corvaja--Zannier bound without rounding it to a natural +number. -/ +theorem badOrderTraceSupport_card_cast_le_sum + (sigma : E) (H₁ : Subgroup Eˣ) (orders : Finset ℕ) + (rightSubgroup : ℕ → Subgroup Eˣ) (bound : ℕ → ℝ) + (hbound : ∀ d ∈ orders, + ((traceEquationSolutions sigma H₁ (rightSubgroup d)).card : ℝ) ≤ bound d) : + ((badOrderTraceSupport sigma H₁ orders rightSubgroup).card : ℝ) ≤ + ∑ d ∈ orders, bound d := by + classical + calc + ((badOrderTraceSupport sigma H₁ orders rightSubgroup).card : ℝ) ≤ + ∑ d ∈ orders, ((traceEquationLeftSupport sigma H₁ (rightSubgroup d)).card : ℝ) := by + exact_mod_cast (Finset.card_biUnion_le : + (badOrderTraceSupport sigma H₁ orders rightSubgroup).card ≤ + ∑ d ∈ orders, (traceEquationLeftSupport sigma H₁ (rightSubgroup d)).card) + _ ≤ ∑ d ∈ orders, + ((traceEquationSolutions sigma H₁ (rightSubgroup d)).card : ℝ) := by + exact Finset.sum_le_sum fun d _ ↦ by + exact_mod_cast traceEquationLeftSupport_card_le_solutions sigma H₁ (rightSubgroup d) + _ ≤ ∑ d ∈ orders, bound d := Finset.sum_le_sum hbound + +/-- Direct wiring of the quoted Corvaja--Zannier estimate into the finite bad-order union. The +deep estimate is the explicit hypothesis `hCZ`; this theorem proves only its combinatorial use. -/ +theorem middleGameBadOrderTraceSupport_card_cast_le_corvajaZannierSum + (p : ℕ) (sigma : E) (H₁ : Subgroup Eˣ) + (rightSubgroup : ℕ → Subgroup Eˣ) + (hCZ : ∀ d ∈ middleGameCandidateOrders p (Nat.card H₁), + ((traceEquationSolutions sigma H₁ (rightSubgroup d)).card : ℝ) ≤ + corvajaZannierTraceUpperBound p (Nat.card H₁) d) : + ((badOrderTraceSupport sigma H₁ (middleGameCandidateOrders p (Nat.card H₁)) + rightSubgroup).card : ℝ) ≤ + ∑ d ∈ middleGameCandidateOrders p (Nat.card H₁), + corvajaZannierTraceUpperBound p (Nat.card H₁) d := + badOrderTraceSupport_card_cast_le_sum sigma H₁ _ rightSubgroup _ hCZ + +/-- The published bad-order union bound, with the deep estimate exposed as a bound on each actual +trace-equation solution set. -/ +theorem middleGameBadOrderTraceSupport_card_le + (p : ℕ) (sigma : E) (H₁ : Subgroup Eˣ) + (rightSubgroup : ℕ → Subgroup Eˣ) (bound : ℕ) + (hbound : ∀ d ∈ middleGameCandidateOrders p (Nat.card H₁), + (traceEquationSolutions sigma H₁ (rightSubgroup d)).card ≤ bound) : + (badOrderTraceSupport sigma H₁ (middleGameCandidateOrders p (Nat.card H₁)) + rightSubgroup).card ≤ + ((p - 1).divisors.card + (p + 1).divisors.card) * bound := by + calc + (badOrderTraceSupport sigma H₁ (middleGameCandidateOrders p (Nat.card H₁)) + rightSubgroup).card ≤ + (middleGameCandidateOrders p (Nat.card H₁)).card * bound := + badOrderTraceSupport_card_le sigma H₁ _ rightSubgroup bound hbound + _ ≤ ((p - 1).divisors.card + (p + 1).divisors.card) * bound := + Nat.mul_le_mul_right bound (middleGameCandidateOrders_card_le p (Nat.card H₁)) + +/-- If the divisor-counted union is strictly smaller than `H₁`, some left rotation element +cannot meet any right subgroup of candidate order. This is the exact pigeonhole step used to +increase the maximal rotation order in the published middle game. -/ +theorem exists_left_element_escaping_middleGameCandidateOrders + (p : ℕ) (sigma : E) (H₁ : Subgroup Eˣ) + (rightSubgroup : ℕ → Subgroup Eˣ) (bound : ℕ) + (hbound : ∀ d ∈ middleGameCandidateOrders p (Nat.card H₁), + (traceEquationSolutions sigma H₁ (rightSubgroup d)).card ≤ bound) + (hsmall : ((p - 1).divisors.card + (p + 1).divisors.card) * bound < Nat.card H₁) : + ∃ h₁ : H₁, ∀ d ∈ middleGameCandidateOrders p (Nat.card H₁), + ∀ h₂ : rightSubgroup d, + twistedUnitTrace sigma h₁ ≠ twistedUnitTrace 1 h₂ := by + classical + let bad := badOrderTraceSupport sigma H₁ + (middleGameCandidateOrders p (Nat.card H₁)) rightSubgroup + have hbad : bad.card < Nat.card H₁ := + (middleGameBadOrderTraceSupport_card_le p sigma H₁ rightSubgroup bound hbound).trans_lt + hsmall + have hexists : ∃ h₁ : H₁, h₁ ∉ bad := by + by_contra hall + push Not at hall + have hle : (Finset.univ : Finset H₁).card ≤ bad.card := + Finset.card_le_card fun h₁ _ ↦ hall h₁ + rw [Finset.card_univ, Fintype.card_eq_nat_card] at hle + exact (Nat.not_le_of_lt hbad) hle + obtain ⟨h₁, hh₁⟩ := hexists + refine ⟨h₁, ?_⟩ + intro d hd h₂ heq + apply hh₁ + exact mem_badOrderTraceSupport_iff.mpr ⟨d, hd, h₂, heq⟩ + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/WeightedTraceBound.lean b/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/WeightedTraceBound.lean new file mode 100644 index 0000000000..484e8dc3fc --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/WeightedTraceBound.lean @@ -0,0 +1,86 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.CorvajaZannierSeparability +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.CorvajaZannierSourceBound + +/-! +# The weighted-trace torsion-intersection bound + +This module records the exact numerical statement consumed by the Markoff middle game. The +statement is intentionally independent of how the estimate is proved, so low-level escape lemmas +do not import the full general Corvaja--Zannier development. + +The bound is uniform in the two weights and the two torsion orders. Its hypotheses expose the +actual curve admissibility, positivity, and prime-to-characteristic requirements. The completed +producer `corvajaZannierWeightedTraceBound` supplies this statement from the in-repository general +Corvaja--Zannier theorem. + +The conclusion is the safe coefficient-`48` envelope used by the downstream middle game. This +permits the genuine degree-only Euler bound `χ ≤ 8` for a general bidegree-`(2,2)` torus curve; no +unsupported genus-one identification is built into the interface. +-/ + +@[expose] public section + +namespace BGS.Markoff + +noncomputable section + +/-- The numerical weighted-trace torsion-intersection statement used by the middle game. + +This is a lightweight internal proof boundary, not an external assumption. The selected BGS path +constructs it with `corvajaZannierWeightedTraceBound`. -/ +def WeightedTraceTorsionIntersectionBound + (p : ℕ) [Fact p.Prime] + (E : Type*) [Field E] [Fintype E] [CharP E p] : Prop := + ∀ (alpha beta : E) (leftOrder rightOrder : ℕ), + WeightedTraceCurveIsCorvajaZannierAdmissible alpha beta → + 0 < leftOrder → + 0 < rightOrder → + ¬ p ∣ leftOrder → + ¬ p ∣ rightOrder → + ((weightedTraceCurveTorsionIntersection alpha beta + leftOrder rightOrder).card : ℝ) ≤ + corvajaZannierTraceUpperBound p leftOrder rightOrder + +variable (p : ℕ) [Fact p.Prime] +variable (E : Type*) [Field E] [Fintype E] [CharP E p] + +/-- Multiplicative subgroup orders satisfy every arithmetic side condition in the weighted-trace +torsion-intersection bound. -/ +theorem multiplicativeSubgroups_satisfy_weightedTraceBoundOrderHypotheses + (H₁ H₂ : Subgroup Eˣ) : + 0 < Nat.card H₁ ∧ 0 < Nat.card H₂ ∧ + ¬ p ∣ Nat.card H₁ ∧ ¬ p ∣ Nat.card H₂ := by + refine ⟨Nat.card_pos, Nat.card_pos, ?_⟩ + exact weightedTraceCurveTorsionIntersection_orders_primeToCharacteristic p H₁ H₂ + +/-- Apply the weighted-trace torsion-intersection bound after Lean has proved the concrete curve is +admissible and both subgroup orders satisfy the source's arithmetic hypotheses. -/ +theorem weightedTraceEquationSolutions_card_cast_le_of_weightedTraceBound + (hBound : WeightedTraceTorsionIntersectionBound p E) + (alpha beta : E) (H₁ H₂ : Subgroup Eˣ) + (hadmissible : WeightedTraceCurveIsCorvajaZannierAdmissible alpha beta) : + ((weightedTraceEquationSolutions alpha beta H₁ H₂).card : ℝ) ≤ + corvajaZannierTraceUpperBound p (Nat.card H₁) (Nat.card H₂) := by + have hfinite : + ((weightedTraceEquationSolutions alpha beta H₁ H₂).card : ℝ) ≤ + ((weightedTraceCurveTorsionIntersection alpha beta + (Nat.card H₁) (Nat.card H₂)).card : ℝ) := by + exact_mod_cast weightedTraceEquationSolutions_card_le_curveTorsionIntersection + alpha beta H₁ H₂ + obtain ⟨hleftPositive, hrightPositive, hleftPrime, hrightPrime⟩ := + multiplicativeSubgroups_satisfy_weightedTraceBoundOrderHypotheses p E H₁ H₂ + have hsource := hBound alpha beta (Nat.card H₁) (Nat.card H₂) + hadmissible hleftPositive hrightPositive hleftPrime hrightPrime + exact hfinite.trans hsource + +end + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/WeightedTraceEquation.lean b/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/WeightedTraceEquation.lean new file mode 100644 index 0000000000..de1f8994eb --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/WeightedTraceEquation.lean @@ -0,0 +1,361 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.CorvajaZannierStep +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.Geometry + +/-! +# The weighted middle-game trace equation + +An arbitrary Markoff rotation orbit produces the equation + +`alpha * h₁ + beta / h₁ = h₂ + 1 / h₂`, + +with `h₁` in the cyclic rotation subgroup. This module formalizes its finite solution sets, +the elementary quadratic-fiber bound, and the complete bad-order union and pigeonhole reduction. +The deep weighted Corvaja--Zannier estimate is an explicit theorem hypothesis; it is not encoded +as an axiom, class, or structure field. +-/ + +@[expose] public section + +namespace BGS.Markoff + +open Polynomial + +variable {E : Type*} [Field E] [Fintype E] + +/-- The possible left subgroup elements above one fixed right trace in the weighted equation. -/ +noncomputable def weightedTraceEquationLeftFiber + (alpha beta : E) (H₁ : Subgroup Eˣ) (h₂ : Eˣ) : Finset H₁ := by + classical + exact Finset.univ.filter fun h₁ ↦ + weightedSplitTorusTrace alpha beta h₁ = splitTorusTrace h₂ + +/-- Solutions of the weighted middle-game trace equation inside two finite subgroups. -/ +noncomputable def weightedTraceEquationSolutions + (alpha beta : E) (H₁ H₂ : Subgroup Eˣ) : Finset (H₁ × H₂) := by + classical + exact Finset.univ.biUnion fun h₂ : H₂ ↦ + (weightedTraceEquationLeftFiber alpha beta H₁ h₂).image fun h₁ ↦ (h₁, h₂) + +@[simp] +theorem mem_weightedTraceEquationSolutions_iff + {alpha beta : E} {H₁ H₂ : Subgroup Eˣ} {h : H₁ × H₂} : + h ∈ weightedTraceEquationSolutions alpha beta H₁ H₂ ↔ + weightedSplitTorusTrace alpha beta h.1 = splitTorusTrace h.2 := by + classical + constructor + · intro hh + rw [weightedTraceEquationSolutions, Finset.mem_biUnion] at hh + obtain ⟨h₂, _, hh⟩ := hh + obtain ⟨h₁, hh₁, heq⟩ := Finset.mem_image.mp hh + have hfirst : h₁ = h.1 := congrArg Prod.fst heq + have hsecond : h₂ = h.2 := congrArg Prod.snd heq + simpa [weightedTraceEquationLeftFiber, hfirst, hsecond] using hh₁ + · intro hh + rw [weightedTraceEquationSolutions, Finset.mem_biUnion] + refine ⟨h.2, Finset.mem_univ _, ?_⟩ + exact Finset.mem_image.mpr + ⟨h.1, by simpa [weightedTraceEquationLeftFiber] using hh, rfl⟩ + +omit [Fintype E] in +/-- Dividing the weighted equation by its nonzero leading weight gives the monic twisted-trace +equation used by the existing quadratic polynomial API. -/ +theorem weightedSplitTorusTrace_eq_iff_twistedUnitTrace_eq + (alpha beta trace : E) (h : Eˣ) (halpha : alpha ≠ 0) : + weightedSplitTorusTrace alpha beta h = trace ↔ + twistedUnitTrace (beta / alpha) h = trace / alpha := by + simp only [weightedSplitTorusTrace, twistedUnitTrace] + have hh : (h : E) ≠ 0 := Units.ne_zero h + field_simp [halpha, hh] + +/-- For a fixed right-hand trace, at most two left subgroup elements solve the weighted +equation when the leading weight is nonzero. -/ +theorem weightedTraceEquationLeftFiber_card_le_two + (alpha beta : E) (H₁ : Subgroup Eˣ) (h₂ : Eˣ) (halpha : alpha ≠ 0) : + (weightedTraceEquationLeftFiber alpha beta H₁ h₂).card ≤ 2 := by + classical + let f := twistedTracePolynomial (beta / alpha) (splitTorusTrace h₂ / alpha) + have hf : f ≠ 0 := (twistedTracePolynomial_monic (beta / alpha) _).ne_zero + let rootEmbedding : ↥(weightedTraceEquationLeftFiber alpha beta H₁ h₂) ↪ + ↥f.roots.toFinset := + { toFun := fun h₁ ↦ ⟨((h₁.1 : Eˣ) : E), by + rw [Multiset.mem_toFinset, Polynomial.mem_roots hf] + apply (eval_twistedTracePolynomial_eq_zero_iff (beta / alpha) _ h₁.1).2 + apply (weightedSplitTorusTrace_eq_iff_twistedUnitTrace_eq + alpha beta (splitTorusTrace h₂) h₁.1 halpha).mp + simpa only [weightedTraceEquationLeftFiber, Finset.mem_filter, + Finset.mem_univ, true_and] using h₁.2⟩ + inj' := by + intro x y hxy + apply Subtype.ext + apply Subtype.ext + apply Units.ext + exact congrArg Subtype.val hxy } + have hcard : + (weightedTraceEquationLeftFiber alpha beta H₁ h₂).card ≤ f.roots.toFinset.card := by + simpa only [Fintype.card_coe] using + Fintype.card_le_of_injective rootEmbedding rootEmbedding.injective + calc + (weightedTraceEquationLeftFiber alpha beta H₁ h₂).card ≤ f.roots.toFinset.card := hcard + _ ≤ f.roots.card := Multiset.toFinset_card_le _ + _ ≤ f.natDegree := Polynomial.card_roots' f + _ = 2 := twistedTracePolynomial_natDegree (beta / alpha) _ + +/-- The elementary weighted estimate: every right subgroup element has at most two lifts. -/ +theorem weightedTraceEquationSolutions_card_le_two_mul_right + (alpha beta : E) (H₁ H₂ : Subgroup Eˣ) (halpha : alpha ≠ 0) : + (weightedTraceEquationSolutions alpha beta H₁ H₂).card ≤ 2 * Nat.card H₂ := by + classical + unfold weightedTraceEquationSolutions + calc + (Finset.univ.biUnion fun h₂ : H₂ ↦ + (weightedTraceEquationLeftFiber alpha beta H₁ h₂).image fun h₁ ↦ (h₁, h₂)).card ≤ + Finset.univ.card * 2 := by + apply Finset.card_biUnion_le_card_mul + intro h₂ _ + exact Finset.card_image_le.trans + (weightedTraceEquationLeftFiber_card_le_two alpha beta H₁ h₂ halpha) + _ = 2 * Nat.card H₂ := by + rw [Finset.card_univ, Fintype.card_eq_nat_card] + omega + +/-- Left elements occurring in the weighted trace equation with some right subgroup element. -/ +noncomputable def weightedTraceEquationLeftSupport + (alpha beta : E) (H₁ H₂ : Subgroup Eˣ) : Finset H₁ := by + classical + exact (weightedTraceEquationSolutions alpha beta H₁ H₂).image Prod.fst + +@[simp] +theorem mem_weightedTraceEquationLeftSupport_iff + {alpha beta : E} {H₁ H₂ : Subgroup Eˣ} {h₁ : H₁} : + h₁ ∈ weightedTraceEquationLeftSupport alpha beta H₁ H₂ ↔ + ∃ h₂ : H₂, + weightedSplitTorusTrace alpha beta h₁ = splitTorusTrace h₂ := by + classical + simp only [weightedTraceEquationLeftSupport, Finset.mem_image] + constructor + · rintro ⟨h, hh, rfl⟩ + exact ⟨h.2, mem_weightedTraceEquationSolutions_iff.mp hh⟩ + · rintro ⟨h₂, heq⟩ + exact ⟨(h₁, h₂), mem_weightedTraceEquationSolutions_iff.mpr heq, rfl⟩ + +/-- Projection to the left coordinate cannot increase the weighted solution count. -/ +theorem weightedTraceEquationLeftSupport_card_le_solutions + (alpha beta : E) (H₁ H₂ : Subgroup Eˣ) : + (weightedTraceEquationLeftSupport alpha beta H₁ H₂).card ≤ + (weightedTraceEquationSolutions alpha beta H₁ H₂).card := by + classical + exact Finset.card_image_le + +/-- Left elements meeting at least one member of an indexed family of right subgroups. -/ +noncomputable def weightedBadOrderTraceSupport + (alpha beta : E) (H₁ : Subgroup Eˣ) (orders : Finset ℕ) + (rightSubgroup : ℕ → Subgroup Eˣ) : Finset H₁ := by + classical + exact orders.biUnion fun d ↦ + weightedTraceEquationLeftSupport alpha beta H₁ (rightSubgroup d) + +@[simp] +theorem mem_weightedBadOrderTraceSupport_iff + {alpha beta : E} {H₁ : Subgroup Eˣ} {orders : Finset ℕ} + {rightSubgroup : ℕ → Subgroup Eˣ} {h₁ : H₁} : + h₁ ∈ weightedBadOrderTraceSupport alpha beta H₁ orders rightSubgroup ↔ + ∃ d ∈ orders, ∃ h₂ : rightSubgroup d, + weightedSplitTorusTrace alpha beta h₁ = splitTorusTrace h₂ := by + classical + simp [weightedBadOrderTraceSupport] + +/-- A real-valued estimate for each weighted solution set sums over an arbitrary finite family +of candidate right orders. -/ +theorem weightedBadOrderTraceSupport_card_cast_le_sum + (alpha beta : E) (H₁ : Subgroup Eˣ) (orders : Finset ℕ) + (rightSubgroup : ℕ → Subgroup Eˣ) (bound : ℕ → ℝ) + (hbound : ∀ d ∈ orders, + ((weightedTraceEquationSolutions alpha beta H₁ (rightSubgroup d)).card : ℝ) ≤ + bound d) : + ((weightedBadOrderTraceSupport alpha beta H₁ orders rightSubgroup).card : ℝ) ≤ + ∑ d ∈ orders, bound d := by + classical + calc + ((weightedBadOrderTraceSupport alpha beta H₁ orders rightSubgroup).card : ℝ) ≤ + ∑ d ∈ orders, + ((weightedTraceEquationLeftSupport alpha beta H₁ (rightSubgroup d)).card : ℝ) := by + exact_mod_cast (Finset.card_biUnion_le : + (weightedBadOrderTraceSupport alpha beta H₁ orders rightSubgroup).card ≤ + ∑ d ∈ orders, + (weightedTraceEquationLeftSupport alpha beta H₁ (rightSubgroup d)).card) + _ ≤ ∑ d ∈ orders, + ((weightedTraceEquationSolutions alpha beta H₁ (rightSubgroup d)).card : ℝ) := by + exact Finset.sum_le_sum fun d _ ↦ by + exact_mod_cast weightedTraceEquationLeftSupport_card_le_solutions + alpha beta H₁ (rightSubgroup d) + _ ≤ ∑ d ∈ orders, bound d := Finset.sum_le_sum hbound + +/-- A uniform natural-valued bound gives the corresponding weighted finite-union bound. -/ +theorem weightedBadOrderTraceSupport_card_le + (alpha beta : E) (H₁ : Subgroup Eˣ) (orders : Finset ℕ) + (rightSubgroup : ℕ → Subgroup Eˣ) (bound : ℕ) + (hbound : ∀ d ∈ orders, + (weightedTraceEquationSolutions alpha beta H₁ (rightSubgroup d)).card ≤ bound) : + (weightedBadOrderTraceSupport alpha beta H₁ orders rightSubgroup).card ≤ + orders.card * bound := by + classical + unfold weightedBadOrderTraceSupport + apply Finset.card_biUnion_le_card_mul + intro d hd + exact (weightedTraceEquationLeftSupport_card_le_solutions + alpha beta H₁ (rightSubgroup d)).trans (hbound d hd) + +/-- The published divisor-counted natural-valued weighted bad-order bound. -/ +theorem middleGameWeightedBadOrderTraceSupport_card_le + (p : ℕ) (alpha beta : E) (H₁ : Subgroup Eˣ) + (rightSubgroup : ℕ → Subgroup Eˣ) (bound : ℕ) + (hbound : ∀ d ∈ middleGameCandidateOrders p (Nat.card H₁), + (weightedTraceEquationSolutions alpha beta H₁ (rightSubgroup d)).card ≤ bound) : + (weightedBadOrderTraceSupport alpha beta H₁ + (middleGameCandidateOrders p (Nat.card H₁)) rightSubgroup).card ≤ + ((p - 1).divisors.card + (p + 1).divisors.card) * bound := by + calc + (weightedBadOrderTraceSupport alpha beta H₁ + (middleGameCandidateOrders p (Nat.card H₁)) rightSubgroup).card ≤ + (middleGameCandidateOrders p (Nat.card H₁)).card * bound := + weightedBadOrderTraceSupport_card_le alpha beta H₁ _ rightSubgroup bound hbound + _ ≤ ((p - 1).divisors.card + (p + 1).divisors.card) * bound := + Nat.mul_le_mul_right bound (middleGameCandidateOrders_card_le p (Nat.card H₁)) + +/-- The weighted Corvaja--Zannier estimate, when supplied for each actual right subgroup, +sums to the same numerical expression as in the normalized equation. The essential +nondegeneracy `alpha * beta != 1` is an explicit premise of the estimate. -/ +theorem middleGameWeightedBadOrderTraceSupport_card_cast_le_corvajaZannierSum + (p : ℕ) (alpha beta : E) (H₁ : Subgroup Eˣ) + (rightSubgroup : ℕ → Subgroup Eˣ) + (hrightOrder : ∀ d ∈ middleGameCandidateOrders p (Nat.card H₁), + Nat.card (rightSubgroup d) = d) + (hCZ : alpha * beta ≠ 1 → + ∀ d ∈ middleGameCandidateOrders p (Nat.card H₁), + ((weightedTraceEquationSolutions alpha beta H₁ (rightSubgroup d)).card : ℝ) ≤ + corvajaZannierTraceUpperBound p (Nat.card H₁) + (Nat.card (rightSubgroup d))) + (hnondegenerate : alpha * beta ≠ 1) : + ((weightedBadOrderTraceSupport alpha beta H₁ + (middleGameCandidateOrders p (Nat.card H₁)) rightSubgroup).card : ℝ) ≤ + ∑ d ∈ middleGameCandidateOrders p (Nat.card H₁), + corvajaZannierTraceUpperBound p (Nat.card H₁) d := by + apply weightedBadOrderTraceSupport_card_cast_le_sum + intro d hd + have hEstimate := hCZ hnondegenerate d hd + rw [hrightOrder d hd] at hEstimate + exact hEstimate + +/-- Combining the weighted Corvaja--Zannier estimate with the common current-order envelope. -/ +theorem middleGameWeightedBadOrderTraceSupport_card_cast_le_divisorEnvelope + (p : ℕ) (alpha beta : E) (H₁ : Subgroup Eˣ) + (rightSubgroup : ℕ → Subgroup Eˣ) + (hrightOrder : ∀ d ∈ middleGameCandidateOrders p (Nat.card H₁), + Nat.card (rightSubgroup d) = d) + (hCZ : alpha * beta ≠ 1 → + ∀ d ∈ middleGameCandidateOrders p (Nat.card H₁), + ((weightedTraceEquationSolutions alpha beta H₁ (rightSubgroup d)).card : ℝ) ≤ + corvajaZannierTraceUpperBound p (Nat.card H₁) + (Nat.card (rightSubgroup d))) + (hnondegenerate : alpha * beta ≠ 1) : + ((weightedBadOrderTraceSupport alpha beta H₁ + (middleGameCandidateOrders p (Nat.card H₁)) rightSubgroup).card : ℝ) ≤ + (((p - 1).divisors.card + (p + 1).divisors.card : ℕ) : ℝ) * + corvajaZannierCurrentOrderEnvelope p (Nat.card H₁) := by + exact (middleGameWeightedBadOrderTraceSupport_card_cast_le_corvajaZannierSum + p alpha beta H₁ rightSubgroup hrightOrder hCZ hnondegenerate).trans + (middleGameCorvajaZannierSum_le_divisorCount_mul_envelope p (Nat.card H₁)) + +/-- If the divisor-counted weighted bad set is smaller than the left subgroup, one left element +avoids every candidate right-order trace. -/ +theorem exists_left_element_escaping_weightedCandidateOrders + (p : ℕ) (alpha beta : E) (H₁ : Subgroup Eˣ) + (rightSubgroup : ℕ → Subgroup Eˣ) (bound : ℕ) + (hbound : ∀ d ∈ middleGameCandidateOrders p (Nat.card H₁), + (weightedTraceEquationSolutions alpha beta H₁ (rightSubgroup d)).card ≤ bound) + (hsmall : ((p - 1).divisors.card + (p + 1).divisors.card) * bound < Nat.card H₁) : + ∃ h₁ : H₁, ∀ d ∈ middleGameCandidateOrders p (Nat.card H₁), + ∀ h₂ : rightSubgroup d, + weightedSplitTorusTrace alpha beta h₁ ≠ splitTorusTrace h₂ := by + classical + let orders := middleGameCandidateOrders p (Nat.card H₁) + let bad := weightedBadOrderTraceSupport alpha beta H₁ orders rightSubgroup + have hbad : bad.card < Nat.card H₁ := + (middleGameWeightedBadOrderTraceSupport_card_le + p alpha beta H₁ rightSubgroup bound hbound).trans_lt hsmall + have hexists : ∃ h₁ : H₁, h₁ ∉ bad := by + by_contra hall + push Not at hall + have hle : (Finset.univ : Finset H₁).card ≤ bad.card := + Finset.card_le_card fun h₁ _ ↦ hall h₁ + rw [Finset.card_univ, Fintype.card_eq_nat_card] at hle + exact (Nat.not_le_of_lt hbad) hle + obtain ⟨h₁, hh₁⟩ := hexists + refine ⟨h₁, ?_⟩ + intro d hd h₂ heq + apply hh₁ + exact mem_weightedBadOrderTraceSupport_iff.mpr + ⟨d, by simpa [orders] using hd, h₂, heq⟩ + +/-- The complete finite weighted Corvaja--Zannier escape reduction. The only deep premise is +`hCZ`; the remaining hypotheses are actual subgroup cardinalities and the two explicit size +inequalities controlling the cube-root and `1 / p` terms. -/ +theorem exists_left_element_escaping_of_weightedCorvajaZannierEstimate_and_sizeBounds + (p : ℕ) (alpha beta : E) (H₁ : Subgroup Eˣ) + (rightSubgroup : ℕ → Subgroup Eˣ) + (hrightOrder : ∀ d ∈ middleGameCandidateOrders p (Nat.card H₁), + Nat.card (rightSubgroup d) = d) + (hCZ : alpha * beta ≠ 1 → + ∀ d ∈ middleGameCandidateOrders p (Nat.card H₁), + ((weightedTraceEquationSolutions alpha beta H₁ (rightSubgroup d)).card : ℝ) ≤ + corvajaZannierTraceUpperBound p (Nat.card H₁) + (Nat.card (rightSubgroup d))) + (hnondegenerate : alpha * beta ≠ 1) + (hcurrentOrder : 0 < Nat.card H₁) + (hcube : + (corvajaZannierCorollaryTwoSafeCoefficient * + ((p - 1).divisors.card + (p + 1).divisors.card)) ^ 3 < Nat.card H₁) + (hlinear : + corvajaZannierCorollaryTwoSafeCoefficient * + ((p - 1).divisors.card + (p + 1).divisors.card) * Nat.card H₁ < p) : + ∃ h₁ : H₁, ∀ d ∈ middleGameCandidateOrders p (Nat.card H₁), + ∀ h₂ : rightSubgroup d, + weightedSplitTorusTrace alpha beta h₁ ≠ splitTorusTrace h₂ := by + classical + let orders := middleGameCandidateOrders p (Nat.card H₁) + let bad := weightedBadOrderTraceSupport alpha beta H₁ orders rightSubgroup + have hbadReal : (bad.card : ℝ) < (Nat.card H₁ : ℝ) := by + calc + (bad.card : ℝ) ≤ + (((p - 1).divisors.card + (p + 1).divisors.card : ℕ) : ℝ) * + corvajaZannierCurrentOrderEnvelope p (Nat.card H₁) := by + simpa [orders, bad] using + middleGameWeightedBadOrderTraceSupport_card_cast_le_divisorEnvelope + p alpha beta H₁ rightSubgroup hrightOrder hCZ hnondegenerate + _ < (Nat.card H₁ : ℝ) := + divisorCount_mul_corvajaZannierEnvelope_lt_currentOrder p (Nat.card H₁) + hcurrentOrder hcube hlinear + have hbad : bad.card < Nat.card H₁ := by exact_mod_cast hbadReal + have hexists : ∃ h₁ : H₁, h₁ ∉ bad := by + by_contra hall + push Not at hall + have hle : (Finset.univ : Finset H₁).card ≤ bad.card := + Finset.card_le_card fun h₁ _ ↦ hall h₁ + rw [Finset.card_univ, Fintype.card_eq_nat_card] at hle + exact (Nat.not_le_of_lt hbad) hle + obtain ⟨h₁, hh₁⟩ := hexists + refine ⟨h₁, ?_⟩ + intro d hd h₂ heq + apply hh₁ + exact mem_weightedBadOrderTraceSupport_iff.mpr + ⟨d, by simpa [orders] using hd, h₂, heq⟩ + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/WeightedTraceEulerSeven.lean b/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/WeightedTraceEulerSeven.lean new file mode 100644 index 0000000000..06c577b6db --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/WeightedTraceEulerSeven.lean @@ -0,0 +1,166 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveSharedOriginBoundary +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveAuxiliaryIndependence +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.CorvajaZannierFromGeneral +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.Boundary +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.WeightedBidegree +public import Mathlib.Tactic + +/-! +# Euler budget seven for the weighted trace curve + +The reduced weighted trace closure has bidegree `(2,2)` and, when the second +weight is nonzero, contains the affine origin. Both coordinate functions +vanish at the finite place selected above that origin. Combining this shared +place with the generic canonical-divisor estimate lowers the sound +log-canonical degree budget from `8` to `7`. + +This is deliberately weaker than the paper's unsupported value `3`, but it +uses only the normalization-place machinery proved in the repository. +-/ + +@[expose] public section + +open scoped Polynomial BigOperators + +namespace BGS.Markoff + +open BGS.CorvajaZannier + +noncomputable section + +variable {K : Type*} [Field K] + +/-- The first actual coordinate degree of the weighted trace closure. -/ +theorem weightedTraceTorusClosurePolynomial_degreeOf_first + (alpha beta : K) (hbeta : beta ≠ 0) : + MvPolynomial.degreeOf 0 + (weightedTraceTorusClosurePolynomial alpha beta) = 2 := by + rw [← planeCurveToBivariate_natDegree_eq_degreeOf_zero] + change (finTwoToIteratedPolynomial (K := K) + (weightedTraceTorusClosurePolynomial alpha beta)).natDegree = 2 + rw [finTwoToIteratedPolynomial_weightedTraceTorusClosurePolynomial + alpha beta hbeta] + exact weightedTraceIteratedPolynomial_right_natDegree alpha beta + +/-- The second actual coordinate degree of the weighted trace closure. -/ +theorem weightedTraceTorusClosurePolynomial_degreeOf_second + (alpha beta : K) (halpha : alpha ≠ 0) (hbeta : beta ≠ 0) : + MvPolynomial.degreeOf 1 + (weightedTraceTorusClosurePolynomial alpha beta) = 2 := by + rw [← bivariateEquiv_symm_natDegree_eq_degreeOf_one] + rw [← transposeBivariate_planeCurveToBivariate] + rw [transposeBivariate_eq_bivariateSwap] + change (Polynomial.Bivariate.swap + (finTwoToIteratedPolynomial (K := K) + (weightedTraceTorusClosurePolynomial alpha beta))).natDegree = 2 + rw [finTwoToIteratedPolynomial_weightedTraceTorusClosurePolynomial + alpha beta hbeta] + exact weightedTraceIteratedPolynomial_left_natDegree alpha beta halpha + +/-- The common affine origin of the two coordinate divisors. -/ +def weightedTraceTorusClosureOrigin + (alpha beta : K) (hbeta : beta ≠ 0) : + AffinePlaneCurvePoint + (weightedTraceTorusClosurePolynomial alpha beta) := + ⟨(0, 0), by + rw [weightedTraceTorusClosurePolynomial, ite_eq_right hbeta] + exact splitTraceCoverPolynomial_origin_zero + alpha beta 1 1 (by norm_num) (by norm_num)⟩ + +section Finite + +variable [Fintype K] [DecidableEq K] + +/-- The sound log-canonical degree budget for the weighted trace curve is at +most seven. The sole field-size premise is the one needed by the canonical +different estimate. -/ +theorem weightedTraceTorusClosure_canonicalExceptionalDegree_le_seven + (alpha beta : K) (halpha : alpha ≠ 0) (hbeta : beta ≠ 0) + (hnondegenerate : alpha * beta ≠ 1) + (hcardK : 2 < Fintype.card K) + (m n : ℕ) (hm : 0 < m) (hn : 0 < n) : + let f := weightedTraceTorusClosurePolynomial alpha beta + let hf : Irreducible f := + weightedTraceTorusClosurePolynomial_irreducible + alpha beta halpha hbeta hnondegenerate + letI := planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero + (weightedTraceTorusClosurePolynomial_pderiv_second_ne_zero + alpha beta hbeta)) + letI : DecidableEq (RatFunc K) := Classical.decEq _ + letI := planeCurveFirstCoordinateRatFuncAlgebra f hx + letI := finiteDimensional_planeCurveFunctionField_over_ratFunc + hf (weightedTraceTorusClosurePolynomial_pderiv_second_ne_zero + alpha beta hbeta) + letI := separable_planeCurveFunctionField_over_ratFunc + hf (weightedTraceTorusClosurePolynomial_pderiv_second_ne_zero + alpha beta hbeta) + finiteExtensionDivisorDegree K (PlaneCurveFunctionField f) + (finiteExtensionCanonicalDifferentDivisor K + (PlaneCurveFunctionField f) + (finiteExtensionFiniteDifferentIdeal_ne_bot K + (PlaneCurveFunctionField f))) + + (∑ w ∈ propositionTwoExceptionalPlaces K + (PlaneCurveFunctionField f) + ((planeCurveFunction f 0) ^ m) ((planeCurveFunction f 1) ^ n), + finiteExtensionPlaceDegree K (PlaneCurveFunctionField f) w : ℤ) ≤ + 7 := by + let f := weightedTraceTorusClosurePolynomial alpha beta + let hf : Irreducible f := + weightedTraceTorusClosurePolynomial_irreducible + alpha beta halpha hbeta hnondegenerate + let hpartialFirst : + MvPolynomial.pderiv 0 f ≠ 0 := + weightedTraceTorusClosurePolynomial_pderiv_first_ne_zero + alpha beta hbeta + let hpartialSecond : + MvPolynomial.pderiv 1 f ≠ 0 := + weightedTraceTorusClosurePolynomial_pderiv_second_ne_zero + alpha beta hbeta + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let hx := firstCoordinate_transcendental hf + (degreeOf_second_pos_of_pderiv_ne_zero hpartialSecond) + let : DecidableEq (RatFunc K) := Classical.decEq _ + let : Algebra (RatFunc K) (PlaneCurveFunctionField f) := + planeCurveFirstCoordinateRatFuncAlgebra f hx + let : FiniteDimensional (RatFunc K) (PlaneCurveFunctionField f) := + finiteDimensional_planeCurveFunctionField_over_ratFunc + hf hpartialSecond + let : Algebra.IsSeparable (RatFunc K) (PlaneCurveFunctionField f) := + separable_planeCurveFunctionField_over_ratFunc hf hpartialSecond + have hdegreeFirst : + MvPolynomial.degreeOf 0 f = 2 := + weightedTraceTorusClosurePolynomial_degreeOf_first alpha beta hbeta + have hdegreeSecond : + MvPolynomial.degreeOf 1 f = 2 := + weightedTraceTorusClosurePolynomial_degreeOf_second + alpha beta halpha hbeta + have hcardCurve : + MvPolynomial.degreeOf 1 f < Fintype.card K := by + rw [hdegreeSecond] + exact hcardK + have hEulerPlusOne := + planeCurve_canonicalDifferent_add_propositionTwoExceptional_add_one_le + hf hpartialFirst hpartialSecond hcardCurve + (weightedTraceTorusClosureOrigin alpha beta hbeta) + rfl rfl m n hm hn + rw [hdegreeFirst, hdegreeSecond] at hEulerPlusOne + dsimp only [f] at hEulerPlusOne + norm_num at hEulerPlusOne ⊢ + omega + +end Finite + +end + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/WeightedTraceEulerSevenBound.lean b/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/WeightedTraceEulerSevenBound.lean new file mode 100644 index 0000000000..e0725e88bf --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/WeightedTraceEulerSevenBound.lean @@ -0,0 +1,84 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.WeightedTraceEulerSevenLargeBound +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.ElementaryFiniteFieldBound +public import Mathlib.Tactic + +/-! +# The exact Euler-seven weighted trace bound + +Above the elementary range this is the χ≤7 Proposition Two endpoint. Below +that range the roots-of-unity count lands directly in the unchanged +quotient-by-characteristic branch. +-/ + +@[expose] public section + +namespace BGS.Markoff + +noncomputable section + +/-- The χ≤7 weighted trace estimate in every characteristic. -/ +theorem weightedTraceTorsionIntersection_card_cast_le_eulerSeven + {K : Type*} [Field K] [Fintype K] [DecidableEq K] + {p : ℕ} [Fact p.Prime] [CharP K p] + (alpha beta : K) + (hadmissible : WeightedTraceCurveIsCorvajaZannierAdmissible alpha beta) + (m n : ℕ) (hm : 0 < m) (hn : 0 < n) + (hmPrime : ¬ p ∣ m) (hnPrime : ¬ p ∣ n) : + ((BGS.External.torusCurveTorsionIntersection K + (weightedTraceTorusClosurePolynomial alpha beta) m n).card : ℝ) ≤ + corvajaZannierCorollaryTwoNumericalBound p m n 2 2 7 := by + by_cases hlarge : 48 < p + · exact + weightedTraceTorsionIntersection_card_cast_le_eulerSeven_of_largeChar + alpha beta hadmissible m n hm hn hmPrime hnPrime hlarge + · have hsmall : p ≤ 48 := Nat.le_of_not_gt hlarge + have hcardNat := + BGS.External.torusCurveTorsionIntersection_card_le_orders + (weightedTraceTorusClosurePolynomial alpha beta) m n hm hn + have hcardReal : + ((BGS.External.torusCurveTorsionIntersection K + (weightedTraceTorusClosurePolynomial alpha beta) m n).card : ℝ) ≤ + ((m * n : ℕ) : ℝ) := by + exact_mod_cast hcardNat + have hpReal : (0 : ℝ) < p := by + exact_mod_cast (Fact.out : p.Prime).pos + have hscaledNat : p * (m * n) ≤ 48 * (m * n) := + Nat.mul_le_mul_right (m * n) hsmall + have hscaledReal : + (p : ℝ) * ((m * n : ℕ) : ℝ) ≤ + 48 * ((m * n : ℕ) : ℝ) := by + exact_mod_cast hscaledNat + have hquotient : + ((m * n : ℕ) : ℝ) ≤ + 48 * ((m * n : ℕ) : ℝ) / (p : ℝ) := by + apply (le_div_iff₀ hpReal).2 + simpa [mul_comm] using hscaledReal + have hright : + 48 * ((m * n : ℕ) : ℝ) / (p : ℝ) = + 12 * ((m * n * 2 * 2 : ℕ) : ℝ) / (p : ℝ) := by + push_cast + ring + unfold corvajaZannierCorollaryTwoNumericalBound + calc + ((BGS.External.torusCurveTorsionIntersection K + (weightedTraceTorusClosurePolynomial alpha beta) m n).card : ℝ) + ≤ ((m * n : ℕ) : ℝ) := hcardReal + _ ≤ 48 * ((m * n : ℕ) : ℝ) / (p : ℝ) := hquotient + _ = 12 * ((m * n * 2 * 2 : ℕ) : ℝ) / (p : ℝ) := hright + _ ≤ max + (3 * (2 * ((m * n * 2 * 2 : ℕ) : ℝ) * 7) ^ + ((1 : ℝ) / 3)) + (12 * ((m * n * 2 * 2 : ℕ) : ℝ) / (p : ℝ)) := + le_max_right _ _ + +end + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/WeightedTraceEulerSevenLargeBound.lean b/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/WeightedTraceEulerSevenLargeBound.lean new file mode 100644 index 0000000000..5ef3295328 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/WeightedTraceEulerSevenLargeBound.lean @@ -0,0 +1,139 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.WeightedTraceEulerSevenPropositionTwo +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurveExhaustiveGcdEndpoint +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.NumericalCorollary +public import Mathlib.Tactic + +/-! +# The Euler-seven weighted trace bound above the elementary range + +This module converts the exact χ≤7 Proposition Two result into its numerical +torsion-intersection estimate when `48 < p`. +-/ + +@[expose] public section + +namespace BGS.Markoff + +open BGS.CorvajaZannier + +noncomputable section + + +theorem weightedTraceTorsionIntersection_card_cast_le_eulerSeven_of_largeChar + {K : Type*} [Field K] [Fintype K] [DecidableEq K] + {p : ℕ} [Fact p.Prime] [CharP K p] + (alpha beta : K) + (hadmissible : WeightedTraceCurveIsCorvajaZannierAdmissible alpha beta) + (m n : ℕ) (hm : 0 < m) (hn : 0 < n) + (hmPrime : ¬ p ∣ m) (hnPrime : ¬ p ∣ n) + (hlarge : 48 < p) : + ((BGS.External.torusCurveTorsionIntersection K + (weightedTraceTorusClosurePolynomial alpha beta) m n).card : ℝ) ≤ + corvajaZannierCorollaryTwoNumericalBound p m n 2 2 7 := by + let f := weightedTraceTorusClosurePolynomial alpha beta + let hf : Irreducible f := + irreducible_of_irreducible_map_algebraicClosure + hadmissible.2.2.2.1 + let hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0 := + weightedTraceTorusClosurePolynomial_pderiv_first_ne_zero + alpha beta hadmissible.2.1 + let hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0 := + weightedTraceTorusClosurePolynomial_pderiv_second_ne_zero + alpha beta hadmissible.2.1 + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let card : ℕ := + (BGS.External.torusCurveTorsionIntersection K f m n).card + let gcdDegree : ℕ := + planeCurveExhaustiveTorsionGcdWeightedDegree + hf hpartialSecond m n + have hdegreeFirst : + MvPolynomial.degreeOf 0 f = 2 := + weightedTraceTorusClosurePolynomial_degreeOf_first + alpha beta hadmissible.2.1 + have hdegreeSecond : + MvPolynomial.degreeOf 1 f = 2 := + weightedTraceTorusClosurePolynomial_degreeOf_second + alpha beta hadmissible.1 hadmissible.2.1 + have hlargeActual : + 12 * MvPolynomial.degreeOf 0 f * + MvPolynomial.degreeOf 1 f < p := by + rw [hdegreeFirst, hdegreeSecond] + norm_num at hlarge ⊢ + exact hlarge + have hcardK : 2 < Fintype.card K := by + have hdegreeCard := + planeCurve_degreeOf_second_lt_card_of_twelve_mul_degrees_lt_char + hpartialFirst hpartialSecond hlargeActual + rw [hdegreeSecond] at hdegreeCard + exact hdegreeCard + have hpropositionGcd := + weightedTracePropositionTwo_eulerSeven + (p := p) alpha beta hadmissible m n hm hn + hmPrime hnPrime hcardK + have hcurve := + weightedTraceCurve_isGeneralCorvajaZannierPlaneCurve + alpha beta hadmissible + have hbidegree := + weightedTraceTorusClosurePolynomial_hasBidegreeAtMost + alpha beta hadmissible.2.1 + have hnonzero := + poweredTorsionFunctions_ne_zero_of_isCorvajaZannierPlaneCurve + hcurve m n hm hn + have hcardGcd : card ≤ gcdDegree := by + dsimp only [card, gcdDegree] + rw [torusCurveTorsionIntersection_card_eq_torsionPoint_card] + exact torsionPoint_card_le_planeCurveExhaustiveTorsionGcdWeightedDegree + hf hpartialSecond m n hnonzero.1 hnonzero.2 + have hcardTrivial : + card ≤ planeCurveTorsionLowerDegree 2 2 m n := by + dsimp only [card, planeCurveTorsionLowerDegree] + simpa only [min_comm] using + torusCurveTorsionIntersection_card_le_min_bidegree_order + f 2 2 m n hbidegree hcurve hm hn + have hpropositionCard : PropositionTwoNumericalAlternatives + (planeCurveTorsionLowerDegree 2 2 m n) + (planeCurveTorsionUpperDegree 2 2 m n) + p 7 (card : ℝ) := by + apply propositionTwoNumericalAlternatives_mono + (G := (card : ℝ)) (H := (gcdDegree : ℝ)) + · exact_mod_cast hcardGcd + · simpa only [f, hf, gcdDegree, hdegreeFirst, hdegreeSecond] using + hpropositionGcd + let a := planeCurveTorsionLowerDegree 2 2 m n + let b := planeCurveTorsionUpperDegree 2 2 m n + have ha : 0 < a := by + dsimp only [a, planeCurveTorsionLowerDegree] + exact lt_min (Nat.mul_pos hn (by norm_num)) + (Nat.mul_pos hm (by norm_num)) + have hab : a ≤ b := by + dsimp only [a, b, planeCurveTorsionLowerDegree, + planeCurveTorsionUpperDegree] + exact min_le_max + have hbound := + theoremTwo_maxBound_of_propositionTwo + a b 7 p (card : ℝ) ha hab (by norm_num) + (Fact.out : p.Prime).pos (Nat.cast_nonneg card) + (by exact_mod_cast hcardTrivial) (by + simpa only [a, b] using hpropositionCard) + have habProduct : a * b = m * n * 2 * 2 := by + simpa only [a, b] using + planeCurveTorsionLowerDegree_mul_upperDegree 2 2 m n + have habProductReal : + (a : ℝ) * (b : ℝ) = ((m * n * 2 * 2 : ℕ) : ℝ) := by + exact_mod_cast habProduct + rw [habProductReal] at hbound + simpa only [card, f, corvajaZannierCorollaryTwoNumericalBound, + Nat.cast_ofNat, mul_assoc] using hbound + +end + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/WeightedTraceEulerSevenPropositionTwo.lean b/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/WeightedTraceEulerSevenPropositionTwo.lean new file mode 100644 index 0000000000..0c1cc5dfbb --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/WeightedTraceEulerSevenPropositionTwo.lean @@ -0,0 +1,275 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.WeightedTraceEulerSeven +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.WeightedTracePoweredImageIndexTwo +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PlaneCurvePropositionTwoGeometric +public import Mathlib.Tactic + +/-! +# Proposition Two with Euler budget seven for the weighted trace curve + +The general bidegree endpoint uses the ambient budget `8`. For the weighted +trace curve, the common affine origin saves one boundary degree, while the +sparse support determinant bounds the powered-image index by `2`. This module +feeds both exact inputs into the natural and swapped Proposition Two proofs. +-/ + +@[expose] public section + +namespace BGS.Markoff + +open BGS.CorvajaZannier + +noncomputable section + + +theorem weightedTracePropositionTwo_natural_eulerSeven + {K : Type*} [Field K] [Fintype K] [DecidableEq K] + {p : ℕ} [Fact p.Prime] [CharP K p] + (alpha beta : K) + (hadmissible : WeightedTraceCurveIsCorvajaZannierAdmissible alpha beta) + (m n : ℕ) (hm : 0 < m) (hn : 0 < n) + (hmPrime : ¬ p ∣ m) (hnPrime : ¬ p ∣ n) + (hcardK : 2 < Fintype.card K) : + let f := weightedTraceTorusClosurePolynomial alpha beta + let hf : Irreducible f := + irreducible_of_irreducible_map_algebraicClosure + hadmissible.2.2.2.1 + PropositionTwoNumericalAlternatives + (n * MvPolynomial.degreeOf 0 f) + (m * MvPolynomial.degreeOf 1 f) p 7 + (planeCurveExhaustiveTorsionGcdWeightedDegree + hf + (weightedTraceTorusClosurePolynomial_pderiv_second_ne_zero + alpha beta hadmissible.2.1) + m n : ℝ) := by + let f := weightedTraceTorusClosurePolynomial alpha beta + let hf : Irreducible f := + irreducible_of_irreducible_map_algebraicClosure + hadmissible.2.2.2.1 + let hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0 := + weightedTraceTorusClosurePolynomial_pderiv_first_ne_zero + alpha beta hadmissible.2.1 + let hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0 := + weightedTraceTorusClosurePolynomial_pderiv_second_ne_zero + alpha beta hadmissible.2.1 + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let : DecidableEq (RatFunc K) := Classical.decEq _ + have hindexTwo : + Module.finrank (PoweredImageOverFirst f m n) + (PlaneCurveFunctionField f) ≤ 2 := by + simpa only [f, hf] using + weightedTraceTorusClosure_poweredImageIndex_le_two + (p := p) alpha beta hadmissible m n hm hn hmPrime hnPrime + have hindexSeven : + Module.finrank (PoweredImageOverFirst f m n) + (PlaneCurveFunctionField f) ≤ 7 := + hindexTwo.trans (by omega) + apply planeCurvePropositionTwo_natural_of_auxiliaryBounds + hf hpartialFirst hpartialSecond m n p 7 hm hn hindexSeven + intro h k hh hk hparameters hexcluded + let L := PlaneCurveFunctionField f + let : CharP L p := charP_of_injective_algebraMap + (algebraMap K L).injective p + let gK := poweredCoordinateImageRelation hf hpartialSecond m hm n + let g := poweredCoordinateFrobeniusImageRelation + (p := p) hf hpartialSecond m hm n + have hbidegree := poweredCoordinateImageRelation_bidegree_le + hf hpartialFirst hpartialSecond m hm n hn + have hdegreeG : g.natDegree ≤ n * MvPolynomial.degreeOf 0 f := by + dsimp only [g] + rw [poweredCoordinateFrobeniusImageRelation_natDegree] + exact hbidegree.2 + have hdegreeTranspose : (transposeBivariate g).natDegree ≤ + m * MvPolynomial.degreeOf 1 f := by + dsimp only [g] + rw [transposeBivariate_poweredCoordinateFrobeniusImageRelation_natDegree] + exact hbidegree.1 + have hsize : g.natDegree * h + + (transposeBivariate g).natDegree * k < p := by + apply lt_of_le_of_lt _ hparameters.2 + exact Nat.add_le_add + (Nat.mul_le_mul_right h hdegreeG) + (Nat.mul_le_mul_right k hdegreeTranspose) + have hexcludedG : ¬ (g.natDegree ≤ k ∧ + (transposeBivariate g).natDegree ≤ h) := by + dsimp only [g, gK] at hexcluded ⊢ + rw [poweredCoordinateFrobeniusImageRelation_natDegree, + transposeBivariate_poweredCoordinateFrobeniusImageRelation_natDegree] + exact hexcluded + have hLI := + poweredCoordinateFrobeniusImage_auxiliaryFamily_linearIndependent + (p := p) hadmissible.2.2.2.1 hf hpartialFirst hpartialSecond + m n hm hnPrime h k hh hk hsize hexcludedG + have hEuler := + weightedTraceTorusClosure_canonicalExceptionalDegree_le_seven + alpha beta hadmissible.1 hadmissible.2.1 hadmissible.2.2.1 + hcardK m n hm hn + exact finiteExtensionGcdBound_planeCurvePowers_of_auxiliaryFamily_linearIndependent + (p := p) hf hpartialFirst hpartialSecond m n hm hn + h k hparameters.1 7 hLI (by + simpa only [f, hf, Nat.cast_ofNat] using hEuler) + +private theorem exceptionalPlaces_comm + (K : Type*) [Field K] [DecidableEq K] [DecidableEq (RatFunc K)] + (L : Type*) [Field L] [Algebra (RatFunc K) L] + [FiniteDimensional (RatFunc K) L] [Algebra.IsSeparable (RatFunc K) L] + (u v : L) : propositionTwoExceptionalPlaces K L u v = + propositionTwoExceptionalPlaces K L v u := by + classical + exact Finset.union_comm _ _ + +theorem weightedTracePropositionTwo_swapped_eulerSeven + {K : Type*} [Field K] [Fintype K] [DecidableEq K] + {p : ℕ} [Fact p.Prime] [CharP K p] + (alpha beta : K) + (hadmissible : WeightedTraceCurveIsCorvajaZannierAdmissible alpha beta) + (m n : ℕ) (hm : 0 < m) (hn : 0 < n) + (hmPrime : ¬ p ∣ m) (hnPrime : ¬ p ∣ n) + (hcardK : 2 < Fintype.card K) : + let f := weightedTraceTorusClosurePolynomial alpha beta + let hf : Irreducible f := + irreducible_of_irreducible_map_algebraicClosure + hadmissible.2.2.2.1 + PropositionTwoNumericalAlternatives + (m * MvPolynomial.degreeOf 1 f) + (n * MvPolynomial.degreeOf 0 f) p 7 + (planeCurveExhaustiveTorsionGcdWeightedDegree + hf + (weightedTraceTorusClosurePolynomial_pderiv_second_ne_zero + alpha beta hadmissible.2.1) + m n : ℝ) := by + let f := weightedTraceTorusClosurePolynomial alpha beta + let hf : Irreducible f := + irreducible_of_irreducible_map_algebraicClosure + hadmissible.2.2.2.1 + let hpartialFirst : MvPolynomial.pderiv 0 f ≠ 0 := + weightedTraceTorusClosurePolynomial_pderiv_first_ne_zero + alpha beta hadmissible.2.1 + let hpartialSecond : MvPolynomial.pderiv 1 f ≠ 0 := + weightedTraceTorusClosurePolynomial_pderiv_second_ne_zero + alpha beta hadmissible.2.1 + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + let : DecidableEq (RatFunc K) := Classical.decEq _ + have hindexTwo : + Module.finrank (PoweredImageOverFirst f m n) + (PlaneCurveFunctionField f) ≤ 2 := by + simpa only [f, hf] using + weightedTraceTorusClosure_poweredImageIndex_le_two + (p := p) alpha beta hadmissible m n hm hn hmPrime hnPrime + have hindexSeven : + Module.finrank (PoweredImageOverFirst f m n) + (PlaneCurveFunctionField f) ≤ 7 := + hindexTwo.trans (by omega) + apply planeCurvePropositionTwo_swapped_of_auxiliaryBounds + hf hpartialFirst hpartialSecond m n p 7 hm hn hindexSeven + intro h k hh hk hparameters hexcluded + let L := PlaneCurveFunctionField f + let : CharP L p := charP_of_injective_algebraMap + (algebraMap K L).injective p + let F := frobeniusSubfield L p + let ι : K →+* F := + perfectConstantsToFrobeniusSubfield (K := K) (L := L) (p := p) + let gK := poweredCoordinateImageRelation hf hpartialSecond m hm n + let g : Polynomial (Polynomial F) := gK.map (Polynomial.mapRingHom ι) + have hι : Function.Injective ι := + perfectConstantsToFrobeniusSubfield_injective + (K := K) (L := L) (p := p) + have hmap : Function.Injective (Polynomial.mapRingHom ι) := + Polynomial.map_injective ι hι + have hdegreeG : g.natDegree = gK.natDegree := by + dsimp only [g] + exact Polynomial.natDegree_map_eq_of_injective hmap _ + have hdegreeTranspose : (transposeBivariate g).natDegree = + (transposeBivariate gK).natDegree := by + dsimp only [g] + rw [transposeBivariate_map] + exact Polynomial.natDegree_map_eq_of_injective hmap _ + have hbidegree := poweredCoordinateImageRelation_bidegree_le + hf hpartialFirst hpartialSecond m hm n hn + have hsize : g.natDegree * h + + (transposeBivariate g).natDegree * k < p := by + apply lt_of_le_of_lt _ hparameters.2 + rw [hdegreeG, hdegreeTranspose] + exact Nat.add_le_add + (Nat.mul_le_mul_right h hbidegree.1) + (Nat.mul_le_mul_right k hbidegree.2) + have hexcludedG : ¬ (g.natDegree ≤ k ∧ + (transposeBivariate g).natDegree ≤ h) := by + rw [hdegreeG, hdegreeTranspose] + exact hexcluded + have hLI := + poweredCoordinateFrobeniusImage_auxiliaryFamily_linearIndependent_swapped + (p := p) hadmissible.2.2.2.1 hf hpartialFirst hpartialSecond + m n hm hn hmPrime h k hh hk hsize hexcludedG + have hEuler := + weightedTraceTorusClosure_canonicalExceptionalDegree_le_seven + alpha beta hadmissible.1 hadmissible.2.1 hadmissible.2.2.1 + hcardK m n hm hn + exact + finiteExtensionGcdBound_planeCurvePowers_swapped_of_auxiliaryFamily_linearIndependent + (p := p) hf hpartialFirst hpartialSecond m n hm hn + h k hparameters.1 7 hLI (by + erw [exceptionalPlaces_comm] + exact hEuler) + +/-- The natural and swapped orientations give the minimum/maximum form with +Euler budget exactly seven. -/ +theorem weightedTracePropositionTwo_eulerSeven + {K : Type*} [Field K] [Fintype K] [DecidableEq K] + {p : ℕ} [Fact p.Prime] [CharP K p] + (alpha beta : K) + (hadmissible : WeightedTraceCurveIsCorvajaZannierAdmissible alpha beta) + (m n : ℕ) (hm : 0 < m) (hn : 0 < n) + (hmPrime : ¬ p ∣ m) (hnPrime : ¬ p ∣ n) + (hcardK : 2 < Fintype.card K) : + let f := weightedTraceTorusClosurePolynomial alpha beta + let hf : Irreducible f := + irreducible_of_irreducible_map_algebraicClosure + hadmissible.2.2.2.1 + PropositionTwoNumericalAlternatives + (planeCurveTorsionLowerDegree + (MvPolynomial.degreeOf 0 f) (MvPolynomial.degreeOf 1 f) m n) + (planeCurveTorsionUpperDegree + (MvPolynomial.degreeOf 0 f) (MvPolynomial.degreeOf 1 f) m n) + p 7 + (planeCurveExhaustiveTorsionGcdWeightedDegree + hf + (weightedTraceTorusClosurePolynomial_pderiv_second_ne_zero + alpha beta hadmissible.2.1) + m n : ℝ) := by + let f := weightedTraceTorusClosurePolynomial alpha beta + let hf : Irreducible f := + irreducible_of_irreducible_map_algebraicClosure + hadmissible.2.2.2.1 + by_cases horient : n * MvPolynomial.degreeOf 0 f ≤ + m * MvPolynomial.degreeOf 1 f + · have hnatural := + weightedTracePropositionTwo_natural_eulerSeven + (p := p) alpha beta hadmissible m n hm hn + hmPrime hnPrime hcardK + simpa only [f, hf, planeCurveTorsionLowerDegree, + planeCurveTorsionUpperDegree, min_eq_left horient, + max_eq_right horient] using hnatural + · have horient' : m * MvPolynomial.degreeOf 1 f ≤ + n * MvPolynomial.degreeOf 0 f := + Nat.le_of_lt (lt_of_not_ge horient) + have hswapped := + weightedTracePropositionTwo_swapped_eulerSeven + (p := p) alpha beta hadmissible m n hm hn + hmPrime hnPrime hcardK + simpa only [f, hf, planeCurveTorsionLowerDegree, + planeCurveTorsionUpperDegree, min_eq_right horient', + max_eq_left horient'] using hswapped + +end + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/WeightedTracePoweredImageIndexTwo.lean b/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/WeightedTracePoweredImageIndexTwo.lean new file mode 100644 index 0000000000..536ef82650 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/MiddleGame/WeightedTracePoweredImageIndexTwo.lean @@ -0,0 +1,150 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.CorvajaZannier.PoweredImageExactSupportIndexBound +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.CorvajaZannierFromGeneral +public import Mathlib.Tactic + +/-! +# Powered-image index two for the weighted trace curve + +Three always-present monomials of the nonzero-weight trace closure have +exponents `(1,0)`, `(2,1)`, and `(0,1)`. Their support determinant is `2`. +Retaining this exact sparse-support certificate lowers the source-to-powered +image index bound from the generic bidegree value `8` to `2`. +-/ + +@[expose] public section + +namespace BGS.Markoff + +open BGS.CorvajaZannier + +noncomputable section + +variable {K : Type*} [Field K] + +private def weightedTraceSupportAlpha : Fin 2 →₀ ℕ := + Finsupp.single 0 1 + Finsupp.single 1 2 + +private def weightedTraceSupportRightConstant : Fin 2 →₀ ℕ := + Finsupp.single 0 1 + +private def weightedTraceSupportMixed : Fin 2 →₀ ℕ := + Finsupp.single 0 2 + Finsupp.single 1 1 + +private def weightedTraceSupportLeftConstant : Fin 2 →₀ ℕ := + Finsupp.single 1 1 + +private theorem weightedTraceX_eq_monomial (i : Fin 2) : + (MvPolynomial.X i : MvPolynomial (Fin 2) K) = + MvPolynomial.monomial (Finsupp.single i 1) 1 := by + rw [← pow_one (MvPolynomial.X i), MvPolynomial.X_pow_eq_monomial] + +private theorem splitTraceCoverPolynomial_one_one_eq_monomials + (alpha beta : K) : + splitTraceCoverPolynomial alpha beta 1 1 = + MvPolynomial.monomial weightedTraceSupportAlpha alpha + + MvPolynomial.monomial weightedTraceSupportRightConstant beta - + MvPolynomial.monomial weightedTraceSupportMixed 1 - + MvPolynomial.monomial weightedTraceSupportLeftConstant 1 := by + rw [splitTraceCoverPolynomial] + norm_num only [pow_one, mul_one] + rw [MvPolynomial.C_mul_X_eq_monomial, + MvPolynomial.C_mul_X_eq_monomial, + MvPolynomial.X_pow_eq_monomial, + weightedTraceX_eq_monomial, weightedTraceX_eq_monomial] + simp [MvPolynomial.monomial_pow, weightedTraceSupportAlpha, + weightedTraceSupportRightConstant, weightedTraceSupportMixed, + weightedTraceSupportLeftConstant] + +private theorem weightedTraceSupportRightConstant_mem + (alpha beta : K) (hbeta : beta ≠ 0) : + weightedTraceSupportRightConstant ∈ + (weightedTraceTorusClosurePolynomial alpha beta).support := by + rw [weightedTraceTorusClosurePolynomial, ite_eq_right hbeta] + rw [splitTraceCoverPolynomial_one_one_eq_monomials] + rw [MvPolynomial.mem_support_iff] + simp [weightedTraceSupportAlpha, weightedTraceSupportRightConstant, + weightedTraceSupportMixed, weightedTraceSupportLeftConstant, hbeta, + Finsupp.ext_iff] + +private theorem weightedTraceSupportMixed_mem + (alpha beta : K) (hbeta : beta ≠ 0) : + weightedTraceSupportMixed ∈ + (weightedTraceTorusClosurePolynomial alpha beta).support := by + rw [weightedTraceTorusClosurePolynomial, ite_eq_right hbeta] + rw [splitTraceCoverPolynomial_one_one_eq_monomials] + rw [MvPolynomial.mem_support_iff] + simp [weightedTraceSupportAlpha, weightedTraceSupportRightConstant, + weightedTraceSupportMixed, weightedTraceSupportLeftConstant, + Finsupp.ext_iff] + +private theorem weightedTraceSupportLeftConstant_mem + (alpha beta : K) (hbeta : beta ≠ 0) : + weightedTraceSupportLeftConstant ∈ + (weightedTraceTorusClosurePolynomial alpha beta).support := by + rw [weightedTraceTorusClosurePolynomial, ite_eq_right hbeta] + rw [splitTraceCoverPolynomial_one_one_eq_monomials] + rw [MvPolynomial.mem_support_iff] + simp [weightedTraceSupportAlpha, weightedTraceSupportRightConstant, + weightedTraceSupportMixed, weightedTraceSupportLeftConstant, + Finsupp.ext_iff] + +private theorem weightedTraceSupportDeterminant : + planeCurveSupportDifferenceDet + weightedTraceSupportRightConstant + weightedTraceSupportMixed + weightedTraceSupportLeftConstant = 2 := by + simp [planeCurveSupportDifferenceDet, + weightedTraceSupportRightConstant, weightedTraceSupportMixed, + weightedTraceSupportLeftConstant] + +/-- The exact support determinant gives powered-image index at most two for +every prime-to-characteristic pair of powers. -/ +theorem weightedTraceTorusClosure_poweredImageIndex_le_two + {p : ℕ} [Fact p.Prime] [CharP K p] + (alpha beta : K) + (hadmissible : WeightedTraceCurveIsCorvajaZannierAdmissible alpha beta) + (m n : ℕ) (hm : 0 < m) (hn : 0 < n) + (hmPrime : ¬ p ∣ m) (hnPrime : ¬ p ∣ n) : + let f := weightedTraceTorusClosurePolynomial alpha beta + let hf : Irreducible f := + irreducible_of_irreducible_map_algebraicClosure + hadmissible.2.2.2.1 + letI := planeCurveCoordinateRing_isDomain hf + Module.finrank (PoweredImageOverFirst f m n) + (PlaneCurveFunctionField f) ≤ 2 := by + let f := weightedTraceTorusClosurePolynomial alpha beta + let hf : Irreducible f := + irreducible_of_irreducible_map_algebraicClosure + hadmissible.2.2.2.1 + let : IsDomain (PlaneCurveCoordinateRing f) := + planeCurveCoordinateRing_isDomain hf + have hindex := + finrank_poweredImageOverFirst_le_supportDet + (p := p) hadmissible.2.2.2.1 + (weightedTraceTorusClosurePolynomial_pderiv_first_ne_zero + alpha beta hadmissible.2.1) + (weightedTraceTorusClosurePolynomial_pderiv_second_ne_zero + alpha beta hadmissible.2.1) + (weightedTraceSupportRightConstant_mem + alpha beta hadmissible.2.1) + (weightedTraceSupportMixed_mem + alpha beta hadmissible.2.1) + (weightedTraceSupportLeftConstant_mem + alpha beta hadmissible.2.1) + (by rw [weightedTraceSupportDeterminant]; norm_num) + m n hm hn hmPrime hnPrime + rw [weightedTraceSupportDeterminant] at hindex + norm_num at hindex ⊢ + exact hindex + +end + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Opening.lean b/LeanPool/MarkoffModP/BGS/Markoff/Opening.lean new file mode 100644 index 0000000000..5a36d3cd00 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Opening.lean @@ -0,0 +1,24 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Opening.AlgebraicClosureTransport +public import LeanPool.MarkoffModP.BGS.Markoff.Opening.CompatibleRoots +public import LeanPool.MarkoffModP.BGS.Markoff.Opening.CyclotomicBound +public import LeanPool.MarkoffModP.BGS.Markoff.Opening.CyclotomicDefect +public import LeanPool.MarkoffModP.BGS.Markoff.Opening.CyclotomicNorm +public import LeanPool.MarkoffModP.BGS.Markoff.Opening.CyclotomicReduction +public import LeanPool.MarkoffModP.BGS.Markoff.Opening.EveryOrbitLarge +public import LeanPool.MarkoffModP.BGS.Markoff.Opening.FiniteOrbit +public import LeanPool.MarkoffModP.BGS.Markoff.Opening.OrbitCardBound +public import LeanPool.MarkoffModP.BGS.Markoff.Opening.OrderArithmetic +public import LeanPool.MarkoffModP.BGS.Markoff.Opening.ParabolicPeriodicity +public import LeanPool.MarkoffModP.BGS.Markoff.Opening.PeriodicSemisimple +public import LeanPool.MarkoffModP.BGS.Markoff.Opening.RotationOrbitCard +public import LeanPool.MarkoffModP.BGS.Markoff.Opening.TorsionTraces +public import LeanPool.MarkoffModP.BGS.Markoff.Opening.TraceOrderBound +public import LeanPool.MarkoffModP.BGS.Markoff.Opening.UnitCircle diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Opening/AlgebraicClosureTransport.lean b/LeanPool/MarkoffModP/BGS/Markoff/Opening/AlgebraicClosureTransport.lean new file mode 100644 index 0000000000..c33648393d --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Opening/AlgebraicClosureTransport.lean @@ -0,0 +1,292 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Opening.FiniteOrbit +public import Mathlib.FieldTheory.IsAlgClosed.AlgebraicClosure + +/-! +# Transporting the characteristic-zero opening through an algebraic closure + +The archimedean argument is proved over `ℂ`, while the paper formulates the opening over an +algebraic closure of `ℚ`. This file records the missing functorial step. A field embedding sends +normalized Markoff points coordinatewise and intertwines the five generators. Closure induction +on `Gamma` then shows that a finite orbit over the source field has finite image orbit over `ℂ`. +-/ + +@[expose] public section + +namespace BGS.Markoff + +universe u v + +/-- Apply a ring homomorphism coordinatewise to a normalized trace point. -/ +def NormalizedPoint.map {R : Type u} {S : Type v} [CommRing R] [CommRing S] + (f : R →+* S) (x : NormalizedPoint R) : NormalizedPoint S := + ⟨f x.u1, f x.u2, f x.u3⟩ + +@[simp] +theorem NormalizedPoint.map_u1 {R : Type u} {S : Type v} [CommRing R] [CommRing S] + (f : R →+* S) (x : NormalizedPoint R) : (x.map f).u1 = f x.u1 := + rfl + +@[simp] +theorem NormalizedPoint.map_u2 {R : Type u} {S : Type v} [CommRing R] [CommRing S] + (f : R →+* S) (x : NormalizedPoint R) : (x.map f).u2 = f x.u2 := + rfl + +@[simp] +theorem NormalizedPoint.map_u3 {R : Type u} {S : Type v} [CommRing R] [CommRing S] + (f : R →+* S) (x : NormalizedPoint R) : (x.map f).u3 = f x.u3 := + rfl + +@[simp] +theorem NormalizedPoint.map_origin {R : Type u} {S : Type v} [CommRing R] [CommRing S] + (f : R →+* S) : (normalizedOrigin : NormalizedPoint R).map f = normalizedOrigin := by + ext <;> simp [NormalizedPoint.map, normalizedOrigin] + +@[simp] +theorem normalizedPolynomial_map {R : Type u} {S : Type v} [CommRing R] [CommRing S] + (f : R →+* S) (x : NormalizedPoint R) : + normalizedPolynomial (x.map f) = f (normalizedPolynomial x) := by + simp [normalizedPolynomial, NormalizedPoint.map] + +/-- A ring homomorphism sends the normalized Markoff surface to the normalized Markoff surface. -/ +def normalizedSurfaceMap {R : Type u} {S : Type v} [CommRing R] [CommRing S] + (f : R →+* S) (x : NormalizedMarkoffSurface R) : NormalizedMarkoffSurface S := + ⟨x.1.map f, by + change normalizedPolynomial (x.1.map f) = 0 + rw [normalizedPolynomial_map, x.property, map_zero]⟩ + +@[simp] +theorem coe_normalizedSurfaceMap {R : Type u} {S : Type v} [CommRing R] [CommRing S] + (f : R →+* S) (x : NormalizedMarkoffSurface R) : + (normalizedSurfaceMap f x).1 = x.1.map f := + rfl + +theorem normalizedSurfaceMap_injective {R : Type u} {S : Type v} + [CommRing R] [CommRing S] (f : R →+* S) (hf : Function.Injective f) : + Function.Injective (normalizedSurfaceMap f) := by + intro x y hxy + apply Subtype.ext + apply NormalizedPoint.ext + · exact hf (congrArg NormalizedPoint.u1 (congrArg Subtype.val hxy)) + · exact hf (congrArg NormalizedPoint.u2 (congrArg Subtype.val hxy)) + · exact hf (congrArg NormalizedPoint.u3 (congrArg Subtype.val hxy)) + +private def normalizedVieta1Surface {R : Type u} [CommRing R] + (x : NormalizedMarkoffSurface R) : NormalizedMarkoffSurface R := + ⟨normalizedVieta1 x.1, (isNormalizedMarkoff_vieta1 x.1).2 x.property⟩ + +private def normalizedVieta2Surface {R : Type u} [CommRing R] + (x : NormalizedMarkoffSurface R) : NormalizedMarkoffSurface R := + ⟨normalizedVieta2 x.1, (isNormalizedMarkoff_vieta2 x.1).2 x.property⟩ + +private def normalizedVieta3Surface {R : Type u} [CommRing R] + (x : NormalizedMarkoffSurface R) : NormalizedMarkoffSurface R := + ⟨normalizedVieta3 x.1, (isNormalizedMarkoff_vieta3 x.1).2 x.property⟩ + +private theorem gammaVieta1_smul_normalizedSurface + {R : Type u} [CommRing R] [Invertible (3 : R)] (x : NormalizedMarkoffSurface R) : + gammaVieta1 R • x = normalizedVieta1Surface x := by + rw [normalizedGamma_smul_eq_perm, normalizedGammaPerm_apply] + rw [show (gammaVieta1 R : Equiv.Perm (MarkoffSurface R)) + ((normalizationSurfaceEquiv R).symm x) = + vieta1SurfacePerm R ((normalizationSurfaceEquiv R).symm x) by + exact gammaVieta1_smul_surface ((normalizationSurfaceEquiv R).symm x)] + apply Subtype.ext + change toNormalized (vieta1 ((normalizationSurfaceEquiv R).symm x : Point R)) = + normalizedVieta1 x + rw [toNormalized_vieta1] + rw [show toNormalized ((normalizationSurfaceEquiv R).symm x : Point R) = x by + exact congrArg Subtype.val ((normalizationSurfaceEquiv R).apply_symm_apply x)] + +private theorem gammaVieta2_smul_normalizedSurface + {R : Type u} [CommRing R] [Invertible (3 : R)] (x : NormalizedMarkoffSurface R) : + gammaVieta2 R • x = normalizedVieta2Surface x := by + rw [normalizedGamma_smul_eq_perm, normalizedGammaPerm_apply] + rw [show (gammaVieta2 R : Equiv.Perm (MarkoffSurface R)) + ((normalizationSurfaceEquiv R).symm x) = + vieta2SurfacePerm R ((normalizationSurfaceEquiv R).symm x) by + exact gammaVieta2_smul_surface ((normalizationSurfaceEquiv R).symm x)] + apply Subtype.ext + change toNormalized (vieta2 ((normalizationSurfaceEquiv R).symm x : Point R)) = + normalizedVieta2 x + rw [toNormalized_vieta2] + rw [show toNormalized ((normalizationSurfaceEquiv R).symm x : Point R) = x by + exact congrArg Subtype.val ((normalizationSurfaceEquiv R).apply_symm_apply x)] + +private theorem gammaVieta3_smul_normalizedSurface + {R : Type u} [CommRing R] [Invertible (3 : R)] (x : NormalizedMarkoffSurface R) : + gammaVieta3 R • x = normalizedVieta3Surface x := by + rw [normalizedGamma_smul_eq_perm, normalizedGammaPerm_apply] + rw [show (gammaVieta3 R : Equiv.Perm (MarkoffSurface R)) + ((normalizationSurfaceEquiv R).symm x) = + vieta3SurfacePerm R ((normalizationSurfaceEquiv R).symm x) by + exact gammaVieta3_smul_surface ((normalizationSurfaceEquiv R).symm x)] + apply Subtype.ext + change toNormalized (vieta3 ((normalizationSurfaceEquiv R).symm x : Point R)) = + normalizedVieta3 x + rw [toNormalized_vieta3] + rw [show toNormalized ((normalizationSurfaceEquiv R).symm x : Point R) = x by + exact congrArg Subtype.val ((normalizationSurfaceEquiv R).apply_symm_apply x)] + +private theorem normalizedSurfaceMap_vieta1 {R : Type u} {S : Type v} + [CommRing R] [CommRing S] (f : R →+* S) (x : NormalizedMarkoffSurface R) : + normalizedSurfaceMap f (normalizedVieta1Surface x) = + normalizedVieta1Surface (normalizedSurfaceMap f x) := by + apply Subtype.ext + ext <;> simp [normalizedSurfaceMap, NormalizedPoint.map, normalizedVieta1Surface, + normalizedVieta1] + +private theorem normalizedSurfaceMap_vieta2 {R : Type u} {S : Type v} + [CommRing R] [CommRing S] (f : R →+* S) (x : NormalizedMarkoffSurface R) : + normalizedSurfaceMap f (normalizedVieta2Surface x) = + normalizedVieta2Surface (normalizedSurfaceMap f x) := by + apply Subtype.ext + ext <;> simp [normalizedSurfaceMap, NormalizedPoint.map, normalizedVieta2Surface, + normalizedVieta2] + +private theorem normalizedSurfaceMap_vieta3 {R : Type u} {S : Type v} + [CommRing R] [CommRing S] (f : R →+* S) (x : NormalizedMarkoffSurface R) : + normalizedSurfaceMap f (normalizedVieta3Surface x) = + normalizedVieta3Surface (normalizedSurfaceMap f x) := by + apply Subtype.ext + ext <;> simp [normalizedSurfaceMap, NormalizedPoint.map, normalizedVieta3Surface, + normalizedVieta3] + +private theorem normalizedSurfaceMap_swap12 {R : Type u} {S : Type v} + [CommRing R] [CommRing S] (f : R →+* S) (x : NormalizedMarkoffSurface R) : + normalizedSurfaceMap f (normalizedSwap12Surface x) = + normalizedSwap12Surface (normalizedSurfaceMap f x) := by + apply Subtype.ext + ext <;> simp [normalizedSurfaceMap, NormalizedPoint.map, normalizedSwap12Surface, + normalizedSwap12] + +private theorem normalizedSurfaceMap_swap23 {R : Type u} {S : Type v} + [CommRing R] [CommRing S] (f : R →+* S) (x : NormalizedMarkoffSurface R) : + normalizedSurfaceMap f (normalizedSwap23Surface x) = + normalizedSwap23Surface (normalizedSurfaceMap f x) := by + apply Subtype.ext + ext <;> simp [normalizedSurfaceMap, NormalizedPoint.map, normalizedSwap23Surface, + normalizedSwap23] + +/-- Every normalized `Gamma` word over the target field has a source-field word with the same +action after applying a field embedding. -/ +theorem exists_normalizedGamma_lift_along_fieldHom + {K : Type u} {L : Type v} [Field K] [Field L] + [Invertible (3 : K)] [Invertible (3 : L)] (f : K →+* L) (g : Gamma L) : + ∃ h : Gamma K, ∀ x : NormalizedMarkoffSurface K, + normalizedSurfaceMap f (h • x) = g • normalizedSurfaceMap f x := by + let motive : ∀ q : Equiv.Perm (MarkoffSurface L), q ∈ Subgroup.closure (gammaGenerators L) → Prop := + fun q hq ↦ ∃ h : Gamma K, ∀ x : NormalizedMarkoffSurface K, + normalizedSurfaceMap f (h • x) = + (⟨q, hq⟩ : Gamma L) • normalizedSurfaceMap f x + apply Subgroup.closure_induction (p := motive) + · intro q hq + simp only [gammaGenerators, Set.mem_insert_iff, Set.mem_singleton_iff] at hq + rcases hq with rfl | rfl | rfl | rfl | rfl + · refine ⟨gammaVieta1 K, fun x ↦ ?_⟩ + change normalizedSurfaceMap f (gammaVieta1 K • x) = + gammaVieta1 L • normalizedSurfaceMap f x + rw [gammaVieta1_smul_normalizedSurface, gammaVieta1_smul_normalizedSurface] + exact normalizedSurfaceMap_vieta1 f x + · refine ⟨gammaVieta2 K, fun x ↦ ?_⟩ + change normalizedSurfaceMap f (gammaVieta2 K • x) = + gammaVieta2 L • normalizedSurfaceMap f x + rw [gammaVieta2_smul_normalizedSurface, gammaVieta2_smul_normalizedSurface] + exact normalizedSurfaceMap_vieta2 f x + · refine ⟨gammaVieta3 K, fun x ↦ ?_⟩ + change normalizedSurfaceMap f (gammaVieta3 K • x) = + gammaVieta3 L • normalizedSurfaceMap f x + rw [gammaVieta3_smul_normalizedSurface, gammaVieta3_smul_normalizedSurface] + exact normalizedSurfaceMap_vieta3 f x + · refine ⟨gammaSwap12 K, fun x ↦ ?_⟩ + change normalizedSurfaceMap f (gammaSwap12 K • x) = + gammaSwap12 L • normalizedSurfaceMap f x + rw [gammaSwap12_smul_normalizedSurface, gammaSwap12_smul_normalizedSurface] + exact normalizedSurfaceMap_swap12 f x + · refine ⟨gammaSwap23 K, fun x ↦ ?_⟩ + change normalizedSurfaceMap f (gammaSwap23 K • x) = + gammaSwap23 L • normalizedSurfaceMap f x + rw [gammaSwap23_smul_normalizedSurface, gammaSwap23_smul_normalizedSurface] + exact normalizedSurfaceMap_swap23 f x + · refine ⟨1, fun x ↦ ?_⟩ + simp + · intro q r hq hr hqLift hrLift + obtain ⟨qK, hqK⟩ := hqLift + obtain ⟨rK, hrK⟩ := hrLift + refine ⟨qK * rK, fun x ↦ ?_⟩ + change normalizedSurfaceMap f ((qK * rK) • x) = + ((⟨q, hq⟩ : Gamma L) * (⟨r, hr⟩ : Gamma L)) • normalizedSurfaceMap f x + rw [mul_smul, mul_smul, hqK, hrK] + · intro q hq hqLift + obtain ⟨qK, hqK⟩ := hqLift + refine ⟨qK⁻¹, fun x ↦ ?_⟩ + have h := congrArg (fun y ↦ (⟨q, hq⟩ : Gamma L)⁻¹ • y) (hqK (qK⁻¹ • x)) + simpa [mul_smul] using h.symm + +/-- The target-field orbit of the mapped point is contained in the image of the source orbit. -/ +theorem normalizedGammaOrbit_map_subset + {K : Type u} {L : Type v} [Field K] [Field L] + [Invertible (3 : K)] [Invertible (3 : L)] (f : K →+* L) + (x : NormalizedMarkoffSurface K) : + normalizedGammaOrbit (normalizedSurfaceMap f x) ⊆ + normalizedSurfaceMap f '' normalizedGammaOrbit x := by + intro y hy + change y ∈ MulAction.orbit (Gamma L) (normalizedSurfaceMap f x) at hy + rw [MulAction.mem_orbit_iff] at hy + obtain ⟨g, rfl⟩ := hy + obtain ⟨h, hh⟩ := exists_normalizedGamma_lift_along_fieldHom f g + refine ⟨h • x, (MulAction.mem_orbit_iff).2 ⟨h, rfl⟩, hh x⟩ + +/-- A finite normalized orbit stays finite after applying a field embedding. -/ +theorem finite_normalizedGammaOrbit_map + {K : Type u} {L : Type v} [Field K] [Field L] + [Invertible (3 : K)] [Invertible (3 : L)] (f : K →+* L) + (x : NormalizedMarkoffSurface K) (hfinite : (normalizedGammaOrbit x).Finite) : + (normalizedGammaOrbit (normalizedSurfaceMap f x)).Finite := + (hfinite.image (normalizedSurfaceMap f)).subset (normalizedGammaOrbit_map_subset f x) + +/-- The complex opening theorem descends along any field embedding into `ℂ`. -/ +theorem normalizedGammaOrbit_infinite_of_ne_origin_of_complexEmbedding + {K : Type u} [Field K] [Invertible (3 : K)] (f : K →+* ℂ) + (x : NormalizedMarkoffSurface K) (hx : x.1 ≠ normalizedOrigin) : + (normalizedGammaOrbit x).Infinite := by + intro hfinite + have hmapNe : (normalizedSurfaceMap f x).1 ≠ normalizedOrigin := by + intro hzero + apply hx + apply NormalizedPoint.ext + · apply f.injective + simpa [normalizedSurfaceMap, NormalizedPoint.map, normalizedOrigin] using + congrArg NormalizedPoint.u1 hzero + · apply f.injective + simpa [normalizedSurfaceMap, NormalizedPoint.map, normalizedOrigin] using + congrArg NormalizedPoint.u2 hzero + · apply f.injective + simpa [normalizedSurfaceMap, NormalizedPoint.map, normalizedOrigin] using + congrArg NormalizedPoint.u3 hzero + exact complex_normalizedGammaOrbit_infinite_of_ne_origin (normalizedSurfaceMap f x) hmapNe + (finite_normalizedGammaOrbit_map f x hfinite) + +/-- A chosen embedding of the canonical algebraic closure of `ℚ` into `ℂ`. -/ +noncomputable def algebraicClosureRatComplexEmbedding : AlgebraicClosure ℚ →+* ℂ := + letI : Algebra.IsAlgebraic ℚ (AlgebraicClosure ℚ) := + AlgebraicClosure.isAlgebraic ℚ + (IsAlgClosed.lift (R := ℚ) (S := AlgebraicClosure ℚ) (M := ℂ)).toRingHom + +/-- The published characteristic-zero opening: every nonzero normalized Markoff point over the +canonical algebraic closure of `ℚ` has infinite `Gamma`-orbit. -/ +theorem algebraicClosureRat_normalizedGammaOrbit_infinite_of_ne_origin + (x : NormalizedMarkoffSurface (AlgebraicClosure ℚ)) + (hx : x.1 ≠ normalizedOrigin) : + (normalizedGammaOrbit x).Infinite := + normalizedGammaOrbit_infinite_of_ne_origin_of_complexEmbedding + algebraicClosureRatComplexEmbedding x hx + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Opening/CompatibleRoots.lean b/LeanPool/MarkoffModP/BGS/Markoff/Opening/CompatibleRoots.lean new file mode 100644 index 0000000000..2429b31fb3 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Opening/CompatibleRoots.lean @@ -0,0 +1,55 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import Mathlib.RingTheory.RootsOfUnity.AlgebraicallyClosed + +/-! +# Compatible powers of a common primitive root + +Represent several torsion elements as powers of one primitive root under the required order +divisibility conditions. +-/ + +@[expose] public section + +namespace BGS.Markoff + +variable {K : Type*} [Field K] [IsAlgClosed K] [CharZero K] + +theorem exists_common_primitiveRoot_powers (n : ℕ) [NeZero n] + (w₁ w₂ w₃ : K) (hw₁ : w₁ ^ n = 1) (hw₂ : w₂ ^ n = 1) + (hw₃ : w₃ ^ n = 1) : + ∃ ζ : K, ∃ a₁ a₂ a₃ : ℕ, + IsPrimitiveRoot ζ n ∧ a₁ < n ∧ a₂ < n ∧ a₃ < n ∧ + ζ ^ a₁ = w₁ ∧ ζ ^ a₂ = w₂ ∧ ζ ^ a₃ = w₃ := by + have : NeZero (n : K) := ⟨by exact_mod_cast (NeZero.ne n)⟩ + obtain ⟨ζ, hζ⟩ := HasEnoughRootsOfUnity.exists_primitiveRoot K n + obtain ⟨a₁, ha₁n, ha₁⟩ := hζ.eq_pow_of_pow_eq_one hw₁ + obtain ⟨a₂, ha₂n, ha₂⟩ := hζ.eq_pow_of_pow_eq_one hw₂ + obtain ⟨a₃, ha₃n, ha₃⟩ := hζ.eq_pow_of_pow_eq_one hw₃ + exact ⟨ζ, a₁, a₂, a₃, hζ, ha₁n, ha₂n, ha₃n, ha₁, ha₂, ha₃⟩ + +/-- Three units whose exact orders divide `n` are simultaneous powers of one primitive +`n`-th root. This is the group-theoretic core of the compatible cyclotomic lift. -/ +theorem exists_common_primitiveRoot_powers_of_orderOf_dvd + (n : ℕ) [NeZero n] (w₁ w₂ w₃ : Kˣ) + (hw₁ : orderOf w₁ ∣ n) (hw₂ : orderOf w₂ ∣ n) + (hw₃ : orderOf w₃ ∣ n) : + ∃ ζ : K, ∃ a₁ a₂ a₃ : ℕ, + IsPrimitiveRoot ζ n ∧ a₁ < n ∧ a₂ < n ∧ a₃ < n ∧ + ζ ^ a₁ = (w₁ : K) ∧ ζ ^ a₂ = (w₂ : K) ∧ ζ ^ a₃ = (w₃ : K) := by + have hpow₁ : (w₁ : K) ^ n = 1 := by + simpa using congrArg Units.val (orderOf_dvd_iff_pow_eq_one.mp hw₁) + have hpow₂ : (w₂ : K) ^ n = 1 := by + simpa using congrArg Units.val (orderOf_dvd_iff_pow_eq_one.mp hw₂) + have hpow₃ : (w₃ : K) ^ n = 1 := by + simpa using congrArg Units.val (orderOf_dvd_iff_pow_eq_one.mp hw₃) + exact exists_common_primitiveRoot_powers n (w₁ : K) (w₂ : K) (w₃ : K) + hpow₁ hpow₂ hpow₃ + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Opening/CyclotomicBound.lean b/LeanPool/MarkoffModP/BGS/Markoff/Opening/CyclotomicBound.lean new file mode 100644 index 0000000000..249ff86a4b --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Opening/CyclotomicBound.lean @@ -0,0 +1,275 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Opening.CyclotomicReduction + +/-! +# The concrete cyclotomic opening bound + +This file evaluates the integral cyclotomic defect at the compatible residue prime and connects +that vanishing to the archimedean norm estimate. +-/ + +@[expose] public section + +open scoped NumberField + +namespace BGS.Markoff + +/-- An integral reciprocal trace, written polynomially using `ζⁿ = 1`. -/ +noncomputable def openingCyclotomicIntegerTrace + (n a : ℕ) [NeZero n] : OpeningCyclotomicIntegers n := + openingCyclotomicIntegerRoot n ^ a + openingCyclotomicIntegerRoot n ^ (n - a) + +/-- The integral defect formed from three polynomial reciprocal traces. -/ +noncomputable def openingCyclotomicIntegerDefect + (n a₁ a₂ a₃ : ℕ) [NeZero n] : OpeningCyclotomicIntegers n := + let t₁ := openingCyclotomicIntegerTrace n a₁ + let t₂ := openingCyclotomicIntegerTrace n a₂ + let t₃ := openingCyclotomicIntegerTrace n a₃ + t₁ ^ 2 + t₂ ^ 2 + t₃ ^ 2 - t₁ * t₂ * t₃ + +private theorem openingCyclotomicRoot_pow_mul_complement + (n a : ℕ) [NeZero n] (ha : a ≤ n) : + openingCyclotomicRoot n ^ a * openingCyclotomicRoot n ^ (n - a) = 1 := by + rw [← pow_add, Nat.add_sub_of_le ha] + exact (openingCyclotomicRoot_isPrimitive n).pow_eq_one + +private theorem residueRoot_pow_mul_complement + {K : Type*} [Field K] {n a : ℕ} {w : K} + (hw : IsPrimitiveRoot w n) (ha : a ≤ n) : + w ^ a * w ^ (n - a) = 1 := by + rw [← pow_add, Nat.add_sub_of_le ha] + exact hw.pow_eq_one + +private theorem coe_openingCyclotomicIntegerRoot (n : ℕ) [NeZero n] : + algebraMap (OpeningCyclotomicIntegers n) (OpeningCyclotomicField n) + (openingCyclotomicIntegerRoot n) = openingCyclotomicRoot n := by + exact (openingCyclotomicRoot_isPrimitive n).coe_toInteger + +/-- Coercing the integral polynomial trace to the cyclotomic field gives the reciprocal trace. -/ +theorem coe_openingCyclotomicIntegerTrace + (n a : ℕ) [NeZero n] (ha : a ≤ n) : + ((openingCyclotomicIntegerTrace n a : OpeningCyclotomicIntegers n) : + OpeningCyclotomicField n) = + cyclotomicTrace (openingCyclotomicRoot n ^ a) := by + rw [openingCyclotomicIntegerTrace, cyclotomicTrace] + simp only [map_add, map_pow] + rw [coe_openingCyclotomicIntegerRoot n] + rw [eq_inv_of_mul_eq_one_right (openingCyclotomicRoot_pow_mul_complement n a ha)] + +/-- Coercing the integral polynomial defect gives the characteristic-zero cyclotomic defect. -/ +theorem coe_openingCyclotomicIntegerDefect + (n a₁ a₂ a₃ : ℕ) [NeZero n] + (ha₁ : a₁ ≤ n) (ha₂ : a₂ ≤ n) (ha₃ : a₃ ≤ n) : + ((openingCyclotomicIntegerDefect n a₁ a₂ a₃ : OpeningCyclotomicIntegers n) : + OpeningCyclotomicField n) = + cyclotomicDefect (openingCyclotomicRoot n ^ a₁) + (openingCyclotomicRoot n ^ a₂) (openingCyclotomicRoot n ^ a₃) := by + simp only [openingCyclotomicIntegerDefect, map_sub, map_add, map_mul, map_pow] + rw [show algebraMap (OpeningCyclotomicIntegers n) (OpeningCyclotomicField n) + (openingCyclotomicIntegerTrace n a₁) = + cyclotomicTrace (openingCyclotomicRoot n ^ a₁) from + coe_openingCyclotomicIntegerTrace n a₁ ha₁, + show algebraMap (OpeningCyclotomicIntegers n) (OpeningCyclotomicField n) + (openingCyclotomicIntegerTrace n a₂) = + cyclotomicTrace (openingCyclotomicRoot n ^ a₂) from + coe_openingCyclotomicIntegerTrace n a₂ ha₂, + show algebraMap (OpeningCyclotomicIntegers n) (OpeningCyclotomicField n) + (openingCyclotomicIntegerTrace n a₃) = + cyclotomicTrace (openingCyclotomicRoot n ^ a₃) from + coe_openingCyclotomicIntegerTrace n a₃ ha₃] + rfl + +/-- Compatible reduction sends the polynomial integral trace to the prescribed residue trace. -/ +theorem openingCyclotomicReduction_integerTrace + (p n a : ℕ) [Fact p.Prime] [NeZero n] (hcoprime : Nat.Coprime p n) + (ω : OpeningResidueClosure p) (hω : IsPrimitiveRoot ω n) (ha : a ≤ n) : + openingCyclotomicReduction p n hcoprime ω hω + (openingCyclotomicIntegerTrace n a) = + cyclotomicTrace (ω ^ a) := by + rw [openingCyclotomicIntegerTrace, map_add, map_pow, map_pow, + openingCyclotomicReduction_integerRoot, cyclotomicTrace] + rw [eq_inv_of_mul_eq_one_right (residueRoot_pow_mul_complement hω ha)] + +/-- Compatible reduction sends the integral defect to the residue-field cyclotomic defect. -/ +theorem openingCyclotomicReduction_integerDefect + (p n a₁ a₂ a₃ : ℕ) [Fact p.Prime] [NeZero n] + (hcoprime : Nat.Coprime p n) + (ω : OpeningResidueClosure p) (hω : IsPrimitiveRoot ω n) + (ha₁ : a₁ ≤ n) (ha₂ : a₂ ≤ n) (ha₃ : a₃ ≤ n) : + openingCyclotomicReduction p n hcoprime ω hω + (openingCyclotomicIntegerDefect n a₁ a₂ a₃) = + cyclotomicDefect (ω ^ a₁) (ω ^ a₂) (ω ^ a₃) := by + simp only [openingCyclotomicIntegerDefect, map_sub, map_add, map_mul, map_pow] + rw [openingCyclotomicReduction_integerTrace p n a₁ hcoprime ω hω ha₁, + openingCyclotomicReduction_integerTrace p n a₂ hcoprime ω hω ha₂, + openingCyclotomicReduction_integerTrace p n a₃ hcoprime ω hω ha₃] + rfl + +/-- A normalized residue Markoff point makes the corresponding residue cyclotomic defect vanish. -/ +theorem residueCyclotomicDefect_eq_zero_of_normalizedMarkoff + {p : ℕ} [Fact p.Prime] (x : NormalizedPoint (OpeningResidueClosure p)) + (hx : IsNormalizedMarkoff x) + {z₁ z₂ z₃ : OpeningResidueClosure p} + (h₁ : x.u1 = cyclotomicTrace z₁) (h₂ : x.u2 = cyclotomicTrace z₂) + (h₃ : x.u3 = cyclotomicTrace z₃) : + cyclotomicDefect z₁ z₂ z₃ = 0 := by + simpa [IsNormalizedMarkoff, normalizedPolynomial, cyclotomicDefect, h₁, h₂, h₃] using hx + +/-- The integral defect therefore belongs to the compatible prime selected by the residue root. -/ +theorem openingCyclotomicIntegerDefect_mem_prime_of_normalizedMarkoff + (p n a₁ a₂ a₃ : ℕ) [Fact p.Prime] [NeZero n] + (hcoprime : Nat.Coprime p n) + (ω : OpeningResidueClosure p) (hω : IsPrimitiveRoot ω n) + (ha₁ : a₁ ≤ n) (ha₂ : a₂ ≤ n) (ha₃ : a₃ ≤ n) + (x : NormalizedPoint (OpeningResidueClosure p)) (hx : IsNormalizedMarkoff x) + (h₁ : x.u1 = cyclotomicTrace (ω ^ a₁)) + (h₂ : x.u2 = cyclotomicTrace (ω ^ a₂)) + (h₃ : x.u3 = cyclotomicTrace (ω ^ a₃)) : + openingCyclotomicIntegerDefect n a₁ a₂ a₃ ∈ + openingCyclotomicPrime p n hcoprime ω hω := by + rw [openingCyclotomicPrime, RingHom.mem_ker] + rw [show (openingCyclotomicReduction p n hcoprime ω hω).toRingHom + (openingCyclotomicIntegerDefect n a₁ a₂ a₃) = + cyclotomicDefect (ω ^ a₁) (ω ^ a₂) (ω ^ a₃) from + openingCyclotomicReduction_integerDefect p n a₁ a₂ a₃ hcoprime ω hω + ha₁ ha₂ ha₃] + exact residueCyclotomicDefect_eq_zero_of_normalizedMarkoff x hx h₁ h₂ h₃ + +private theorem openingCyclotomicRoot_pow_isOfFinOrder + (n a : ℕ) [NeZero n] : IsOfFinOrder (openingCyclotomicRoot n ^ a) := by + rw [isOfFinOrder_iff_pow_eq_one] + refine ⟨n, NeZero.pos n, ?_⟩ + rw [pow_right_comm, (openingCyclotomicRoot_isPrimitive n).pow_eq_one, one_pow] + +/-- If the residue traces form a nonorigin point, the characteristic-zero cyclotomic defect of +the compatible powers is nonzero. -/ +theorem openingCyclotomicDefect_ne_zero_of_residuePoint_ne_origin + (p n a₁ a₂ a₃ : ℕ) [Fact p.Prime] [NeZero n] + (hcoprime : Nat.Coprime p n) + (ω : OpeningResidueClosure p) (hω : IsPrimitiveRoot ω n) + (ha₁ : a₁ ≤ n) (ha₂ : a₂ ≤ n) (ha₃ : a₃ ≤ n) + (x : NormalizedPoint (OpeningResidueClosure p)) + (h₁ : x.u1 = cyclotomicTrace (ω ^ a₁)) + (h₂ : x.u2 = cyclotomicTrace (ω ^ a₂)) + (h₃ : x.u3 = cyclotomicTrace (ω ^ a₃)) + (hxne : x ≠ normalizedOrigin) : + cyclotomicDefect (openingCyclotomicRoot n ^ a₁) + (openingCyclotomicRoot n ^ a₂) (openingCyclotomicRoot n ^ a₃) ≠ 0 := by + intro hzero + let σ : OpeningCyclotomicField n →ₐ[ℚ] ℂ := IsAlgClosed.lift + let z₁ := openingCyclotomicRoot n ^ a₁ + let z₂ := openingCyclotomicRoot n ^ a₂ + let z₃ := openingCyclotomicRoot n ^ a₃ + have hz₁fin : IsOfFinOrder z₁ := openingCyclotomicRoot_pow_isOfFinOrder n a₁ + have hz₂fin : IsOfFinOrder z₂ := openingCyclotomicRoot_pow_isOfFinOrder n a₂ + have hz₃fin : IsOfFinOrder z₃ := openingCyclotomicRoot_pow_isOfFinOrder n a₃ + have hz₁prim : IsPrimitiveRoot z₁ (orderOf z₁) := IsPrimitiveRoot.orderOf z₁ + have hz₂prim : IsPrimitiveRoot z₂ (orderOf z₂) := IsPrimitiveRoot.orderOf z₂ + have hz₃prim : IsPrimitiveRoot z₃ (orderOf z₃) := IsPrimitiveRoot.orderOf z₃ + have hnorm₁ : ‖σ z₁‖ = 1 := + (hz₁prim.map_of_injective σ.injective).norm'_eq_one hz₁fin.orderOf_pos.ne' + have hnorm₂ : ‖σ z₂‖ = 1 := + (hz₂prim.map_of_injective σ.injective).norm'_eq_one hz₂fin.orderOf_pos.ne' + have hnorm₃ : ‖σ z₃‖ = 1 := + (hz₃prim.map_of_injective σ.injective).norm'_eq_one hz₃fin.orderOf_pos.ne' + have hzeroComplex : cyclotomicDefect (σ z₁) (σ z₂) (σ z₃) = 0 := by + simpa [z₁, z₂, z₃, cyclotomicDefect, cyclotomicTrace] using congrArg σ hzero + obtain ⟨htrace₁Complex, htrace₂Complex, htrace₃Complex⟩ := + cyclotomicTrace_eq_zero_of_defect_eq_zero hnorm₁ hnorm₂ hnorm₃ hzeroComplex + have htrace₁ : cyclotomicTrace z₁ = 0 := by + apply σ.injective + simpa [cyclotomicTrace] using htrace₁Complex + have htrace₂ : cyclotomicTrace z₂ = 0 := by + apply σ.injective + simpa [cyclotomicTrace] using htrace₂Complex + have htrace₃ : cyclotomicTrace z₃ = 0 := by + apply σ.injective + simpa [cyclotomicTrace] using htrace₃Complex + have hIntegerTrace₁ : openingCyclotomicIntegerTrace n a₁ = 0 := by + apply NumberField.RingOfIntegers.coe_injective + simpa [z₁, coe_openingCyclotomicIntegerTrace n a₁ ha₁] using htrace₁ + have hIntegerTrace₂ : openingCyclotomicIntegerTrace n a₂ = 0 := by + apply NumberField.RingOfIntegers.coe_injective + simpa [z₂, coe_openingCyclotomicIntegerTrace n a₂ ha₂] using htrace₂ + have hIntegerTrace₃ : openingCyclotomicIntegerTrace n a₃ = 0 := by + apply NumberField.RingOfIntegers.coe_injective + simpa [z₃, coe_openingCyclotomicIntegerTrace n a₃ ha₃] using htrace₃ + have hResidueTrace₁ : cyclotomicTrace (ω ^ a₁) = 0 := by + simpa [hIntegerTrace₁] using + (openingCyclotomicReduction_integerTrace p n a₁ hcoprime ω hω ha₁).symm + have hResidueTrace₂ : cyclotomicTrace (ω ^ a₂) = 0 := by + simpa [hIntegerTrace₂] using + (openingCyclotomicReduction_integerTrace p n a₂ hcoprime ω hω ha₂).symm + have hResidueTrace₃ : cyclotomicTrace (ω ^ a₃) = 0 := by + simpa [hIntegerTrace₃] using + (openingCyclotomicReduction_integerTrace p n a₃ hcoprime ω hω ha₃).symm + apply hxne + apply NormalizedPoint.ext + · simpa [normalizedOrigin, h₁] using hResidueTrace₁ + · simpa [normalizedOrigin, h₂] using hResidueTrace₂ + · simpa [normalizedOrigin, h₃] using hResidueTrace₃ + +/-- The concrete cyclotomic opening inequality. A nonorigin normalized Markoff point whose three +coordinates are reciprocal traces of powers of one primitive residue root forces +`p ≤ 20 ^ φ(n)`. -/ +theorem modulus_le_twenty_pow_totient_of_compatible_residue_traces + (p n a₁ a₂ a₃ : ℕ) [Fact p.Prime] [NeZero n] + (hcoprime : Nat.Coprime p n) + (ω : OpeningResidueClosure p) (hω : IsPrimitiveRoot ω n) + (ha₁ : a₁ ≤ n) (ha₂ : a₂ ≤ n) (ha₃ : a₃ ≤ n) + (x : NormalizedPoint (OpeningResidueClosure p)) (hx : IsNormalizedMarkoff x) + (h₁ : x.u1 = cyclotomicTrace (ω ^ a₁)) + (h₂ : x.u2 = cyclotomicTrace (ω ^ a₂)) + (h₃ : x.u3 = cyclotomicTrace (ω ^ a₃)) + (hxne : x ≠ normalizedOrigin) : + p ≤ 20 ^ n.totient := by + let : NeZero (n : ℚ) := ⟨by exact_mod_cast (NeZero.ne n)⟩ + let : IsCyclotomicExtension {n} ℚ (OpeningCyclotomicField n) := + CyclotomicField.isCyclotomicExtension n ℚ + let z₁ := openingCyclotomicRoot n ^ a₁ + let z₂ := openingCyclotomicRoot n ^ a₂ + let z₃ := openingCyclotomicRoot n ^ a₃ + let l₁ := orderOf z₁ + let l₂ := orderOf z₂ + let l₃ := orderOf z₃ + have hz₁fin : IsOfFinOrder z₁ := openingCyclotomicRoot_pow_isOfFinOrder n a₁ + have hz₂fin : IsOfFinOrder z₂ := openingCyclotomicRoot_pow_isOfFinOrder n a₂ + have hz₃fin : IsOfFinOrder z₃ := openingCyclotomicRoot_pow_isOfFinOrder n a₃ + have hz₁ : IsPrimitiveRoot z₁ l₁ := IsPrimitiveRoot.orderOf z₁ + have hz₂ : IsPrimitiveRoot z₂ l₂ := IsPrimitiveRoot.orderOf z₂ + have hz₃ : IsPrimitiveRoot z₃ l₃ := IsPrimitiveRoot.orderOf z₃ + have hl₁ : 0 < l₁ := hz₁fin.orderOf_pos + have hl₂ : 0 < l₂ := hz₂fin.orderOf_pos + have hl₃ : 0 < l₃ := hz₃fin.orderOf_pos + let P := openingCyclotomicPrime p n hcoprime ω hω + have hdefectNe : cyclotomicDefect z₁ z₂ z₃ ≠ 0 := by + exact openingCyclotomicDefect_ne_zero_of_residuePoint_ne_origin + p n a₁ a₂ a₃ hcoprime ω hω ha₁ ha₂ ha₃ x h₁ h₂ h₃ hxne + have hred : + let γ : OpeningCyclotomicIntegers n := + ⟨cyclotomicDefect z₁ z₂ z₃, + isIntegral_cyclotomicDefect_of_primitiveRoots hz₁ hl₁ hz₂ hl₂ hz₃ hl₃⟩ + Ideal.Quotient.mk P γ = 0 := by + dsimp only + erw [Ideal.Quotient.eq_zero_iff_mem] + have hmem := openingCyclotomicIntegerDefect_mem_prime_of_normalizedMarkoff + p n a₁ a₂ a₃ hcoprime ω hω ha₁ ha₂ ha₃ x hx h₁ h₂ h₃ + rw [show (⟨cyclotomicDefect z₁ z₂ z₃, + isIntegral_cyclotomicDefect_of_primitiveRoots hz₁ hl₁ hz₂ hl₂ hz₃ hl₃⟩ : + OpeningCyclotomicIntegers n) = openingCyclotomicIntegerDefect n a₁ a₂ a₃ by + apply Subtype.ext + exact (coe_openingCyclotomicIntegerDefect n a₁ a₂ a₃ ha₁ ha₂ ha₃).symm] + exact hmem + exact modulus_le_twenty_pow_totient_of_cyclotomicDefect_reduction + (n := n) hz₁ hl₁ hz₂ hl₂ hz₃ hl₃ P p + (by simpa [P] using openingCyclotomicPrime_under p n hcoprime ω hω) + hdefectNe hred + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Opening/CyclotomicDefect.lean b/LeanPool/MarkoffModP/BGS/Markoff/Opening/CyclotomicDefect.lean new file mode 100644 index 0000000000..bf17a1288d --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Opening/CyclotomicDefect.lean @@ -0,0 +1,127 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Opening.UnitCircle +public import Mathlib.Analysis.Complex.Basic +public import Mathlib.Analysis.Complex.Norm + +/-! +# The cyclotomic defect in the opening + +This module isolates the characteristic-zero algebra used after compatible finite-field +eigenvalues have been lifted to roots of unity. The difficult number-field reduction interface +is not assumed here: given three complex unit-circle lifts, we define the symmetric defect, +prove its uniform archimedean bound, and prove that it cannot vanish unless all three traces do. +-/ + +@[expose] public section + +namespace BGS.Markoff + +/-- The trace associated to a nonzero eigenvalue and its reciprocal. -/ +def cyclotomicTrace {K : Type*} [Field K] (z : K) : K := + z + z⁻¹ + +/-- The symmetric Markoff defect of three lifted eigenvalues. -/ +def cyclotomicDefect {K : Type*} [Field K] (z₁ z₂ z₃ : K) : K := + cyclotomicTrace z₁ ^ 2 + cyclotomicTrace z₂ ^ 2 + cyclotomicTrace z₃ ^ 2 - + cyclotomicTrace z₁ * cyclotomicTrace z₂ * cyclotomicTrace z₃ + +/-- On the complex unit circle, reciprocal-eigenvalue trace is twice the real part. -/ +theorem cyclotomicTrace_eq_two_mul_re {z : ℂ} (hz : ‖z‖ = 1) : + cyclotomicTrace z = (2 * z.re : ℝ) := by + rw [cyclotomicTrace, Complex.inv_eq_conj hz] + apply Complex.ext + · simp + ring + · simp + +/-- A unit-circle trace has complex norm at most two. -/ +theorem norm_cyclotomicTrace_le_two {z : ℂ} (hz : ‖z‖ = 1) : + ‖cyclotomicTrace z‖ ≤ 2 := by + rw [cyclotomicTrace] + calc + ‖z + z⁻¹‖ ≤ ‖z‖ + ‖z⁻¹‖ := norm_add_le _ _ + _ = 2 := by simp [hz]; norm_num + +/-- Every complex embedding of the symmetric cyclotomic defect has absolute value at most +`20`, provided the three eigenvalues lie on the unit circle. -/ +theorem norm_cyclotomicDefect_le_twenty + {z₁ z₂ z₃ : ℂ} (hz₁ : ‖z₁‖ = 1) (hz₂ : ‖z₂‖ = 1) (hz₃ : ‖z₃‖ = 1) : + ‖cyclotomicDefect z₁ z₂ z₃‖ ≤ 20 := by + let t₁ := cyclotomicTrace z₁ + let t₂ := cyclotomicTrace z₂ + let t₃ := cyclotomicTrace z₃ + have ht₁ : ‖t₁‖ ≤ 2 := norm_cyclotomicTrace_le_two hz₁ + have ht₂ : ‖t₂‖ ≤ 2 := norm_cyclotomicTrace_le_two hz₂ + have ht₃ : ‖t₃‖ ≤ 2 := norm_cyclotomicTrace_le_two hz₃ + have ht₁sq : ‖t₁ ^ 2‖ ≤ 4 := by rw [norm_pow]; nlinarith [norm_nonneg t₁] + have ht₂sq : ‖t₂ ^ 2‖ ≤ 4 := by rw [norm_pow]; nlinarith [norm_nonneg t₂] + have ht₃sq : ‖t₃ ^ 2‖ ≤ 4 := by rw [norm_pow]; nlinarith [norm_nonneg t₃] + have htprod : ‖t₁ * t₂ * t₃‖ ≤ 8 := by + rw [norm_mul, norm_mul] + nlinarith [norm_nonneg t₁, norm_nonneg t₂, norm_nonneg t₃, + mul_nonneg (norm_nonneg t₁) (norm_nonneg t₂)] + change ‖t₁ ^ 2 + t₂ ^ 2 + t₃ ^ 2 - t₁ * t₂ * t₃‖ ≤ 20 + have hsum : ‖t₁ ^ 2 + t₂ ^ 2 + t₃ ^ 2‖ ≤ + ‖t₁ ^ 2‖ + ‖t₂ ^ 2‖ + ‖t₃ ^ 2‖ := by + calc + ‖t₁ ^ 2 + t₂ ^ 2 + t₃ ^ 2‖ ≤ ‖t₁ ^ 2 + t₂ ^ 2‖ + ‖t₃ ^ 2‖ := + norm_add_le _ _ + _ ≤ (‖t₁ ^ 2‖ + ‖t₂ ^ 2‖) + ‖t₃ ^ 2‖ := by + linarith [norm_add_le (t₁ ^ 2) (t₂ ^ 2)] + calc + ‖t₁ ^ 2 + t₂ ^ 2 + t₃ ^ 2 - t₁ * t₂ * t₃‖ ≤ + ‖t₁ ^ 2 + t₂ ^ 2 + t₃ ^ 2‖ + ‖t₁ * t₂ * t₃‖ := norm_sub_le _ _ + _ ≤ (‖t₁ ^ 2‖ + ‖t₂ ^ 2‖ + ‖t₃ ^ 2‖) + ‖t₁ * t₂ * t₃‖ := by + linarith + _ ≤ 20 := by linarith + +/-- Three unit-circle lifts with vanishing cyclotomic defect have zero trace in every +coordinate. -/ +theorem cyclotomicTrace_eq_zero_of_defect_eq_zero + {z₁ z₂ z₃ : ℂ} (hz₁ : ‖z₁‖ = 1) (hz₂ : ‖z₂‖ = 1) (hz₃ : ‖z₃‖ = 1) + (hdefect : cyclotomicDefect z₁ z₂ z₃ = 0) : + cyclotomicTrace z₁ = 0 ∧ cyclotomicTrace z₂ = 0 ∧ cyclotomicTrace z₃ = 0 := by + let a : ℝ := 2 * z₁.re + let b : ℝ := 2 * z₂.re + let c : ℝ := 2 * z₃.re + have ht₁ : cyclotomicTrace z₁ = (a : ℂ) := cyclotomicTrace_eq_two_mul_re hz₁ + have ht₂ : cyclotomicTrace z₂ = (b : ℂ) := cyclotomicTrace_eq_two_mul_re hz₂ + have ht₃ : cyclotomicTrace z₃ = (c : ℂ) := cyclotomicTrace_eq_two_mul_re hz₃ + have hreal : a ^ 2 + b ^ 2 + c ^ 2 - a * b * c = 0 := by + rw [cyclotomicDefect, ht₁, ht₂, ht₃] at hdefect + exact_mod_cast hdefect + let x : NormalizedPoint ℝ := ⟨a, b, c⟩ + have hx : IsNormalizedMarkoff x := hreal + have haBound : a ∈ Set.Icc (-2 : ℝ) 2 := by + dsimp [a] + have hre := Complex.abs_re_le_norm z₁ + rw [hz₁] at hre + obtain ⟨hreLower, hreUpper⟩ := abs_le.mp hre + constructor <;> nlinarith + have hxOrigin := real_normalizedMarkoff_eq_origin_of_firstCoordinate_mem_Icc x hx haBound + have ha : a = 0 := congrArg NormalizedPoint.u1 hxOrigin + have hb : b = 0 := congrArg NormalizedPoint.u2 hxOrigin + have hc : c = 0 := congrArg NormalizedPoint.u3 hxOrigin + exact ⟨ht₁.trans (by simp [ha]), ht₂.trans (by simp [hb]), ht₃.trans (by simp [hc])⟩ + +/-- Unless all three reciprocal-eigenvalue traces vanish, the cyclotomic defect is nonzero. -/ +theorem cyclotomicDefect_ne_zero_of_some_trace_ne_zero + {z₁ z₂ z₃ : ℂ} (hz₁ : ‖z₁‖ = 1) (hz₂ : ‖z₂‖ = 1) (hz₃ : ‖z₃‖ = 1) + (htrace : cyclotomicTrace z₁ ≠ 0 ∨ cyclotomicTrace z₂ ≠ 0 ∨ + cyclotomicTrace z₃ ≠ 0) : + cyclotomicDefect z₁ z₂ z₃ ≠ 0 := by + intro hzero + obtain ⟨h₁, h₂, h₃⟩ := cyclotomicTrace_eq_zero_of_defect_eq_zero hz₁ hz₂ hz₃ hzero + rcases htrace with htrace | htrace | htrace + · exact htrace h₁ + · exact htrace h₂ + · exact htrace h₃ + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Opening/CyclotomicNorm.lean b/LeanPool/MarkoffModP/BGS/Markoff/Opening/CyclotomicNorm.lean new file mode 100644 index 0000000000..f0f814f708 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Opening/CyclotomicNorm.lean @@ -0,0 +1,208 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Opening.CyclotomicDefect +public import Mathlib.NumberTheory.NumberField.Cyclotomic.Basic +public import Mathlib.RingTheory.Ideal.Int + +/-! +# The norm and reduction bridge in the cyclotomic opening + +This module connects the already formalized archimedean estimate for the symmetric cyclotomic +defect to the arithmetic norm used in the opening argument. It also records the exact ideal +theoretic step turning vanishing modulo a prime above `p` into divisibility of the integer norm +by `p`. + +The construction of simultaneous compatible lifts and of the prime ideal realizing their +finite-field reduction is deliberately not assumed here. Those are the remaining inputs needed +before `prime_dvd_integerNorm_of_quotient_eq_zero` can be applied to the defect. +-/ + +@[expose] public section + +open scoped NumberField + +namespace BGS.Markoff + +/-- If every complex embedding of a number-field element has norm at most `B`, then its rational +field norm has norm at most `B` to the field degree. -/ +theorem algebraNorm_norm_le_pow_of_embeddings + {K : Type*} [Field K] [NumberField K] + (x : K) (B : ℝ) (hB : ∀ σ : K →+* ℂ, ‖σ x‖ ≤ B) : + ‖Algebra.norm ℚ x‖ ≤ B ^ Module.finrank ℚ K := by + classical + calc + ‖Algebra.norm ℚ x‖ = ‖((Algebra.norm ℚ x : ℚ) : ℝ)‖ := by + exact (Rat.norm_cast_real _).symm + _ = |((Algebra.norm ℚ x : ℚ) : ℝ)| := Real.norm_eq_abs _ + _ = ‖(algebraMap ℚ ℂ) (Algebra.norm ℚ x)‖ := by + change |((Algebra.norm ℚ x : ℚ) : ℝ)| = ‖((Algebra.norm ℚ x : ℚ) : ℂ)‖ + rw [Complex.norm_ratCast] + _ = ‖∏ σ : K →ₐ[ℚ] ℂ, σ x‖ := by rw [Algebra.norm_eq_prod_embeddings] + _ ≤ ∏ σ : K →ₐ[ℚ] ℂ, ‖σ x‖ := Finset.norm_prod_le _ _ + _ ≤ ∏ _σ : K →ₐ[ℚ] ℂ, B := by + exact Finset.prod_le_prod₀ (fun _ _ ↦ norm_nonneg _) (fun σ _ ↦ hB σ) + _ = B ^ Module.finrank ℚ K := by simp [AlgHom.card] + +/-- Integral version of `algebraNorm_norm_le_pow_of_embeddings`, with an integer-valued bound. -/ +theorem integerNorm_natAbs_le_pow_of_embeddings + {K : Type*} [Field K] [NumberField K] + (x : 𝓞 K) (B : ℕ) (hB : ∀ σ : K →+* ℂ, ‖σ (x : K)‖ ≤ B) : + (Algebra.norm ℤ x).natAbs ≤ B ^ Module.finrank ℚ K := by + rw [← Nat.cast_le (α := ℝ), Nat.cast_natAbs, Int.cast_abs] + have h := algebraNorm_norm_le_pow_of_embeddings (x : K) (B : ℝ) hB + rw [← Algebra.coe_norm_int] at h + rw [← Rat.norm_cast_real, Real.norm_eq_abs] at h + simpa only [Rat.cast_intCast, Int.cast_abs, Rat.cast_natCast, Nat.cast_pow] using h + +/-- A nonzero algebraic integer has a nonzero, hence positive-natural-absolute, integer norm. -/ +theorem integerNorm_natAbs_pos + {K : Type*} [Field K] [NumberField K] {x : 𝓞 K} (hx : x ≠ 0) : + 0 < (Algebra.norm ℤ x).natAbs := by + rw [Int.natAbs_pos] + exact Algebra.norm_ne_zero_iff.mpr hx + +/-- If an algebraic integer lies in an ideal above the rational ideal `(p)`, then `p` divides its +integer norm. Primality is not needed for this algebraic implication; it is needed when the ideal +above `p` is constructed. -/ +theorem prime_dvd_integerNorm_of_mem_idealAbove + {K : Type*} [Field K] [NumberField K] + (P : Ideal (𝓞 K)) (p : ℕ) (x : 𝓞 K) + (hP : P.under ℤ = Ideal.span {(p : ℤ)}) (hx : x ∈ P) : + (p : ℤ) ∣ Algebra.norm ℤ x := by + have h_under : p ∣ Ideal.absNorm P := by + have h := Int.absNorm_under_dvd_absNorm P + rw [hP, Ideal.absNorm_span_singleton] at h + simpa using h + exact (Int.natCast_dvd_natCast.mpr h_under).trans (Ideal.absNorm_dvd_norm_of_mem hx) + +/-- Quotient-map form of `prime_dvd_integerNorm_of_mem_idealAbove`, matching the reduction step in +the paper: reduction of `x` to zero modulo a prime above `p` forces `p ∣ N(x)`. -/ +theorem prime_dvd_integerNorm_of_quotient_eq_zero + {K : Type*} [Field K] [NumberField K] + (P : Ideal (𝓞 K)) (p : ℕ) (x : 𝓞 K) + (hP : P.under ℤ = Ideal.span {(p : ℤ)}) + (hx : Ideal.Quotient.mk P x = 0) : + (p : ℤ) ∣ Algebra.norm ℤ x := by + apply prime_dvd_integerNorm_of_mem_idealAbove P p x hP + exact Ideal.Quotient.eq_zero_iff_mem.mp hx + +/-- If a nonzero algebraic integer reduces to zero modulo an ideal above `(p)`, then `p` is at +most the natural absolute value of its integer norm. -/ +theorem modulus_le_integerNorm_natAbs_of_quotient_eq_zero + {K : Type*} [Field K] [NumberField K] + (P : Ideal (𝓞 K)) (p : ℕ) (x : 𝓞 K) + (hP : P.under ℤ = Ideal.span {(p : ℤ)}) + (hx : Ideal.Quotient.mk P x = 0) (hxne : x ≠ 0) : + p ≤ (Algebra.norm ℤ x).natAbs := by + apply Nat.le_of_dvd (integerNorm_natAbs_pos hxne) + change (p : ℤ).natAbs ∣ (Algebra.norm ℤ x).natAbs + rw [Int.natAbs_dvd_natAbs] + simpa using prime_dvd_integerNorm_of_quotient_eq_zero P p x hP hx + +/-- Reciprocal trace preserves integrality when both the eigenvalue and its inverse are integral. -/ +theorem isIntegral_cyclotomicTrace + {K : Type*} [Field K] {z : K} + (hz : IsIntegral ℤ z) (hzinv : IsIntegral ℤ z⁻¹) : + IsIntegral ℤ (cyclotomicTrace z) := by + exact hz.add hzinv + +/-- The symmetric defect is integral when the three reciprocal traces are integral. -/ +theorem isIntegral_cyclotomicDefect + {K : Type*} [Field K] {z₁ z₂ z₃ : K} + (hz₁ : IsIntegral ℤ z₁) (hz₁inv : IsIntegral ℤ z₁⁻¹) + (hz₂ : IsIntegral ℤ z₂) (hz₂inv : IsIntegral ℤ z₂⁻¹) + (hz₃ : IsIntegral ℤ z₃) (hz₃inv : IsIntegral ℤ z₃⁻¹) : + IsIntegral ℤ (cyclotomicDefect z₁ z₂ z₃) := by + have h₁ := isIntegral_cyclotomicTrace hz₁ hz₁inv + have h₂ := isIntegral_cyclotomicTrace hz₂ hz₂inv + have h₃ := isIntegral_cyclotomicTrace hz₃ hz₃inv + exact ((h₁.pow 2).add (h₂.pow 2) |>.add (h₃.pow 2)).sub ((h₁.mul h₂).mul h₃) + +/-- The cyclotomic defect of three primitive roots of positive orders is an algebraic integer. -/ +theorem isIntegral_cyclotomicDefect_of_primitiveRoots + {K : Type*} [Field K] {z₁ z₂ z₃ : K} {l₁ l₂ l₃ : ℕ} + (hz₁ : IsPrimitiveRoot z₁ l₁) (hl₁ : 0 < l₁) + (hz₂ : IsPrimitiveRoot z₂ l₂) (hl₂ : 0 < l₂) + (hz₃ : IsPrimitiveRoot z₃ l₃) (hl₃ : 0 < l₃) : + IsIntegral ℤ (cyclotomicDefect z₁ z₂ z₃) := by + exact BGS.Markoff.isIntegral_cyclotomicDefect + (hz₁.isIntegral hl₁) (hz₁.inv.isIntegral hl₁) + (hz₂.isIntegral hl₂) (hz₂.inv.isIntegral hl₂) + (hz₃.isIntegral hl₃) (hz₃.inv.isIntegral hl₃) + +/-- The exact archimedean norm conclusion needed in the opening: the integer norm of a +cyclotomic defect is bounded by `20 ^ φ(n)`. -/ +theorem cyclotomicDefect_integerNorm_natAbs_le_twenty_pow_totient + {K : Type*} [Field K] [NumberField K] + {n l₁ l₂ l₃ : ℕ} [NeZero n] [IsCyclotomicExtension {n} ℚ K] + {z₁ z₂ z₃ : K} + (hz₁ : IsPrimitiveRoot z₁ l₁) (hl₁ : 0 < l₁) + (hz₂ : IsPrimitiveRoot z₂ l₂) (hl₂ : 0 < l₂) + (hz₃ : IsPrimitiveRoot z₃ l₃) (hl₃ : 0 < l₃) : + let η : 𝓞 K := ⟨cyclotomicDefect z₁ z₂ z₃, + isIntegral_cyclotomicDefect_of_primitiveRoots hz₁ hl₁ hz₂ hl₂ hz₃ hl₃⟩ + (Algebra.norm ℤ η).natAbs ≤ 20 ^ n.totient := by + dsimp only + rw [← IsCyclotomicExtension.Rat.finrank n K] + apply integerNorm_natAbs_le_pow_of_embeddings + intro σ + simpa [cyclotomicDefect, cyclotomicTrace] using + norm_cyclotomicDefect_le_twenty + ((hz₁.map_of_injective σ.injective).norm'_eq_one hl₁.ne') + ((hz₂.map_of_injective σ.injective).norm'_eq_one hl₂.ne') + ((hz₃.map_of_injective σ.injective).norm'_eq_one hl₃.ne') + +/-- A nonzero cyclotomic defect has positive natural absolute integer norm. -/ +theorem cyclotomicDefect_integerNorm_natAbs_pos + {K : Type*} [Field K] [NumberField K] + {z₁ z₂ z₃ : K} {l₁ l₂ l₃ : ℕ} + (hz₁ : IsPrimitiveRoot z₁ l₁) (hl₁ : 0 < l₁) + (hz₂ : IsPrimitiveRoot z₂ l₂) (hl₂ : 0 < l₂) + (hz₃ : IsPrimitiveRoot z₃ l₃) (hl₃ : 0 < l₃) + (hη : cyclotomicDefect z₁ z₂ z₃ ≠ 0) : + let η : 𝓞 K := ⟨cyclotomicDefect z₁ z₂ z₃, + isIntegral_cyclotomicDefect_of_primitiveRoots hz₁ hl₁ hz₂ hl₂ hz₃ hl₃⟩ + 0 < (Algebra.norm ℤ η).natAbs := by + dsimp only + apply integerNorm_natAbs_pos + intro hzero + apply hη + exact congrArg (fun x : 𝓞 K ↦ (x : K)) hzero + +/-- The completed norm-and-reduction implication: if the nonzero cyclotomic defect reduces to zero +at an ideal above `(p)`, then `p ≤ 20 ^ φ(n)`. Constructing the compatible reduction data is the +remaining opening problem, not an assumption hidden in this theorem. -/ +theorem modulus_le_twenty_pow_totient_of_cyclotomicDefect_reduction + {K : Type*} [Field K] [NumberField K] + {n l₁ l₂ l₃ : ℕ} [NeZero n] [IsCyclotomicExtension {n} ℚ K] + {z₁ z₂ z₃ : K} + (hz₁ : IsPrimitiveRoot z₁ l₁) (hl₁ : 0 < l₁) + (hz₂ : IsPrimitiveRoot z₂ l₂) (hl₂ : 0 < l₂) + (hz₃ : IsPrimitiveRoot z₃ l₃) (hl₃ : 0 < l₃) + (P : Ideal (𝓞 K)) (p : ℕ) + (hP : P.under ℤ = Ideal.span {(p : ℤ)}) + (hη : cyclotomicDefect z₁ z₂ z₃ ≠ 0) + (hred : let η : 𝓞 K := ⟨cyclotomicDefect z₁ z₂ z₃, + isIntegral_cyclotomicDefect_of_primitiveRoots hz₁ hl₁ hz₂ hl₂ hz₃ hl₃⟩ + Ideal.Quotient.mk P η = 0) : + p ≤ 20 ^ n.totient := by + let η : 𝓞 K := ⟨cyclotomicDefect z₁ z₂ z₃, + isIntegral_cyclotomicDefect_of_primitiveRoots hz₁ hl₁ hz₂ hl₂ hz₃ hl₃⟩ + have hηne : η ≠ 0 := by + intro hzero + apply hη + exact congrArg (fun x : 𝓞 K ↦ (x : K)) hzero + have hp_le : p ≤ (Algebra.norm ℤ η).natAbs := + modulus_le_integerNorm_natAbs_of_quotient_eq_zero P p η hP (by simpa [η] using hred) hηne + exact hp_le.trans <| by + simpa [η] using + cyclotomicDefect_integerNorm_natAbs_le_twenty_pow_totient + hz₁ hl₁ hz₂ hl₂ hz₃ hl₃ + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Opening/CyclotomicReduction.lean b/LeanPool/MarkoffModP/BGS/Markoff/Opening/CyclotomicReduction.lean new file mode 100644 index 0000000000..86c7b9217d --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Opening/CyclotomicReduction.lean @@ -0,0 +1,222 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Opening.CompatibleRoots +public import LeanPool.MarkoffModP.BGS.Markoff.Opening.CyclotomicNorm +public import Mathlib.FieldTheory.IsAlgClosed.AlgebraicClosure +public import Mathlib.NumberTheory.NumberField.Cyclotomic.Basic +public import Mathlib.RingTheory.Polynomial.Cyclotomic.Roots + +/-! +# A compatible prime and reduction for the cyclotomic opening + +For `p ∤ n`, a prescribed primitive `n`-th root in an algebraic closure of `ZMod p` +determines a homomorphism from the ring of integers of `ℚ(ζₙ)`. Its kernel is a prime above +`(p)`, and the induced quotient map sends all powers of the characteristic-zero generator to the +corresponding powers of the prescribed finite-characteristic root. +-/ + +@[expose] public section + +open scoped NumberField +open Polynomial + +namespace BGS.Markoff + +/-- The canonical cyclotomic number field used for a common order `n`. -/ +abbrev OpeningCyclotomicField (n : ℕ) := CyclotomicField n ℚ + +/-- The ring of integers of the canonical cyclotomic number field. -/ +abbrev OpeningCyclotomicIntegers (n : ℕ) := + NumberField.RingOfIntegers (OpeningCyclotomicField n) + +/-- The algebraic closure in which the prescribed characteristic-`p` roots live. -/ +abbrev OpeningResidueClosure (p : ℕ) [Fact p.Prime] := AlgebraicClosure (ZMod p) + +private theorem neZero_ratCast (n : ℕ) [NeZero n] : (n : ℚ) ≠ 0 := by + exact_mod_cast (NeZero.ne n) + +/-- Coprimality with the characteristic makes `n` nonzero in the chosen residue closure. -/ +theorem residueClosure_natCast_ne_zero_of_coprime + (p n : ℕ) [Fact p.Prime] (hcoprime : Nat.Coprime p n) : + (n : OpeningResidueClosure p) ≠ 0 := by + have hnmod : (n : ZMod p) ≠ 0 := by + rw [ne_eq, ZMod.natCast_eq_zero_iff] + intro hpn + have hdiv : p ∣ Nat.gcd p n := Nat.dvd_gcd (dvd_refl p) hpn + rw [hcoprime.gcd_eq_one] at hdiv + exact (Fact.out : p.Prime).not_dvd_one hdiv + change algebraMap (ZMod p) (OpeningResidueClosure p) (n : ZMod p) ≠ 0 + exact (map_ne_zero_iff _ (algebraMap (ZMod p) (OpeningResidueClosure p)).injective).2 hnmod + +/-- Three `n`-th roots in the residue closure are powers of one primitive `n`-th root. The +coprimality hypothesis supplies the nonvanishing of `n` that was previously obtained from +characteristic zero. -/ +theorem exists_residue_common_primitiveRoot_powers + (p n : ℕ) [Fact p.Prime] [NeZero n] (hcoprime : Nat.Coprime p n) + (w₁ w₂ w₃ : OpeningResidueClosure p) + (hw₁ : w₁ ^ n = 1) (hw₂ : w₂ ^ n = 1) (hw₃ : w₃ ^ n = 1) : + ∃ ω : OpeningResidueClosure p, ∃ a₁ a₂ a₃ : ℕ, + IsPrimitiveRoot ω n ∧ a₁ < n ∧ a₂ < n ∧ a₃ < n ∧ + ω ^ a₁ = w₁ ∧ ω ^ a₂ = w₂ ∧ ω ^ a₃ = w₃ := by + let : NeZero (n : OpeningResidueClosure p) := + ⟨residueClosure_natCast_ne_zero_of_coprime p n hcoprime⟩ + obtain ⟨ω, hω⟩ := HasEnoughRootsOfUnity.exists_primitiveRoot (OpeningResidueClosure p) n + obtain ⟨a₁, ha₁lt, ha₁⟩ := hω.eq_pow_of_pow_eq_one hw₁ + obtain ⟨a₂, ha₂lt, ha₂⟩ := hω.eq_pow_of_pow_eq_one hw₂ + obtain ⟨a₃, ha₃lt, ha₃⟩ := hω.eq_pow_of_pow_eq_one hw₃ + exact ⟨ω, a₁, a₂, a₃, hω, ha₁lt, ha₂lt, ha₃lt, ha₁, ha₂, ha₃⟩ + +/-- The canonical primitive `n`-th root in the chosen characteristic-zero cyclotomic field. -/ +noncomputable def openingCyclotomicRoot (n : ℕ) [NeZero n] : OpeningCyclotomicField n := by + letI : NeZero (n : ℚ) := ⟨by exact neZero_ratCast n⟩ + letI : IsCyclotomicExtension {n} ℚ (OpeningCyclotomicField n) := + CyclotomicField.isCyclotomicExtension n ℚ + exact IsCyclotomicExtension.zeta n ℚ (OpeningCyclotomicField n) + +/-- The canonical characteristic-zero root has exact order `n`. -/ +theorem openingCyclotomicRoot_isPrimitive (n : ℕ) [NeZero n] : + IsPrimitiveRoot (openingCyclotomicRoot n) n := by + let : NeZero (n : ℚ) := ⟨by exact neZero_ratCast n⟩ + let : IsCyclotomicExtension {n} ℚ (OpeningCyclotomicField n) := + CyclotomicField.isCyclotomicExtension n ℚ + exact IsCyclotomicExtension.zeta_spec n ℚ (OpeningCyclotomicField n) + +/-- The canonical cyclotomic root, regarded as an algebraic integer. -/ +noncomputable def openingCyclotomicIntegerRoot (n : ℕ) [NeZero n] : + OpeningCyclotomicIntegers n := + (openingCyclotomicRoot_isPrimitive n).toInteger + +/-- The integral power basis generated by the canonical cyclotomic root. -/ +noncomputable def openingCyclotomicIntegralPowerBasis (n : ℕ) [NeZero n] : + PowerBasis ℤ (OpeningCyclotomicIntegers n) := by + letI : NeZero (n : ℚ) := ⟨by exact neZero_ratCast n⟩ + letI : IsCyclotomicExtension {n} ℚ (OpeningCyclotomicField n) := + CyclotomicField.isCyclotomicExtension n ℚ + exact (openingCyclotomicRoot_isPrimitive n).integralPowerBasis + +@[simp] +theorem openingCyclotomicIntegralPowerBasis_gen (n : ℕ) [NeZero n] : + (openingCyclotomicIntegralPowerBasis n).gen = openingCyclotomicIntegerRoot n := by + let : NeZero (n : ℚ) := ⟨by exact neZero_ratCast n⟩ + let : IsCyclotomicExtension {n} ℚ (OpeningCyclotomicField n) := + CyclotomicField.isCyclotomicExtension n ℚ + exact (openingCyclotomicRoot_isPrimitive n).integralPowerBasis_gen + +private theorem primitiveRoot_isRoot_integralPowerBasis_minpoly + (p n : ℕ) [Fact p.Prime] [NeZero n] (_hcoprime : Nat.Coprime p n) + (ω : OpeningResidueClosure p) (hω : IsPrimitiveRoot ω n) : + aeval ω (minpoly ℤ (openingCyclotomicIntegralPowerBasis n).gen) = 0 := by + let : NeZero (n : OpeningResidueClosure p) := + ⟨residueClosure_natCast_ne_zero_of_coprime p n _hcoprime⟩ + have hrootCyclotomic : aeval ω (cyclotomic n ℤ) = 0 := by + rw [aeval_def, ← eval_map, map_cyclotomic] + exact hω.isRoot_cyclotomic (NeZero.pos n) + let : NeZero (n : ℚ) := ⟨by exact neZero_ratCast n⟩ + let : IsCyclotomicExtension {n} ℚ (OpeningCyclotomicField n) := + CyclotomicField.isCyclotomicExtension n ℚ + rw [openingCyclotomicIntegralPowerBasis_gen] + rw [← NumberField.RingOfIntegers.minpoly_coe] + change aeval ω (minpoly ℤ (openingCyclotomicRoot n)) = 0 + erw [← cyclotomic_eq_minpoly (openingCyclotomicRoot_isPrimitive n) (NeZero.pos n)] + exact hrootCyclotomic + +/-- The compatible reduction homomorphism determined by the prescribed primitive root `ω`. -/ +noncomputable def openingCyclotomicReduction + (p n : ℕ) [Fact p.Prime] [NeZero n] (hcoprime : Nat.Coprime p n) + (ω : OpeningResidueClosure p) (hω : IsPrimitiveRoot ω n) : + OpeningCyclotomicIntegers n →ₐ[ℤ] OpeningResidueClosure p := + (openingCyclotomicIntegralPowerBasis n).lift ω + (by exact primitiveRoot_isRoot_integralPowerBasis_minpoly p n hcoprime ω hω) + +/-- The compatible reduction sends the characteristic-zero generator to the prescribed root. -/ +@[simp] +theorem openingCyclotomicReduction_integerRoot + (p n : ℕ) [Fact p.Prime] [NeZero n] (hcoprime : Nat.Coprime p n) + (ω : OpeningResidueClosure p) (hω : IsPrimitiveRoot ω n) : + openingCyclotomicReduction p n hcoprime ω hω (openingCyclotomicIntegerRoot n) = ω := by + rw [← openingCyclotomicIntegralPowerBasis_gen n] + exact PowerBasis.lift_gen _ _ _ + +/-- The prime ideal of the cyclotomic integers selected by the prescribed residue root. -/ +noncomputable def openingCyclotomicPrime + (p n : ℕ) [Fact p.Prime] [NeZero n] (hcoprime : Nat.Coprime p n) + (ω : OpeningResidueClosure p) (hω : IsPrimitiveRoot ω n) : + Ideal (OpeningCyclotomicIntegers n) := + RingHom.ker (openingCyclotomicReduction p n hcoprime ω hω).toRingHom + +/-- The selected kernel is prime because the residue closure is a field. -/ +theorem openingCyclotomicPrime_isPrime + (p n : ℕ) [Fact p.Prime] [NeZero n] (hcoprime : Nat.Coprime p n) + (ω : OpeningResidueClosure p) (hω : IsPrimitiveRoot ω n) : + (openingCyclotomicPrime p n hcoprime ω hω).IsPrime := + RingHom.ker_isPrime _ + +/-- The selected prime lies above the rational prime `(p)`. -/ +theorem openingCyclotomicPrime_under + (p n : ℕ) [Fact p.Prime] [NeZero n] (hcoprime : Nat.Coprime p n) + (ω : OpeningResidueClosure p) (hω : IsPrimitiveRoot ω n) : + (openingCyclotomicPrime p n hcoprime ω hω).under ℤ = + Ideal.span {(p : ℤ)} := by + unfold openingCyclotomicPrime Ideal.under + rw [RingHom.comap_ker] + have hcomp : + (openingCyclotomicReduction p n hcoprime ω hω).toRingHom.comp + (algebraMap ℤ (OpeningCyclotomicIntegers n)) = + algebraMap ℤ (OpeningResidueClosure p) := by + ext z + exact (openingCyclotomicReduction p n hcoprime ω hω).commutes z + rw [hcomp] + exact CharP.ker_intAlgebraMap_eq_span p + +/-- The quotient by the compatible prime embeds in the chosen residue closure. -/ +noncomputable def openingCyclotomicQuotientReduction + (p n : ℕ) [Fact p.Prime] [NeZero n] (hcoprime : Nat.Coprime p n) + (ω : OpeningResidueClosure p) (hω : IsPrimitiveRoot ω n) : + (OpeningCyclotomicIntegers n ⧸ openingCyclotomicPrime p n hcoprime ω hω) →+* + OpeningResidueClosure p := + (openingCyclotomicReduction p n hcoprime ω hω).toRingHom.kerLift + +/-- The quotient reduction is injective: its source is exactly the quotient by the kernel. -/ +theorem openingCyclotomicQuotientReduction_injective + (p n : ℕ) [Fact p.Prime] [NeZero n] (hcoprime : Nat.Coprime p n) + (ω : OpeningResidueClosure p) (hω : IsPrimitiveRoot ω n) : + Function.Injective (openingCyclotomicQuotientReduction p n hcoprime ω hω) := by + unfold openingCyclotomicQuotientReduction openingCyclotomicPrime + exact RingHom.kerLift_injective _ + +/-- The quotient reduction sends every power of the integral generator to the matching power of +the prescribed residue root. -/ +theorem openingCyclotomicQuotientReduction_integerRoot_pow + (p n a : ℕ) [Fact p.Prime] [NeZero n] (hcoprime : Nat.Coprime p n) + (ω : OpeningResidueClosure p) (hω : IsPrimitiveRoot ω n) : + openingCyclotomicQuotientReduction p n hcoprime ω hω + (Ideal.Quotient.mk (openingCyclotomicPrime p n hcoprime ω hω) + (openingCyclotomicIntegerRoot n ^ a)) = + ω ^ a := by + unfold openingCyclotomicQuotientReduction openingCyclotomicPrime + rw [RingHom.kerLift_mk, map_pow] + exact congrArg (fun z : OpeningResidueClosure p ↦ z ^ a) + (openingCyclotomicReduction_integerRoot p n hcoprime ω hω) + +/-- One chosen prime therefore realizes three prescribed powers simultaneously. -/ +theorem openingCyclotomicQuotientReduction_three_powers + (p n a₁ a₂ a₃ : ℕ) [Fact p.Prime] [NeZero n] + (hcoprime : Nat.Coprime p n) + (ω : OpeningResidueClosure p) (hω : IsPrimitiveRoot ω n) : + let reduce := openingCyclotomicQuotientReduction p n hcoprime ω hω + let quotient := Ideal.Quotient.mk (openingCyclotomicPrime p n hcoprime ω hω) + reduce (quotient (openingCyclotomicIntegerRoot n ^ a₁)) = ω ^ a₁ ∧ + reduce (quotient (openingCyclotomicIntegerRoot n ^ a₂)) = ω ^ a₂ ∧ + reduce (quotient (openingCyclotomicIntegerRoot n ^ a₃)) = ω ^ a₃ := by + dsimp only + exact ⟨openingCyclotomicQuotientReduction_integerRoot_pow p n a₁ hcoprime ω hω, + openingCyclotomicQuotientReduction_integerRoot_pow p n a₂ hcoprime ω hω, + openingCyclotomicQuotientReduction_integerRoot_pow p n a₃ hcoprime ω hω⟩ + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Opening/EveryOrbitLarge.lean b/LeanPool/MarkoffModP/BGS/Markoff/Opening/EveryOrbitLarge.lean new file mode 100644 index 0000000000..62d56debd6 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Opening/EveryOrbitLarge.lean @@ -0,0 +1,148 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Opening.OrbitCardBound +public import LeanPool.MarkoffModP.BGS.Markoff.Core.Statements + +/-! +# The logarithmic lower-bound half of Theorem 1 + +The opening proves the exact inequality `p ≤ 20 ^ m ^ 3` for every punctured orbit of cardinality +`m`. This file performs the analytic conversion that the paper calls immediate and packages it +with the quantifiers of `EveryOrbitLargeAt` and `TheoremOneStatement`. +-/ + +@[expose] public section + +namespace BGS.Markoff + +noncomputable section + +/-- Forgetting the proof that a point is nonzero maps its punctured orbit onto its orbit in the +full Markoff surface. -/ +theorem subtypeVal_image_puncturedGammaOrbit + {R : Type*} [CommRing R] (x : PuncturedMarkoffSurface R) : + Subtype.val '' puncturedGammaOrbit x = gammaOrbit x.1 := by + ext y + constructor + · rintro ⟨z, hz, rfl⟩ + change ∃ g : Gamma R, g • x.1 = z.1 + change ∃ g : Gamma R, g • x = z at hz + obtain ⟨g, rfl⟩ := hz + exact ⟨g, rfl⟩ + · intro hy + change ∃ g : Gamma R, g • x.1 = y at hy + obtain ⟨g, hgy⟩ := hy + refine ⟨g • x, ?_, ?_⟩ + · change ∃ h : Gamma R, h • x = g • x + exact ⟨g, rfl⟩ + · exact hgy + +/-- Puncturing does not change the cardinality of a nonzero Gamma orbit. -/ +theorem puncturedGammaOrbit_ncard_eq_gammaOrbit_ncard + {R : Type*} [CommRing R] (x : PuncturedMarkoffSurface R) : + (puncturedGammaOrbit x).ncard = (gammaOrbit x.1).ncard := by + rw [← subtypeVal_image_puncturedGammaOrbit x] + exact (Set.ncard_image_of_injective _ Subtype.val_injective).symm + +/-- Punctured-orbit form of the exact opening inequality. -/ +theorem prime_le_twenty_pow_puncturedGammaOrbit_ncard_cube + (p : ℕ) [Fact p.Prime] (hpTwo : p ≠ 2) (hpThree : p ≠ 3) + (x : PuncturedMarkoffSurface (ZMod p)) : + p ≤ 20 ^ (puncturedGammaOrbit x).ncard ^ 3 := by + have hxne : x.1.1 ≠ origin := by + intro hx + apply x.2 + apply Subtype.ext + exact hx + have h := prime_le_twenty_pow_gammaOrbit_ncard_cube p hpTwo hpThree x.1 hxne + rwa [puncturedGammaOrbit_ncard_eq_gammaOrbit_ncard] + +/-- The exact exponential opening bound implies a uniform cube-root logarithmic lower bound. +The deliberately coarse constant `1 / 3` avoids introducing an artificial transcendental +constant into Theorem 1. -/ +theorem one_third_mul_log_rpow_le_of_prime_le_twenty_pow_cube + (p orbitCard : ℕ) (hp : p.Prime) + (hbound : p ≤ 20 ^ orbitCard ^ 3) : + (1 / 3 : ℝ) * Real.rpow (Real.log p) (1 / 3 : ℝ) ≤ orbitCard := by + have hpOne : 1 ≤ p := hp.one_le + have hpRealPos : (0 : ℝ) < p := by exact_mod_cast hp.pos + have hlogNonnegative : 0 ≤ Real.log (p : ℝ) := Real.log_nonneg (by exact_mod_cast hpOne) + have hboundReal : (p : ℝ) ≤ (20 : ℝ) ^ (orbitCard ^ 3) := by + exact_mod_cast hbound + have hlogBound : + Real.log (p : ℝ) ≤ (orbitCard ^ 3 : ℕ) * Real.log (20 : ℝ) := by + calc + Real.log (p : ℝ) ≤ Real.log ((20 : ℝ) ^ (orbitCard ^ 3)) := + Real.log_le_log hpRealPos hboundReal + _ = (orbitCard ^ 3 : ℕ) * Real.log (20 : ℝ) := by + rw [Real.log_pow] + have hlogTwenty : Real.log (20 : ℝ) ≤ 27 := by + calc + Real.log (20 : ℝ) ≤ 20 - 1 := Real.log_le_sub_one_of_pos (by norm_num) + _ ≤ 27 := by norm_num + have hlogBoundCoarse : + Real.log (p : ℝ) ≤ 27 * (orbitCard : ℝ) ^ 3 := by + calc + Real.log (p : ℝ) ≤ (orbitCard ^ 3 : ℕ) * Real.log (20 : ℝ) := hlogBound + _ ≤ (orbitCard ^ 3 : ℕ) * 27 := by + gcongr + _ = 27 * (orbitCard : ℝ) ^ 3 := by + norm_num [mul_comm] + have hcuberootNonnegative : + 0 ≤ Real.rpow (Real.log (p : ℝ)) (1 / 3 : ℝ) := + Real.rpow_nonneg hlogNonnegative _ + have hcuberootCube : + (Real.rpow (Real.log (p : ℝ)) (1 / 3 : ℝ)) ^ 3 = Real.log (p : ℝ) := by + calc + (Real.rpow (Real.log (p : ℝ)) (1 / 3 : ℝ)) ^ 3 = + Real.rpow (Real.log (p : ℝ)) ((1 / 3 : ℝ) * (3 : ℕ)) := + (Real.rpow_mul_natCast hlogNonnegative (1 / 3 : ℝ) 3).symm + _ = Real.log (p : ℝ) := by norm_num + have hleftNonnegative : + 0 ≤ (1 / 3 : ℝ) * Real.rpow (Real.log (p : ℝ)) (1 / 3 : ℝ) := by + positivity + have horbitNonnegative : (0 : ℝ) ≤ orbitCard := by positivity + apply (pow_le_pow_iff_left₀ hleftNonnegative horbitNonnegative (by norm_num : 3 ≠ 0)).mp + rw [mul_pow, hcuberootCube] + norm_num + nlinarith + +/-- Every punctured orbit over every prime `p ≥ 5` satisfies the lower bound in Theorem 1 with +the absolute constant `1 / 3`. -/ +theorem everyOrbitLargeAt_one_third + (p : ℕ) (hp : p.Prime) (hpFive : 5 ≤ p) : + EveryOrbitLargeAt p hp (1 / 3 : ℝ) := by + let : Fact p.Prime := ⟨hp⟩ + intro x + exact one_third_mul_log_rpow_le_of_prime_le_twenty_pow_cube + p (puncturedGammaOrbit x).ncard hp + (prime_le_twenty_pow_puncturedGammaOrbit_ncard_cube p (by omega) (by omega) x) + +/-- The second conjunct of `TheoremOneStatement`, including its absolute constant and threshold, +is completely formalized. -/ +theorem theoremOne_everyOrbitLarge : + ∃ c : ℝ, 0 < c ∧ + ∃ p0 : ℕ, ∀ (p : ℕ) (hp : p.Prime), p0 ≤ p → EveryOrbitLargeAt p hp c := by + refine ⟨1 / 3, by norm_num, 5, ?_⟩ + intro p hp hpFive + exact everyOrbitLargeAt_one_third p hp hpFive + +/-- With the every-orbit lower bound now proved, `TheoremOneStatement` is reduced exactly to its +giant-orbit conjunct. -/ +theorem theoremOneStatement_of_eventually_hasGiantOrbit + (hgiant : + ∀ epsilon : ℝ, 0 < epsilon → + ∃ p0 : ℕ, ∀ (p : ℕ) (hp : p.Prime), p0 ≤ p → HasGiantOrbitAt p hp epsilon) : + TheoremOneStatement := + ⟨hgiant, theoremOne_everyOrbitLarge⟩ + +end + + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Opening/FiniteOrbit.lean b/LeanPool/MarkoffModP/BGS/Markoff/Opening/FiniteOrbit.lean new file mode 100644 index 0000000000..badf34daf0 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Opening/FiniteOrbit.lean @@ -0,0 +1,138 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import Mathlib.Analysis.Complex.Polynomial.Basic +public import LeanPool.MarkoffModP.BGS.Dynamics.FiniteForwardOrbit +public import LeanPool.MarkoffModP.BGS.Markoff.Core.NormalizedOrbit +public import LeanPool.MarkoffModP.BGS.Markoff.Opening.ParabolicPeriodicity +public import LeanPool.MarkoffModP.BGS.Markoff.Opening.PeriodicSemisimple +public import LeanPool.MarkoffModP.BGS.Markoff.Opening.TorsionTraces + +/-! +# Torsion traces forced by finite Markoff orbits + +Use returns of coordinate rotations to obtain torsion traces and rule out finite complex orbits +away from the origin. +-/ + +@[expose] public section + +namespace BGS.Markoff + +universe u + +theorem normalizedRotate1Surface_injective + {R : Type u} [CommRing R] [Invertible (3 : R)] : + Function.Injective (normalizedRotate1Surface (R := R)) := by + intro x y hxy + have hx : normalizedGammaPerm R (gammaRotate1 R) x = normalizedRotate1Surface x := by + change gammaRotate1 R • x = normalizedRotate1Surface x + exact gammaRotate1_smul_normalizedSurface x + have hy : normalizedGammaPerm R (gammaRotate1 R) y = normalizedRotate1Surface y := by + change gammaRotate1 R • y = normalizedRotate1Surface y + exact gammaRotate1_smul_normalizedSurface y + apply (normalizedGammaPerm R (gammaRotate1 R)).injective + exact hx.trans (hxy.trans hy.symm) + +theorem coe_iterate_normalizedRotate1Surface + {R : Type u} [CommRing R] (x : NormalizedMarkoffSurface R) (n : ℕ) : + ((normalizedRotate1Surface^[n]) x).1 = (normalizedRotate1^[n]) x.1 := by + induction n with + | zero => rfl + | succ n ih => + rw [Function.iterate_succ_apply', Function.iterate_succ_apply'] + change normalizedRotate1 ((normalizedRotate1Surface^[n]) x).1 = + normalizedRotate1 ((normalizedRotate1^[n]) x.1) + rw [ih] + +theorem exists_positive_normalizedRotate1Surface_return_of_finite_component + {R : Type u} [CommRing R] [Invertible (3 : R)] + {x y : NormalizedMarkoffSurface R} + (hfinite : (normalizedGammaOrbit x).Finite) + (hxy : SameNormalizedComponent x y) : + ∃ n : ℕ, 0 < n ∧ (normalizedRotate1Surface^[n]) y = y := by + apply BGS.exists_positive_iterate_eq_self_of_forwardOrbit_subset + normalizedRotate1Surface_injective hfinite + rintro _ ⟨n, rfl⟩ + apply (sameNormalizedComponent_iff_mem_normalizedGammaOrbit x _).mp + exact sameNormalizedComponent_trans hxy + (sameNormalizedComponent_iterate_normalizedRotate1Surface y n) + +variable {K : Type u} [Field K] [IsAlgClosed K] [CharZero K] [Invertible (3 : K)] + +omit [CharZero K] [Invertible (3 : K)] in +private theorem exists_root_neg_one : ∃ i : K, i ^ 2 = -1 := by + exact IsAlgClosed.exists_pow_nat_eq (-1 : K) (by norm_num) + +theorem finite_component_coordinate1_has_torsion_trace + {x y : NormalizedMarkoffSurface K} + (hfinite : (normalizedGammaOrbit x).Finite) + (hxy : SameNormalizedComponent x y) : + ∃ w : Kˣ, IsOfFinOrder w ∧ y.1.u1 = splitTorusTrace w := by + obtain ⟨n, hn, hreturn⟩ := + exists_positive_normalizedRotate1Surface_return_of_finite_component hfinite hxy + have hpointReturn : (normalizedRotate1^[n]) y.1 = y.1 := by + rw [← coe_iterate_normalizedRotate1Surface] + exact congrArg Subtype.val hreturn + have hyFiber : y.1 ∈ normalizedFiber1 y.1.u1 := ⟨y.property, rfl⟩ + by_cases hsemisimple : y.1.u1 ^ 2 ≠ 4 + · exact periodic_nonparabolic_fiber_has_torsion_eigenvalue + hsemisimple hyFiber hn hpointReturn + · exfalso + obtain ⟨i, hi⟩ := exists_root_neg_one (K := K) + have hsq : y.1.u1 ^ 2 = 4 := not_ne_iff.mp hsemisimple + have hfactor : (y.1.u1 - 2) * (y.1.u1 + 2) = 0 := by + calc + (y.1.u1 - 2) * (y.1.u1 + 2) = y.1.u1 ^ 2 - 4 := by ring + _ = 0 := sub_eq_zero.mpr hsq + rcases mul_eq_zero.mp hfactor with htwo | hnegTwo + · have ht : y.1.u1 = 2 := sub_eq_zero.mp htwo + exact (iterate_normalizedRotate1_ne_self_of_mem_fiber1_two i hi + (by simpa [ht] using hyFiber) n hn) hpointReturn + · have ht : y.1.u1 = -2 := by linear_combination hnegTwo + exact (iterate_normalizedRotate1_ne_self_of_mem_fiber1_neg_two i hi + (by simpa [ht] using hyFiber) n hn) hpointReturn + +theorem finite_normalizedGammaOrbit_has_torsion_traces + (x : NormalizedMarkoffSurface K) + (hfinite : (normalizedGammaOrbit x).Finite) : + ∃ w₁ w₂ w₃ : Kˣ, + IsOfFinOrder w₁ ∧ IsOfFinOrder w₂ ∧ IsOfFinOrder w₃ ∧ + x.1.u1 = splitTorusTrace w₁ ∧ x.1.u2 = splitTorusTrace w₂ ∧ + x.1.u3 = splitTorusTrace w₃ := by + obtain ⟨w₁, hw₁, htrace₁⟩ := finite_component_coordinate1_has_torsion_trace + hfinite (sameNormalizedComponent_refl x) + obtain ⟨w₂, hw₂, htrace₂⟩ := finite_component_coordinate1_has_torsion_trace + hfinite (sameNormalizedComponent_swap12Surface x) + let x₃ := normalizedSwap12Surface (normalizedSwap23Surface x) + have hx₃ : SameNormalizedComponent x x₃ := + sameNormalizedComponent_trans (sameNormalizedComponent_swap23Surface x) + (sameNormalizedComponent_swap12Surface (normalizedSwap23Surface x)) + obtain ⟨w₃, hw₃, htrace₃⟩ := finite_component_coordinate1_has_torsion_trace + hfinite hx₃ + refine ⟨w₁, w₂, w₃, hw₁, hw₂, hw₃, htrace₁, ?_, ?_⟩ + · simpa [normalizedSwap12Surface, normalizedSwap12] using htrace₂ + · simpa [x₃, normalizedSwap12Surface, normalizedSwap23Surface, + normalizedSwap12, normalizedSwap23] using htrace₃ + +theorem complex_normalizedPoint_eq_origin_of_finite_normalizedGammaOrbit + (x : NormalizedMarkoffSurface ℂ) + (hfinite : (normalizedGammaOrbit x).Finite) : + x.1 = normalizedOrigin := by + obtain ⟨w₁, w₂, w₃, hw₁, hw₂, hw₃, h₁, h₂, h₃⟩ := + finite_normalizedGammaOrbit_has_torsion_traces x hfinite + exact complex_normalizedMarkoff_eq_origin_of_torsion_traces x.1 x.property + ⟨w₁, hw₁, h₁⟩ ⟨w₂, hw₂, h₂⟩ ⟨w₃, hw₃, h₃⟩ + +theorem complex_normalizedGammaOrbit_infinite_of_ne_origin + (x : NormalizedMarkoffSurface ℂ) (hx : x.1 ≠ normalizedOrigin) : + (normalizedGammaOrbit x).Infinite := by + intro hfinite + exact hx (complex_normalizedPoint_eq_origin_of_finite_normalizedGammaOrbit x hfinite) + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Opening/OrbitCardBound.lean b/LeanPool/MarkoffModP/BGS/Markoff/Opening/OrbitCardBound.lean new file mode 100644 index 0000000000..5e9f6883f8 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Opening/OrbitCardBound.lean @@ -0,0 +1,376 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Opening.RotationOrbitCard +public import LeanPool.MarkoffModP.BGS.Markoff.Opening.TraceOrderBound + +/-! +# Bounding the opening orders by the full Gamma orbit + +The nonzero semisimple fibers use the existing conic parametrizations. Trace zero and the two +parabolic traces are handled explicitly, since the generic parametrizations deliberately exclude +those values. +-/ + +@[expose] public section + +namespace BGS.Markoff + +private theorem two_ne_zero_zmod_of_prime_ne_two + (p : ℕ) [Fact p.Prime] (hpTwo : p ≠ 2) : (2 : ZMod p) ≠ 0 := by + intro hzero + have hpDvd : p ∣ 2 := (ZMod.natCast_eq_zero_iff 2 p).1 hzero + exact hpTwo (Nat.le_antisymm (Nat.le_of_dvd (by norm_num) hpDvd) + (Fact.out : p.Prime).two_le) + +private theorem four_le_normalizedGammaOrbit_ncard_of_firstCoordinate_zero + (p : ℕ) [Fact p.Prime] [Invertible (3 : ZMod p)] (hpTwo : p ≠ 2) + (x : NormalizedMarkoffSurface (ZMod p)) (hxzero : x.1.u1 = 0) + (hxne : x.1 ≠ normalizedOrigin) : + 4 ≤ (normalizedGammaOrbit x).ncard := by + classical + have hsurface : x.1.u2 ^ 2 + x.1.u3 ^ 2 = 0 := by + have := x.property + change normalizedPolynomial x.1 = 0 at this + rw [normalizedPolynomial, hxzero] at this + simpa using this + have h₂ : x.1.u2 ≠ 0 := by + intro hzero + rw [hzero] at hsurface + have h₃sq : x.1.u3 ^ 2 = 0 := by simpa using hsurface + have h₃ : x.1.u3 = 0 := sq_eq_zero_iff.mp h₃sq + apply hxne + ext + · simpa [normalizedOrigin] using hxzero + · simpa [normalizedOrigin] using hzero + · simpa [normalizedOrigin] using h₃ + have h₃ : x.1.u3 ≠ 0 := by + intro hzero + rw [hzero] at hsurface + have h₂sq : x.1.u2 ^ 2 = 0 := by simpa using hsurface + exact h₂ (sq_eq_zero_iff.mp h₂sq) + have h₂₃ : x.1.u2 ≠ x.1.u3 := by + intro heq + have htwo : (2 : ZMod p) ≠ 0 := two_ne_zero_zmod_of_prime_ne_two p hpTwo + have hsq : 2 * x.1.u2 ^ 2 = 0 := by + rw [← heq] at hsurface + linear_combination hsurface + have : x.1.u2 ^ 2 = 0 := (mul_eq_zero.mp hsq).resolve_left htwo + exact h₂ (sq_eq_zero_iff.mp this) + let x₁₂ := normalizedSwap12Surface x + let x₂₃ := normalizedSwap23Surface x + let x₂₃₁₂ := normalizedSwap12Surface x₂₃ + let f : Fin 4 → NormalizedMarkoffSurface (ZMod p) := ![x, x₁₂, x₂₃, x₂₃₁₂] + have hf : Function.Injective f := by + intro i j hij + fin_cases i <;> fin_cases j <;> try rfl + all_goals + exfalso + have hval := congrArg Subtype.val hij + have hfirst := congrArg NormalizedPoint.u1 hval + have hsecond := congrArg NormalizedPoint.u2 hval + have hthird := congrArg NormalizedPoint.u3 hval + simp [f, x₁₂, x₂₃, x₂₃₁₂, normalizedSwap12Surface, + normalizedSwap23Surface, normalizedSwap12, normalizedSwap23, hxzero] at hfirst hsecond hthird + first + | exact h₂ hfirst + | exact h₂ hfirst.symm + | exact h₂ hsecond + | exact h₂ hsecond.symm + | exact h₂ hthird + | exact h₂ hthird.symm + | exact h₃ hfirst + | exact h₃ hfirst.symm + | exact h₃ hsecond + | exact h₃ hsecond.symm + | exact h₃ hthird + | exact h₃ hthird.symm + | exact h₂₃ hfirst + | exact h₂₃ hfirst.symm + | exact h₂₃ hsecond + | exact h₂₃ hsecond.symm + let cycle : Finset (NormalizedMarkoffSurface (ZMod p)) := Finset.univ.image f + have hcard : cycle.card = 4 := by + change (Finset.univ.image f).card = 4 + rw [Finset.card_image_of_injective _ hf] + simp + have hsubset : (cycle : Set (NormalizedMarkoffSurface (ZMod p))) ⊆ normalizedGammaOrbit x := by + change ((↑(Finset.univ.image f) : Set _) ⊆ normalizedGammaOrbit x) + intro y hy + rw [Finset.mem_coe, Finset.mem_image] at hy + obtain ⟨i, _hi, rfl⟩ := hy + fin_cases i + · exact (sameNormalizedComponent_iff_mem_normalizedGammaOrbit x _).mp + (sameNormalizedComponent_refl x) + · exact (sameNormalizedComponent_iff_mem_normalizedGammaOrbit x _).mp + (sameNormalizedComponent_swap12Surface x) + · exact (sameNormalizedComponent_iff_mem_normalizedGammaOrbit x _).mp + (sameNormalizedComponent_swap23Surface x) + · exact (sameNormalizedComponent_iff_mem_normalizedGammaOrbit x _).mp + (sameNormalizedComponent_trans (sameNormalizedComponent_swap23Surface x) + (sameNormalizedComponent_swap12Surface (normalizedSwap23Surface x))) + rw [← hcard, ← Set.ncard_coe_finset] + exact Set.ncard_le_ncard hsubset + +private theorem two_le_normalizedGammaOrbit_ncard_of_parabolic_firstCoordinate + (p : ℕ) [Fact p.Prime] [Invertible (3 : ZMod p)] (hpTwo : p ≠ 2) + (x : NormalizedMarkoffSurface (ZMod p)) (hxparabolic : x.1.u1 ^ 2 = 4) : + 2 ≤ (normalizedGammaOrbit x).ncard := by + classical + have hrotateNe : normalizedRotate1Surface x ≠ x := by + intro hfix + have hval := congrArg Subtype.val hfix + have h₂ := congrArg NormalizedPoint.u2 hval + have h₃ := congrArg NormalizedPoint.u3 hval + change x.1.u3 = x.1.u2 at h₂ + change x.1.u1 * x.1.u3 - x.1.u2 = x.1.u3 at h₃ + have hcases : x.1.u1 = 2 ∨ x.1.u1 = -2 := by + have hfactor : (x.1.u1 - 2) * (x.1.u1 + 2) = 0 := by + calc + (x.1.u1 - 2) * (x.1.u1 + 2) = x.1.u1 ^ 2 - 4 := by ring + _ = 0 := sub_eq_zero.mpr hxparabolic + rcases mul_eq_zero.mp hfactor with h | h + · exact Or.inl (sub_eq_zero.mp h) + · exact Or.inr (eq_neg_of_add_eq_zero_left h) + have htwo : (2 : ZMod p) ≠ 0 := two_ne_zero_zmod_of_prime_ne_two p hpTwo + rcases hcases with ht | ht + · have hsurface : normalizedPolynomial x.1 = 0 := x.property + rw [normalizedPolynomial, ht, h₂] at hsurface + have hfourZero : (4 : ZMod p) = 0 := by linear_combination hsurface + have hfour : (4 : ZMod p) ≠ 0 := by + (convert pow_ne_zero 2 htwo using 1; norm_num [pow_two]) + exact hfour hfourZero + · have hy : x.1.u2 = 0 := by + rw [ht, h₂] at h₃ + have hfour : (4 : ZMod p) ≠ 0 := by + (convert pow_ne_zero 2 htwo using 1; norm_num [pow_two]) + exact (mul_eq_zero.mp (by linear_combination -h₃)).resolve_left hfour + have hsurface : normalizedPolynomial x.1 = 0 := x.property + rw [normalizedPolynomial, ht, h₂, hy] at hsurface + have hfourZero : (4 : ZMod p) = 0 := by linear_combination hsurface + have hfour : (4 : ZMod p) ≠ 0 := by + (convert pow_ne_zero 2 htwo using 1; norm_num [pow_two]) + exact hfour hfourZero + let pair : Finset (NormalizedMarkoffSurface (ZMod p)) := {x, normalizedRotate1Surface x} + have hcard : pair.card = 2 := by + change ({x, normalizedRotate1Surface x} : Finset _).card = 2 + exact Finset.card_pair hrotateNe.symm + have hsubset : (pair : Set (NormalizedMarkoffSurface (ZMod p))) ⊆ normalizedGammaOrbit x := by + change ((↑({x, normalizedRotate1Surface x} : Finset _) : Set _) ⊆ normalizedGammaOrbit x) + intro y hy + simp only [Finset.mem_coe, Finset.mem_insert, Finset.mem_singleton] at hy + rcases hy with hy | hy + · subst y + apply (sameNormalizedComponent_iff_mem_normalizedGammaOrbit x _).mp + exact sameNormalizedComponent_refl x + · subst y + apply (sameNormalizedComponent_iff_mem_normalizedGammaOrbit x _).mp + exact sameNormalizedComponent_rotate1Surface x + rw [← hcard, ← Set.ncard_coe_finset] + exact Set.ncard_le_ncard hsubset + +/-- The exact order of any residue-closure eigenvalue representing the first trace is bounded by +the full normalized Gamma orbit. Nonzero semisimple traces use the conic rotation cycles; trace +zero and parabolic traces use the explicit exceptional lower bounds above. -/ +theorem eigenvalueOrder_le_normalizedGammaOrbit_ncard + (p : ℕ) [Fact p.Prime] [Invertible (3 : ZMod p)] (hpTwo : p ≠ 2) + (x : NormalizedMarkoffSurface (ZMod p)) (hxne : x.1 ≠ normalizedOrigin) + (W : (OpeningResidueClosure p)ˣ) + (htrace : algebraMap (ZMod p) (OpeningResidueClosure p) x.1.u1 = splitTorusTrace W) : + orderOf W ≤ (normalizedGammaOrbit x).ncard := by + by_cases hparabolic : x.1.u1 ^ 2 = 4 + · have htraceSq : (splitTorusTrace W) ^ 2 = 4 := by + rw [← htrace, ← map_pow, hparabolic, map_ofNat] + have hdiffSq : + ((W : OpeningResidueClosure p) - ((W⁻¹ : (OpeningResidueClosure p)ˣ) : + OpeningResidueClosure p)) ^ 2 = 0 := by + have hmul : (W : OpeningResidueClosure p) * + ((W⁻¹ : (OpeningResidueClosure p)ˣ) : OpeningResidueClosure p) = 1 := by simp + rw [splitTorusTrace] at htraceSq + linear_combination htraceSq - 4 * hmul + have hinv : ((W⁻¹ : (OpeningResidueClosure p)ˣ) : OpeningResidueClosure p) = W := by + exact (sub_eq_zero.mp (sq_eq_zero_iff.mp hdiffSq)).symm + have hWsq : W ^ 2 = 1 := by + apply Units.ext + change (W : OpeningResidueClosure p) ^ 2 = 1 + calc + (W : OpeningResidueClosure p) ^ 2 = W * W := pow_two _ + _ = W * ((W⁻¹ : (OpeningResidueClosure p)ˣ) : OpeningResidueClosure p) := by rw [hinv] + _ = 1 := by simp + have horder : orderOf W ≤ 2 := + Nat.le_of_dvd (by norm_num) (orderOf_dvd_iff_pow_eq_one.mpr hWsq) + exact horder.trans + (two_le_normalizedGammaOrbit_ncard_of_parabolic_firstCoordinate p hpTwo x hparabolic) + · by_cases hzero : x.1.u1 = 0 + · have hsum : splitTorusTrace W = 0 := by rw [← htrace, hzero, map_zero] + have hWsq : ((W : OpeningResidueClosure p) ^ 2) = -1 := by + have hmul : (W : OpeningResidueClosure p) * + ((W⁻¹ : (OpeningResidueClosure p)ˣ) : OpeningResidueClosure p) = 1 := by simp + rw [splitTorusTrace] at hsum + calc + (W : OpeningResidueClosure p) ^ 2 = + W * (W + ((W⁻¹ : (OpeningResidueClosure p)ˣ) : OpeningResidueClosure p)) - + W * ((W⁻¹ : (OpeningResidueClosure p)ˣ) : OpeningResidueClosure p) := by ring + _ = 0 - 1 := by rw [hsum, mul_zero, hmul] + _ = -1 := by ring + have hWfour : W ^ 4 = 1 := by + apply Units.ext + change (W : OpeningResidueClosure p) ^ 4 = 1 + calc + (W : OpeningResidueClosure p) ^ 4 = ((W : OpeningResidueClosure p) ^ 2) ^ 2 := by ring + _ = (-1 : OpeningResidueClosure p) ^ 2 := by rw [hWsq] + _ = 1 := by ring + have horder : orderOf W ≤ 4 := + Nat.le_of_dvd (by norm_num) (orderOf_dvd_iff_pow_eq_one.mpr hWfour) + exact horder.trans + (four_le_normalizedGammaOrbit_ncard_of_firstCoordinate_zero p hpTwo x hzero hxne) + · have hWnonparabolic : (W : OpeningResidueClosure p) ^ 2 ≠ 1 := by + intro hW + apply hparabolic + apply (algebraMap (ZMod p) (OpeningResidueClosure p)).injective + rw [map_pow, map_ofNat, htrace] + have hinv : ((W⁻¹ : (OpeningResidueClosure p)ˣ) : OpeningResidueClosure p) = W := + Units.inv_eq_of_mul_eq_one_right (by simpa [pow_two] using hW) + rw [splitTorusTrace, hinv] + calc + ((W : OpeningResidueClosure p) + W) ^ 2 = 4 * (W : OpeningResidueClosure p) ^ 2 := by ring + _ = 4 := by rw [hW, mul_one] + have hrotation : rotationOrder x.1.u1 = orderOf W := + rotationOrder_eq_orderOf_extensionEigenvalue x.1.u1 W hWnonparabolic htrace + let xf : ↑(normalizedFiber1 x.1.u1) := ⟨x.1, x.property, rfl⟩ + have hcycle : (normalizedRotationCycle x.1.u1 x.1).card = rotationOrder x.1.u1 := by + simpa [xf] using normalizedRotationCycle_card_of_nonzero_nonparabolic + p hpTwo x.1.u1 hparabolic hzero xf + calc + orderOf W = rotationOrder x.1.u1 := hrotation.symm + _ = (normalizedRotationCycle x.1.u1 x.1).card := hcycle.symm + _ ≤ (normalizedGammaOrbit x).ncard := + normalizedRotationCycle_card_le_normalizedGammaOrbit_ncard x + +private theorem three_ne_zero_zmod_of_prime_ne_three + (p : ℕ) [Fact p.Prime] (hpThree : p ≠ 3) : (3 : ZMod p) ≠ 0 := by + intro hzero + have hpDvd : p ∣ 3 := (ZMod.natCast_eq_zero_iff 3 p).1 hzero + have hpLe : p ≤ 3 := Nat.le_of_dvd (by norm_num) hpDvd + have hpGe : 2 ≤ p := (Fact.out : p.Prime).two_le + have hpTwoOrThree : p = 2 ∨ p = 3 := by omega + rcases hpTwoOrThree with hpTwo | hpThreeEq + · subst p + norm_num at hpDvd + · exact hpThree hpThreeEq + +/-- The concrete opening exponent can be bounded by the cardinality of the full normalized Gamma +orbit. The exclusions `p ≠ 2, 3` are explicit: oddness is used by the trace classification and +`3` must be invertible for the transported normalized action. -/ +theorem prime_le_twenty_pow_normalizedGammaOrbit_ncard_cube + (p : ℕ) [Fact p.Prime] (hpTwo : p ≠ 2) (hpThree : p ≠ 3) + (x : NormalizedMarkoffSurface (ZMod p)) (hxne : x.1 ≠ normalizedOrigin) : + p ≤ 20 ^ (letI : Invertible (3 : ZMod p) := + invertibleOfNonzero (by exact three_ne_zero_zmod_of_prime_ne_three p hpThree) + normalizedGammaOrbit x).ncard ^ 3 := by + let : Invertible (3 : ZMod p) := + invertibleOfNonzero (by exact three_ne_zero_zmod_of_prime_ne_three p hpThree) + obtain ⟨W₁, W₂, W₃, htrace₁, htrace₂, htrace₃, _hfin₁, _hfin₂, _hfin₃, + _hcoprime₁, _hcoprime₂, _hcoprime₃, hpBound⟩ := + exists_exact_eigenvalue_orders_with_cyclotomic_bound p hpTwo x.1 x.property hxne + let m := (normalizedGammaOrbit x).ncard + have horder₁ : orderOf W₁ ≤ m := + eigenvalueOrder_le_normalizedGammaOrbit_ncard p hpTwo x hxne W₁ htrace₁ + let x₂ := normalizedSwap12Surface x + have hx₂ne : x₂.1 ≠ normalizedOrigin := by + intro hzero + simp [x₂, normalizedSwap12Surface, normalizedSwap12, normalizedOrigin] at hzero + apply hxne + ext + · exact hzero.2.1 + · exact hzero.1 + · exact hzero.2.2 + have horbit₂ : normalizedGammaOrbit x₂ = normalizedGammaOrbit x := by + apply MulAction.orbit_eq_iff.mpr + exact (sameNormalizedComponent_iff_mem_normalizedGammaOrbit x _).mp + (sameNormalizedComponent_swap12Surface x) + have horder₂ : orderOf W₂ ≤ m := by + have h := eigenvalueOrder_le_normalizedGammaOrbit_ncard p hpTwo x₂ hx₂ne W₂ (by + simpa [x₂, normalizedSwap12Surface, normalizedSwap12] using htrace₂) + simpa [m, horbit₂] using h + let x₃ := normalizedSwap12Surface (normalizedSwap23Surface x) + have hx₃ne : x₃.1 ≠ normalizedOrigin := by + intro hzero + simp [x₃, normalizedSwap12Surface, normalizedSwap23Surface, + normalizedSwap12, normalizedSwap23, normalizedOrigin] at hzero + apply hxne + ext + · exact hzero.2.1 + · exact hzero.2.2 + · exact hzero.1 + have hx₃component : SameNormalizedComponent x x₃ := + sameNormalizedComponent_trans (sameNormalizedComponent_swap23Surface x) + (sameNormalizedComponent_swap12Surface (normalizedSwap23Surface x)) + have horbit₃ : normalizedGammaOrbit x₃ = normalizedGammaOrbit x := by + apply MulAction.orbit_eq_iff.mpr + exact (sameNormalizedComponent_iff_mem_normalizedGammaOrbit x _).mp hx₃component + have horder₃ : orderOf W₃ ≤ m := by + have h := eigenvalueOrder_le_normalizedGammaOrbit_ncard p hpTwo x₃ hx₃ne W₃ (by + simpa [x₃, normalizedSwap12Surface, normalizedSwap23Surface, + normalizedSwap12, normalizedSwap23] using htrace₃) + simpa [m, horbit₃] using h + have hmax : max (orderOf W₁) (max (orderOf W₂) (orderOf W₃)) ≤ m := by + exact max_le horder₁ (max_le horder₂ horder₃) + exact hpBound.trans (Nat.pow_le_pow_right (by norm_num) (Nat.pow_le_pow_left hmax 3)) + +/-- Normalization carries the original Gamma orbit bijectively onto the transported normalized +Gamma orbit. -/ +theorem normalizedGammaOrbit_normalization_eq_image + {R : Type*} [Field R] [Invertible (3 : R)] (x : MarkoffSurface R) : + normalizedGammaOrbit (normalizationSurfaceEquiv R x) = + normalizationSurfaceEquiv R '' gammaOrbit x := by + ext y + constructor + · intro hy + have hcomponent : SameNormalizedComponent (normalizationSurfaceEquiv R x) y := + (sameNormalizedComponent_iff_mem_normalizedGammaOrbit _ _).2 hy + have horiginal : SameComponent x ((normalizationSurfaceEquiv R).symm y) := by + simpa [SameNormalizedComponent] using hcomponent + exact ⟨(normalizationSurfaceEquiv R).symm y, horiginal, + (normalizationSurfaceEquiv R).apply_symm_apply y⟩ + · rintro ⟨z, hz, rfl⟩ + apply (sameNormalizedComponent_iff_mem_normalizedGammaOrbit _ _).1 + have horiginal : SameComponent x z := hz + simpa [SameNormalizedComponent] using horiginal + +/-- Original and normalized Gamma orbits have the same cardinality. -/ +theorem normalizedGammaOrbit_normalization_ncard + {R : Type*} [Field R] [Invertible (3 : R)] (x : MarkoffSurface R) : + (normalizedGammaOrbit (normalizationSurfaceEquiv R x)).ncard = (gammaOrbit x).ncard := by + rw [normalizedGammaOrbit_normalization_eq_image] + exact Set.ncard_image_of_injective _ (normalizationSurfaceEquiv R).injective + +/-- Original-coordinate form of the orbit-card opening bound. -/ +theorem prime_le_twenty_pow_gammaOrbit_ncard_cube + (p : ℕ) [Fact p.Prime] (hpTwo : p ≠ 2) (hpThree : p ≠ 3) + (x : MarkoffSurface (ZMod p)) (hxne : x.1 ≠ origin) : + p ≤ 20 ^ (gammaOrbit x).ncard ^ 3 := by + let : Invertible (3 : ZMod p) := + invertibleOfNonzero (by exact three_ne_zero_zmod_of_prime_ne_three p hpThree) + let xn := normalizationSurfaceEquiv (ZMod p) x + have hxnNe : xn.1 ≠ normalizedOrigin := by + intro hzero + apply hxne + change toNormalized x.1 = normalizedOrigin at hzero + have hsurfaceOriginal : x = ⟨origin, markoffPolynomial_origin⟩ := by + apply (normalizationSurfaceEquiv (ZMod p)).injective + apply Subtype.ext + change toNormalized x.1 = toNormalized origin + simpa using hzero + exact congrArg Subtype.val hsurfaceOriginal + have hbound := prime_le_twenty_pow_normalizedGammaOrbit_ncard_cube + p hpTwo hpThree xn hxnNe + rw [normalizedGammaOrbit_normalization_ncard] at hbound + exact hbound + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Opening/OrderArithmetic.lean b/LeanPool/MarkoffModP/BGS/Markoff/Opening/OrderArithmetic.lean new file mode 100644 index 0000000000..f61e0a092f --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Opening/OrderArithmetic.lean @@ -0,0 +1,61 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import Mathlib.Data.Nat.Totient +public import Mathlib.Data.Nat.GCD.Basic + +/-! +# Arithmetic bounds for three torsion orders + +Bound the least common multiple of three orders by the cube of their maximum and transfer the +resulting modulus estimate. +-/ + +@[expose] public section + +namespace BGS.Markoff + +/-- The totient exponent is no larger than the conductor exponent. -/ +theorem twenty_pow_totient_le_twenty_pow (n : ℕ) : + 20 ^ n.totient ≤ 20 ^ n := + Nat.pow_le_pow_right (by norm_num) (Nat.totient_le n) + +/-- The least common multiple of three positive orders is bounded by their product. -/ +theorem lcm_three_le_product {l₁ l₂ l₃ : ℕ} + (hl₁ : 0 < l₁) (hl₂ : 0 < l₂) (hl₃ : 0 < l₃) : + Nat.lcm (Nat.lcm l₁ l₂) l₃ ≤ l₁ * l₂ * l₃ := by + apply Nat.le_of_dvd (mul_pos (mul_pos hl₁ hl₂) hl₃) + exact (Nat.lcm_dvd_mul (Nat.lcm l₁ l₂) l₃).trans + (Nat.mul_dvd_mul_right (Nat.lcm_dvd_mul l₁ l₂) l₃) + +/-- Three orders are bounded by the cube of their maximum. -/ +theorem product_le_max_cube (l₁ l₂ l₃ : ℕ) : + l₁ * l₂ * l₃ ≤ max (max l₁ l₂) l₃ ^ 3 := by + have h₁ : l₁ ≤ max (max l₁ l₂) l₃ := le_trans (le_max_left _ _) (le_max_left _ _) + have h₂ : l₂ ≤ max (max l₁ l₂) l₃ := le_trans (le_max_right _ _) (le_max_left _ _) + have h₃ : l₃ ≤ max (max l₁ l₂) l₃ := le_max_right _ _ + calc + l₁ * l₂ * l₃ ≤ max (max l₁ l₂) l₃ * max (max l₁ l₂) l₃ * + max (max l₁ l₂) l₃ := Nat.mul_le_mul (Nat.mul_le_mul h₁ h₂) h₃ + _ = max (max l₁ l₂) l₃ ^ 3 := by ring + +/-- The numerical conclusion of the opening norm argument in maximum-order form. -/ +theorem modulus_le_twenty_pow_max_order_cube_of_lcm_totient_bound + {p l₁ l₂ l₃ : ℕ} (hl₁ : 0 < l₁) (hl₂ : 0 < l₂) (hl₃ : 0 < l₃) + (hbound : p ≤ 20 ^ (Nat.lcm (Nat.lcm l₁ l₂) l₃).totient) : + p ≤ 20 ^ (max (max l₁ l₂) l₃ ^ 3) := by + calc + p ≤ 20 ^ (Nat.lcm (Nat.lcm l₁ l₂) l₃).totient := hbound + _ ≤ 20 ^ Nat.lcm (Nat.lcm l₁ l₂) l₃ := + twenty_pow_totient_le_twenty_pow _ + _ ≤ 20 ^ (l₁ * l₂ * l₃) := + Nat.pow_le_pow_right (by norm_num) (lcm_three_le_product hl₁ hl₂ hl₃) + _ ≤ 20 ^ (max (max l₁ l₂) l₃ ^ 3) := + Nat.pow_le_pow_right (by norm_num) (product_le_max_cube l₁ l₂ l₃) + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Opening/ParabolicPeriodicity.lean b/LeanPool/MarkoffModP/BGS/Markoff/Opening/ParabolicPeriodicity.lean new file mode 100644 index 0000000000..49d8198943 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Opening/ParabolicPeriodicity.lean @@ -0,0 +1,96 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Core.ConicParametrization + +/-! +# Parabolic fibers are aperiodic in characteristic zero + +Finite periodicity of a point does not imply finite order of the ambient rotation matrix. The +opening therefore needs a point-level argument at normalized traces `2` and `-2`. The explicit +parabolic-line translations give that argument in characteristic zero. +-/ + +@[expose] public section + +namespace BGS.Markoff + +universe u + +variable {K : Type u} [Field K] [CharZero K] + +private theorem root_neg_one_ne_zero {i : K} (hi : i ^ 2 = -1) : i ≠ 0 := by + intro hzero + subst i + norm_num at hi + +/-- No positive iterate of the trace-`2` rotation fixes a point on either parabolic line in +characteristic zero. -/ +theorem iterate_normalizedRotate1_parabolicLineAtTwo_ne_self_of_pos + (n : ℕ) (hn : 0 < n) (i t : K) (hi : i ^ 2 = -1) : + (normalizedRotate1^[n]) (parabolicLineAtTwo i t) ≠ parabolicLineAtTwo i t := by + rw [iterate_normalizedRotate1_parabolicLineAtTwo] + intro hreturn + have hparameter := congrArg NormalizedPoint.u2 hreturn + change t + (n : K) * (2 * i) = t at hparameter + have hnCast : (n : K) ≠ 0 := by exact_mod_cast hn.ne' + have htwo : (2 : K) ≠ 0 := by norm_num + exact (mul_ne_zero hnCast (mul_ne_zero htwo (root_neg_one_ne_zero hi))) <| by + linear_combination hparameter + +/-- No positive iterate of the trace-`-2` rotation fixes a point on either parabolic line in +characteristic zero. -/ +theorem iterate_normalizedRotate1_parabolicLineAtNegTwo_ne_self_of_pos + (n : ℕ) (hn : 0 < n) (i t : K) (hi : i ^ 2 = -1) : + (normalizedRotate1^[n]) (parabolicLineAtNegTwo i t) ≠ parabolicLineAtNegTwo i t := by + rcases n.even_or_odd' with ⟨k, rfl | rfl⟩ + · rw [iterate_two_mul_normalizedRotate1_parabolicLineAtNegTwo] + intro hreturn + have hparameter := congrArg NormalizedPoint.u2 hreturn + change t - (k : K) * (4 * i) = t at hparameter + have hk : 0 < k := by omega + have hkCast : (k : K) ≠ 0 := by exact_mod_cast hk.ne' + have hfour : (4 : K) ≠ 0 := by norm_num + exact (mul_ne_zero hkCast (mul_ne_zero hfour (root_neg_one_ne_zero hi))) <| by + linear_combination -hparameter + · rw [iterate_two_mul_add_one_normalizedRotate1_parabolicLineAtNegTwo] + intro hreturn + have hsecond := congrArg NormalizedPoint.u2 hreturn + have hthird := congrArg NormalizedPoint.u3 hreturn + change -(t - (k : K) * (4 * i)) + 2 * i = t at hsecond + change -(-(t - (k : K) * (4 * i)) + 2 * i) + 2 * (-i) = -t + 2 * i at hthird + rw [hsecond] at hthird + have hfour : (4 : K) ≠ 0 := by norm_num + exact (mul_ne_zero hfour (root_neg_one_ne_zero hi)) <| by + linear_combination -hthird + +/-- Every point of the normalized trace-`2` fiber is aperiodic once a square root of `-1` is +fixed. -/ +theorem iterate_normalizedRotate1_ne_self_of_mem_fiber1_two + (i : K) (hi : i ^ 2 = -1) {x : NormalizedPoint K} + (hx : x ∈ normalizedFiber1 (2 : K)) (n : ℕ) (hn : 0 < n) : + (normalizedRotate1^[n]) x ≠ x := by + rw [normalizedFiber1_two_eq_parabolic_lines i hi] at hx + rcases hx with ⟨t, rfl⟩ | ⟨t, rfl⟩ + · exact iterate_normalizedRotate1_parabolicLineAtTwo_ne_self_of_pos n hn i t hi + · exact iterate_normalizedRotate1_parabolicLineAtTwo_ne_self_of_pos n hn (-i) t <| by + rw [neg_sq, hi] + +/-- Every point of the normalized trace-`-2` fiber is aperiodic once a square root of `-1` is +fixed. -/ +theorem iterate_normalizedRotate1_ne_self_of_mem_fiber1_neg_two + (i : K) (hi : i ^ 2 = -1) {x : NormalizedPoint K} + (hx : x ∈ normalizedFiber1 (-2 : K)) (n : ℕ) (hn : 0 < n) : + (normalizedRotate1^[n]) x ≠ x := by + rw [normalizedFiber1_neg_two_eq_parabolic_lines i hi] at hx + rcases hx with ⟨t, rfl⟩ | ⟨t, rfl⟩ + · exact iterate_normalizedRotate1_parabolicLineAtNegTwo_ne_self_of_pos n hn i t hi + · exact iterate_normalizedRotate1_parabolicLineAtNegTwo_ne_self_of_pos n hn (-i) t <| by + rw [neg_sq, hi] + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Opening/PeriodicSemisimple.lean b/LeanPool/MarkoffModP/BGS/Markoff/Opening/PeriodicSemisimple.lean new file mode 100644 index 0000000000..f32a8341cc --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Opening/PeriodicSemisimple.lean @@ -0,0 +1,105 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Core.ConicParametrization +public import LeanPool.MarkoffModP.BGS.Markoff.Core.FiniteRotationEigenvalues + +/-! +# Periodic points on semisimple fibers + +This module proves the point-level implication needed in the opening. It does not infer finite +matrix order from periodicity of a single vector. Instead it uses the explicit conic +parametrization: on a nonparabolic fiber, rotation multiplies the eigen-coordinate by a chosen +matrix eigenvalue, so a positive return forces that eigenvalue to be torsion. +-/ + +@[expose] public section + +namespace BGS.Markoff + +open Polynomial + +variable {K : Type*} [Field K] [IsAlgClosed K] + +/-- Every trace parameter over an algebraically closed field is `w + w⁻¹` for a nonzero +eigenvalue `w`. -/ +theorem exists_splitTorusTrace_eq (t : K) : + ∃ w : Kˣ, t = splitTorusTrace w := by + let f : K[X] := X ^ 2 - C t * X + 1 + have hfdegree : f.degree ≠ 0 := by + have hfshape : IsMonicOfDegree f 2 := by + simpa [f] using isMonicOfDegree_sub_add_two t (1 : K) + rw [degree_eq_natDegree hfshape.monic.ne_zero, hfshape.natDegree_eq] + norm_num + obtain ⟨r, hr⟩ := IsAlgClosed.exists_root f hfdegree + have hreigen : r ^ 2 - t * r + 1 = 0 := by simpa [f] using hr + have hrne : r ≠ 0 := by + intro hrzero + simp [hrzero] at hreigen + let w : Kˣ := Units.mk0 r hrne + refine ⟨w, ?_⟩ + have hmul : t * r = r ^ 2 + 1 := by linear_combination -hreigen + change t = r + r⁻¹ + apply mul_right_cancel₀ hrne + rw [hmul] + field_simp + +omit [IsAlgClosed K] in +private theorem eigenvalue_nonparabolic + {t : K} {w : Kˣ} (htrace : t = splitTorusTrace w) (ht : t ^ 2 ≠ 4) : + (w : K) ^ 2 ≠ 1 := by + intro hw + apply ht + have hinv : ((w⁻¹ : Kˣ) : K) = (w : K) := by + apply (mul_right_cancel₀ (Units.ne_zero w)) + simpa [pow_two] using hw.symm + apply sub_eq_zero.mp + rw [htrace, splitTorusTrace_sq_sub_four, hinv, sub_self, zero_pow] + norm_num + +omit [IsAlgClosed K] in +private theorem torsion_of_trace_zero {w : Kˣ} (htrace : splitTorusTrace w = 0) : + IsOfFinOrder w := by + have hwSquare : (w : K) ^ 2 = -1 := by + have h : (w : K) + (w : K)⁻¹ = 0 := by + simpa [splitTorusTrace] using htrace + have hmul := congrArg (fun q : K => q * (w : K)) h + simp [add_mul, Units.ne_zero w] at hmul + linear_combination hmul + rw [isOfFinOrder_iff_pow_eq_one] + refine ⟨4, by norm_num, ?_⟩ + apply Units.ext + change (w : K) ^ 4 = 1 + rw [show (4 : ℕ) = 2 * 2 by norm_num, pow_mul, hwSquare] + norm_num + +/-- A positive return of a point on a nonparabolic normalized fiber produces a torsion +eigenvalue representing the fixed trace coordinate. -/ +theorem periodic_nonparabolic_fiber_has_torsion_eigenvalue + {t : K} (ht : t ^ 2 ≠ 4) {x : NormalizedPoint K} + (hx : x ∈ normalizedFiber1 t) {n : ℕ} (hn : 0 < n) + (hperiodic : (normalizedRotate1^[n]) x = x) : + ∃ w : Kˣ, IsOfFinOrder w ∧ t = splitTorusTrace w := by + obtain ⟨w, htrace⟩ := exists_splitTorusTrace_eq t + have hw := eigenvalue_nonparabolic htrace ht + by_cases htZero : t = 0 + · refine ⟨w, torsion_of_trace_zero ?_, htrace⟩ + rw [← htrace, htZero] + · let xp : ↑(normalizedFiber1 (splitTorusTrace w)) := ⟨x, by + rw [← htrace] + exact hx⟩ + let s : Kˣ := (splitFiberEquiv w hw (htrace ▸ htZero)).symm xp + have hxrepr : splitFiberPoint w s = x := by + exact congrArg Subtype.val ((splitFiberEquiv w hw (htrace ▸ htZero)).apply_symm_apply xp) + rw [← hxrepr] at hperiodic + have hpower := (iterate_normalizedRotate1_splitFiberPoint_eq_self_iff w s hw n).mp hperiodic + refine ⟨w, ?_, htrace⟩ + rw [isOfFinOrder_iff_pow_eq_one] + exact ⟨n, hn, hpower⟩ + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Opening/RotationOrbitCard.lean b/LeanPool/MarkoffModP/BGS/Markoff/Opening/RotationOrbitCard.lean new file mode 100644 index 0000000000..8a964582cd --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Opening/RotationOrbitCard.lean @@ -0,0 +1,80 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Opening.FiniteOrbit +public import LeanPool.MarkoffModP.BGS.Markoff.Core.ConicParametrization + +/-! +# Cardinality of coordinate-rotation orbits + +Embed coordinate-rotation cycles in the full normalized Markoff orbit and compare their +cardinalities. +-/ + +@[expose] public section + +namespace BGS.Markoff + +universe u + +variable {R : Type u} [Field R] [DecidableEq R] [Invertible (3 : R)] + +/-- The finite segment of normalized surface iterates cut out by the matrix rotation order. -/ +noncomputable def normalizedSurfaceRotationCycle (x : NormalizedMarkoffSurface R) : + Finset (NormalizedMarkoffSurface R) := by + classical + exact (Finset.range (rotationOrder x.1.u1)).image fun n => + (normalizedRotate1Surface^[n]) x + +/-- Every point of the normalized rotation cycle belongs to the full transported Gamma orbit. -/ +theorem normalizedSurfaceRotationCycle_subset_normalizedGammaOrbit + (x : NormalizedMarkoffSurface R) : + (normalizedSurfaceRotationCycle x : Set (NormalizedMarkoffSurface R)) ⊆ + normalizedGammaOrbit x := by + classical + intro y hy + rw [Finset.mem_coe, normalizedSurfaceRotationCycle, Finset.mem_image] at hy + obtain ⟨n, _hn, rfl⟩ := hy + exact (sameNormalizedComponent_iff_mem_normalizedGammaOrbit x _).mp + (sameNormalizedComponent_iterate_normalizedRotate1Surface x n) + +omit [Invertible (3 : R)] in +/-- Forgetting the surface proof identifies the surface cycle with the existing point cycle. -/ +theorem normalizedSurfaceRotationCycle_image_val + (x : NormalizedMarkoffSurface R) : + (normalizedSurfaceRotationCycle x).image Subtype.val = + normalizedRotationCycle x.1.u1 x.1 := by + classical + ext y + simp only [normalizedSurfaceRotationCycle, normalizedRotationCycle, Finset.mem_image, + Finset.mem_range] + constructor + · rintro ⟨z, ⟨n, hn, rfl⟩, rfl⟩ + exact ⟨n, hn, (coe_iterate_normalizedRotate1Surface x n).symm⟩ + · rintro ⟨n, hn, rfl⟩ + exact ⟨(normalizedRotate1Surface^[n]) x, ⟨n, hn, rfl⟩, + coe_iterate_normalizedRotate1Surface x n⟩ + +omit [Invertible (3 : R)] in +/-- Surface and point rotation cycles have the same cardinality. -/ +theorem normalizedSurfaceRotationCycle_card + (x : NormalizedMarkoffSurface R) : + (normalizedSurfaceRotationCycle x).card = + (normalizedRotationCycle x.1.u1 x.1).card := by + rw [← normalizedSurfaceRotationCycle_image_val x] + exact (Finset.card_image_of_injective _ Subtype.val_injective).symm + +/-- A normalized rotation cycle injects into the full Gamma orbit, so its cardinality is an +honest lower bound for the orbit cardinality. -/ +theorem normalizedRotationCycle_card_le_normalizedGammaOrbit_ncard + [Fintype R] (x : NormalizedMarkoffSurface R) : + (normalizedRotationCycle x.1.u1 x.1).card ≤ (normalizedGammaOrbit x).ncard := by + rw [← normalizedSurfaceRotationCycle_card x, ← Set.ncard_coe_finset] + exact Set.ncard_le_ncard (normalizedSurfaceRotationCycle_subset_normalizedGammaOrbit x) + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Opening/TorsionTraces.lean b/LeanPool/MarkoffModP/BGS/Markoff/Opening/TorsionTraces.lean new file mode 100644 index 0000000000..338f40ad31 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Opening/TorsionTraces.lean @@ -0,0 +1,75 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Opening.CyclotomicDefect +public import LeanPool.MarkoffModP.BGS.Markoff.Opening.PeriodicSemisimple + +/-! +# Torsion eigenvalue traces force the complex Markoff origin + +This is the characteristic-zero contradiction at the heart of the opening. Once each +coordinate of a complex normalized Markoff point is represented by a torsion eigenvalue and its +reciprocal, the unit-circle defect argument forces all three coordinates to vanish. +-/ + +@[expose] public section + +namespace BGS.Markoff + +/-- A finite-order complex unit has norm one. -/ +theorem norm_coe_eq_one_of_isOfFinOrder (w : ℂˣ) (hw : IsOfFinOrder w) : + ‖(w : ℂ)‖ = 1 := by + rw [isOfFinOrder_iff_pow_eq_one] at hw + obtain ⟨n, hn, hpower⟩ := hw + have hpowerComplex : (w : ℂ) ^ n = 1 := by + exact congrArg Units.val hpower + exact Complex.norm_eq_one_of_pow_eq_one hpowerComplex hn.ne' + +/-- A complex normalized Markoff point whose three coordinates are reciprocal traces of torsion +eigenvalues is the origin. -/ +theorem complex_normalizedMarkoff_eq_origin_of_torsion_traces + (x : NormalizedPoint ℂ) (hx : IsNormalizedMarkoff x) + (h₁ : ∃ w₁ : ℂˣ, IsOfFinOrder w₁ ∧ x.u1 = splitTorusTrace w₁) + (h₂ : ∃ w₂ : ℂˣ, IsOfFinOrder w₂ ∧ x.u2 = splitTorusTrace w₂) + (h₃ : ∃ w₃ : ℂˣ, IsOfFinOrder w₃ ∧ x.u3 = splitTorusTrace w₃) : + x = normalizedOrigin := by + obtain ⟨w₁, hw₁, hx₁⟩ := h₁ + obtain ⟨w₂, hw₂, hx₂⟩ := h₂ + obtain ⟨w₃, hw₃, hx₃⟩ := h₃ + have hn₁ := norm_coe_eq_one_of_isOfFinOrder w₁ hw₁ + have hn₂ := norm_coe_eq_one_of_isOfFinOrder w₂ hw₂ + have hn₃ := norm_coe_eq_one_of_isOfFinOrder w₃ hw₃ + have ht₁' : cyclotomicTrace (w₁ : ℂ) = x.u1 := by + rw [hx₁] + simp [cyclotomicTrace, splitTorusTrace] + have ht₂' : cyclotomicTrace (w₂ : ℂ) = x.u2 := by + rw [hx₂] + simp [cyclotomicTrace, splitTorusTrace] + have ht₃' : cyclotomicTrace (w₃ : ℂ) = x.u3 := by + rw [hx₃] + simp [cyclotomicTrace, splitTorusTrace] + have hdefect : cyclotomicDefect (w₁ : ℂ) (w₂ : ℂ) (w₃ : ℂ) = 0 := by + calc + cyclotomicDefect (w₁ : ℂ) (w₂ : ℂ) (w₃ : ℂ) = normalizedPolynomial x := by + rw [cyclotomicDefect, ht₁', ht₂', ht₃'] + rfl + _ = 0 := hx + obtain ⟨ht₁, ht₂, ht₃⟩ := + cyclotomicTrace_eq_zero_of_defect_eq_zero hn₁ hn₂ hn₃ hdefect + apply NormalizedPoint.ext + · change x.u1 = 0 + rw [← ht₁'] + exact ht₁ + · change x.u2 = 0 + rw [← ht₂'] + exact ht₂ + · change x.u3 = 0 + rw [← ht₃'] + exact ht₃ + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Opening/TraceOrderBound.lean b/LeanPool/MarkoffModP/BGS/Markoff/Opening/TraceOrderBound.lean new file mode 100644 index 0000000000..2ea255ad85 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Opening/TraceOrderBound.lean @@ -0,0 +1,229 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import Mathlib.Data.Nat.GCD.Prime +public import LeanPool.MarkoffModP.BGS.Markoff.Core.ConicParametrization +public import LeanPool.MarkoffModP.BGS.Markoff.Opening.AlgebraicClosureTransport +public import LeanPool.MarkoffModP.BGS.Markoff.Opening.CyclotomicBound +public import LeanPool.MarkoffModP.BGS.Markoff.Core.TraceClassification + +/-! +# From residue traces to the concrete cyclotomic opening bound + +This file chooses eigenvalues for arbitrary normalized traces over `ZMod p`, including the two +parabolic traces, and combines their exact orders by an lcm. +-/ + +@[expose] public section + +namespace BGS.Markoff + +private theorem prime_coprime_orderOf_splitUnit + (p : ℕ) [Fact p.Prime] (w : (ZMod p)ˣ) : + Nat.Coprime p (orderOf w) := by + apply Nat.Coprime.of_dvd_right (orderOf_dvd_card : orderOf w ∣ Fintype.card (ZMod p)ˣ) + rw [ZMod.card_units] + exact (Nat.coprime_self_sub_right (Fact.out : p.Prime).one_le).2 (Nat.coprime_one_right p) + +private theorem prime_coprime_orderOf_quadraticNormOne + (p : ℕ) [Fact p.Prime] (w : quadraticNormOneTorus p) : + Nat.Coprime p (orderOf w) := by + apply Nat.Coprime.of_dvd_right + (orderOf_dvd_card : orderOf w ∣ Fintype.card (quadraticNormOneTorus p)) + rw [Fintype.card_eq_nat_card, quadraticNormOneTorus_natCard] + rw [add_comm, Nat.coprime_add_self_right] + exact Nat.coprime_one_right p + +private theorem mapped_split_eigenvalue + (p : ℕ) [Fact p.Prime] (t : ZMod p) (w : (ZMod p)ˣ) + (htrace : splitTorusTrace w = t) : + ∃ W : (OpeningResidueClosure p)ˣ, + algebraMap (ZMod p) (OpeningResidueClosure p) t = splitTorusTrace W ∧ + IsOfFinOrder W ∧ Nat.Coprime p (orderOf W) := by + let f := algebraMap (ZMod p) (OpeningResidueClosure p) + let W : (OpeningResidueClosure p)ˣ := Units.map f.toMonoidHom w + refine ⟨W, ?_, ?_, ?_⟩ + · rw [← htrace] + change f ((w : ZMod p) + ((w⁻¹ : (ZMod p)ˣ) : ZMod p)) = + f (w : ZMod p) + f ((w⁻¹ : (ZMod p)ˣ) : ZMod p) + exact map_add f _ _ + · exact (Units.map f.toMonoidHom).isOfFinOrder (isOfFinOrder_of_finite w) + · rw [show orderOf W = orderOf w by + exact orderOf_injective (Units.map f.toMonoidHom) + (Units.map_injective f.injective) w] + exact prime_coprime_orderOf_splitUnit p w + +private theorem mapped_quadraticNormOne_eigenvalue + (p : ℕ) [Fact p.Prime] (t : ZMod p) (w : quadraticNormOneTorus p) + (htrace : quadraticNormOneTrace p w = t) : + ∃ W : (OpeningResidueClosure p)ˣ, + algebraMap (ZMod p) (OpeningResidueClosure p) t = splitTorusTrace W ∧ + IsOfFinOrder W ∧ Nat.Coprime p (orderOf W) := by + let σ : quadraticFiniteField p →ₐ[ZMod p] OpeningResidueClosure p := IsAlgClosed.lift + let W : (OpeningResidueClosure p)ˣ := + Units.map σ.toRingHom.toMonoidHom (w : (quadraticFiniteField p)ˣ) + refine ⟨W, ?_, ?_, ?_⟩ + · calc + algebraMap (ZMod p) (OpeningResidueClosure p) t = + σ (algebraMap (ZMod p) (quadraticFiniteField p) t) := (σ.commutes t).symm + _ = σ (splitTorusTrace (w : (quadraticFiniteField p)ˣ)) := by + rw [← algebraMap_quadraticNormOneTrace p w, htrace] + _ = splitTorusTrace W := by simp [W, splitTorusTrace] + · exact (Units.map σ.toRingHom.toMonoidHom).isOfFinOrder + (isOfFinOrder_of_finite (w : (quadraticFiniteField p)ˣ)) + · rw [show orderOf W = orderOf w by + calc + orderOf W = orderOf (w : (quadraticFiniteField p)ˣ) := + orderOf_injective (Units.map σ.toRingHom.toMonoidHom) + (Units.map_injective σ.injective) _ + _ = orderOf w := orderOf_injective (quadraticNormOneTorus p).subtype + Subtype.coe_injective w] + exact prime_coprime_orderOf_quadraticNormOne p w + +/-- Every normalized trace over an odd prime field has a finite-order eigenvalue in the fixed +residue closure. Parabolic traces are represented explicitly by `1` or `-1`; all other traces +use the split/norm-one classification. -/ +theorem exists_residueClosure_eigenvalue_of_trace + (p : ℕ) [Fact p.Prime] (hpTwo : p ≠ 2) (t : ZMod p) : + ∃ W : (OpeningResidueClosure p)ˣ, + algebraMap (ZMod p) (OpeningResidueClosure p) t = splitTorusTrace W ∧ + IsOfFinOrder W ∧ Nat.Coprime p (orderOf W) := by + by_cases ht : t ^ 2 = 4 + · have hfactor : (t - 2) * (t + 2) = 0 := by + calc + (t - 2) * (t + 2) = t ^ 2 - 4 := by ring + _ = 0 := sub_eq_zero.mpr ht + rcases mul_eq_zero.mp hfactor with h | h + · have htTwo : t = 2 := sub_eq_zero.mp h + exact mapped_split_eigenvalue p t 1 (by + rw [htTwo] + change (1 : ZMod p) + 1 = 2 + ring) + · have htNegTwo : t = -2 := eq_neg_of_add_eq_zero_left h + exact mapped_split_eigenvalue p t (-1) (by + rw [htNegTwo] + change (-1 : ZMod p) + -1 = -2 + ring) + · rcases exists_split_or_quadraticNormOneTrace p hpTwo t ht with + ⟨w, htrace, _⟩ | ⟨w, htrace, _⟩ + · exact mapped_split_eigenvalue p t w htrace + · exact mapped_quadraticNormOne_eigenvalue p t w htrace + +/-- Every nonorigin normalized Markoff point over an odd prime field admits three compatible +residue-closure eigenvalues. Their exact orders control the concrete cyclotomic opening bound. -/ +theorem exists_exact_eigenvalue_orders_with_cyclotomic_bound + (p : ℕ) [Fact p.Prime] (hpTwo : p ≠ 2) + (x : NormalizedPoint (ZMod p)) (hx : IsNormalizedMarkoff x) + (hxne : x ≠ normalizedOrigin) : + ∃ W₁ W₂ W₃ : (OpeningResidueClosure p)ˣ, + algebraMap (ZMod p) (OpeningResidueClosure p) x.u1 = splitTorusTrace W₁ ∧ + algebraMap (ZMod p) (OpeningResidueClosure p) x.u2 = splitTorusTrace W₂ ∧ + algebraMap (ZMod p) (OpeningResidueClosure p) x.u3 = splitTorusTrace W₃ ∧ + IsOfFinOrder W₁ ∧ IsOfFinOrder W₂ ∧ IsOfFinOrder W₃ ∧ + Nat.Coprime p (orderOf W₁) ∧ Nat.Coprime p (orderOf W₂) ∧ + Nat.Coprime p (orderOf W₃) ∧ + p ≤ 20 ^ (max (orderOf W₁) (max (orderOf W₂) (orderOf W₃))) ^ 3 := by + obtain ⟨W₁, htrace₁, hfin₁, hcoprime₁⟩ := + exists_residueClosure_eigenvalue_of_trace p hpTwo x.u1 + obtain ⟨W₂, htrace₂, hfin₂, hcoprime₂⟩ := + exists_residueClosure_eigenvalue_of_trace p hpTwo x.u2 + obtain ⟨W₃, htrace₃, hfin₃, hcoprime₃⟩ := + exists_residueClosure_eigenvalue_of_trace p hpTwo x.u3 + let l₁ := orderOf W₁ + let l₂ := orderOf W₂ + let l₃ := orderOf W₃ + let n := Nat.lcm l₁ (Nat.lcm l₂ l₃) + let m := max l₁ (max l₂ l₃) + have hl₁ : 0 < l₁ := hfin₁.orderOf_pos + have hl₂ : 0 < l₂ := hfin₂.orderOf_pos + have hl₃ : 0 < l₃ := hfin₃.orderOf_pos + have hn : 0 < n := Nat.lcm_pos hl₁ (Nat.lcm_pos hl₂ hl₃) + let : NeZero n := ⟨hn.ne'⟩ + have hcoprimeN : Nat.Coprime p n := by + apply (Fact.out : p.Prime).coprime_iff_not_dvd.2 + exact (Fact.out : p.Prime).not_dvd_lcm + ((Fact.out : p.Prime).coprime_iff_not_dvd.mp hcoprime₁) + ((Fact.out : p.Prime).not_dvd_lcm + ((Fact.out : p.Prime).coprime_iff_not_dvd.mp hcoprime₂) + ((Fact.out : p.Prime).coprime_iff_not_dvd.mp hcoprime₃)) + have hW₁pow : (W₁ : OpeningResidueClosure p) ^ n = 1 := by + simpa using congrArg Units.val + (orderOf_dvd_iff_pow_eq_one.mp (Nat.dvd_lcm_left l₁ (Nat.lcm l₂ l₃))) + have hW₂pow : (W₂ : OpeningResidueClosure p) ^ n = 1 := by + have hdvd : l₂ ∣ n := + (Nat.dvd_lcm_left l₂ l₃).trans (Nat.dvd_lcm_right l₁ (Nat.lcm l₂ l₃)) + simpa using congrArg Units.val (orderOf_dvd_iff_pow_eq_one.mp hdvd) + have hW₃pow : (W₃ : OpeningResidueClosure p) ^ n = 1 := by + have hdvd : l₃ ∣ n := + (Nat.dvd_lcm_right l₂ l₃).trans (Nat.dvd_lcm_right l₁ (Nat.lcm l₂ l₃)) + simpa using congrArg Units.val (orderOf_dvd_iff_pow_eq_one.mp hdvd) + obtain ⟨ω, a₁, a₂, a₃, hω, ha₁lt, ha₂lt, ha₃lt, ha₁, ha₂, ha₃⟩ := + exists_residue_common_primitiveRoot_powers p n hcoprimeN + (W₁ : OpeningResidueClosure p) (W₂ : OpeningResidueClosure p) + (W₃ : OpeningResidueClosure p) hW₁pow hW₂pow hW₃pow + let f := algebraMap (ZMod p) (OpeningResidueClosure p) + let xResidue : NormalizedPoint (OpeningResidueClosure p) := x.map f + have hxResidue : IsNormalizedMarkoff xResidue := by + change normalizedPolynomial (x.map f) = 0 + rw [normalizedPolynomial_map, hx, map_zero] + have hxResidueNe : xResidue ≠ normalizedOrigin := by + intro hzero + apply hxne + apply NormalizedPoint.ext + · apply f.injective + simpa [xResidue, f, NormalizedPoint.map, normalizedOrigin] using + congrArg NormalizedPoint.u1 hzero + · apply f.injective + simpa [xResidue, f, NormalizedPoint.map, normalizedOrigin] using + congrArg NormalizedPoint.u2 hzero + · apply f.injective + simpa [xResidue, f, NormalizedPoint.map, normalizedOrigin] using + congrArg NormalizedPoint.u3 hzero + have hcoord₁ : xResidue.u1 = cyclotomicTrace (ω ^ a₁) := by + calc + xResidue.u1 = f x.u1 := rfl + _ = splitTorusTrace W₁ := htrace₁ + _ = cyclotomicTrace (W₁ : OpeningResidueClosure p) := by + simp [splitTorusTrace, cyclotomicTrace] + _ = cyclotomicTrace (ω ^ a₁) := by rw [ha₁] + have hcoord₂ : xResidue.u2 = cyclotomicTrace (ω ^ a₂) := by + calc + xResidue.u2 = f x.u2 := rfl + _ = splitTorusTrace W₂ := htrace₂ + _ = cyclotomicTrace (W₂ : OpeningResidueClosure p) := by + simp [splitTorusTrace, cyclotomicTrace] + _ = cyclotomicTrace (ω ^ a₂) := by rw [ha₂] + have hcoord₃ : xResidue.u3 = cyclotomicTrace (ω ^ a₃) := by + calc + xResidue.u3 = f x.u3 := rfl + _ = splitTorusTrace W₃ := htrace₃ + _ = cyclotomicTrace (W₃ : OpeningResidueClosure p) := by + simp [splitTorusTrace, cyclotomicTrace] + _ = cyclotomicTrace (ω ^ a₃) := by rw [ha₃] + have hpCyclotomic : p ≤ 20 ^ n.totient := + modulus_le_twenty_pow_totient_of_compatible_residue_traces + p n a₁ a₂ a₃ hcoprimeN ω hω (Nat.le_of_lt ha₁lt) (Nat.le_of_lt ha₂lt) + (Nat.le_of_lt ha₃lt) xResidue hxResidue hcoord₁ hcoord₂ hcoord₃ hxResidueNe + have hn_le_m_cube : n ≤ m ^ 3 := by + have hl₁m : l₁ ≤ m := le_max_left _ _ + have hl₂m : l₂ ≤ m := (le_max_left _ _).trans (le_max_right _ _) + have hl₃m : l₃ ≤ m := (le_max_right _ _).trans (le_max_right _ _) + calc + n ≤ l₁ * Nat.lcm l₂ l₃ := Nat.lcm_le_mul hl₁ (Nat.lcm_pos hl₂ hl₃) + _ ≤ l₁ * (l₂ * l₃) := + Nat.mul_le_mul_left l₁ (Nat.lcm_le_mul hl₂ hl₃) + _ = l₁ * l₂ * l₃ := by ring + _ ≤ m * m * m := Nat.mul_le_mul (Nat.mul_le_mul hl₁m hl₂m) hl₃m + _ = m ^ 3 := by ring + have htotient : n.totient ≤ m ^ 3 := (Nat.totient_le n).trans hn_le_m_cube + have hpMax : p ≤ 20 ^ m ^ 3 := + hpCyclotomic.trans (Nat.pow_le_pow_right (by norm_num) htotient) + exact ⟨W₁, W₂, W₃, htrace₁, htrace₂, htrace₃, hfin₁, hfin₂, hfin₃, + hcoprime₁, hcoprime₂, hcoprime₃, by simpa [l₁, l₂, l₃, m] using hpMax⟩ + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/Opening/UnitCircle.lean b/LeanPool/MarkoffModP/BGS/Markoff/Opening/UnitCircle.lean new file mode 100644 index 0000000000..00e962eba1 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/Opening/UnitCircle.lean @@ -0,0 +1,77 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Core.Normalization + +/-! +# The real compactness lemma in the opening + +The published opening rules out finite characteristic-zero orbits by first placing all three +normalized trace coordinates in `[-2, 2]`. The elementary real inequality used at that point is +proved here independently of the later cyclotomic lifting argument. +-/ + +@[expose] public section + +namespace BGS.Markoff + +/-- A real normalized Markoff point whose first trace coordinate lies in `[-2, 2]` is the +origin. In particular, the published hypothesis that all three coordinates lie in this interval +is more than is needed. + +The proof uses `2|bc| ≤ b² + c²`. Since the Markoff equation makes `abc` equal to the +nonnegative sum of three squares and `|a| ≤ 2`, it follows that `a² ≤ 0`; the remaining two +squares then vanish as well. -/ +theorem real_normalizedMarkoff_eq_origin_of_firstCoordinate_mem_Icc + (x : NormalizedPoint ℝ) (hx : IsNormalizedMarkoff x) + (hfirst : x.u1 ∈ Set.Icc (-2 : ℝ) 2) : + x = normalizedOrigin := by + rcases x with ⟨a, b, c⟩ + change a ^ 2 + b ^ 2 + c ^ 2 - a * b * c = 0 at hx + have haAbs : |a| ≤ 2 := (abs_le).2 hfirst + have hsumNonnegative : 0 ≤ a ^ 2 + b ^ 2 + c ^ 2 := by positivity + have hproductEq : a * b * c = a ^ 2 + b ^ 2 + c ^ 2 := by linarith + have hproductNonnegative : 0 ≤ a * b * c := hproductEq ▸ hsumNonnegative + have habsProduct : |a * b * c| = a * b * c := abs_of_nonneg hproductNonnegative + have habsBCNonnegative : 0 ≤ |b| * |c| := mul_nonneg (abs_nonneg b) (abs_nonneg c) + have hproductBound : |a * b * c| ≤ 2 * |b| * |c| := by + rw [abs_mul, abs_mul] + nlinarith + have hbcBound : 2 * |b| * |c| ≤ b ^ 2 + c ^ 2 := by + have hsquare := sq_nonneg (|b| - |c|) + have hbAbsSquare : |b| ^ 2 = b ^ 2 := sq_abs b + have hcAbsSquare : |c| ^ 2 = c ^ 2 := sq_abs c + nlinarith + have haSquareNonpositive : a ^ 2 ≤ 0 := by + rw [habsProduct] at hproductBound + nlinarith + have ha : a = 0 := sq_eq_zero_iff.mp (le_antisymm haSquareNonpositive (sq_nonneg a)) + have hbSquareNonpositive : b ^ 2 ≤ 0 := by + rw [ha] at hx + norm_num at hx + nlinarith [sq_nonneg c] + have hb : b = 0 := sq_eq_zero_iff.mp (le_antisymm hbSquareNonpositive (sq_nonneg b)) + have hc : c = 0 := by + rw [ha, hb] at hx + norm_num at hx + exact hx + subst a + subst b + subst c + rfl + +/-- Published Proposition 16's real inequality, stated with all three interval hypotheses. -/ +theorem real_normalizedMarkoff_eq_origin_of_coordinates_mem_Icc + (x : NormalizedPoint ℝ) (hx : IsNormalizedMarkoff x) + (hfirst : x.u1 ∈ Set.Icc (-2 : ℝ) 2) + (_hsecond : x.u2 ∈ Set.Icc (-2 : ℝ) 2) + (_hthird : x.u3 ∈ Set.Icc (-2 : ℝ) 2) : + x = normalizedOrigin := + real_normalizedMarkoff_eq_origin_of_firstCoordinate_mem_Icc x hx hfirst + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/PreliminaryEndgame.lean b/LeanPool/MarkoffModP/BGS/Markoff/PreliminaryEndgame.lean new file mode 100644 index 0000000000..2330240b1d --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/PreliminaryEndgame.lean @@ -0,0 +1,157 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.ExplicitEndgame +public import LeanPool.MarkoffModP.BGS.Markoff.PreliminaryNumerics + +/-! +# Endgame wrappers for the elementary preliminary route + +The geometry and incidence estimates are the already proved explicit endgame +and cage theorems. This file supplies them with the smaller preliminary-route +numerical certificates. +-/ + +@[expose] public section + +namespace BGS.Markoff + +noncomputable section + +private theorem preliminaryCutoff_seven_le + {p : ℕ} [Fact p.Prime] + (hp : preliminaryStrongApproximationCutoff ≤ p) : 7 ≤ p := by + have hpOne : (1 : ℝ) ≤ p := by + exact_mod_cast (preliminaryCutoff_gt_one.trans_le hp).le + have hrootLe : (p : ℝ) ^ (1 / 8 : ℝ) ≤ p := by + simpa using + Real.rpow_le_self_of_one_le hpOne (by norm_num : (1 / 8 : ℝ) ≤ 1) + have hfiveRoot : (5 : ℝ) < (p : ℝ) ^ (1 / 8 : ℝ) := + preliminary_small_fixed_lt_rpow_one_div_eight hp (by norm_num) + have hfive : 5 < p := by + exact_mod_cast hfiveRoot.trans_le hrootLe + have hpSix : p ≠ 6 := by + intro hpEq + subst p + have hprime : Nat.Prime 6 := Fact.out + norm_num at hprime + omega + +/-- At the elementary preliminary cutoff, a large first-coordinate rotation +reaches a maximal split rotation. -/ +theorem exists_preliminary_sameComponent_maximalRotation_of_large_firstCoordinate + {p : ℕ} [Fact p.Prime] [Invertible (3 : ZMod p)] + (hp : preliminaryStrongApproximationCutoff ≤ p) + (x : NormalizedMarkoffSurface (ZMod p)) + (hlarge : (p : ℝ) ^ (5 / 6 : ℝ) ≤ rotationOrder x.1.u1) : + ∃ y : NormalizedMarkoffSurface (ZMod p), + SameNormalizedComponent x y ∧ rotationOrder y.1.u2 = p - 1 := by + let xf : ↑(normalizedFiber1 x.1.u1) := ⟨x.1, x.property, rfl⟩ + obtain ⟨n, hrotation⟩ := + exists_iterate_point_with_maximal_secondRotation_of_explicitInequalities + p ((by norm_num : 5 ≤ 7).trans (preliminaryCutoff_seven_le hp)) + x.1.u1 xf + (fun orbitExponent orbitOrder hmul horder ↦ + preliminary_endgamePrimitiveTrace_explicitInequality_of_card_sub_one + hp hmul horder (by norm_num)) + (fun orbitExponent orbitOrder hmul horder ↦ + preliminary_endgamePrimitiveTrace_explicitInequality_of_card_add_one + hp hmul horder (by norm_num)) + (preliminary_four_lt_rpow_five_div_six hp) hlarge + let y := (normalizedRotate1Surface^[n]) x + refine ⟨y, sameNormalizedComponent_iterate_normalizedRotate1Surface x n, ?_⟩ + rw [show y.1 = (normalizedRotate1^[n]) x.1 by + exact coe_iterate_normalizedRotate1Surface x n] + exact hrotation + +/-- First-coordinate form of the preliminary large-order-to-cage endgame. -/ +theorem exists_preliminary_sameComponent_splitCage_of_large_firstCoordinate + {p : ℕ} [Fact p.Prime] [Invertible (3 : ZMod p)] + (hp : preliminaryStrongApproximationCutoff ≤ p) + (x : NormalizedMarkoffSurface (ZMod p)) + (hlarge : (p : ℝ) ^ (5 / 6 : ℝ) ≤ rotationOrder x.1.u1) : + ∃ y : NormalizedMarkoffSurface (ZMod p), + SameNormalizedComponent x y ∧ IsInSplitCage p y := by + obtain ⟨y, hxy, hyOrder⟩ := + exists_preliminary_sameComponent_maximalRotation_of_large_firstCoordinate + hp x hlarge + exact ⟨y, hxy, .second, hyOrder⟩ + +/-- If one coordinate rotation is large, the point reaches the split cage. -/ +theorem exists_preliminary_sameComponent_splitCage_of_some_largeCoordinate + {p : ℕ} [Fact p.Prime] [Invertible (3 : ZMod p)] + (hp : preliminaryStrongApproximationCutoff ≤ p) + (x : NormalizedMarkoffSurface (ZMod p)) + (hlarge : + (p : ℝ) ^ (5 / 6 : ℝ) ≤ rotationOrder x.1.u1 ∨ + (p : ℝ) ^ (5 / 6 : ℝ) ≤ rotationOrder x.1.u2 ∨ + (p : ℝ) ^ (5 / 6 : ℝ) ≤ rotationOrder x.1.u3) : + ∃ y : NormalizedMarkoffSurface (ZMod p), + SameNormalizedComponent x y ∧ IsInSplitCage p y := by + rcases hlarge with hfirst | hsecond | hthird + · exact + exists_preliminary_sameComponent_splitCage_of_large_firstCoordinate + hp x hfirst + · let x' := normalizedSwap12Surface x + have hx' : SameNormalizedComponent x x' := + sameNormalizedComponent_swap12Surface x + have hlarge' : + (p : ℝ) ^ (5 / 6 : ℝ) ≤ rotationOrder x'.1.u1 := by + simpa [x', normalizedSwap12, coe_normalizedSwap12Surface] using hsecond + obtain ⟨y, hy, hyOrder⟩ := + exists_preliminary_sameComponent_maximalRotation_of_large_firstCoordinate + hp x' hlarge' + exact ⟨y, sameNormalizedComponent_trans hx' hy, .second, hyOrder⟩ + · let x' := normalizedSwap12Surface (normalizedSwap23Surface x) + have hx23 : SameNormalizedComponent x (normalizedSwap23Surface x) := + sameNormalizedComponent_swap23Surface x + have hx12 : SameNormalizedComponent (normalizedSwap23Surface x) x' := + sameNormalizedComponent_swap12Surface (normalizedSwap23Surface x) + have hlarge' : + (p : ℝ) ^ (5 / 6 : ℝ) ≤ rotationOrder x'.1.u1 := by + simpa [x', normalizedSwap12, normalizedSwap23, + coe_normalizedSwap12Surface, coe_normalizedSwap23Surface] using hthird + obtain ⟨y, hy, hyOrder⟩ := + exists_preliminary_sameComponent_maximalRotation_of_large_firstCoordinate + hp x' hlarge' + exact ⟨y, sameNormalizedComponent_trans + (sameNormalizedComponent_trans hx23 hx12) hy, .second, hyOrder⟩ + +/-- The selected split cage is connected at the preliminary cutoff. -/ +theorem preliminary_splitCage_connected + {p : ℕ} [Fact p.Prime] [Invertible (3 : ZMod p)] + (hp : preliminaryStrongApproximationCutoff ≤ p) + (x y : NormalizedMarkoffSurface (ZMod p)) + (hx : IsInSplitCage p x) (hy : IsInSplitCage p y) : + SameNormalizedComponent x y := by + exact splitCage_connected_of_explicitInequality p + (preliminaryCutoff_seven_le hp) + (preliminary_cageWitness_explicitInequality hp (by norm_num)) + x y hx hy + +/-- A large-order point lies in the component of any chosen cage base point. -/ +theorem preliminary_sameNormalizedComponent_of_largeOrder_to_splitCage + {p : ℕ} [Fact p.Prime] [Invertible (3 : ZMod p)] + (hp : preliminaryStrongApproximationCutoff ≤ p) + (base x : NormalizedMarkoffSurface (ZMod p)) + (hbase : IsInSplitCage p base) + (hlarge : + (p : ℝ) ^ (5 / 6 : ℝ) ≤ rotationOrder x.1.u1 ∨ + (p : ℝ) ^ (5 / 6 : ℝ) ≤ rotationOrder x.1.u2 ∨ + (p : ℝ) ^ (5 / 6 : ℝ) ≤ rotationOrder x.1.u3) : + SameNormalizedComponent base x := by + obtain ⟨y, hxy, hy⟩ := + exists_preliminary_sameComponent_splitCage_of_some_largeCoordinate + hp x hlarge + exact sameNormalizedComponent_trans + (preliminary_splitCage_connected hp base y hbase hy) + (sameNormalizedComponent_symm hxy) + +end + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/PreliminaryNumerics.lean b/LeanPool/MarkoffModP/BGS/Markoff/PreliminaryNumerics.lean new file mode 100644 index 0000000000..fd496e69a2 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/PreliminaryNumerics.lean @@ -0,0 +1,580 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.ExplicitNumericCertificates +public import LeanPool.MarkoffModP.BGS.NumberTheory.PreliminaryDivisorBound + +/-! +# Elementary numerical certificates for the paper's preliminary route + +The published preliminary argument uses Nicolas' explicit divisor bound to +obtain the threshold `10^532`. Here we formalize the same all-divisors +Corvaja--Zannier route using a completely elementary tenth-moment estimate. +The resulting cutoff is somewhat larger, but every numerical input is checked +inside Lean. +-/ + +@[expose] public section + +namespace BGS.Markoff + +/-- The simultaneous tenth-moment constant for the divisor counts of `p - 1` +and `p + 1`. -/ +def preliminaryDivisorMomentConstant : ℕ := 2 ^ 457 + +theorem preliminaryDivisorMomentConstant_eq : + preliminaryDivisorMomentConstant = 2 ^ 457 := rfl + +theorem preliminaryDivisorMomentConstant_pos : + 0 < preliminaryDivisorMomentConstant := by + rw [preliminaryDivisorMomentConstant_eq] + positivity + +/-- Sealed data for the elementary preliminary-route cutoff. -/ +@[irreducible] def preliminaryStrongApproximationCutoffData : + {n : ℕ // n = 2 ^ 1833 * (48 ^ 3 + 1) ^ 10 + 1} := + ⟨2 ^ 1833 * (48 ^ 3 + 1) ^ 10 + 1, rfl⟩ + +/-- A fully elementary replacement for the paper's `10^532` threshold. -/ +def preliminaryStrongApproximationCutoff : ℕ := + preliminaryStrongApproximationCutoffData.1 + +theorem preliminaryStrongApproximationCutoff_eq : + preliminaryStrongApproximationCutoff = + 2 ^ 1833 * (48 ^ 3 + 1) ^ 10 + 1 := + preliminaryStrongApproximationCutoffData.2 + +theorem preliminaryCutoff_gt_one : + 1 < preliminaryStrongApproximationCutoff := by + rw [preliminaryStrongApproximationCutoff_eq] + have h : 0 < 2 ^ 1833 * (48 ^ 3 + 1) ^ 10 := + Nat.mul_pos (pow_pos (by norm_num) _) (pow_pos (by norm_num) _) + omega + +theorem preliminaryCutoff_constant_lt + {p : ℕ} (hp : preliminaryStrongApproximationCutoff ≤ p) : + 2 ^ 1833 * (48 ^ 3 + 1) ^ 10 < p := by + rw [preliminaryStrongApproximationCutoff_eq] at hp + omega + +/-- The two divisor counts needed by the preliminary route satisfy one +simultaneous tenth-moment estimate. -/ +theorem preliminary_divisor_sum_pow_ten_le + {p : ℕ} (hp : 2 ≤ p) : + ((p - 1).divisors.card + (p + 1).divisors.card) ^ 10 ≤ + preliminaryDivisorMomentConstant * p := by + have hminusNe : p - 1 ≠ 0 := by omega + have hplusNe : p + 1 ≠ 0 := by omega + have hminus := + BGS.NumberTheory.card_divisors_pow_ten_le_preliminary_constant_mul + (p - 1) hminusNe + have hplus := + BGS.NumberTheory.card_divisors_pow_ten_le_preliminary_constant_mul + (p + 1) hplusNe + calc + ((p - 1).divisors.card + (p + 1).divisors.card) ^ 10 ≤ + 2 ^ (10 - 1) * + ((p - 1).divisors.card ^ 10 + (p + 1).divisors.card ^ 10) := + add_pow_le (Nat.zero_le _) (Nat.zero_le _) 10 + _ ≤ 2 ^ 9 * + (2 ^ 447 * (p - 1) + 2 ^ 447 * (p + 1)) := by + norm_num + gcongr + _ = preliminaryDivisorMomentConstant * p := by + rw [preliminaryDivisorMomentConstant_eq] + have hsum : p - 1 + (p + 1) = 2 * p := by omega + have hpow : 2 ^ 9 * 2 ^ 447 * 2 = 2 ^ 457 := by + have h447 : 2 ^ 447 * 2 = 2 ^ 448 := by + simpa using (pow_succ 2 447).symm + calc + 2 ^ 9 * 2 ^ 447 * 2 = 2 ^ 9 * (2 ^ 447 * 2) := by ring + _ = 2 ^ 9 * 2 ^ 448 := by rw [h447] + _ = 2 ^ (9 + 448) := (pow_add 2 9 448).symm + _ = 2 ^ 457 := by norm_num + calc + 2 ^ 9 * (2 ^ 447 * (p - 1) + 2 ^ 447 * (p + 1)) = + 2 ^ 9 * 2 ^ 447 * (p - 1 + (p + 1)) := by ring + _ = 2 ^ 9 * 2 ^ 447 * (2 * p) := by rw [hsum] + _ = (2 ^ 9 * 2 ^ 447 * 2) * p := by ring + _ = 2 ^ 457 * p := by rw [hpow] + +private theorem preliminary_moment_pow_eight_le_cutoff_sq : + preliminaryDivisorMomentConstant ^ 8 ≤ + (2 ^ 1833 * (48 ^ 3 + 1) ^ 10) ^ 2 := by + rw [preliminaryDivisorMomentConstant_eq] + calc + (2 ^ 457) ^ 8 = 2 ^ 3656 := by + rw [show (3656 : ℕ) = 457 * 8 by norm_num, pow_mul] + _ ≤ 2 ^ 3666 := Nat.pow_le_pow_right (by norm_num) (by norm_num) + _ = (2 ^ 1833) ^ 2 := by + rw [show (3666 : ℕ) = 1833 * 2 by norm_num, pow_mul] + _ ≤ (2 ^ 1833 * (48 ^ 3 + 1) ^ 10) ^ 2 := by + gcongr + exact Nat.le_mul_of_pos_right _ (by positivity) + +private theorem preliminary_middle_coefficient_le_cutoff_pow_four : + 48 ^ 60 * preliminaryDivisorMomentConstant ^ 6 ≤ + (2 ^ 1833 * (48 ^ 3 + 1) ^ 10) ^ 4 := by + rw [preliminaryDivisorMomentConstant_eq] + have htwo : (2 ^ 457) ^ 6 ≤ 2 ^ 7332 := by + calc + (2 ^ 457) ^ 6 = 2 ^ 2742 := by + rw [show (2742 : ℕ) = 457 * 6 by norm_num, pow_mul] + _ ≤ 2 ^ 7332 := Nat.pow_le_pow_right (by norm_num) (by norm_num) + have hbase : 48 ^ 60 ≤ (48 ^ 3 + 1) ^ 40 := by + calc + 48 ^ 60 = (48 ^ 3) ^ 20 := by + rw [show (60 : ℕ) = 3 * 20 by norm_num, pow_mul] + _ ≤ (48 ^ 3 + 1) ^ 20 := Nat.pow_le_pow_left (by omega) _ + _ ≤ (48 ^ 3 + 1) ^ 40 := + Nat.pow_le_pow_right (by positivity) (by norm_num) + calc + 48 ^ 60 * (2 ^ 457) ^ 6 = (2 ^ 457) ^ 6 * 48 ^ 60 := by ring + _ ≤ 2 ^ 7332 * (48 ^ 3 + 1) ^ 40 := Nat.mul_le_mul htwo hbase + _ = (2 ^ 1833 * (48 ^ 3 + 1) ^ 10) ^ 4 := by + norm_num [mul_pow, ← pow_mul] + +private theorem preliminary_endgame_coefficient_le_cutoff_pow_four : + 68 ^ 30 * preliminaryDivisorMomentConstant ^ 6 ≤ + (2 ^ 1833 * (48 ^ 3 + 1) ^ 10) ^ 4 := by + rw [preliminaryDivisorMomentConstant_eq] + have htwo : (2 ^ 457) ^ 6 ≤ 2 ^ 7332 := by + calc + (2 ^ 457) ^ 6 = 2 ^ 2742 := by + rw [show (2742 : ℕ) = 457 * 6 by norm_num, pow_mul] + _ ≤ 2 ^ 7332 := Nat.pow_le_pow_right (by norm_num) (by norm_num) + have hbase : 68 ^ 30 ≤ (48 ^ 3 + 1) ^ 40 := by + calc + 68 ^ 30 ≤ (48 ^ 3 + 1) ^ 30 := + Nat.pow_le_pow_left (by norm_num) _ + _ ≤ (48 ^ 3 + 1) ^ 40 := + Nat.pow_le_pow_right (by positivity) (by norm_num) + calc + 68 ^ 30 * (2 ^ 457) ^ 6 = (2 ^ 457) ^ 6 * 68 ^ 30 := by ring + _ ≤ 2 ^ 7332 * (48 ^ 3 + 1) ^ 40 := Nat.mul_le_mul htwo hbase + _ = (2 ^ 1833 * (48 ^ 3 + 1) ^ 10) ^ 4 := by + norm_num [mul_pow, ← pow_mul] + +private theorem preliminary_fixed_pow_eight_le_cutoff : + 100522 ^ 8 ≤ 2 ^ 1833 * (48 ^ 3 + 1) ^ 10 := by + decide +kernel + +private theorem preliminary_lowOrder_coefficient_eq_cutoff_sq : + 2 ^ 10 * (48 ^ 3 + 1) ^ 20 * preliminaryDivisorMomentConstant ^ 8 = + (2 ^ 1833 * (48 ^ 3 + 1) ^ 10) ^ 2 := by + rw [preliminaryDivisorMomentConstant_eq] + have htwo457 : (2 ^ 457) ^ 8 = 2 ^ 3656 := by + rw [show (3656 : ℕ) = 457 * 8 by norm_num, pow_mul] + have htwo : 2 ^ 10 * (2 ^ 457) ^ 8 = 2 ^ 3666 := by + rw [htwo457] + exact (pow_add 2 10 3656).symm.trans (by norm_num) + have htwo' : (2 ^ 1833) ^ 2 = 2 ^ 3666 := by + rw [show (3666 : ℕ) = 1833 * 2 by norm_num, pow_mul] + have hbase : + (48 ^ 3 + 1) ^ 20 = ((48 ^ 3 + 1) ^ 10) ^ 2 := by + rw [show (20 : ℕ) = 10 * 2 by norm_num, pow_mul] + calc + 2 ^ 10 * (48 ^ 3 + 1) ^ 20 * (2 ^ 457) ^ 8 = + (2 ^ 10 * (2 ^ 457) ^ 8) * (48 ^ 3 + 1) ^ 20 := by ring + _ = 2 ^ 3666 * (48 ^ 3 + 1) ^ 20 := by rw [htwo] + _ = (2 ^ 1833) ^ 2 * ((48 ^ 3 + 1) ^ 10) ^ 2 := by + rw [htwo', hbase] + _ = (2 ^ 1833 * (48 ^ 3 + 1) ^ 10) ^ 2 := by rw [mul_pow] +/-- The simultaneous divisor count is smaller than the eighth root of `p`. -/ +theorem preliminary_divisor_sum_lt_rpow_one_div_eight + {p : ℕ} (hp : preliminaryStrongApproximationCutoff ≤ p) : + (((p - 1).divisors.card + (p + 1).divisors.card : ℕ) : ℝ) < + (p : ℝ) ^ (1 / 8 : ℝ) := by + let T := (p - 1).divisors.card + (p + 1).divisors.card + let Q := 2 ^ 1833 * (48 ^ 3 + 1) ^ 10 + have hpTwo : 2 ≤ p := by + have := preliminaryCutoff_gt_one.trans_le hp + omega + have hmoment : T ^ 10 ≤ preliminaryDivisorMomentConstant * p := by + simpa [T] using preliminary_divisor_sum_pow_ten_le hpTwo + have hQ : Q < p := by + simpa [Q] using preliminaryCutoff_constant_lt hp + have hpowNat : T ^ 80 < p ^ 10 := by + calc + T ^ 80 = (T ^ 10) ^ 8 := by + rw [show (80 : ℕ) = 10 * 8 by norm_num, pow_mul] + _ ≤ (preliminaryDivisorMomentConstant * p) ^ 8 := by gcongr + _ = preliminaryDivisorMomentConstant ^ 8 * p ^ 8 := by rw [mul_pow] + _ ≤ Q ^ 2 * p ^ 8 := by + exact Nat.mul_le_mul_right _ <| by + simpa [Q] using preliminary_moment_pow_eight_le_cutoff_sq + _ < p ^ 2 * p ^ 8 := by gcongr + _ = p ^ 10 := by ring + have hpNonnegative : (0 : ℝ) ≤ p := by positivity + have hpowReal : (T : ℝ) ^ 80 < (p : ℝ) ^ 10 := by + exact_mod_cast hpowNat + have hrootPow : + ((p : ℝ) ^ (1 / 8 : ℝ)) ^ 80 = (p : ℝ) ^ 10 := by + calc + ((p : ℝ) ^ (1 / 8 : ℝ)) ^ 80 = + (p : ℝ) ^ ((1 / 8 : ℝ) * 80) := + (Real.rpow_mul_natCast hpNonnegative (1 / 8 : ℝ) 80).symm + _ = (p : ℝ) ^ 10 := by norm_num + change (T : ℝ) < (p : ℝ) ^ (1 / 8 : ℝ) + apply lt_of_pow_lt_pow_left₀ 80 (Real.rpow_nonneg hpNonnegative _) + rw [hrootPow] + exact hpowReal + +/-- The coefficient-48 all-divisors term is smaller than the sixth root of +`p`, as required by the preliminary middle game. -/ +theorem preliminary_corvajaZannier_divisor_term_lt_rpow_one_div_six + {p : ℕ} (hp : preliminaryStrongApproximationCutoff ≤ p) : + (corvajaZannierCorollaryTwoSafeCoefficient * + ((p - 1).divisors.card + (p + 1).divisors.card) : ℕ) < + (p : ℝ) ^ (1 / 6 : ℝ) := by + let T := (p - 1).divisors.card + (p + 1).divisors.card + let Q := 2 ^ 1833 * (48 ^ 3 + 1) ^ 10 + have hpTwo : 2 ≤ p := by + have := preliminaryCutoff_gt_one.trans_le hp + omega + have hmoment : T ^ 10 ≤ preliminaryDivisorMomentConstant * p := by + simpa [T] using preliminary_divisor_sum_pow_ten_le hpTwo + have hQ : Q < p := by + simpa [Q] using preliminaryCutoff_constant_lt hp + have hpowNat : (48 * T) ^ 60 < p ^ 10 := by + calc + (48 * T) ^ 60 = 48 ^ 60 * (T ^ 10) ^ 6 := by ring + _ ≤ 48 ^ 60 * (preliminaryDivisorMomentConstant * p) ^ 6 := by gcongr + _ = (48 ^ 60 * preliminaryDivisorMomentConstant ^ 6) * p ^ 6 := by + rw [mul_pow] + ring + _ ≤ Q ^ 4 * p ^ 6 := by + exact Nat.mul_le_mul_right _ <| by + simpa [Q] using preliminary_middle_coefficient_le_cutoff_pow_four + _ < p ^ 4 * p ^ 6 := by gcongr + _ = p ^ 10 := by ring + have hpNonnegative : (0 : ℝ) ≤ p := by positivity + have hpowReal : ((48 * T : ℕ) : ℝ) ^ 60 < (p : ℝ) ^ 10 := by + exact_mod_cast hpowNat + have hrootPow : + ((p : ℝ) ^ (1 / 6 : ℝ)) ^ 60 = (p : ℝ) ^ 10 := by + calc + ((p : ℝ) ^ (1 / 6 : ℝ)) ^ 60 = + (p : ℝ) ^ ((1 / 6 : ℝ) * 60) := + (Real.rpow_mul_natCast hpNonnegative (1 / 6 : ℝ) 60).symm + _ = (p : ℝ) ^ 10 := by norm_num + norm_num only [corvajaZannierCorollaryTwoSafeCoefficient] + change ((48 * T : ℕ) : ℝ) < (p : ℝ) ^ (1 / 6 : ℝ) + apply lt_of_pow_lt_pow_left₀ 60 (Real.rpow_nonneg hpNonnegative _) + rw [hrootPow] + exact hpowReal + +/-- The weighted divisor square is smaller than the one-third power needed +by the primitive-trace endgame. -/ +theorem preliminary_weighted_divisor_sum_sq_lt_rpow_one_div_three + {p : ℕ} (hp : preliminaryStrongApproximationCutoff ≤ p) : + ((68 * ((p - 1).divisors.card + (p + 1).divisors.card) ^ 2 : ℕ) : ℝ) < + (p : ℝ) ^ (1 / 3 : ℝ) := by + let T := (p - 1).divisors.card + (p + 1).divisors.card + let Q := 2 ^ 1833 * (48 ^ 3 + 1) ^ 10 + have hpTwo : 2 ≤ p := by + have := preliminaryCutoff_gt_one.trans_le hp + omega + have hmoment : T ^ 10 ≤ preliminaryDivisorMomentConstant * p := by + simpa [T] using preliminary_divisor_sum_pow_ten_le hpTwo + have hQ : Q < p := by + simpa [Q] using preliminaryCutoff_constant_lt hp + have hpowNat : (68 * T ^ 2) ^ 30 < p ^ 10 := by + calc + (68 * T ^ 2) ^ 30 = 68 ^ 30 * (T ^ 10) ^ 6 := by ring + _ ≤ 68 ^ 30 * (preliminaryDivisorMomentConstant * p) ^ 6 := by gcongr + _ = (68 ^ 30 * preliminaryDivisorMomentConstant ^ 6) * p ^ 6 := by + rw [mul_pow] + ring + _ ≤ Q ^ 4 * p ^ 6 := by + exact Nat.mul_le_mul_right _ <| by + simpa [Q] using preliminary_endgame_coefficient_le_cutoff_pow_four + _ < p ^ 4 * p ^ 6 := by gcongr + _ = p ^ 10 := by ring + have hpNonnegative : (0 : ℝ) ≤ p := by positivity + have hpowReal : ((68 * T ^ 2 : ℕ) : ℝ) ^ 30 < (p : ℝ) ^ 10 := by + exact_mod_cast hpowNat + have hrootPow : + ((p : ℝ) ^ (1 / 3 : ℝ)) ^ 30 = (p : ℝ) ^ 10 := by + calc + ((p : ℝ) ^ (1 / 3 : ℝ)) ^ 30 = + (p : ℝ) ^ ((1 / 3 : ℝ) * 30) := + (Real.rpow_mul_natCast hpNonnegative (1 / 3 : ℝ) 30).symm + _ = (p : ℝ) ^ 10 := by norm_num + change ((68 * T ^ 2 : ℕ) : ℝ) < (p : ℝ) ^ (1 / 3 : ℝ) + apply lt_of_pow_lt_pow_left₀ 30 (Real.rpow_nonneg hpNonnegative _) + rw [hrootPow] + exact hpowReal + +/-- Every fixed coefficient used in the cage is smaller than the eighth root +of `p`. -/ +theorem preliminary_small_fixed_lt_rpow_one_div_eight + {p fixed : ℕ} (hp : preliminaryStrongApproximationCutoff ≤ p) + (hfixed : fixed ≤ 100522) : + (fixed : ℝ) < (p : ℝ) ^ (1 / 8 : ℝ) := by + have hpowNat : fixed ^ 8 < p := by + calc + fixed ^ 8 ≤ 100522 ^ 8 := Nat.pow_le_pow_left hfixed _ + _ ≤ 2 ^ 1833 * (48 ^ 3 + 1) ^ 10 := + preliminary_fixed_pow_eight_le_cutoff + _ < p := preliminaryCutoff_constant_lt hp + have hpNonnegative : (0 : ℝ) ≤ p := by positivity + have hpowReal : (fixed : ℝ) ^ 8 < (p : ℝ) := by + exact_mod_cast hpowNat + have hrootPow : + ((p : ℝ) ^ (1 / 8 : ℝ)) ^ 8 = (p : ℝ) := by + calc + ((p : ℝ) ^ (1 / 8 : ℝ)) ^ 8 = + (p : ℝ) ^ ((1 / 8 : ℝ) * 8) := + (Real.rpow_mul_natCast hpNonnegative (1 / 8 : ℝ) 8).symm + _ = (p : ℝ) := by norm_num + apply lt_of_pow_lt_pow_left₀ 8 (Real.rpow_nonneg hpNonnegative _) + rw [hrootPow] + exact hpowReal + +private theorem preliminary_prime_one_lt + {p : ℕ} (hp : preliminaryStrongApproximationCutoff ≤ p) : + (1 : ℝ) < p := by + exact_mod_cast preliminaryCutoff_gt_one.trans_le hp + +private theorem preliminary_rpow_lt_self_of_exponent_lt_one + {p : ℕ} (hp : preliminaryStrongApproximationCutoff ≤ p) + {a : ℝ} (ha : a < 1) : + (p : ℝ) ^ a < p := by + simpa only [Real.rpow_one] using + Real.rpow_lt_rpow_of_exponent_lt (preliminary_prime_one_lt hp) ha + +/-- Assembly-facing preliminary middle-game certificate. -/ +theorem preliminary_middleGame_corvajaZannier_linearBound + {p currentOrder : ℕ} (hp : preliminaryStrongApproximationCutoff ≤ p) + (hUpper : (currentOrder : ℝ) < (p : ℝ) ^ (5 / 6 : ℝ)) : + corvajaZannierCorollaryTwoSafeCoefficient * + ((p - 1).divisors.card + (p + 1).divisors.card) * currentOrder < p := by + let A : ℕ := corvajaZannierCorollaryTwoSafeCoefficient * + ((p - 1).divisors.card + (p + 1).divisors.card) + have hpRealPos : (0 : ℝ) < p := + (preliminary_prime_one_lt hp).trans' zero_lt_one + have hA : (A : ℝ) < (p : ℝ) ^ (1 / 6 : ℝ) := by + simpa [A] using + preliminary_corvajaZannier_divisor_term_lt_rpow_one_div_six hp + have hLinearPower : + (p : ℝ) ^ (1 / 6 : ℝ) * (p : ℝ) ^ (5 / 6 : ℝ) = (p : ℝ) := by + rw [← Real.rpow_add hpRealPos] + norm_num + have hLinear : (A : ℝ) * currentOrder < p := by + calc + (A : ℝ) * currentOrder ≤ + (p : ℝ) ^ (1 / 6 : ℝ) * currentOrder := + mul_le_mul_of_nonneg_right hA.le (Nat.cast_nonneg currentOrder) + _ < (p : ℝ) ^ (1 / 6 : ℝ) * (p : ℝ) ^ (5 / 6 : ℝ) := + mul_lt_mul_of_pos_left hUpper (Real.rpow_pos_of_pos hpRealPos _) + _ = (p : ℝ) := hLinearPower + exact_mod_cast hLinear + +/-- Preliminary primitive-trace inclusion--exclusion certificate. -/ +theorem preliminary_endgamePrimitiveTrace_explicitInequality + {p orbitExponent coefficient : ℕ} + (hp : preliminaryStrongApproximationCutoff ≤ p) + (horbit : (orbitExponent : ℝ) ≤ 2 * (p : ℝ) ^ (1 / 6 : ℝ)) + (hcoefficient : coefficient ≤ 34) : + (orbitExponent : ℝ) * ((p - 1).divisors.card : ℝ) ^ 2 * + ((coefficient : ℝ) * Real.sqrt (p : ℝ)) < p := by + let T := (p - 1).divisors.card + (p + 1).divisors.card + have hpRealPos : (0 : ℝ) < p := + (preliminary_prime_one_lt hp).trans' zero_lt_one + have hdivisor : ((p - 1).divisors.card : ℝ) ≤ (T : ℝ) := by + exact_mod_cast (show (p - 1).divisors.card ≤ T by + dsimp [T] + omega) + have hweighted : (68 : ℝ) * (T : ℝ) ^ 2 < + (p : ℝ) ^ (1 / 3 : ℝ) := by + simpa [T] using + preliminary_weighted_divisor_sum_sq_lt_rpow_one_div_three hp + calc + (orbitExponent : ℝ) * ((p - 1).divisors.card : ℝ) ^ 2 * + ((coefficient : ℝ) * Real.sqrt (p : ℝ)) ≤ + (2 * (p : ℝ) ^ (1 / 6 : ℝ)) * (T : ℝ) ^ 2 * + (34 * Real.sqrt (p : ℝ)) := by + gcongr + exact_mod_cast hcoefficient + _ = (68 * (T : ℝ) ^ 2) * + ((p : ℝ) ^ (1 / 6 : ℝ) * Real.sqrt (p : ℝ)) := by ring + _ < (p : ℝ) ^ (1 / 3 : ℝ) * + ((p : ℝ) ^ (1 / 6 : ℝ) * Real.sqrt (p : ℝ)) := by + exact mul_lt_mul_of_pos_right hweighted <| + mul_pos (Real.rpow_pos_of_pos hpRealPos _) (Real.sqrt_pos.2 hpRealPos) + _ = (p : ℝ) := by + rw [Real.sqrt_eq_rpow, ← Real.rpow_add hpRealPos, + ← Real.rpow_add hpRealPos] + norm_num + +theorem preliminary_endgamePrimitiveTrace_explicitInequality_of_card_sub_one + {p orbitExponent orbitOrder coefficient : ℕ} + (hp : preliminaryStrongApproximationCutoff ≤ p) + (hmul : orbitExponent * orbitOrder = p - 1) + (horder : (p : ℝ) ^ (5 / 6 : ℝ) ≤ orbitOrder) + (hcoefficient : coefficient ≤ 34) : + (orbitExponent : ℝ) * ((p - 1).divisors.card : ℝ) ^ 2 * + ((coefficient : ℝ) * Real.sqrt (p : ℝ)) < p := by + apply preliminary_endgamePrimitiveTrace_explicitInequality hp ?_ hcoefficient + have hpNat : 0 < p := + Nat.zero_lt_one.trans (preliminaryCutoff_gt_one.trans_le hp) + have horbit := orbitExponent_le_rpow_of_mul_order_eq_card_sub_one + p orbitExponent orbitOrder (δ := (1 / 3 : ℝ)) hpNat hmul (by + convert horder using 1 <;> norm_num) + calc + (orbitExponent : ℝ) ≤ (p : ℝ) ^ (1 / 6 : ℝ) := by + convert horbit using 1 <;> norm_num + _ ≤ 2 * (p : ℝ) ^ (1 / 6 : ℝ) := by + nlinarith [Real.rpow_nonneg (Nat.cast_nonneg p) (1 / 6 : ℝ)] + +theorem preliminary_endgamePrimitiveTrace_explicitInequality_of_card_add_one + {p orbitExponent orbitOrder coefficient : ℕ} + (hp : preliminaryStrongApproximationCutoff ≤ p) + (hmul : orbitExponent * orbitOrder = p + 1) + (horder : (p : ℝ) ^ (5 / 6 : ℝ) ≤ orbitOrder) + (hcoefficient : coefficient ≤ 34) : + (orbitExponent : ℝ) * ((p - 1).divisors.card : ℝ) ^ 2 * + ((coefficient : ℝ) * Real.sqrt (p : ℝ)) < p := by + apply preliminary_endgamePrimitiveTrace_explicitInequality hp ?_ hcoefficient + have hpNat : 0 < p := + Nat.zero_lt_one.trans (preliminaryCutoff_gt_one.trans_le hp) + have horbit := orbitExponent_le_two_mul_rpow_of_mul_order_eq_card_add_one + p orbitExponent orbitOrder (δ := (1 / 3 : ℝ)) hpNat hmul (by + convert horder using 1 <;> norm_num) + convert horbit using 1 <;> norm_num + +theorem preliminary_four_lt_rpow_five_div_six + {p : ℕ} (hp : preliminaryStrongApproximationCutoff ≤ p) : + (4 : ℝ) < (p : ℝ) ^ (5 / 6 : ℝ) := by + have hfour : (4 : ℝ) < (p : ℝ) ^ (1 / 8 : ℝ) := + preliminary_small_fixed_lt_rpow_one_div_eight hp (by norm_num) + exact hfour.trans <| + Real.rpow_lt_rpow_of_exponent_lt (preliminary_prime_one_lt hp) (by norm_num) + +/-- Preliminary cage inequality with the existing point-count coefficient. -/ +theorem preliminary_cageWitness_explicitInequality + {p coefficient : ℕ} (hp : preliminaryStrongApproximationCutoff ≤ p) + (hcoefficient : coefficient ≤ 100522) : + ((p - 1).divisors.card : ℝ) ^ 2 * + ((coefficient : ℝ) * Real.sqrt (p : ℝ)) < p := by + have hpRealPos : (0 : ℝ) < p := + (preliminary_prime_one_lt hp).trans' zero_lt_one + have hpRealNonneg : (0 : ℝ) ≤ p := hpRealPos.le + have hsum := preliminary_divisor_sum_lt_rpow_one_div_eight hp + have hdivisor : ((p - 1).divisors.card : ℝ) ≤ + (p : ℝ) ^ (1 / 8 : ℝ) := by + norm_num only [Nat.cast_add] at hsum + exact (le_add_of_nonneg_right (Nat.cast_nonneg _)).trans hsum.le + have hfixed : (100522 : ℝ) < (p : ℝ) ^ (1 / 8 : ℝ) := + preliminary_small_fixed_lt_rpow_one_div_eight hp (by norm_num) + have hsqrt : Real.sqrt (p : ℝ) = (p : ℝ) ^ (4 / 8 : ℝ) := by + rw [Real.sqrt_eq_rpow] + congr 1 + norm_num + have hpower : ((p : ℝ) ^ (1 / 8 : ℝ)) ^ 2 * Real.sqrt (p : ℝ) = + (p : ℝ) ^ (6 / 8 : ℝ) := by + rw [hsqrt, ← Real.rpow_mul_natCast hpRealNonneg, + ← Real.rpow_add hpRealPos] + congr 1 + norm_num + calc + ((p - 1).divisors.card : ℝ) ^ 2 * + ((coefficient : ℝ) * Real.sqrt (p : ℝ)) ≤ + ((p : ℝ) ^ (1 / 8 : ℝ)) ^ 2 * + (100522 * Real.sqrt (p : ℝ)) := by + gcongr + exact_mod_cast hcoefficient + _ = 100522 * (p : ℝ) ^ (6 / 8 : ℝ) := by + rw [← hpower] + ring + _ < (p : ℝ) ^ (1 / 8 : ℝ) * (p : ℝ) ^ (6 / 8 : ℝ) := by + exact mul_lt_mul_of_pos_right hfixed (Real.rpow_pos_of_pos hpRealPos _) + _ = (p : ℝ) ^ (7 / 8 : ℝ) := by + rw [← Real.rpow_add hpRealPos] + congr 1 + norm_num + _ < p := + preliminary_rpow_lt_self_of_exponent_lt_one hp (by norm_num) + +/-- The low-order Corvaja--Zannier cube contradiction, now driven by the +elementary tenth moment. -/ +theorem preliminary_lowOrder_divisorSensitive_cube + {p d : ℕ} (hp : preliminaryStrongApproximationCutoff ≤ p) + (hdPos : 0 < d) + (hpLe : p ≤ 2 * (2 + d * + ((p - 1).divisors.card + (p + 1).divisors.card)) ^ 2) : + (corvajaZannierCorollaryTwoSafeCoefficient * + ((p - 1).divisors.card + (p + 1).divisors.card)) ^ 3 < d := by + let T := (p - 1).divisors.card + (p + 1).divisors.card + let B := 48 ^ 3 + 1 + let Q := 2 ^ 1833 * B ^ 10 + have hpTwo : 2 ≤ p := by + have := preliminaryCutoff_gt_one.trans_le hp + omega + have hminusNonempty : (p - 1).divisors.Nonempty := + (Nat.nonempty_divisors).2 (by omega) + have hplusNonempty : (p + 1).divisors.Nonempty := + (Nat.nonempty_divisors).2 (by omega) + have hTtwo : 2 ≤ T := by + have hm : 0 < (p - 1).divisors.card := + Finset.card_pos.mpr hminusNonempty + have hp' : 0 < (p + 1).divisors.card := + Finset.card_pos.mpr hplusNonempty + dsimp [T] + omega + have hTfour : 2 ≤ T ^ 4 := by + calc + 2 ≤ T := hTtwo + _ = T * 1 := by ring + _ ≤ T * T ^ 3 := by + gcongr + exact Nat.one_le_pow 3 T (by omega) + _ = T ^ 4 := by ring + change (48 * T) ^ 3 < d + by_contra hcube + have hdUpper : d ≤ (48 * T) ^ 3 := by omega + have hinner : 2 + d * T ≤ B * T ^ 4 := by + calc + 2 + d * T ≤ T ^ 4 + d * T := Nat.add_le_add_right hTfour _ + _ ≤ T ^ 4 + (48 * T) ^ 3 * T := by gcongr + _ = B * T ^ 4 := by + dsimp [B] + ring + have hpLeCoarse : p ≤ 2 * B ^ 2 * T ^ 8 := by + calc + p ≤ 2 * (2 + d * T) ^ 2 := by simpa [T] using hpLe + _ ≤ 2 * (B * T ^ 4) ^ 2 := by gcongr + _ = 2 * B ^ 2 * T ^ 8 := by ring + have hmoment : T ^ 10 ≤ preliminaryDivisorMomentConstant * p := by + simpa [T] using preliminary_divisor_sum_pow_ten_le hpTwo + have hpPowLe : + p ^ 10 ≤ Q ^ 2 * p ^ 8 := by + calc + p ^ 10 ≤ (2 * B ^ 2 * T ^ 8) ^ 10 := + Nat.pow_le_pow_left hpLeCoarse _ + _ = 2 ^ 10 * B ^ 20 * (T ^ 10) ^ 8 := by ring + _ ≤ 2 ^ 10 * B ^ 20 * + (preliminaryDivisorMomentConstant * p) ^ 8 := by gcongr + _ = (2 ^ 10 * B ^ 20 * + preliminaryDivisorMomentConstant ^ 8) * p ^ 8 := by ring + _ = Q ^ 2 * p ^ 8 := by + change (2 ^ 10 * (48 ^ 3 + 1) ^ 20 * + preliminaryDivisorMomentConstant ^ 8) * p ^ 8 = + (2 ^ 1833 * (48 ^ 3 + 1) ^ 10) ^ 2 * p ^ 8 + exact congrArg (fun n : ℕ => n * p ^ 8) + preliminary_lowOrder_coefficient_eq_cutoff_sq + have hQ : Q < p := by + simpa [Q, B] using preliminaryCutoff_constant_lt hp + have hstrict : Q ^ 2 * p ^ 8 < p ^ 10 := by + calc + Q ^ 2 * p ^ 8 < p ^ 2 * p ^ 8 := by gcongr + _ = p ^ 10 := by ring + exact (not_lt_of_ge hpPowLe) hstrict + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve.lean b/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve.lean new file mode 100644 index 0000000000..d6e2a80f86 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve.lean @@ -0,0 +1,41 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.AffineNormalization +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.BiprojectiveClosure +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.BiprojectiveScheme +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.Boundary +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.Characteristic +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.ChartLocalization +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.CommonKummerIndependence +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.CommonPrimeKummerTower +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.Geometry +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.IrreducibilityObstructions +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.Kummer +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.LaurentComparisonInjectivity +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.LaurentJacobian +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.LaurentNormalization +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.LaurentSmooth +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.Localization +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.NormalForm +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.OddCommonPrimeIndependence +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.OddCoprimeIrreducibility +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.PositiveCoprimeIrreducibility +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.ProjectiveChart +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.ProjectiveNormalizationCharts +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.ProjectiveNormalizationMorphism +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.ProjectivePointEstimate +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.SemanticNormalForm +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.SyntacticDivisionCriterion +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.SyntacticDivisionObstruction +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.SyntacticNormalForm +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.WeightedBidegree +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.WeightedEllipticModel +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.WeightedIrreducibility +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.WeightedNotSubtorus +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.WeightedOddCoprimeIrreducibility diff --git a/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/AffineNormalization.lean b/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/AffineNormalization.lean new file mode 100644 index 0000000000..2e168fa561 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/AffineNormalization.lean @@ -0,0 +1,133 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.WeightedOddCoprimeIrreducibility +public import Mathlib.AlgebraicGeometry.Normalization + +/-! +# Affine normalization of the weighted trace cover + +This module constructs the actual relative normalization of the irreducible affine trace-cover +scheme inside its fraction field. It connects the proved polynomial irreducibility theorem to +Mathlib's scheme-theoretic normalization construction. + +This is only the affine normalization. The endgame still requires compatible normalizations of +the other three biprojective charts, their gluing into a proper curve, the boundary-branch labels, +and the genus and Hasse--Weil estimates. +-/ + +@[expose] public section + +namespace BGS.Markoff + +open CategoryTheory +open AlgebraicGeometry + +noncomputable section + +variable {K : Type*} [Field K] + +/-- Coordinate ring of the weighted denominator-cleared affine trace cover. -/ +abbrev WeightedSplitTraceAffineCoordinateRing (alpha beta : K) (d e : ℕ) := + MvPolynomial (Fin 2) K ⧸ Ideal.span {splitTraceCoverPolynomial alpha beta d e} + +/-- Irreducibility of the defining polynomial makes the affine coordinate ring a domain. -/ +theorem weightedSplitTraceAffineCoordinateRing_isDomain + (alpha beta : K) (d e : ℕ) + (h : Irreducible (splitTraceCoverPolynomial alpha beta d e)) : + IsDomain (WeightedSplitTraceAffineCoordinateRing alpha beta d e) := by + let I : Ideal (MvPolynomial (Fin 2) K) := + Ideal.span {splitTraceCoverPolynomial alpha beta d e} + have hprime : I.IsPrime := + (Ideal.span_singleton_prime h.ne_zero).mpr h.prime + exact (Ideal.Quotient.isDomain_iff_prime I).mpr hprime + +/-- The generic-point morphism from the fraction field to the irreducible affine curve. -/ +def weightedSplitTraceAffineGenericPointMorphism + (alpha beta : K) (d e : ℕ) + [IsDomain (WeightedSplitTraceAffineCoordinateRing alpha beta d e)] : + Spec (CommRingCat.of + (FractionRing (WeightedSplitTraceAffineCoordinateRing alpha beta d e))) ⟶ + Spec (CommRingCat.of (WeightedSplitTraceAffineCoordinateRing alpha beta d e)) := + Spec.map (CommRingCat.ofHom + (algebraMap (WeightedSplitTraceAffineCoordinateRing alpha beta d e) + (FractionRing (WeightedSplitTraceAffineCoordinateRing alpha beta d e)))) + +/-- The relative normalization of the affine trace cover inside its fraction field. -/ +def weightedSplitTraceAffineNormalization + (alpha beta : K) (d e : ℕ) + (h : Irreducible (splitTraceCoverPolynomial alpha beta d e)) : Scheme := by + letI : IsDomain (WeightedSplitTraceAffineCoordinateRing alpha beta d e) := + weightedSplitTraceAffineCoordinateRing_isDomain alpha beta d e h + exact (weightedSplitTraceAffineGenericPointMorphism alpha beta d e).normalization + +/-- The integral morphism from the affine normalization to the original affine curve. -/ +def weightedSplitTraceAffineNormalizationToCurve + (alpha beta : K) (d e : ℕ) + (h : Irreducible (splitTraceCoverPolynomial alpha beta d e)) : + weightedSplitTraceAffineNormalization alpha beta d e h ⟶ + Spec (CommRingCat.of + (WeightedSplitTraceAffineCoordinateRing alpha beta d e)) := by + letI : IsDomain (WeightedSplitTraceAffineCoordinateRing alpha beta d e) := + weightedSplitTraceAffineCoordinateRing_isDomain alpha beta d e h + exact (weightedSplitTraceAffineGenericPointMorphism alpha beta d e).fromNormalization + +instance weightedSplitTraceAffineNormalizationToCurve_isIntegral + (alpha beta : K) (d e : ℕ) + (h : Irreducible (splitTraceCoverPolynomial alpha beta d e)) : + IsIntegralHom (weightedSplitTraceAffineNormalizationToCurve alpha beta d e h) := by + dsimp [weightedSplitTraceAffineNormalizationToCurve, + weightedSplitTraceAffineNormalization] + infer_instance + +instance weightedSplitTraceAffineNormalization_isIntegral + (alpha beta : K) (d e : ℕ) + (h : Irreducible (splitTraceCoverPolynomial alpha beta d e)) : + IsIntegral (weightedSplitTraceAffineNormalization alpha beta d e h) := by + let : IsDomain (WeightedSplitTraceAffineCoordinateRing alpha beta d e) := + weightedSplitTraceAffineCoordinateRing_isDomain alpha beta d e h + dsimp [weightedSplitTraceAffineNormalization] + infer_instance + +instance weightedSplitTraceAffineNormalization_isReduced + (alpha beta : K) (d e : ℕ) + (h : Irreducible (splitTraceCoverPolynomial alpha beta d e)) : + IsReduced (weightedSplitTraceAffineNormalization alpha beta d e h) := by + let : IsDomain (WeightedSplitTraceAffineCoordinateRing alpha beta d e) := + weightedSplitTraceAffineCoordinateRing_isDomain alpha beta d e h + dsimp [weightedSplitTraceAffineNormalization] + infer_instance + +/-- The actual geometric affine normalization in the paper's positive-exponent range, obtained by +combining absolute irreducibility with the relative-normalization construction. -/ +def weightedSplitTraceGeometricAffineNormalization + (alpha beta : K) (halpha : alpha ≠ 0) (hbeta : beta ≠ 0) + (hnondegenerate : alpha * beta ≠ 1) + (d e : ℕ) (hd : 0 < d) (he : 0 < e) (heChar : (e : K) ≠ 0) : Scheme := by + let phi : K →+* AlgebraicClosure K := algebraMap K (AlgebraicClosure K) + have hirred := splitTraceCoverPolynomial_absolutelyIrreducible_of_positiveExponents + alpha beta halpha hbeta hnondegenerate e d he hd heChar + rw [map_splitTraceCoverPolynomial phi alpha beta d e] at hirred + exact weightedSplitTraceAffineNormalization (phi alpha) (phi beta) d e hirred + +/-- The two affine normalizations needed for all four standard charts of the biprojective closure. +The first-coordinate inversion preserves the weights, while the second-coordinate inversion swaps +them. This pair is not yet a glued projective scheme. -/ +def weightedSplitTraceGeometricChartNormalizations + (alpha beta : K) (halpha : alpha ≠ 0) (hbeta : beta ≠ 0) + (hnondegenerate : alpha * beta ≠ 1) + (d e : ℕ) (hd : 0 < d) (he : 0 < e) (heChar : (e : K) ≠ 0) : + Scheme × Scheme := + (weightedSplitTraceGeometricAffineNormalization alpha beta halpha hbeta + hnondegenerate d e hd he heChar, + weightedSplitTraceGeometricAffineNormalization beta alpha hbeta halpha + (by simpa [mul_comm] using hnondegenerate) d e hd he heChar) + +end + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/BiprojectiveClosure.lean b/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/BiprojectiveClosure.lean new file mode 100644 index 0000000000..663e83118b --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/BiprojectiveClosure.lean @@ -0,0 +1,477 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import Mathlib.Algebra.MvPolynomial.PDeriv +public import Mathlib.RingTheory.RootsOfUnity.AlgebraicallyClosed +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.Boundary +public import Mathlib.FieldTheory.KummerExtension + +/-! +# Explicit biprojective closure of the trace cover + +This uses `Option K` as the standard affine chart plus the point at infinity of `P^1(K)`. +It controls the raw closure in `P^1 × P^1`; it does not identify that generally singular closure +with its normalization. +-/ + +@[expose] public section + +namespace BGS.Markoff + +open Polynomial + +noncomputable section + +variable {K : Type*} [Field K] + +/-- The bidegree-`(2d,2e)` homogenization of the cleared trace-cover polynomial. -/ +def splitTraceBihomogeneousValue (alpha beta : K) (d e : ℕ) + (X₀ X₁ Y₀ Y₁ : K) : K := + alpha * X₀ ^ d * X₁ ^ d * Y₀ ^ (2 * e) + + beta * X₀ ^ d * X₁ ^ d * Y₁ ^ (2 * e) - + X₀ ^ (2 * d) * Y₀ ^ e * Y₁ ^ e - + X₁ ^ (2 * d) * Y₀ ^ e * Y₁ ^ e + +/-- Canonical homogeneous coordinates for the affine chart and infinity of `P^1(K)`. -/ +def projectiveLineChartCoordinates : Option K → K × K + | some x => (x, 1) + | none => (1, 0) + +/-- Evaluation of the raw biprojective closure on canonical chart representatives. -/ +def splitTraceBiprojectiveValue (alpha beta : K) (d e : ℕ) + (z : Option K × Option K) : K := + let X := projectiveLineChartCoordinates z.1 + let Y := projectiveLineChartCoordinates z.2 + splitTraceBihomogeneousValue alpha beta d e X.1 X.2 Y.1 Y.2 + +theorem splitTraceBiprojectiveValue_affine (alpha beta : K) (d e : ℕ) (x y : K) : + splitTraceBiprojectiveValue alpha beta d e (some x, some y) = + MvPolynomial.eval ![x, y] (splitTraceCoverPolynomial alpha beta d e) := by + rw [eval_splitTraceCoverPolynomial] + simp [splitTraceBiprojectiveValue, projectiveLineChartCoordinates, + splitTraceBihomogeneousValue] + +theorem splitTraceBiprojectiveValue_infinity_affine + (alpha beta : K) (d e : ℕ) (hd : 0 < d) (y : K) : + splitTraceBiprojectiveValue alpha beta d e (none, some y) = -(y ^ e) := by + have hd0 : d ≠ 0 := hd.ne' + have h2d0 : 2 * d ≠ 0 := by omega + simp [splitTraceBiprojectiveValue, projectiveLineChartCoordinates, + splitTraceBihomogeneousValue, hd0, h2d0] + +theorem splitTraceBiprojectiveValue_affine_infinity + (alpha beta : K) (d e : ℕ) (he : 0 < e) (x : K) : + splitTraceBiprojectiveValue alpha beta d e (some x, none) = alpha * x ^ d := by + have he0 : e ≠ 0 := he.ne' + have h2e0 : 2 * e ≠ 0 := by omega + simp [splitTraceBiprojectiveValue, projectiveLineChartCoordinates, + splitTraceBihomogeneousValue, he0, h2e0] + +theorem splitTraceBiprojectiveValue_infinity_infinity + (alpha beta : K) (d e : ℕ) (hd : 0 < d) (he : 0 < e) : + splitTraceBiprojectiveValue alpha beta d e (none, none) = 0 := by + have hd0 : d ≠ 0 := hd.ne' + have he0 : e ≠ 0 := he.ne' + have h2d0 : 2 * d ≠ 0 := by omega + have h2e0 : 2 * e ≠ 0 := by omega + simp [splitTraceBiprojectiveValue, projectiveLineChartCoordinates, + splitTraceBihomogeneousValue, hd0, he0, h2d0, h2e0] + +/-- The same bihomogeneous equation as a four-variable polynomial, ordered as +`X₀, X₁, Y₀, Y₁`. -/ +def splitTraceBihomogeneousPolynomial (alpha beta : K) (d e : ℕ) : + MvPolynomial (Fin 4) K := + MvPolynomial.C alpha * MvPolynomial.X 0 ^ d * MvPolynomial.X 1 ^ d * + MvPolynomial.X 2 ^ (2 * e) + + MvPolynomial.C beta * MvPolynomial.X 0 ^ d * MvPolynomial.X 1 ^ d * + MvPolynomial.X 3 ^ (2 * e) - + MvPolynomial.X 0 ^ (2 * d) * MvPolynomial.X 2 ^ e * MvPolynomial.X 3 ^ e - + MvPolynomial.X 1 ^ (2 * d) * MvPolynomial.X 2 ^ e * MvPolynomial.X 3 ^ e + +theorem eval_splitTraceBihomogeneousPolynomial + (alpha beta : K) (d e : ℕ) (X₀ X₁ Y₀ Y₁ : K) : + MvPolynomial.eval ![X₀, X₁, Y₀, Y₁] + (splitTraceBihomogeneousPolynomial alpha beta d e) = + splitTraceBihomogeneousValue alpha beta d e X₀ X₁ Y₀ Y₁ := by + simp [splitTraceBihomogeneousPolynomial, splitTraceBihomogeneousValue] + +/-! ### The four standard biprojective charts -/ + +/-- The finite-finite chart is the original cleared affine polynomial. -/ +theorem splitTraceBihomogeneousValue_zero_zero_chart + (alpha beta : K) (d e : ℕ) (x y : K) : + splitTraceBihomogeneousValue alpha beta d e x 1 y 1 = + MvPolynomial.eval ![x, y] (splitTraceCoverPolynomial alpha beta d e) := by + rw [eval_splitTraceCoverPolynomial] + simp [splitTraceBihomogeneousValue] + +/-- Inverting the first projective coordinate leaves the affine polynomial unchanged. -/ +theorem splitTraceBihomogeneousValue_infinity_zero_chart + (alpha beta : K) (d e : ℕ) (x y : K) : + splitTraceBihomogeneousValue alpha beta d e 1 x y 1 = + MvPolynomial.eval ![x, y] (splitTraceCoverPolynomial alpha beta d e) := by + rw [eval_splitTraceCoverPolynomial] + simp [splitTraceBihomogeneousValue] + ring + +/-- Inverting the second projective coordinate swaps the two trace weights. -/ +theorem splitTraceBihomogeneousValue_zero_infinity_chart + (alpha beta : K) (d e : ℕ) (x y : K) : + splitTraceBihomogeneousValue alpha beta d e x 1 1 y = + MvPolynomial.eval ![x, y] (splitTraceCoverPolynomial beta alpha d e) := by + rw [eval_splitTraceCoverPolynomial] + simp [splitTraceBihomogeneousValue] + ring + +/-- Inverting both coordinates again gives the affine polynomial with swapped weights. -/ +theorem splitTraceBihomogeneousValue_infinity_infinity_chart + (alpha beta : K) (d e : ℕ) (x y : K) : + splitTraceBihomogeneousValue alpha beta d e 1 x 1 y = + MvPolynomial.eval ![x, y] (splitTraceCoverPolynomial beta alpha d e) := by + rw [eval_splitTraceCoverPolynomial] + simp [splitTraceBihomogeneousValue] + ring + +/-- Torus points of the weighted trace cover, as a finite-type-independent subtype. -/ +abbrev WeightedSplitTraceTorusCurve (alpha beta : K) (d e : ℕ) := + {z : Kˣ × Kˣ // SplitTraceCurveEquation alpha beta d e z.1 z.2} + +/-- First-coordinate inversion is a transition automorphism of the torus curve. -/ +theorem splitTraceCurveEquation_left_inv_iff + (alpha beta : K) (d e : ℕ) (x y : Kˣ) : + SplitTraceCurveEquation alpha beta d e x⁻¹ y ↔ + SplitTraceCurveEquation alpha beta d e x y := by + simp [SplitTraceCurveEquation, splitTorusTrace] + ring_nf + +/-- Second-coordinate inversion is the transition map to the chart with swapped weights. -/ +theorem splitTraceCurveEquation_right_inv_iff_swapped + (alpha beta : K) (d e : ℕ) (x y : Kˣ) : + SplitTraceCurveEquation alpha beta d e x y⁻¹ ↔ + SplitTraceCurveEquation beta alpha d e x y := by + simp [SplitTraceCurveEquation, weightedSplitTorusTrace, splitTorusTrace] + constructor <;> intro h <;> linear_combination h + +/-- The involutive first-coordinate transition on torus points. -/ +def weightedSplitTraceTorusCurveLeftInversionEquiv + (alpha beta : K) (d e : ℕ) : + WeightedSplitTraceTorusCurve alpha beta d e ≃ + WeightedSplitTraceTorusCurve alpha beta d e where + toFun z := ⟨(z.1.1⁻¹, z.1.2), + (splitTraceCurveEquation_left_inv_iff alpha beta d e z.1.1 z.1.2).2 z.2⟩ + invFun z := ⟨(z.1.1⁻¹, z.1.2), + (splitTraceCurveEquation_left_inv_iff alpha beta d e z.1.1 z.1.2).2 z.2⟩ + left_inv z := by ext <;> simp + right_inv z := by ext <;> simp + +/-- The involutive second-coordinate transition between the two weight orderings. -/ +def weightedSplitTraceTorusCurveRightInversionEquiv + (alpha beta : K) (d e : ℕ) : + WeightedSplitTraceTorusCurve alpha beta d e ≃ + WeightedSplitTraceTorusCurve beta alpha d e where + toFun z := ⟨(z.1.1, z.1.2⁻¹), + (splitTraceCurveEquation_right_inv_iff_swapped + beta alpha d e z.1.1 z.1.2).2 z.2⟩ + invFun z := ⟨(z.1.1, z.1.2⁻¹), + (splitTraceCurveEquation_right_inv_iff_swapped + alpha beta d e z.1.1 z.1.2).2 z.2⟩ + left_inv z := by ext <;> simp + right_inv z := by ext <;> simp + +/-- For covering degrees greater than one, the corner `(∞,∞)` of the raw closure has zero +formal gradient. Thus the raw closure cannot be substituted for its normalization in the +Hasse--Weil step. -/ +theorem splitTraceBihomogeneousPolynomial_pderiv_eval_infinity_infinity + (alpha beta : K) (d e : ℕ) (hd : 1 < d) (he : 1 < e) (i : Fin 4) : + MvPolynomial.eval ![(1 : K), 0, 1, 0] + (MvPolynomial.pderiv i (splitTraceBihomogeneousPolynomial alpha beta d e)) = 0 := by + have hd0 : d ≠ 0 := by omega + have hd1 : d - 1 ≠ 0 := by omega + have he0 : e ≠ 0 := by omega + have he1 : e - 1 ≠ 0 := by omega + have h2d0 : 2 * d ≠ 0 := by omega + have h2d1 : 2 * d - 1 ≠ 0 := by omega + have h2e0 : 2 * e ≠ 0 := by omega + have h2e1 : 2 * e - 1 ≠ 0 := by omega + fin_cases i <;> + simp [splitTraceBihomogeneousPolynomial, hd0, hd1, he0, he1, + h2d0, h2d1, h2e0, h2e1] + +/-! ### Weighted local equations at the projective corners -/ + +/-- In the `(∞,∞)` chart, weighted scaling `x ↦ T^e x`, `y ↦ T^d y` separates +the binomial of weighted degree `de` from the terms of weighted degree `3de`. -/ +theorem splitTraceBihomogeneousValue_infinity_infinity_weightedScaling + (alpha beta : K) (d e : ℕ) (T x y : K) : + splitTraceBihomogeneousValue alpha beta d e + 1 (T ^ e * x) 1 (T ^ d * y) = + T ^ (d * e) * (alpha * x ^ d - y ^ e) + + T ^ (3 * (d * e)) * + (beta * x ^ d * y ^ (2 * e) - x ^ (2 * d) * y ^ e) := by + simp only [splitTraceBihomogeneousValue, one_pow, one_mul, mul_one, mul_pow] + ring_nf + +/-- The `(0,∞)` corner has the same weighted local equation as `(∞,∞)`. -/ +theorem splitTraceBihomogeneousValue_zero_infinity_weightedScaling + (alpha beta : K) (d e : ℕ) (T x y : K) : + splitTraceBihomogeneousValue alpha beta d e + (T ^ e * x) 1 1 (T ^ d * y) = + T ^ (d * e) * (alpha * x ^ d - y ^ e) + + T ^ (3 * (d * e)) * + (beta * x ^ d * y ^ (2 * e) - x ^ (2 * d) * y ^ e) := by + simp only [splitTraceBihomogeneousValue, one_pow, one_mul, mul_one, mul_pow] + ring_nf + +/-- In the `(∞,0)` chart the leading coefficient is the second weight `beta`. -/ +theorem splitTraceBihomogeneousValue_infinity_zero_weightedScaling + (alpha beta : K) (d e : ℕ) (T x y : K) : + splitTraceBihomogeneousValue alpha beta d e + 1 (T ^ e * x) (T ^ d * y) 1 = + T ^ (d * e) * (beta * x ^ d - y ^ e) + + T ^ (3 * (d * e)) * + (alpha * x ^ d * y ^ (2 * e) - x ^ (2 * d) * y ^ e) := by + simp only [splitTraceBihomogeneousValue, one_pow, one_mul, mul_one, mul_pow] + ring_nf + +/-- The `(0,0)` corner has the same weighted local equation as `(∞,0)`. -/ +theorem splitTraceBihomogeneousValue_zero_zero_weightedScaling + (alpha beta : K) (d e : ℕ) (T x y : K) : + splitTraceBihomogeneousValue alpha beta d e + (T ^ e * x) 1 (T ^ d * y) 1 = + T ^ (d * e) * (beta * x ^ d - y ^ e) + + T ^ (3 * (d * e)) * + (alpha * x ^ d * y ^ (2 * e) - x ^ (2 * d) * y ^ e) := by + simp only [splitTraceBihomogeneousValue, one_pow, one_mul, mul_one, mul_pow] + ring_nf + +/-- The common weighted initial polynomial at a corner, with coefficient `gamma`. -/ +noncomputable def splitTraceCornerInitialPolynomial (gamma : K) (d e : ℕ) : + MvPolynomial (Fin 2) K := + MvPolynomial.C gamma * MvPolynomial.X 0 ^ d - MvPolynomial.X 1 ^ e + +/-- If both exponents have a common factor `q` and the leading coefficient is a `q`-th power, +the weighted initial polynomial has the corresponding binomial factor. Over an algebraic closure +the coefficient condition is automatic. -/ +theorem splitTraceCornerInitialPolynomial_factor_of_commonScaling + (a : K) (q d e : ℕ) : + MvPolynomial.C a * MvPolynomial.X 0 ^ d - MvPolynomial.X 1 ^ e ∣ + splitTraceCornerInitialPolynomial (a ^ q) (q * d) (q * e) := by + change MvPolynomial.C a * MvPolynomial.X 0 ^ d - MvPolynomial.X 1 ^ e ∣ + MvPolynomial.C (a ^ q) * MvPolynomial.X 0 ^ (q * d) - + MvPolynomial.X 1 ^ (q * e) + rw [map_pow] + rw [show MvPolynomial.X (0 : Fin 2) ^ (q * d) = + (MvPolynomial.X 0 ^ d) ^ q by rw [Nat.mul_comm, pow_mul]] + rw [show MvPolynomial.X (1 : Fin 2) ^ (q * e) = + (MvPolynomial.X 1 ^ e) ^ q by rw [Nat.mul_comm, pow_mul]] + rw [← mul_pow] + exact sub_dvd_pow_sub_pow + (MvPolynomial.C a * MvPolynomial.X (0 : Fin 2) ^ d) + (MvPolynomial.X (1 : Fin 2) ^ e) q + +/-- Over an algebraically closed field every positive common scaling of the corner exponents +produces an explicit binomial factor of the weighted initial polynomial. -/ +theorem exists_splitTraceCornerInitialPolynomial_factor_of_commonScaling + [IsAlgClosed K] (gamma : K) (q d e : ℕ) (hq : 0 < q) : + ∃ a : K, a ^ q = gamma ∧ + MvPolynomial.C a * MvPolynomial.X 0 ^ d - MvPolynomial.X 1 ^ e ∣ + splitTraceCornerInitialPolynomial gamma (q * d) (q * e) := by + obtain ⟨a, ha⟩ := IsAlgClosed.exists_pow_nat_eq gamma hq + refine ⟨a, ha, ?_⟩ + rw [← ha] + exact splitTraceCornerInitialPolynomial_factor_of_commonScaling a q d e + +/-- With a primitive `q`-th root of unity, the corner initial polynomial factors into exactly +the expected `q` binomials. This is the algebraic input for counting branches above a corner; +lifting these initial factors to the normalization remains a separate theorem. -/ +theorem splitTraceCornerInitialPolynomial_eq_prod_factors + (gamma a zeta : K) (q d e : ℕ) (hq : 0 < q) + (ha : a ^ q = gamma) (hzeta : IsPrimitiveRoot zeta q) : + splitTraceCornerInitialPolynomial gamma (q * d) (q * e) = + ∏ i ∈ Finset.range q, + (MvPolynomial.C a * MvPolynomial.X 0 ^ d - + MvPolynomial.C (zeta ^ i) * MvPolynomial.X 1 ^ e) := by + let R := MvPolynomial (Fin 2) K + let A : R := MvPolynomial.C a * MvPolynomial.X 0 ^ d + let B : R := MvPolynomial.X 1 ^ e + have hzetaR : IsPrimitiveRoot (MvPolynomial.C zeta : R) q := + hzeta.map_of_injective (MvPolynomial.C_injective (Fin 2) K) + have hpoly := X_pow_sub_C_eq_prod hzetaR hq (show B ^ q = B ^ q from rfl) + have heval := congrArg (Polynomial.eval A) hpoly + simp only [Polynomial.eval_sub, Polynomial.eval_pow, Polynomial.eval_X, + Polynomial.eval_C, Polynomial.eval_prod] at heval + rw [splitTraceCornerInitialPolynomial, ← ha] + change MvPolynomial.C (a ^ q) * MvPolynomial.X 0 ^ (q * d) - + MvPolynomial.X 1 ^ (q * e) = _ + rw [map_pow] + rw [show MvPolynomial.X (0 : Fin 2) ^ (q * d) = + (MvPolynomial.X 0 ^ d) ^ q by rw [Nat.mul_comm, pow_mul]] + rw [show MvPolynomial.X (1 : Fin 2) ^ (q * e) = + (MvPolynomial.X 1 ^ e) ^ q by rw [Nat.mul_comm, pow_mul]] + rw [← mul_pow] + rw [heval] + simp [A, B, R, map_pow] + +/-- The `q` binomials in the preceding factorization are pairwise distinct. -/ +theorem splitTraceCornerInitialPolynomial_factors_injective + (a zeta : K) (q d e : ℕ) (hzeta : IsPrimitiveRoot zeta q) : + Function.Injective (fun i : Fin q => + (MvPolynomial.C a : MvPolynomial (Fin 2) K) * MvPolynomial.X 0 ^ d - + MvPolynomial.C (zeta ^ (i : ℕ)) * MvPolynomial.X 1 ^ e) := by + intro i j hij + have hvalue := congrArg + (fun P : MvPolynomial (Fin 2) K => MvPolynomial.eval ![(1 : K), 1] P) hij + simp at hvalue + apply Fin.ext + exact hzeta.pow_inj i.isLt j.isLt hvalue + +/-- For the actual exponents, the number of distinct factors in the weighted initial form is +controlled by `gcd d e`. The characteristic hypothesis is automatic in the endgame because both +covering degrees are prime to the field characteristic. -/ +theorem exists_splitTraceCornerInitialPolynomial_gcd_factorization + [IsAlgClosed K] (gamma : K) (d e : ℕ) (hd : 0 < d) + (hgChar : ((Nat.gcd d e : ℕ) : K) ≠ 0) : + ∃ a zeta : K, + a ^ Nat.gcd d e = gamma ∧ IsPrimitiveRoot zeta (Nat.gcd d e) ∧ + splitTraceCornerInitialPolynomial gamma d e = + ∏ i ∈ Finset.range (Nat.gcd d e), + (MvPolynomial.C a * MvPolynomial.X 0 ^ (d / Nat.gcd d e) - + MvPolynomial.C (zeta ^ i) * MvPolynomial.X 1 ^ (e / Nat.gcd d e)) := by + let q := Nat.gcd d e + change ∃ a zeta : K, + a ^ q = gamma ∧ IsPrimitiveRoot zeta q ∧ + splitTraceCornerInitialPolynomial gamma d e = + ∏ i ∈ Finset.range q, + (MvPolynomial.C a * MvPolynomial.X 0 ^ (d / q) - + MvPolynomial.C (zeta ^ i) * MvPolynomial.X 1 ^ (e / q)) + have hq : 0 < q := Nat.gcd_pos_of_pos_left e hd + let : NeZero q := ⟨hq.ne'⟩ + let : NeZero (q : K) := ⟨by simpa [q] using hgChar⟩ + obtain ⟨a, ha⟩ := IsAlgClosed.exists_pow_nat_eq gamma hq + obtain ⟨zeta, hzeta⟩ := HasEnoughRootsOfUnity.exists_primitiveRoot K q + have hqd : q ∣ d := Nat.gcd_dvd_left d e + have hqe : q ∣ e := Nat.gcd_dvd_right d e + have hdEq : q * (d / q) = d := Nat.mul_div_cancel' hqd + have heEq : q * (e / q) = e := Nat.mul_div_cancel' hqe + refine ⟨a, zeta, ha, hzeta, ?_⟩ + calc + splitTraceCornerInitialPolynomial gamma d e = + splitTraceCornerInitialPolynomial gamma (q * (d / q)) (q * (e / q)) := by + rw [hdEq, heEq] + _ = _ := splitTraceCornerInitialPolynomial_eq_prod_factors + gamma a zeta q (d / q) (e / q) hq ha hzeta + +section Finite + +variable (K : Type*) [Field K] [Fintype K] [DecidableEq K] + +/-- Rational points of the raw closure in the canonical `P^1 × P^1` charts. -/ +def splitTraceBiprojectiveZeros (alpha beta : K) (d e : ℕ) : + Finset (Option K × Option K) := + Finset.univ.filter fun z => splitTraceBiprojectiveValue alpha beta d e z = 0 + +/-- Points of the raw closure outside the affine `A^1 × A^1` chart. -/ +def splitTraceBiprojectiveAffineBoundary (alpha beta : K) (d e : ℕ) : + Finset (Option K × Option K) := + (splitTraceBiprojectiveZeros K alpha beta d e).filter fun z => + z.1.isNone || z.2.isNone + +/-- The three raw boundary points outside `A^1 × A^1`. Together with the affine origin these +are the four boundary points of the torus chart. -/ +def splitTraceBiprojectiveBoundaryCorners : Finset (Option K × Option K) := + {(none, some 0), (none, none), (some 0, none)} + +theorem splitTraceBiprojectiveAffineBoundary_eq_corners + (alpha beta : K) (d e : ℕ) (hd : 0 < d) (he : 0 < e) + (halpha : alpha ≠ 0) : + splitTraceBiprojectiveAffineBoundary K alpha beta d e = + splitTraceBiprojectiveBoundaryCorners K := by + ext z + rcases z with ⟨x, y⟩ + cases x with + | none => + cases y with + | none => + simp [splitTraceBiprojectiveAffineBoundary, splitTraceBiprojectiveZeros, + splitTraceBiprojectiveBoundaryCorners, + splitTraceBiprojectiveValue_infinity_infinity alpha beta d e hd he] + | some y => + simp [splitTraceBiprojectiveAffineBoundary, splitTraceBiprojectiveZeros, + splitTraceBiprojectiveBoundaryCorners, + splitTraceBiprojectiveValue_infinity_affine alpha beta d e hd y, + pow_eq_zero_iff he.ne'] + | some x => + cases y with + | none => + simp [splitTraceBiprojectiveAffineBoundary, splitTraceBiprojectiveZeros, + splitTraceBiprojectiveBoundaryCorners, + splitTraceBiprojectiveValue_affine_infinity alpha beta d e he x, + halpha, pow_eq_zero_iff hd.ne'] + | some y => + simp [splitTraceBiprojectiveAffineBoundary, splitTraceBiprojectiveZeros, + splitTraceBiprojectiveBoundaryCorners] + +theorem splitTraceBiprojectiveAffineBoundary_card + (alpha beta : K) (d e : ℕ) (hd : 0 < d) (he : 0 < e) + (halpha : alpha ≠ 0) : + (splitTraceBiprojectiveAffineBoundary K alpha beta d e).card = 3 := by + rw [splitTraceBiprojectiveAffineBoundary_eq_corners K alpha beta d e hd he halpha] + simp [splitTraceBiprojectiveBoundaryCorners] + +/-- The denominator-cleared affine zero set is exactly the affine chart of the raw +biprojective closure. -/ +def affineSplitTraceCoverZerosEquivBiprojectiveOffBoundary + (alpha beta : K) (d e : ℕ) : + ↥(affineSplitTraceCoverZeros K alpha beta d e) ≃ + ↥(splitTraceBiprojectiveZeros K alpha beta d e \ + splitTraceBiprojectiveAffineBoundary K alpha beta d e) := + Equiv.ofBijective + (fun z => + ⟨(some z.1.1, some z.1.2), by + rw [Finset.mem_sdiff] + constructor + · rw [splitTraceBiprojectiveZeros, Finset.mem_filter] + refine ⟨Finset.mem_univ _, ?_⟩ + rw [splitTraceBiprojectiveValue_affine] + exact (mem_affineSplitTraceCoverZeros_iff K alpha beta d e z.1).mp z.2 + · simp [splitTraceBiprojectiveAffineBoundary]⟩) + ⟨by + intro z w h + apply Subtype.ext + apply Prod.ext + · exact Option.some.inj (congrArg (fun q => q.1.1) h) + · exact Option.some.inj (congrArg (fun q => q.1.2) h), by + rintro ⟨⟨x, y⟩, hxy⟩ + rcases Finset.mem_sdiff.mp hxy with ⟨hzero, hnotBoundary⟩ + cases x with + | none => + exfalso + apply hnotBoundary + simp [splitTraceBiprojectiveAffineBoundary, hzero] + | some x => + cases y with + | none => + exfalso + apply hnotBoundary + simp [splitTraceBiprojectiveAffineBoundary, hzero] + | some y => + have hvalue : splitTraceBiprojectiveValue alpha beta d e (some x, some y) = 0 := + (Finset.mem_filter.mp (show + (some x, some y) ∈ Finset.univ.filter + (fun z => splitTraceBiprojectiveValue alpha beta d e z = 0) by + exact hzero)).2 + refine ⟨⟨(x, y), ?_⟩, rfl⟩ + rw [mem_affineSplitTraceCoverZeros_iff] + rw [← splitTraceBiprojectiveValue_affine] + exact hvalue⟩ + +end Finite + +end + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/BiprojectiveScheme.lean b/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/BiprojectiveScheme.lean new file mode 100644 index 0000000000..3cb9303c83 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/BiprojectiveScheme.lean @@ -0,0 +1,161 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.AlgebraicGeometry.ConstantOpenGlueData +public import LeanPool.MarkoffModP.BGS.AlgebraicGeometry.SpecRingEquiv +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.ChartLocalization +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.ProjectiveChart +public import Mathlib.AlgebraicGeometry.OpenImmersion + +/-! +# The biprojective trace curve as a glued scheme + +The published trace curve has four standard affine charts. This module glues the corresponding +affine hypersurface schemes along their common Laurent torus, using the explicit coordinate +inversions already proved for the chart rings. +-/ + +@[expose] public section + +namespace BGS.Markoff + +open CategoryTheory +open AlgebraicGeometry + +noncomputable section + +universe u + +variable {K : Type u} [Field K] + +/-- One affine equation chart of the biprojective trace curve. -/ +def weightedSplitTraceAffineCurveSpec (alpha beta : K) (d e : ℕ) : Scheme := + Spec (CommRingCat.of (WeightedSplitTraceAffineCoordinateRing alpha beta d e)) + +/-- The Laurent torus open in an affine equation chart. -/ +def weightedSplitTraceLaurentCurveSpec (alpha beta : K) (d e : ℕ) : Scheme := + Spec (CommRingCat.of (WeightedSplitTraceLaurentCoordinateRing alpha beta d e)) + +/-- The torus-open immersion into an affine equation chart. -/ +def weightedSplitTraceLaurentCurveOpenImmersion (alpha beta : K) (d e : ℕ) : + weightedSplitTraceLaurentCurveSpec alpha beta d e ⟶ + weightedSplitTraceAffineCurveSpec alpha beta d e := + Spec.map (CommRingCat.ofHom + (algebraMap (WeightedSplitTraceAffineCoordinateRing alpha beta d e) + (WeightedSplitTraceLaurentCoordinateRing alpha beta d e))) + +instance weightedSplitTraceLaurentCurveOpenImmersion_isOpen + (alpha beta : K) (d e : ℕ) : + IsOpenImmersion (weightedSplitTraceLaurentCurveOpenImmersion alpha beta d e) := by + dsimp only [weightedSplitTraceLaurentCurveOpenImmersion, + weightedSplitTraceLaurentCurveSpec, weightedSplitTraceAffineCurveSpec, + WeightedSplitTraceLaurentCoordinateRing] + infer_instance + +/-- First-coordinate inversion on the raw Laurent curve scheme. -/ +def weightedSplitTraceLeftInversionLaurentCurveSchemeIso + (alpha beta : K) (d e : ℕ) : + weightedSplitTraceLaurentCurveSpec alpha beta d e ≅ + weightedSplitTraceLaurentCurveSpec alpha beta d e := + BGS.specIsoOfRingEquiv + (weightedSplitTraceLeftInversionLaurentEquiv alpha beta d e) + +/-- Second-coordinate inversion between the two weight orderings of the raw Laurent curve. -/ +def weightedSplitTraceRightInversionLaurentCurveSchemeIso + (alpha beta : K) (d e : ℕ) : + weightedSplitTraceLaurentCurveSpec alpha beta d e ≅ + weightedSplitTraceLaurentCurveSpec beta alpha d e := + BGS.specIsoOfRingEquiv + (weightedSplitTraceRightInversionLaurentEquiv alpha beta d e) + +/-- Raw affine equation scheme used by each standard projective chart. -/ +def weightedSplitTraceProjectiveChartScheme + (alpha beta : K) (d e : ℕ) : WeightedSplitTraceProjectiveChart → Scheme + | .affine | .invertFirst => weightedSplitTraceAffineCurveSpec alpha beta d e + | .invertSecond | .invertBoth => weightedSplitTraceAffineCurveSpec beta alpha d e + +/-- Raw Laurent overlap in each standard projective chart. -/ +def weightedSplitTraceProjectiveChartOpen + (alpha beta : K) (d e : ℕ) : WeightedSplitTraceProjectiveChart → Scheme + | .affine | .invertFirst => weightedSplitTraceLaurentCurveSpec alpha beta d e + | .invertSecond | .invertBoth => weightedSplitTraceLaurentCurveSpec beta alpha d e + +/-- The Laurent-open immersion in each raw projective chart. -/ +def weightedSplitTraceProjectiveChartOpenImmersion + (alpha beta : K) (d e : ℕ) (i : WeightedSplitTraceProjectiveChart) : + weightedSplitTraceProjectiveChartOpen alpha beta d e i ⟶ + weightedSplitTraceProjectiveChartScheme alpha beta d e i := by + cases i with + | affine | invertFirst => exact weightedSplitTraceLaurentCurveOpenImmersion alpha beta d e + | invertSecond | invertBoth => exact weightedSplitTraceLaurentCurveOpenImmersion beta alpha d e + +instance weightedSplitTraceProjectiveChartOpenImmersion_isOpen + (alpha beta : K) (d e : ℕ) (i : WeightedSplitTraceProjectiveChart) : + IsOpenImmersion (weightedSplitTraceProjectiveChartOpenImmersion alpha beta d e i) := by + cases i with + | affine | invertFirst => + exact weightedSplitTraceLaurentCurveOpenImmersion_isOpen alpha beta d e + | invertSecond | invertBoth => + exact weightedSplitTraceLaurentCurveOpenImmersion_isOpen beta alpha d e + +/-- Every raw chart overlap identified with the Laurent curve in the original coordinates. -/ +def weightedSplitTraceProjectiveChartOpenIsoCommon + (alpha beta : K) (d e : ℕ) (i : WeightedSplitTraceProjectiveChart) : + weightedSplitTraceProjectiveChartOpen alpha beta d e i ≅ + weightedSplitTraceLaurentCurveSpec alpha beta d e := by + let left := weightedSplitTraceLeftInversionLaurentCurveSchemeIso alpha beta d e + let right := weightedSplitTraceRightInversionLaurentCurveSchemeIso alpha beta d e + cases i with + | affine => exact Iso.refl _ + | invertFirst => exact left + | invertSecond => exact right.symm + | invertBoth => exact right.symm.trans left + +/-- Four-chart gluing datum for the biprojective trace curve itself. -/ +def weightedSplitTraceBiprojectiveCurveGlueData + (alpha beta : K) (d e : ℕ) : Scheme.GlueData := + BGS.constantOpenGlueDataOfCommonTarget + (fun i : WeightedSplitTraceProjectiveChartIndex ↦ + weightedSplitTraceProjectiveChartScheme alpha beta d e i.down) + (fun i : WeightedSplitTraceProjectiveChartIndex ↦ + weightedSplitTraceProjectiveChartOpen alpha beta d e i.down) + (fun i : WeightedSplitTraceProjectiveChartIndex ↦ + weightedSplitTraceProjectiveChartOpenImmersion alpha beta d e i.down) + (weightedSplitTraceLaurentCurveSpec alpha beta d e) + (fun i : WeightedSplitTraceProjectiveChartIndex ↦ + weightedSplitTraceProjectiveChartOpenIsoCommon alpha beta d e i.down) + +/-- The biprojective trace curve obtained by gluing its four standard affine equation charts. -/ +def weightedSplitTraceBiprojectiveCurve (alpha beta : K) (d e : ℕ) : Scheme := + (weightedSplitTraceBiprojectiveCurveGlueData alpha beta d e).glued + +/-- Open immersion of a standard raw chart into the biprojective trace curve. -/ +def weightedSplitTraceProjectiveChartMap + (alpha beta : K) (d e : ℕ) (i : WeightedSplitTraceProjectiveChartIndex) : + weightedSplitTraceProjectiveChartScheme alpha beta d e i.down ⟶ + weightedSplitTraceBiprojectiveCurve alpha beta d e := + (weightedSplitTraceBiprojectiveCurveGlueData alpha beta d e).ι i + +instance weightedSplitTraceProjectiveChartMap_isOpen + (alpha beta : K) (d e : ℕ) (i : WeightedSplitTraceProjectiveChartIndex) : + IsOpenImmersion (weightedSplitTraceProjectiveChartMap alpha beta d e i) := + Scheme.GlueData.ι_isOpenImmersion + (weightedSplitTraceBiprojectiveCurveGlueData alpha beta d e) i + +/-- The four raw affine charts jointly cover the biprojective trace curve. -/ +theorem weightedSplitTraceProjectiveChartMap_jointly_surjective + (alpha beta : K) (d e : ℕ) + (x : (weightedSplitTraceBiprojectiveCurve alpha beta d e).carrier) : + ∃ (i : WeightedSplitTraceProjectiveChartIndex) + (y : (weightedSplitTraceProjectiveChartScheme alpha beta d e i.down).carrier), + weightedSplitTraceProjectiveChartMap alpha beta d e i y = x := + (weightedSplitTraceBiprojectiveCurveGlueData alpha beta d e).ι_jointly_surjective x + +end + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/Boundary.lean b/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/Boundary.lean new file mode 100644 index 0000000000..2b5850a107 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/Boundary.lean @@ -0,0 +1,214 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.Geometry + +/-! +# Affine boundary of the split trace cover + +The split trace equation is naturally an equation on `G_m × G_m`, whereas +`splitTraceCoverPolynomial` is its denominator-cleared affine model. Weil estimates are often +stated for an affine or projective model, so the points introduced on the coordinate axes must be +accounted for explicitly. For positive covering exponents and nonzero second weight, the affine +model adds exactly the origin and no other coordinate-axis point. +-/ + +@[expose] public section + +namespace BGS.Markoff + +open Polynomial + +section Boundary + +variable {K : Type*} [Field K] + +/-- A zero of the denominator-cleared split trace polynomial on either coordinate axis is the +origin. The positivity hypotheses are essential: they ensure that clearing the Laurent +denominators really contributes powers of both coordinates. -/ +theorem splitTraceCoverPolynomial_axis_zero_eq_origin + (alpha beta : K) (d e : ℕ) (hd : 0 < d) (he : 0 < e) (hbeta : beta ≠ 0) + (x y : K) + (hzero : MvPolynomial.eval ![x, y] (splitTraceCoverPolynomial alpha beta d e) = 0) + (haxis : x = 0 ∨ y = 0) : + x = 0 ∧ y = 0 := by + rw [eval_splitTraceCoverPolynomial] at hzero + have htwoD : 2 * d ≠ 0 := by omega + have htwoE : 2 * e ≠ 0 := by omega + rcases haxis with rfl | rfl + · constructor + · rfl + · have hyPow : y ^ e = 0 := by + have hneg : -(y ^ e) = 0 := by + simpa only [zero_pow hd.ne', zero_pow htwoD, zero_mul, mul_zero, + add_zero, sub_zero, zero_sub] using hzero + exact neg_eq_zero.mp hneg + exact (pow_eq_zero_iff he.ne').mp hyPow + · constructor + · have hxPow : x ^ d = 0 := by + have hbetaPow : beta * x ^ d = 0 := by + simpa only [zero_pow he.ne', zero_pow htwoE, mul_zero, + add_zero, sub_zero, zero_add] using hzero + exact (mul_eq_zero.mp hbetaPow).resolve_left hbeta + exact (pow_eq_zero_iff hd.ne').mp hxPow + · rfl + +/-- The origin is always the affine boundary point added by clearing denominators when both +covering exponents are positive. -/ +theorem splitTraceCoverPolynomial_origin_zero + (alpha beta : K) (d e : ℕ) (hd : 0 < d) (he : 0 < e) : + MvPolynomial.eval ![(0 : K), (0 : K)] + (splitTraceCoverPolynomial alpha beta d e) = 0 := by + rw [eval_splitTraceCoverPolynomial] + have htwoD : 2 * d ≠ 0 := by omega + have htwoE : 2 * e ≠ 0 := by omega + simp only [zero_pow hd.ne', zero_pow he.ne', + zero_pow htwoD, zero_pow htwoE, mul_zero, + add_zero, sub_zero] + +/-- Away from the single affine boundary point, every zero of the cleared polynomial has two +nonzero coordinates and therefore is genuinely a point of the original Laurent trace curve. -/ +theorem splitTraceCoverPolynomial_nonorigin_has_nonzero_coordinates + (alpha beta : K) (d e : ℕ) (hd : 0 < d) (he : 0 < e) (hbeta : beta ≠ 0) + (x y : K) + (hzero : MvPolynomial.eval ![x, y] (splitTraceCoverPolynomial alpha beta d e) = 0) + (hnonorigin : (x, y) ≠ (0, 0)) : + x ≠ 0 ∧ y ≠ 0 := by + constructor + · intro hx + exact hnonorigin (Prod.ext hx + (splitTraceCoverPolynomial_axis_zero_eq_origin alpha beta d e hd he hbeta x y hzero + (Or.inl hx)).2) + · intro hy + exact hnonorigin (Prod.ext + (splitTraceCoverPolynomial_axis_zero_eq_origin alpha beta d e hd he hbeta x y hzero + (Or.inr hy)).1 hy) + +end Boundary + +section FiniteBoundaryCount + +variable (K : Type*) [Field K] [Fintype K] [DecidableEq K] + +/-- Affine zeros of the denominator-cleared split trace polynomial. -/ +noncomputable def affineSplitTraceCoverZeros + (alpha beta : K) (d e : ℕ) : Finset (K × K) := by + classical + exact Finset.univ.filter fun z => + MvPolynomial.eval ![z.1, z.2] (splitTraceCoverPolynomial alpha beta d e) = 0 + +/-- Zeros of the cleared polynomial that lie on the original two-dimensional torus. -/ +noncomputable def torusSplitTraceCoverZeros + (alpha beta : K) (d e : ℕ) : Finset (K × K) := by + classical + exact (affineSplitTraceCoverZeros K alpha beta d e).filter fun z => + z.1 ≠ 0 ∧ z.2 ≠ 0 + +/-- Solutions of the original Laurent trace equation, represented on `Kˣ × Kˣ` rather +than in the denominator-cleared affine plane. -/ +noncomputable def splitTraceCurveSolutions + (alpha beta : K) (d e : ℕ) : Finset (Kˣ × Kˣ) := by + classical + exact Finset.univ.filter fun z => SplitTraceCurveEquation alpha beta d e z.1 z.2 + +@[simp] +theorem mem_affineSplitTraceCoverZeros_iff + (alpha beta : K) (d e : ℕ) (z : K × K) : + z ∈ affineSplitTraceCoverZeros K alpha beta d e ↔ + MvPolynomial.eval ![z.1, z.2] (splitTraceCoverPolynomial alpha beta d e) = 0 := by + classical + simp [affineSplitTraceCoverZeros] + +@[simp] +theorem mem_torusSplitTraceCoverZeros_iff + (alpha beta : K) (d e : ℕ) (z : K × K) : + z ∈ torusSplitTraceCoverZeros K alpha beta d e ↔ + MvPolynomial.eval ![z.1, z.2] (splitTraceCoverPolynomial alpha beta d e) = 0 ∧ + z.1 ≠ 0 ∧ z.2 ≠ 0 := by + classical + simp [torusSplitTraceCoverZeros] + +@[simp] +theorem mem_splitTraceCurveSolutions_iff + (alpha beta : K) (d e : ℕ) (z : Kˣ × Kˣ) : + z ∈ splitTraceCurveSolutions K alpha beta d e ↔ + SplitTraceCurveEquation alpha beta d e z.1 z.2 := by + classical + simp [splitTraceCurveSolutions] + +/-- The nonzero affine zeros of the cleared polynomial and the solutions of the original Laurent +equation have exactly the same cardinality. This is the finite-field bridge needed before a +point estimate for one model can be used for the other. -/ +theorem torusSplitTraceCoverZeros_card_eq_splitTraceCurveSolutions_card + (alpha beta : K) (d e : ℕ) : + (torusSplitTraceCoverZeros K alpha beta d e).card = + (splitTraceCurveSolutions K alpha beta d e).card := by + classical + symm + apply Finset.card_bij + (fun z (_hz : z ∈ splitTraceCurveSolutions K alpha beta d e) => + (((z.1 : K), (z.2 : K)) : K × K)) + · intro z hz + rw [mem_torusSplitTraceCoverZeros_iff] + refine ⟨(eval_splitTraceCoverPolynomial_eq_zero_iff alpha beta d e z.1 z.2).2 ?_, + z.1.ne_zero, z.2.ne_zero⟩ + exact (mem_splitTraceCurveSolutions_iff K alpha beta d e z).1 hz + · intro z₁ hz₁ z₂ hz₂ heq + apply Prod.ext + · apply Units.ext + exact congrArg Prod.fst heq + · apply Units.ext + exact congrArg Prod.snd heq + · intro z hz + rw [mem_torusSplitTraceCoverZeros_iff] at hz + let ux : Kˣ := Units.mk0 z.1 hz.2.1 + let uy : Kˣ := Units.mk0 z.2 hz.2.2 + refine ⟨(ux, uy), ?_, ?_⟩ + · rw [mem_splitTraceCurveSolutions_iff] + exact (eval_splitTraceCoverPolynomial_eq_zero_iff alpha beta d e ux uy).1 (by + simpa [ux, uy] using hz.1) + · simp [ux, uy] + +/-- Erasing the unique coordinate-axis point from the affine zero set leaves exactly the genuine +torus zero set. -/ +theorem affineSplitTraceCoverZeros_erase_origin + (alpha beta : K) (d e : ℕ) (hd : 0 < d) (he : 0 < e) (hbeta : beta ≠ 0) : + (affineSplitTraceCoverZeros K alpha beta d e).erase ((0, 0) : K × K) = + torusSplitTraceCoverZeros K alpha beta d e := by + classical + ext z + simp only [Finset.mem_erase, mem_affineSplitTraceCoverZeros_iff, + mem_torusSplitTraceCoverZeros_iff] + constructor + · rintro ⟨hnonorigin, hz⟩ + exact ⟨hz, + splitTraceCoverPolynomial_nonorigin_has_nonzero_coordinates alpha beta d e hd he hbeta + z.1 z.2 hz (by simpa using hnonorigin)⟩ + · rintro ⟨hz, hx, hy⟩ + refine ⟨?_, hz⟩ + intro horigin + exact hx (congrArg Prod.fst horigin) + +/-- Clearing Laurent denominators adds exactly one affine point. This is the exact boundary +correction required when a point estimate for the affine polynomial is converted to the torus +count used in the paper's endgame. -/ +theorem affineSplitTraceCoverZeros_card_eq_torus_card_add_one + (alpha beta : K) (d e : ℕ) (hd : 0 < d) (he : 0 < e) (hbeta : beta ≠ 0) : + (affineSplitTraceCoverZeros K alpha beta d e).card = + (torusSplitTraceCoverZeros K alpha beta d e).card + 1 := by + classical + have horiginMem : ((0, 0) : K × K) ∈ + affineSplitTraceCoverZeros K alpha beta d e := by + rw [mem_affineSplitTraceCoverZeros_iff] + exact splitTraceCoverPolynomial_origin_zero alpha beta d e hd he + rw [← affineSplitTraceCoverZeros_erase_origin K alpha beta d e hd he hbeta] + exact (Finset.card_erase_add_one horiginMem).symm + +end FiniteBoundaryCount + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/Characteristic.lean b/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/Characteristic.lean new file mode 100644 index 0000000000..eb74216217 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/Characteristic.lean @@ -0,0 +1,75 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.Geometry +public import Mathlib.Algebra.CharP.Lemmas + +/-! +# The characteristic restriction in the split trace-cover lemma + +The published absolute-irreducibility statement for the split trace cover does not require the +covering exponents to be prime to the characteristic. This omission is substantive: when both +exponents equal the positive characteristic, the cleared trace polynomial is a Frobenius power. + +This file records the obstruction directly on the polynomial used by the endgame. It is kept +separate from the positive Kummer descent: the theorem below is a counterexample to an omitted +hypothesis, not another assumption on which downstream formalization may rely. +-/ + +@[expose] public section + +namespace BGS.Markoff + +open Polynomial + +variable {K : Type*} [Field K] + +/-- Simultaneously multiplying both covering exponents by the characteristic turns the cover +with Frobenius-powered coefficients into a Frobenius power. -/ +theorem splitTraceCoverPolynomial_frobenius_pullback + (alpha beta : K) (d e p : ℕ) [Fact p.Prime] [CharP K p] : + splitTraceCoverPolynomial (alpha ^ p) (beta ^ p) (p * d) (p * e) = + (splitTraceCoverPolynomial alpha beta d e) ^ p := by + simp only [splitTraceCoverPolynomial] + rw [sub_pow_char, sub_pow_char, add_pow_char, mul_pow, mul_pow, mul_pow, mul_pow] + simp only [pow_mul] + have hpd : p * d = d * p := Nat.mul_comm p d + have hpe : p * e = e * p := Nat.mul_comm p e + have htwoPD : 2 * p * d = 2 * d * p := by ac_rfl + have htwoPE : 2 * p * e = 2 * e * p := by ac_rfl + simp only [← pow_mul, hpd, hpe, htwoPD, htwoPE] + simp only [MvPolynomial.C_pow] + +/-- In characteristic `p`, the trace-cover polynomial with both exponents `p` is the `p`-th +power of its degree-one counterpart. The parameters `(1, 0)` satisfy the published conditions +"not both zero" and `alpha * beta ≠ 1`. -/ +theorem splitTraceCoverPolynomial_frobenius_factorization + (p : ℕ) [Fact p.Prime] [CharP K p] : + splitTraceCoverPolynomial (1 : K) 0 p p = + (splitTraceCoverPolynomial (1 : K) 0 1 1) ^ p := by + simpa [zero_pow (Fact.out : p.Prime).ne_zero] using + splitTraceCoverPolynomial_frobenius_pullback (K := K) 1 0 1 1 p + +/-- Therefore the published irreducibility conclusion is false without a restriction excluding +covering exponents divisible by the characteristic. This is reducibility over the ground field, +so in particular it also rules out absolute irreducibility. -/ +theorem splitTraceCoverPolynomial_not_irreducible_when_exponents_equal_char + (p : ℕ) [Fact p.Prime] [CharP K p] : + ¬ Irreducible (splitTraceCoverPolynomial (1 : K) 0 p p) := by + rw [splitTraceCoverPolynomial_frobenius_factorization] + exact not_irreducible_pow (Fact.out : p.Prime).ne_one + +/-- A direct formal counterexample to Lemma 11 as printed: its two parameter hypotheses hold, +but the conclusion fails when both covering exponents equal the characteristic. -/ +theorem publishedTraceCoverIrreducibility_requiresCharacteristicHypothesis + (p : ℕ) [Fact p.Prime] [CharP K p] : + (((1 : K) ≠ 0 ∨ (0 : K) ≠ 0) ∧ (1 : K) * 0 ≠ 1) ∧ + ¬ Irreducible (splitTraceCoverPolynomial (1 : K) 0 p p) := by + exact ⟨by simp, splitTraceCoverPolynomial_not_irreducible_when_exponents_equal_char p⟩ + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/ChartLocalization.lean b/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/ChartLocalization.lean new file mode 100644 index 0000000000..3686b4b2a7 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/ChartLocalization.lean @@ -0,0 +1,580 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.AffineNormalization +public import Mathlib.RingTheory.Localization.Away.Basic + +/-! +# Localized transition maps for the weighted trace-cover charts + +The four standard charts of the biprojective trace cover have two affine coordinate rings, +corresponding to the weight orders `(alpha, beta)` and `(beta, alpha)`. This file localizes each +ring away from the coordinate axes and constructs the actual algebra isomorphisms induced by +`x ↦ x⁻¹` and `y ↦ y⁻¹`. + +These are coordinate-ring isomorphisms, not merely equivalences of torus-valued points. The next +geometric wall is to identify these localizations with overlap opens in the affine normalizations +and use the maps in a scheme-gluing datum. +-/ + +@[expose] public section + +namespace BGS.Markoff + +noncomputable section + +variable {K : Type*} [Field K] + +def weightedSplitTraceAffineX (alpha beta : K) (d e : ℕ) : + WeightedSplitTraceAffineCoordinateRing alpha beta d e := + Ideal.Quotient.mk _ (MvPolynomial.X 0) + +def weightedSplitTraceAffineY (alpha beta : K) (d e : ℕ) : + WeightedSplitTraceAffineCoordinateRing alpha beta d e := + Ideal.Quotient.mk _ (MvPolynomial.X 1) + +def weightedSplitTraceAffineCoordinateProduct (alpha beta : K) (d e : ℕ) : + WeightedSplitTraceAffineCoordinateRing alpha beta d e := + weightedSplitTraceAffineX alpha beta d e * weightedSplitTraceAffineY alpha beta d e + +abbrev WeightedSplitTraceLaurentCoordinateRing (alpha beta : K) (d e : ℕ) := + Localization.Away (weightedSplitTraceAffineCoordinateProduct alpha beta d e) + +def weightedSplitTraceLaurentX (alpha beta : K) (d e : ℕ) : WeightedSplitTraceLaurentCoordinateRing alpha beta d e := + algebraMap _ _ (weightedSplitTraceAffineX alpha beta d e) + +def weightedSplitTraceLaurentY (alpha beta : K) (d e : ℕ) : WeightedSplitTraceLaurentCoordinateRing alpha beta d e := + algebraMap _ _ (weightedSplitTraceAffineY alpha beta d e) + +theorem weightedSplitTraceLaurentCoordinateProduct_isUnit (alpha beta : K) (d e : ℕ) : + IsUnit (weightedSplitTraceLaurentX alpha beta d e * weightedSplitTraceLaurentY alpha beta d e) := by + simpa only [weightedSplitTraceLaurentX, weightedSplitTraceLaurentY, weightedSplitTraceAffineCoordinateProduct, map_mul] using + (IsLocalization.Away.algebraMap_isUnit + (S := WeightedSplitTraceLaurentCoordinateRing alpha beta d e) (weightedSplitTraceAffineCoordinateProduct alpha beta d e)) + +theorem weightedSplitTraceLaurentX_isUnit (alpha beta : K) (d e : ℕ) : + IsUnit (weightedSplitTraceLaurentX alpha beta d e) := + ((Commute.all _ _).isUnit_mul_iff.mp + (weightedSplitTraceLaurentCoordinateProduct_isUnit alpha beta d e)).1 + +theorem weightedSplitTraceLaurentY_isUnit (alpha beta : K) (d e : ℕ) : + IsUnit (weightedSplitTraceLaurentY alpha beta d e) := + ((Commute.all _ _).isUnit_mul_iff.mp + (weightedSplitTraceLaurentCoordinateProduct_isUnit alpha beta d e)).2 + +def weightedSplitTraceLaurentXUnit (alpha beta : K) (d e : ℕ) : + (WeightedSplitTraceLaurentCoordinateRing alpha beta d e)ˣ := + (weightedSplitTraceLaurentX_isUnit alpha beta d e).unit + +def weightedSplitTraceLaurentYUnit (alpha beta : K) (d e : ℕ) : + (WeightedSplitTraceLaurentCoordinateRing alpha beta d e)ˣ := + (weightedSplitTraceLaurentY_isUnit alpha beta d e).unit + +@[simp] +theorem weightedSplitTraceLaurentXUnit_val (alpha beta : K) (d e : ℕ) : + (weightedSplitTraceLaurentXUnit alpha beta d e : WeightedSplitTraceLaurentCoordinateRing alpha beta d e) = + weightedSplitTraceLaurentX alpha beta d e := + (weightedSplitTraceLaurentX_isUnit alpha beta d e).unit_spec + +@[simp] +theorem weightedSplitTraceLaurentYUnit_val (alpha beta : K) (d e : ℕ) : + (weightedSplitTraceLaurentYUnit alpha beta d e : WeightedSplitTraceLaurentCoordinateRing alpha beta d e) = + weightedSplitTraceLaurentY alpha beta d e := + (weightedSplitTraceLaurentY_isUnit alpha beta d e).unit_spec + +def weightedSplitTraceLaurentXInverse (alpha beta : K) (d e : ℕ) : + WeightedSplitTraceLaurentCoordinateRing alpha beta d e := + ↑(weightedSplitTraceLaurentXUnit alpha beta d e)⁻¹ + +def weightedSplitTraceLaurentYInverse (alpha beta : K) (d e : ℕ) : + WeightedSplitTraceLaurentCoordinateRing alpha beta d e := + ↑(weightedSplitTraceLaurentYUnit alpha beta d e)⁻¹ + +theorem weightedSplitTraceAffineDefiningRelation (alpha beta : K) (d e : ℕ) : + Ideal.Quotient.mk (Ideal.span {splitTraceCoverPolynomial alpha beta d e}) + (splitTraceCoverPolynomial alpha beta d e) = 0 := by + rw [Ideal.Quotient.eq_zero_iff_mem] + exact Ideal.subset_span (Set.mem_singleton _) + +theorem weightedSplitTraceLaurentDefiningRelation (alpha beta : K) (d e : ℕ) : + algebraMap K (WeightedSplitTraceLaurentCoordinateRing alpha beta d e) alpha * + weightedSplitTraceLaurentX alpha beta d e ^ d * weightedSplitTraceLaurentY alpha beta d e ^ (2 * e) + + algebraMap K (WeightedSplitTraceLaurentCoordinateRing alpha beta d e) beta * + weightedSplitTraceLaurentX alpha beta d e ^ d - + weightedSplitTraceLaurentX alpha beta d e ^ (2 * d) * weightedSplitTraceLaurentY alpha beta d e ^ e - + weightedSplitTraceLaurentY alpha beta d e ^ e = 0 := by + let ev : MvPolynomial (Fin 2) K →+* WeightedSplitTraceLaurentCoordinateRing alpha beta d e := + MvPolynomial.eval₂Hom (algebraMap K (WeightedSplitTraceLaurentCoordinateRing alpha beta d e)) + ![weightedSplitTraceLaurentX alpha beta d e, weightedSplitTraceLaurentY alpha beta d e] + have hev : ev = + (algebraMap (WeightedSplitTraceAffineCoordinateRing alpha beta d e) + (WeightedSplitTraceLaurentCoordinateRing alpha beta d e)).comp + (Ideal.Quotient.mk (Ideal.span {splitTraceCoverPolynomial alpha beta d e})) := by + ext a + · simp only [RingHom.comp_apply, ev, MvPolynomial.eval₂Hom_C] + exact IsScalarTower.algebraMap_apply K + (WeightedSplitTraceAffineCoordinateRing alpha beta d e) + (WeightedSplitTraceLaurentCoordinateRing alpha beta d e) a + · fin_cases a <;> + simp [RingHom.comp_apply, ev, weightedSplitTraceLaurentX, weightedSplitTraceLaurentY, weightedSplitTraceAffineX, weightedSplitTraceAffineY] + have hp : ev (splitTraceCoverPolynomial alpha beta d e) = 0 := by + rw [hev] + simpa only [RingHom.comp_apply, map_zero] using congrArg + (algebraMap (WeightedSplitTraceAffineCoordinateRing alpha beta d e) + (WeightedSplitTraceLaurentCoordinateRing alpha beta d e)) + (weightedSplitTraceAffineDefiningRelation alpha beta d e) + simpa [ev, splitTraceCoverPolynomial] using hp + +theorem weightedSplitTraceLeftInverseDefiningRelation (alpha beta : K) (d e : ℕ) : + algebraMap K (WeightedSplitTraceLaurentCoordinateRing alpha beta d e) alpha * + weightedSplitTraceLaurentXInverse alpha beta d e ^ d * + weightedSplitTraceLaurentY alpha beta d e ^ (2 * e) + + algebraMap K (WeightedSplitTraceLaurentCoordinateRing alpha beta d e) beta * + weightedSplitTraceLaurentXInverse alpha beta d e ^ d - + weightedSplitTraceLaurentXInverse alpha beta d e ^ (2 * d) * + weightedSplitTraceLaurentY alpha beta d e ^ e - + weightedSplitTraceLaurentY alpha beta d e ^ e = 0 := by + let u := weightedSplitTraceLaurentXUnit alpha beta d e + have hcancel : + ((↑(u⁻¹) : WeightedSplitTraceLaurentCoordinateRing alpha beta d e) ^ (2 * d)) * + ((↑u : WeightedSplitTraceLaurentCoordinateRing alpha beta d e) ^ d) = + (↑(u⁻¹) : WeightedSplitTraceLaurentCoordinateRing alpha beta d e) ^ d := by + norm_cast + simp [two_mul, pow_add] + have hcancelTwo : + ((↑(u⁻¹) : WeightedSplitTraceLaurentCoordinateRing alpha beta d e) ^ (2 * d)) * + ((↑u : WeightedSplitTraceLaurentCoordinateRing alpha beta d e) ^ (2 * d)) = 1 := by + norm_cast + simp + dsimp [u] at hcancel hcancelTwo + calc + algebraMap K (WeightedSplitTraceLaurentCoordinateRing alpha beta d e) alpha * + weightedSplitTraceLaurentXInverse alpha beta d e ^ d * + weightedSplitTraceLaurentY alpha beta d e ^ (2 * e) + + algebraMap K (WeightedSplitTraceLaurentCoordinateRing alpha beta d e) beta * + weightedSplitTraceLaurentXInverse alpha beta d e ^ d - + weightedSplitTraceLaurentXInverse alpha beta d e ^ (2 * d) * + weightedSplitTraceLaurentY alpha beta d e ^ e - + weightedSplitTraceLaurentY alpha beta d e ^ e = + weightedSplitTraceLaurentXInverse alpha beta d e ^ (2 * d) * + (algebraMap K (WeightedSplitTraceLaurentCoordinateRing alpha beta d e) alpha * + weightedSplitTraceLaurentX alpha beta d e ^ d * + weightedSplitTraceLaurentY alpha beta d e ^ (2 * e) + + algebraMap K (WeightedSplitTraceLaurentCoordinateRing alpha beta d e) beta * + weightedSplitTraceLaurentX alpha beta d e ^ d - + weightedSplitTraceLaurentX alpha beta d e ^ (2 * d) * + weightedSplitTraceLaurentY alpha beta d e ^ e - + weightedSplitTraceLaurentY alpha beta d e ^ e) := by + dsimp [weightedSplitTraceLaurentXInverse] + rw [← weightedSplitTraceLaurentXUnit_val] + linear_combination + -(algebraMap K (WeightedSplitTraceLaurentCoordinateRing alpha beta d e) alpha * + weightedSplitTraceLaurentY alpha beta d e ^ (2 * e)) * hcancel - + algebraMap K (WeightedSplitTraceLaurentCoordinateRing alpha beta d e) beta * hcancel + + weightedSplitTraceLaurentY alpha beta d e ^ e * hcancelTwo + _ = 0 := by rw [weightedSplitTraceLaurentDefiningRelation, mul_zero] + +def weightedSplitTraceLeftInversionPolynomialMap (alpha beta : K) (d e : ℕ) : + MvPolynomial (Fin 2) K →ₐ[K] WeightedSplitTraceLaurentCoordinateRing alpha beta d e := + MvPolynomial.aeval + ![weightedSplitTraceLaurentXInverse alpha beta d e, weightedSplitTraceLaurentY alpha beta d e] + +theorem weightedSplitTraceLeftInversionPolynomialMap_relation (alpha beta : K) (d e : ℕ) : + weightedSplitTraceLeftInversionPolynomialMap alpha beta d e + (splitTraceCoverPolynomial alpha beta d e) = 0 := by + simpa [weightedSplitTraceLeftInversionPolynomialMap, MvPolynomial.aeval_def, splitTraceCoverPolynomial] using + weightedSplitTraceLeftInverseDefiningRelation alpha beta d e + +def weightedSplitTraceLeftInversionAffineMap (alpha beta : K) (d e : ℕ) : + WeightedSplitTraceAffineCoordinateRing alpha beta d e →ₐ[K] + WeightedSplitTraceLaurentCoordinateRing alpha beta d e := by + refine Ideal.Quotient.liftₐ + (Ideal.span {splitTraceCoverPolynomial alpha beta d e}) + (weightedSplitTraceLeftInversionPolynomialMap alpha beta d e) ?_ + intro p hp + have hle : Ideal.span {splitTraceCoverPolynomial alpha beta d e} ≤ + RingHom.ker (weightedSplitTraceLeftInversionPolynomialMap alpha beta d e).toRingHom := by + rw [Ideal.span_le] + intro q hq + simp only [Set.mem_singleton_iff] at hq + subst q + exact weightedSplitTraceLeftInversionPolynomialMap_relation alpha beta d e + exact hle hp + +@[simp] +theorem weightedSplitTraceLeftInversionAffineMap_x (alpha beta : K) (d e : ℕ) : + weightedSplitTraceLeftInversionAffineMap alpha beta d e (weightedSplitTraceAffineX alpha beta d e) = + weightedSplitTraceLaurentXInverse alpha beta d e := by + change MvPolynomial.aeval + ![weightedSplitTraceLaurentXInverse alpha beta d e, + weightedSplitTraceLaurentY alpha beta d e] (MvPolynomial.X 0) = _ + simp + +@[simp] +theorem weightedSplitTraceLeftInversionAffineMap_y (alpha beta : K) (d e : ℕ) : + weightedSplitTraceLeftInversionAffineMap alpha beta d e (weightedSplitTraceAffineY alpha beta d e) = + weightedSplitTraceLaurentY alpha beta d e := by + change MvPolynomial.aeval + ![weightedSplitTraceLaurentXInverse alpha beta d e, + weightedSplitTraceLaurentY alpha beta d e] (MvPolynomial.X 1) = _ + simp + +theorem weightedSplitTraceLeftInversionAffineMap_coordinateProduct_isUnit (alpha beta : K) (d e : ℕ) : + IsUnit (weightedSplitTraceLeftInversionAffineMap alpha beta d e (weightedSplitTraceAffineCoordinateProduct alpha beta d e)) := by + simpa [weightedSplitTraceAffineCoordinateProduct, weightedSplitTraceLaurentXInverse] using + (Units.isUnit (weightedSplitTraceLaurentXUnit alpha beta d e)⁻¹).mul + (weightedSplitTraceLaurentY_isUnit alpha beta d e) + +def weightedSplitTraceLeftInversionLaurentMap (alpha beta : K) (d e : ℕ) : + WeightedSplitTraceLaurentCoordinateRing alpha beta d e →ₐ[K] WeightedSplitTraceLaurentCoordinateRing alpha beta d e := + IsLocalization.Away.liftAlgHom (weightedSplitTraceAffineCoordinateProduct alpha beta d e) + (weightedSplitTraceLeftInversionAffineMap_coordinateProduct_isUnit alpha beta d e) + +@[simp] +theorem weightedSplitTraceLeftInversionLaurentMap_x (alpha beta : K) (d e : ℕ) : + weightedSplitTraceLeftInversionLaurentMap alpha beta d e (weightedSplitTraceLaurentX alpha beta d e) = + weightedSplitTraceLaurentXInverse alpha beta d e := by + simp only [weightedSplitTraceLeftInversionLaurentMap, weightedSplitTraceLaurentX, IsLocalization.Away.liftAlgHom_apply] + rw [IsLocalization.Away.lift_eq] + exact weightedSplitTraceLeftInversionAffineMap_x alpha beta d e + +@[simp] +theorem weightedSplitTraceLeftInversionLaurentMap_y (alpha beta : K) (d e : ℕ) : + weightedSplitTraceLeftInversionLaurentMap alpha beta d e (weightedSplitTraceLaurentY alpha beta d e) = + weightedSplitTraceLaurentY alpha beta d e := by + simp only [weightedSplitTraceLeftInversionLaurentMap, weightedSplitTraceLaurentY, IsLocalization.Away.liftAlgHom_apply] + rw [IsLocalization.Away.lift_eq] + exact weightedSplitTraceLeftInversionAffineMap_y alpha beta d e + +@[simp] +theorem weightedSplitTraceLeftInversionLaurentMap_xInverse (alpha beta : K) (d e : ℕ) : + weightedSplitTraceLeftInversionLaurentMap alpha beta d e (weightedSplitTraceLaurentXInverse alpha beta d e) = + weightedSplitTraceLaurentX alpha beta d e := by + let u := weightedSplitTraceLaurentXUnit alpha beta d e + let f := weightedSplitTraceLeftInversionLaurentMap alpha beta d e + have hu : Units.map f.toMonoidHom u = u⁻¹ := by + ext + simp [f, u, weightedSplitTraceLaurentXInverse] + change f (↑(u⁻¹) : WeightedSplitTraceLaurentCoordinateRing alpha beta d e) = + (↑u : WeightedSplitTraceLaurentCoordinateRing alpha beta d e) + calc + f (↑(u⁻¹) : WeightedSplitTraceLaurentCoordinateRing alpha beta d e) = + ↑(Units.map f.toMonoidHom (u⁻¹)) := + (Units.coe_map f.toMonoidHom (u⁻¹)).symm + _ = ↑((Units.map f.toMonoidHom u)⁻¹) := by rw [map_inv] + _ = ↑((u⁻¹)⁻¹) := by rw [hu] + _ = (↑u : WeightedSplitTraceLaurentCoordinateRing alpha beta d e) := by simp + +@[simp] +theorem weightedSplitTraceLeftInversionLaurentMap_yInverse + (alpha beta : K) (d e : ℕ) : + weightedSplitTraceLeftInversionLaurentMap alpha beta d e + (weightedSplitTraceLaurentYInverse alpha beta d e) = + weightedSplitTraceLaurentYInverse alpha beta d e := by + let u := weightedSplitTraceLaurentYUnit alpha beta d e + let f := weightedSplitTraceLeftInversionLaurentMap alpha beta d e + have hu : Units.map f.toMonoidHom u = u := by + ext + simp [f, u] + change f (↑(u⁻¹) : WeightedSplitTraceLaurentCoordinateRing alpha beta d e) = + (↑(u⁻¹) : WeightedSplitTraceLaurentCoordinateRing alpha beta d e) + calc + f (↑(u⁻¹) : WeightedSplitTraceLaurentCoordinateRing alpha beta d e) = + ↑(Units.map f.toMonoidHom (u⁻¹)) := + (Units.coe_map f.toMonoidHom (u⁻¹)).symm + _ = ↑((Units.map f.toMonoidHom u)⁻¹) := by rw [map_inv] + _ = (↑(u⁻¹) : WeightedSplitTraceLaurentCoordinateRing alpha beta d e) := by rw [hu] + +theorem weightedSplitTraceLeftInversionLaurentMap_involutive (alpha beta : K) (d e : ℕ) : + (weightedSplitTraceLeftInversionLaurentMap alpha beta d e).comp + (weightedSplitTraceLeftInversionLaurentMap alpha beta d e) = + AlgHom.id K (WeightedSplitTraceLaurentCoordinateRing alpha beta d e) := by + apply IsLocalization.algHom_ext + (Submonoid.powers (weightedSplitTraceAffineCoordinateProduct alpha beta d e)) + apply Ideal.Quotient.algHom_ext K + apply MvPolynomial.algHom_ext + intro i + fin_cases i + · change weightedSplitTraceLeftInversionLaurentMap alpha beta d e + (weightedSplitTraceLeftInversionLaurentMap alpha beta d e (weightedSplitTraceLaurentX alpha beta d e)) = + weightedSplitTraceLaurentX alpha beta d e + rw [weightedSplitTraceLeftInversionLaurentMap_x, weightedSplitTraceLeftInversionLaurentMap_xInverse] + · change weightedSplitTraceLeftInversionLaurentMap alpha beta d e + (weightedSplitTraceLeftInversionLaurentMap alpha beta d e (weightedSplitTraceLaurentY alpha beta d e)) = + weightedSplitTraceLaurentY alpha beta d e + rw [weightedSplitTraceLeftInversionLaurentMap_y, weightedSplitTraceLeftInversionLaurentMap_y] + +def weightedSplitTraceLeftInversionLaurentEquiv (alpha beta : K) (d e : ℕ) : + WeightedSplitTraceLaurentCoordinateRing alpha beta d e ≃ₐ[K] WeightedSplitTraceLaurentCoordinateRing alpha beta d e := + AlgEquiv.ofAlgHom (weightedSplitTraceLeftInversionLaurentMap alpha beta d e) + (weightedSplitTraceLeftInversionLaurentMap alpha beta d e) + (weightedSplitTraceLeftInversionLaurentMap_involutive alpha beta d e) + (weightedSplitTraceLeftInversionLaurentMap_involutive alpha beta d e) + +/-! ### The weight-swapping second-coordinate transition -/ + +/-- Substituting `y⁻¹` changes the defining equation with weights `(alpha, beta)` into the +defining equation with weights `(beta, alpha)`. -/ +theorem weightedSplitTraceRightInverseDefiningRelation + (alpha beta : K) (d e : ℕ) : + algebraMap K (WeightedSplitTraceLaurentCoordinateRing alpha beta d e) beta * + weightedSplitTraceLaurentX alpha beta d e ^ d * + weightedSplitTraceLaurentYInverse alpha beta d e ^ (2 * e) + + algebraMap K (WeightedSplitTraceLaurentCoordinateRing alpha beta d e) alpha * + weightedSplitTraceLaurentX alpha beta d e ^ d - + weightedSplitTraceLaurentX alpha beta d e ^ (2 * d) * + weightedSplitTraceLaurentYInverse alpha beta d e ^ e - + weightedSplitTraceLaurentYInverse alpha beta d e ^ e = 0 := by + let u := weightedSplitTraceLaurentYUnit alpha beta d e + have hcancel : + ((↑(u⁻¹) : WeightedSplitTraceLaurentCoordinateRing alpha beta d e) ^ (2 * e)) * + ((↑u : WeightedSplitTraceLaurentCoordinateRing alpha beta d e) ^ e) = + (↑(u⁻¹) : WeightedSplitTraceLaurentCoordinateRing alpha beta d e) ^ e := by + norm_cast + simp [two_mul, pow_add] + have hcancelTwo : + ((↑(u⁻¹) : WeightedSplitTraceLaurentCoordinateRing alpha beta d e) ^ (2 * e)) * + ((↑u : WeightedSplitTraceLaurentCoordinateRing alpha beta d e) ^ (2 * e)) = 1 := by + norm_cast + simp + dsimp [u] at hcancel hcancelTwo + calc + algebraMap K (WeightedSplitTraceLaurentCoordinateRing alpha beta d e) beta * + weightedSplitTraceLaurentX alpha beta d e ^ d * + weightedSplitTraceLaurentYInverse alpha beta d e ^ (2 * e) + + algebraMap K (WeightedSplitTraceLaurentCoordinateRing alpha beta d e) alpha * + weightedSplitTraceLaurentX alpha beta d e ^ d - + weightedSplitTraceLaurentX alpha beta d e ^ (2 * d) * + weightedSplitTraceLaurentYInverse alpha beta d e ^ e - + weightedSplitTraceLaurentYInverse alpha beta d e ^ e = + weightedSplitTraceLaurentYInverse alpha beta d e ^ (2 * e) * + (algebraMap K (WeightedSplitTraceLaurentCoordinateRing alpha beta d e) alpha * + weightedSplitTraceLaurentX alpha beta d e ^ d * + weightedSplitTraceLaurentY alpha beta d e ^ (2 * e) + + algebraMap K (WeightedSplitTraceLaurentCoordinateRing alpha beta d e) beta * + weightedSplitTraceLaurentX alpha beta d e ^ d - + weightedSplitTraceLaurentX alpha beta d e ^ (2 * d) * + weightedSplitTraceLaurentY alpha beta d e ^ e - + weightedSplitTraceLaurentY alpha beta d e ^ e) := by + dsimp [weightedSplitTraceLaurentYInverse] + rw [← weightedSplitTraceLaurentYUnit_val] + linear_combination + (weightedSplitTraceLaurentX alpha beta d e ^ (2 * d) + 1) * hcancel - + (algebraMap K (WeightedSplitTraceLaurentCoordinateRing alpha beta d e) alpha * + weightedSplitTraceLaurentX alpha beta d e ^ d) * hcancelTwo + _ = 0 := by rw [weightedSplitTraceLaurentDefiningRelation, mul_zero] + +/-- Polynomial substitution defining the second-coordinate transition from the swapped chart. -/ +def weightedSplitTraceRightInversionPolynomialMap (alpha beta : K) (d e : ℕ) : + MvPolynomial (Fin 2) K →ₐ[K] + WeightedSplitTraceLaurentCoordinateRing alpha beta d e := + MvPolynomial.aeval + ![weightedSplitTraceLaurentX alpha beta d e, + weightedSplitTraceLaurentYInverse alpha beta d e] + +theorem weightedSplitTraceRightInversionPolynomialMap_relation + (alpha beta : K) (d e : ℕ) : + weightedSplitTraceRightInversionPolynomialMap alpha beta d e + (splitTraceCoverPolynomial beta alpha d e) = 0 := by + simpa [weightedSplitTraceRightInversionPolynomialMap, MvPolynomial.aeval_def, + splitTraceCoverPolynomial] using + weightedSplitTraceRightInverseDefiningRelation alpha beta d e + +/-- The swapped affine chart maps to the original Laurent chart by `x ↦ x`, `y ↦ y⁻¹`. -/ +def weightedSplitTraceRightInversionAffineMap (alpha beta : K) (d e : ℕ) : + WeightedSplitTraceAffineCoordinateRing beta alpha d e →ₐ[K] + WeightedSplitTraceLaurentCoordinateRing alpha beta d e := by + refine Ideal.Quotient.liftₐ + (Ideal.span {splitTraceCoverPolynomial beta alpha d e}) + (weightedSplitTraceRightInversionPolynomialMap alpha beta d e) ?_ + intro p hp + have hle : Ideal.span {splitTraceCoverPolynomial beta alpha d e} ≤ + RingHom.ker + (weightedSplitTraceRightInversionPolynomialMap alpha beta d e).toRingHom := by + rw [Ideal.span_le] + intro q hq + simp only [Set.mem_singleton_iff] at hq + subst q + exact weightedSplitTraceRightInversionPolynomialMap_relation alpha beta d e + exact hle hp + +@[simp] +theorem weightedSplitTraceRightInversionAffineMap_x + (alpha beta : K) (d e : ℕ) : + weightedSplitTraceRightInversionAffineMap alpha beta d e + (weightedSplitTraceAffineX beta alpha d e) = + weightedSplitTraceLaurentX alpha beta d e := by + change MvPolynomial.aeval + ![weightedSplitTraceLaurentX alpha beta d e, + weightedSplitTraceLaurentYInverse alpha beta d e] (MvPolynomial.X 0) = _ + simp + +@[simp] +theorem weightedSplitTraceRightInversionAffineMap_y + (alpha beta : K) (d e : ℕ) : + weightedSplitTraceRightInversionAffineMap alpha beta d e + (weightedSplitTraceAffineY beta alpha d e) = + weightedSplitTraceLaurentYInverse alpha beta d e := by + change MvPolynomial.aeval + ![weightedSplitTraceLaurentX alpha beta d e, + weightedSplitTraceLaurentYInverse alpha beta d e] (MvPolynomial.X 1) = _ + simp + +theorem weightedSplitTraceRightInversionAffineMap_coordinateProduct_isUnit + (alpha beta : K) (d e : ℕ) : + IsUnit (weightedSplitTraceRightInversionAffineMap alpha beta d e + (weightedSplitTraceAffineCoordinateProduct beta alpha d e)) := by + simpa [weightedSplitTraceAffineCoordinateProduct, + weightedSplitTraceLaurentYInverse] using + (weightedSplitTraceLaurentX_isUnit alpha beta d e).mul + (Units.isUnit (weightedSplitTraceLaurentYUnit alpha beta d e)⁻¹) + +/-- The localized coordinate-ring map for second-coordinate inversion. -/ +def weightedSplitTraceRightInversionLaurentMap (alpha beta : K) (d e : ℕ) : + WeightedSplitTraceLaurentCoordinateRing beta alpha d e →ₐ[K] + WeightedSplitTraceLaurentCoordinateRing alpha beta d e := + IsLocalization.Away.liftAlgHom + (weightedSplitTraceAffineCoordinateProduct beta alpha d e) + (weightedSplitTraceRightInversionAffineMap_coordinateProduct_isUnit alpha beta d e) + +@[simp] +theorem weightedSplitTraceRightInversionLaurentMap_x + (alpha beta : K) (d e : ℕ) : + weightedSplitTraceRightInversionLaurentMap alpha beta d e + (weightedSplitTraceLaurentX beta alpha d e) = + weightedSplitTraceLaurentX alpha beta d e := by + simp only [weightedSplitTraceRightInversionLaurentMap, weightedSplitTraceLaurentX, + IsLocalization.Away.liftAlgHom_apply] + rw [IsLocalization.Away.lift_eq] + exact weightedSplitTraceRightInversionAffineMap_x alpha beta d e + +@[simp] +theorem weightedSplitTraceRightInversionLaurentMap_y + (alpha beta : K) (d e : ℕ) : + weightedSplitTraceRightInversionLaurentMap alpha beta d e + (weightedSplitTraceLaurentY beta alpha d e) = + weightedSplitTraceLaurentYInverse alpha beta d e := by + simp only [weightedSplitTraceRightInversionLaurentMap, weightedSplitTraceLaurentY, + IsLocalization.Away.liftAlgHom_apply] + rw [IsLocalization.Away.lift_eq] + exact weightedSplitTraceRightInversionAffineMap_y alpha beta d e + +@[simp] +theorem weightedSplitTraceRightInversionLaurentMap_yInverse + (alpha beta : K) (d e : ℕ) : + weightedSplitTraceRightInversionLaurentMap alpha beta d e + (weightedSplitTraceLaurentYInverse beta alpha d e) = + weightedSplitTraceLaurentY alpha beta d e := by + let sourceUnit := weightedSplitTraceLaurentYUnit beta alpha d e + let targetUnit := weightedSplitTraceLaurentYUnit alpha beta d e + let f := weightedSplitTraceRightInversionLaurentMap alpha beta d e + have hu : Units.map f.toMonoidHom sourceUnit = targetUnit⁻¹ := by + ext + simp [f, sourceUnit, targetUnit, weightedSplitTraceLaurentYInverse] + change f (↑(sourceUnit⁻¹) : WeightedSplitTraceLaurentCoordinateRing beta alpha d e) = + (↑targetUnit : WeightedSplitTraceLaurentCoordinateRing alpha beta d e) + calc + f (↑(sourceUnit⁻¹) : WeightedSplitTraceLaurentCoordinateRing beta alpha d e) = + ↑(Units.map f.toMonoidHom (sourceUnit⁻¹)) := + (Units.coe_map f.toMonoidHom (sourceUnit⁻¹)).symm + _ = ↑((Units.map f.toMonoidHom sourceUnit)⁻¹) := by rw [map_inv] + _ = ↑((targetUnit⁻¹)⁻¹) := by rw [hu] + _ = (↑targetUnit : WeightedSplitTraceLaurentCoordinateRing alpha beta d e) := by simp + +@[simp] +theorem weightedSplitTraceRightInversionLaurentMap_xInverse + (alpha beta : K) (d e : ℕ) : + weightedSplitTraceRightInversionLaurentMap alpha beta d e + (weightedSplitTraceLaurentXInverse beta alpha d e) = + weightedSplitTraceLaurentXInverse alpha beta d e := by + let sourceUnit := weightedSplitTraceLaurentXUnit beta alpha d e + let targetUnit := weightedSplitTraceLaurentXUnit alpha beta d e + let f := weightedSplitTraceRightInversionLaurentMap alpha beta d e + have hu : Units.map f.toMonoidHom sourceUnit = targetUnit := by + ext + simp [f, sourceUnit, targetUnit] + change f (↑(sourceUnit⁻¹) : WeightedSplitTraceLaurentCoordinateRing beta alpha d e) = + (↑(targetUnit⁻¹) : WeightedSplitTraceLaurentCoordinateRing alpha beta d e) + calc + f (↑(sourceUnit⁻¹) : WeightedSplitTraceLaurentCoordinateRing beta alpha d e) = + ↑(Units.map f.toMonoidHom (sourceUnit⁻¹)) := + (Units.coe_map f.toMonoidHom (sourceUnit⁻¹)).symm + _ = ↑((Units.map f.toMonoidHom sourceUnit)⁻¹) := by rw [map_inv] + _ = (↑(targetUnit⁻¹) : WeightedSplitTraceLaurentCoordinateRing alpha beta d e) := by rw [hu] + +theorem weightedSplitTraceRightInversionLaurentMap_inverseComposition + (alpha beta : K) (d e : ℕ) : + (weightedSplitTraceRightInversionLaurentMap alpha beta d e).comp + (weightedSplitTraceRightInversionLaurentMap beta alpha d e) = + AlgHom.id K (WeightedSplitTraceLaurentCoordinateRing alpha beta d e) := by + apply IsLocalization.algHom_ext + (Submonoid.powers (weightedSplitTraceAffineCoordinateProduct alpha beta d e)) + apply Ideal.Quotient.algHom_ext K + apply MvPolynomial.algHom_ext + intro i + fin_cases i + · change weightedSplitTraceRightInversionLaurentMap alpha beta d e + (weightedSplitTraceRightInversionLaurentMap beta alpha d e + (weightedSplitTraceLaurentX alpha beta d e)) = + weightedSplitTraceLaurentX alpha beta d e + rw [weightedSplitTraceRightInversionLaurentMap_x, + weightedSplitTraceRightInversionLaurentMap_x] + · change weightedSplitTraceRightInversionLaurentMap alpha beta d e + (weightedSplitTraceRightInversionLaurentMap beta alpha d e + (weightedSplitTraceLaurentY alpha beta d e)) = + weightedSplitTraceLaurentY alpha beta d e + rw [weightedSplitTraceRightInversionLaurentMap_y, + weightedSplitTraceRightInversionLaurentMap_yInverse] + +/-- The two coordinate inversions commute on the Laurent overlap. This is the algebraic cocycle +square needed by the four-chart gluing datum. -/ +theorem weightedSplitTraceLaurentInversions_commute + (alpha beta : K) (d e : ℕ) : + (weightedSplitTraceLeftInversionLaurentMap alpha beta d e).comp + (weightedSplitTraceRightInversionLaurentMap alpha beta d e) = + (weightedSplitTraceRightInversionLaurentMap alpha beta d e).comp + (weightedSplitTraceLeftInversionLaurentMap beta alpha d e) := by + apply IsLocalization.algHom_ext + (Submonoid.powers (weightedSplitTraceAffineCoordinateProduct beta alpha d e)) + apply Ideal.Quotient.algHom_ext K + apply MvPolynomial.algHom_ext + intro i + fin_cases i + · change weightedSplitTraceLeftInversionLaurentMap alpha beta d e + (weightedSplitTraceRightInversionLaurentMap alpha beta d e + (weightedSplitTraceLaurentX beta alpha d e)) = + weightedSplitTraceRightInversionLaurentMap alpha beta d e + (weightedSplitTraceLeftInversionLaurentMap beta alpha d e + (weightedSplitTraceLaurentX beta alpha d e)) + rw [weightedSplitTraceRightInversionLaurentMap_x, + weightedSplitTraceLeftInversionLaurentMap_x, + weightedSplitTraceLeftInversionLaurentMap_x, + weightedSplitTraceRightInversionLaurentMap_xInverse] + · change weightedSplitTraceLeftInversionLaurentMap alpha beta d e + (weightedSplitTraceRightInversionLaurentMap alpha beta d e + (weightedSplitTraceLaurentY beta alpha d e)) = + weightedSplitTraceRightInversionLaurentMap alpha beta d e + (weightedSplitTraceLeftInversionLaurentMap beta alpha d e + (weightedSplitTraceLaurentY beta alpha d e)) + rw [weightedSplitTraceRightInversionLaurentMap_y, + weightedSplitTraceLeftInversionLaurentMap_yInverse, + weightedSplitTraceLeftInversionLaurentMap_y, + weightedSplitTraceRightInversionLaurentMap_y] + +/-- The Laurent coordinate rings of the two weight orderings are isomorphic by `y ↦ y⁻¹`. -/ +def weightedSplitTraceRightInversionLaurentEquiv (alpha beta : K) (d e : ℕ) : + WeightedSplitTraceLaurentCoordinateRing beta alpha d e ≃ₐ[K] + WeightedSplitTraceLaurentCoordinateRing alpha beta d e := + AlgEquiv.ofAlgHom (weightedSplitTraceRightInversionLaurentMap alpha beta d e) + (weightedSplitTraceRightInversionLaurentMap beta alpha d e) + (weightedSplitTraceRightInversionLaurentMap_inverseComposition alpha beta d e) + (weightedSplitTraceRightInversionLaurentMap_inverseComposition beta alpha d e) + +end + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/CommonKummerIndependence.lean b/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/CommonKummerIndependence.lean new file mode 100644 index 0000000000..e340d0599c --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/CommonKummerIndependence.lean @@ -0,0 +1,176 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.Kummer +public import LeanPool.MarkoffModP.BGS.Markoff.Incidence.CoordinateRing + +/-! +# Kummer-class independence for common cover primes + +When a prime divides both cover exponents, the successive norm-degree argument used for coprime +covers loses exactly the common-prime information. This module begins the required replacement +by treating the exceptional prime `2` directly. In the quadratic presentation of the degree-one +trace curve, it proves that the product of the two torus coordinates remains nonsquare. + +The odd common-prime classes and the roots-of-unity eigencharacter descent are deliberately not +assumed here; they remain the next noncoprime wall. +-/ + +@[expose] public section + +namespace BGS.Markoff + +open Polynomial + +noncomputable section + +variable {K : Type*} [Field K] + +private lemma ratFunc_sigma_ratio_not_square + (sigma : K) (hsigma : sigma ≠ 0) (hnondegenerate : sigma ≠ 1) + (z : RatFunc K) : + z ^ 2 ≠ + (1 - RatFunc.C sigma * RatFunc.X) / (1 - RatFunc.X) := by + intro hpow + have hdenPoly : (1 - X : K[X]) ≠ 0 := by + intro h + have hval := congrArg (Polynomial.eval (0 : K)) h + simp at hval + have hdenRat : (1 - RatFunc.X : RatFunc K) ≠ 0 := by + simpa [← RatFunc.algebraMap_X, ← RatFunc.algebraMap_C] using + (map_ne_zero_iff (algebraMap K[X] (RatFunc K)) + (RatFunc.algebraMap_injective K)).mpr hdenPoly + have hcrossRat : + algebraMap K[X] (RatFunc K) (z.num ^ 2 * (1 - X)) = + algebraMap K[X] (RatFunc K) ((1 - C sigma * X) * z.denom ^ 2) := by + simp only [map_mul, map_pow, map_sub, map_one, RatFunc.algebraMap_X, + RatFunc.algebraMap_C] + have hzden : algebraMap K[X] (RatFunc K) z.denom ≠ 0 := + (map_ne_zero_iff (algebraMap K[X] (RatFunc K)) + (RatFunc.algebraMap_injective K)).mpr z.denom_ne_zero + rw [← RatFunc.num_div_denom z] at hpow + field_simp [hzden, hdenRat] at hpow + simpa [mul_assoc, mul_left_comm, mul_comm] using hpow + have hcross : z.num ^ 2 * (1 - X) = + (1 - C sigma * X) * z.denom ^ 2 := + (RatFunc.algebraMap_injective K) hcrossRat + let l : K[X] := normalizedSplitTraceEisensteinPrime sigma + have hlIrred : Irreducible l := + normalizedSplitTraceEisensteinPrime_irreducible sigma hsigma + have hlPrime : Prime l := hlIrred.prime + have hlNotDvdDenPoly : ¬ l ∣ (1 - X : K[X]) := by + intro h + apply normalizedSplitTraceEisensteinPrime_not_dvd_leading + sigma hsigma hnondegenerate + simpa [l, normalizedSplitTraceLeadingCoefficient] using + (dvd_mul_of_dvd_right h X) + have hlDvdNumSq : l ∣ z.num ^ 2 := by + have hprod : l ∣ z.num ^ 2 * (1 - X) := by + rw [hcross] + refine ⟨-(z.denom ^ 2), ?_⟩ + simp [l, normalizedSplitTraceEisensteinPrime] + ring + exact (hlPrime.dvd_mul.mp hprod).resolve_right hlNotDvdDenPoly + have hlDvdNum : l ∣ z.num := hlPrime.dvd_of_dvd_pow hlDvdNumSq + have hlNotDvdDen : ¬ l ∣ z.denom := by + intro hlDvdDen + exact hlIrred.not_isUnit + (z.isCoprime_num_denom.isUnit_of_dvd' hlDvdNum hlDvdDen) + obtain ⟨num', hnum⟩ := hlDvdNum + have hlNe : l ≠ 0 := hlIrred.ne_zero + have hcancel : l * (num' ^ 2 * (1 - X)) = -(z.denom ^ 2) := by + apply mul_left_cancel₀ hlNe + calc + l * (l * (num' ^ 2 * (1 - X))) = + (l * num') ^ 2 * (1 - X) := by ring + _ = z.num ^ 2 * (1 - X) := by rw [← hnum] + _ = (1 - C sigma * X) * z.denom ^ 2 := hcross + _ = l * (-(z.denom ^ 2)) := by + simp [l, normalizedSplitTraceEisensteinPrime] + ring + have hlDvdDenSq : l ∣ z.denom ^ 2 := by + refine ⟨-(num' ^ 2 * (1 - X)), ?_⟩ + calc + z.denom ^ 2 = -(l * (num' ^ 2 * (1 - X))) := by rw [hcancel]; simp + _ = l * (-(num' ^ 2 * (1 - X))) := by ring + exact hlNotDvdDen (hlPrime.dvd_of_dvd_pow hlDvdDenSq) + +private lemma ratFunc_X_mul_splitTraceRadicand_eq_sigma_ratio + (sigma : K) : + RatFunc.X * splitTraceRadicand sigma = + (1 - RatFunc.C sigma * RatFunc.X) / (1 - RatFunc.X) := by + have hX : (RatFunc.X : RatFunc K) ≠ 0 := RatFunc.X_ne_zero + have hOneSubX : (1 - RatFunc.X : RatFunc K) ≠ 0 := by + intro h + have honeX : (1 : RatFunc K) = RatFunc.X := sub_eq_zero.mp h + have hdegree := congrArg RatFunc.intDegree honeX + norm_num at hdegree + simp only [splitTraceRadicand, splitTraceRadicandNumerator, + splitTraceRadicandDenominator, map_sub, map_one, map_mul, + RatFunc.algebraMap_C, RatFunc.algebraMap_X] + field_simp [hX, hOneSubX] + +private lemma splitTraceRadicand_mul_X_mul_splitTraceRadicand_intDegree + (sigma : K) (hsigma : sigma ≠ 0) : + (splitTraceRadicand sigma * + (RatFunc.X * splitTraceRadicand sigma)).intDegree = -1 := by + have hr : splitTraceRadicand sigma ≠ 0 := + splitTraceRadicand_ne_zero sigma hsigma + rw [RatFunc.intDegree_mul hr (mul_ne_zero RatFunc.X_ne_zero hr), + RatFunc.intDegree_mul RatFunc.X_ne_zero hr, + RatFunc.intDegree_X, splitTraceRadicand_intDegree sigma hsigma] + norm_num + +/-- The sole two-primary residue class left invisible by the four boundary +valuations is nevertheless nontrivial: on the degree-one trace curve, the +product of the two torus coordinates is not a square. -/ +theorem splitTraceCoordinateProduct_quadraticPresentation_not_isSquare + (sigma : K) (hsigma : sigma ≠ 0) (hnondegenerate : sigma ≠ 1) + (h2 : (2 : K) ≠ 0) : + ¬ IsSquare (algebraMap (RatFunc K) + (AdjoinRoot (adjoinSquarePolynomial (splitTraceRadicand sigma))) + (RatFunc.X * splitTraceRadicand sigma)) := by + let f : RatFunc K := splitTraceRadicand sigma + let g : RatFunc K := RatFunc.X * splitTraceRadicand sigma + have hf0 : f ≠ 0 := splitTraceRadicand_ne_zero sigma hsigma + have hg0 : g ≠ 0 := mul_ne_zero RatFunc.X_ne_zero hf0 + have hf : ¬ IsSquare f := by + rintro ⟨z, hz⟩ + exact RatFunc.pow_ne_of_not_dvd_intDegree f hf0 2 + (by rw [splitTraceRadicand_intDegree sigma hsigma]; norm_num) z + (by simpa [pow_two] using hz.symm) + have hg : ¬ IsSquare g := by + rintro ⟨z, hz⟩ + apply ratFunc_sigma_ratio_not_square sigma hsigma hnondegenerate z + rw [← ratFunc_X_mul_splitTraceRadicand_eq_sigma_ratio sigma] + simpa [g, pow_two] using hz.symm + have hfg0 : f * g ≠ 0 := mul_ne_zero hf0 hg0 + have hfg : ¬ IsSquare (f * g) := by + rintro ⟨z, hz⟩ + exact RatFunc.pow_ne_of_not_dvd_intDegree (f * g) hfg0 2 + (by + change ¬ (2 : ℤ) ∣ + (splitTraceRadicand sigma * + (RatFunc.X * splitTraceRadicand sigma)).intDegree + rw [splitTraceRadicand_mul_X_mul_splitTraceRadicand_intDegree sigma hsigma] + norm_num) z + (by simpa [pow_two] using hz.symm) + have h2Rat : (2 : RatFunc K) ≠ 0 := by + intro hzero + apply h2 + apply FaithfulSMul.algebraMap_injective K (RatFunc K) + simpa only [map_ofNat, map_zero] using hzero + have hnotMapped : ¬ IsSquare + (algebraMap (RatFunc K) (AdjoinRoot (adjoinSquarePolynomial f)) g) := + not_isSquare_algebraMap_adjoinSquare_of_independent + (F := RatFunc K) (f := f) (g := g) h2Rat hf hg hfg + simpa only [f, g] using hnotMapped + +end + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/CommonPrimeKummerTower.lean b/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/CommonPrimeKummerTower.lean new file mode 100644 index 0000000000..e04d41dc8a --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/CommonPrimeKummerTower.lean @@ -0,0 +1,415 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Algebra.KummerEigencharacterDescent +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.OddCommonPrimeIndependence +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.PositiveCoprimeIrreducibility + +/-! +# The split trace Kummer tower for arbitrary positive exponents + +This module combines cyclic eigencharacter descent with the trace curve's explicit Kummer-class +calculations. It handles primes common to both covering exponents, proving that the second +radicand remains non-power after adjoining an arbitrary positive root of the first coordinate. +Consequently the second Kummer polynomial is irreducible without a coprimality assumption, under +the explicit roots-of-unity hypotheses used by the descent. +-/ + +@[expose] public section + +namespace BGS.Markoff + +open Polynomial AdjoinRoot + +noncomputable section + +variable {K : Type*} [Field K] + +private lemma two_ne_zero_of_primitive_even_root + {e : ℕ} (he : 0 < e) (h2e : 2 ∣ e) {zeta : K} + (hzeta : IsPrimitiveRoot zeta e) : (2 : K) ≠ 0 := by + let zetaTwo := zeta ^ (e / 2) + have hfactor : e = (e / 2) * 2 := (Nat.div_mul_cancel h2e).symm + have hzetaTwo : IsPrimitiveRoot zetaTwo 2 := hzeta.pow he hfactor + intro htwo + have hnegOne : (-1 : K) = 1 := by + rw [neg_eq_iff_add_eq_zero] + simpa [one_add_one_eq_two] using htwo + apply hzetaTwo.ne_one (by norm_num) + rw [hzetaTwo.eq_neg_one_of_two_right, hnegOne] + +private lemma splitTraceBaseUV_not_square + (sigma : K) (hsigma : sigma ≠ 0) + (c : SplitTraceBaseFunctionField K sigma) : + letI : Fact (Irreducible (splitTraceBaseKummerPolynomial sigma)) := + ⟨splitTraceBaseKummerPolynomial_irreducible sigma hsigma⟩ + c ^ 2 ≠ splitTraceBaseU sigma * splitTraceBaseV sigma := by + let hBaseIrred := splitTraceBaseKummerPolynomial_irreducible sigma hsigma + let : Fact (Irreducible (splitTraceBaseKummerPolynomial sigma)) := ⟨hBaseIrred⟩ + let baseField := SplitTraceBaseFunctionField K sigma + let U : baseField := splitTraceBaseU sigma + let V : baseField := splitTraceBaseV sigma + have hV : V ≠ 0 := by + change AdjoinRoot.root (splitTraceBaseKummerPolynomial sigma) ≠ 0 + exact (root_X_pow_sub_C_ne_zero_iff hBaseIrred).mpr + (splitTraceRadicand_ne_zero sigma hsigma) + have hU : U ≠ 0 := by + exact (map_ne_zero_iff _ (algebraMap (RatFunc K) baseField).injective).mpr + RatFunc.X_ne_zero + have hUV : U * V ≠ 0 := mul_ne_zero hU hV + intro hpow + have hc : c ≠ 0 := by + intro hc + apply hUV + simpa [hc] using hpow.symm + let : Module.Finite (RatFunc K) baseField := + (monic_X_pow_sub_C _ (by norm_num : (2 : ℕ) ≠ 0)).finite_adjoinRoot + have hnorm := congrArg (Algebra.norm (RatFunc K)) hpow + rw [map_pow] at hnorm + have hnormC : Algebra.norm (RatFunc K) c ≠ 0 := + Algebra.norm_ne_zero_iff.mpr hc + have hdegree := congrArg RatFunc.intDegree hnorm + rw [RatFunc.intDegree_pow _ hnormC, + norm_splitTraceBaseU_mul_V_intDegree sigma hsigma] at hdegree + omega + +/-- The second trace radicand is not a common-prime power after adjoining an arbitrary +positive `e`-th root of the first coordinate. -/ +theorem splitTraceXiRadicand_not_primePower_of_commonPrime + (sigma : K) (hsigma : sigma ≠ 0) (hnondegenerate : sigma ≠ 1) + (i : K) (hi : i ^ 2 = -1) + (e : ℕ) (he : 0 < e) (zeta : K) (hzeta : IsPrimitiveRoot zeta e) + (q : ℕ) (hq : q.Prime) (hqe : q ∣ e) + (z : letI : Fact (Irreducible (splitTraceBaseKummerPolynomial sigma)) := + ⟨splitTraceBaseKummerPolynomial_irreducible sigma hsigma⟩ + letI : Fact (Irreducible (splitTraceEtaKummerPolynomial sigma e)) := + ⟨splitTraceEtaKummerPolynomial_irreducible_of_sqrt_neg_one + sigma hsigma i hi e he⟩ + SplitTraceEtaFunctionField K sigma e) : + letI : Fact (Irreducible (splitTraceBaseKummerPolynomial sigma)) := + ⟨splitTraceBaseKummerPolynomial_irreducible sigma hsigma⟩ + letI : Fact (Irreducible (splitTraceEtaKummerPolynomial sigma e)) := + ⟨splitTraceEtaKummerPolynomial_irreducible_of_sqrt_neg_one + sigma hsigma i hi e he⟩ + z ^ q ≠ splitTraceXiRadicand sigma e := by + let hBaseIrred := splitTraceBaseKummerPolynomial_irreducible sigma hsigma + let : Fact (Irreducible (splitTraceBaseKummerPolynomial sigma)) := ⟨hBaseIrred⟩ + let hEtaIrred := splitTraceEtaKummerPolynomial_irreducible_of_sqrt_neg_one + sigma hsigma i hi e he + let : Fact (Irreducible (splitTraceEtaKummerPolynomial sigma e)) := ⟨hEtaIrred⟩ + let baseField := SplitTraceBaseFunctionField K sigma + let etaField := SplitTraceEtaFunctionField K sigma e + let U : baseField := splitTraceBaseU sigma + let V : baseField := splitTraceBaseV sigma + have hV : V ≠ 0 := by + change AdjoinRoot.root (splitTraceBaseKummerPolynomial sigma) ≠ 0 + exact (root_X_pow_sub_C_ne_zero_iff hBaseIrred).mpr + (splitTraceRadicand_ne_zero sigma hsigma) + have hU : U ≠ 0 := by + exact (map_ne_zero_iff _ (algebraMap (RatFunc K) baseField).injective).mpr + RatFunc.X_ne_zero + have hUV : U * V ≠ 0 := mul_ne_zero hU hV + intro hpow + have hzetaBase : IsPrimitiveRoot (algebraMap K baseField zeta) e := + hzeta.map_of_injective (algebraMap K baseField).injective + have hpowBase : z ^ q = algebraMap baseField etaField (U * V) := by + change z ^ q = algebraMap (SplitTraceBaseFunctionField K sigma) + (SplitTraceEtaFunctionField K sigma e) + (splitTraceBaseU sigma * splitTraceBaseV sigma) + exact hpow + obtain ⟨k, hklt, hdiv, c, hc⟩ := + BGS.Algebra.exists_rootMonomial_of_primePower_mem_base + (v := splitTraceBaseV sigma) + (ζ := algebraMap K (SplitTraceBaseFunctionField K sigma) zeta) + (a := splitTraceBaseU sigma * splitTraceBaseV sigma) + he hzetaBase (by simpa [splitTraceEtaKummerPolynomial] using hEtaIrred) + hq hqe z hpowBase + have hc' : z = algebraMap baseField etaField c * + AdjoinRoot.root (splitTraceEtaKummerPolynomial sigma e) ^ k := by + change z = algebraMap baseField etaField c * + AdjoinRoot.root (splitTraceEtaKummerPolynomial sigma e) ^ k at hc + exact hc + let r := q * k / e + have hrlt : r < q := by + apply (Nat.div_lt_iff_lt_mul he).2 + simpa [Nat.mul_comm] using (Nat.mul_lt_mul_left hq.pos).2 hklt + have hqk : e * r = q * k := by + exact Nat.mul_div_cancel' hdiv + have hetaRoot : + (AdjoinRoot.root (splitTraceEtaKummerPolynomial sigma e)) ^ e = + algebraMap baseField etaField V := by + apply sub_eq_zero.mp + have h := AdjoinRoot.eval₂_root (splitTraceEtaKummerPolynomial sigma e) + rw [splitTraceEtaKummerPolynomial] at h + simp only [Polynomial.eval₂_sub, Polynomial.eval₂_pow, Polynomial.eval₂_X, + Polynomial.eval₂_C] at h + rw [← AdjoinRoot.algebraMap_eq] at h + exact h + have hetaPow : (AdjoinRoot.root (splitTraceEtaKummerPolynomial sigma e)) ^ (q * k) = + algebraMap baseField etaField (V ^ r) := by + calc + (AdjoinRoot.root (splitTraceEtaKummerPolynomial sigma e)) ^ (q * k) = + (AdjoinRoot.root (splitTraceEtaKummerPolynomial sigma e)) ^ (e * r) := by + rw [hqk] + _ = ((AdjoinRoot.root (splitTraceEtaKummerPolynomial sigma e)) ^ e) ^ r := by + rw [pow_mul] + _ = (algebraMap baseField etaField V) ^ r := by + rw [hetaRoot] + _ = algebraMap baseField etaField (V ^ r) := by rw [map_pow] + have hbaseEq : c ^ q * V ^ r = U * V := by + apply (algebraMap baseField etaField).injective + calc + algebraMap baseField etaField (c ^ q * V ^ r) = + (algebraMap baseField etaField c) ^ q * + (AdjoinRoot.root (splitTraceEtaKummerPolynomial sigma e)) ^ (q * k) := by + rw [map_mul, map_pow, hetaPow] + _ = (algebraMap baseField etaField c * + AdjoinRoot.root (splitTraceEtaKummerPolynomial sigma e) ^ k) ^ q := by + rw [mul_pow, ← pow_mul, Nat.mul_comm q k] + _ = z ^ q := by rw [← hc'] + _ = algebraMap baseField etaField (U * V) := by + simpa [splitTraceXiRadicand, U, V, baseField, etaField] using hpow + by_cases hqTwo : q = 2 + · subst q + have h2 : (2 : K) ≠ 0 := + two_ne_zero_of_primitive_even_root he hqe hzeta + have hrCases : r = 0 ∨ r = 1 := by + generalize hrr : r = rr at hrlt ⊢ + omega + rcases hrCases with hrZero | hrOne + · apply splitTraceBaseUV_not_square sigma hsigma c + simpa [hrZero, U, V, baseField] using hbaseEq + · have hcSquareU : c ^ 2 = U := by + apply mul_right_cancel₀ hV + simpa [hrOne, pow_one, mul_assoc] using hbaseEq + have hnot := splitTraceCoordinateProduct_quadraticPresentation_not_isSquare + sigma hsigma hnondegenerate h2 + apply hnot + change IsSquare (algebraMap (RatFunc K) baseField + (RatFunc.X * splitTraceRadicand sigma)) + refine ⟨c * V, ?_⟩ + have hrootSquare : V ^ 2 = + algebraMap (RatFunc K) baseField (splitTraceRadicand sigma) := by + change AdjoinRoot.root (X ^ 2 - C (splitTraceRadicand sigma)) ^ 2 = _ + exact root_X_pow_sub_C_pow 2 (splitTraceRadicand sigma) + calc + algebraMap (RatFunc K) baseField + (RatFunc.X * splitTraceRadicand sigma) = + U * algebraMap (RatFunc K) baseField (splitTraceRadicand sigma) := by + simp [U, baseField, splitTraceBaseU] + _ = U * V ^ 2 := by rw [hrootSquare] + _ = c ^ 2 * V ^ 2 := by rw [hcSquareU] + _ = (c * V) * (c * V) := by ring + · by_cases hrZero : r = 0 + · apply splitTraceBaseCoordinates_mixedPower_ne_oddPrimePower + sigma hsigma hnondegenerate q 1 0 hq hqTwo hq.one_lt hq.pos (by simp) c + simpa [hrZero, U, V, baseField] using hbaseEq + · have hrPositive : 0 < r := Nat.pos_of_ne_zero hrZero + have hrLe : r ≤ q := Nat.le_of_lt hrlt + have hEq : (c * V) ^ q = (U * V) ^ 1 * V ^ (q - r) := by + rw [mul_pow, pow_one] + have hv : V ^ q = V ^ r * V ^ (q - r) := by + rw [← pow_add, Nat.add_sub_of_le hrLe] + calc + c ^ q * V ^ q = c ^ q * (V ^ r * V ^ (q - r)) := by rw [hv] + _ = (c ^ q * V ^ r) * V ^ (q - r) := by rw [mul_assoc] + _ = (U * V) * V ^ (q - r) := by rw [hbaseEq] + apply splitTraceBaseCoordinates_mixedPower_ne_oddPrimePower + sigma hsigma hnondegenerate q 1 (q - r) hq hqTwo hq.one_lt + (Nat.sub_lt (Nat.pos_of_ne_zero hq.ne_zero) hrPositive) (by simp) (c * V) + simpa [U, V, baseField] using hEq + +/-- With a primitive `e`-th root in the constant field, the xi Kummer polynomial is +irreducible for arbitrary positive exponents; coprimality is no longer required. -/ +theorem splitTraceXiKummerPolynomial_irreducible_of_primitiveRoot + (sigma : K) (hsigma : sigma ≠ 0) (hnondegenerate : sigma ≠ 1) + (i : K) (hi : i ^ 2 = -1) + (e d : ℕ) (he : 0 < e) (hd : 0 < d) + (zeta : K) (hzeta : IsPrimitiveRoot zeta e) : + letI : Fact (Irreducible (splitTraceBaseKummerPolynomial sigma)) := + ⟨splitTraceBaseKummerPolynomial_irreducible sigma hsigma⟩ + letI : Fact (Irreducible (splitTraceEtaKummerPolynomial sigma e)) := + ⟨splitTraceEtaKummerPolynomial_irreducible_of_sqrt_neg_one + sigma hsigma i hi e he⟩ + Irreducible (splitTraceXiKummerPolynomial sigma e d) := by + let hBaseIrred := splitTraceBaseKummerPolynomial_irreducible sigma hsigma + let : Fact (Irreducible (splitTraceBaseKummerPolynomial sigma)) := ⟨hBaseIrred⟩ + let hEtaIrred := splitTraceEtaKummerPolynomial_irreducible_of_sqrt_neg_one + sigma hsigma i hi e he + let : Fact (Irreducible (splitTraceEtaKummerPolynomial sigma e)) := ⟨hEtaIrred⟩ + rw [splitTraceXiKummerPolynomial] + apply X_pow_sub_C_irreducible_of_sqrt_neg_one + (algebraMap K (SplitTraceEtaFunctionField K sigma e) i) + · rw [← map_pow, hi, map_neg, map_one] + · exact hd.ne' + · intro q hq hqd z + by_cases hqe : q ∣ e + · exact splitTraceXiRadicand_not_primePower_of_commonPrime + sigma hsigma hnondegenerate i hi e he zeta hzeta q hq hqe z + · exact splitTraceXiRadicand_not_primePower_of_sqrt_neg_one + sigma hsigma i hi e he q hq hqe z + +/-- The roots of the arbitrary positive-exponent Kummer tower satisfy the cleared affine cover +equation. -/ +theorem generalSplitTraceKummerTower_cover_maps_to_zero_of_primitiveRoot + (sigma : K) (hsigma : sigma ≠ 0) (hnondegenerate : sigma ≠ 1) + (i : K) (hi : i ^ 2 = -1) + (e d : ℕ) (he : 0 < e) (hd : 0 < d) + (zeta : K) (hzeta : IsPrimitiveRoot zeta e) : + letI : Fact (Irreducible (splitTraceBaseKummerPolynomial sigma)) := + ⟨splitTraceBaseKummerPolynomial_irreducible sigma hsigma⟩ + letI : Fact (Irreducible (splitTraceEtaKummerPolynomial sigma e)) := + ⟨splitTraceEtaKummerPolynomial_irreducible_of_sqrt_neg_one + sigma hsigma i hi e he⟩ + letI : Fact (Irreducible (splitTraceXiKummerPolynomial sigma e d)) := + ⟨splitTraceXiKummerPolynomial_irreducible_of_primitiveRoot + sigma hsigma hnondegenerate i hi e d he hd zeta hzeta⟩ + generalSplitTracePolynomialToKummerTop sigma e d + (splitTraceCoverPolynomial (1 : K) sigma d e) = 0 := by + let hBaseIrred := splitTraceBaseKummerPolynomial_irreducible sigma hsigma + let : Fact (Irreducible (splitTraceBaseKummerPolynomial sigma)) := ⟨hBaseIrred⟩ + let hEtaIrred := splitTraceEtaKummerPolynomial_irreducible_of_sqrt_neg_one + sigma hsigma i hi e he + let : Fact (Irreducible (splitTraceEtaKummerPolynomial sigma e)) := ⟨hEtaIrred⟩ + let hXiIrred := splitTraceXiKummerPolynomial_irreducible_of_primitiveRoot + sigma hsigma hnondegenerate i hi e d he hd zeta hzeta + let : Fact (Irreducible (splitTraceXiKummerPolynomial sigma e d)) := ⟨hXiIrred⟩ + let baseToXi : SplitTraceBaseFunctionField K sigma →+* + SplitTraceXiFunctionField K sigma e d := + (algebraMap (SplitTraceEtaFunctionField K sigma e) + (SplitTraceXiFunctionField K sigma e d)).comp + (algebraMap (SplitTraceBaseFunctionField K sigma) + (SplitTraceEtaFunctionField K sigma e)) + have hBase := splitTraceBaseU_V_equation sigma hsigma + have hBaseTop := congrArg baseToXi hBase + simp only [map_add, map_sub, map_mul, map_pow, map_one, map_zero] at hBaseTop + have hEtaRoot : + (AdjoinRoot.root (splitTraceEtaKummerPolynomial sigma e)) ^ e = + algebraMap (SplitTraceBaseFunctionField K sigma) + (SplitTraceEtaFunctionField K sigma e) (splitTraceBaseV sigma) := by + apply sub_eq_zero.mp + have h := AdjoinRoot.eval₂_root (splitTraceEtaKummerPolynomial sigma e) + rw [splitTraceEtaKummerPolynomial] at h + simp only [Polynomial.eval₂_sub, Polynomial.eval₂_pow, Polynomial.eval₂_X, + Polynomial.eval₂_C] at h + rw [← AdjoinRoot.algebraMap_eq] at h + exact h + have hEtaTop := congrArg + (algebraMap (SplitTraceEtaFunctionField K sigma e) + (SplitTraceXiFunctionField K sigma e d)) hEtaRoot + simp only [map_pow] at hEtaTop + have hXiRoot : + splitTraceXiRoot sigma e d ^ d = + algebraMap (SplitTraceEtaFunctionField K sigma e) + (SplitTraceXiFunctionField K sigma e d) (splitTraceXiRadicand sigma e) := by + apply sub_eq_zero.mp + have h := AdjoinRoot.eval₂_root (splitTraceXiKummerPolynomial sigma e d) + rw [splitTraceXiKummerPolynomial] at h + simp only [Polynomial.eval₂_sub, Polynomial.eval₂_pow, Polynomial.eval₂_X, + Polynomial.eval₂_C] at h + rw [← AdjoinRoot.algebraMap_eq] at h + exact h + have hCover := eval_splitTraceCoverPolynomial_of_powerRootRelations + (splitTraceBaseElementInXiField sigma e d + (algebraMap (RatFunc K) (SplitTraceBaseFunctionField K sigma) (RatFunc.C sigma))) + (splitTraceBaseElementInXiField sigma e d (splitTraceBaseU sigma)) + (splitTraceBaseElementInXiField sigma e d (splitTraceBaseV sigma)) + (splitTraceXiRoot sigma e d) (splitTraceEtaRootInXiField sigma e d) d e + (by simpa [baseToXi, splitTraceBaseElementInXiField] using hBaseTop) + (by simpa [splitTraceEtaRootInXiField, splitTraceBaseElementInXiField, baseToXi] + using hEtaTop) + (by simpa [splitTraceXiRadicand, splitTraceBaseElementInXiField, baseToXi, + splitTraceXiRoot] using hXiRoot) + have hsigmaTop : + splitTraceBaseElementInXiField sigma e d + (algebraMap (RatFunc K) (SplitTraceBaseFunctionField K sigma) (RatFunc.C sigma)) = + algebraMap K (SplitTraceXiFunctionField K sigma e d) sigma := by + change algebraMap (SplitTraceEtaFunctionField K sigma e) + (SplitTraceXiFunctionField K sigma e d) + (algebraMap (SplitTraceBaseFunctionField K sigma) + (SplitTraceEtaFunctionField K sigma e) + (algebraMap (RatFunc K) (SplitTraceBaseFunctionField K sigma) + (algebraMap K (RatFunc K) sigma))) = _ + rw [← IsScalarTower.algebraMap_apply K (RatFunc K) + (SplitTraceBaseFunctionField K sigma)] + rw [← IsScalarTower.algebraMap_apply K + (SplitTraceBaseFunctionField K sigma) (SplitTraceEtaFunctionField K sigma e)] + rw [← IsScalarTower.algebraMap_apply K + (SplitTraceEtaFunctionField K sigma e) (SplitTraceXiFunctionField K sigma e d)] + rw [hsigmaTop] at hCover + simpa [generalSplitTracePolynomialToKummerTop, MvPolynomial.aeval_def, + splitTraceCoverPolynomial] using hCover + +private lemma arbitrarySplitTraceCoverPolynomial_ne_zero + (sigma : K) (d e : ℕ) (hd : 0 < d) : + splitTraceCoverPolynomial (1 : K) sigma d e ≠ 0 := by + intro hzero + have heval := congrArg + (MvPolynomial.eval ![(0 : K), (1 : K)]) hzero + rw [eval_splitTraceCoverPolynomial] at heval + norm_num [hd.ne'] at heval + +/-- The normalized split trace-cover polynomial is irreducible for arbitrary positive exponents +over a field containing a square root of `-1` and a primitive `e`-th root of unity. -/ +theorem splitTraceCoverPolynomial_irreducible_of_primitiveRoot + (sigma : K) (hsigma : sigma ≠ 0) (hnondegenerate : sigma ≠ 1) + (i : K) (hi : i ^ 2 = -1) + (e d : ℕ) (he : 0 < e) (hd : 0 < d) + (zeta : K) (hzeta : IsPrimitiveRoot zeta e) : + Irreducible (splitTraceCoverPolynomial (1 : K) sigma d e) := by + let hBaseIrred := splitTraceBaseKummerPolynomial_irreducible sigma hsigma + let : Fact (Irreducible (splitTraceBaseKummerPolynomial sigma)) := ⟨hBaseIrred⟩ + let hEtaIrred := splitTraceEtaKummerPolynomial_irreducible_of_sqrt_neg_one + sigma hsigma i hi e he + let : Fact (Irreducible (splitTraceEtaKummerPolynomial sigma e)) := ⟨hEtaIrred⟩ + let hXiIrred := splitTraceXiKummerPolynomial_irreducible_of_primitiveRoot + sigma hsigma hnondegenerate i hi e d he hd zeta hzeta + let : Fact (Irreducible (splitTraceXiKummerPolynomial sigma e d)) := ⟨hXiIrred⟩ + let : IsDomain (SplitTraceXiFunctionField K sigma e d) := + AdjoinRoot.isDomain_of_prime hXiIrred.prime + let f : MvPolynomial (Fin 2) K →+* SplitTraceXiFunctionField K sigma e d := + (generalSplitTracePolynomialToKummerTop sigma e d).toRingHom + let I : Ideal (MvPolynomial (Fin 2) K) := + Ideal.span {splitTraceCoverPolynomial (1 : K) sigma d e} + have hCoverZero : + generalSplitTracePolynomialToKummerTop sigma e d + (splitTraceCoverPolynomial (1 : K) sigma d e) = 0 := + generalSplitTraceKummerTower_cover_maps_to_zero_of_primitiveRoot + sigma hsigma hnondegenerate i hi e d he hd zeta hzeta + have hI_le : I ≤ RingHom.ker f := by + change Ideal.span {splitTraceCoverPolynomial (1 : K) sigma d e} ≤ RingHom.ker f + rw [Ideal.span_le] + intro p hp + simp only [Set.mem_singleton_iff] at hp + subst p + exact hCoverZero + have hker_le : RingHom.ker f ≤ I := by + intro p hp + apply generalSplitTracePolynomialSyntacticNormalForm_division + sigma hsigma i hi e d he hd hnondegenerate p + apply (generalSplitTracePolynomialSyntacticNormalForm_eq_zero_iff + sigma hsigma i hi e d he hd p).2 + exact hp + let quotientToTop : MvPolynomial (Fin 2) K ⧸ I →+* + SplitTraceXiFunctionField K sigma e d := + Ideal.Quotient.lift I f hI_le + have hInjective : Function.Injective quotientToTop := + RingHom.lift_injective_of_ker_le_ideal I hI_le hker_le + let : IsDomain (MvPolynomial (Fin 2) K ⧸ I) := + hInjective.isDomain quotientToTop + have hprimeIdeal : I.IsPrime := + (Ideal.Quotient.isDomain_iff_prime I).mp inferInstance + have hprimeElement : Prime (splitTraceCoverPolynomial (1 : K) sigma d e) := + (Ideal.span_singleton_prime + (arbitrarySplitTraceCoverPolynomial_ne_zero sigma d e hd)).1 (by + simpa [I] using hprimeIdeal) + exact irreducible_iff_prime.mpr hprimeElement + +end + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/Geometry.lean b/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/Geometry.lean new file mode 100644 index 0000000000..2e0bc5828d --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/Geometry.lean @@ -0,0 +1,253 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Core.RotationTorus +public import Mathlib.RingTheory.Polynomial.Eisenstein.Basic +public import Mathlib.Algebra.MvPolynomial.NoZeroDivisors + +/-! +# Split trace curves: an exact polynomial model and the first irreducibility wall + +The source equation is a Laurent equation on a two-dimensional torus. We keep that torus +equation separate from its cleared affine polynomial, because boundary monomials are units on the +torus but not in an affine polynomial ring. + +For the degree-one cover, the birational change `u = x / y` turns the normalized equation into + +`u * (1 - u) * y^2 + sigma * u - 1 = 0`. + +The latter polynomial is Eisenstein at `sigma * u - 1` when `sigma` is neither zero nor one. This +gives an irreducibility proof that survives every field extension. The higher power-cover descent +required by the paper is deliberately not encoded in this theorem: irreducibility of the quotient +curve does not imply irreducibility after adjoining the two power roots. +-/ + +@[expose] public section + +namespace BGS.Markoff + +open Polynomial + +section ExactTraceCurve + +variable {K : Type*} [Field K] + +/-- A weighted split-torus trace. The paper's orbit coordinates have this form. -/ +def weightedSplitTorusTrace (alpha beta : K) (w : Kˣ) : K := + alpha * (w : K) + beta * (w⁻¹ : Kˣ) + +@[simp] +theorem weightedSplitTorusTrace_one_one (w : Kˣ) : + weightedSplitTorusTrace 1 1 w = splitTorusTrace w := by + simp [weightedSplitTorusTrace, splitTorusTrace] + +/-- The exact split trace-cover equation from source equation (31). -/ +def SplitTraceCurveEquation (alpha beta : K) (d e : ℕ) (x y : Kˣ) : Prop := + weightedSplitTorusTrace alpha beta (y ^ e) = splitTorusTrace (x ^ d) + +/-- The affine polynomial obtained by multiplying the Laurent equation by `x^d * y^e`. + +Variable `0` is `x` and variable `1` is `y`. In particular, the third term contains the factor +`y^e`; this is the factor missing from the displayed polynomial on source line 749. +-/ +noncomputable def splitTraceCoverPolynomial (alpha beta : K) (d e : ℕ) : + MvPolynomial (Fin 2) K := + MvPolynomial.C alpha * MvPolynomial.X 0 ^ d * MvPolynomial.X 1 ^ (2 * e) + + MvPolynomial.C beta * MvPolynomial.X 0 ^ d - + MvPolynomial.X 0 ^ (2 * d) * MvPolynomial.X 1 ^ e - + MvPolynomial.X 1 ^ e + +theorem eval_splitTraceCoverPolynomial (alpha beta : K) (d e : ℕ) (x y : K) : + MvPolynomial.eval ![x, y] (splitTraceCoverPolynomial alpha beta d e) = + alpha * x ^ d * y ^ (2 * e) + beta * x ^ d - x ^ (2 * d) * y ^ e - y ^ e := by + simp [splitTraceCoverPolynomial] + +/-- On the torus, vanishing of the cleared polynomial is exactly the source Laurent equation. +No affine boundary point is silently added to this statement. -/ +theorem eval_splitTraceCoverPolynomial_eq_zero_iff + (alpha beta : K) (d e : ℕ) (x y : Kˣ) : + MvPolynomial.eval ![(x : K), (y : K)] (splitTraceCoverPolynomial alpha beta d e) = 0 ↔ + SplitTraceCurveEquation alpha beta d e x y := by + rw [eval_splitTraceCoverPolynomial] + unfold SplitTraceCurveEquation weightedSplitTorusTrace splitTorusTrace + simp only [Units.val_pow_eq_pow_val, Units.val_inv_eq_inv_val] + change alpha * (x : K) ^ d * (y : K) ^ (2 * e) + beta * (x : K) ^ d - + (x : K) ^ (2 * d) * (y : K) ^ e - (y : K) ^ e = 0 ↔ + alpha * (y : K) ^ e + beta * ((y : K) ^ e)⁻¹ = + (x : K) ^ d + ((x : K) ^ d)⁻¹ + field_simp + constructor <;> intro h <;> linear_combination h + +/-- At the excluded parameter `alpha * beta = 1`, the normalized cleared polynomial visibly +factors. This proves that the paper's nondegeneracy condition is mathematically necessary. -/ +theorem splitTraceCoverPolynomial_degenerate_factorization (d e : ℕ) : + splitTraceCoverPolynomial (1 : K) 1 d e = + (MvPolynomial.X 1 ^ e - MvPolynomial.X 0 ^ d) * + (MvPolynomial.X 0 ^ d * MvPolynomial.X 1 ^ e - 1) := by + simp only [splitTraceCoverPolynomial, MvPolynomial.C_1] + ring + +/-- The birational degree-one equation obtained from the normalized cleared equation by setting +`u = x / y` and removing the invertible factor `y`. -/ +def normalizedSplitTraceBirationalEquation (sigma u y : K) : K := + u * (1 - u) * y ^ 2 + sigma * u - 1 + +theorem normalizedSplitTrace_birational_change (sigma x y : K) (hy : y ≠ 0) : + x * y ^ 2 + sigma * x - x ^ 2 * y - y = + y * normalizedSplitTraceBirationalEquation sigma (x / y) y := by + change x * y ^ 2 + sigma * x - x ^ 2 * y - y = + y * ((x / y) * (1 - x / y) * y ^ 2 + sigma * (x / y) - 1) + field_simp [hy] + ring + +end ExactTraceCurve + +section BirationalIrreducibility + +variable {K : Type*} [Field K] + +/-- The coefficient of `y^2` in the birational degree-one trace equation. -/ +noncomputable def normalizedSplitTraceLeadingCoefficient : K[X] := + X * (1 - X) + +/-- The prime used in the Eisenstein proof. -/ +noncomputable def normalizedSplitTraceEisensteinPrime (sigma : K) : K[X] := + C sigma * X - 1 + +/-- The birational degree-one trace equation, as a polynomial in `y` over `K[u]`. -/ +noncomputable def normalizedSplitTraceBirationalPolynomial (sigma : K) : Polynomial K[X] := + C normalizedSplitTraceLeadingCoefficient * X ^ 2 + + C (normalizedSplitTraceEisensteinPrime sigma) + +@[simp] +theorem eval_normalizedSplitTraceBirationalPolynomial (sigma u y : K) : + ((normalizedSplitTraceBirationalPolynomial sigma).eval (C y)).eval u = + normalizedSplitTraceBirationalEquation sigma u y := by + simp [normalizedSplitTraceBirationalPolynomial, normalizedSplitTraceLeadingCoefficient, + normalizedSplitTraceEisensteinPrime, normalizedSplitTraceBirationalEquation] + ring + +lemma normalizedSplitTraceEisensteinPrime_irreducible (sigma : K) (hsigma : sigma ≠ 0) : + Irreducible (normalizedSplitTraceEisensteinPrime sigma) := by + simpa [normalizedSplitTraceEisensteinPrime, sub_eq_add_neg] using + (Polynomial.irreducible_C_mul_X_add_C hsigma + ((isUnit_neg_one : IsUnit (-1 : K)).isRelPrime_right)) + +lemma normalizedSplitTraceEisensteinPrime_not_dvd_leading + (sigma : K) (hsigma : sigma ≠ 0) (hsigmaOne : sigma ≠ 1) : + ¬ normalizedSplitTraceEisensteinPrime sigma ∣ + (normalizedSplitTraceLeadingCoefficient : K[X]) := by + intro hdvd + have hdvdEval := map_dvd (Polynomial.evalRingHom (sigma⁻¹)) hdvd + have hinv : sigma⁻¹ ≠ 0 := inv_ne_zero hsigma + have hinvOne : sigma⁻¹ ≠ 1 := inv_ne_one.mpr hsigmaOne + have hzero : 1 - sigma⁻¹ = 0 := by + simpa [normalizedSplitTraceEisensteinPrime, normalizedSplitTraceLeadingCoefficient, + hsigma, hinv] using hdvdEval + exact (sub_ne_zero.mpr (Ne.symm hinvOne)) hzero + +lemma normalizedSplitTraceBirationalPolynomial_natDegree (sigma : K) : + (normalizedSplitTraceBirationalPolynomial sigma).natDegree = 2 := by + have hOneSubX : (1 - X : K[X]) ≠ 0 := by + intro h + have hval : (1 : K) = 0 := by + simpa using congrArg (Polynomial.eval (0 : K)) h + exact one_ne_zero hval + have hLeading : (normalizedSplitTraceLeadingCoefficient : K[X]) ≠ 0 := + mul_ne_zero Polynomial.X_ne_zero hOneSubX + simp [normalizedSplitTraceBirationalPolynomial, hLeading] + +lemma normalizedSplitTraceBirationalPolynomial_isPrimitive + (sigma : K) (hsigma : sigma ≠ 0) (hsigmaOne : sigma ≠ 1) : + (normalizedSplitTraceBirationalPolynomial sigma).IsPrimitive := by + rw [Polynomial.isPrimitive_iff_isUnit_of_C_dvd] + intro r hr + have hcoeff := (Polynomial.C_dvd_iff_dvd_coeff r + (normalizedSplitTraceBirationalPolynomial sigma)).mp hr + have hrPrime : r ∣ normalizedSplitTraceEisensteinPrime sigma := by + simpa [normalizedSplitTraceBirationalPolynomial] using hcoeff 0 + have hrLeading : r ∣ (normalizedSplitTraceLeadingCoefficient : K[X]) := by + simpa [normalizedSplitTraceBirationalPolynomial] using hcoeff 2 + exact ((normalizedSplitTraceEisensteinPrime_irreducible sigma hsigma).coprime_iff_not_dvd.mpr + (normalizedSplitTraceEisensteinPrime_not_dvd_leading sigma hsigma hsigmaOne)).isUnit_of_dvd' + hrPrime hrLeading + +lemma normalizedSplitTraceBirationalPolynomial_isEisenstein + (sigma : K) (hsigma : sigma ≠ 0) (hsigmaOne : sigma ≠ 1) : + (normalizedSplitTraceBirationalPolynomial sigma).IsEisensteinAt + (Ideal.span {normalizedSplitTraceEisensteinPrime sigma}) := by + have hPrimeIrred := normalizedSplitTraceEisensteinPrime_irreducible sigma hsigma + have hDegree := normalizedSplitTraceBirationalPolynomial_natDegree sigma + have hLeadingCoeff : + (normalizedSplitTraceBirationalPolynomial sigma).leadingCoeff = + (normalizedSplitTraceLeadingCoefficient : K[X]) := by + rw [leadingCoeff, hDegree] + simp [normalizedSplitTraceBirationalPolynomial] + have hCoeffZero : + (normalizedSplitTraceBirationalPolynomial sigma).coeff 0 = + normalizedSplitTraceEisensteinPrime sigma := by + simp [normalizedSplitTraceBirationalPolynomial] + refine { + leading := ?_ + mem := ?_ + notMem := ?_ } + · rw [Ideal.mem_span_singleton] + rw [hLeadingCoeff] + exact normalizedSplitTraceEisensteinPrime_not_dvd_leading sigma hsigma hsigmaOne + · intro n hn + rw [hDegree] at hn + interval_cases n <;> + simp [normalizedSplitTraceBirationalPolynomial] + · rw [hCoeffZero, Ideal.span_singleton_pow, Ideal.mem_span_singleton] + intro hdvd + have hDegreePrime : (normalizedSplitTraceEisensteinPrime sigma).natDegree = 1 := by + rw [← Polynomial.degree_eq_iff_natDegree_eq_of_pos (by norm_num : 0 < 1)] + rw [normalizedSplitTraceEisensteinPrime] + compute_degree! + have hle := Polynomial.natDegree_le_of_dvd hdvd hPrimeIrred.ne_zero + norm_num [Polynomial.natDegree_pow, hDegreePrime] at hle + +/-- The degree-one birational trace polynomial is irreducible over every field, under exactly the +two nondegeneracy conditions used by the Eisenstein argument. -/ +theorem normalizedSplitTraceBirationalPolynomial_irreducible + (sigma : K) (hsigma : sigma ≠ 0) (hsigmaOne : sigma ≠ 1) : + Irreducible (normalizedSplitTraceBirationalPolynomial sigma) := by + have hPrimeIrred := normalizedSplitTraceEisensteinPrime_irreducible sigma hsigma + have hIdealPrime : (Ideal.span {normalizedSplitTraceEisensteinPrime sigma}).IsPrime := + (Ideal.span_singleton_prime hPrimeIrred.ne_zero).mpr hPrimeIrred.prime + apply (normalizedSplitTraceBirationalPolynomial_isEisenstein sigma hsigma hsigmaOne).irreducible + hIdealPrime + (normalizedSplitTraceBirationalPolynomial_isPrimitive sigma hsigma hsigmaOne) + rw [normalizedSplitTraceBirationalPolynomial_natDegree] + norm_num + +theorem map_normalizedSplitTraceBirationalPolynomial + {L : Type*} [Field L] (phi : K →+* L) (sigma : K) : + (normalizedSplitTraceBirationalPolynomial sigma).map (Polynomial.mapRingHom phi) = + normalizedSplitTraceBirationalPolynomial (phi sigma) := by + simp [normalizedSplitTraceBirationalPolynomial, normalizedSplitTraceLeadingCoefficient, + normalizedSplitTraceEisensteinPrime] + +/-- Universal scalar-extension irreducibility. In particular, taking an algebraic closure gives +absolute irreducibility of this explicit birational degree-one model. -/ +theorem normalizedSplitTraceBirationalPolynomial_irreducible_after_baseChange + {L : Type*} [Field L] (phi : K →+* L) (sigma : K) + (hsigma : sigma ≠ 0) (hsigmaOne : sigma ≠ 1) : + Irreducible + ((normalizedSplitTraceBirationalPolynomial sigma).map (Polynomial.mapRingHom phi)) := by + rw [map_normalizedSplitTraceBirationalPolynomial] + apply normalizedSplitTraceBirationalPolynomial_irreducible + · exact (map_ne_zero_iff phi phi.injective).mpr hsigma + · intro h + apply hsigmaOne + apply phi.injective + simpa using h + +end BirationalIrreducibility + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/IrreducibilityObstructions.lean b/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/IrreducibilityObstructions.lean new file mode 100644 index 0000000000..653733a485 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/IrreducibilityObstructions.lean @@ -0,0 +1,152 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import Mathlib.Algebra.MvPolynomial.Nilpotent +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.Characteristic +public import Mathlib.FieldTheory.Perfect + +/-! +# Exact obstructions to the published trace-cover irreducibility statement + +The counterexample in `TraceCurveCharacteristic` uses a zero second weight. That already +falsifies the published statement as written, but it does not test the normalized family used by +the current split endgame. This file records the stronger obstruction: over a perfect field of +positive characteristic, every normalized coefficient has a Frobenius root, so simultaneously +multiplying both cover exponents by the characteristic makes the normalized cover a Frobenius +power. This remains true when `sigma` is nonzero and different from one. +-/ + +@[expose] public section + +namespace BGS.Markoff + +open Polynomial + +variable {K : Type*} [Field K] + +section ZeroSecondWeight + +/-- If the second trace weight is zero, denominator clearing introduces the coordinate factor +`y^e`. Thus the polynomial displayed in the published proof is not the torus closure in this +case. -/ +theorem splitTraceCoverPolynomial_zero_second_weight_factorization + (alpha : K) (d e : ℕ) : + splitTraceCoverPolynomial alpha 0 d e = + MvPolynomial.X 1 ^ e * + (MvPolynomial.C alpha * MvPolynomial.X 0 ^ d * MvPolynomial.X 1 ^ e - + MvPolynomial.X 0 ^ (2 * d) - 1) := by + simp only [splitTraceCoverPolynomial, MvPolynomial.C_0, zero_mul, add_zero] + ring + +lemma splitTraceCoverPolynomial_zero_second_weight_coordinateFactor_not_isUnit + (e : ℕ) (he : 0 < e) : + ¬ IsUnit (MvPolynomial.X (R := K) (1 : Fin 2) ^ e) := by + intro hunit + obtain ⟨r, _hr, heq⟩ := + (MvPolynomial.isUnit_iff_eq_C_of_isReduced.mp hunit) + have hzero := congrArg + (MvPolynomial.eval₂ (σ := Fin 2) (RingHom.id K) (![0, 0] : Fin 2 → K)) heq + have hone := congrArg + (MvPolynomial.eval₂ (σ := Fin 2) (RingHom.id K) (![0, 1] : Fin 2 → K)) heq + simp [he.ne'] at hzero hone + exact zero_ne_one (hzero.trans hone.symm) + +lemma splitTraceCoverPolynomial_zero_second_weight_remainingFactor_not_isUnit + (alpha : K) (halpha : alpha ≠ 0) (d e : ℕ) (he : 0 < e) : + ¬ IsUnit + (MvPolynomial.C alpha * MvPolynomial.X 0 ^ d * MvPolynomial.X 1 ^ e - + MvPolynomial.X (0 : Fin 2) ^ (2 * d) - 1 : MvPolynomial (Fin 2) K) := by + intro hunit + obtain ⟨r, _hr, heq⟩ := + (MvPolynomial.isUnit_iff_eq_C_of_isReduced.mp hunit) + have hzero := congrArg + (MvPolynomial.eval₂ (σ := Fin 2) (RingHom.id K) (![1, 0] : Fin 2 → K)) heq + have hone := congrArg + (MvPolynomial.eval₂ (σ := Fin 2) (RingHom.id K) (![1, 1] : Fin 2 → K)) heq + simp [he.ne'] at hzero hone + apply halpha + linear_combination hone - hzero + +/-- The printed hypotheses "the weights are not both zero" and `alpha * beta ≠ 1` do not imply +irreducibility of the cleared polynomial: whenever `beta = 0`, `alpha ≠ 0`, and `e > 0`, both +factors above are nonunits. This obstruction already occurs in characteristic zero. -/ +theorem splitTraceCoverPolynomial_zero_second_weight_not_irreducible + (alpha : K) (halpha : alpha ≠ 0) (d e : ℕ) (he : 0 < e) : + ¬ Irreducible (splitTraceCoverPolynomial alpha 0 d e) := by + intro hirreducible + have hfactor := splitTraceCoverPolynomial_zero_second_weight_factorization alpha d e + rcases hirreducible.isUnit_or_isUnit hfactor with hcoordinate | hremaining + · exact splitTraceCoverPolynomial_zero_second_weight_coordinateFactor_not_isUnit e he hcoordinate + · exact splitTraceCoverPolynomial_zero_second_weight_remainingFactor_not_isUnit + alpha halpha d e he hremaining + +/-- A direct counterexample to the published lemma in its own logical form, independent of any +positive-characteristic issue. -/ +theorem publishedTraceCoverIrreducibility_requires_nonzero_secondWeight + (alpha : K) (halpha : alpha ≠ 0) (d e : ℕ) (he : 0 < e) : + ((alpha ≠ 0 ∨ (0 : K) ≠ 0) ∧ alpha * 0 ≠ 1) ∧ + ¬ Irreducible (splitTraceCoverPolynomial alpha 0 d e) := by + exact ⟨⟨Or.inl halpha, by simp⟩, + splitTraceCoverPolynomial_zero_second_weight_not_irreducible alpha halpha d e he⟩ + +end ZeroSecondWeight + +/-- In a perfect field of characteristic `p`, the normalized cover with exponents `(p*d,p*e)` +is a `p`-th power after choosing a Frobenius root of `sigma`. -/ +theorem exists_splitTraceCoverPolynomial_normalized_frobenius_factorization + [PerfectField K] (p : ℕ) [Fact p.Prime] [CharP K p] + (sigma : K) (d e : ℕ) : + ∃ tau : K, + tau ^ p = sigma ∧ + splitTraceCoverPolynomial (1 : K) sigma (p * d) (p * e) = + (splitTraceCoverPolynomial (1 : K) tau d e) ^ p := by + obtain ⟨tau, htau⟩ := surjective_frobenius K p sigma + have htauPow : tau ^ p = sigma := by + exact htau + refine ⟨tau, ?_, ?_⟩ + · exact htauPow + · rw [← htauPow] + simpa using + (splitTraceCoverPolynomial_frobenius_pullback + (K := K) (1 : K) tau d e p) + +/-- Any normalized cover for which the characteristic divides both exponents is a nontrivial +power over a perfect field, regardless of the residual exponents. -/ +theorem splitTraceCoverPolynomial_normalized_not_irreducible_when_char_mul_exponents + [PerfectField K] (p : ℕ) [Fact p.Prime] [CharP K p] + (sigma : K) (d e : ℕ) : + ¬ Irreducible + (splitTraceCoverPolynomial (1 : K) sigma (p * d) (p * e)) := by + obtain ⟨tau, _htau, hfactor⟩ := + exists_splitTraceCoverPolynomial_normalized_frobenius_factorization + (K := K) p sigma d e + rw [hfactor] + exact not_irreducible_pow (Fact.out : p.Prime).ne_one + +/-- Hence the normalized cover is not irreducible whenever the characteristic divides both +covering exponents. The hypotheses `sigma ≠ 0,1` do not repair this obstruction. -/ +theorem splitTraceCoverPolynomial_normalized_not_irreducible_when_exponents_equal_char + [PerfectField K] (p : ℕ) [Fact p.Prime] [CharP K p] + (sigma : K) : + ¬ Irreducible (splitTraceCoverPolynomial (1 : K) sigma p p) := by + simpa using + (splitTraceCoverPolynomial_normalized_not_irreducible_when_char_mul_exponents + (K := K) p sigma 1 1) + +/-- Direct logical form of the repaired counterexample: even after imposing the current +normalized nondegeneracy assumptions, the published conclusion fails if the characteristic +divides both exponents. -/ +theorem normalizedTraceCoverIrreducibility_requires_commonCharacteristicExclusion + [PerfectField K] (p : ℕ) [Fact p.Prime] [CharP K p] + (sigma : K) (hsigma : sigma ≠ 0) (hnondegenerate : sigma ≠ 1) : + (sigma ≠ 0 ∧ sigma ≠ 1) ∧ + ¬ Irreducible (splitTraceCoverPolynomial (1 : K) sigma p p) := by + exact ⟨⟨hsigma, hnondegenerate⟩, + splitTraceCoverPolynomial_normalized_not_irreducible_when_exponents_equal_char p sigma⟩ + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/Kummer.lean b/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/Kummer.lean new file mode 100644 index 0000000000..b10c4ae011 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/Kummer.lean @@ -0,0 +1,596 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.Geometry +public import Mathlib.FieldTheory.KummerExtension +public import Mathlib.FieldTheory.RatFunc.Degree +public import Mathlib.RingTheory.Norm.Basic + +/-! +# Kummer descent for the split trace power cover + +The normalized split trace cover is obtained from the base curve + +`u * (1 - u) * v^2 + sigma * u - 1 = 0` + +by adjoining `eta` and `xi` with `eta^e = v` and `xi^d = u * v`. This file makes that +two-stage Kummer construction explicit. Oddness is imposed because Mathlib's composite-binomial +criterion currently covers odd exponents; coprimality of `d` and `e` is used in the second norm +argument. Neither hypothesis is hidden in a structure field. +-/ + +@[expose] public section + +namespace BGS.Markoff + +open Polynomial AdjoinRoot + +noncomputable section + +section ExactPowerSubstitution + +variable {L : Type*} [Field L] + +/-- The two Kummer root relations really land on the correctly cleared trace-cover polynomial. -/ +theorem eval_splitTraceCoverPolynomial_of_powerRootRelations + (sigma u v xi eta : L) (d e : ℕ) + (hbase : u * (1 - u) * v ^ 2 + sigma * u - 1 = 0) + (heta : eta ^ e = v) (hxi : xi ^ d = u * v) : + MvPolynomial.eval ![xi, eta] (splitTraceCoverPolynomial 1 sigma d e) = 0 := by + rw [eval_splitTraceCoverPolynomial] + have hetaTwo : eta ^ (2 * e) = (eta ^ e) ^ 2 := by + simpa [Nat.mul_comm] using (pow_mul eta e 2) + have hxiTwo : xi ^ (2 * d) = (xi ^ d) ^ 2 := by + simpa [Nat.mul_comm] using (pow_mul xi d 2) + rw [hetaTwo, hxiTwo, heta, hxi] + linear_combination v * hbase + +end ExactPowerSubstitution + +section RationalBase + +variable {K : Type*} [Field K] + +/-- Numerator of the quadratic radicand on the rational `u`-line. -/ +def splitTraceRadicandNumerator (sigma : K) : K[X] := + 1 - C sigma * X + +/-- Denominator of the quadratic radicand on the rational `u`-line. -/ +def splitTraceRadicandDenominator : K[X] := + X * (1 - X) + +/-- The base trace curve has function equation `v^2 = splitTraceRadicand sigma`. -/ +def splitTraceRadicand (sigma : K) : RatFunc K := + algebraMap K[X] (RatFunc K) (splitTraceRadicandNumerator sigma) / + algebraMap K[X] (RatFunc K) splitTraceRadicandDenominator + +lemma splitTraceRadicandNumerator_natDegree (sigma : K) (hsigma : sigma ≠ 0) : + (splitTraceRadicandNumerator sigma).natDegree = 1 := by + rw [← Polynomial.degree_eq_iff_natDegree_eq_of_pos (by norm_num : 0 < 1)] + rw [splitTraceRadicandNumerator] + compute_degree! + +lemma splitTraceRadicandDenominator_natDegree : + (splitTraceRadicandDenominator : K[X]).natDegree = 2 := by + rw [← Polynomial.degree_eq_iff_natDegree_eq_of_pos (by norm_num : 0 < 2)] + rw [splitTraceRadicandDenominator] + compute_degree! + +lemma splitTraceRadicandNumerator_ne_zero (sigma : K) (hsigma : sigma ≠ 0) : + splitTraceRadicandNumerator sigma ≠ 0 := by + intro h + have := congrArg Polynomial.natDegree h + simp [splitTraceRadicandNumerator_natDegree sigma hsigma] at this + +lemma splitTraceRadicandDenominator_ne_zero : + (splitTraceRadicandDenominator : K[X]) ≠ 0 := by + intro h + have := congrArg Polynomial.natDegree h + simp [splitTraceRadicandDenominator_natDegree (K := K)] at this + +lemma splitTraceRadicand_ne_zero (sigma : K) (hsigma : sigma ≠ 0) : + splitTraceRadicand sigma ≠ 0 := by + apply div_ne_zero + · exact (map_ne_zero_iff _ (RatFunc.algebraMap_injective K)).mpr + (splitTraceRadicandNumerator_ne_zero sigma hsigma) + · exact (map_ne_zero_iff _ (RatFunc.algebraMap_injective K)).mpr + (splitTraceRadicandDenominator_ne_zero (K := K)) + +lemma splitTraceRadicand_intDegree (sigma : K) (hsigma : sigma ≠ 0) : + (splitTraceRadicand sigma).intDegree = -1 := by + rw [splitTraceRadicand, RatFunc.intDegree_div] + · rw [RatFunc.intDegree_polynomial, RatFunc.intDegree_polynomial, + splitTraceRadicandNumerator_natDegree sigma hsigma, + splitTraceRadicandDenominator_natDegree] + norm_num + · exact (map_ne_zero_iff _ (RatFunc.algebraMap_injective K)).mpr + (splitTraceRadicandNumerator_ne_zero sigma hsigma) + · exact (map_ne_zero_iff _ (RatFunc.algebraMap_injective K)).mpr + (splitTraceRadicandDenominator_ne_zero (K := K)) + +/-- The rational radicand satisfies the cleared base trace equation before adjoining its square +root. -/ +lemma splitTraceRadicand_equation (sigma : K) : + RatFunc.X * (1 - RatFunc.X) * splitTraceRadicand sigma + + RatFunc.C sigma * RatFunc.X - 1 = 0 := by + have hOneNeX : (1 : RatFunc K) ≠ RatFunc.X := by + intro h + have hDegree := congrArg RatFunc.intDegree h + norm_num at hDegree + have hDenominator : + RatFunc.X * (1 - RatFunc.X) ≠ (0 : RatFunc K) := + mul_ne_zero RatFunc.X_ne_zero (sub_ne_zero.mpr hOneNeX) + simp only [splitTraceRadicand, splitTraceRadicandNumerator, + splitTraceRadicandDenominator, map_sub, map_one, map_mul, + RatFunc.algebraMap_C, RatFunc.algebraMap_X] + field_simp [hDenominator] + ring_nf + simp [RatFunc.X_ne_zero] + +lemma RatFunc.intDegree_pow (z : RatFunc K) (hz : z ≠ 0) (n : ℕ) : + (z ^ n).intDegree = (n : ℤ) * z.intDegree := by + induction n with + | zero => simp + | succ n ih => + rw [pow_succ, RatFunc.intDegree_mul (pow_ne_zero n hz) hz, ih] + push_cast + ring + +/-- An element of rational-function degree not divisible by `q` cannot be a `q`-th power. -/ +lemma RatFunc.pow_ne_of_not_dvd_intDegree + (a : RatFunc K) (ha : a ≠ 0) (q : ℕ) (hdegree : ¬ (q : ℤ) ∣ a.intDegree) + (z : RatFunc K) : + z ^ q ≠ a := by + intro hpow + by_cases hq : q = 0 + · subst q + apply hdegree + rw [← hpow] + simp + have hz : z ≠ 0 := by + intro hz + apply ha + simpa [hz, hq] using hpow.symm + apply hdegree + refine ⟨z.intDegree, ?_⟩ + rw [← hpow, RatFunc.intDegree_pow z hz q] + +/-- The monic quadratic defining the base function field. -/ +def splitTraceBaseKummerPolynomial (sigma : K) : Polynomial (RatFunc K) := + X ^ 2 - C (splitTraceRadicand sigma) + +theorem splitTraceBaseKummerPolynomial_irreducible + (sigma : K) (hsigma : sigma ≠ 0) : + Irreducible (splitTraceBaseKummerPolynomial sigma) := by + rw [splitTraceBaseKummerPolynomial] + apply X_pow_sub_C_irreducible_of_prime Nat.prime_two + intro z + apply RatFunc.pow_ne_of_not_dvd_intDegree + (splitTraceRadicand sigma) (splitTraceRadicand_ne_zero sigma hsigma) + rw [splitTraceRadicand_intDegree sigma hsigma] + norm_num + +/-- The quadratic base root has norm `-splitTraceRadicand sigma`. -/ +lemma norm_splitTraceBaseRoot + (sigma : K) (hsigma : sigma ≠ 0) : + letI : Fact (Irreducible (splitTraceBaseKummerPolynomial sigma)) := + ⟨splitTraceBaseKummerPolynomial_irreducible sigma hsigma⟩ + Algebra.norm (RatFunc K) + (AdjoinRoot.root (splitTraceBaseKummerPolynomial sigma)) = + -splitTraceRadicand sigma := by + let hIrred := splitTraceBaseKummerPolynomial_irreducible sigma hsigma + let : Fact (Irreducible (splitTraceBaseKummerPolynomial sigma)) := ⟨hIrred⟩ + let pb := AdjoinRoot.powerBasis hIrred.ne_zero + have hdim : pb.dim = 2 := by + change (splitTraceBaseKummerPolynomial sigma).natDegree = 2 + simp [splitTraceBaseKummerPolynomial] + change Algebra.norm (RatFunc K) pb.gen = -splitTraceRadicand sigma + rw [Algebra.PowerBasis.norm_gen_eq_coeff_zero_minpoly, hdim, + AdjoinRoot.minpoly_powerBasis_gen_of_monic] + · simp [ splitTraceBaseKummerPolynomial] + · exact monic_X_pow_sub_C _ (by norm_num) + +/-- A prime-power root of the base coordinate `v` cannot already lie in the quadratic base +function field. The obstruction is the rational-function degree `-1` of its norm. -/ +theorem splitTraceBaseRoot_not_primePower + (sigma : K) (hsigma : sigma ≠ 0) (q : ℕ) (hq : q.Prime) + (z : AdjoinRoot (splitTraceBaseKummerPolynomial sigma)) : + z ^ q ≠ AdjoinRoot.root (splitTraceBaseKummerPolynomial sigma) := by + let hIrred := splitTraceBaseKummerPolynomial_irreducible sigma hsigma + let : Fact (Irreducible (splitTraceBaseKummerPolynomial sigma)) := ⟨hIrred⟩ + intro hpow + have hnorm := congrArg (Algebra.norm (RatFunc K)) hpow + rw [map_pow, norm_splitTraceBaseRoot sigma hsigma] at hnorm + have hRadicandNegNe : -splitTraceRadicand sigma ≠ 0 := + neg_ne_zero.mpr (splitTraceRadicand_ne_zero sigma hsigma) + have hNotDvd : ¬ (q : ℤ) ∣ (-splitTraceRadicand sigma).intDegree := by + rw [RatFunc.intDegree_neg, splitTraceRadicand_intDegree sigma hsigma] + intro hdvd + rw [Int.natCast_dvd] at hdvd + exact hq.ne_one (Nat.eq_one_of_dvd_one hdvd) + exact RatFunc.pow_ne_of_not_dvd_intDegree + (-splitTraceRadicand sigma) hRadicandNegNe q hNotDvd + (Algebra.norm (RatFunc K) z) hnorm + +/-- For every positive odd `e`, adjoining an `e`-th root of the base coordinate `v` is a genuine +degree-`e` Kummer extension. -/ +theorem splitTraceEtaKummerPolynomial_irreducible + (sigma : K) (hsigma : sigma ≠ 0) (e : ℕ) (heOdd : Odd e) : + letI : Fact (Irreducible (splitTraceBaseKummerPolynomial sigma)) := + ⟨splitTraceBaseKummerPolynomial_irreducible sigma hsigma⟩ + Irreducible + (X ^ e - C (AdjoinRoot.root (splitTraceBaseKummerPolynomial sigma))) := by + let hBaseIrred := splitTraceBaseKummerPolynomial_irreducible sigma hsigma + let : Fact (Irreducible (splitTraceBaseKummerPolynomial sigma)) := ⟨hBaseIrred⟩ + apply X_pow_sub_C_irreducible_of_odd heOdd + intro q hq _ z + exact splitTraceBaseRoot_not_primePower sigma hsigma q hq z + +/-- The rational parameter `u`, embedded in the quadratic base function field. -/ +def splitTraceBaseU (sigma : K) : + AdjoinRoot (splitTraceBaseKummerPolynomial sigma) := + algebraMap (RatFunc K) _ RatFunc.X + +/-- The quadratic coordinate `v` in the base function field. -/ +def splitTraceBaseV (sigma : K) : + AdjoinRoot (splitTraceBaseKummerPolynomial sigma) := + AdjoinRoot.root (splitTraceBaseKummerPolynomial sigma) + +/-- The two base coordinates satisfy the birational trace equation inside the quadratic function +field. -/ +lemma splitTraceBaseU_V_equation + (sigma : K) (hsigma : sigma ≠ 0) : + letI : Fact (Irreducible (splitTraceBaseKummerPolynomial sigma)) := + ⟨splitTraceBaseKummerPolynomial_irreducible sigma hsigma⟩ + splitTraceBaseU sigma * (1 - splitTraceBaseU sigma) * splitTraceBaseV sigma ^ 2 + + algebraMap (RatFunc K) (AdjoinRoot (splitTraceBaseKummerPolynomial sigma)) + (RatFunc.C sigma) * splitTraceBaseU sigma - 1 = 0 := by + let hBaseIrred := splitTraceBaseKummerPolynomial_irreducible sigma hsigma + let : Fact (Irreducible (splitTraceBaseKummerPolynomial sigma)) := ⟨hBaseIrred⟩ + have hRootSquare : splitTraceBaseV sigma ^ 2 = + algebraMap (RatFunc K) (AdjoinRoot (splitTraceBaseKummerPolynomial sigma)) + (splitTraceRadicand sigma) := by + apply sub_eq_zero.mp + have h := AdjoinRoot.eval₂_root (splitTraceBaseKummerPolynomial sigma) + rw [splitTraceBaseKummerPolynomial] at h + simp only [Polynomial.eval₂_sub, Polynomial.eval₂_pow, Polynomial.eval₂_X, + Polynomial.eval₂_C] at h + rw [← AdjoinRoot.algebraMap_eq] at h + exact h + have hMapped := congrArg + (algebraMap (RatFunc K) (AdjoinRoot (splitTraceBaseKummerPolynomial sigma))) + (splitTraceRadicand_equation sigma) + simp only [map_add, map_sub, map_mul, map_one, map_zero] at hMapped + rw [splitTraceBaseU, hRootSquare] + exact hMapped + +lemma splitTraceBaseFunctionField_finrank + (sigma : K) (hsigma : sigma ≠ 0) : + letI : Fact (Irreducible (splitTraceBaseKummerPolynomial sigma)) := + ⟨splitTraceBaseKummerPolynomial_irreducible sigma hsigma⟩ + Module.finrank (RatFunc K) + (AdjoinRoot (splitTraceBaseKummerPolynomial sigma)) = 2 := by + let hIrred := splitTraceBaseKummerPolynomial_irreducible sigma hsigma + let : Fact (Irreducible (splitTraceBaseKummerPolynomial sigma)) := ⟨hIrred⟩ + rw [PowerBasis.finrank (AdjoinRoot.powerBasis hIrred.ne_zero)] + change (splitTraceBaseKummerPolynomial sigma).natDegree = 2 + simp [splitTraceBaseKummerPolynomial] + +/-- The norm of `u * v` has rational-function degree one. This is the second independent divisor +obstruction used after adjoining the `e`-th root of `v`. -/ +lemma norm_splitTraceBaseU_mul_V_intDegree + (sigma : K) (hsigma : sigma ≠ 0) : + letI : Fact (Irreducible (splitTraceBaseKummerPolynomial sigma)) := + ⟨splitTraceBaseKummerPolynomial_irreducible sigma hsigma⟩ + (Algebra.norm (RatFunc K) (splitTraceBaseU sigma * splitTraceBaseV sigma)).intDegree = 1 := by + let hIrred := splitTraceBaseKummerPolynomial_irreducible sigma hsigma + let : Fact (Irreducible (splitTraceBaseKummerPolynomial sigma)) := ⟨hIrred⟩ + have hNorm : Algebra.norm (RatFunc K) (splitTraceBaseU sigma * splitTraceBaseV sigma) = + RatFunc.X ^ 2 * (-splitTraceRadicand sigma) := by + rw [map_mul] + rw [splitTraceBaseU, Algebra.norm_algebraMap, + splitTraceBaseFunctionField_finrank sigma hsigma] + rw [splitTraceBaseV, norm_splitTraceBaseRoot sigma hsigma] + rw [hNorm, RatFunc.intDegree_mul] + · rw [RatFunc.intDegree_pow RatFunc.X RatFunc.X_ne_zero, + RatFunc.intDegree_X, RatFunc.intDegree_neg, + splitTraceRadicand_intDegree sigma hsigma] + norm_num + · exact pow_ne_zero 2 RatFunc.X_ne_zero + · exact neg_ne_zero.mpr (splitTraceRadicand_ne_zero sigma hsigma) + +/-- The first Kummer polynomial, adjoining `eta` with `eta^e = v`. -/ +def splitTraceEtaKummerPolynomial (sigma : K) (e : ℕ) : + Polynomial (AdjoinRoot (splitTraceBaseKummerPolynomial sigma)) := + X ^ e - C (splitTraceBaseV sigma) + +lemma splitTraceEtaKummerPolynomial_irreducible' + (sigma : K) (hsigma : sigma ≠ 0) (e : ℕ) (heOdd : Odd e) : + letI : Fact (Irreducible (splitTraceBaseKummerPolynomial sigma)) := + ⟨splitTraceBaseKummerPolynomial_irreducible sigma hsigma⟩ + Irreducible (splitTraceEtaKummerPolynomial sigma e) := by + simpa [splitTraceEtaKummerPolynomial, splitTraceBaseV] using + splitTraceEtaKummerPolynomial_irreducible sigma hsigma e heOdd + +lemma splitTraceEtaFunctionField_finrank + (sigma : K) (hsigma : sigma ≠ 0) (e : ℕ) (heOdd : Odd e) : + letI : Fact (Irreducible (splitTraceBaseKummerPolynomial sigma)) := + ⟨splitTraceBaseKummerPolynomial_irreducible sigma hsigma⟩ + letI : Fact (Irreducible (splitTraceEtaKummerPolynomial sigma e)) := + ⟨splitTraceEtaKummerPolynomial_irreducible' sigma hsigma e heOdd⟩ + Module.finrank (AdjoinRoot (splitTraceBaseKummerPolynomial sigma)) + (AdjoinRoot (splitTraceEtaKummerPolynomial sigma e)) = e := by + let hBaseIrred := splitTraceBaseKummerPolynomial_irreducible sigma hsigma + let : Fact (Irreducible (splitTraceBaseKummerPolynomial sigma)) := ⟨hBaseIrred⟩ + let hEtaIrred := splitTraceEtaKummerPolynomial_irreducible' sigma hsigma e heOdd + let : Fact (Irreducible (splitTraceEtaKummerPolynomial sigma e)) := ⟨hEtaIrred⟩ + rw [PowerBasis.finrank (AdjoinRoot.powerBasis hEtaIrred.ne_zero)] + change (splitTraceEtaKummerPolynomial sigma e).natDegree = e + simp [splitTraceEtaKummerPolynomial] + +/-- The second Kummer radicand, corresponding to `xi^d = u * v`. -/ +def splitTraceXiRadicand (sigma : K) (e : ℕ) : + AdjoinRoot (splitTraceEtaKummerPolynomial sigma e) := + algebraMap (AdjoinRoot (splitTraceBaseKummerPolynomial sigma)) _ + (splitTraceBaseU sigma * splitTraceBaseV sigma) + +/-- After adjoining the `e`-th root of `v`, the element `u*v` is not a `q`-th power whenever +`q` is prime and coprime to `e`. The proof takes two successive norms; their rational-function +degree forces `q` to divide `e`, a contradiction. -/ +theorem splitTraceXiRadicand_not_primePower + (sigma : K) (hsigma : sigma ≠ 0) (e : ℕ) (heOdd : Odd e) + (q : ℕ) (hq : q.Prime) (hqe : ¬ q ∣ e) + (z : AdjoinRoot (splitTraceEtaKummerPolynomial sigma e)) : + z ^ q ≠ splitTraceXiRadicand sigma e := by + let hBaseIrred := splitTraceBaseKummerPolynomial_irreducible sigma hsigma + let : Fact (Irreducible (splitTraceBaseKummerPolynomial sigma)) := ⟨hBaseIrred⟩ + let hEtaIrred := splitTraceEtaKummerPolynomial_irreducible' sigma hsigma e heOdd + let : Fact (Irreducible (splitTraceEtaKummerPolynomial sigma e)) := ⟨hEtaIrred⟩ + let : Module.Finite (RatFunc K) + (AdjoinRoot (splitTraceBaseKummerPolynomial sigma)) := + (monic_X_pow_sub_C _ (by norm_num : (2 : ℕ) ≠ 0)).finite_adjoinRoot + have he : e ≠ 0 := by + rintro rfl + simp at heOdd + let : Module.Finite (AdjoinRoot (splitTraceBaseKummerPolynomial sigma)) + (AdjoinRoot (splitTraceEtaKummerPolynomial sigma e)) := + (monic_X_pow_sub_C _ he).finite_adjoinRoot + have hBaseV : splitTraceBaseV sigma ≠ 0 := by + change AdjoinRoot.root (splitTraceBaseKummerPolynomial sigma) ≠ 0 + have hroot := (root_X_pow_sub_C_ne_zero_iff hBaseIrred).mpr + (splitTraceRadicand_ne_zero sigma hsigma) + exact hroot + have hBaseU : splitTraceBaseU sigma ≠ 0 := by + exact (map_ne_zero_iff _ + (algebraMap (RatFunc K) + (AdjoinRoot (splitTraceBaseKummerPolynomial sigma))).injective).mpr RatFunc.X_ne_zero + have hBaseUV : splitTraceBaseU sigma * splitTraceBaseV sigma ≠ 0 := + mul_ne_zero hBaseU hBaseV + have hXiRadicand : splitTraceXiRadicand sigma e ≠ 0 := by + exact (map_ne_zero_iff _ + (algebraMap (AdjoinRoot (splitTraceBaseKummerPolynomial sigma)) + (AdjoinRoot (splitTraceEtaKummerPolynomial sigma e))).injective).mpr hBaseUV + intro hpow + have hz : z ≠ 0 := by + intro hz + apply hXiRadicand + simpa [hz, hq.ne_zero] using hpow.symm + have hFirstNorm := congrArg + (Algebra.norm (AdjoinRoot (splitTraceBaseKummerPolynomial sigma))) hpow + rw [map_pow, splitTraceXiRadicand, Algebra.norm_algebraMap, + splitTraceEtaFunctionField_finrank sigma hsigma e heOdd] at hFirstNorm + have hSecondNorm := congrArg (Algebra.norm (RatFunc K)) hFirstNorm + rw [map_pow, map_pow] at hSecondNorm + have hNormZNe : + Algebra.norm (AdjoinRoot (splitTraceBaseKummerPolynomial sigma)) z ≠ 0 := + Algebra.norm_ne_zero_iff.mpr hz + have hDoubleNormZNe : + Algebra.norm (RatFunc K) + (Algebra.norm (AdjoinRoot (splitTraceBaseKummerPolynomial sigma)) z) ≠ 0 := + Algebra.norm_ne_zero_iff.mpr hNormZNe + have hNormBaseUVNe : + Algebra.norm (RatFunc K) (splitTraceBaseU sigma * splitTraceBaseV sigma) ≠ 0 := + Algebra.norm_ne_zero_iff.mpr hBaseUV + have hDegree := congrArg RatFunc.intDegree hSecondNorm + rw [RatFunc.intDegree_pow _ hDoubleNormZNe, + RatFunc.intDegree_pow _ hNormBaseUVNe, + norm_splitTraceBaseU_mul_V_intDegree sigma hsigma] at hDegree + apply hqe + rw [← Int.natCast_dvd_natCast] + exact ⟨_, by simpa using hDegree.symm⟩ + +/-- The second Kummer polynomial, adjoining `xi` with `xi^d = u*v`. -/ +def splitTraceXiKummerPolynomial (sigma : K) (e d : ℕ) : + Polynomial (AdjoinRoot (splitTraceEtaKummerPolynomial sigma e)) := + X ^ d - C (splitTraceXiRadicand sigma e) + +/-- The three fields in the explicit Kummer tower. -/ +abbrev SplitTraceBaseFunctionField (K : Type*) [Field K] (sigma : K) := + AdjoinRoot (splitTraceBaseKummerPolynomial sigma) + +abbrev SplitTraceEtaFunctionField (K : Type*) [Field K] (sigma : K) (e : ℕ) := + AdjoinRoot (splitTraceEtaKummerPolynomial sigma e) + +abbrev SplitTraceXiFunctionField (K : Type*) [Field K] (sigma : K) (e d : ℕ) := + AdjoinRoot (splitTraceXiKummerPolynomial sigma e d) + +/-- Embed a base-function-field element through both Kummer stages. -/ +def splitTraceBaseElementInXiField (sigma : K) (e d : ℕ) + (a : SplitTraceBaseFunctionField K sigma) : + SplitTraceXiFunctionField K sigma e d := + algebraMap (SplitTraceEtaFunctionField K sigma e) _ + (algebraMap (SplitTraceBaseFunctionField K sigma) _ a) + +/-- The canonical `eta` root, embedded into the top Kummer field. -/ +def splitTraceEtaRootInXiField (sigma : K) (e d : ℕ) : + SplitTraceXiFunctionField K sigma e d := + algebraMap (SplitTraceEtaFunctionField K sigma e) _ + (AdjoinRoot.root (splitTraceEtaKummerPolynomial sigma e)) + +/-- The canonical `xi` root in the top Kummer field. -/ +def splitTraceXiRoot (sigma : K) (e d : ℕ) : + SplitTraceXiFunctionField K sigma e d := + AdjoinRoot.root (splitTraceXiKummerPolynomial sigma e d) + +/-- For positive odd coprime exponents, the second Kummer polynomial is irreducible. This is the +connectedness step that the printed translate argument does not supply. -/ +theorem splitTraceXiKummerPolynomial_irreducible + (sigma : K) (hsigma : sigma ≠ 0) (e d : ℕ) + (heOdd : Odd e) (hdOdd : Odd d) (hde : d.Coprime e) : + letI : Fact (Irreducible (splitTraceBaseKummerPolynomial sigma)) := + ⟨splitTraceBaseKummerPolynomial_irreducible sigma hsigma⟩ + letI : Fact (Irreducible (splitTraceEtaKummerPolynomial sigma e)) := + ⟨splitTraceEtaKummerPolynomial_irreducible' sigma hsigma e heOdd⟩ + Irreducible (splitTraceXiKummerPolynomial sigma e d) := by + let hBaseIrred := splitTraceBaseKummerPolynomial_irreducible sigma hsigma + let : Fact (Irreducible (splitTraceBaseKummerPolynomial sigma)) := ⟨hBaseIrred⟩ + let hEtaIrred := splitTraceEtaKummerPolynomial_irreducible' sigma hsigma e heOdd + let : Fact (Irreducible (splitTraceEtaKummerPolynomial sigma e)) := ⟨hEtaIrred⟩ + rw [splitTraceXiKummerPolynomial] + apply X_pow_sub_C_irreducible_of_odd hdOdd + intro q hq hqd z + have hqe : ¬ q ∣ e := + (hq.coprime_iff_not_dvd.mp (Nat.Coprime.of_dvd_left hqd hde)) + exact splitTraceXiRadicand_not_primePower sigma hsigma e heOdd q hq hqe z + +/-- The canonical roots of the proved Kummer tower lie on the exact cleared trace-cover +polynomial. This connects the function-field construction back to `splitTraceCoverPolynomial`. -/ +theorem splitTraceKummerTower_roots_on_cover + (sigma : K) (hsigma : sigma ≠ 0) + (e d : ℕ) (heOdd : Odd e) (hdOdd : Odd d) (hde : d.Coprime e) : + letI : Fact (Irreducible (splitTraceBaseKummerPolynomial sigma)) := + ⟨splitTraceBaseKummerPolynomial_irreducible sigma hsigma⟩ + letI : Fact (Irreducible (splitTraceEtaKummerPolynomial sigma e)) := + ⟨splitTraceEtaKummerPolynomial_irreducible' sigma hsigma e heOdd⟩ + letI : Fact (Irreducible (splitTraceXiKummerPolynomial sigma e d)) := + ⟨splitTraceXiKummerPolynomial_irreducible sigma hsigma e d heOdd hdOdd hde⟩ + MvPolynomial.eval + ![splitTraceXiRoot sigma e d, splitTraceEtaRootInXiField sigma e d] + (splitTraceCoverPolynomial 1 + (splitTraceBaseElementInXiField sigma e d + (algebraMap (RatFunc K) (SplitTraceBaseFunctionField K sigma) (RatFunc.C sigma))) + d e) = 0 := by + let hBaseIrred := splitTraceBaseKummerPolynomial_irreducible sigma hsigma + let : Fact (Irreducible (splitTraceBaseKummerPolynomial sigma)) := ⟨hBaseIrred⟩ + let hEtaIrred := splitTraceEtaKummerPolynomial_irreducible' sigma hsigma e heOdd + let : Fact (Irreducible (splitTraceEtaKummerPolynomial sigma e)) := ⟨hEtaIrred⟩ + let hXiIrred := + splitTraceXiKummerPolynomial_irreducible sigma hsigma e d heOdd hdOdd hde + let : Fact (Irreducible (splitTraceXiKummerPolynomial sigma e d)) := ⟨hXiIrred⟩ + let baseToXi : SplitTraceBaseFunctionField K sigma →+* + SplitTraceXiFunctionField K sigma e d := + (algebraMap (SplitTraceEtaFunctionField K sigma e) + (SplitTraceXiFunctionField K sigma e d)).comp + (algebraMap (SplitTraceBaseFunctionField K sigma) + (SplitTraceEtaFunctionField K sigma e)) + have hBase := splitTraceBaseU_V_equation sigma hsigma + have hBaseTop := congrArg baseToXi hBase + simp only [map_add, map_sub, map_mul, map_pow, map_one, map_zero] at hBaseTop + have hEtaRoot : + (AdjoinRoot.root (splitTraceEtaKummerPolynomial sigma e)) ^ e = + algebraMap (SplitTraceBaseFunctionField K sigma) + (SplitTraceEtaFunctionField K sigma e) (splitTraceBaseV sigma) := by + apply sub_eq_zero.mp + have h := AdjoinRoot.eval₂_root (splitTraceEtaKummerPolynomial sigma e) + rw [splitTraceEtaKummerPolynomial] at h + simp only [Polynomial.eval₂_sub, Polynomial.eval₂_pow, Polynomial.eval₂_X, + Polynomial.eval₂_C] at h + rw [← AdjoinRoot.algebraMap_eq] at h + exact h + have hEtaTop := congrArg + (algebraMap (SplitTraceEtaFunctionField K sigma e) + (SplitTraceXiFunctionField K sigma e d)) hEtaRoot + simp only [map_pow] at hEtaTop + have hXiRoot : + (splitTraceXiRoot sigma e d) ^ d = + algebraMap (SplitTraceEtaFunctionField K sigma e) + (SplitTraceXiFunctionField K sigma e d) (splitTraceXiRadicand sigma e) := by + apply sub_eq_zero.mp + have h := AdjoinRoot.eval₂_root (splitTraceXiKummerPolynomial sigma e d) + rw [splitTraceXiKummerPolynomial] at h + simp only [Polynomial.eval₂_sub, Polynomial.eval₂_pow, Polynomial.eval₂_X, + Polynomial.eval₂_C] at h + rw [← AdjoinRoot.algebraMap_eq] at h + exact h + apply eval_splitTraceCoverPolynomial_of_powerRootRelations + (splitTraceBaseElementInXiField sigma e d + (algebraMap (RatFunc K) (SplitTraceBaseFunctionField K sigma) (RatFunc.C sigma))) + (splitTraceBaseElementInXiField sigma e d (splitTraceBaseU sigma)) + (splitTraceBaseElementInXiField sigma e d (splitTraceBaseV sigma)) + (splitTraceXiRoot sigma e d) (splitTraceEtaRootInXiField sigma e d) d e + · simpa [baseToXi, splitTraceBaseElementInXiField] using hBaseTop + · simpa [splitTraceEtaRootInXiField, splitTraceBaseElementInXiField, baseToXi] using hEtaTop + · simpa [splitTraceXiRadicand, splitTraceBaseElementInXiField, baseToXi, + splitTraceXiRoot] using hXiRoot + +lemma splitTraceXiFunctionField_finrank + (sigma : K) (hsigma : sigma ≠ 0) (e d : ℕ) + (heOdd : Odd e) (hdOdd : Odd d) (hde : d.Coprime e) : + letI : Fact (Irreducible (splitTraceBaseKummerPolynomial sigma)) := + ⟨splitTraceBaseKummerPolynomial_irreducible sigma hsigma⟩ + letI : Fact (Irreducible (splitTraceEtaKummerPolynomial sigma e)) := + ⟨splitTraceEtaKummerPolynomial_irreducible' sigma hsigma e heOdd⟩ + letI : Fact (Irreducible (splitTraceXiKummerPolynomial sigma e d)) := + ⟨splitTraceXiKummerPolynomial_irreducible sigma hsigma e d heOdd hdOdd hde⟩ + Module.finrank (AdjoinRoot (splitTraceEtaKummerPolynomial sigma e)) + (AdjoinRoot (splitTraceXiKummerPolynomial sigma e d)) = d := by + let hBaseIrred := splitTraceBaseKummerPolynomial_irreducible sigma hsigma + let : Fact (Irreducible (splitTraceBaseKummerPolynomial sigma)) := ⟨hBaseIrred⟩ + let hEtaIrred := splitTraceEtaKummerPolynomial_irreducible' sigma hsigma e heOdd + let : Fact (Irreducible (splitTraceEtaKummerPolynomial sigma e)) := ⟨hEtaIrred⟩ + let hXiIrred := + splitTraceXiKummerPolynomial_irreducible sigma hsigma e d heOdd hdOdd hde + let : Fact (Irreducible (splitTraceXiKummerPolynomial sigma e d)) := ⟨hXiIrred⟩ + rw [PowerBasis.finrank (AdjoinRoot.powerBasis hXiIrred.ne_zero)] + change (splitTraceXiKummerPolynomial sigma e d).natDegree = d + simp [splitTraceXiKummerPolynomial] + +/-- The iterated Kummer function-field tower for the odd, coprime split trace power cover is a +domain. All three irreducibility facts are constructed from the explicit norm-degree arguments +above; none is assumed as a field or typeclass parameter. This theorem does not yet identify the +tower with a localization or tensor base change of the affine coordinate ring. -/ +theorem splitTraceOddCoprimeKummerTower_isDomain + (sigma : K) (hsigma : sigma ≠ 0) + (e d : ℕ) (heOdd : Odd e) (hdOdd : Odd d) (hde : d.Coprime e) : + letI : Fact (Irreducible (splitTraceBaseKummerPolynomial sigma)) := + ⟨splitTraceBaseKummerPolynomial_irreducible sigma hsigma⟩ + letI : Fact (Irreducible (splitTraceEtaKummerPolynomial sigma e)) := + ⟨splitTraceEtaKummerPolynomial_irreducible' sigma hsigma e heOdd⟩ + IsDomain (AdjoinRoot (splitTraceXiKummerPolynomial sigma e d)) := by + let hBaseIrred := splitTraceBaseKummerPolynomial_irreducible sigma hsigma + let : Fact (Irreducible (splitTraceBaseKummerPolynomial sigma)) := ⟨hBaseIrred⟩ + let hEtaIrred := splitTraceEtaKummerPolynomial_irreducible' sigma hsigma e heOdd + let : Fact (Irreducible (splitTraceEtaKummerPolynomial sigma e)) := ⟨hEtaIrred⟩ + let hXiIrred := + splitTraceXiKummerPolynomial_irreducible sigma hsigma e d heOdd hdOdd hde + let : Fact (Irreducible (splitTraceXiKummerPolynomial sigma e d)) := ⟨hXiIrred⟩ + exact AdjoinRoot.isDomain_of_prime hXiIrred.prime + +/-- Reconstructing the same explicit Kummer tower after an arbitrary extension of the constant +field again gives a domain. The remaining scheme-level wall is to identify this reconstructed +tower with the localization of the tensor-product base change of the original coordinate ring. -/ +theorem splitTraceOddCoprimeKummerTower_isDomain_afterConstantExtension + {L : Type*} [Field L] (phi : K →+* L) + (sigma : K) (hsigma : sigma ≠ 0) + (e d : ℕ) (heOdd : Odd e) (hdOdd : Odd d) (hde : d.Coprime e) : + letI : Fact (Irreducible (splitTraceBaseKummerPolynomial (phi sigma))) := + ⟨splitTraceBaseKummerPolynomial_irreducible (phi sigma) + ((map_ne_zero_iff phi phi.injective).mpr hsigma)⟩ + letI : Fact (Irreducible (splitTraceEtaKummerPolynomial (phi sigma) e)) := + ⟨splitTraceEtaKummerPolynomial_irreducible' (phi sigma) + ((map_ne_zero_iff phi phi.injective).mpr hsigma) e heOdd⟩ + IsDomain (AdjoinRoot (splitTraceXiKummerPolynomial (phi sigma) e d)) := by + exact splitTraceOddCoprimeKummerTower_isDomain + (phi sigma) ((map_ne_zero_iff phi phi.injective).mpr hsigma) + e d heOdd hdOdd hde + +end RationalBase + +end + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/LaurentComparisonInjectivity.lean b/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/LaurentComparisonInjectivity.lean new file mode 100644 index 0000000000..2a86f7d57f --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/LaurentComparisonInjectivity.lean @@ -0,0 +1,373 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.SyntacticDivisionCriterion +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.WeightedIrreducibility +public import Mathlib.FieldTheory.RatFunc.IntermediateField + +/-! +# Injectivity of the Laurent comparison from cover irreducibility + +This file identifies the remaining Laurent-to-Kummer comparison wall with the actual +irreducibility assertion in the paper. The canonical `eta` coordinate in the Kummer tower is +proved transcendental over the constant field. Consequently it may be used as the coefficient +parameter in a rational-function field. An irreducible cleared cover polynomial then becomes the +minimal polynomial of the `xi` coordinate, so evaluation has exactly the expected principal +kernel. +-/ + +@[expose] public section + +namespace BGS.Markoff + +open Polynomial + +noncomputable section + +variable {K : Type*} [Field K] + +section Transcendence + +/-- The rational radicand is not a constant rational function. -/ +theorem splitTraceRadicand_not_constant (sigma : K) (hsigma : sigma ≠ 0) : + ¬ ∃ c : K, splitTraceRadicand sigma = RatFunc.C c := by + rintro ⟨c, hc⟩ + have hdegree := congrArg RatFunc.intDegree hc + rw [splitTraceRadicand_intDegree sigma hsigma] at hdegree + by_cases hc0 : c = 0 + · subst c + exact splitTraceRadicand_ne_zero sigma hsigma (by simpa using hc) + · simp at hdegree + +/-- The quadratic base coordinate is transcendental over the constant field. -/ +theorem splitTraceBaseV_transcendental (sigma : K) (hsigma : sigma ≠ 0) : + Transcendental K (splitTraceBaseV sigma) := by + let hBaseIrred := splitTraceBaseKummerPolynomial_irreducible sigma hsigma + let : Fact (Irreducible (splitTraceBaseKummerPolynomial sigma)) := ⟨hBaseIrred⟩ + have hradicand : Transcendental K (splitTraceRadicand sigma) := + RatFunc.transcendental_of_ne_C _ + (splitTraceRadicand_not_constant sigma hsigma) + have hmapped : Transcendental K + (algebraMap (RatFunc K) (SplitTraceBaseFunctionField K sigma) + (splitTraceRadicand sigma)) := + (transcendental_algebraMap_iff + (algebraMap (RatFunc K) (SplitTraceBaseFunctionField K sigma)).injective).2 + hradicand + rw [← splitTraceBaseV_sq (sigma := sigma)] at hmapped + intro hV + exact hmapped (hV.pow 2) + +/-- The `eta` coordinate of the explicit odd-coprime Kummer tower is transcendental over `K`. +This is the coefficient-field input needed to turn bivariate evaluation into honest univariate +minimal-polynomial evaluation. -/ +theorem splitTraceEtaRootInXiField_transcendental + (sigma : K) (hsigma : sigma ≠ 0) (e d : ℕ) + (heOdd : Odd e) (hdOdd : Odd d) (hde : d.Coprime e) : + Transcendental K (splitTraceEtaRootInXiField sigma e d) := by + let hBaseIrred := splitTraceBaseKummerPolynomial_irreducible sigma hsigma + let : Fact (Irreducible (splitTraceBaseKummerPolynomial sigma)) := ⟨hBaseIrred⟩ + let hEtaIrred := splitTraceEtaKummerPolynomial_irreducible' sigma hsigma e heOdd + let : Fact (Irreducible (splitTraceEtaKummerPolynomial sigma e)) := ⟨hEtaIrred⟩ + let hXiIrred := + splitTraceXiKummerPolynomial_irreducible sigma hsigma e d heOdd hdOdd hde + let : Fact (Irreducible (splitTraceXiKummerPolynomial sigma e d)) := ⟨hXiIrred⟩ + have hBaseV : Transcendental K (splitTraceBaseV sigma) := + splitTraceBaseV_transcendental sigma hsigma + have hBaseVTop : Transcendental K + (splitTraceBaseElementInXiField sigma e d (splitTraceBaseV sigma)) := by + have hmap : Transcendental K + (algebraMap (SplitTraceBaseFunctionField K sigma) + (SplitTraceXiFunctionField K sigma e d) (splitTraceBaseV sigma)) := + (transcendental_algebraMap_iff + (algebraMap (SplitTraceBaseFunctionField K sigma) + (SplitTraceXiFunctionField K sigma e d)).injective).2 hBaseV + rw [splitTraceBaseElementInXiField, + ← IsScalarTower.algebraMap_apply + (SplitTraceBaseFunctionField K sigma) + (SplitTraceEtaFunctionField K sigma e) + (SplitTraceXiFunctionField K sigma e d)] + exact hmap + rw [← splitTraceEtaRootInXiField_pow (sigma := sigma) (e := e) (d := d)] at hBaseVTop + intro hEta + exact hBaseVTop (hEta.pow e) + +end Transcendence + +section IteratedPresentation + +/-- The cleared cover, viewed as a polynomial in `x` with coefficients in `K[y]`. -/ +noncomputable def splitTraceCoverIteratedPolynomial + (sigma : K) (d e : ℕ) : Polynomial K[X] := + monomial (2 * d) (-(X ^ e)) + + monomial d (X ^ (2 * e) + C sigma) + + C (-(X ^ e)) + +theorem finTwoToIteratedPolynomial_splitTraceCoverPolynomial + (sigma : K) (d e : ℕ) : + finTwoToIteratedPolynomial (K := K) + (splitTraceCoverPolynomial (1 : K) sigma d e) = + splitTraceCoverIteratedPolynomial sigma d e := by + simp [splitTraceCoverPolynomial, splitTraceCoverIteratedPolynomial, + ← Polynomial.C_mul_X_pow_eq_monomial] + ring + +theorem splitTraceCoverIteratedPolynomial_coeff_two_mul + (sigma : K) (d e : ℕ) (hd : d ≠ 0) : + (splitTraceCoverIteratedPolynomial sigma d e).coeff (2 * d) = -(X ^ e) := by + have htwo_d_ne_d : 2 * d ≠ d := by omega + have hd_ne_two_d : d ≠ 2 * d := by omega + have htwo_d_ne_zero : 2 * d ≠ 0 := by omega + rw [splitTraceCoverIteratedPolynomial, coeff_add, coeff_add, + coeff_monomial, coeff_monomial, coeff_C_of_ne_zero htwo_d_ne_zero] + simp [hd_ne_two_d] + +theorem splitTraceCoverIteratedPolynomial_natDegree_ne_zero + (sigma : K) (d e : ℕ) (hd : d ≠ 0) : + (splitTraceCoverIteratedPolynomial sigma d e).natDegree ≠ 0 := by + have hcoeff : (splitTraceCoverIteratedPolynomial sigma d e).coeff (2 * d) ≠ 0 := by + rw [splitTraceCoverIteratedPolynomial_coeff_two_mul sigma d e hd] + exact neg_ne_zero.mpr (pow_ne_zero e X_ne_zero) + have hle := Polynomial.le_natDegree_of_ne_zero hcoeff + omega + +/-- Evaluation through the iterated-polynomial presentation is ordinary bivariate evaluation. +The outer polynomial variable is coordinate `0`, while the coefficient-polynomial variable is +coordinate `1`. -/ +theorem finTwoToIteratedPolynomial_aeval + {A : Type*} [CommRing A] [Algebra K A] + (p : MvPolynomial (Fin 2) K) (x y : A) : + Polynomial.aevalTower (Polynomial.aeval y) x + (finTwoToIteratedPolynomial (K := K) p) = + MvPolynomial.aeval ![x, y] p := by + let lhs : MvPolynomial (Fin 2) K →ₐ[K] A := + (Polynomial.aevalTower (Polynomial.aeval y) x).comp + (finTwoToIteratedPolynomial (K := K)).toAlgHom + let rhs : MvPolynomial (Fin 2) K →ₐ[K] A := + MvPolynomial.aeval ![x, y] + have heq : lhs = rhs := by + apply MvPolynomial.algHom_ext + intro i + fin_cases i <;> + simp [lhs, rhs, finTwoToIteratedPolynomial_X_zero, + finTwoToIteratedPolynomial_X_one] + exact DFunLike.congr_fun heq p + +/-- Evaluate a coefficient polynomial at the transcendental Kummer eta coordinate. -/ +def splitTraceEtaPolynomialEvaluation + (sigma : K) (e d : ℕ) : + K[X] →ₐ[K] SplitTraceXiFunctionField K sigma e d := + Polynomial.aeval (splitTraceEtaRootInXiField sigma e d) + +private theorem splitTraceEtaPolynomialEvaluation_injective + (sigma : K) (hsigma : sigma ≠ 0) (e d : ℕ) + (heOdd : Odd e) (hdOdd : Odd d) (hde : d.Coprime e) : + Function.Injective (splitTraceEtaPolynomialEvaluation sigma e d) := by + exact transcendental_iff_injective.mp + (splitTraceEtaRootInXiField_transcendental + sigma hsigma e d heOdd hdOdd hde) + +/-- Specialize rational functions at the transcendental Kummer eta coordinate. -/ +def splitTraceEtaRatFuncEvaluation + (sigma : K) (hsigma : sigma ≠ 0) (e d : ℕ) + (heOdd : Odd e) (hdOdd : Odd d) (hde : d.Coprime e) : + RatFunc K →ₐ[K] SplitTraceXiFunctionField K sigma e d := by + let hBaseIrred := splitTraceBaseKummerPolynomial_irreducible sigma hsigma + letI : Fact (Irreducible (splitTraceBaseKummerPolynomial sigma)) := ⟨hBaseIrred⟩ + let hEtaIrred := splitTraceEtaKummerPolynomial_irreducible' sigma hsigma e heOdd + letI : Fact (Irreducible (splitTraceEtaKummerPolynomial sigma e)) := ⟨hEtaIrred⟩ + let hXiIrred := + splitTraceXiKummerPolynomial_irreducible sigma hsigma e d heOdd hdOdd hde + letI : Fact (Irreducible (splitTraceXiKummerPolynomial sigma e d)) := ⟨hXiIrred⟩ + letI : IsDomain (SplitTraceXiFunctionField K sigma e d) := + AdjoinRoot.isDomain_of_prime hXiIrred.prime + exact RatFunc.liftAlgHom (K := K) (S := K) + (L := SplitTraceXiFunctionField K sigma e d) + (splitTraceEtaPolynomialEvaluation sigma e d) + (nonZeroDivisors_le_comap_nonZeroDivisors_of_injective _ + (by + exact splitTraceEtaPolynomialEvaluation_injective + sigma hsigma e d heOdd hdOdd hde)) + +private theorem splitTraceEtaRatFuncEvaluation_algebraMap + (sigma : K) (hsigma : sigma ≠ 0) (e d : ℕ) + (heOdd : Odd e) (hdOdd : Odd d) (hde : d.Coprime e) + (q : K[X]) : + splitTraceEtaRatFuncEvaluation sigma hsigma e d heOdd hdOdd hde + (algebraMap K[X] (RatFunc K) q) = + splitTraceEtaPolynomialEvaluation sigma e d q := by + let hBaseIrred := splitTraceBaseKummerPolynomial_irreducible sigma hsigma + let : Fact (Irreducible (splitTraceBaseKummerPolynomial sigma)) := ⟨hBaseIrred⟩ + let hEtaIrred := splitTraceEtaKummerPolynomial_irreducible' sigma hsigma e heOdd + let : Fact (Irreducible (splitTraceEtaKummerPolynomial sigma e)) := ⟨hEtaIrred⟩ + let hXiIrred := + splitTraceXiKummerPolynomial_irreducible sigma hsigma e d heOdd hdOdd hde + let : Fact (Irreducible (splitTraceXiKummerPolynomial sigma e d)) := ⟨hXiIrred⟩ + exact RatFunc.liftRingHom_algebraMap _ _ q + +/-- Mapping an iterated polynomial to `K(y)[x]` and then specializing the transcendental +coefficient parameter `y` to the Kummer `eta` coordinate recovers direct bivariate evaluation. -/ +theorem splitTraceIteratedFractionEvaluation + (sigma : K) (hsigma : sigma ≠ 0) (e d : ℕ) + (heOdd : Odd e) (hdOdd : Odd d) (hde : d.Coprime e) + (p : MvPolynomial (Fin 2) K) : + Polynomial.eval₂ + (splitTraceEtaRatFuncEvaluation sigma hsigma e d heOdd hdOdd hde).toRingHom + (splitTraceXiRoot sigma e d) + ((finTwoToIteratedPolynomial (K := K) p).map + (algebraMap K[X] (RatFunc K))) = + MvPolynomial.aeval + ![splitTraceXiRoot sigma e d, splitTraceEtaRootInXiField sigma e d] p := by + let hBaseIrred := splitTraceBaseKummerPolynomial_irreducible sigma hsigma + let : Fact (Irreducible (splitTraceBaseKummerPolynomial sigma)) := ⟨hBaseIrred⟩ + let hEtaIrred := splitTraceEtaKummerPolynomial_irreducible' sigma hsigma e heOdd + let : Fact (Irreducible (splitTraceEtaKummerPolynomial sigma e)) := ⟨hEtaIrred⟩ + let hXiIrred := + splitTraceXiKummerPolynomial_irreducible sigma hsigma e d heOdd hdOdd hde + let : Fact (Irreducible (splitTraceXiKummerPolynomial sigma e d)) := ⟨hXiIrred⟩ + rw [Polynomial.eval₂_map] + have hcomp : + (splitTraceEtaRatFuncEvaluation sigma hsigma e d heOdd hdOdd hde).toRingHom.comp + (algebraMap K[X] (RatFunc K)) = + (splitTraceEtaPolynomialEvaluation sigma e d).toRingHom := by + apply DFunLike.ext _ _ + intro q + exact splitTraceEtaRatFuncEvaluation_algebraMap + sigma hsigma e d heOdd hdOdd hde q + rw [hcomp] + exact finTwoToIteratedPolynomial_aeval p + (splitTraceXiRoot sigma e d) (splitTraceEtaRootInXiField sigma e d) + +/-- Once the actual cleared cover polynomial is irreducible, its principal ideal is the full +kernel of evaluation at the Kummer coordinates. The proof uses `eta` as a transcendental +coefficient parameter and the irreducible iterated polynomial as the minimal polynomial of +`xi`. -/ +theorem splitTracePolynomial_mem_span_of_cover_irreducible_and_maps_to_zero + (sigma : K) (hsigma : sigma ≠ 0) (e d : ℕ) + (heOdd : Odd e) (hdOdd : Odd d) (hde : d.Coprime e) + (hcover : Irreducible (splitTraceCoverPolynomial (1 : K) sigma d e)) + (p : MvPolynomial (Fin 2) K) + (hp : splitTracePolynomialToKummerTop + sigma hsigma e d heOdd hdOdd hde p = 0) : + p ∈ Ideal.span {splitTraceCoverPolynomial (1 : K) sigma d e} := by + let hBaseIrred := splitTraceBaseKummerPolynomial_irreducible sigma hsigma + let : Fact (Irreducible (splitTraceBaseKummerPolynomial sigma)) := ⟨hBaseIrred⟩ + let hEtaIrred := splitTraceEtaKummerPolynomial_irreducible' sigma hsigma e heOdd + let : Fact (Irreducible (splitTraceEtaKummerPolynomial sigma e)) := ⟨hEtaIrred⟩ + let hXiIrred := + splitTraceXiKummerPolynomial_irreducible sigma hsigma e d heOdd hdOdd hde + let : Fact (Irreducible (splitTraceXiKummerPolynomial sigma e d)) := ⟨hXiIrred⟩ + let : IsDomain (SplitTraceXiFunctionField K sigma e d) := + AdjoinRoot.isDomain_of_prime hXiIrred.prime + have hd : d ≠ 0 := by + rintro rfl + simp at hdOdd + let q : Polynomial K[X] := splitTraceCoverIteratedPolynomial sigma d e + let r : Polynomial K[X] := finTwoToIteratedPolynomial (K := K) p + have hqIrred : Irreducible q := by + have hmapped := hcover.map (finTwoToIteratedPolynomial (K := K)) + simpa [q, finTwoToIteratedPolynomial_splitTraceCoverPolynomial] using hmapped + have hqPrimitive : q.IsPrimitive := + hqIrred.isPrimitive + (splitTraceCoverIteratedPolynomial_natDegree_ne_zero sigma d e hd) + have hqFractionIrred : Irreducible + (q.map (algebraMap K[X] (RatFunc K))) := + hqPrimitive.irreducible_iff_irreducible_map_fraction_map.mp hqIrred + have hcoverEval : MvPolynomial.aeval + ![splitTraceXiRoot sigma e d, splitTraceEtaRootInXiField sigma e d] + (splitTraceCoverPolynomial (1 : K) sigma d e) = 0 := by + simpa [splitTracePolynomialToKummerTop, MvPolynomial.aeval_def] using + splitTracePolynomialToKummerTop_relation + sigma hsigma e d heOdd hdOdd hde + have hpEval : MvPolynomial.aeval + ![splitTraceXiRoot sigma e d, splitTraceEtaRootInXiField sigma e d] p = 0 := by + simpa [splitTracePolynomialToKummerTop, MvPolynomial.aeval_def] using hp + let phi : RatFunc K →ₐ[K] SplitTraceXiFunctionField K sigma e d := + splitTraceEtaRatFuncEvaluation sigma hsigma e d heOdd hdOdd hde + let : Algebra (RatFunc K) (SplitTraceXiFunctionField K sigma e d) := + phi.toRingHom.toAlgebra + have hqRoot : Polynomial.aeval (splitTraceXiRoot sigma e d) + (q.map (algebraMap K[X] (RatFunc K))) = 0 := by + rw [Polynomial.aeval_def] + change Polynomial.eval₂ phi.toRingHom (splitTraceXiRoot sigma e d) + (q.map (algebraMap K[X] (RatFunc K))) = 0 + simpa [phi, q, finTwoToIteratedPolynomial_splitTraceCoverPolynomial] using + (splitTraceIteratedFractionEvaluation + sigma hsigma e d heOdd hdOdd hde + (splitTraceCoverPolynomial (1 : K) sigma d e)).trans hcoverEval + have hpRoot : Polynomial.aeval (splitTraceXiRoot sigma e d) + (r.map (algebraMap K[X] (RatFunc K))) = 0 := by + rw [Polynomial.aeval_def] + change Polynomial.eval₂ phi.toRingHom (splitTraceXiRoot sigma e d) + (r.map (algebraMap K[X] (RatFunc K))) = 0 + simpa [phi, r] using + (splitTraceIteratedFractionEvaluation + sigma hsigma e d heOdd hdOdd hde p).trans hpEval + have hminpoly : + q.map (algebraMap K[X] (RatFunc K)) * + C (q.map (algebraMap K[X] (RatFunc K))).leadingCoeff⁻¹ = + minpoly (RatFunc K) (splitTraceXiRoot sigma e d) := + minpoly.eq_of_irreducible hqFractionIrred hqRoot + have hqDvdMinpoly : + q.map (algebraMap K[X] (RatFunc K)) ∣ + minpoly (RatFunc K) (splitTraceXiRoot sigma e d) := + ⟨C (q.map (algebraMap K[X] (RatFunc K))).leadingCoeff⁻¹, + hminpoly.symm⟩ + have hminpolyDvd : + minpoly (RatFunc K) (splitTraceXiRoot sigma e d) ∣ + r.map (algebraMap K[X] (RatFunc K)) := + minpoly.dvd (RatFunc K) (splitTraceXiRoot sigma e d) hpRoot + have hqDvdFraction : + q.map (algebraMap K[X] (RatFunc K)) ∣ + r.map (algebraMap K[X] (RatFunc K)) := + hqDvdMinpoly.trans hminpolyDvd + have hqDvd : q ∣ r := + hqPrimitive.dvd_of_fraction_map_dvd_fraction_map hqDvdFraction + rw [Ideal.mem_span_singleton] + rcases hqDvd with ⟨s, hs⟩ + refine ⟨(finTwoToIteratedPolynomial (K := K)).symm s, ?_⟩ + apply (finTwoToIteratedPolynomial (K := K)).injective + simpa [q, r, finTwoToIteratedPolynomial_splitTraceCoverPolynomial] using hs + +/-- The paper's irreducibility assertion is sufficient for injectivity of the explicit +Laurent-to-Kummer comparison map. There is no additional hidden localization hypothesis: the +coordinate-product localization was already proved faithful. -/ +theorem splitTraceLaurentToKummerTop_injective_of_coverPolynomial_irreducible + (sigma : K) (hsigma : sigma ≠ 0) (hnondegenerate : sigma ≠ 1) + (e d : ℕ) (heOdd : Odd e) (hdOdd : Odd d) (hde : d.Coprime e) + (hcover : Irreducible (splitTraceCoverPolynomial (1 : K) sigma d e)) : + Function.Injective + (splitTraceLaurentToKummerTop sigma hsigma e d heOdd hdOdd hde) := by + apply (splitTracePolynomialSyntacticNormalForm_division_iff_laurentInjective + sigma hsigma e d heOdd hdOdd hde hnondegenerate).1 + intro p hnormal + apply splitTracePolynomial_mem_span_of_cover_irreducible_and_maps_to_zero + sigma hsigma e d heOdd hdOdd hde hcover p + exact (splitTracePolynomialSyntacticNormalForm_eq_zero_iff + sigma hsigma e d heOdd hdOdd hde p).1 hnormal + +/-- Exact endgame wall: in the nondegenerate odd-coprime case, injectivity of the constructed +Laurent comparison is equivalent to irreducibility of the paper's cleared trace-cover polynomial. +Thus proving the published irreducibility lemma closes the comparison; no extra quotient-division +axiom is required. -/ +theorem splitTraceLaurentToKummerTop_injective_iff_coverPolynomial_irreducible + (sigma : K) (hsigma : sigma ≠ 0) (hnondegenerate : sigma ≠ 1) + (e d : ℕ) (heOdd : Odd e) (hdOdd : Odd d) (hde : d.Coprime e) : + Function.Injective + (splitTraceLaurentToKummerTop sigma hsigma e d heOdd hdOdd hde) ↔ + Irreducible (splitTraceCoverPolynomial (1 : K) sigma d e) := by + constructor + · exact splitTraceCoverPolynomial_irreducible_of_laurentInjective + sigma hsigma e d heOdd hdOdd hde + · exact splitTraceLaurentToKummerTop_injective_of_coverPolynomial_irreducible + sigma hsigma hnondegenerate e d heOdd hdOdd hde + +end IteratedPresentation + +end + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/LaurentJacobian.lean b/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/LaurentJacobian.lean new file mode 100644 index 0000000000..66a0433df7 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/LaurentJacobian.lean @@ -0,0 +1,208 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.ChartLocalization + +/-! +# Jacobian control on the Laurent trace cover + +This file proves the algebraic nonsingularity calculation needed to identify the normalization +with the original trace curve away from the coordinate boundary. The two formal partial +derivatives generate the unit ideal in the Laurent coordinate ring when `2`, `d`, and `e` are +nonzero and the paper's parameter condition `alpha * beta ≠ 1` holds. + +The proof exposes the characteristic assumptions and gives an explicit ideal calculation. It does +not assume smoothness or normality as a structure field. +-/ + +@[expose] public section + +namespace BGS.Markoff + +noncomputable section + +variable {K : Type*} [Field K] + +/-- The nonunit-free factor of the partial derivative with respect to `x`. -/ +def weightedSplitTraceLaurentJacobianXFactor (alpha beta : K) (d e : ℕ) : + WeightedSplitTraceLaurentCoordinateRing alpha beta d e := + algebraMap K _ alpha * weightedSplitTraceLaurentY alpha beta d e ^ (2 * e) + + algebraMap K _ beta - + 2 * weightedSplitTraceLaurentX alpha beta d e ^ d * + weightedSplitTraceLaurentY alpha beta d e ^ e + +/-- The nonunit-free factor of the partial derivative with respect to `y`. -/ +def weightedSplitTraceLaurentJacobianYFactor (alpha beta : K) (d e : ℕ) : + WeightedSplitTraceLaurentCoordinateRing alpha beta d e := + 2 * algebraMap K _ alpha * weightedSplitTraceLaurentX alpha beta d e ^ d * + weightedSplitTraceLaurentY alpha beta d e ^ e - + weightedSplitTraceLaurentX alpha beta d e ^ (2 * d) - 1 + +/-- Exact evaluation formula for the first formal partial derivative. -/ +theorem splitTraceCoverPolynomial_pderiv_zero_eval + (alpha beta : K) (d e : ℕ) (hd : 0 < d) (x y : K) : + MvPolynomial.eval ![x, y] + (MvPolynomial.pderiv 0 (splitTraceCoverPolynomial alpha beta d e)) = + (d : K) * x ^ (d - 1) * + (alpha * y ^ (2 * e) + beta - 2 * x ^ d * y ^ e) := by + have htwoD : 2 * d - 1 = (d - 1) + d := by omega + simp [splitTraceCoverPolynomial, htwoD, pow_add] + ring + +/-- Exact evaluation formula for the second formal partial derivative. -/ +theorem splitTraceCoverPolynomial_pderiv_one_eval + (alpha beta : K) (d e : ℕ) (he : 0 < e) (x y : K) : + MvPolynomial.eval ![x, y] + (MvPolynomial.pderiv 1 (splitTraceCoverPolynomial alpha beta d e)) = + (e : K) * y ^ (e - 1) * + (2 * alpha * x ^ d * y ^ e - x ^ (2 * d) - 1) := by + have htwoE : 2 * e - 1 = (e - 1) + e := by omega + simp [splitTraceCoverPolynomial, htwoE, pow_add] + ring + +/-- The first formal partial derivative evaluated in the Laurent coordinate ring. -/ +def weightedSplitTraceLaurentPartialX (alpha beta : K) (d e : ℕ) : + WeightedSplitTraceLaurentCoordinateRing alpha beta d e := + MvPolynomial.aeval + ![weightedSplitTraceLaurentX alpha beta d e, + weightedSplitTraceLaurentY alpha beta d e] + (MvPolynomial.pderiv 0 (splitTraceCoverPolynomial alpha beta d e)) + +/-- The second formal partial derivative evaluated in the Laurent coordinate ring. -/ +def weightedSplitTraceLaurentPartialY (alpha beta : K) (d e : ℕ) : + WeightedSplitTraceLaurentCoordinateRing alpha beta d e := + MvPolynomial.aeval + ![weightedSplitTraceLaurentX alpha beta d e, + weightedSplitTraceLaurentY alpha beta d e] + (MvPolynomial.pderiv 1 (splitTraceCoverPolynomial alpha beta d e)) + +theorem weightedSplitTraceLaurentPartialX_eq (alpha beta : K) (d e : ℕ) (hd : 0 < d) : + weightedSplitTraceLaurentPartialX alpha beta d e = + algebraMap K _ (d : K) * weightedSplitTraceLaurentX alpha beta d e ^ (d - 1) * + weightedSplitTraceLaurentJacobianXFactor alpha beta d e := by + have htwoD : 2 * d - 1 = (d - 1) + d := by omega + simp [weightedSplitTraceLaurentPartialX, weightedSplitTraceLaurentJacobianXFactor, MvPolynomial.aeval_def, + splitTraceCoverPolynomial, htwoD, pow_add] + ring + +theorem weightedSplitTraceLaurentPartialY_eq (alpha beta : K) (d e : ℕ) (he : 0 < e) : + weightedSplitTraceLaurentPartialY alpha beta d e = + algebraMap K _ (e : K) * weightedSplitTraceLaurentY alpha beta d e ^ (e - 1) * + weightedSplitTraceLaurentJacobianYFactor alpha beta d e := by + have htwoE : 2 * e - 1 = (e - 1) + e := by omega + simp [weightedSplitTraceLaurentPartialY, weightedSplitTraceLaurentJacobianYFactor, MvPolynomial.aeval_def, + splitTraceCoverPolynomial, htwoE, pow_add] + ring + +theorem weightedSplitTraceLaurentJacobianFactors_span_top + (alpha beta : K) (hnondegenerate : alpha * beta ≠ 1) + (htwo : (2 : K) ≠ 0) (d e : ℕ) : + Ideal.span {weightedSplitTraceLaurentJacobianXFactor alpha beta d e, + weightedSplitTraceLaurentJacobianYFactor alpha beta d e} = ⊤ := by + let L := WeightedSplitTraceLaurentCoordinateRing alpha beta d e + let x : L := weightedSplitTraceLaurentX alpha beta d e + let y : L := weightedSplitTraceLaurentY alpha beta d e + let X : L := x ^ d + let Y : L := y ^ e + let a : L := algebraMap K L alpha + let b : L := algebraMap K L beta + let A : L := weightedSplitTraceLaurentJacobianXFactor alpha beta d e + let B : L := weightedSplitTraceLaurentJacobianYFactor alpha beta d e + let I : Ideal L := Ideal.span {A, B} + change I = ⊤ + have hAeq : A = a * Y ^ 2 + b - 2 * X * Y := by + simp [A, a, b, X, Y, x, y, L, weightedSplitTraceLaurentJacobianXFactor, Nat.mul_comm, pow_mul] + have hBeq : B = 2 * a * X * Y - X ^ 2 - 1 := by + simp [B, a, X, Y, x, y, L, weightedSplitTraceLaurentJacobianYFactor, Nat.mul_comm, pow_mul] + have hA : A ∈ I := Ideal.subset_span (by simp) + have hB : B ∈ I := Ideal.subset_span (by simp) + have hF : a * X * Y ^ 2 + b * X - X ^ 2 * Y - Y = 0 := by + have h := weightedSplitTraceLaurentDefiningRelation alpha beta d e + change a * x ^ d * y ^ (2 * e) + b * x ^ d - + x ^ (2 * d) * y ^ e - y ^ e = 0 at h + rw [show y ^ (2 * e) = Y ^ 2 by simp [Y, Nat.mul_comm, pow_mul], + show x ^ (2 * d) = X ^ 2 by simp [X, Nat.mul_comm, pow_mul]] at h + exact h + have hYUnit : IsUnit Y := by + exact (weightedSplitTraceLaurentY_isUnit alpha beta d e).pow e + have hTwoUnit : IsUnit (2 : L) := by + simpa only [map_ofNat] using + (isUnit_iff_ne_zero.mpr htwo).map (algebraMap K L) + have hXSquare : X ^ 2 - 1 ∈ I := by + apply (I.unit_mul_mem_iff_mem hYUnit).mp + have hXA : X * A ∈ I := I.mul_mem_left X hA + have : Y * (X ^ 2 - 1) = -(X * A) := by + rw [hAeq] + linear_combination hF + rw [this] + exact I.neg_mem hXA + have hAlphaXY : a * X * Y - 1 ∈ I := by + apply (I.unit_mul_mem_iff_mem hTwoUnit).mp + have hsum : B + (X ^ 2 - 1) ∈ I := I.add_mem hB hXSquare + rw [hBeq] at hsum + convert hsum using 1 + all_goals ring + have hAlphaSquareY : a ^ 2 * Y ^ 2 - 1 ∈ I := by + have hproduct : (a * X * Y - 1) * (a * X * Y + 1) ∈ I := + I.mul_mem_right (a * X * Y + 1) hAlphaXY + have hcorrection : a ^ 2 * Y ^ 2 * (X ^ 2 - 1) ∈ I := + I.mul_mem_left (a ^ 2 * Y ^ 2) hXSquare + have hsub := I.sub_mem hproduct hcorrection + convert hsub using 1 + all_goals ring + have hProductMinusOne : a * b - 1 ∈ I := by + have haA : a * A ∈ I := I.mul_mem_left a hA + rw [hAeq] at haA + have htwice : 2 * (a * X * Y - 1) ∈ I := I.mul_mem_left 2 hAlphaXY + have hcombination := I.add_mem (I.sub_mem haA hAlphaSquareY) htwice + convert hcombination using 1 + all_goals ring + have hProductUnit : IsUnit (a * b - 1) := by + have h : IsUnit (alpha * beta - 1) := + isUnit_iff_ne_zero.mpr (sub_ne_zero.mpr hnondegenerate) + simpa [a, b, L] using h.map (algebraMap K L) + exact I.eq_top_of_isUnit_mem hProductMinusOne hProductUnit + +theorem weightedSplitTraceLaurentPartials_span_top + (alpha beta : K) (hnondegenerate : alpha * beta ≠ 1) + (htwo : (2 : K) ≠ 0) (d e : ℕ) (hd : 0 < d) (he : 0 < e) + (hdChar : (d : K) ≠ 0) (heChar : (e : K) ≠ 0) : + Ideal.span {weightedSplitTraceLaurentPartialX alpha beta d e, + weightedSplitTraceLaurentPartialY alpha beta d e} = ⊤ := by + let L := WeightedSplitTraceLaurentCoordinateRing alpha beta d e + let J : Ideal L := Ideal.span {weightedSplitTraceLaurentPartialX alpha beta d e, + weightedSplitTraceLaurentPartialY alpha beta d e} + have hFactorTop := weightedSplitTraceLaurentJacobianFactors_span_top alpha beta hnondegenerate htwo d e + apply le_antisymm le_top + rw [← hFactorTop] + apply Ideal.span_le.mpr + intro z hz + simp only [Set.mem_insert_iff, Set.mem_singleton_iff] at hz + rcases hz with rfl | rfl + · have hPartial : weightedSplitTraceLaurentPartialX alpha beta d e ∈ J := + Ideal.subset_span (by simp) + rw [weightedSplitTraceLaurentPartialX_eq alpha beta d e hd] at hPartial + have hDegreeUnit : IsUnit (algebraMap K L (d : K)) := + (isUnit_iff_ne_zero.mpr hdChar).map (algebraMap K L) + have hXPowerUnit : + IsUnit (weightedSplitTraceLaurentX alpha beta d e ^ (d - 1)) := + (weightedSplitTraceLaurentX_isUnit alpha beta d e).pow (d - 1) + exact (J.unit_mul_mem_iff_mem (hDegreeUnit.mul hXPowerUnit)).mp hPartial + · have hPartial : weightedSplitTraceLaurentPartialY alpha beta d e ∈ J := + Ideal.subset_span (by simp) + rw [weightedSplitTraceLaurentPartialY_eq alpha beta d e he] at hPartial + have hDegreeUnit : IsUnit (algebraMap K L (e : K)) := + (isUnit_iff_ne_zero.mpr heChar).map (algebraMap K L) + have hYPowerUnit : + IsUnit (weightedSplitTraceLaurentY alpha beta d e ^ (e - 1)) := + (weightedSplitTraceLaurentY_isUnit alpha beta d e).pow (e - 1) + exact (J.unit_mul_mem_iff_mem (hDegreeUnit.mul hYPowerUnit)).mp hPartial + +end + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/LaurentNormalization.lean b/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/LaurentNormalization.lean new file mode 100644 index 0000000000..ae30c17c3b --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/LaurentNormalization.lean @@ -0,0 +1,493 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.AlgebraicGeometry.SpecRingEquiv +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.ChartLocalization +public import Mathlib.RingTheory.Localization.Integral + +/-! +# Normalized Laurent overlap transitions + +This module lifts the explicit Laurent chart transitions to integral closures in the corresponding +fraction fields. The lift is constructed directly: integrality is transported simultaneously +along the coordinate-ring equivalence and its induced fraction-field equivalence. In particular, +no unproved `smooth implies normal` bridge is used. + +The final cocycle is proved first in the fraction fields and then in the integral closures. Its +domain hypotheses are precisely the domain instances obtained from the already-proved +irreducibility of the two affine chart equations. +-/ + +@[expose] public section + +namespace BGS.Markoff + +open AlgebraicGeometry + +noncomputable section + +section IntegralClosureTransport + +variable {K A B C : Type*} [Field K] +variable [CommRing A] [CommRing B] [CommRing C] +variable [Algebra K A] [Algebra K B] [Algebra K C] +variable [IsDomain A] [IsDomain B] [IsDomain C] + +omit [IsDomain A] [IsDomain B] in +/-- The induced fraction-field equivalence preserves elements integral over the base ring. -/ +theorem fractionRingEquiv_maps_integral + (e : A ≃ₐ[K] B) (x : integralClosure A (FractionRing A)) : + IsIntegral B + ((IsFractionRing.algEquivOfAlgEquiv + (K := FractionRing A) (L := FractionRing B) e) (x : FractionRing A)) := by + apply IsIntegral.map_of_comp_eq (R := A) (S := FractionRing A) + (T := B) (U := FractionRing B) e.toRingEquiv.toRingHom + (IsFractionRing.algEquivOfAlgEquiv + (K := FractionRing A) (L := FractionRing B) e).toRingEquiv.toRingHom + · ext a + exact (IsFractionRing.algEquivOfAlgEquiv_algebraMap + (K := FractionRing A) (L := FractionRing B) e a).symm + · exact x.property + +/-- An equivalence of domain algebras transports their integral closures in their fraction fields. -/ +def integralClosureFractionRingEquiv (e : A ≃ₐ[K] B) : + integralClosure A (FractionRing A) ≃+* + integralClosure B (FractionRing B) where + toFun x := ⟨(IsFractionRing.algEquivOfAlgEquiv + (K := FractionRing A) (L := FractionRing B) e) (x : FractionRing A), + fractionRingEquiv_maps_integral e x⟩ + invFun y := ⟨(IsFractionRing.algEquivOfAlgEquiv + (K := FractionRing B) (L := FractionRing A) e.symm) (y : FractionRing B), + fractionRingEquiv_maps_integral e.symm y⟩ + left_inv x := by + ext + exact (IsFractionRing.algEquivOfAlgEquiv + (K := FractionRing A) (L := FractionRing B) e).symm_apply_apply x + right_inv y := by + ext + exact (IsFractionRing.algEquivOfAlgEquiv + (K := FractionRing A) (L := FractionRing B) e).apply_symm_apply y + map_add' x y := by + ext + exact map_add _ _ _ + map_mul' x y := by + ext + exact map_mul _ _ _ + +omit [IsDomain A] [IsDomain B] in +@[simp] +theorem integralClosureFractionRingEquiv_coe (e : A ≃ₐ[K] B) + (x : integralClosure A (FractionRing A)) : + ((integralClosureFractionRingEquiv e x : + integralClosure B (FractionRing B)) : FractionRing B) = + (IsFractionRing.algEquivOfAlgEquiv + (K := FractionRing A) (L := FractionRing B) e) (x : FractionRing A) := rfl + +omit [IsDomain A] [IsDomain B] in +/-- The lifted integral-closure equivalence extends the original coordinate-ring equivalence. -/ +theorem integralClosureFractionRingEquiv_comp_algebraMap (e : A ≃ₐ[K] B) : + (integralClosureFractionRingEquiv e).toRingHom.comp + (algebraMap A (integralClosure A (FractionRing A))) = + (algebraMap B (integralClosure B (FractionRing B))).comp e.toRingHom := by + apply DFunLike.ext _ _ + intro a + apply Subtype.ext + exact IsFractionRing.algEquivOfAlgEquiv_algebraMap + (K := FractionRing A) (L := FractionRing B) e a + +omit [IsDomain A] [IsDomain B] in +@[simp] +theorem integralClosureFractionRingEquiv_symm (e : A ≃ₐ[K] B) : + (integralClosureFractionRingEquiv e).symm = + integralClosureFractionRingEquiv e.symm := rfl + +omit [IsDomain B] in +/-- Passing to fraction fields respects composition of algebra equivalences. -/ +theorem fractionRingEquiv_trans (e : A ≃ₐ[K] B) (f : B ≃ₐ[K] C) : + (IsFractionRing.algEquivOfAlgEquiv + (K := FractionRing A) (L := FractionRing B) e).trans + (IsFractionRing.algEquivOfAlgEquiv + (K := FractionRing B) (L := FractionRing C) f) = + IsFractionRing.algEquivOfAlgEquiv + (K := FractionRing A) (L := FractionRing C) (e.trans f) := by + apply AlgEquiv.ext + intro x + have h : + ((IsFractionRing.algEquivOfAlgEquiv + (K := FractionRing A) (L := FractionRing B) e).trans + (IsFractionRing.algEquivOfAlgEquiv + (K := FractionRing B) (L := FractionRing C) f)).toRingEquiv.toRingHom = + (IsFractionRing.algEquivOfAlgEquiv + (K := FractionRing A) (L := FractionRing C) (e.trans f)).toRingEquiv.toRingHom := by + apply IsFractionRing.ringHom_ext (A := A) + intro a + simp + exact RingHom.congr_fun h x + +omit [IsDomain B] in +/-- Transport of integral closures respects composition. -/ +theorem integralClosureFractionRingEquiv_trans + (e : A ≃ₐ[K] B) (f : B ≃ₐ[K] C) : + (integralClosureFractionRingEquiv e).trans + (integralClosureFractionRingEquiv f) = + integralClosureFractionRingEquiv (e.trans f) := by + ext x + change + ((IsFractionRing.algEquivOfAlgEquiv + (K := FractionRing A) (L := FractionRing B) e).trans + (IsFractionRing.algEquivOfAlgEquiv + (K := FractionRing B) (L := FractionRing C) f)) x = _ + rw [fractionRingEquiv_trans] + rfl + +end IntegralClosureTransport + +section IntegralClosureLocalization + +variable {R : Type*} [CommRing R] [IsDomain R] + +/-- The canonical map from a principal open of an integral domain to the corresponding principal +open of its normalization. -/ +def integralClosureAwayMap (f : R) : + Localization.Away f →+* + Localization.Away (algebraMap R (integralClosure R (FractionRing R)) f) := by + letI : IsLocalization.Away + ((Algebra.ofId R (integralClosure R (FractionRing R))) f) + (Localization.Away (algebraMap R (integralClosure R (FractionRing R)) f)) := by + simpa using (inferInstance : IsLocalization.Away + (algebraMap R (integralClosure R (FractionRing R)) f) + (Localization.Away (algebraMap R (integralClosure R (FractionRing R)) f))) + exact (IsLocalization.Away.mapₐ + (Localization.Away f) + (Localization.Away (algebraMap R (integralClosure R (FractionRing R)) f)) + (Algebra.ofId R (integralClosure R (FractionRing R))) f).toRingHom + +/-- The localization comparison for normalization, bundled with the square that identifies its +restriction on the original principal open. Keeping the square in the data prevents the +normalization chart transition from being used without its compatibility with the raw chart. -/ +structure IntegralClosureAwayComparison (f : R) where + equiv : + Localization.Away (algebraMap R (integralClosure R (FractionRing R)) f) ≃+* + integralClosure (Localization.Away f) (FractionRing (Localization.Away f)) + equiv_comp_map : equiv.toRingHom.comp (integralClosureAwayMap f) = + algebraMap (Localization.Away f) + (integralClosure (Localization.Away f) (FractionRing (Localization.Away f))) + +/-- Normalizing an integral domain and then restricting to a nonempty principal open agrees with +normalizing that principal open in its own fraction field, compatibly with the raw principal open. + +The construction makes all comparison maps explicit. The fraction field of `R` is first given +its compatible `Localization.Away f`-algebra structure. Mathlib's +`IsLocalization.Away.integralClosure` then identifies the intermediate integral closure as a +localization of `integralClosure R (FractionRing R)`, and `FractionRing.algEquiv` compares the +intermediate ambient field with the canonical fraction field of `Localization.Away f`. -/ +def integralClosureAwayComparison (f : R) (hf : f ≠ 0) : + IntegralClosureAwayComparison f := by + let Rf := Localization.Away f + let F := FractionRing R + let N := integralClosure R F + have hfF : algebraMap R F f ≠ 0 := + (map_ne_zero_iff (algebraMap R F) (FaithfulSMul.algebraMap_injective R F)).mpr hf + have hfUnit : IsUnit (algebraMap R F f) := isUnit_iff_ne_zero.mpr hfF + let phi : Rf →ₐ[R] F := + IsLocalization.Away.liftAlgHom f (f := Algebra.ofId R F) hfUnit + letI : Algebra Rf F := phi.toRingHom.toAlgebra + letI : IsScalarTower R Rf F := IsScalarTower.of_algebraMap_eq' (by + ext r + exact (phi.commutes r).symm) + letI : IsFractionRing Rf F := + IsFractionRing.isFractionRing_of_isDomain_of_isLocalization + (Submonoid.powers f) Rf F + let T := integralClosure Rf F + let Nf := integralClosure Rf (FractionRing Rf) + let fracEquiv : FractionRing Rf ≃ₐ[Rf] F := FractionRing.algEquiv Rf F + let psi : N →+* T := + { toFun := fun x ↦ ⟨(x : F), x.property.tower_top⟩ + map_one' := rfl + map_mul' := fun _ _ ↦ rfl + map_zero' := rfl + map_add' := fun _ _ ↦ rfl } + letI : Algebra N T := psi.toAlgebra + letI : IsScalarTower N T F := IsScalarTower.of_algebraMap_eq' rfl + letI : IsScalarTower R N T := IsScalarTower.of_algebraMap_eq' (by + ext r + rfl) + letI : IsLocalization.Away (algebraMap R F f) F := + IsLocalization.away_of_isUnit_of_bijective F hfUnit Function.bijective_id + letI : IsLocalization.Away (algebraMap R N f) T := + IsLocalization.Away.integralClosure (S := F) (Rf := Rf) (Sf := F) f + let localizationEquiv : Localization.Away (algebraMap R N f) ≃ₐ[N] T := + IsLocalization.algEquiv (Submonoid.powers (algebraMap R N f)) + (Localization.Away (algebraMap R N f)) T + let ambientFieldEquiv : T ≃+* Nf := + (fracEquiv.mapIntegralClosure).symm.toRingEquiv + let e := localizationEquiv.toRingEquiv.trans ambientFieldEquiv + refine ⟨e, ?_⟩ + apply IsLocalization.ringHom_ext (M := Submonoid.powers f) + ext r + simp [e, localizationEquiv, ambientFieldEquiv, integralClosureAwayMap] + apply_fun fracEquiv + have hmap (x : T) : + fracEquiv ↑(fracEquiv.mapIntegralClosure.symm x) = (x : F) := by + exact congrArg Subtype.val (fracEquiv.mapIntegralClosure.apply_symm_apply x) + rw [hmap] + rw [show + (algebraMap R (Localization.Away (algebraMap R N f))) r = + (algebraMap N (Localization.Away (algebraMap R N f))) ((algebraMap R N) r) by + simpa using + (IsScalarTower.algebraMap_apply R N + (Localization.Away (algebraMap R N f)) r)] + rw [localizationEquiv.commutes] + rw [fracEquiv.commutes] + change + algebraMap T F (algebraMap N T (algebraMap R N r)) = + algebraMap Rf F (algebraMap R Rf r) + rw [← IsScalarTower.algebraMap_apply N T F] + rw [← IsScalarTower.algebraMap_apply R N F] + rw [← IsScalarTower.algebraMap_apply R Rf F] + +/-- The ring equivalence underlying `integralClosureAwayComparison`. -/ +def integralClosureAwayEquiv (f : R) (hf : f ≠ 0) : + Localization.Away (algebraMap R (integralClosure R (FractionRing R)) f) ≃+* + integralClosure (Localization.Away f) (FractionRing (Localization.Away f)) := + (integralClosureAwayComparison f hf).equiv + +/-- The localization equivalence carries the canonical raw-to-normalized principal-open map to +the canonical normalization map of the raw principal open. -/ +theorem integralClosureAwayEquiv_comp_map (f : R) (hf : f ≠ 0) : + (integralClosureAwayEquiv f hf).toRingHom.comp (integralClosureAwayMap f) = + algebraMap (Localization.Away f) + (integralClosure (Localization.Away f) (FractionRing (Localization.Away f))) := + (integralClosureAwayComparison f hf).equiv_comp_map + +end IntegralClosureLocalization + +section TraceCoverCharts + +variable {K : Type*} [Field K] + +/-- Coordinate ring of the affine normalization, before passing to `Spec`. -/ +abbrev WeightedSplitTraceAffineNormalizationRing + (alpha beta : K) (d e : ℕ) := + integralClosure (WeightedSplitTraceAffineCoordinateRing alpha beta d e) + (FractionRing (WeightedSplitTraceAffineCoordinateRing alpha beta d e)) + +/-- Normalization ring of the common Laurent overlap of a trace-cover affine chart. -/ +abbrev WeightedSplitTraceLaurentNormalizationRing + (alpha beta : K) (d e : ℕ) := + integralClosure (WeightedSplitTraceLaurentCoordinateRing alpha beta d e) + (FractionRing (WeightedSplitTraceLaurentCoordinateRing alpha beta d e)) + +/-- Irreducibility and positivity ensure that localizing away from the coordinate product is a +genuine nonzero open. The proof exposes the two possible coordinate-axis divisors and rules them +out by evaluation at `(0, 1)` and `(1, 0)`. -/ +theorem weightedSplitTraceAffineCoordinateProduct_ne_zero_of_irreducible + (alpha beta : K) (d e : ℕ) (hd : 0 < d) (he : 0 < e) (hbeta : beta ≠ 0) + (h : Irreducible (splitTraceCoverPolynomial alpha beta d e)) : + weightedSplitTraceAffineCoordinateProduct alpha beta d e ≠ 0 := by + intro hzero + have hmul : MvPolynomial.X (0 : Fin 2) * MvPolynomial.X (1 : Fin 2) ∈ + Ideal.span {splitTraceCoverPolynomial alpha beta d e} := by + exact Ideal.Quotient.eq_zero_iff_mem.mp hzero + rw [Ideal.mem_span_singleton] at hmul + rcases h.prime.dvd_mul.mp hmul with hx | hy + · have ha := h.prime.associated_of_dvd (MvPolynomial.X_prime (i := (0 : Fin 2))) hx + have hamap := ha.map (MvPolynomial.eval ![0, 1]) + simp [eval_splitTraceCoverPolynomial, hd.ne'] at hamap + · have ha := h.prime.associated_of_dvd (MvPolynomial.X_prime (i := (1 : Fin 2))) hy + have hamap := ha.map (MvPolynomial.eval ![1, 0]) + simp [eval_splitTraceCoverPolynomial, he.ne', hbeta] at hamap + +/-- The Laurent coordinate ring is a domain once irreducibility proves that its affine source is +a domain and the preceding theorem proves that the inverted coordinate product is nonzero. -/ +theorem weightedSplitTraceLaurentCoordinateRing_isDomain + (alpha beta : K) (d e : ℕ) (hd : 0 < d) (he : 0 < e) (hbeta : beta ≠ 0) + (h : Irreducible (splitTraceCoverPolynomial alpha beta d e)) : + IsDomain (WeightedSplitTraceLaurentCoordinateRing alpha beta d e) := by + let : IsDomain (WeightedSplitTraceAffineCoordinateRing alpha beta d e) := + weightedSplitTraceAffineCoordinateRing_isDomain alpha beta d e h + exact IsLocalization.Away.isDomain + (S := WeightedSplitTraceLaurentCoordinateRing alpha beta d e) + (weightedSplitTraceAffineCoordinateProduct_ne_zero_of_irreducible + alpha beta d e hd he hbeta h) + +/-- The normalized Laurent overlap is the principal open of the affine normalization obtained by +inverting the original coordinate product. Both the affine-domain and nonempty-open hypotheses +are discharged from irreducibility and positivity. -/ +def weightedSplitTraceAffineNormalizationLaurentOpenEquiv_of_irreducible + (alpha beta : K) (d e : ℕ) (hd : 0 < d) (he : 0 < e) (hbeta : beta ≠ 0) + (h : Irreducible (splitTraceCoverPolynomial alpha beta d e)) : + Localization.Away + (algebraMap (WeightedSplitTraceAffineCoordinateRing alpha beta d e) + (WeightedSplitTraceAffineNormalizationRing alpha beta d e) + (weightedSplitTraceAffineCoordinateProduct alpha beta d e)) ≃+* + WeightedSplitTraceLaurentNormalizationRing alpha beta d e := by + letI : IsDomain (WeightedSplitTraceAffineCoordinateRing alpha beta d e) := + weightedSplitTraceAffineCoordinateRing_isDomain alpha beta d e h + exact integralClosureAwayEquiv + (weightedSplitTraceAffineCoordinateProduct alpha beta d e) + (weightedSplitTraceAffineCoordinateProduct_ne_zero_of_irreducible + alpha beta d e hd he hbeta h) + +/-- Scheme-level form of the normalized principal-open comparison. -/ +def weightedSplitTraceAffineNormalizationLaurentOpenSchemeIso_of_irreducible + (alpha beta : K) (d e : ℕ) (hd : 0 < d) (he : 0 < e) (hbeta : beta ≠ 0) + (h : Irreducible (splitTraceCoverPolynomial alpha beta d e)) : + Spec (CommRingCat.of (WeightedSplitTraceLaurentNormalizationRing alpha beta d e)) ≅ + Spec (CommRingCat.of (Localization.Away + (algebraMap (WeightedSplitTraceAffineCoordinateRing alpha beta d e) + (WeightedSplitTraceAffineNormalizationRing alpha beta d e) + (weightedSplitTraceAffineCoordinateProduct alpha beta d e)))) := + BGS.specIsoOfRingEquiv + (weightedSplitTraceAffineNormalizationLaurentOpenEquiv_of_irreducible + alpha beta d e hd he hbeta h) + +variable (alpha beta : K) (d e : ℕ) +variable [IsDomain (WeightedSplitTraceLaurentCoordinateRing alpha beta d e)] +variable [IsDomain (WeightedSplitTraceLaurentCoordinateRing beta alpha d e)] + +/-- The first-coordinate inversion lifted to the normalized Laurent overlap. -/ +def weightedSplitTraceLeftInversionLaurentNormalizationEquiv : + WeightedSplitTraceLaurentNormalizationRing alpha beta d e ≃+* + WeightedSplitTraceLaurentNormalizationRing alpha beta d e := + integralClosureFractionRingEquiv + (weightedSplitTraceLeftInversionLaurentEquiv alpha beta d e) + +/-- The second-coordinate inversion lifted to the normalized Laurent overlap. -/ +def weightedSplitTraceRightInversionLaurentNormalizationEquiv : + WeightedSplitTraceLaurentNormalizationRing beta alpha d e ≃+* + WeightedSplitTraceLaurentNormalizationRing alpha beta d e := + integralClosureFractionRingEquiv + (weightedSplitTraceRightInversionLaurentEquiv alpha beta d e) + +omit [IsDomain (WeightedSplitTraceLaurentCoordinateRing alpha beta d e)] + [IsDomain (WeightedSplitTraceLaurentCoordinateRing beta alpha d e)] in +/-- The coordinate-ring transition equivalences satisfy the same square cocycle as their maps. -/ +theorem weightedSplitTraceLaurentInversionEquivs_commute : + (weightedSplitTraceRightInversionLaurentEquiv alpha beta d e).trans + (weightedSplitTraceLeftInversionLaurentEquiv alpha beta d e) = + (weightedSplitTraceLeftInversionLaurentEquiv beta alpha d e).trans + (weightedSplitTraceRightInversionLaurentEquiv alpha beta d e) := by + apply AlgEquiv.ext + intro x + exact DFunLike.congr_fun + (weightedSplitTraceLaurentInversions_commute alpha beta d e) x + +/-- The lifted normalization transitions satisfy the required square cocycle. -/ +theorem weightedSplitTraceLaurentNormalizationInversions_commute : + (weightedSplitTraceRightInversionLaurentNormalizationEquiv alpha beta d e).trans + (weightedSplitTraceLeftInversionLaurentNormalizationEquiv alpha beta d e) = + (weightedSplitTraceLeftInversionLaurentNormalizationEquiv beta alpha d e).trans + (weightedSplitTraceRightInversionLaurentNormalizationEquiv alpha beta d e) := by + simp only [weightedSplitTraceRightInversionLaurentNormalizationEquiv, + weightedSplitTraceLeftInversionLaurentNormalizationEquiv] + rw [integralClosureFractionRingEquiv_trans, + integralClosureFractionRingEquiv_trans, + weightedSplitTraceLaurentInversionEquivs_commute] + +omit [IsDomain (WeightedSplitTraceLaurentCoordinateRing alpha beta d e)] + [IsDomain (WeightedSplitTraceLaurentCoordinateRing beta alpha d e)] in +/-- The normalization cocycle with its domain instances explicitly discharged by the two affine +irreducibility theorems. This is the upstream-to-downstream wiring used by the geometric charts. -/ +theorem weightedSplitTraceLaurentNormalizationInversions_commute_of_irreducible + (hd : 0 < d) (he : 0 < e) (halpha : alpha ≠ 0) (hbeta : beta ≠ 0) + (h : Irreducible (splitTraceCoverPolynomial alpha beta d e)) + (hswap : Irreducible (splitTraceCoverPolynomial beta alpha d e)) : + letI : IsDomain (WeightedSplitTraceLaurentCoordinateRing alpha beta d e) := + weightedSplitTraceLaurentCoordinateRing_isDomain alpha beta d e hd he hbeta h + letI : IsDomain (WeightedSplitTraceLaurentCoordinateRing beta alpha d e) := + weightedSplitTraceLaurentCoordinateRing_isDomain beta alpha d e hd he halpha hswap + (weightedSplitTraceRightInversionLaurentNormalizationEquiv alpha beta d e).trans + (weightedSplitTraceLeftInversionLaurentNormalizationEquiv alpha beta d e) = + (weightedSplitTraceLeftInversionLaurentNormalizationEquiv beta alpha d e).trans + (weightedSplitTraceRightInversionLaurentNormalizationEquiv alpha beta d e) := by + let : IsDomain (WeightedSplitTraceLaurentCoordinateRing alpha beta d e) := + weightedSplitTraceLaurentCoordinateRing_isDomain alpha beta d e hd he hbeta h + let : IsDomain (WeightedSplitTraceLaurentCoordinateRing beta alpha d e) := + weightedSplitTraceLaurentCoordinateRing_isDomain beta alpha d e hd he halpha hswap + exact weightedSplitTraceLaurentNormalizationInversions_commute alpha beta d e + +/-- Scheme isomorphism on the normalized overlap induced by first-coordinate inversion. -/ +def weightedSplitTraceLeftInversionLaurentNormalizationSchemeIso : + Spec (CommRingCat.of (WeightedSplitTraceLaurentNormalizationRing alpha beta d e)) ≅ + Spec (CommRingCat.of (WeightedSplitTraceLaurentNormalizationRing alpha beta d e)) := + BGS.specIsoOfRingEquiv + (weightedSplitTraceLeftInversionLaurentNormalizationEquiv alpha beta d e) + +/-- Contravariant scheme isomorphism on normalized overlaps induced by second-coordinate inversion. -/ +def weightedSplitTraceRightInversionLaurentNormalizationSchemeIso : + Spec (CommRingCat.of (WeightedSplitTraceLaurentNormalizationRing alpha beta d e)) ≅ + Spec (CommRingCat.of (WeightedSplitTraceLaurentNormalizationRing beta alpha d e)) := + BGS.specIsoOfRingEquiv + (weightedSplitTraceRightInversionLaurentNormalizationEquiv alpha beta d e) + +section ConjugatedPrincipalOpenTransitions + +universe u + +variable {OA OB : Type u} [CommRing OA] [CommRing OB] + +/-- Transport first-coordinate inversion from the normalized Laurent ring to any explicitly +identified principal-open ring model. -/ +def conjugatedLeftNormalizationOpenEquiv + (openEquiv : OA ≃+* WeightedSplitTraceLaurentNormalizationRing alpha beta d e) : + OA ≃+* OA := + openEquiv.trans + ((weightedSplitTraceLeftInversionLaurentNormalizationEquiv alpha beta d e).trans + openEquiv.symm) + +/-- Transport second-coordinate inversion between two explicitly identified principal-open ring +models. -/ +def conjugatedRightNormalizationOpenEquiv + (openEquiv : OA ≃+* WeightedSplitTraceLaurentNormalizationRing alpha beta d e) + (swappedOpenEquiv : OB ≃+* WeightedSplitTraceLaurentNormalizationRing beta alpha d e) : + OB ≃+* OA := + swappedOpenEquiv.trans + ((weightedSplitTraceRightInversionLaurentNormalizationEquiv alpha beta d e).trans + openEquiv.symm) + +/-- Conjugating by arbitrary principal-open identifications preserves the normalization cocycle. -/ +theorem conjugatedNormalizationOpenInversions_commute + (openEquiv : OA ≃+* WeightedSplitTraceLaurentNormalizationRing alpha beta d e) + (swappedOpenEquiv : OB ≃+* WeightedSplitTraceLaurentNormalizationRing beta alpha d e) : + (conjugatedRightNormalizationOpenEquiv alpha beta d e openEquiv swappedOpenEquiv).trans + (conjugatedLeftNormalizationOpenEquiv alpha beta d e openEquiv) = + (conjugatedLeftNormalizationOpenEquiv beta alpha d e swappedOpenEquiv).trans + (conjugatedRightNormalizationOpenEquiv alpha beta d e openEquiv swappedOpenEquiv) := by + ext x + simp only [conjugatedRightNormalizationOpenEquiv, conjugatedLeftNormalizationOpenEquiv, + RingEquiv.trans_apply, RingEquiv.apply_symm_apply] + exact congrArg openEquiv.symm + (DFunLike.congr_fun + (weightedSplitTraceLaurentNormalizationInversions_commute alpha beta d e) + (swappedOpenEquiv x)) + +/-- Scheme automorphism of a principal-open model induced by first-coordinate inversion. -/ +def conjugatedLeftNormalizationOpenSchemeIso + (openEquiv : OA ≃+* WeightedSplitTraceLaurentNormalizationRing alpha beta d e) : + Spec (CommRingCat.of OA) ≅ Spec (CommRingCat.of OA) := + BGS.specIsoOfRingEquiv + (conjugatedLeftNormalizationOpenEquiv alpha beta d e openEquiv) + +/-- Contravariant scheme isomorphism of principal-open models induced by second-coordinate +inversion. -/ +def conjugatedRightNormalizationOpenSchemeIso + (openEquiv : OA ≃+* WeightedSplitTraceLaurentNormalizationRing alpha beta d e) + (swappedOpenEquiv : OB ≃+* WeightedSplitTraceLaurentNormalizationRing beta alpha d e) : + Spec (CommRingCat.of OA) ≅ Spec (CommRingCat.of OB) := + BGS.specIsoOfRingEquiv + (conjugatedRightNormalizationOpenEquiv alpha beta d e + openEquiv swappedOpenEquiv) + +end ConjugatedPrincipalOpenTransitions + +end TraceCoverCharts + +end + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/LaurentSmooth.lean b/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/LaurentSmooth.lean new file mode 100644 index 0000000000..c65bcf2e79 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/LaurentSmooth.lean @@ -0,0 +1,430 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.LaurentJacobian +public import Mathlib.RingTheory.Smooth.Locus +public import Mathlib.RingTheory.Smooth.StandardSmooth +public import Mathlib.RingTheory.Smooth.StandardSmoothCotangent + +/-! +# Smoothness of the Laurent trace cover + +This module converts the Jacobian unit-ideal calculation into an actual `Algebra.Smooth` theorem. +It constructs submersive presentations on the two principal opens where the formal partial +derivatives are inverted, proves those localizations standard smooth, and covers the prime +spectrum using `weightedSplitTraceLaurentPartials_span_top`. + +The construction is explicit: no smoothness or normality assumption is stored in a structure or +passed as an opaque typeclass premise. +-/ + +@[expose] public section + +namespace BGS.Markoff + +noncomputable section + +variable {K : Type*} [Field K] + +/-! ### Finite presentations and the first-partial smooth chart -/ + +/-- The singleton family of equations presenting the affine trace cover. -/ +def weightedSplitTraceRelationFamily (alpha beta : K) (d e : ℕ) (_ : Unit) : + MvPolynomial (Fin 2) K := splitTraceCoverPolynomial alpha beta d e + +def weightedSplitTraceAffinePresentationEquiv (alpha beta : K) (d e : ℕ) : + (MvPolynomial (Fin 2) K ⧸ Ideal.span (Set.range + (weightedSplitTraceRelationFamily alpha beta d e))) ≃ₐ[K] + WeightedSplitTraceAffineCoordinateRing alpha beta d e := + Ideal.quotientEquivAlgOfEq K (by + congr 1 + ext p + simp [weightedSplitTraceRelationFamily, eq_comm]) + +def weightedSplitTraceAffineXPreSubmersivePresentation (alpha beta : K) (d e : ℕ) : + Algebra.PreSubmersivePresentation K + (WeightedSplitTraceAffineCoordinateRing alpha beta d e) (Fin 2) Unit := + (Algebra.PreSubmersivePresentation.naive + (v := weightedSplitTraceRelationFamily alpha beta d e) + (fun _ => 0) (fun _ _ _ => Subsingleton.elim _ _)).ofAlgEquiv + (weightedSplitTraceAffinePresentationEquiv alpha beta d e) + +noncomputable instance weightedSplitTraceAffineFinitePresentation (alpha beta : K) (d e : ℕ) : + Algebra.FinitePresentation K + (WeightedSplitTraceAffineCoordinateRing alpha beta d e) := + Algebra.Presentation.finitePresentation_of_isFinite + (weightedSplitTraceAffineXPreSubmersivePresentation alpha beta d e).toPresentation + +noncomputable instance weightedSplitTraceLaurentFinitePresentation (alpha beta : K) (d e : ℕ) : + Algebra.FinitePresentation K + (WeightedSplitTraceLaurentCoordinateRing alpha beta d e) := + Algebra.FinitePresentation.trans K + (WeightedSplitTraceAffineCoordinateRing alpha beta d e) + (WeightedSplitTraceLaurentCoordinateRing alpha beta d e) + +def weightedSplitTraceAffinePartialX (alpha beta : K) (d e : ℕ) : + WeightedSplitTraceAffineCoordinateRing alpha beta d e := + Ideal.Quotient.mk _ + (MvPolynomial.pderiv 0 (splitTraceCoverPolynomial alpha beta d e)) + +theorem weightedSplitTraceAffineXPreSubmersivePresentation_jacobian + (alpha beta : K) (d e : ℕ) : + (weightedSplitTraceAffineXPreSubmersivePresentation alpha beta d e).jacobian = + weightedSplitTraceAffinePartialX alpha beta d e := by + let P := Algebra.PreSubmersivePresentation.naive + (v := weightedSplitTraceRelationFamily alpha beta d e) + (fun _ => 0) (fun _ _ _ => Subsingleton.elim _ _) + let E := weightedSplitTraceAffinePresentationEquiv alpha beta d e + change (P.ofAlgEquiv E).jacobian = weightedSplitTraceAffinePartialX alpha beta d e + erw [Algebra.PreSubmersivePresentation.jacobian_ofAlgEquiv, + Algebra.PreSubmersivePresentation.jacobian_eq_jacobiMatrix_det, + Matrix.det_unique, Algebra.PreSubmersivePresentation.jacobiMatrix_naive] + change E (Ideal.Quotient.mk _ + (MvPolynomial.pderiv 0 (splitTraceCoverPolynomial alpha beta d e))) = + Ideal.Quotient.mk _ + (MvPolynomial.pderiv 0 (splitTraceCoverPolynomial alpha beta d e)) + exact Ideal.quotientEquivAlgOfEq_mk K _ _ + +theorem weightedSplitTraceLaurentEval_eq_algebraMap_mk + (alpha beta : K) (d e : ℕ) (p : MvPolynomial (Fin 2) K) : + MvPolynomial.aeval + ![weightedSplitTraceLaurentX alpha beta d e, + weightedSplitTraceLaurentY alpha beta d e] p = + algebraMap (WeightedSplitTraceAffineCoordinateRing alpha beta d e) + (WeightedSplitTraceLaurentCoordinateRing alpha beta d e) + (Ideal.Quotient.mk _ p) := by + let ev : MvPolynomial (Fin 2) K →ₐ[K] + WeightedSplitTraceLaurentCoordinateRing alpha beta d e := + MvPolynomial.aeval + ![weightedSplitTraceLaurentX alpha beta d e, + weightedSplitTraceLaurentY alpha beta d e] + let q : MvPolynomial (Fin 2) K →ₐ[K] + WeightedSplitTraceAffineCoordinateRing alpha beta d e := + Ideal.Quotient.mkₐ K _ + let inclusion : WeightedSplitTraceAffineCoordinateRing alpha beta d e →ₐ[K] + WeightedSplitTraceLaurentCoordinateRing alpha beta d e := + { toRingHom := algebraMap _ _ + commutes' := fun k => IsScalarTower.algebraMap_apply K + (WeightedSplitTraceAffineCoordinateRing alpha beta d e) + (WeightedSplitTraceLaurentCoordinateRing alpha beta d e) k } + have h : ev = + inclusion.comp q := by + apply MvPolynomial.algHom_ext + intro i + fin_cases i <;> + simp [ev, q, inclusion, AlgHom.comp_apply, weightedSplitTraceLaurentX, + weightedSplitTraceLaurentY, weightedSplitTraceAffineX, + weightedSplitTraceAffineY] + change ev p = _ + rw [h] + rfl + +theorem weightedSplitTraceAffinePartialX_mapsToLaurent + (alpha beta : K) (d e : ℕ) : + algebraMap (WeightedSplitTraceAffineCoordinateRing alpha beta d e) + (WeightedSplitTraceLaurentCoordinateRing alpha beta d e) + (weightedSplitTraceAffinePartialX alpha beta d e) = + weightedSplitTraceLaurentPartialX alpha beta d e := by + symm + exact weightedSplitTraceLaurentEval_eq_algebraMap_mk alpha beta d e _ + +abbrev WeightedSplitTracePartialXLocalization (alpha beta : K) (d e : ℕ) := + Localization.Away (weightedSplitTraceLaurentPartialX alpha beta d e) + +def weightedSplitTraceCoordinateProductPreSubmersivePresentation + (alpha beta : K) (d e : ℕ) : + Algebra.PreSubmersivePresentation + (WeightedSplitTraceAffineCoordinateRing alpha beta d e) + (WeightedSplitTraceLaurentCoordinateRing alpha beta d e) Unit Unit := + Algebra.PreSubmersivePresentation.localizationAway + (WeightedSplitTraceLaurentCoordinateRing alpha beta d e) + (weightedSplitTraceAffineCoordinateProduct alpha beta d e) + +def weightedSplitTraceLaurentXPreSubmersivePresentation (alpha beta : K) (d e : ℕ) : + Algebra.PreSubmersivePresentation K + (WeightedSplitTraceLaurentCoordinateRing alpha beta d e) + (Unit ⊕ Fin 2) (Unit ⊕ Unit) := + (weightedSplitTraceCoordinateProductPreSubmersivePresentation alpha beta d e).comp + (weightedSplitTraceAffineXPreSubmersivePresentation alpha beta d e) + +def weightedSplitTracePartialXLocalizationPreSubmersivePresentation + (alpha beta : K) (d e : ℕ) : + Algebra.PreSubmersivePresentation + (WeightedSplitTraceLaurentCoordinateRing alpha beta d e) + (WeightedSplitTracePartialXLocalization alpha beta d e) Unit Unit := + Algebra.PreSubmersivePresentation.localizationAway + (WeightedSplitTracePartialXLocalization alpha beta d e) + (weightedSplitTraceLaurentPartialX alpha beta d e) + +def weightedSplitTracePartialXCompositePresentation + (alpha beta : K) (d e : ℕ) : + Algebra.PreSubmersivePresentation K + (WeightedSplitTracePartialXLocalization alpha beta d e) + (Unit ⊕ (Unit ⊕ Fin 2)) (Unit ⊕ (Unit ⊕ Unit)) := + (weightedSplitTracePartialXLocalizationPreSubmersivePresentation alpha beta d e).comp + (weightedSplitTraceLaurentXPreSubmersivePresentation alpha beta d e) + +theorem weightedSplitTracePartialXCompositePresentation_jacobian_isUnit + (alpha beta : K) (d e : ℕ) : + IsUnit (weightedSplitTracePartialXCompositePresentation alpha beta d e).jacobian := by + let A := WeightedSplitTraceAffineCoordinateRing alpha beta d e + let L := WeightedSplitTraceLaurentCoordinateRing alpha beta d e + let Lx := WeightedSplitTracePartialXLocalization alpha beta d e + let P₀ := weightedSplitTraceAffineXPreSubmersivePresentation alpha beta d e + let Qxy := weightedSplitTraceCoordinateProductPreSubmersivePresentation alpha beta d e + let P₁ := weightedSplitTraceLaurentXPreSubmersivePresentation alpha beta d e + let Qx := weightedSplitTracePartialXLocalizationPreSubmersivePresentation alpha beta d e + have hP₀ : IsUnit (algebraMap L Lx (algebraMap A L P₀.jacobian)) := by + rw [show P₀.jacobian = weightedSplitTraceAffinePartialX alpha beta d e by + exact weightedSplitTraceAffineXPreSubmersivePresentation_jacobian alpha beta d e] + rw [weightedSplitTraceAffinePartialX_mapsToLaurent] + exact IsLocalization.Away.algebraMap_isUnit + (S := Lx) (weightedSplitTraceLaurentPartialX alpha beta d e) + have hQxy : IsUnit (algebraMap L Lx Qxy.jacobian) := by + rw [show Qxy.jacobian = algebraMap A L + (weightedSplitTraceAffineCoordinateProduct alpha beta d e) by + exact Algebra.PreSubmersivePresentation.localizationAway_jacobian _] + exact (IsLocalization.Away.algebraMap_isUnit + (S := L) (weightedSplitTraceAffineCoordinateProduct alpha beta d e)).map + (algebraMap L Lx) + have hQx : IsUnit Qx.jacobian := by + rw [show Qx.jacobian = algebraMap L Lx + (weightedSplitTraceLaurentPartialX alpha beta d e) by + exact Algebra.PreSubmersivePresentation.localizationAway_jacobian _] + exact IsLocalization.Away.algebraMap_isUnit + (S := Lx) (weightedSplitTraceLaurentPartialX alpha beta d e) + change IsUnit (Qx.comp P₁).jacobian + rw [Algebra.PreSubmersivePresentation.comp_jacobian_eq_jacobian_smul_jacobian, + Algebra.smul_def] + have hP₁ : IsUnit (algebraMap L Lx P₁.jacobian) := by + change IsUnit (algebraMap L Lx (Qxy.comp P₀).jacobian) + rw [Algebra.PreSubmersivePresentation.comp_jacobian_eq_jacobian_smul_jacobian, + Algebra.smul_def, map_mul] + exact hP₀.mul hQxy + exact hP₁.mul hQx + +def weightedSplitTracePartialXSubmersivePresentation + (alpha beta : K) (d e : ℕ) : + Algebra.SubmersivePresentation K + (WeightedSplitTracePartialXLocalization alpha beta d e) + (Unit ⊕ (Unit ⊕ Fin 2)) (Unit ⊕ (Unit ⊕ Unit)) where + toPreSubmersivePresentation := + weightedSplitTracePartialXCompositePresentation alpha beta d e + jacobian_isUnit := + weightedSplitTracePartialXCompositePresentation_jacobian_isUnit alpha beta d e + +theorem weightedSplitTracePartialXLocalization_isStandardSmooth + (alpha beta : K) (d e : ℕ) : + Algebra.IsStandardSmooth K + (WeightedSplitTracePartialXLocalization alpha beta d e) := + (weightedSplitTracePartialXSubmersivePresentation alpha beta d e).isStandardSmooth + +theorem weightedSplitTracePartialXLocalization_smooth + (alpha beta : K) (d e : ℕ) : + Algebra.Smooth K (WeightedSplitTracePartialXLocalization alpha beta d e) := by + let : Algebra.IsStandardSmooth K + (WeightedSplitTracePartialXLocalization alpha beta d e) := + weightedSplitTracePartialXLocalization_isStandardSmooth alpha beta d e + infer_instance + +/-! ### The second-partial smooth chart -/ + +/-- The affine second partial derivative, before localization at the coordinate product. -/ +def weightedSplitTraceAffinePartialY (alpha beta : K) (d e : ℕ) : + WeightedSplitTraceAffineCoordinateRing alpha beta d e := + Ideal.Quotient.mk _ + (MvPolynomial.pderiv 1 (splitTraceCoverPolynomial alpha beta d e)) + +/-- The hypersurface presentation selecting the `y` column of its Jacobian matrix. -/ +def weightedSplitTraceAffineYPreSubmersivePresentation + (alpha beta : K) (d e : ℕ) : + Algebra.PreSubmersivePresentation K + (WeightedSplitTraceAffineCoordinateRing alpha beta d e) (Fin 2) Unit := + (Algebra.PreSubmersivePresentation.naive + (v := weightedSplitTraceRelationFamily alpha beta d e) + (fun _ => 1) (fun _ _ _ => Subsingleton.elim _ _)).ofAlgEquiv + (weightedSplitTraceAffinePresentationEquiv alpha beta d e) + +theorem weightedSplitTraceAffineYPreSubmersivePresentation_jacobian + (alpha beta : K) (d e : ℕ) : + (weightedSplitTraceAffineYPreSubmersivePresentation alpha beta d e).jacobian = + weightedSplitTraceAffinePartialY alpha beta d e := by + let P := Algebra.PreSubmersivePresentation.naive + (v := weightedSplitTraceRelationFamily alpha beta d e) + (fun _ => 1) (fun _ _ _ => Subsingleton.elim _ _) + let E := weightedSplitTraceAffinePresentationEquiv alpha beta d e + change (P.ofAlgEquiv E).jacobian = weightedSplitTraceAffinePartialY alpha beta d e + erw [Algebra.PreSubmersivePresentation.jacobian_ofAlgEquiv, + Algebra.PreSubmersivePresentation.jacobian_eq_jacobiMatrix_det, + Matrix.det_unique, Algebra.PreSubmersivePresentation.jacobiMatrix_naive] + change E (Ideal.Quotient.mk _ + (MvPolynomial.pderiv 1 (splitTraceCoverPolynomial alpha beta d e))) = + Ideal.Quotient.mk _ + (MvPolynomial.pderiv 1 (splitTraceCoverPolynomial alpha beta d e)) + exact Ideal.quotientEquivAlgOfEq_mk K _ _ + +theorem weightedSplitTraceAffinePartialY_mapsToLaurent + (alpha beta : K) (d e : ℕ) : + algebraMap (WeightedSplitTraceAffineCoordinateRing alpha beta d e) + (WeightedSplitTraceLaurentCoordinateRing alpha beta d e) + (weightedSplitTraceAffinePartialY alpha beta d e) = + weightedSplitTraceLaurentPartialY alpha beta d e := by + symm + exact weightedSplitTraceLaurentEval_eq_algebraMap_mk alpha beta d e _ + +/-- The principal open on which the second partial derivative is invertible. -/ +abbrev WeightedSplitTracePartialYLocalization (alpha beta : K) (d e : ℕ) := + Localization.Away (weightedSplitTraceLaurentPartialY alpha beta d e) + +/-- Laurent presentation whose hypersurface Jacobian is the second partial derivative. -/ +def weightedSplitTraceLaurentYPreSubmersivePresentation + (alpha beta : K) (d e : ℕ) : + Algebra.PreSubmersivePresentation K + (WeightedSplitTraceLaurentCoordinateRing alpha beta d e) + (Unit ⊕ Fin 2) (Unit ⊕ Unit) := + (weightedSplitTraceCoordinateProductPreSubmersivePresentation alpha beta d e).comp + (weightedSplitTraceAffineYPreSubmersivePresentation alpha beta d e) + +def weightedSplitTracePartialYLocalizationPreSubmersivePresentation + (alpha beta : K) (d e : ℕ) : + Algebra.PreSubmersivePresentation + (WeightedSplitTraceLaurentCoordinateRing alpha beta d e) + (WeightedSplitTracePartialYLocalization alpha beta d e) Unit Unit := + Algebra.PreSubmersivePresentation.localizationAway + (WeightedSplitTracePartialYLocalization alpha beta d e) + (weightedSplitTraceLaurentPartialY alpha beta d e) + +def weightedSplitTracePartialYCompositePresentation + (alpha beta : K) (d e : ℕ) : + Algebra.PreSubmersivePresentation K + (WeightedSplitTracePartialYLocalization alpha beta d e) + (Unit ⊕ (Unit ⊕ Fin 2)) (Unit ⊕ (Unit ⊕ Unit)) := + (weightedSplitTracePartialYLocalizationPreSubmersivePresentation alpha beta d e).comp + (weightedSplitTraceLaurentYPreSubmersivePresentation alpha beta d e) + +theorem weightedSplitTracePartialYCompositePresentation_jacobian_isUnit + (alpha beta : K) (d e : ℕ) : + IsUnit (weightedSplitTracePartialYCompositePresentation alpha beta d e).jacobian := by + let A := WeightedSplitTraceAffineCoordinateRing alpha beta d e + let L := WeightedSplitTraceLaurentCoordinateRing alpha beta d e + let Ly := WeightedSplitTracePartialYLocalization alpha beta d e + let P₀ := weightedSplitTraceAffineYPreSubmersivePresentation alpha beta d e + let Qxy := weightedSplitTraceCoordinateProductPreSubmersivePresentation alpha beta d e + let P₁ := weightedSplitTraceLaurentYPreSubmersivePresentation alpha beta d e + let Qy := weightedSplitTracePartialYLocalizationPreSubmersivePresentation alpha beta d e + have hP₀ : IsUnit (algebraMap L Ly (algebraMap A L P₀.jacobian)) := by + rw [show P₀.jacobian = weightedSplitTraceAffinePartialY alpha beta d e by + exact weightedSplitTraceAffineYPreSubmersivePresentation_jacobian alpha beta d e] + rw [weightedSplitTraceAffinePartialY_mapsToLaurent] + exact IsLocalization.Away.algebraMap_isUnit + (S := Ly) (weightedSplitTraceLaurentPartialY alpha beta d e) + have hQxy : IsUnit (algebraMap L Ly Qxy.jacobian) := by + rw [show Qxy.jacobian = algebraMap A L + (weightedSplitTraceAffineCoordinateProduct alpha beta d e) by + exact Algebra.PreSubmersivePresentation.localizationAway_jacobian _] + exact (IsLocalization.Away.algebraMap_isUnit + (S := L) (weightedSplitTraceAffineCoordinateProduct alpha beta d e)).map + (algebraMap L Ly) + have hQy : IsUnit Qy.jacobian := by + rw [show Qy.jacobian = algebraMap L Ly + (weightedSplitTraceLaurentPartialY alpha beta d e) by + exact Algebra.PreSubmersivePresentation.localizationAway_jacobian _] + exact IsLocalization.Away.algebraMap_isUnit + (S := Ly) (weightedSplitTraceLaurentPartialY alpha beta d e) + change IsUnit (Qy.comp P₁).jacobian + rw [Algebra.PreSubmersivePresentation.comp_jacobian_eq_jacobian_smul_jacobian, + Algebra.smul_def] + have hP₁ : IsUnit (algebraMap L Ly P₁.jacobian) := by + change IsUnit (algebraMap L Ly (Qxy.comp P₀).jacobian) + rw [Algebra.PreSubmersivePresentation.comp_jacobian_eq_jacobian_smul_jacobian, + Algebra.smul_def, map_mul] + exact hP₀.mul hQxy + exact hP₁.mul hQy + +def weightedSplitTracePartialYSubmersivePresentation + (alpha beta : K) (d e : ℕ) : + Algebra.SubmersivePresentation K + (WeightedSplitTracePartialYLocalization alpha beta d e) + (Unit ⊕ (Unit ⊕ Fin 2)) (Unit ⊕ (Unit ⊕ Unit)) where + toPreSubmersivePresentation := + weightedSplitTracePartialYCompositePresentation alpha beta d e + jacobian_isUnit := + weightedSplitTracePartialYCompositePresentation_jacobian_isUnit alpha beta d e + +theorem weightedSplitTracePartialYLocalization_isStandardSmooth + (alpha beta : K) (d e : ℕ) : + Algebra.IsStandardSmooth K + (WeightedSplitTracePartialYLocalization alpha beta d e) := + (weightedSplitTracePartialYSubmersivePresentation alpha beta d e).isStandardSmooth + +theorem weightedSplitTracePartialYLocalization_smooth + (alpha beta : K) (d e : ℕ) : + Algebra.Smooth K (WeightedSplitTracePartialYLocalization alpha beta d e) := by + let : Algebra.IsStandardSmooth K + (WeightedSplitTracePartialYLocalization alpha beta d e) := + weightedSplitTracePartialYLocalization_isStandardSmooth alpha beta d e + infer_instance + +theorem weightedSplitTraceLaurent_smooth_of_partialLocalizations + (alpha beta : K) (d e : ℕ) + (hspan : Ideal.span {weightedSplitTraceLaurentPartialX alpha beta d e, + weightedSplitTraceLaurentPartialY alpha beta d e} = ⊤) + (hX : Algebra.Smooth K + (Localization.Away (weightedSplitTraceLaurentPartialX alpha beta d e))) + (hY : Algebra.Smooth K + (Localization.Away (weightedSplitTraceLaurentPartialY alpha beta d e))) : + Algebra.Smooth K (WeightedSplitTraceLaurentCoordinateRing alpha beta d e) := by + let L := WeightedSplitTraceLaurentCoordinateRing alpha beta d e + let fx : L := weightedSplitTraceLaurentPartialX alpha beta d e + let fy : L := weightedSplitTraceLaurentPartialY alpha beta d e + have hXOpen : (PrimeSpectrum.basicOpen fx : Set (PrimeSpectrum L)) ⊆ + Algebra.smoothLocus K L := + Algebra.basicOpen_subset_smoothLocus_iff_smooth.mpr hX + have hYOpen : (PrimeSpectrum.basicOpen fy : Set (PrimeSpectrum L)) ⊆ + Algebra.smoothLocus K L := + Algebra.basicOpen_subset_smoothLocus_iff_smooth.mpr hY + have hLocus : Algebra.smoothLocus K L = Set.univ := by + apply Set.eq_univ_of_forall + intro p + by_cases hpx : p ∈ PrimeSpectrum.basicOpen fx + · exact hXOpen hpx + by_cases hpy : p ∈ PrimeSpectrum.basicOpen fy + · exact hYOpen hpy + have hfx : fx ∈ p.asIdeal := by + simpa [PrimeSpectrum.mem_basicOpen] using hpx + have hfy : fy ∈ p.asIdeal := by + simpa [PrimeSpectrum.mem_basicOpen] using hpy + exfalso + have hle : Ideal.span {fx, fy} ≤ p.asIdeal := by + rw [Ideal.span_le] + intro z hz + simp only [Set.mem_insert_iff, Set.mem_singleton_iff] at hz + rcases hz with rfl | rfl + · exact hfx + · exact hfy + have hpTop : p.asIdeal = ⊤ := top_unique (hspan ▸ hle) + exact p.isPrime.ne_top hpTop + exact ⟨(Algebra.smoothLocus_eq_univ_iff.mp hLocus), inferInstance⟩ + +/-- The Laurent trace-cover algebra is smooth over the ground field in the paper's +nondegenerate, characteristic-compatible range. -/ +theorem weightedSplitTraceLaurent_smooth + (alpha beta : K) (hnondegenerate : alpha * beta ≠ 1) + (htwo : (2 : K) ≠ 0) (d e : ℕ) (hd : 0 < d) (he : 0 < e) + (hdChar : (d : K) ≠ 0) (heChar : (e : K) ≠ 0) : + Algebra.Smooth K + (WeightedSplitTraceLaurentCoordinateRing alpha beta d e) := + weightedSplitTraceLaurent_smooth_of_partialLocalizations alpha beta d e + (weightedSplitTraceLaurentPartials_span_top alpha beta hnondegenerate + htwo d e hd he hdChar heChar) + (weightedSplitTracePartialXLocalization_smooth alpha beta d e) + (weightedSplitTracePartialYLocalization_smooth alpha beta d e) + +end + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/Localization.lean b/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/Localization.lean new file mode 100644 index 0000000000..5ea1bfcb93 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/Localization.lean @@ -0,0 +1,402 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.Kummer +public import Mathlib.RingTheory.Localization.Away.Basic + +/-! +# The Laurent split trace cover inside its Kummer function field + +This file constructs the comparison map that was missing between the denominator-cleared affine +trace-cover coordinate ring, localized away from the two coordinate axes, and the explicit +odd-coprime Kummer tower. Injectivity is kept as the visible remaining wall; it is not encoded as +an axiom or typeclass field. +-/ + +@[expose] public section + +namespace BGS.Markoff + +open Polynomial + +noncomputable section + +variable {K : Type*} [Field K] + +/-- The affine coordinate ring of the normalized split trace cover. -/ +abbrev SplitTraceAffineCoordinateRing (K : Type*) [Field K] + (sigma : K) (d e : ℕ) := + MvPolynomial (Fin 2) K ⧸ + Ideal.span {splitTraceCoverPolynomial (1 : K) sigma d e} + +/-- The product of the two coordinate functions in the affine trace-cover ring. -/ +def splitTraceAffineCoordinateProduct (sigma : K) (d e : ℕ) : + SplitTraceAffineCoordinateRing K sigma d e := + Ideal.Quotient.mk _ (MvPolynomial.X 0 * MvPolynomial.X 1) + +/-- The coordinate ring of the open trace cover in the two-dimensional torus. -/ +abbrev SplitTraceLaurentCoordinateRing (K : Type*) [Field K] + (sigma : K) (d e : ℕ) := + Localization.Away (splitTraceAffineCoordinateProduct sigma d e) + +section OddCoprimeTower + +variable (sigma : K) (hsigma : sigma ≠ 0) (e d : ℕ) + (heOdd : Odd e) (hdOdd : Odd d) (hde : d.Coprime e) + +/-- Evaluation of the two affine coordinates at the canonical roots of the Kummer tower. -/ +def splitTracePolynomialToKummerTop : + MvPolynomial (Fin 2) K →ₐ[K] SplitTraceXiFunctionField K sigma e d := by + let hBaseIrred := splitTraceBaseKummerPolynomial_irreducible sigma hsigma + letI : Fact (Irreducible (splitTraceBaseKummerPolynomial sigma)) := ⟨hBaseIrred⟩ + let hEtaIrred := splitTraceEtaKummerPolynomial_irreducible' sigma hsigma e heOdd + letI : Fact (Irreducible (splitTraceEtaKummerPolynomial sigma e)) := ⟨hEtaIrred⟩ + let hXiIrred := + splitTraceXiKummerPolynomial_irreducible sigma hsigma e d heOdd hdOdd hde + letI : Fact (Irreducible (splitTraceXiKummerPolynomial sigma e d)) := ⟨hXiIrred⟩ + exact MvPolynomial.aeval ![splitTraceXiRoot sigma e d, + splitTraceEtaRootInXiField sigma e d] + +/-- The defining affine trace-cover relation vanishes under evaluation in the Kummer tower. -/ +lemma splitTracePolynomialToKummerTop_relation : + splitTracePolynomialToKummerTop sigma hsigma e d heOdd hdOdd hde + (splitTraceCoverPolynomial 1 sigma d e) = 0 := by + let hBaseIrred := splitTraceBaseKummerPolynomial_irreducible sigma hsigma + let : Fact (Irreducible (splitTraceBaseKummerPolynomial sigma)) := ⟨hBaseIrred⟩ + let hEtaIrred := splitTraceEtaKummerPolynomial_irreducible' sigma hsigma e heOdd + let : Fact (Irreducible (splitTraceEtaKummerPolynomial sigma e)) := ⟨hEtaIrred⟩ + let hXiIrred := + splitTraceXiKummerPolynomial_irreducible sigma hsigma e d heOdd hdOdd hde + let : Fact (Irreducible (splitTraceXiKummerPolynomial sigma e d)) := ⟨hXiIrred⟩ + have hCover := splitTraceKummerTower_roots_on_cover + sigma hsigma e d heOdd hdOdd hde + have hsigmaMap : + splitTraceBaseElementInXiField sigma e d + (algebraMap (RatFunc K) (SplitTraceBaseFunctionField K sigma) (RatFunc.C sigma)) = + algebraMap K (SplitTraceXiFunctionField K sigma e d) sigma := by + rw [show RatFunc.C sigma = algebraMap K (RatFunc K) sigma by + rw [RatFunc.algebraMap_eq_C]] + change algebraMap (RatFunc K) (SplitTraceXiFunctionField K sigma e d) + (algebraMap K (RatFunc K) sigma) = + algebraMap K (SplitTraceXiFunctionField K sigma e d) sigma + exact (IsScalarTower.algebraMap_apply K (RatFunc K) + (SplitTraceXiFunctionField K sigma e d) sigma).symm + rw [hsigmaMap] at hCover + simpa [splitTracePolynomialToKummerTop, MvPolynomial.aeval_def, + splitTraceCoverPolynomial] using hCover + +/-- The affine trace-cover coordinate ring maps canonically to the Kummer top field. -/ +def splitTraceAffineToKummerTop : + SplitTraceAffineCoordinateRing K sigma d e →ₐ[K] + SplitTraceXiFunctionField K sigma e d := by + let hBaseIrred := splitTraceBaseKummerPolynomial_irreducible sigma hsigma + letI : Fact (Irreducible (splitTraceBaseKummerPolynomial sigma)) := ⟨hBaseIrred⟩ + let hEtaIrred := splitTraceEtaKummerPolynomial_irreducible' sigma hsigma e heOdd + letI : Fact (Irreducible (splitTraceEtaKummerPolynomial sigma e)) := ⟨hEtaIrred⟩ + let hXiIrred := + splitTraceXiKummerPolynomial_irreducible sigma hsigma e d heOdd hdOdd hde + letI : Fact (Irreducible (splitTraceXiKummerPolynomial sigma e d)) := ⟨hXiIrred⟩ + refine Ideal.Quotient.liftₐ + (Ideal.span {splitTraceCoverPolynomial (1 : K) sigma d e}) + (splitTracePolynomialToKummerTop sigma hsigma e d heOdd hdOdd hde) ?_ + intro p hp + have hle : Ideal.span {splitTraceCoverPolynomial (1 : K) sigma d e} ≤ + RingHom.ker + (splitTracePolynomialToKummerTop sigma hsigma e d heOdd hdOdd hde).toRingHom := by + rw [Ideal.span_le] + intro q hq + simp only [Set.mem_singleton_iff] at hq + subst q + exact splitTracePolynomialToKummerTop_relation sigma hsigma e d heOdd hdOdd hde + exact hle hp + +@[simp] +lemma splitTraceAffineToKummerTop_coordinate (i : Fin 2) : + splitTraceAffineToKummerTop sigma hsigma e d heOdd hdOdd hde + (Ideal.Quotient.mk _ (MvPolynomial.X i)) = + ![splitTraceXiRoot sigma e d, splitTraceEtaRootInXiField sigma e d] i := by + let hBaseIrred := splitTraceBaseKummerPolynomial_irreducible sigma hsigma + let : Fact (Irreducible (splitTraceBaseKummerPolynomial sigma)) := ⟨hBaseIrred⟩ + let hEtaIrred := splitTraceEtaKummerPolynomial_irreducible' sigma hsigma e heOdd + let : Fact (Irreducible (splitTraceEtaKummerPolynomial sigma e)) := ⟨hEtaIrred⟩ + let hXiIrred := + splitTraceXiKummerPolynomial_irreducible sigma hsigma e d heOdd hdOdd hde + let : Fact (Irreducible (splitTraceXiKummerPolynomial sigma e d)) := ⟨hXiIrred⟩ + change MvPolynomial.aeval + ![splitTraceXiRoot sigma e d, splitTraceEtaRootInXiField sigma e d] (MvPolynomial.X i) = _ + simp + +lemma splitTraceBaseV_sq : + splitTraceBaseV sigma ^ 2 = + algebraMap (RatFunc K) (SplitTraceBaseFunctionField K sigma) + (splitTraceRadicand sigma) := by + apply sub_eq_zero.mp + have h := AdjoinRoot.eval₂_root (splitTraceBaseKummerPolynomial sigma) + rw [splitTraceBaseKummerPolynomial] at h + simp only [Polynomial.eval₂_sub, Polynomial.eval₂_pow, Polynomial.eval₂_X, + Polynomial.eval₂_C] at h + rw [← AdjoinRoot.algebraMap_eq] at h + exact h + +lemma splitTraceEtaRoot_pow : + (AdjoinRoot.root (splitTraceEtaKummerPolynomial sigma e)) ^ e = + algebraMap (SplitTraceBaseFunctionField K sigma) + (SplitTraceEtaFunctionField K sigma e) (splitTraceBaseV sigma) := by + apply sub_eq_zero.mp + have h := AdjoinRoot.eval₂_root (splitTraceEtaKummerPolynomial sigma e) + rw [splitTraceEtaKummerPolynomial] at h + simp only [Polynomial.eval₂_sub, Polynomial.eval₂_pow, Polynomial.eval₂_X, + Polynomial.eval₂_C] at h + rw [← AdjoinRoot.algebraMap_eq] at h + exact h + +lemma splitTraceXiRoot_pow : + splitTraceXiRoot sigma e d ^ d = + algebraMap (SplitTraceEtaFunctionField K sigma e) + (SplitTraceXiFunctionField K sigma e d) (splitTraceXiRadicand sigma e) := by + apply sub_eq_zero.mp + have h := AdjoinRoot.eval₂_root (splitTraceXiKummerPolynomial sigma e d) + rw [splitTraceXiKummerPolynomial] at h + simp only [Polynomial.eval₂_sub, Polynomial.eval₂_pow, Polynomial.eval₂_X, + Polynomial.eval₂_C] at h + rw [← AdjoinRoot.algebraMap_eq] at h + exact h + +lemma splitTraceBaseV_ne_zero (hsigma : sigma ≠ 0) : splitTraceBaseV sigma ≠ 0 := by + let hBaseIrred := splitTraceBaseKummerPolynomial_irreducible sigma hsigma + let : Fact (Irreducible (splitTraceBaseKummerPolynomial sigma)) := ⟨hBaseIrred⟩ + change AdjoinRoot.root (splitTraceBaseKummerPolynomial sigma) ≠ 0 + exact (root_X_pow_sub_C_ne_zero_iff hBaseIrred).mpr + (splitTraceRadicand_ne_zero sigma hsigma) + +lemma splitTraceBaseU_ne_zero (hsigma : sigma ≠ 0) : splitTraceBaseU sigma ≠ 0 := by + let hBaseIrred := splitTraceBaseKummerPolynomial_irreducible sigma hsigma + let : Fact (Irreducible (splitTraceBaseKummerPolynomial sigma)) := ⟨hBaseIrred⟩ + exact (map_ne_zero_iff _ + (algebraMap (RatFunc K) (SplitTraceBaseFunctionField K sigma)).injective).mpr + RatFunc.X_ne_zero + +lemma splitTraceEtaRootInXiField_ne_zero + (hsigma : sigma ≠ 0) (heOdd : Odd e) (hdOdd : Odd d) (hde : d.Coprime e) : + splitTraceEtaRootInXiField sigma e d ≠ 0 := by + let hBaseIrred := splitTraceBaseKummerPolynomial_irreducible sigma hsigma + let : Fact (Irreducible (splitTraceBaseKummerPolynomial sigma)) := ⟨hBaseIrred⟩ + let hEtaIrred := splitTraceEtaKummerPolynomial_irreducible' sigma hsigma e heOdd + let : Fact (Irreducible (splitTraceEtaKummerPolynomial sigma e)) := ⟨hEtaIrred⟩ + let hXiIrred := + splitTraceXiKummerPolynomial_irreducible sigma hsigma e d heOdd hdOdd hde + let : Fact (Irreducible (splitTraceXiKummerPolynomial sigma e d)) := ⟨hXiIrred⟩ + apply (map_ne_zero_iff _ + (algebraMap (SplitTraceEtaFunctionField K sigma e) + (SplitTraceXiFunctionField K sigma e d)).injective).mpr + change AdjoinRoot.root (splitTraceEtaKummerPolynomial sigma e) ≠ 0 + change AdjoinRoot.root (X ^ e - C (splitTraceBaseV sigma)) ≠ 0 + exact (root_X_pow_sub_C_ne_zero_iff hEtaIrred).mpr + (splitTraceBaseV_ne_zero (sigma := sigma) hsigma) + +lemma splitTraceXiRoot_ne_zero + (hsigma : sigma ≠ 0) (heOdd : Odd e) (hdOdd : Odd d) (hde : d.Coprime e) : + splitTraceXiRoot sigma e d ≠ 0 := by + let hBaseIrred := splitTraceBaseKummerPolynomial_irreducible sigma hsigma + let : Fact (Irreducible (splitTraceBaseKummerPolynomial sigma)) := ⟨hBaseIrred⟩ + let hEtaIrred := splitTraceEtaKummerPolynomial_irreducible' sigma hsigma e heOdd + let : Fact (Irreducible (splitTraceEtaKummerPolynomial sigma e)) := ⟨hEtaIrred⟩ + let hXiIrred := + splitTraceXiKummerPolynomial_irreducible sigma hsigma e d heOdd hdOdd hde + let : Fact (Irreducible (splitTraceXiKummerPolynomial sigma e d)) := ⟨hXiIrred⟩ + have hRadicand : splitTraceXiRadicand sigma e ≠ 0 := by + apply (map_ne_zero_iff _ + (algebraMap (SplitTraceBaseFunctionField K sigma) + (SplitTraceEtaFunctionField K sigma e)).injective).mpr + exact mul_ne_zero + (splitTraceBaseU_ne_zero (sigma := sigma) hsigma) + (splitTraceBaseV_ne_zero (sigma := sigma) hsigma) + change AdjoinRoot.root (X ^ d - C (splitTraceXiRadicand sigma e)) ≠ 0 + exact (root_X_pow_sub_C_ne_zero_iff hXiIrred).mpr hRadicand + +lemma splitTraceAffineCoordinateProduct_maps_to_nonzero : + letI : Fact (Irreducible (splitTraceBaseKummerPolynomial sigma)) := + ⟨splitTraceBaseKummerPolynomial_irreducible sigma hsigma⟩ + letI : Fact (Irreducible (splitTraceEtaKummerPolynomial sigma e)) := + ⟨splitTraceEtaKummerPolynomial_irreducible' sigma hsigma e heOdd⟩ + letI : Fact (Irreducible (splitTraceXiKummerPolynomial sigma e d)) := + ⟨splitTraceXiKummerPolynomial_irreducible sigma hsigma e d heOdd hdOdd hde⟩ + splitTraceAffineToKummerTop sigma hsigma e d heOdd hdOdd hde + (splitTraceAffineCoordinateProduct sigma d e) ≠ 0 := by + let hBaseIrred := splitTraceBaseKummerPolynomial_irreducible sigma hsigma + let : Fact (Irreducible (splitTraceBaseKummerPolynomial sigma)) := ⟨hBaseIrred⟩ + let hEtaIrred := splitTraceEtaKummerPolynomial_irreducible' sigma hsigma e heOdd + let : Fact (Irreducible (splitTraceEtaKummerPolynomial sigma e)) := ⟨hEtaIrred⟩ + let hXiIrred := + splitTraceXiKummerPolynomial_irreducible sigma hsigma e d heOdd hdOdd hde + let : Fact (Irreducible (splitTraceXiKummerPolynomial sigma e d)) := ⟨hXiIrred⟩ + change splitTraceAffineToKummerTop sigma hsigma e d heOdd hdOdd hde + (Ideal.Quotient.mk _ (MvPolynomial.X 0 * MvPolynomial.X 1)) ≠ 0 + simp only [map_mul] + rw [splitTraceAffineToKummerTop_coordinate, splitTraceAffineToKummerTop_coordinate] + exact mul_ne_zero + (splitTraceXiRoot_ne_zero (sigma := sigma) (e := e) (d := d) + hsigma heOdd hdOdd hde) + (splitTraceEtaRootInXiField_ne_zero (sigma := sigma) (e := e) (d := d) + hsigma heOdd hdOdd hde) + +/-- The image of the coordinate product is a unit for algebraic reasons internal to the Kummer +tower. This proof uses the three root-power equations, rather than treating the top quotient as a +field through a late typeclass instance. -/ +lemma splitTraceAffineCoordinateProduct_maps_to_isUnit : + IsUnit (splitTraceAffineToKummerTop sigma hsigma e d heOdd hdOdd hde + (splitTraceAffineCoordinateProduct sigma d e)) := by + let hBaseIrred := splitTraceBaseKummerPolynomial_irreducible sigma hsigma + let : Fact (Irreducible (splitTraceBaseKummerPolynomial sigma)) := ⟨hBaseIrred⟩ + let hEtaIrred := splitTraceEtaKummerPolynomial_irreducible' sigma hsigma e heOdd + let : Fact (Irreducible (splitTraceEtaKummerPolynomial sigma e)) := ⟨hEtaIrred⟩ + let hXiIrred := + splitTraceXiKummerPolynomial_irreducible sigma hsigma e d heOdd hdOdd hde + let : Fact (Irreducible (splitTraceXiKummerPolynomial sigma e d)) := ⟨hXiIrred⟩ + have hBaseUUnit : IsUnit (splitTraceBaseU sigma) := + (isUnit_iff_ne_zero.mpr RatFunc.X_ne_zero).map + (algebraMap (RatFunc K) (SplitTraceBaseFunctionField K sigma)) + have hBaseVUnit : IsUnit (splitTraceBaseV sigma) := by + apply (isUnit_pow_iff (by norm_num : (2 : ℕ) ≠ 0)).mp + rw [splitTraceBaseV_sq] + exact (isUnit_iff_ne_zero.mpr (splitTraceRadicand_ne_zero sigma hsigma)).map + (algebraMap (RatFunc K) (SplitTraceBaseFunctionField K sigma)) + have hEtaUnit : + IsUnit (AdjoinRoot.root (splitTraceEtaKummerPolynomial sigma e)) := by + have he : e ≠ 0 := by + rintro rfl + simp at heOdd + apply (isUnit_pow_iff he).mp + rw [splitTraceEtaRoot_pow] + exact hBaseVUnit.map + (algebraMap (SplitTraceBaseFunctionField K sigma) + (SplitTraceEtaFunctionField K sigma e)) + have hEtaTopUnit : IsUnit (splitTraceEtaRootInXiField sigma e d) := + hEtaUnit.map (algebraMap (SplitTraceEtaFunctionField K sigma e) + (SplitTraceXiFunctionField K sigma e d)) + have hXiRadicandUnit : IsUnit (splitTraceXiRadicand sigma e) := + (hBaseUUnit.mul hBaseVUnit).map + (algebraMap (SplitTraceBaseFunctionField K sigma) + (SplitTraceEtaFunctionField K sigma e)) + have hXiUnit : IsUnit (splitTraceXiRoot sigma e d) := by + have hd : d ≠ 0 := by + rintro rfl + simp at hdOdd + apply (isUnit_pow_iff hd).mp + rw [splitTraceXiRoot_pow] + exact hXiRadicandUnit.map + (algebraMap (SplitTraceEtaFunctionField K sigma e) + (SplitTraceXiFunctionField K sigma e d)) + have himage : + splitTraceAffineToKummerTop sigma hsigma e d heOdd hdOdd hde + (splitTraceAffineCoordinateProduct sigma d e) = + splitTraceXiRoot sigma e d * splitTraceEtaRootInXiField sigma e d := by + change splitTraceAffineToKummerTop sigma hsigma e d heOdd hdOdd hde + (Ideal.Quotient.mk _ (MvPolynomial.X 0 * MvPolynomial.X 1)) = _ + simp only [map_mul] + rw [splitTraceAffineToKummerTop_coordinate, splitTraceAffineToKummerTop_coordinate] + simp + rw [himage] + exact hXiUnit.mul hEtaTopUnit + +/-- The affine comparison map extends uniquely across the localization inverting both trace-cover +coordinates. -/ +def splitTraceLaurentToKummerTop : + letI : Fact (Irreducible (splitTraceBaseKummerPolynomial sigma)) := + ⟨splitTraceBaseKummerPolynomial_irreducible sigma hsigma⟩ + letI : Fact (Irreducible (splitTraceEtaKummerPolynomial sigma e)) := + ⟨splitTraceEtaKummerPolynomial_irreducible' sigma hsigma e heOdd⟩ + letI : Fact (Irreducible (splitTraceXiKummerPolynomial sigma e d)) := + ⟨splitTraceXiKummerPolynomial_irreducible sigma hsigma e d heOdd hdOdd hde⟩ + SplitTraceLaurentCoordinateRing K sigma d e →ₐ[K] + SplitTraceXiFunctionField K sigma e d := by + let hBaseIrred := splitTraceBaseKummerPolynomial_irreducible sigma hsigma + letI : Fact (Irreducible (splitTraceBaseKummerPolynomial sigma)) := ⟨hBaseIrred⟩ + let hEtaIrred := splitTraceEtaKummerPolynomial_irreducible' sigma hsigma e heOdd + letI : Fact (Irreducible (splitTraceEtaKummerPolynomial sigma e)) := ⟨hEtaIrred⟩ + let hXiIrred := + splitTraceXiKummerPolynomial_irreducible sigma hsigma e d heOdd hdOdd hde + letI : Fact (Irreducible (splitTraceXiKummerPolynomial sigma e d)) := ⟨hXiIrred⟩ + apply IsLocalization.Away.liftAlgHom (splitTraceAffineCoordinateProduct sigma d e) + exact splitTraceAffineCoordinateProduct_maps_to_isUnit + sigma hsigma e d heOdd hdOdd hde + +theorem splitTraceLaurentToKummerTop_algebraMap_apply + (a : SplitTraceAffineCoordinateRing K sigma d e) : + letI : Fact (Irreducible (splitTraceBaseKummerPolynomial sigma)) := + ⟨splitTraceBaseKummerPolynomial_irreducible sigma hsigma⟩ + letI : Fact (Irreducible (splitTraceEtaKummerPolynomial sigma e)) := + ⟨splitTraceEtaKummerPolynomial_irreducible' sigma hsigma e heOdd⟩ + letI : Fact (Irreducible (splitTraceXiKummerPolynomial sigma e d)) := + ⟨splitTraceXiKummerPolynomial_irreducible sigma hsigma e d heOdd hdOdd hde⟩ + splitTraceLaurentToKummerTop sigma hsigma e d heOdd hdOdd hde + (algebraMap (SplitTraceAffineCoordinateRing K sigma d e) + (SplitTraceLaurentCoordinateRing K sigma d e) a) = + splitTraceAffineToKummerTop sigma hsigma e d heOdd hdOdd hde a := by + let hBaseIrred := splitTraceBaseKummerPolynomial_irreducible sigma hsigma + let : Fact (Irreducible (splitTraceBaseKummerPolynomial sigma)) := ⟨hBaseIrred⟩ + let hEtaIrred := splitTraceEtaKummerPolynomial_irreducible' sigma hsigma e heOdd + let : Fact (Irreducible (splitTraceEtaKummerPolynomial sigma e)) := ⟨hEtaIrred⟩ + let hXiIrred := + splitTraceXiKummerPolynomial_irreducible sigma hsigma e d heOdd hdOdd hde + let : Fact (Irreducible (splitTraceXiKummerPolynomial sigma e d)) := ⟨hXiIrred⟩ + simp only [splitTraceLaurentToKummerTop, IsLocalization.Away.liftAlgHom_apply] + apply IsLocalization.Away.lift_eq + +/-- Injectivity of the Laurent comparison map is reduced exactly to injectivity of the affine +quotient map. No domain hypothesis is manufactured here: proving the affine map injective is the +remaining kernel-equality/irreducibility wall. -/ +theorem splitTraceLaurentToKummerTop_injective_of_affine_injective + (hAffine : Function.Injective + (splitTraceAffineToKummerTop sigma hsigma e d heOdd hdOdd hde)) : + letI : Fact (Irreducible (splitTraceBaseKummerPolynomial sigma)) := + ⟨splitTraceBaseKummerPolynomial_irreducible sigma hsigma⟩ + letI : Fact (Irreducible (splitTraceEtaKummerPolynomial sigma e)) := + ⟨splitTraceEtaKummerPolynomial_irreducible' sigma hsigma e heOdd⟩ + letI : Fact (Irreducible (splitTraceXiKummerPolynomial sigma e d)) := + ⟨splitTraceXiKummerPolynomial_irreducible sigma hsigma e d heOdd hdOdd hde⟩ + Function.Injective + (splitTraceLaurentToKummerTop sigma hsigma e d heOdd hdOdd hde) := by + let hBaseIrred := splitTraceBaseKummerPolynomial_irreducible sigma hsigma + let : Fact (Irreducible (splitTraceBaseKummerPolynomial sigma)) := ⟨hBaseIrred⟩ + let hEtaIrred := splitTraceEtaKummerPolynomial_irreducible' sigma hsigma e heOdd + let : Fact (Irreducible (splitTraceEtaKummerPolynomial sigma e)) := ⟨hEtaIrred⟩ + let hXiIrred := + splitTraceXiKummerPolynomial_irreducible sigma hsigma e d heOdd hdOdd hde + let : Fact (Irreducible (splitTraceXiKummerPolynomial sigma e d)) := ⟨hXiIrred⟩ + apply (IsLocalization.injective_iff_map_algebraMap_eq + (Submonoid.powers (splitTraceAffineCoordinateProduct sigma d e)) + (splitTraceLaurentToKummerTop sigma hsigma e d heOdd hdOdd hde).toRingHom).2 + intro x y + change algebraMap (SplitTraceAffineCoordinateRing K sigma d e) + (SplitTraceLaurentCoordinateRing K sigma d e) x = + algebraMap (SplitTraceAffineCoordinateRing K sigma d e) + (SplitTraceLaurentCoordinateRing K sigma d e) y ↔ + splitTraceLaurentToKummerTop sigma hsigma e d heOdd hdOdd hde + (algebraMap (SplitTraceAffineCoordinateRing K sigma d e) + (SplitTraceLaurentCoordinateRing K sigma d e) x) = + splitTraceLaurentToKummerTop sigma hsigma e d heOdd hdOdd hde + (algebraMap (SplitTraceAffineCoordinateRing K sigma d e) + (SplitTraceLaurentCoordinateRing K sigma d e) y) + rw [splitTraceLaurentToKummerTop_algebraMap_apply, + splitTraceLaurentToKummerTop_algebraMap_apply] + constructor + · intro hxy + have hMapped := congrArg + (splitTraceLaurentToKummerTop sigma hsigma e d heOdd hdOdd hde) hxy + simpa only [splitTraceLaurentToKummerTop_algebraMap_apply] using hMapped + · intro hxy + exact congrArg + (algebraMap (SplitTraceAffineCoordinateRing K sigma d e) + (SplitTraceLaurentCoordinateRing K sigma d e)) (hAffine hxy) + +end OddCoprimeTower + +end + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/NormalForm.lean b/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/NormalForm.lean new file mode 100644 index 0000000000..2b9a376ecb --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/NormalForm.lean @@ -0,0 +1,160 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.Localization + +/-! +# Normal forms in the split trace-cover Kummer tower + +The full kernel calculation for the Laurent trace-cover map requires reducing arbitrary Laurent +polynomials to a bounded monomial normal form. This file proves the risky uniqueness half of that +calculation: the bounded `eta`--`xi` monomials are linearly independent over the quadratic base +function ring, so no nontrivial reduced normal form can vanish in the iterated Kummer algebra. + +This basis statement only uses that the two defining binomials are monic. Irreducibility, proved +in `TraceCurveKummer`, is needed later to regard the same rings as fields, but is not smuggled into +the normal-form interface. +-/ + +@[expose] public section + +namespace BGS.Markoff + +open Polynomial + +noncomputable section + +/-- Iterating two monic `AdjoinRoot` constructions gives a linearly independent rectangular +family of powers. This generic lemma keeps the typeclass structures fixed before the concrete +Kummer polynomials are substituted. -/ +theorem adjoinRootTower_normalMonomials_linearIndependent + {R : Type*} [CommRing R] (f : R[X]) (hf : f.Monic) + (g : Polynomial (AdjoinRoot f)) (hg : g.Monic) : + @LinearIndependent (Fin f.natDegree × Fin g.natDegree) R (AdjoinRoot g) + (fun ji : Fin f.natDegree × Fin g.natDegree ↦ + algebraMap (AdjoinRoot f) (AdjoinRoot g) + (AdjoinRoot.root f ^ (ji.1 : ℕ)) * + AdjoinRoot.root g ^ (ji.2 : ℕ)) + _ (AdjoinRoot.instCommRing g).toAddCommMonoid _ := by + have hFirst := (AdjoinRoot.powerBasis' hf).basis.linearIndependent + have hSecond := (AdjoinRoot.powerBasis' hg).basis.linearIndependent + have hProduct := linearIndependent_smul hFirst hSecond + change LinearIndependent R + (fun p : Fin f.natDegree × Fin g.natDegree ↦ + (AdjoinRoot.powerBasis' hf).basis p.1 • + (AdjoinRoot.powerBasis' hg).basis p.2) at hProduct + simpa [PowerBasis.basis_eq_pow, Algebra.smul_def] using hProduct + +variable {K : Type*} [Field K] + +lemma splitTraceEtaKummerPolynomial_monic + (sigma : K) (e : ℕ) (he : e ≠ 0) : + (splitTraceEtaKummerPolynomial sigma e).Monic := by + rw [splitTraceEtaKummerPolynomial] + exact monic_X_pow_sub_C _ he + +lemma splitTraceXiKummerPolynomial_monic + (sigma : K) (e d : ℕ) (hd : d ≠ 0) : + (splitTraceXiKummerPolynomial sigma e d).Monic := by + rw [splitTraceXiKummerPolynomial] + exact monic_X_pow_sub_C _ hd + +/-- A bounded `eta`--`xi` normal form has unique coefficients over the base function ring. +Equivalently, its linear-combination evaluation map into the Kummer top algebra is injective. -/ +theorem splitTraceEtaXiNormalMonomials_linearIndependent + (sigma : K) (e d : ℕ) (he : e ≠ 0) (hd : d ≠ 0) : + letI : CommRing (AdjoinRoot (splitTraceBaseKummerPolynomial sigma)) := + AdjoinRoot.instCommRing _ + letI : CommRing (AdjoinRoot (splitTraceEtaKummerPolynomial sigma e)) := + AdjoinRoot.instCommRing _ + letI : CommRing (AdjoinRoot (splitTraceXiKummerPolynomial sigma e d)) := + AdjoinRoot.instCommRing _ + LinearIndependent (AdjoinRoot (splitTraceBaseKummerPolynomial sigma)) + (fun ji : Fin (splitTraceEtaKummerPolynomial sigma e).natDegree × + Fin (splitTraceXiKummerPolynomial sigma e d).natDegree ↦ + splitTraceEtaRootInXiField sigma e d ^ (ji.1 : ℕ) * + splitTraceXiRoot sigma e d ^ (ji.2 : ℕ)) := by + let : CommRing (AdjoinRoot (splitTraceBaseKummerPolynomial sigma)) := + AdjoinRoot.instCommRing _ + let : CommRing (AdjoinRoot (splitTraceEtaKummerPolynomial sigma e)) := + AdjoinRoot.instCommRing _ + let : CommRing (AdjoinRoot (splitTraceXiKummerPolynomial sigma e d)) := + AdjoinRoot.instCommRing _ + simpa [splitTraceEtaRootInXiField, splitTraceXiRoot] using + adjoinRootTower_normalMonomials_linearIndependent + (splitTraceEtaKummerPolynomial sigma e) + (splitTraceEtaKummerPolynomial_monic sigma e he) + (splitTraceXiKummerPolynomial sigma e d) + (splitTraceXiKummerPolynomial_monic sigma e d hd) + +/-- In the odd-coprime situation used by the endgame, oddness supplies the required positive +exponents for the bounded normal-form theorem. -/ +theorem splitTraceEtaXiNormalMonomials_linearIndependent_of_oddCoprime + (sigma : K) (e d : ℕ) (heOdd : Odd e) (hdOdd : Odd d) (_hde : d.Coprime e) : + letI : CommRing (AdjoinRoot (splitTraceBaseKummerPolynomial sigma)) := + AdjoinRoot.instCommRing _ + letI : CommRing (AdjoinRoot (splitTraceEtaKummerPolynomial sigma e)) := + AdjoinRoot.instCommRing _ + letI : CommRing (AdjoinRoot (splitTraceXiKummerPolynomial sigma e d)) := + AdjoinRoot.instCommRing _ + LinearIndependent (AdjoinRoot (splitTraceBaseKummerPolynomial sigma)) + (fun ji : Fin (splitTraceEtaKummerPolynomial sigma e).natDegree × + Fin (splitTraceXiKummerPolynomial sigma e d).natDegree ↦ + splitTraceEtaRootInXiField sigma e d ^ (ji.1 : ℕ) * + splitTraceXiRoot sigma e d ^ (ji.2 : ℕ)) := by + let : CommRing (AdjoinRoot (splitTraceBaseKummerPolynomial sigma)) := + AdjoinRoot.instCommRing _ + let : CommRing (AdjoinRoot (splitTraceEtaKummerPolynomial sigma e)) := + AdjoinRoot.instCommRing _ + let : CommRing (AdjoinRoot (splitTraceXiKummerPolynomial sigma e d)) := + AdjoinRoot.instCommRing _ + have he : e ≠ 0 := by + rintro rfl + simp at heOdd + have hd : d ≠ 0 := by + rintro rfl + simp at hdOdd + exact splitTraceEtaXiNormalMonomials_linearIndependent sigma e d he hd + +/-- In the odd-coprime endgame range, a reduced rectangular normal form evaluates to zero in the +Kummer top algebra exactly when every coefficient is zero. This is the concrete kernel statement +available before the separate existence-of-normal-form reduction for Laurent polynomials. -/ +theorem splitTraceEtaXiNormalForm_evaluation_eq_zero_iff + (sigma : K) (e d : ℕ) (heOdd : Odd e) (hdOdd : Odd d) (hde : d.Coprime e) + (c : (Fin (splitTraceEtaKummerPolynomial sigma e).natDegree × + Fin (splitTraceXiKummerPolynomial sigma e d).natDegree) →₀ + AdjoinRoot (splitTraceBaseKummerPolynomial sigma)) : + letI : CommRing (AdjoinRoot (splitTraceBaseKummerPolynomial sigma)) := + AdjoinRoot.instCommRing _ + letI : CommRing (AdjoinRoot (splitTraceEtaKummerPolynomial sigma e)) := + AdjoinRoot.instCommRing _ + letI : CommRing (AdjoinRoot (splitTraceXiKummerPolynomial sigma e d)) := + AdjoinRoot.instCommRing _ + Finsupp.linearCombination (AdjoinRoot (splitTraceBaseKummerPolynomial sigma)) + (fun ji : Fin (splitTraceEtaKummerPolynomial sigma e).natDegree × + Fin (splitTraceXiKummerPolynomial sigma e d).natDegree ↦ + splitTraceEtaRootInXiField sigma e d ^ (ji.1 : ℕ) * + splitTraceXiRoot sigma e d ^ (ji.2 : ℕ)) c = 0 ↔ + c = 0 := by + let : CommRing (AdjoinRoot (splitTraceBaseKummerPolynomial sigma)) := + AdjoinRoot.instCommRing _ + let : CommRing (AdjoinRoot (splitTraceEtaKummerPolynomial sigma e)) := + AdjoinRoot.instCommRing _ + let : CommRing (AdjoinRoot (splitTraceXiKummerPolynomial sigma e d)) := + AdjoinRoot.instCommRing _ + constructor + · intro hc + apply splitTraceEtaXiNormalMonomials_linearIndependent_of_oddCoprime + sigma e d heOdd hdOdd hde + simpa using hc + · rintro rfl + simp + +end + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/OddCommonPrimeIndependence.lean b/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/OddCommonPrimeIndependence.lean new file mode 100644 index 0000000000..bb2142261f --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/OddCommonPrimeIndependence.lean @@ -0,0 +1,339 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.CommonKummerIndependence + +/-! +# Odd common-prime Kummer classes on the split trace curve + +This module proves the rational-function and quadratic-base obstructions needed when an odd prime +divides both covering exponents. Exact height-one-prime divisibility rules out nontrivial powers +of the residual ratio `(1 - sigma * X) / (1 - X)`, and a norm calculation upgrades this to +independence of the two degree-one trace-coordinate classes modulo an odd prime. + +Turning this base-field class calculation into irreducibility for noncoprime covers still requires +the roots-of-unity eigencharacter descent in the first Kummer extension. +-/ + +@[expose] public section + +namespace BGS.Markoff + +open Polynomial + +noncomputable section + +variable {K : Type*} [Field K] + +/-- No nontrivial power below a prime exponent of the residual trace ratio +can itself be a prime power in the rational-function field. This is the +height-one-prime obstruction at `sigma * X - 1`; the denominator prime +`1 - X` is distinct precisely when `sigma != 1`. -/ +theorem splitTraceResidualRatio_pow_ne_primePower + (sigma : K) (hsigma : sigma ≠ 0) (hnondegenerate : sigma ≠ 1) + (q a : ℕ) (_hq : q.Prime) (ha : 0 < a) (haq : a < q) + (z : RatFunc K) : + z ^ q ≠ + ((1 - RatFunc.C sigma * RatFunc.X) / (1 - RatFunc.X)) ^ a := by + intro hpow + let numeratorPrime : K[X] := normalizedSplitTraceEisensteinPrime sigma + let numerator : K[X] := 1 - C sigma * X + let denominator : K[X] := 1 - X + have hdenominator : denominator ≠ 0 := by + intro h + have hval := congrArg (Polynomial.eval (0 : K)) h + simp [denominator] at hval + have hdenominatorRat : + algebraMap K[X] (RatFunc K) denominator ≠ 0 := + (map_ne_zero_iff (algebraMap K[X] (RatFunc K)) + (RatFunc.algebraMap_injective K)).mpr hdenominator + have hzdenominatorRat : + algebraMap K[X] (RatFunc K) z.denom ≠ 0 := + (map_ne_zero_iff (algebraMap K[X] (RatFunc K)) + (RatFunc.algebraMap_injective K)).mpr z.denom_ne_zero + have hcrossRat : + algebraMap K[X] (RatFunc K) + (z.num ^ q * denominator ^ a) = + algebraMap K[X] (RatFunc K) + (numerator ^ a * z.denom ^ q) := by + have hpow' : + (algebraMap K[X] (RatFunc K) z.num / + algebraMap K[X] (RatFunc K) z.denom) ^ q = + (algebraMap K[X] (RatFunc K) numerator / + algebraMap K[X] (RatFunc K) denominator) ^ a := by + rw [RatFunc.num_div_denom] + simpa [numerator, denominator, RatFunc.algebraMap_C, + RatFunc.algebraMap_X] using hpow + rw [div_pow, div_pow] at hpow' + field_simp [hzdenominatorRat, hdenominatorRat] at hpow' + simpa only [map_mul, map_pow, mul_assoc, mul_left_comm, mul_comm] using hpow' + have hcross : + z.num ^ q * denominator ^ a = numerator ^ a * z.denom ^ q := + (RatFunc.algebraMap_injective K) hcrossRat + have hprimeIrreducible : Irreducible numeratorPrime := + normalizedSplitTraceEisensteinPrime_irreducible sigma hsigma + have hprime : Prime numeratorPrime := hprimeIrreducible.prime + have hprimeNotDvdDenominator : ¬ numeratorPrime ∣ denominator := by + intro h + apply normalizedSplitTraceEisensteinPrime_not_dvd_leading + sigma hsigma hnondegenerate + simpa [numeratorPrime, denominator, normalizedSplitTraceLeadingCoefficient] using + (dvd_mul_of_dvd_right h X) + have hnumeratorEq : numerator = -numeratorPrime := by + simp [numerator, numeratorPrime, normalizedSplitTraceEisensteinPrime] + have hprimeDvdNumeratorPow : numeratorPrime ∣ numerator ^ a := by + rw [hnumeratorEq, neg_pow] + exact dvd_mul_of_dvd_right (dvd_pow_self numeratorPrime ha.ne') ((-1 : K[X]) ^ a) + have hprimeDvdLeft : numeratorPrime ∣ z.num ^ q * denominator ^ a := by + rw [hcross] + exact dvd_mul_of_dvd_left hprimeDvdNumeratorPow _ + have hprimeNotDvdDenominatorPow : ¬ numeratorPrime ∣ denominator ^ a := by + exact fun h => hprimeNotDvdDenominator (hprime.dvd_of_dvd_pow h) + have hprimeDvdNumPow : numeratorPrime ∣ z.num ^ q := + (hprime.dvd_mul.mp hprimeDvdLeft).resolve_right hprimeNotDvdDenominatorPow + have hprimeDvdNum : numeratorPrime ∣ z.num := + hprime.dvd_of_dvd_pow hprimeDvdNumPow + have hprimeNotDvdDenom : ¬ numeratorPrime ∣ z.denom := by + intro hprimeDvdDenom + exact hprimeIrreducible.not_isUnit + (z.isCoprime_num_denom.isUnit_of_dvd' hprimeDvdNum hprimeDvdDenom) + obtain ⟨num', hnum⟩ := hprimeDvdNum + have haqLe : a ≤ q := Nat.le_of_lt haq + have hcancel : + numeratorPrime ^ (q - a) * (num' ^ q * denominator ^ a) = + (-1 : K[X]) ^ a * z.denom ^ q := by + apply mul_left_cancel₀ (pow_ne_zero a hprime.ne_zero) + calc + numeratorPrime ^ a * + (numeratorPrime ^ (q - a) * (num' ^ q * denominator ^ a)) = + (numeratorPrime * num') ^ q * denominator ^ a := by + calc + numeratorPrime ^ a * + (numeratorPrime ^ (q - a) * + (num' ^ q * denominator ^ a)) = + (numeratorPrime ^ a * numeratorPrime ^ (q - a)) * + (num' ^ q * denominator ^ a) := by ring + _ = numeratorPrime ^ (a + (q - a)) * + (num' ^ q * denominator ^ a) := by rw [pow_add] + _ = numeratorPrime ^ q * + (num' ^ q * denominator ^ a) := by rw [Nat.add_sub_of_le haqLe] + _ = (numeratorPrime * num') ^ q * denominator ^ a := by + rw [mul_pow] + ring + _ = z.num ^ q * denominator ^ a := by rw [← hnum] + _ = numerator ^ a * z.denom ^ q := hcross + _ = numeratorPrime ^ a * + ((-1 : K[X]) ^ a * z.denom ^ q) := by + rw [hnumeratorEq, neg_pow] + ring + have hsubPositive : 0 < q - a := Nat.sub_pos_of_lt haq + have hprimeDvdLeftAfterCancel : + numeratorPrime ∣ + numeratorPrime ^ (q - a) * (num' ^ q * denominator ^ a) := + dvd_mul_of_dvd_left (dvd_pow_self numeratorPrime hsubPositive.ne') _ + have hprimeDvdSignedDenomPow : + numeratorPrime ∣ (-1 : K[X]) ^ a * z.denom ^ q := by + rw [← hcancel] + exact hprimeDvdLeftAfterCancel + have hprimeNotDvdSign : ¬ numeratorPrime ∣ (-1 : K[X]) ^ a := by + intro h + exact hprimeIrreducible.not_isUnit + (isUnit_of_dvd_unit h (isUnit_neg_one.pow a)) + have hprimeDvdDenomPow : numeratorPrime ∣ z.denom ^ q := + (hprime.dvd_mul.mp hprimeDvdSignedDenomPow).resolve_left hprimeNotDvdSign + exact hprimeNotDvdDenom (hprime.dvd_of_dvd_pow hprimeDvdDenomPow) + +/-- The residual ratio is exactly `X * splitTraceRadicand sigma` in the +rational base of the trace curve. -/ +theorem RatFunc.X_mul_splitTraceRadicand_eq_residualRatio + (sigma : K) : + RatFunc.X * splitTraceRadicand sigma = + (1 - RatFunc.C sigma * RatFunc.X) / (1 - RatFunc.X) := by + have hX : (RatFunc.X : RatFunc K) ≠ 0 := RatFunc.X_ne_zero + have hOneSubX : (1 - RatFunc.X : RatFunc K) ≠ 0 := by + intro h + have honeX : (1 : RatFunc K) = RatFunc.X := sub_eq_zero.mp h + have hdegree := congrArg RatFunc.intDegree honeX + norm_num at hdegree + simp only [splitTraceRadicand, splitTraceRadicandNumerator, + splitTraceRadicandDenominator, map_sub, map_one, map_mul, + RatFunc.algebraMap_C, RatFunc.algebraMap_X] + field_simp [hX, hOneSubX] + +/-- Trace-radicand form of the odd-common-prime residual obstruction. -/ +theorem splitTrace_X_mul_radicand_pow_ne_primePower + (sigma : K) (hsigma : sigma ≠ 0) (hnondegenerate : sigma ≠ 1) + (q a : ℕ) (hq : q.Prime) (ha : 0 < a) (haq : a < q) + (z : RatFunc K) : + z ^ q ≠ (RatFunc.X * splitTraceRadicand sigma) ^ a := by + rw [RatFunc.X_mul_splitTraceRadicand_eq_residualRatio] + exact splitTraceResidualRatio_pow_ne_primePower + sigma hsigma hnondegenerate q a hq ha haq z + +/-- Divisibility form used after taking norms: the exponent of the residual +ratio need only be nonzero modulo `q`. -/ +theorem splitTrace_X_mul_radicand_pow_ne_primePower_of_not_dvd + (sigma : K) (hsigma : sigma ≠ 0) (hnondegenerate : sigma ≠ 1) + (q a : ℕ) (hq : q.Prime) (hqa : ¬ q ∣ a) + (z : RatFunc K) : + z ^ q ≠ (RatFunc.X * splitTraceRadicand sigma) ^ a := by + intro hpow + let residual : RatFunc K := RatFunc.X * splitTraceRadicand sigma + have hresidual : residual ≠ 0 := + mul_ne_zero RatFunc.X_ne_zero (splitTraceRadicand_ne_zero sigma hsigma) + have hremainderNe : a % q ≠ 0 := by + intro hzero + apply hqa + rw [Nat.dvd_iff_mod_eq_zero] + exact hzero + have hremainderPositive : 0 < a % q := Nat.pos_of_ne_zero hremainderNe + have hremainderLt : a % q < q := Nat.mod_lt _ hq.pos + let reducedRoot : RatFunc K := z / residual ^ (a / q) + apply splitTrace_X_mul_radicand_pow_ne_primePower + sigma hsigma hnondegenerate q (a % q) hq + hremainderPositive hremainderLt reducedRoot + have hdecomposition : a % q + q * (a / q) = a := Nat.mod_add_div a q + have hpowerDecomposition : + residual ^ a = + residual ^ (a % q) * (residual ^ (a / q)) ^ q := by + calc + residual ^ a = residual ^ (a % q + q * (a / q)) := by rw [hdecomposition] + _ = residual ^ (a % q) * residual ^ (q * (a / q)) := by rw [pow_add] + _ = residual ^ (a % q) * (residual ^ (a / q)) ^ q := by + rw [← pow_mul, Nat.mul_comm] + calc + reducedRoot ^ q = z ^ q / (residual ^ (a / q)) ^ q := by + simp [reducedRoot, div_pow] + _ = residual ^ a / (residual ^ (a / q)) ^ q := by + rw [hpow] + _ = residual ^ (a % q) := by + rw [hpowerDecomposition] + field_simp [hresidual] + _ = (RatFunc.X * splitTraceRadicand sigma) ^ (a % q) := by rfl + +/-- Odd-prime Kummer-class independence of the two degree-one trace +coordinates. The norm first forces the two character exponents to agree; +the remaining diagonal character is exactly the residual rational function +handled above. -/ +theorem splitTraceBaseCoordinates_mixedPower_ne_oddPrimePower + (sigma : K) (hsigma : sigma ≠ 0) (hnondegenerate : sigma ≠ 1) + (q a b : ℕ) (hq : q.Prime) (hqTwo : q ≠ 2) + (haq : a < q) (hbq : b < q) (hab : a ≠ 0 ∨ b ≠ 0) + (z : SplitTraceBaseFunctionField K sigma) : + letI : Fact (Irreducible (splitTraceBaseKummerPolynomial sigma)) := + ⟨splitTraceBaseKummerPolynomial_irreducible sigma hsigma⟩ + z ^ q ≠ + (splitTraceBaseU sigma * splitTraceBaseV sigma) ^ a * + splitTraceBaseV sigma ^ b := by + let hBaseIrred := splitTraceBaseKummerPolynomial_irreducible sigma hsigma + let : Fact (Irreducible (splitTraceBaseKummerPolynomial sigma)) := ⟨hBaseIrred⟩ + let baseField := SplitTraceBaseFunctionField K sigma + let U : baseField := splitTraceBaseU sigma + let V : baseField := splitTraceBaseV sigma + have hr : splitTraceRadicand sigma ≠ 0 := + splitTraceRadicand_ne_zero sigma hsigma + have hV : V ≠ 0 := by + change AdjoinRoot.root (splitTraceBaseKummerPolynomial sigma) ≠ 0 + exact (root_X_pow_sub_C_ne_zero_iff hBaseIrred).mpr hr + have hU : U ≠ 0 := by + exact (map_ne_zero_iff _ + (algebraMap (RatFunc K) baseField).injective).mpr RatFunc.X_ne_zero + have hUV : U * V ≠ 0 := mul_ne_zero hU hV + have hrightNonzero : (U * V) ^ a * V ^ b ≠ 0 := + mul_ne_zero (pow_ne_zero a hUV) (pow_ne_zero b hV) + intro hpow + have hz : z ≠ 0 := by + intro hz + apply hrightNonzero + simpa [hz, hq.ne_zero] using hpow.symm + let : Module.Finite (RatFunc K) baseField := + (monic_X_pow_sub_C _ (by norm_num : (2 : ℕ) ≠ 0)).finite_adjoinRoot + have hnorm := congrArg (Algebra.norm (RatFunc K)) hpow + rw [map_pow, map_mul, map_pow, map_pow] at hnorm + have hnormZNe : Algebra.norm (RatFunc K) z ≠ 0 := + Algebra.norm_ne_zero_iff.mpr hz + have hnormUVNe : Algebra.norm (RatFunc K) (U * V) ≠ 0 := + Algebra.norm_ne_zero_iff.mpr hUV + have hnormVNe : Algebra.norm (RatFunc K) V ≠ 0 := + Algebra.norm_ne_zero_iff.mpr hV + have hdegree := congrArg RatFunc.intDegree hnorm + rw [RatFunc.intDegree_pow _ hnormZNe, + RatFunc.intDegree_mul (pow_ne_zero a hnormUVNe) (pow_ne_zero b hnormVNe), + RatFunc.intDegree_pow _ hnormUVNe, + RatFunc.intDegree_pow _ hnormVNe, + norm_splitTraceBaseU_mul_V_intDegree sigma hsigma] at hdegree + have hnormV : Algebra.norm (RatFunc K) V = -splitTraceRadicand sigma := by + simpa [V, splitTraceBaseV] using norm_splitTraceBaseRoot sigma hsigma + have hnormVIntDegree : + (Algebra.norm (RatFunc K) V).intDegree = -1 := by + rw [hnormV, RatFunc.intDegree_neg, splitTraceRadicand_intDegree sigma hsigma] + rw [hnormVIntDegree] at hdegree + have hdiv : (q : ℤ) ∣ (a : ℤ) - (b : ℤ) := by + refine ⟨(Algebra.norm (RatFunc K) z).intDegree, ?_⟩ + simpa [sub_eq_add_neg, mul_add] using hdegree.symm + have habEq : a = b := by + rcases le_total b a with hba | hab + · have hdivNat : q ∣ a - b := by + rw [← Int.natCast_dvd_natCast] + simpa [Nat.cast_sub hba] using hdiv + have hzero : a - b = 0 := + Nat.eq_zero_of_dvd_of_lt hdivNat (lt_of_le_of_lt (Nat.sub_le a b) haq) + exact Nat.le_antisymm (Nat.sub_eq_zero_iff_le.mp hzero) hba + · have hdivNeg : (q : ℤ) ∣ (b : ℤ) - (a : ℤ) := by + simpa only [neg_sub] using (dvd_neg.mpr hdiv) + have hdivNat : q ∣ b - a := by + rw [← Int.natCast_dvd_natCast] + simpa [Nat.cast_sub hab] using hdivNeg + have hzero : b - a = 0 := + Nat.eq_zero_of_dvd_of_lt hdivNat (lt_of_le_of_lt (Nat.sub_le b a) hbq) + exact Nat.le_antisymm hab (Nat.sub_eq_zero_iff_le.mp hzero) + subst b + have haPositive : 0 < a := by + rcases hab with ha | ha <;> exact Nat.pos_of_ne_zero ha + have hqNotDvdA : ¬ q ∣ a := Nat.not_dvd_of_pos_of_lt haPositive haq + have hqNotDvdTwoA : ¬ q ∣ 2 * a := by + intro h + rcases hq.dvd_mul.mp h with hqDvdTwo | hqDvdA + · exact hqTwo ((Nat.dvd_prime Nat.prime_two).mp hqDvdTwo |>.resolve_left hq.ne_one) + · exact hqNotDvdA hqDvdA + let residual : RatFunc K := RatFunc.X * splitTraceRadicand sigma + have hrootSquare : V ^ 2 = algebraMap (RatFunc K) baseField + (splitTraceRadicand sigma) := by + change splitTraceBaseV sigma ^ 2 = + algebraMap (RatFunc K) (SplitTraceBaseFunctionField K sigma) + (splitTraceRadicand sigma) + apply sub_eq_zero.mp + have h := AdjoinRoot.eval₂_root (splitTraceBaseKummerPolynomial sigma) + rw [splitTraceBaseKummerPolynomial] at h + simp only [Polynomial.eval₂_sub, Polynomial.eval₂_pow, Polynomial.eval₂_X, + Polynomial.eval₂_C] at h + rw [← AdjoinRoot.algebraMap_eq] at h + exact h + have hcoordinateProduct : + (U * V) * V = algebraMap (RatFunc K) baseField residual := by + rw [mul_assoc, ← pow_two, hrootSquare] + simp [U, residual, baseField, splitTraceBaseU] + have hpowResidual : + z ^ q = algebraMap (RatFunc K) baseField (residual ^ a) := by + calc + z ^ q = (U * V) ^ a * V ^ a := hpow + _ = ((U * V) * V) ^ a := by + simpa [mul_assoc] using (mul_pow (U * V) V a).symm + _ = (algebraMap (RatFunc K) baseField residual) ^ a := by rw [hcoordinateProduct] + _ = algebraMap (RatFunc K) baseField (residual ^ a) := by rw [map_pow] + have hnormResidual := congrArg (Algebra.norm (RatFunc K)) hpowResidual + rw [map_pow, Algebra.norm_algebraMap, + splitTraceBaseFunctionField_finrank sigma hsigma] at hnormResidual + apply splitTrace_X_mul_radicand_pow_ne_primePower_of_not_dvd + sigma hsigma hnondegenerate q (2 * a) hq hqNotDvdTwoA + (Algebra.norm (RatFunc K) z) + simpa [residual, pow_mul, Nat.mul_comm] using hnormResidual + +end + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/OddCoprimeIrreducibility.lean b/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/OddCoprimeIrreducibility.lean new file mode 100644 index 0000000000..0da17ba181 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/OddCoprimeIrreducibility.lean @@ -0,0 +1,443 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.LaurentComparisonInjectivity + +/-! +# Irreducibility of the odd coprime split trace cover + +The key source-side argument is a residue decomposition. Every polynomial in `x,y` is written +uniquely as a sum of terms + +`x^r * y^s * q_{r,s}(x^d, y^e)`, with `r < d` and `s < e`. + +Evaluation in the Kummer tower sends the coefficient polynomial `q_{r,s}` to the degree-one +base trace curve at `(u*v,v)`. Irreducibility of that already-proved degree-one curve therefore +forces each `q_{r,s}` to be divisible by the base cover equation. Power substitution then shows +that the original polynomial is divisible by the `(d,e)` cover equation. This proves the +source-division theorem without assuming the target irreducibility or either comparison-map +injectivity statement. +-/ + +@[expose] public section + +namespace BGS.Markoff + +open Polynomial + +noncomputable section + +variable {K : Type*} [Field K] + +section ResidueBlocks + +variable (sigma : K) (hsigma : sigma ≠ 0) (e d : ℕ) + (heOdd : Odd e) (hdOdd : Odd d) + +/-- A two-variable exponent with the displayed exponents in coordinates `0,1`. -/ +def finTwoExponent (i j : ℕ) : Fin 2 →₀ ℕ := + Finsupp.single 0 i + Finsupp.single 1 j + +theorem monomial_finTwoExponent (i j : ℕ) (c : K) : + MvPolynomial.monomial (finTwoExponent i j) c = + MvPolynomial.C c * MvPolynomial.X 0 ^ i * MvPolynomial.X 1 ^ j := by + rw [finTwoExponent, MvPolynomial.monomial_add_single, + ← MvPolynomial.C_mul_X_pow_eq_monomial] + +theorem finTwoExponent_of_finsupp (ex : Fin 2 →₀ ℕ) : + finTwoExponent (ex 0) (ex 1) = ex := by + ext k + fin_cases k <;> simp [finTwoExponent] + +/-- Substitute `x^d,y^e` for the two variables. -/ +def splitTracePowerSubstitution : + MvPolynomial (Fin 2) K →ₐ[K] MvPolynomial (Fin 2) K := + MvPolynomial.aeval ![MvPolynomial.X 0 ^ d, MvPolynomial.X 1 ^ e] + +@[simp] +theorem splitTracePowerSubstitution_X_zero : + splitTracePowerSubstitution (K := K) e d (MvPolynomial.X 0) = + MvPolynomial.X 0 ^ d := by + simp [splitTracePowerSubstitution] + +@[simp] +theorem splitTracePowerSubstitution_X_one : + splitTracePowerSubstitution (K := K) e d (MvPolynomial.X 1) = + MvPolynomial.X 1 ^ e := by + simp [splitTracePowerSubstitution] + +@[simp] +theorem splitTracePowerSubstitution_C (c : K) : + splitTracePowerSubstitution (K := K) e d (MvPolynomial.C c) = + MvPolynomial.C c := by + simp [splitTracePowerSubstitution] + +/-- The polynomial coefficient in one residue block. A monomial `x^i y^j` contributes +`X^(i/d) Y^(j/e)` to block `(j mod e, i mod d)`. -/ +def splitTracePolynomialResidueBlocks (p : MvPolynomial (Fin 2) K) : + (Fin (splitTraceEtaKummerPolynomial sigma e).natDegree × + Fin (splitTraceXiKummerPolynomial sigma e d).natDegree) →₀ + MvPolynomial (Fin 2) K := + (AddMonoidAlgebra.coeff p).sum fun ex c ↦ + Finsupp.single + (splitTraceMonomialNormalIndex sigma hsigma e d heOdd hdOdd (ex 0) (ex 1)) + (MvPolynomial.monomial (finTwoExponent (ex 0 / d) (ex 1 / e)) c) + +@[simp] +theorem splitTracePolynomialResidueBlocks_zero : + splitTracePolynomialResidueBlocks sigma hsigma e d heOdd hdOdd 0 = 0 := by + simp [splitTracePolynomialResidueBlocks] + +theorem splitTracePolynomialResidueBlocks_add + (p q : MvPolynomial (Fin 2) K) : + splitTracePolynomialResidueBlocks sigma hsigma e d heOdd hdOdd (p + q) = + splitTracePolynomialResidueBlocks sigma hsigma e d heOdd hdOdd p + + splitTracePolynomialResidueBlocks sigma hsigma e d heOdd hdOdd q := by + classical + simp only [splitTracePolynomialResidueBlocks] + apply Finsupp.sum_add_index + · intro ex + simp + · intro ex _ a b + simp only [map_add, Finsupp.single_add] + +@[simp] +theorem splitTracePolynomialResidueBlocks_monomial + (ex : Fin 2 →₀ ℕ) (c : K) : + splitTracePolynomialResidueBlocks sigma hsigma e d heOdd hdOdd + (MvPolynomial.monomial ex c) = + Finsupp.single + (splitTraceMonomialNormalIndex sigma hsigma e d heOdd hdOdd (ex 0) (ex 1)) + (MvPolynomial.monomial (finTwoExponent (ex 0 / d) (ex 1 / e)) c) := by + rw [splitTracePolynomialResidueBlocks] + apply MvPolynomial.sum_monomial_eq + simp + +/-- Reassemble residue blocks after power substitution. -/ +def splitTraceRecomposeResidueBlocks + (q : (Fin (splitTraceEtaKummerPolynomial sigma e).natDegree × + Fin (splitTraceXiKummerPolynomial sigma e d).natDegree) →₀ + MvPolynomial (Fin 2) K) : MvPolynomial (Fin 2) K := + q.sum fun ji a ↦ + MvPolynomial.X 0 ^ (ji.2 : ℕ) * MvPolynomial.X 1 ^ (ji.1 : ℕ) * + splitTracePowerSubstitution (K := K) e d a + +theorem splitTracePowerSubstitution_monomial + (i j : ℕ) (c : K) : + splitTracePowerSubstitution (K := K) e d + (MvPolynomial.monomial (finTwoExponent i j) c) = + MvPolynomial.C c * MvPolynomial.X 0 ^ (d * i) * + MvPolynomial.X 1 ^ (e * j) := by + rw [monomial_finTwoExponent] + simp only [map_mul, map_pow, splitTracePowerSubstitution_C, + splitTracePowerSubstitution_X_zero, splitTracePowerSubstitution_X_one] + rw [pow_mul, pow_mul] + +theorem splitTraceRecomposeResidueBlocks_single_monomial + (i j : ℕ) (c : K) : + splitTraceRecomposeResidueBlocks sigma e d + (Finsupp.single + (splitTraceMonomialNormalIndex sigma hsigma e d heOdd hdOdd i j) + (MvPolynomial.monomial (finTwoExponent (i / d) (j / e)) c)) = + MvPolynomial.monomial (finTwoExponent i j) c := by + rw [splitTraceRecomposeResidueBlocks, Finsupp.sum_single_index] + · rw [splitTracePowerSubstitution_monomial] + simp only [splitTraceMonomialNormalIndex_fst_val, + splitTraceMonomialNormalIndex_snd_val] + rw [monomial_finTwoExponent] + have hi : i % d + d * (i / d) = i := Nat.mod_add_div i d + have hj : j % e + e * (j / e) = j := Nat.mod_add_div j e + calc + MvPolynomial.X (0 : Fin 2) ^ (i % d) * MvPolynomial.X 1 ^ (j % e) * + (MvPolynomial.C c * MvPolynomial.X (0 : Fin 2) ^ (d * (i / d)) * + MvPolynomial.X (1 : Fin 2) ^ (e * (j / e))) = + MvPolynomial.C c * + (MvPolynomial.X (0 : Fin 2) ^ (i % d) * + MvPolynomial.X (0 : Fin 2) ^ (d * (i / d))) * + (MvPolynomial.X (1 : Fin 2) ^ (j % e) * + MvPolynomial.X (1 : Fin 2) ^ (e * (j / e))) := by + ring + _ = MvPolynomial.C c * MvPolynomial.X (0 : Fin 2) ^ i * + MvPolynomial.X (1 : Fin 2) ^ j := by + rw [← pow_add, ← pow_add, hi, hj] + · simp + +theorem splitTraceRecomposeResidueBlocks_add + (q r : (Fin (splitTraceEtaKummerPolynomial sigma e).natDegree × + Fin (splitTraceXiKummerPolynomial sigma e d).natDegree) →₀ + MvPolynomial (Fin 2) K) : + splitTraceRecomposeResidueBlocks sigma e d (q + r) = + splitTraceRecomposeResidueBlocks sigma e d q + + splitTraceRecomposeResidueBlocks sigma e d r := by + classical + simp only [splitTraceRecomposeResidueBlocks] + apply Finsupp.sum_add_index + · intro ji + simp + · intro ji _ a b + simp [map_add, mul_add] + +/-- Exact reconstruction from the residue blocks. -/ +theorem splitTraceRecomposeResidueBlocks_polynomial + (p : MvPolynomial (Fin 2) K) : + splitTraceRecomposeResidueBlocks sigma e d + (splitTracePolynomialResidueBlocks sigma hsigma e d heOdd hdOdd p) = p := by + induction p using MvPolynomial.induction_on' with + | monomial ex c => + rw [splitTracePolynomialResidueBlocks_monomial, + splitTraceRecomposeResidueBlocks_single_monomial] + rw [finTwoExponent_of_finsupp] + | add p q hp hq => + rw [splitTracePolynomialResidueBlocks_add, + splitTraceRecomposeResidueBlocks_add, hp, hq] + +/-- Evaluate a residue-block polynomial on the degree-one base cover coordinates `(u*v,v)`. -/ +def splitTraceBaseResidueEvaluation : + MvPolynomial (Fin 2) K →ₐ[K] SplitTraceBaseFunctionField K sigma := + MvPolynomial.aeval + ![splitTraceBaseU sigma * splitTraceBaseV sigma, splitTraceBaseV sigma] + +theorem splitTraceBaseResidueEvaluation_monomial + (a b : ℕ) (c : K) : + splitTraceBaseResidueEvaluation sigma + (MvPolynomial.monomial (finTwoExponent a b) c) = + algebraMap K (SplitTraceBaseFunctionField K sigma) c * + splitTraceBaseU sigma ^ a * splitTraceBaseV sigma ^ (a + b) := by + rw [monomial_finTwoExponent] + simp only [map_mul, map_pow] + simp only [splitTraceBaseResidueEvaluation, MvPolynomial.aeval_C, + MvPolynomial.aeval_X, Matrix.cons_val_zero, Matrix.cons_val_one] + rw [mul_pow, pow_add] + ring + +/-- Each syntactic Kummer coefficient is exactly the degree-one base-curve evaluation of the +corresponding residue-block polynomial. -/ +theorem splitTraceBaseResidueEvaluation_residueBlock + (p : MvPolynomial (Fin 2) K) + (ji : Fin (splitTraceEtaKummerPolynomial sigma e).natDegree × + Fin (splitTraceXiKummerPolynomial sigma e d).natDegree) : + splitTraceBaseResidueEvaluation sigma + (splitTracePolynomialResidueBlocks sigma hsigma e d heOdd hdOdd p ji) = + splitTracePolynomialSyntacticNormalForm + sigma hsigma e d heOdd hdOdd p ji := by + induction p using MvPolynomial.induction_on' with + | monomial ex c => + rw [splitTracePolynomialResidueBlocks_monomial, + splitTracePolynomialSyntacticNormalForm_monomial] + by_cases hindex : + splitTraceMonomialNormalIndex sigma hsigma e d heOdd hdOdd (ex 0) (ex 1) = ji + · subst ji + simp only [Finsupp.single_eq_same] + rw [splitTraceBaseResidueEvaluation_monomial] + simp only [splitTraceMonomialNormalCoefficient, mul_assoc] + · simp [hindex] + | add p q hp hq => + rw [splitTracePolynomialResidueBlocks_add, + splitTracePolynomialSyntacticNormalForm_add] + simp only [Finsupp.add_apply, map_add, hp, hq] + +end ResidueBlocks + +section DegreeOneKernel + +variable (sigma : K) (hsigma : sigma ≠ 0) + +private lemma splitTraceEtaRootInXiField_one_one : + splitTraceEtaRootInXiField sigma 1 1 = + splitTraceBaseElementInXiField sigma 1 1 (splitTraceBaseV sigma) := by + simpa using (splitTraceEtaRootInXiField_pow (K := K) sigma 1 1) + +private lemma splitTraceXiRoot_one_one : + splitTraceXiRoot sigma 1 1 = + splitTraceBaseElementInXiField sigma 1 1 + (splitTraceBaseU sigma * splitTraceBaseV sigma) := by + have h := splitTraceXiRoot_pow (K := K) (sigma := sigma) (e := 1) (d := 1) + simpa [splitTraceXiRadicand, splitTraceBaseElementInXiField] using h + +/-- For the degree-one tower, evaluation at the two Kummer roots is just base-curve evaluation +at `(u*v,v)`, followed by the canonical inclusion of the base function field. -/ +theorem splitTracePolynomialToKummerTop_one_one_eq_baseResidueEvaluation + (q : MvPolynomial (Fin 2) K) : + splitTracePolynomialToKummerTop sigma hsigma 1 1 + (by decide) (by decide) (by decide) q = + IsScalarTower.toAlgHom K (SplitTraceBaseFunctionField K sigma) + (SplitTraceXiFunctionField K sigma 1 1) + (splitTraceBaseResidueEvaluation sigma q) := by + let hBaseIrred := splitTraceBaseKummerPolynomial_irreducible sigma hsigma + let : Fact (Irreducible (splitTraceBaseKummerPolynomial sigma)) := ⟨hBaseIrred⟩ + let hEtaIrred := splitTraceEtaKummerPolynomial_irreducible' sigma hsigma 1 (by decide) + let : Fact (Irreducible (splitTraceEtaKummerPolynomial sigma 1)) := ⟨hEtaIrred⟩ + let hXiIrred := + splitTraceXiKummerPolynomial_irreducible sigma hsigma 1 1 + (by decide) (by decide) (by decide) + let : Fact (Irreducible (splitTraceXiKummerPolynomial sigma 1 1)) := ⟨hXiIrred⟩ + let lhs : MvPolynomial (Fin 2) K →ₐ[K] + SplitTraceXiFunctionField K sigma 1 1 := + splitTracePolynomialToKummerTop sigma hsigma 1 1 + (by decide) (by decide) (by decide) + let rhs : MvPolynomial (Fin 2) K →ₐ[K] + SplitTraceXiFunctionField K sigma 1 1 := + (IsScalarTower.toAlgHom K (SplitTraceBaseFunctionField K sigma) + (SplitTraceXiFunctionField K sigma 1 1)).comp + (splitTraceBaseResidueEvaluation sigma) + have heq : lhs = rhs := by + apply MvPolynomial.algHom_ext + intro i + fin_cases i + · dsimp [lhs, rhs, splitTracePolynomialToKummerTop, + splitTraceBaseResidueEvaluation] + simp only [MvPolynomial.aeval_X, Matrix.cons_val_zero] + change splitTraceXiRoot sigma 1 1 = + algebraMap (SplitTraceBaseFunctionField K sigma) + (SplitTraceXiFunctionField K sigma 1 1) + (splitTraceBaseU sigma * splitTraceBaseV sigma) + simpa [lhs, rhs, splitTracePolynomialToKummerTop, + splitTraceBaseResidueEvaluation, splitTraceBaseElementInXiField, + IsScalarTower.algebraMap_apply + (SplitTraceBaseFunctionField K sigma) + (SplitTraceEtaFunctionField K sigma 1) + (SplitTraceXiFunctionField K sigma 1 1)] using + (splitTraceXiRoot_one_one (K := K) sigma) + · dsimp [lhs, rhs, splitTracePolynomialToKummerTop, + splitTraceBaseResidueEvaluation] + simp only [MvPolynomial.aeval_X, Matrix.cons_val_one] + change splitTraceEtaRootInXiField sigma 1 1 = + algebraMap (SplitTraceBaseFunctionField K sigma) + (SplitTraceXiFunctionField K sigma 1 1) (splitTraceBaseV sigma) + simpa [lhs, rhs, splitTracePolynomialToKummerTop, + splitTraceBaseResidueEvaluation, splitTraceBaseElementInXiField, + IsScalarTower.algebraMap_apply + (SplitTraceBaseFunctionField K sigma) + (SplitTraceEtaFunctionField K sigma 1) + (SplitTraceXiFunctionField K sigma 1 1)] using + (splitTraceEtaRootInXiField_one_one (K := K) sigma) + exact DFunLike.congr_fun heq q + +/-- The independently proved irreducibility of the degree-one trace curve gives the exact kernel +of base residue evaluation. -/ +theorem splitTraceBaseResiduePolynomial_mem_baseCover + (hsigma : sigma ≠ 0) (hnondegenerate : sigma ≠ 1) + (q : MvPolynomial (Fin 2) K) + (hq : splitTraceBaseResidueEvaluation sigma q = 0) : + q ∈ Ideal.span {splitTraceCoverPolynomial (1 : K) sigma 1 1} := by + have hcover : Irreducible (splitTraceCoverPolynomial (1 : K) sigma 1 1) := by + have hirred := weightedTraceTorusClosurePolynomial_irreducible + (1 : K) sigma one_ne_zero hsigma (by simpa using hnondegenerate) + simpa [weightedTraceTorusClosurePolynomial, hsigma] using hirred + apply splitTracePolynomial_mem_span_of_cover_irreducible_and_maps_to_zero + sigma hsigma 1 1 (by decide) (by decide) (by decide) hcover q + rw [splitTracePolynomialToKummerTop_one_one_eq_baseResidueEvaluation] + simp [hq] + +end DegreeOneKernel + +section SourceDivision + +variable (sigma : K) (hsigma : sigma ≠ 0) (e d : ℕ) + (heOdd : Odd e) (hdOdd : Odd d) (hde : d.Coprime e) + +/-- Power substitution carries the degree-one base equation to the exact `(d,e)` cover +equation. -/ +theorem splitTracePowerSubstitution_baseCover : + splitTracePowerSubstitution (K := K) e d + (splitTraceCoverPolynomial (1 : K) sigma 1 1) = + splitTraceCoverPolynomial (1 : K) sigma d e := by + simp only [splitTraceCoverPolynomial, map_add, map_sub, map_mul, map_pow, + splitTracePowerSubstitution_C, splitTracePowerSubstitution_X_zero, + splitTracePowerSubstitution_X_one] + simp only [pow_one, ← pow_mul] + rw [Nat.mul_comm e 2, Nat.mul_comm d 2] + +/-- Every residue-block term whose coefficient vanishes on the degree-one base curve is already +in the principal ideal of the full power-cover equation. -/ +theorem splitTraceResidueBlockTerm_mem_coverIdeal + (hsigma : sigma ≠ 0) (hnondegenerate : sigma ≠ 1) + (ji : Fin (splitTraceEtaKummerPolynomial sigma e).natDegree × + Fin (splitTraceXiKummerPolynomial sigma e d).natDegree) + (q : MvPolynomial (Fin 2) K) + (hq : splitTraceBaseResidueEvaluation sigma q = 0) : + MvPolynomial.X 0 ^ (ji.2 : ℕ) * MvPolynomial.X 1 ^ (ji.1 : ℕ) * + splitTracePowerSubstitution (K := K) e d q ∈ + Ideal.span {splitTraceCoverPolynomial (1 : K) sigma d e} := by + rw [Ideal.mem_span_singleton] + have hbase : splitTraceCoverPolynomial (1 : K) sigma 1 1 ∣ q := by + rw [← Ideal.mem_span_singleton] + exact splitTraceBaseResiduePolynomial_mem_baseCover + sigma hsigma hnondegenerate q hq + have hmapped := map_dvd (splitTracePowerSubstitution (K := K) e d) hbase + rw [splitTracePowerSubstitution_baseCover] at hmapped + exact dvd_mul_of_dvd_right hmapped + (MvPolynomial.X 0 ^ (ji.2 : ℕ) * MvPolynomial.X 1 ^ (ji.1 : ℕ)) + +/-- The missing source-division theorem for the nondegenerate odd-coprime cover. Its proof is +entirely bottom-up: residue decomposition, the independently proved degree-one kernel, and exact +power substitution. -/ +theorem splitTracePolynomialSyntacticNormalForm_division_of_oddCoprime + (hnondegenerate : sigma ≠ 1) (p : MvPolynomial (Fin 2) K) + (hnormal : splitTracePolynomialSyntacticNormalForm + sigma hsigma e d heOdd hdOdd p = 0) : + p ∈ Ideal.span {splitTraceCoverPolynomial (1 : K) sigma d e} := by + rw [← splitTraceRecomposeResidueBlocks_polynomial + sigma hsigma e d heOdd hdOdd p] + rw [splitTraceRecomposeResidueBlocks, Finsupp.sum] + apply Ideal.sum_mem + intro ji hji + apply splitTraceResidueBlockTerm_mem_coverIdeal + sigma e d hsigma hnondegenerate ji + rw [splitTraceBaseResidueEvaluation_residueBlock] + rw [hnormal] + rfl + +end SourceDivision + +section Irreducibility + +/-- The explicit Laurent comparison is injective in the nondegenerate +odd-coprime range; no irreducibility premise remains. -/ +theorem splitTraceLaurentToKummerTop_injective_of_oddCoprime + (sigma : K) (hsigma : sigma ≠ 0) (hnondegenerate : sigma ≠ 1) + (e d : ℕ) (heOdd : Odd e) (hdOdd : Odd d) (hde : d.Coprime e) : + Function.Injective + (splitTraceLaurentToKummerTop sigma hsigma e d heOdd hdOdd hde) := by + apply (splitTracePolynomialSyntacticNormalForm_division_iff_laurentInjective + sigma hsigma e d heOdd hdOdd hde hnondegenerate).1 + intro p hp + exact splitTracePolynomialSyntacticNormalForm_division_of_oddCoprime + sigma hsigma e d heOdd hdOdd hnondegenerate p hp + +/-- The affine comparison is injective in the same range because the +coordinate-product localization has already been proved faithful. -/ +theorem splitTraceAffineToKummerTop_injective_of_oddCoprime + (sigma : K) (hsigma : sigma ≠ 0) (hnondegenerate : sigma ≠ 1) + (e d : ℕ) (heOdd : Odd e) (hdOdd : Odd d) (hde : d.Coprime e) : + Function.Injective + (splitTraceAffineToKummerTop sigma hsigma e d heOdd hdOdd hde) := + splitTraceAffineToKummerTop_injective_of_laurentInjective + sigma hsigma e d heOdd hdOdd hde + (splitTraceLaurentToKummerTop_injective_of_oddCoprime + sigma hsigma hnondegenerate e d heOdd hdOdd hde) + +/-- The normalized split trace-cover polynomial is irreducible for nondegenerate odd coprime +exponents. No characteristic restriction is needed. -/ +theorem splitTraceCoverPolynomial_irreducible_of_oddCoprime + (sigma : K) (hsigma : sigma ≠ 0) (hnondegenerate : sigma ≠ 1) + (e d : ℕ) (heOdd : Odd e) (hdOdd : Odd d) (hde : d.Coprime e) : + Irreducible (splitTraceCoverPolynomial (1 : K) sigma d e) := by + have hLaurent : Function.Injective + (splitTraceLaurentToKummerTop sigma hsigma e d heOdd hdOdd hde) := + splitTraceLaurentToKummerTop_injective_of_oddCoprime + sigma hsigma hnondegenerate e d heOdd hdOdd hde + exact splitTraceCoverPolynomial_irreducible_of_laurentInjective + sigma hsigma e d heOdd hdOdd hde hLaurent + +end Irreducibility + +end + + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/PositiveCoprimeIrreducibility.lean b/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/PositiveCoprimeIrreducibility.lean new file mode 100644 index 0000000000..2ab1806a6f --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/PositiveCoprimeIrreducibility.lean @@ -0,0 +1,694 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.OddCoprimeIrreducibility + +/-! +# Irreducibility of positive coprime split trace covers + +This module removes the oddness restriction from the split-cover proof. A Capelli-style +binomial criterion constructs the Kummer tower for arbitrary positive coprime exponents over a +field containing a square root of `-1`. A parity-free residue decomposition then reconnects the +tower to the actual affine cover polynomial and proves its principal ideal prime. + +The coprimality restriction is still real in this proof: common prime divisors require a separate +Kummer-class independence argument and are not hidden here. +-/ + +@[expose] public section + +namespace BGS.Markoff + +open Polynomial AdjoinRoot IntermediateField + +noncomputable section + +variable {K : Type*} [Field K] + +lemma exists_primePowerRootOfNegOne + (i : K) (hi : i ^ 2 = -1) (q : ℕ) (hq : q.Prime) : + ∃ c : K, c ^ q = -1 := by + by_cases hqTwo : q = 2 + · exact ⟨i, by simpa [hqTwo] using hi⟩ + · refine ⟨-1, ?_⟩ + simpa using (hq.odd_of_ne_two hqTwo).neg_one_pow (α := K) + +/-- Over a field in which `-1` is a square, the usual prime-radicand criterion for +`X^n-a` is valid also for even `n`. -/ +theorem X_pow_sub_C_irreducible_of_sqrt_neg_one + (i : K) (hi : i ^ 2 = -1) {n : ℕ} (hn : n ≠ 0) {a : K} + (ha : ∀ q : ℕ, q.Prime → q ∣ n → ∀ b : K, b ^ q ≠ a) : + Irreducible (X ^ n - C a) := by + induction n using induction_on_primes generalizing K a with + | zero => exact (hn rfl).elim + | one => simpa using irreducible_X_sub_C a + | prime_mul p n hp IH => + have hn' : n ≠ 0 := by + intro hnZero + apply hn + simp [hnZero] + rw [mul_comm] + apply X_pow_mul_sub_C_irreducible + (X_pow_sub_C_irreducible_of_prime hp (ha p hp (dvd_mul_right _ _))) + intro E _ _ x hx + have hxIntegral : IsIntegral K x := not_not.mp fun h => by + simpa only [degree_zero, degree_X_pow_sub_C hp.pos, + WithBot.natCast_ne_bot] using congr_arg degree (hx.symm.trans (dite_eq_right h)) + let iE : ↥(IntermediateField.adjoin K {x}) := + algebraMap K (↥(IntermediateField.adjoin K {x})) i + have hiE : iE ^ 2 = -1 := by + dsimp [iE] + rw [← map_pow, hi, map_neg, map_one] + apply IH iE hiE hn' + intro q hq hqn b hb + by_cases hpTwo : p = 2 + · have hnormNeg : (Algebra.norm K b) ^ q = -a := by + rw [← map_pow, hb, ← adjoin.powerBasis_gen hxIntegral, + Algebra.PowerBasis.norm_gen_eq_coeff_zero_minpoly] + simp [minpoly_gen, hx, hpTwo] + obtain ⟨c, hc⟩ := exists_primePowerRootOfNegOne i hi q hq + apply ha q hq (dvd_mul_of_dvd_right hqn p) (c * Algebra.norm K b) + rw [mul_pow, hc, hnormNeg] + simp + · apply ha q hq (dvd_mul_of_dvd_right hqn p) (Algebra.norm K b) + rw [← map_pow, hb, ← adjoin.powerBasis_gen hxIntegral, + Algebra.PowerBasis.norm_gen_eq_coeff_zero_minpoly] + simp [minpoly_gen, hx, hp.ne_zero.symm, (hp.odd_of_ne_two hpTwo).neg_pow] + +/-- The first trace-curve Kummer polynomial is irreducible for every positive exponent once +the constant field contains a square root of `-1`. -/ +theorem splitTraceEtaKummerPolynomial_irreducible_of_sqrt_neg_one + (sigma : K) (hsigma : sigma ≠ 0) (i : K) (hi : i ^ 2 = -1) + (e : ℕ) (he : 0 < e) : + letI : Fact (Irreducible (splitTraceBaseKummerPolynomial sigma)) := + ⟨splitTraceBaseKummerPolynomial_irreducible sigma hsigma⟩ + Irreducible (splitTraceEtaKummerPolynomial sigma e) := by + let hBaseIrred := splitTraceBaseKummerPolynomial_irreducible sigma hsigma + let : Fact (Irreducible (splitTraceBaseKummerPolynomial sigma)) := ⟨hBaseIrred⟩ + apply X_pow_sub_C_irreducible_of_sqrt_neg_one + (algebraMap K (SplitTraceBaseFunctionField K sigma) i) + · rw [← map_pow, hi, map_neg, map_one] + · exact he.ne' + · intro q hq _ z + exact splitTraceBaseRoot_not_primePower sigma hsigma q hq z + +lemma splitTraceEtaFunctionField_finrank_of_sqrt_neg_one + (sigma : K) (hsigma : sigma ≠ 0) (i : K) (hi : i ^ 2 = -1) + (e : ℕ) (he : 0 < e) : + letI : Fact (Irreducible (splitTraceBaseKummerPolynomial sigma)) := + ⟨splitTraceBaseKummerPolynomial_irreducible sigma hsigma⟩ + letI : Fact (Irreducible (splitTraceEtaKummerPolynomial sigma e)) := + ⟨splitTraceEtaKummerPolynomial_irreducible_of_sqrt_neg_one + sigma hsigma i hi e he⟩ + Module.finrank (SplitTraceBaseFunctionField K sigma) + (SplitTraceEtaFunctionField K sigma e) = e := by + let hBaseIrred := splitTraceBaseKummerPolynomial_irreducible sigma hsigma + let : Fact (Irreducible (splitTraceBaseKummerPolynomial sigma)) := ⟨hBaseIrred⟩ + let hEtaIrred := splitTraceEtaKummerPolynomial_irreducible_of_sqrt_neg_one + sigma hsigma i hi e he + let : Fact (Irreducible (splitTraceEtaKummerPolynomial sigma e)) := ⟨hEtaIrred⟩ + rw [PowerBasis.finrank (AdjoinRoot.powerBasis hEtaIrred.ne_zero)] + change (splitTraceEtaKummerPolynomial sigma e).natDegree = e + simp [splitTraceEtaKummerPolynomial] + +/-- The norm-degree obstruction for the second radicand does not depend on parity. It applies +to every prime not dividing the first exponent. -/ +theorem splitTraceXiRadicand_not_primePower_of_sqrt_neg_one + (sigma : K) (hsigma : sigma ≠ 0) (i : K) (hi : i ^ 2 = -1) + (e : ℕ) (he : 0 < e) (q : ℕ) (hq : q.Prime) (hqe : ¬ q ∣ e) + (z : letI : Fact (Irreducible (splitTraceBaseKummerPolynomial sigma)) := + ⟨splitTraceBaseKummerPolynomial_irreducible sigma hsigma⟩ + letI : Fact (Irreducible (splitTraceEtaKummerPolynomial sigma e)) := + ⟨splitTraceEtaKummerPolynomial_irreducible_of_sqrt_neg_one + sigma hsigma i hi e he⟩ + SplitTraceEtaFunctionField K sigma e) : + letI : Fact (Irreducible (splitTraceBaseKummerPolynomial sigma)) := + ⟨splitTraceBaseKummerPolynomial_irreducible sigma hsigma⟩ + letI : Fact (Irreducible (splitTraceEtaKummerPolynomial sigma e)) := + ⟨splitTraceEtaKummerPolynomial_irreducible_of_sqrt_neg_one + sigma hsigma i hi e he⟩ + z ^ q ≠ splitTraceXiRadicand sigma e := by + let hBaseIrred := splitTraceBaseKummerPolynomial_irreducible sigma hsigma + let : Fact (Irreducible (splitTraceBaseKummerPolynomial sigma)) := ⟨hBaseIrred⟩ + let hEtaIrred := splitTraceEtaKummerPolynomial_irreducible_of_sqrt_neg_one + sigma hsigma i hi e he + let : Fact (Irreducible (splitTraceEtaKummerPolynomial sigma e)) := ⟨hEtaIrred⟩ + let : Module.Finite (RatFunc K) (SplitTraceBaseFunctionField K sigma) := + (monic_X_pow_sub_C _ (by norm_num : (2 : ℕ) ≠ 0)).finite_adjoinRoot + let : Module.Finite (SplitTraceBaseFunctionField K sigma) + (SplitTraceEtaFunctionField K sigma e) := + (monic_X_pow_sub_C _ he.ne').finite_adjoinRoot + have hBaseV : splitTraceBaseV sigma ≠ 0 := by + change AdjoinRoot.root (splitTraceBaseKummerPolynomial sigma) ≠ 0 + exact (root_X_pow_sub_C_ne_zero_iff hBaseIrred).mpr + (splitTraceRadicand_ne_zero sigma hsigma) + have hBaseU : splitTraceBaseU sigma ≠ 0 := by + exact (map_ne_zero_iff _ + (algebraMap (RatFunc K) (SplitTraceBaseFunctionField K sigma)).injective).mpr + RatFunc.X_ne_zero + have hBaseUV : splitTraceBaseU sigma * splitTraceBaseV sigma ≠ 0 := + mul_ne_zero hBaseU hBaseV + have hXiRadicand : splitTraceXiRadicand sigma e ≠ 0 := by + exact (map_ne_zero_iff _ + (algebraMap (SplitTraceBaseFunctionField K sigma) + (SplitTraceEtaFunctionField K sigma e)).injective).mpr hBaseUV + intro hpow + have hz : z ≠ 0 := by + intro hz + apply hXiRadicand + simpa [hz, hq.ne_zero] using hpow.symm + have hFirstNorm := congrArg + (Algebra.norm (SplitTraceBaseFunctionField K sigma)) hpow + rw [map_pow, splitTraceXiRadicand, Algebra.norm_algebraMap, + splitTraceEtaFunctionField_finrank_of_sqrt_neg_one sigma hsigma i hi e he] at hFirstNorm + have hSecondNorm := congrArg (Algebra.norm (RatFunc K)) hFirstNorm + rw [map_pow, map_pow] at hSecondNorm + have hNormZNe : + Algebra.norm (SplitTraceBaseFunctionField K sigma) z ≠ 0 := + Algebra.norm_ne_zero_iff.mpr hz + have hDoubleNormZNe : + Algebra.norm (RatFunc K) + (Algebra.norm (SplitTraceBaseFunctionField K sigma) z) ≠ 0 := + Algebra.norm_ne_zero_iff.mpr hNormZNe + have hNormBaseUVNe : + Algebra.norm (RatFunc K) (splitTraceBaseU sigma * splitTraceBaseV sigma) ≠ 0 := + Algebra.norm_ne_zero_iff.mpr hBaseUV + have hDegree := congrArg RatFunc.intDegree hSecondNorm + rw [RatFunc.intDegree_pow _ hDoubleNormZNe, + RatFunc.intDegree_pow _ hNormBaseUVNe, + norm_splitTraceBaseU_mul_V_intDegree sigma hsigma] at hDegree + apply hqe + rw [← Int.natCast_dvd_natCast] + exact ⟨_, by simpa using hDegree.symm⟩ + +/-- For arbitrary positive coprime exponents, including even exponents, the second Kummer +polynomial is irreducible once the constant field contains a square root of `-1`. -/ +theorem splitTraceXiKummerPolynomial_irreducible_of_sqrt_neg_one_coprime + (sigma : K) (hsigma : sigma ≠ 0) (i : K) (hi : i ^ 2 = -1) + (e d : ℕ) (he : 0 < e) (hd : 0 < d) (hde : d.Coprime e) : + letI : Fact (Irreducible (splitTraceBaseKummerPolynomial sigma)) := + ⟨splitTraceBaseKummerPolynomial_irreducible sigma hsigma⟩ + letI : Fact (Irreducible (splitTraceEtaKummerPolynomial sigma e)) := + ⟨splitTraceEtaKummerPolynomial_irreducible_of_sqrt_neg_one + sigma hsigma i hi e he⟩ + Irreducible (splitTraceXiKummerPolynomial sigma e d) := by + let hBaseIrred := splitTraceBaseKummerPolynomial_irreducible sigma hsigma + let : Fact (Irreducible (splitTraceBaseKummerPolynomial sigma)) := ⟨hBaseIrred⟩ + let hEtaIrred := splitTraceEtaKummerPolynomial_irreducible_of_sqrt_neg_one + sigma hsigma i hi e he + let : Fact (Irreducible (splitTraceEtaKummerPolynomial sigma e)) := ⟨hEtaIrred⟩ + rw [splitTraceXiKummerPolynomial] + apply X_pow_sub_C_irreducible_of_sqrt_neg_one + (algebraMap K (SplitTraceEtaFunctionField K sigma e) i) + · rw [← map_pow, hi, map_neg, map_one] + · exact hd.ne' + · intro q hq hqd z + exact splitTraceXiRadicand_not_primePower_of_sqrt_neg_one + sigma hsigma i hi e he q hq + (hq.coprime_iff_not_dvd.mp (Nat.Coprime.of_dvd_left hqd hde)) z + +section PositiveCoprimeCover + +variable (sigma : K) (hsigma : sigma ≠ 0) (i : K) (hi : i ^ 2 = -1) + (e d : ℕ) (he : 0 < e) (hd : 0 < d) (hde : d.Coprime e) + +private theorem generalSplitTraceEtaKummerPolynomial_natDegree + (sigma : K) (hsigma : sigma ≠ 0) (e : ℕ) : + letI : Fact (Irreducible (splitTraceBaseKummerPolynomial sigma)) := + ⟨splitTraceBaseKummerPolynomial_irreducible sigma hsigma⟩ + (splitTraceEtaKummerPolynomial sigma e).natDegree = e := by + let hBaseIrred := splitTraceBaseKummerPolynomial_irreducible sigma hsigma + let : Fact (Irreducible (splitTraceBaseKummerPolynomial sigma)) := ⟨hBaseIrred⟩ + change (X ^ e - C (splitTraceBaseV sigma)).natDegree = e + exact natDegree_X_pow_sub_C + +private theorem generalSplitTraceXiKummerPolynomial_natDegree + (sigma : K) (hsigma : sigma ≠ 0) (i : K) (hi : i ^ 2 = -1) + (e : ℕ) (he : 0 < e) (d : ℕ) : + letI : Fact (Irreducible (splitTraceBaseKummerPolynomial sigma)) := + ⟨splitTraceBaseKummerPolynomial_irreducible sigma hsigma⟩ + letI : Fact (Irreducible (splitTraceEtaKummerPolynomial sigma e)) := + ⟨splitTraceEtaKummerPolynomial_irreducible_of_sqrt_neg_one + sigma hsigma i hi e he⟩ + (splitTraceXiKummerPolynomial sigma e d).natDegree = d := by + let hBaseIrred := splitTraceBaseKummerPolynomial_irreducible sigma hsigma + let : Fact (Irreducible (splitTraceBaseKummerPolynomial sigma)) := ⟨hBaseIrred⟩ + let hEtaIrred := splitTraceEtaKummerPolynomial_irreducible_of_sqrt_neg_one + sigma hsigma i hi e he + let : Fact (Irreducible (splitTraceEtaKummerPolynomial sigma e)) := ⟨hEtaIrred⟩ + change (X ^ d - C (splitTraceXiRadicand sigma e)).natDegree = d + exact natDegree_X_pow_sub_C + +/-- Rectangular residue index for arbitrary positive coprime exponents. -/ +def generalSplitTraceMonomialNormalIndex + (sigma : K) (hsigma : sigma ≠ 0) (i : K) (hi : i ^ 2 = -1) + (e d : ℕ) (he : 0 < e) (hd : 0 < d) (a b : ℕ) : + Fin (splitTraceEtaKummerPolynomial sigma e).natDegree × + Fin (splitTraceXiKummerPolynomial sigma e d).natDegree := by + exact (⟨b % e, by + rw [generalSplitTraceEtaKummerPolynomial_natDegree sigma hsigma e] + exact Nat.mod_lt _ he⟩, + ⟨a % d, by + rw [generalSplitTraceXiKummerPolynomial_natDegree sigma hsigma i hi e he d] + exact Nat.mod_lt _ hd⟩) + +@[simp] theorem generalSplitTraceMonomialNormalIndex_fst_val (a b : ℕ) : + (generalSplitTraceMonomialNormalIndex sigma hsigma i hi e d he hd a b).1.val = b % e := rfl + +@[simp] theorem generalSplitTraceMonomialNormalIndex_snd_val (a b : ℕ) : + (generalSplitTraceMonomialNormalIndex sigma hsigma i hi e d he hd a b).2.val = a % d := rfl + +/-- Syntactic rectangular coefficients without parity assumptions. -/ +def generalSplitTracePolynomialSyntacticNormalForm + (sigma : K) (hsigma : sigma ≠ 0) (i : K) (hi : i ^ 2 = -1) + (e d : ℕ) (he : 0 < e) (hd : 0 < d) + (p : MvPolynomial (Fin 2) K) : + (Fin (splitTraceEtaKummerPolynomial sigma e).natDegree × + Fin (splitTraceXiKummerPolynomial sigma e d).natDegree) →₀ + SplitTraceBaseFunctionField K sigma := + (AddMonoidAlgebra.coeff p).sum fun ex c ↦ + Finsupp.single + (generalSplitTraceMonomialNormalIndex sigma hsigma i hi e d he hd (ex 0) (ex 1)) + (algebraMap K (SplitTraceBaseFunctionField K sigma) c * + splitTraceMonomialNormalCoefficient sigma e d (ex 0) (ex 1)) + +@[simp] theorem generalSplitTracePolynomialSyntacticNormalForm_zero : + generalSplitTracePolynomialSyntacticNormalForm + sigma hsigma i hi e d he hd 0 = 0 := by + simp [generalSplitTracePolynomialSyntacticNormalForm] + +theorem generalSplitTracePolynomialSyntacticNormalForm_add + (p q : MvPolynomial (Fin 2) K) : + generalSplitTracePolynomialSyntacticNormalForm sigma hsigma i hi e d he hd (p + q) = + generalSplitTracePolynomialSyntacticNormalForm sigma hsigma i hi e d he hd p + + generalSplitTracePolynomialSyntacticNormalForm sigma hsigma i hi e d he hd q := by + classical + simp only [generalSplitTracePolynomialSyntacticNormalForm] + apply Finsupp.sum_add_index + · intro ex + simp + · intro ex _ a b + simp only [map_add, add_mul, Finsupp.single_add] + +@[simp] theorem generalSplitTracePolynomialSyntacticNormalForm_monomial + (ex : Fin 2 →₀ ℕ) (c : K) : + generalSplitTracePolynomialSyntacticNormalForm sigma hsigma i hi e d he hd + (MvPolynomial.monomial ex c) = + Finsupp.single + (generalSplitTraceMonomialNormalIndex sigma hsigma i hi e d he hd (ex 0) (ex 1)) + (algebraMap K (SplitTraceBaseFunctionField K sigma) c * + splitTraceMonomialNormalCoefficient sigma e d (ex 0) (ex 1)) := by + rw [generalSplitTracePolynomialSyntacticNormalForm] + apply MvPolynomial.sum_monomial_eq + simp + +/-- Evaluation at the two roots in the general positive-coprime Kummer tower. -/ +def generalSplitTracePolynomialToKummerTop : + MvPolynomial (Fin 2) K →ₐ[K] SplitTraceXiFunctionField K sigma e d := + MvPolynomial.aeval + ![splitTraceXiRoot sigma e d, splitTraceEtaRootInXiField sigma e d] + +@[simp] theorem generalSplitTracePolynomialToKummerTop_monomial + (ex : Fin 2 →₀ ℕ) (c : K) : + generalSplitTracePolynomialToKummerTop sigma e d (MvPolynomial.monomial ex c) = + algebraMap K (SplitTraceXiFunctionField K sigma e d) c * + (splitTraceXiRoot sigma e d ^ (ex 0) * + splitTraceEtaRootInXiField sigma e d ^ (ex 1)) := by + simp [generalSplitTracePolynomialToKummerTop, MvPolynomial.aeval_def, + MvPolynomial.eval₂_monomial, Fin.prod_univ_two] + +theorem generalSplitTracePolynomialSyntacticNormalForm_evaluation + (p : MvPolynomial (Fin 2) K) : + splitTraceExplicitNormalFormEvaluation sigma e d + (generalSplitTracePolynomialSyntacticNormalForm + sigma hsigma i hi e d he hd p) = + generalSplitTracePolynomialToKummerTop sigma e d p := by + induction p using MvPolynomial.induction_on' with + | monomial ex c => + rw [generalSplitTracePolynomialSyntacticNormalForm_monomial, + splitTraceExplicitNormalFormEvaluation] + let : CommRing (SplitTraceBaseFunctionField K sigma) := AdjoinRoot.instCommRing _ + let : CommRing (SplitTraceEtaFunctionField K sigma e) := AdjoinRoot.instCommRing _ + let : CommRing (SplitTraceXiFunctionField K sigma e d) := AdjoinRoot.instCommRing _ + rw [Finsupp.linearCombination_single] + simp only [Algebra.smul_def, generalSplitTraceMonomialNormalIndex_fst_val, + generalSplitTraceMonomialNormalIndex_snd_val, map_mul] + have hred := (splitTraceKummer_monomial_reduction + (K := K) sigma e d (ex 0) (ex 1)).symm + rw [generalSplitTracePolynomialToKummerTop_monomial] + calc + (algebraMap (SplitTraceBaseFunctionField K sigma) + (SplitTraceXiFunctionField K sigma e d)) + ((algebraMap K (SplitTraceBaseFunctionField K sigma)) c) * + (algebraMap (SplitTraceBaseFunctionField K sigma) + (SplitTraceXiFunctionField K sigma e d)) + (splitTraceMonomialNormalCoefficient sigma e d (ex 0) (ex 1)) * + (splitTraceEtaRootInXiField sigma e d ^ (ex 1 % e) * + splitTraceXiRoot sigma e d ^ (ex 0 % d)) = + algebraMap K (SplitTraceXiFunctionField K sigma e d) c * + (splitTraceBaseElementInXiField sigma e d + (splitTraceMonomialNormalCoefficient sigma e d (ex 0) (ex 1)) * + (splitTraceEtaRootInXiField sigma e d ^ (ex 1 % e) * + splitTraceXiRoot sigma e d ^ (ex 0 % d))) := by + simp only [splitTraceBaseElementInXiField] + simp_rw [IsScalarTower.algebraMap_apply K + (SplitTraceBaseFunctionField K sigma) + (SplitTraceXiFunctionField K sigma e d)] + simp_rw [IsScalarTower.algebraMap_apply + (SplitTraceBaseFunctionField K sigma) + (SplitTraceEtaFunctionField K sigma e) + (SplitTraceXiFunctionField K sigma e d)] + ring + _ = algebraMap K (SplitTraceXiFunctionField K sigma e d) c * + (splitTraceXiRoot sigma e d ^ ex 0 * + splitTraceEtaRootInXiField sigma e d ^ ex 1) := by rw [hred] + | add p q hp hq => + rw [generalSplitTracePolynomialSyntacticNormalForm_add] + change Finsupp.linearCombination (SplitTraceBaseFunctionField K sigma) + (fun ji ↦ splitTraceEtaRootInXiField sigma e d ^ (ji.1 : ℕ) * + splitTraceXiRoot sigma e d ^ (ji.2 : ℕ)) + (generalSplitTracePolynomialSyntacticNormalForm sigma hsigma i hi e d he hd p + + generalSplitTracePolynomialSyntacticNormalForm sigma hsigma i hi e d he hd q) = _ + change Finsupp.linearCombination (SplitTraceBaseFunctionField K sigma) + (fun ji ↦ splitTraceEtaRootInXiField sigma e d ^ (ji.1 : ℕ) * + splitTraceXiRoot sigma e d ^ (ji.2 : ℕ)) + (generalSplitTracePolynomialSyntacticNormalForm + sigma hsigma i hi e d he hd p) = _ at hp + change Finsupp.linearCombination (SplitTraceBaseFunctionField K sigma) + (fun ji ↦ splitTraceEtaRootInXiField sigma e d ^ (ji.1 : ℕ) * + splitTraceXiRoot sigma e d ^ (ji.2 : ℕ)) + (generalSplitTracePolynomialSyntacticNormalForm + sigma hsigma i hi e d he hd q) = _ at hq + rw [map_add, hp, hq, map_add] + +theorem generalSplitTracePolynomialSyntacticNormalForm_eq_zero_iff + (p : MvPolynomial (Fin 2) K) : + generalSplitTracePolynomialSyntacticNormalForm sigma hsigma i hi e d he hd p = 0 ↔ + generalSplitTracePolynomialToKummerTop sigma e d p = 0 := by + rw [← generalSplitTracePolynomialSyntacticNormalForm_evaluation + sigma hsigma i hi e d he hd p] + let : CommRing (SplitTraceBaseFunctionField K sigma) := AdjoinRoot.instCommRing _ + let : CommRing (SplitTraceEtaFunctionField K sigma e) := AdjoinRoot.instCommRing _ + let : CommRing (SplitTraceXiFunctionField K sigma e d) := AdjoinRoot.instCommRing _ + change generalSplitTracePolynomialSyntacticNormalForm + sigma hsigma i hi e d he hd p = 0 ↔ + Finsupp.linearCombination (SplitTraceBaseFunctionField K sigma) + (fun ji ↦ splitTraceEtaRootInXiField sigma e d ^ (ji.1 : ℕ) * + splitTraceXiRoot sigma e d ^ (ji.2 : ℕ)) + (generalSplitTracePolynomialSyntacticNormalForm + sigma hsigma i hi e d he hd p) = 0 + constructor + · intro h + rw [h] + simp + · intro h + apply splitTraceEtaXiNormalMonomials_linearIndependent sigma e d he.ne' hd.ne' + simpa using h + +/-- Residue-block coefficient polynomials for arbitrary positive exponents. -/ +def generalSplitTracePolynomialResidueBlocks + (p : MvPolynomial (Fin 2) K) : + (Fin (splitTraceEtaKummerPolynomial sigma e).natDegree × + Fin (splitTraceXiKummerPolynomial sigma e d).natDegree) →₀ + MvPolynomial (Fin 2) K := + (AddMonoidAlgebra.coeff p).sum fun ex c ↦ + Finsupp.single + (generalSplitTraceMonomialNormalIndex sigma hsigma i hi e d he hd (ex 0) (ex 1)) + (MvPolynomial.monomial (finTwoExponent (ex 0 / d) (ex 1 / e)) c) + +@[simp] theorem generalSplitTracePolynomialResidueBlocks_zero : + generalSplitTracePolynomialResidueBlocks + sigma hsigma i hi e d he hd 0 = 0 := by + simp [generalSplitTracePolynomialResidueBlocks] + +theorem generalSplitTracePolynomialResidueBlocks_add + (p q : MvPolynomial (Fin 2) K) : + generalSplitTracePolynomialResidueBlocks sigma hsigma i hi e d he hd (p + q) = + generalSplitTracePolynomialResidueBlocks sigma hsigma i hi e d he hd p + + generalSplitTracePolynomialResidueBlocks sigma hsigma i hi e d he hd q := by + classical + simp only [generalSplitTracePolynomialResidueBlocks] + apply Finsupp.sum_add_index + · intro ex + simp + · intro ex _ a b + simp only [map_add, Finsupp.single_add] + +@[simp] theorem generalSplitTracePolynomialResidueBlocks_monomial + (ex : Fin 2 →₀ ℕ) (c : K) : + generalSplitTracePolynomialResidueBlocks sigma hsigma i hi e d he hd + (MvPolynomial.monomial ex c) = + Finsupp.single + (generalSplitTraceMonomialNormalIndex sigma hsigma i hi e d he hd (ex 0) (ex 1)) + (MvPolynomial.monomial (finTwoExponent (ex 0 / d) (ex 1 / e)) c) := by + rw [generalSplitTracePolynomialResidueBlocks] + apply MvPolynomial.sum_monomial_eq + simp + +theorem splitTraceRecomposeGeneralResidueBlocks_single_monomial + (a b : ℕ) (c : K) : + splitTraceRecomposeResidueBlocks sigma e d + (Finsupp.single + (generalSplitTraceMonomialNormalIndex sigma hsigma i hi e d he hd a b) + (MvPolynomial.monomial (finTwoExponent (a / d) (b / e)) c)) = + MvPolynomial.monomial (finTwoExponent a b) c := by + rw [splitTraceRecomposeResidueBlocks, Finsupp.sum_single_index] + · rw [splitTracePowerSubstitution_monomial] + simp only [generalSplitTraceMonomialNormalIndex_fst_val, + generalSplitTraceMonomialNormalIndex_snd_val] + rw [monomial_finTwoExponent] + have ha : a % d + d * (a / d) = a := Nat.mod_add_div a d + have hb : b % e + e * (b / e) = b := Nat.mod_add_div b e + calc + MvPolynomial.X (0 : Fin 2) ^ (a % d) * MvPolynomial.X 1 ^ (b % e) * + (MvPolynomial.C c * MvPolynomial.X (0 : Fin 2) ^ (d * (a / d)) * + MvPolynomial.X (1 : Fin 2) ^ (e * (b / e))) = + MvPolynomial.C c * + (MvPolynomial.X (0 : Fin 2) ^ (a % d) * + MvPolynomial.X (0 : Fin 2) ^ (d * (a / d))) * + (MvPolynomial.X (1 : Fin 2) ^ (b % e) * + MvPolynomial.X (1 : Fin 2) ^ (e * (b / e))) := by ring + _ = MvPolynomial.C c * MvPolynomial.X (0 : Fin 2) ^ a * + MvPolynomial.X (1 : Fin 2) ^ b := by + rw [← pow_add, ← pow_add, ha, hb] + · simp + +/-- Exact reconstruction from the general residue blocks. -/ +theorem splitTraceRecomposeGeneralResidueBlocks_polynomial + (p : MvPolynomial (Fin 2) K) : + splitTraceRecomposeResidueBlocks sigma e d + (generalSplitTracePolynomialResidueBlocks + sigma hsigma i hi e d he hd p) = p := by + induction p using MvPolynomial.induction_on' with + | monomial ex c => + rw [generalSplitTracePolynomialResidueBlocks_monomial, + splitTraceRecomposeGeneralResidueBlocks_single_monomial] + rw [finTwoExponent_of_finsupp] + | add p q hp hq => + rw [generalSplitTracePolynomialResidueBlocks_add, + splitTraceRecomposeResidueBlocks_add, hp, hq] + +/-- Each general syntactic coefficient is the base-curve evaluation of its residue block. -/ +theorem splitTraceBaseResidueEvaluation_generalResidueBlock + (p : MvPolynomial (Fin 2) K) + (ji : Fin (splitTraceEtaKummerPolynomial sigma e).natDegree × + Fin (splitTraceXiKummerPolynomial sigma e d).natDegree) : + splitTraceBaseResidueEvaluation sigma + (generalSplitTracePolynomialResidueBlocks + sigma hsigma i hi e d he hd p ji) = + generalSplitTracePolynomialSyntacticNormalForm + sigma hsigma i hi e d he hd p ji := by + induction p using MvPolynomial.induction_on' with + | monomial ex c => + rw [generalSplitTracePolynomialResidueBlocks_monomial, + generalSplitTracePolynomialSyntacticNormalForm_monomial] + by_cases hindex : + generalSplitTraceMonomialNormalIndex sigma hsigma i hi e d he hd + (ex 0) (ex 1) = ji + · subst ji + simp only [Finsupp.single_eq_same] + rw [splitTraceBaseResidueEvaluation_monomial] + simp only [splitTraceMonomialNormalCoefficient, mul_assoc] + · simp [hindex] + | add p q hp hq => + rw [generalSplitTracePolynomialResidueBlocks_add, + generalSplitTracePolynomialSyntacticNormalForm_add] + simp only [Finsupp.add_apply, map_add, hp, hq] + +/-- Source division for every positive coprime cover once the even Kummer criterion applies. -/ +theorem generalSplitTracePolynomialSyntacticNormalForm_division + (hnondegenerate : sigma ≠ 1) (p : MvPolynomial (Fin 2) K) + (hnormal : generalSplitTracePolynomialSyntacticNormalForm + sigma hsigma i hi e d he hd p = 0) : + p ∈ Ideal.span {splitTraceCoverPolynomial (1 : K) sigma d e} := by + rw [← splitTraceRecomposeGeneralResidueBlocks_polynomial + sigma hsigma i hi e d he hd p] + rw [splitTraceRecomposeResidueBlocks, Finsupp.sum] + apply Ideal.sum_mem + intro ji hji + apply splitTraceResidueBlockTerm_mem_coverIdeal + sigma e d hsigma hnondegenerate ji + rw [splitTraceBaseResidueEvaluation_generalResidueBlock] + rw [hnormal] + rfl + +/-- The roots of the positive-coprime tower satisfy the cleared affine cover equation. -/ +theorem generalSplitTraceKummerTower_cover_maps_to_zero : + letI : Fact (Irreducible (splitTraceBaseKummerPolynomial sigma)) := + ⟨splitTraceBaseKummerPolynomial_irreducible sigma hsigma⟩ + letI : Fact (Irreducible (splitTraceEtaKummerPolynomial sigma e)) := + ⟨splitTraceEtaKummerPolynomial_irreducible_of_sqrt_neg_one + sigma hsigma i hi e he⟩ + letI : Fact (Irreducible (splitTraceXiKummerPolynomial sigma e d)) := + ⟨splitTraceXiKummerPolynomial_irreducible_of_sqrt_neg_one_coprime + sigma hsigma i hi e d he hd hde⟩ + generalSplitTracePolynomialToKummerTop sigma e d + (splitTraceCoverPolynomial (1 : K) sigma d e) = 0 := by + let hBaseIrred := splitTraceBaseKummerPolynomial_irreducible sigma hsigma + let : Fact (Irreducible (splitTraceBaseKummerPolynomial sigma)) := ⟨hBaseIrred⟩ + let hEtaIrred := splitTraceEtaKummerPolynomial_irreducible_of_sqrt_neg_one + sigma hsigma i hi e he + let : Fact (Irreducible (splitTraceEtaKummerPolynomial sigma e)) := ⟨hEtaIrred⟩ + let hXiIrred := splitTraceXiKummerPolynomial_irreducible_of_sqrt_neg_one_coprime + sigma hsigma i hi e d he hd hde + let : Fact (Irreducible (splitTraceXiKummerPolynomial sigma e d)) := ⟨hXiIrred⟩ + let baseToXi : SplitTraceBaseFunctionField K sigma →+* + SplitTraceXiFunctionField K sigma e d := + (algebraMap (SplitTraceEtaFunctionField K sigma e) + (SplitTraceXiFunctionField K sigma e d)).comp + (algebraMap (SplitTraceBaseFunctionField K sigma) + (SplitTraceEtaFunctionField K sigma e)) + have hBase := splitTraceBaseU_V_equation sigma hsigma + have hBaseTop := congrArg baseToXi hBase + simp only [map_add, map_sub, map_mul, map_pow, map_one, map_zero] at hBaseTop + have hEtaRoot : + (AdjoinRoot.root (splitTraceEtaKummerPolynomial sigma e)) ^ e = + algebraMap (SplitTraceBaseFunctionField K sigma) + (SplitTraceEtaFunctionField K sigma e) (splitTraceBaseV sigma) := by + apply sub_eq_zero.mp + have h := AdjoinRoot.eval₂_root (splitTraceEtaKummerPolynomial sigma e) + rw [splitTraceEtaKummerPolynomial] at h + simp only [Polynomial.eval₂_sub, Polynomial.eval₂_pow, Polynomial.eval₂_X, + Polynomial.eval₂_C] at h + rw [← AdjoinRoot.algebraMap_eq] at h + exact h + have hEtaTop := congrArg + (algebraMap (SplitTraceEtaFunctionField K sigma e) + (SplitTraceXiFunctionField K sigma e d)) hEtaRoot + simp only [map_pow] at hEtaTop + have hXiRoot : + splitTraceXiRoot sigma e d ^ d = + algebraMap (SplitTraceEtaFunctionField K sigma e) + (SplitTraceXiFunctionField K sigma e d) (splitTraceXiRadicand sigma e) := by + apply sub_eq_zero.mp + have h := AdjoinRoot.eval₂_root (splitTraceXiKummerPolynomial sigma e d) + rw [splitTraceXiKummerPolynomial] at h + simp only [Polynomial.eval₂_sub, Polynomial.eval₂_pow, Polynomial.eval₂_X, + Polynomial.eval₂_C] at h + rw [← AdjoinRoot.algebraMap_eq] at h + exact h + have hCover := eval_splitTraceCoverPolynomial_of_powerRootRelations + (splitTraceBaseElementInXiField sigma e d + (algebraMap (RatFunc K) (SplitTraceBaseFunctionField K sigma) (RatFunc.C sigma))) + (splitTraceBaseElementInXiField sigma e d (splitTraceBaseU sigma)) + (splitTraceBaseElementInXiField sigma e d (splitTraceBaseV sigma)) + (splitTraceXiRoot sigma e d) (splitTraceEtaRootInXiField sigma e d) d e + (by simpa [baseToXi, splitTraceBaseElementInXiField] using hBaseTop) + (by simpa [splitTraceEtaRootInXiField, splitTraceBaseElementInXiField, baseToXi] + using hEtaTop) + (by simpa [splitTraceXiRadicand, splitTraceBaseElementInXiField, baseToXi, + splitTraceXiRoot] using hXiRoot) + have hsigmaTop : + splitTraceBaseElementInXiField sigma e d + (algebraMap (RatFunc K) (SplitTraceBaseFunctionField K sigma) (RatFunc.C sigma)) = + algebraMap K (SplitTraceXiFunctionField K sigma e d) sigma := by + change algebraMap (SplitTraceEtaFunctionField K sigma e) + (SplitTraceXiFunctionField K sigma e d) + (algebraMap (SplitTraceBaseFunctionField K sigma) + (SplitTraceEtaFunctionField K sigma e) + (algebraMap (RatFunc K) (SplitTraceBaseFunctionField K sigma) + (algebraMap K (RatFunc K) sigma))) = _ + rw [← IsScalarTower.algebraMap_apply K (RatFunc K) + (SplitTraceBaseFunctionField K sigma)] + rw [← IsScalarTower.algebraMap_apply K + (SplitTraceBaseFunctionField K sigma) (SplitTraceEtaFunctionField K sigma e)] + rw [← IsScalarTower.algebraMap_apply K + (SplitTraceEtaFunctionField K sigma e) (SplitTraceXiFunctionField K sigma e d)] + rw [hsigmaTop] at hCover + simpa [generalSplitTracePolynomialToKummerTop, MvPolynomial.aeval_def, + splitTraceCoverPolynomial] using hCover + +private lemma generalSplitTraceCoverPolynomial_ne_zero + (sigma : K) (d : ℕ) (hd : 0 < d) : + splitTraceCoverPolynomial (1 : K) sigma d e ≠ 0 := by + intro hzero + have heval := congrArg + (MvPolynomial.eval ![(0 : K), (1 : K)]) hzero + rw [eval_splitTraceCoverPolynomial] at heval + norm_num [hd.ne'] at heval + +/-- The normalized split trace-cover polynomial is irreducible for all positive coprime +exponents, including even exponents, over a field containing a square root of `-1`. -/ +theorem splitTraceCoverPolynomial_irreducible_of_sqrt_neg_one_coprime + (sigma : K) (hsigma : sigma ≠ 0) (i : K) (hi : i ^ 2 = -1) + (e d : ℕ) (he : 0 < e) (hd : 0 < d) (hde : d.Coprime e) + (hnondegenerate : sigma ≠ 1) : + Irreducible (splitTraceCoverPolynomial (1 : K) sigma d e) := by + let hBaseIrred := splitTraceBaseKummerPolynomial_irreducible sigma hsigma + let : Fact (Irreducible (splitTraceBaseKummerPolynomial sigma)) := ⟨hBaseIrred⟩ + let hEtaIrred := splitTraceEtaKummerPolynomial_irreducible_of_sqrt_neg_one + sigma hsigma i hi e he + let : Fact (Irreducible (splitTraceEtaKummerPolynomial sigma e)) := ⟨hEtaIrred⟩ + let hXiIrred := splitTraceXiKummerPolynomial_irreducible_of_sqrt_neg_one_coprime + sigma hsigma i hi e d he hd hde + let : Fact (Irreducible (splitTraceXiKummerPolynomial sigma e d)) := ⟨hXiIrred⟩ + let : IsDomain (SplitTraceXiFunctionField K sigma e d) := + AdjoinRoot.isDomain_of_prime hXiIrred.prime + let f : MvPolynomial (Fin 2) K →+* SplitTraceXiFunctionField K sigma e d := + (generalSplitTracePolynomialToKummerTop sigma e d).toRingHom + let I : Ideal (MvPolynomial (Fin 2) K) := + Ideal.span {splitTraceCoverPolynomial (1 : K) sigma d e} + have hCoverZero : + generalSplitTracePolynomialToKummerTop sigma e d + (splitTraceCoverPolynomial (1 : K) sigma d e) = 0 := + generalSplitTraceKummerTower_cover_maps_to_zero + sigma hsigma i hi e d he hd hde + have hI_le : I ≤ RingHom.ker f := by + change Ideal.span {splitTraceCoverPolynomial (1 : K) sigma d e} ≤ RingHom.ker f + rw [Ideal.span_le] + intro p hp + simp only [Set.mem_singleton_iff] at hp + subst p + exact hCoverZero + have hker_le : RingHom.ker f ≤ I := by + intro p hp + apply generalSplitTracePolynomialSyntacticNormalForm_division + sigma hsigma i hi e d he hd hnondegenerate p + apply (generalSplitTracePolynomialSyntacticNormalForm_eq_zero_iff + sigma hsigma i hi e d he hd p).2 + exact hp + let quotientToTop : MvPolynomial (Fin 2) K ⧸ I →+* + SplitTraceXiFunctionField K sigma e d := + Ideal.Quotient.lift I f hI_le + have hInjective : Function.Injective quotientToTop := + RingHom.lift_injective_of_ker_le_ideal I hI_le hker_le + let : IsDomain (MvPolynomial (Fin 2) K ⧸ I) := + hInjective.isDomain quotientToTop + have hprimeIdeal : I.IsPrime := + (Ideal.Quotient.isDomain_iff_prime I).mp inferInstance + have hprimeElement : Prime (splitTraceCoverPolynomial (1 : K) sigma d e) := + (Ideal.span_singleton_prime + (generalSplitTraceCoverPolynomial_ne_zero e sigma d hd)).1 (by + simpa [I] using hprimeIdeal) + exact irreducible_iff_prime.mpr hprimeElement + +end PositiveCoprimeCover + +end + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/ProjectiveChart.lean b/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/ProjectiveChart.lean new file mode 100644 index 0000000000..1c97da1084 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/ProjectiveChart.lean @@ -0,0 +1,38 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +/-! +# Standard charts of the biprojective trace curve +-/ + +@[expose] public section + +namespace BGS.Markoff + +/-- The four standard affine charts of the biprojective trace curve. -/ +inductive WeightedSplitTraceProjectiveChart where + /-- The original affine chart. -/ + | affine + /-- The chart obtained by inverting the first projective coordinate. -/ + | invertFirst + /-- The chart obtained by inverting the second projective coordinate. -/ + | invertSecond + /-- The chart obtained by inverting both projective coordinates. -/ + | invertBoth + deriving DecidableEq + +/-- Backwards-compatible name used by earlier Blueprint snapshots. -/ +abbrev WeightedSplitTraceNormalizationChart := WeightedSplitTraceProjectiveChart + +universe u + +/-- Universe-lifted chart index used by Mathlib's gluing category. -/ +abbrev WeightedSplitTraceProjectiveChartIndex := + ULift.{u} WeightedSplitTraceProjectiveChart + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/ProjectiveNormalizationCharts.lean b/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/ProjectiveNormalizationCharts.lean new file mode 100644 index 0000000000..abab98c1f3 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/ProjectiveNormalizationCharts.lean @@ -0,0 +1,267 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.AlgebraicGeometry.ConstantOpenGlueData +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.LaurentNormalization +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.ProjectiveChart +public import Mathlib.AlgebraicGeometry.OpenImmersion + +/-! +# Affine normalization charts and their overlap immersions + +This module packages the integral-closure rings from the trace-cover endgame as explicit affine +schemes. Their common torus overlaps are literal principal-open localizations, with open immersion +maps into the affine normalization charts. The previously proved normalization transitions are +then conjugated onto these concrete overlap schemes. + +The four-chart `Scheme.GlueData` is deliberately not asserted here: Mathlib requires explicit maps +on pullbacks of triple overlaps. The objects, open immersions, transition isomorphisms, and their +ring-level cocycle constructed below are the inputs for that remaining categorical assembly. +-/ + +@[expose] public section + +namespace BGS.Markoff + +open AlgebraicGeometry + +noncomputable section + +universe u + +variable {K : Type u} [Field K] + +/-- Explicit affine `Spec` model of the normalization of one trace-cover chart. -/ +def weightedSplitTraceAffineNormalizationSpec (alpha beta : K) (d e : ℕ) : Scheme := + Spec (CommRingCat.of (WeightedSplitTraceAffineNormalizationRing alpha beta d e)) + +/-- Principal-open ring in the affine normalization obtained by inverting the original coordinate +product. -/ +abbrev WeightedSplitTraceAffineNormalizationLaurentOpenRing + (alpha beta : K) (d e : ℕ) := + Localization.Away + (algebraMap (WeightedSplitTraceAffineCoordinateRing alpha beta d e) + (WeightedSplitTraceAffineNormalizationRing alpha beta d e) + (weightedSplitTraceAffineCoordinateProduct alpha beta d e)) + +/-- The common torus overlap as an explicit affine scheme. -/ +def weightedSplitTraceAffineNormalizationLaurentOpenSpec + (alpha beta : K) (d e : ℕ) : Scheme := + Spec (CommRingCat.of + (WeightedSplitTraceAffineNormalizationLaurentOpenRing alpha beta d e)) + +/-- The principal-open immersion of the normalized torus overlap into an affine normalization +chart. -/ +def weightedSplitTraceAffineNormalizationLaurentOpenImmersion + (alpha beta : K) (d e : ℕ) : + weightedSplitTraceAffineNormalizationLaurentOpenSpec alpha beta d e ⟶ + weightedSplitTraceAffineNormalizationSpec alpha beta d e := + Spec.map (CommRingCat.ofHom + (algebraMap (WeightedSplitTraceAffineNormalizationRing alpha beta d e) + (WeightedSplitTraceAffineNormalizationLaurentOpenRing alpha beta d e))) + +instance weightedSplitTraceAffineNormalizationLaurentOpenImmersion_isOpen + (alpha beta : K) (d e : ℕ) : + IsOpenImmersion + (weightedSplitTraceAffineNormalizationLaurentOpenImmersion alpha beta d e) := by + dsimp only [weightedSplitTraceAffineNormalizationLaurentOpenImmersion, + weightedSplitTraceAffineNormalizationLaurentOpenSpec, + weightedSplitTraceAffineNormalizationSpec, + WeightedSplitTraceAffineNormalizationLaurentOpenRing] + infer_instance + +/-- First-coordinate inversion on the concrete principal-open normalization chart. -/ +def weightedSplitTraceLeftAffineNormalizationOpenEquiv_of_irreducible + (alpha beta : K) (d e : ℕ) (hd : 0 < d) (he : 0 < e) + (hbeta : beta ≠ 0) + (h : Irreducible (splitTraceCoverPolynomial alpha beta d e)) : + WeightedSplitTraceAffineNormalizationLaurentOpenRing alpha beta d e ≃+* + WeightedSplitTraceAffineNormalizationLaurentOpenRing alpha beta d e := by + letI : IsDomain (WeightedSplitTraceLaurentCoordinateRing alpha beta d e) := + weightedSplitTraceLaurentCoordinateRing_isDomain alpha beta d e hd he hbeta h + exact conjugatedLeftNormalizationOpenEquiv alpha beta d e + (weightedSplitTraceAffineNormalizationLaurentOpenEquiv_of_irreducible + alpha beta d e hd he hbeta h) + +/-- Second-coordinate inversion between the two concrete principal-open normalization charts. -/ +def weightedSplitTraceRightAffineNormalizationOpenEquiv_of_irreducible + (alpha beta : K) (d e : ℕ) (hd : 0 < d) (he : 0 < e) + (halpha : alpha ≠ 0) (hbeta : beta ≠ 0) + (h : Irreducible (splitTraceCoverPolynomial alpha beta d e)) + (hswap : Irreducible (splitTraceCoverPolynomial beta alpha d e)) : + WeightedSplitTraceAffineNormalizationLaurentOpenRing beta alpha d e ≃+* + WeightedSplitTraceAffineNormalizationLaurentOpenRing alpha beta d e := by + letI : IsDomain (WeightedSplitTraceLaurentCoordinateRing alpha beta d e) := + weightedSplitTraceLaurentCoordinateRing_isDomain alpha beta d e hd he hbeta h + letI : IsDomain (WeightedSplitTraceLaurentCoordinateRing beta alpha d e) := + weightedSplitTraceLaurentCoordinateRing_isDomain beta alpha d e hd he halpha hswap + exact conjugatedRightNormalizationOpenEquiv alpha beta d e + (weightedSplitTraceAffineNormalizationLaurentOpenEquiv_of_irreducible + alpha beta d e hd he hbeta h) + (weightedSplitTraceAffineNormalizationLaurentOpenEquiv_of_irreducible + beta alpha d e hd he halpha hswap) + +/-- Scheme automorphism of the concrete overlap induced by first-coordinate inversion. -/ +def weightedSplitTraceLeftAffineNormalizationOpenSchemeIso_of_irreducible + (alpha beta : K) (d e : ℕ) (hd : 0 < d) (he : 0 < e) + (hbeta : beta ≠ 0) + (h : Irreducible (splitTraceCoverPolynomial alpha beta d e)) : + weightedSplitTraceAffineNormalizationLaurentOpenSpec alpha beta d e ≅ + weightedSplitTraceAffineNormalizationLaurentOpenSpec alpha beta d e := + BGS.specIsoOfRingEquiv + (weightedSplitTraceLeftAffineNormalizationOpenEquiv_of_irreducible + alpha beta d e hd he hbeta h) + +/-- Contravariant scheme isomorphism of concrete overlaps induced by second-coordinate inversion. -/ +def weightedSplitTraceRightAffineNormalizationOpenSchemeIso_of_irreducible + (alpha beta : K) (d e : ℕ) (hd : 0 < d) (he : 0 < e) + (halpha : alpha ≠ 0) (hbeta : beta ≠ 0) + (h : Irreducible (splitTraceCoverPolynomial alpha beta d e)) + (hswap : Irreducible (splitTraceCoverPolynomial beta alpha d e)) : + weightedSplitTraceAffineNormalizationLaurentOpenSpec alpha beta d e ≅ + weightedSplitTraceAffineNormalizationLaurentOpenSpec beta alpha d e := + BGS.specIsoOfRingEquiv + (weightedSplitTraceRightAffineNormalizationOpenEquiv_of_irreducible + alpha beta d e hd he halpha hbeta h hswap) + +/-- The affine normalization scheme used by each of the four standard charts. Inverting the +second coordinate swaps the two weights. -/ +def weightedSplitTraceNormalizationChartScheme + (alpha beta : K) (d e : ℕ) : WeightedSplitTraceProjectiveChart → Scheme + | .affine | .invertFirst => weightedSplitTraceAffineNormalizationSpec alpha beta d e + | .invertSecond | .invertBoth => weightedSplitTraceAffineNormalizationSpec beta alpha d e + +/-- The common torus open inside each standard normalization chart. -/ +def weightedSplitTraceNormalizationChartOpen + (alpha beta : K) (d e : ℕ) : WeightedSplitTraceProjectiveChart → Scheme + | .affine | .invertFirst => weightedSplitTraceAffineNormalizationLaurentOpenSpec alpha beta d e + | .invertSecond | .invertBoth => + weightedSplitTraceAffineNormalizationLaurentOpenSpec beta alpha d e + +/-- Principal-open immersion from each chart's torus overlap into that affine normalization +chart. -/ +def weightedSplitTraceNormalizationChartOpenImmersion + (alpha beta : K) (d e : ℕ) (i : WeightedSplitTraceProjectiveChart) : + weightedSplitTraceNormalizationChartOpen alpha beta d e i ⟶ + weightedSplitTraceNormalizationChartScheme alpha beta d e i := by + cases i with + | affine | invertFirst => + exact weightedSplitTraceAffineNormalizationLaurentOpenImmersion alpha beta d e + | invertSecond | invertBoth => + exact weightedSplitTraceAffineNormalizationLaurentOpenImmersion beta alpha d e + +instance weightedSplitTraceNormalizationChartOpenImmersion_isOpen + (alpha beta : K) (d e : ℕ) (i : WeightedSplitTraceProjectiveChart) : + IsOpenImmersion + (weightedSplitTraceNormalizationChartOpenImmersion alpha beta d e i) := by + cases i with + | affine | invertFirst => + exact weightedSplitTraceAffineNormalizationLaurentOpenImmersion_isOpen alpha beta d e + | invertSecond | invertBoth => + exact weightedSplitTraceAffineNormalizationLaurentOpenImmersion_isOpen beta alpha d e + +/-- Every chart overlap, expressed in its own coordinates, identified with the normalized Laurent +scheme in the original `(alpha, beta)` coordinates. The four cases encode no inversion, first +inversion, second inversion, and both inversions respectively. -/ +def weightedSplitTraceNormalizationChartOpenIsoCommon + (alpha beta : K) (d e : ℕ) (hd : 0 < d) (he : 0 < e) + (halpha : alpha ≠ 0) (hbeta : beta ≠ 0) + (h : Irreducible (splitTraceCoverPolynomial alpha beta d e)) + (hswap : Irreducible (splitTraceCoverPolynomial beta alpha d e)) + (i : WeightedSplitTraceProjectiveChart) : + weightedSplitTraceNormalizationChartOpen alpha beta d e i ≅ + Spec (CommRingCat.of (WeightedSplitTraceLaurentNormalizationRing alpha beta d e)) := by + letI : IsDomain (WeightedSplitTraceLaurentCoordinateRing alpha beta d e) := + weightedSplitTraceLaurentCoordinateRing_isDomain alpha beta d e hd he hbeta h + letI : IsDomain (WeightedSplitTraceLaurentCoordinateRing beta alpha d e) := + weightedSplitTraceLaurentCoordinateRing_isDomain beta alpha d e hd he halpha hswap + let openA := weightedSplitTraceAffineNormalizationLaurentOpenSchemeIso_of_irreducible + alpha beta d e hd he hbeta h + let openB := weightedSplitTraceAffineNormalizationLaurentOpenSchemeIso_of_irreducible + beta alpha d e hd he halpha hswap + let left := weightedSplitTraceLeftInversionLaurentNormalizationSchemeIso alpha beta d e + let right := weightedSplitTraceRightInversionLaurentNormalizationSchemeIso alpha beta d e + cases i with + | affine => exact openA.symm + | invertFirst => exact openA.symm.trans left + | invertSecond => exact openB.symm.trans right.symm + | invertBoth => exact (openB.symm.trans right.symm).trans left + +/-- The actual four-chart gluing datum for the normalized trace-cover charts. The pullback-level +triple-overlap maps are supplied by `constantOpenGlueDataOfCommonTarget`; they are not assumed. -/ +def weightedSplitTraceProjectiveNormalizationGlueData + (alpha beta : K) (d e : ℕ) (hd : 0 < d) (he : 0 < e) + (halpha : alpha ≠ 0) (hbeta : beta ≠ 0) + (h : Irreducible (splitTraceCoverPolynomial alpha beta d e)) + (hswap : Irreducible (splitTraceCoverPolynomial beta alpha d e)) : + Scheme.GlueData := + BGS.constantOpenGlueDataOfCommonTarget + (fun i : WeightedSplitTraceProjectiveChartIndex ↦ + weightedSplitTraceNormalizationChartScheme alpha beta d e i.down) + (fun i : WeightedSplitTraceProjectiveChartIndex ↦ + weightedSplitTraceNormalizationChartOpen alpha beta d e i.down) + (fun i : WeightedSplitTraceProjectiveChartIndex ↦ + weightedSplitTraceNormalizationChartOpenImmersion alpha beta d e i.down) + (Spec (CommRingCat.of (WeightedSplitTraceLaurentNormalizationRing alpha beta d e))) + (fun i : WeightedSplitTraceProjectiveChartIndex ↦ + weightedSplitTraceNormalizationChartOpenIsoCommon + alpha beta d e hd he halpha hbeta h hswap i.down) + +/-- The four affine normalization charts glued along their normalized torus opens. -/ +def weightedSplitTraceProjectiveNormalization + (alpha beta : K) (d e : ℕ) (hd : 0 < d) (he : 0 < e) + (halpha : alpha ≠ 0) (hbeta : beta ≠ 0) + (h : Irreducible (splitTraceCoverPolynomial alpha beta d e)) + (hswap : Irreducible (splitTraceCoverPolynomial beta alpha d e)) : Scheme := + (weightedSplitTraceProjectiveNormalizationGlueData + alpha beta d e hd he halpha hbeta h hswap).glued + +/-- Open immersion of a standard affine normalization chart into the glued normalization. -/ +def weightedSplitTraceNormalizationChartMap + (alpha beta : K) (d e : ℕ) (hd : 0 < d) (he : 0 < e) + (halpha : alpha ≠ 0) (hbeta : beta ≠ 0) + (h : Irreducible (splitTraceCoverPolynomial alpha beta d e)) + (hswap : Irreducible (splitTraceCoverPolynomial beta alpha d e)) + (i : WeightedSplitTraceProjectiveChartIndex) : + weightedSplitTraceNormalizationChartScheme alpha beta d e i.down ⟶ + weightedSplitTraceProjectiveNormalization + alpha beta d e hd he halpha hbeta h hswap := + (weightedSplitTraceProjectiveNormalizationGlueData + alpha beta d e hd he halpha hbeta h hswap).ι i + +instance weightedSplitTraceNormalizationChartMap_isOpen + (alpha beta : K) (d e : ℕ) (hd : 0 < d) (he : 0 < e) + (halpha : alpha ≠ 0) (hbeta : beta ≠ 0) + (h : Irreducible (splitTraceCoverPolynomial alpha beta d e)) + (hswap : Irreducible (splitTraceCoverPolynomial beta alpha d e)) + (i : WeightedSplitTraceProjectiveChartIndex) : + IsOpenImmersion (weightedSplitTraceNormalizationChartMap + alpha beta d e hd he halpha hbeta h hswap i) := by + dsimp only [weightedSplitTraceNormalizationChartMap] + exact Scheme.GlueData.ι_isOpenImmersion + (weightedSplitTraceProjectiveNormalizationGlueData + alpha beta d e hd he halpha hbeta h hswap) i + +/-- The four standard affine normalization charts cover the glued normalization. -/ +theorem weightedSplitTraceNormalizationChartMap_jointly_surjective + (alpha beta : K) (d e : ℕ) (hd : 0 < d) (he : 0 < e) + (halpha : alpha ≠ 0) (hbeta : beta ≠ 0) + (h : Irreducible (splitTraceCoverPolynomial alpha beta d e)) + (hswap : Irreducible (splitTraceCoverPolynomial beta alpha d e)) + (x : (weightedSplitTraceProjectiveNormalization + alpha beta d e hd he halpha hbeta h hswap).carrier) : + ∃ (i : WeightedSplitTraceProjectiveChartIndex) + (y : (weightedSplitTraceNormalizationChartScheme alpha beta d e i.down).carrier), + weightedSplitTraceNormalizationChartMap + alpha beta d e hd he halpha hbeta h hswap i y = x := + (weightedSplitTraceProjectiveNormalizationGlueData + alpha beta d e hd he halpha hbeta h hswap).ι_jointly_surjective x + +end + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/ProjectiveNormalizationMorphism.lean b/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/ProjectiveNormalizationMorphism.lean new file mode 100644 index 0000000000..9275d96f59 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/ProjectiveNormalizationMorphism.lean @@ -0,0 +1,479 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.BiprojectiveScheme +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.ProjectiveNormalizationCharts + +/-! +# The normalization morphism on trace-curve charts + +This module connects the integral-closure charts to the raw biprojective trace curve. The key +point is the explicit principal-open square: localization of the affine normalization map agrees +with normalization of the Laurent chart. The coordinate inversions are then checked to commute +with the raw-to-normalized Laurent map. +-/ + +@[expose] public section + +namespace BGS.Markoff + +open CategoryTheory +open AlgebraicGeometry + +noncomputable section + +universe u + +variable {K : Type u} [Field K] + +local instance affineNormalizationSelfAction (alpha beta : K) (d e : ℕ) : + DistribMulAction (WeightedSplitTraceAffineNormalizationRing alpha beta d e) + (WeightedSplitTraceAffineNormalizationRing alpha beta d e) := + (Algebra.toModule : Module (WeightedSplitTraceAffineNormalizationRing alpha beta d e) + (WeightedSplitTraceAffineNormalizationRing alpha beta d e)).toDistribMulAction + +/-- Canonical ring map from an affine trace chart to its integral closure. -/ +def weightedSplitTraceAffineNormalizationRingHom (alpha beta : K) (d e : ℕ) : + WeightedSplitTraceAffineCoordinateRing alpha beta d e →+* + WeightedSplitTraceAffineNormalizationRing alpha beta d e := + algebraMap _ _ + +/-- Canonical localization map from an affine normalization to its Laurent principal open. -/ +def weightedSplitTraceAffineNormalizationAwayRingHom (alpha beta : K) (d e : ℕ) : + WeightedSplitTraceAffineNormalizationRing alpha beta d e →+* + WeightedSplitTraceAffineNormalizationLaurentOpenRing alpha beta d e := + algebraMap _ _ + +/-- Canonical ring map from an affine trace chart to its Laurent principal open. -/ +def weightedSplitTraceAffineLaurentRingHom (alpha beta : K) (d e : ℕ) : + WeightedSplitTraceAffineCoordinateRing alpha beta d e →+* + WeightedSplitTraceLaurentCoordinateRing alpha beta d e := + algebraMap _ _ + +/-- Canonical ring map from the raw Laurent chart to its normalization. -/ +def weightedSplitTraceLaurentNormalizationRingHom (alpha beta : K) (d e : ℕ) : + WeightedSplitTraceLaurentCoordinateRing alpha beta d e →+* + WeightedSplitTraceLaurentNormalizationRing alpha beta d e := + algebraMap _ _ + +/-- Inverse of the comparison between the localized affine normalization and normalized Laurent +ring. -/ +def weightedSplitTraceAffineOpenInverseRingHom_of_irreducible + (alpha beta : K) (d e : ℕ) (hd : 0 < d) (he : 0 < e) (hbeta : beta ≠ 0) + (h : Irreducible (splitTraceCoverPolynomial alpha beta d e)) : + WeightedSplitTraceLaurentNormalizationRing alpha beta d e →+* + WeightedSplitTraceAffineNormalizationLaurentOpenRing alpha beta d e := + (weightedSplitTraceAffineNormalizationLaurentOpenEquiv_of_irreducible + alpha beta d e hd he hbeta h).symm.toRingHom + +/-- Before applying the integral-closure comparison, the two routes from the affine chart to the +localized affine normalization are equal by the scalar-tower law. -/ +theorem weightedSplitTraceRawPrincipalOpenSquare + (alpha beta : K) (d e : ℕ) + [IsDomain (WeightedSplitTraceAffineCoordinateRing alpha beta d e)] : + (integralClosureAwayMap + (weightedSplitTraceAffineCoordinateProduct alpha beta d e)).comp + (weightedSplitTraceAffineLaurentRingHom alpha beta d e) = + (weightedSplitTraceAffineNormalizationAwayRingHom alpha beta d e).comp + (weightedSplitTraceAffineNormalizationRingHom alpha beta d e) := by + apply DFunLike.ext _ _ + intro r + simp [integralClosureAwayMap, weightedSplitTraceAffineLaurentRingHom, + weightedSplitTraceAffineNormalizationAwayRingHom, + weightedSplitTraceAffineNormalizationRingHom] + exact IsScalarTower.algebraMap_apply _ _ _ r + +/-- Ring-level affine-chart square for the normalization map. -/ +theorem weightedSplitTraceAffineNormalizationRingSquare + (alpha beta : K) (d e : ℕ) (hd : 0 < d) (he : 0 < e) (hbeta : beta ≠ 0) + (h : Irreducible (splitTraceCoverPolynomial alpha beta d e)) : + (weightedSplitTraceAffineNormalizationAwayRingHom alpha beta d e).comp + (weightedSplitTraceAffineNormalizationRingHom alpha beta d e) = + (weightedSplitTraceAffineOpenInverseRingHom_of_irreducible + alpha beta d e hd he hbeta h).comp + ((weightedSplitTraceLaurentNormalizationRingHom alpha beta d e).comp + (weightedSplitTraceAffineLaurentRingHom alpha beta d e)) := by + let : IsDomain (WeightedSplitTraceAffineCoordinateRing alpha beta d e) := + weightedSplitTraceAffineCoordinateRing_isDomain alpha beta d e h + let E := weightedSplitTraceAffineNormalizationLaurentOpenEquiv_of_irreducible + alpha beta d e hd he hbeta h + apply DFunLike.ext _ _ + intro r + apply E.injective + dsimp only [weightedSplitTraceAffineOpenInverseRingHom_of_irreducible] + change E (((weightedSplitTraceAffineNormalizationAwayRingHom alpha beta d e).comp + (weightedSplitTraceAffineNormalizationRingHom alpha beta d e)) r) = + E (E.symm (((weightedSplitTraceLaurentNormalizationRingHom alpha beta d e).comp + (weightedSplitTraceAffineLaurentRingHom alpha beta d e)) r)) + rw [E.apply_symm_apply] + have hc := integralClosureAwayEquiv_comp_map + (weightedSplitTraceAffineCoordinateProduct alpha beta d e) + (weightedSplitTraceAffineCoordinateProduct_ne_zero_of_irreducible + alpha beta d e hd he hbeta h) + have hr := weightedSplitTraceRawPrincipalOpenSquare alpha beta d e + rw [← DFunLike.congr_fun hr r] + exact DFunLike.congr_fun hc ((weightedSplitTraceAffineLaurentRingHom alpha beta d e) r) + +/-- The affine normalization chart maps to the corresponding raw affine curve chart. -/ +def weightedSplitTraceAffineIntegralClosureToCurve (alpha beta : K) (d e : ℕ) : + weightedSplitTraceAffineNormalizationSpec alpha beta d e ⟶ + weightedSplitTraceAffineCurveSpec alpha beta d e := + Spec.map (CommRingCat.ofHom + (weightedSplitTraceAffineNormalizationRingHom alpha beta d e)) + +/-- The normalized common Laurent chart maps to the raw Laurent chart. -/ +def weightedSplitTraceLaurentNormalizationToCurve (alpha beta : K) (d e : ℕ) : + Spec (CommRingCat.of (WeightedSplitTraceLaurentNormalizationRing alpha beta d e)) ⟶ + weightedSplitTraceLaurentCurveSpec alpha beta d e := + Spec.map (CommRingCat.ofHom + (weightedSplitTraceLaurentNormalizationRingHom alpha beta d e)) + +/-- Scheme-level affine-chart square for the normalization map. -/ +theorem weightedSplitTraceAffineNormalizationSquare + (alpha beta : K) (d e : ℕ) (hd : 0 < d) (he : 0 < e) (hbeta : beta ≠ 0) + (h : Irreducible (splitTraceCoverPolynomial alpha beta d e)) : + weightedSplitTraceAffineNormalizationLaurentOpenImmersion alpha beta d e ≫ + weightedSplitTraceAffineIntegralClosureToCurve alpha beta d e = + (weightedSplitTraceAffineNormalizationLaurentOpenSchemeIso_of_irreducible + alpha beta d e hd he hbeta h).inv ≫ + weightedSplitTraceLaurentNormalizationToCurve alpha beta d e ≫ + weightedSplitTraceLaurentCurveOpenImmersion alpha beta d e := by + change + Spec.map (CommRingCat.ofHom + (weightedSplitTraceAffineNormalizationAwayRingHom alpha beta d e)) ≫ + Spec.map (CommRingCat.ofHom + (weightedSplitTraceAffineNormalizationRingHom alpha beta d e)) = + Spec.map (CommRingCat.ofHom + (weightedSplitTraceAffineOpenInverseRingHom_of_irreducible + alpha beta d e hd he hbeta h)) ≫ + Spec.map (CommRingCat.ofHom + (weightedSplitTraceLaurentNormalizationRingHom alpha beta d e)) ≫ + Spec.map (CommRingCat.ofHom + (weightedSplitTraceAffineLaurentRingHom alpha beta d e)) + exact BGS.specMap_two_eq_three_of_comp_eq + (weightedSplitTraceAffineNormalizationRingHom alpha beta d e) + (weightedSplitTraceAffineNormalizationAwayRingHom alpha beta d e) + (weightedSplitTraceAffineLaurentRingHom alpha beta d e) + (weightedSplitTraceLaurentNormalizationRingHom alpha beta d e) + (weightedSplitTraceAffineOpenInverseRingHom_of_irreducible + alpha beta d e hd he hbeta h) + (weightedSplitTraceAffineNormalizationRingSquare alpha beta d e hd he hbeta h) + +/-- First-coordinate inversion commutes with the raw-to-normalized Laurent ring map. -/ +theorem weightedSplitTraceLeftLaurentNormalizationRingSquare + (alpha beta : K) (d e : ℕ) + [IsDomain (WeightedSplitTraceLaurentCoordinateRing alpha beta d e)] + [IsDomain (WeightedSplitTraceLaurentCoordinateRing beta alpha d e)] : + (weightedSplitTraceLeftInversionLaurentNormalizationEquiv alpha beta d e).toRingHom.comp + (weightedSplitTraceLaurentNormalizationRingHom alpha beta d e) = + (weightedSplitTraceLaurentNormalizationRingHom alpha beta d e).comp + (weightedSplitTraceLeftInversionLaurentEquiv alpha beta d e).toRingHom := + integralClosureFractionRingEquiv_comp_algebraMap + (weightedSplitTraceLeftInversionLaurentEquiv alpha beta d e) + +/-- Second-coordinate inversion commutes with the raw-to-normalized Laurent ring maps. -/ +theorem weightedSplitTraceRightLaurentNormalizationRingSquare + (alpha beta : K) (d e : ℕ) + [IsDomain (WeightedSplitTraceLaurentCoordinateRing alpha beta d e)] + [IsDomain (WeightedSplitTraceLaurentCoordinateRing beta alpha d e)] : + (weightedSplitTraceRightInversionLaurentNormalizationEquiv alpha beta d e).toRingHom.comp + (weightedSplitTraceLaurentNormalizationRingHom beta alpha d e) = + (weightedSplitTraceLaurentNormalizationRingHom alpha beta d e).comp + (weightedSplitTraceRightInversionLaurentEquiv alpha beta d e).toRingHom := + integralClosureFractionRingEquiv_comp_algebraMap + (weightedSplitTraceRightInversionLaurentEquiv alpha beta d e) + +/-- Scheme-level naturality of first-coordinate inversion. -/ +@[reassoc] +theorem weightedSplitTraceLeftLaurentNormalizationSquare + (alpha beta : K) (d e : ℕ) + [IsDomain (WeightedSplitTraceLaurentCoordinateRing alpha beta d e)] + [IsDomain (WeightedSplitTraceLaurentCoordinateRing beta alpha d e)] : + (weightedSplitTraceLeftInversionLaurentNormalizationSchemeIso alpha beta d e).hom ≫ + weightedSplitTraceLaurentNormalizationToCurve alpha beta d e = + weightedSplitTraceLaurentNormalizationToCurve alpha beta d e ≫ + (weightedSplitTraceLeftInversionLaurentCurveSchemeIso alpha beta d e).hom := by + change + Spec.map (CommRingCat.ofHom + (weightedSplitTraceLeftInversionLaurentNormalizationEquiv alpha beta d e).toRingHom) ≫ + Spec.map (CommRingCat.ofHom + (weightedSplitTraceLaurentNormalizationRingHom alpha beta d e)) = + Spec.map (CommRingCat.ofHom + (weightedSplitTraceLaurentNormalizationRingHom alpha beta d e)) ≫ + Spec.map (CommRingCat.ofHom + (weightedSplitTraceLeftInversionLaurentEquiv alpha beta d e).toRingHom) + exact BGS.specMap_two_eq_two_of_comp_eq + (weightedSplitTraceLaurentNormalizationRingHom alpha beta d e) + (weightedSplitTraceLeftInversionLaurentNormalizationEquiv alpha beta d e).toRingHom + (weightedSplitTraceLeftInversionLaurentEquiv alpha beta d e).toRingHom + (weightedSplitTraceLaurentNormalizationRingHom alpha beta d e) + (weightedSplitTraceLeftLaurentNormalizationRingSquare alpha beta d e) + +/-- Scheme-level naturality of second-coordinate inversion. -/ +@[reassoc] +theorem weightedSplitTraceRightLaurentNormalizationSquare + (alpha beta : K) (d e : ℕ) + [IsDomain (WeightedSplitTraceLaurentCoordinateRing alpha beta d e)] + [IsDomain (WeightedSplitTraceLaurentCoordinateRing beta alpha d e)] : + (weightedSplitTraceRightInversionLaurentNormalizationSchemeIso alpha beta d e).hom ≫ + weightedSplitTraceLaurentNormalizationToCurve beta alpha d e = + weightedSplitTraceLaurentNormalizationToCurve alpha beta d e ≫ + (weightedSplitTraceRightInversionLaurentCurveSchemeIso alpha beta d e).hom := by + change + Spec.map (CommRingCat.ofHom + (weightedSplitTraceRightInversionLaurentNormalizationEquiv alpha beta d e).toRingHom) ≫ + Spec.map (CommRingCat.ofHom + (weightedSplitTraceLaurentNormalizationRingHom beta alpha d e)) = + Spec.map (CommRingCat.ofHom + (weightedSplitTraceLaurentNormalizationRingHom alpha beta d e)) ≫ + Spec.map (CommRingCat.ofHom + (weightedSplitTraceRightInversionLaurentEquiv alpha beta d e).toRingHom) + exact BGS.specMap_two_eq_two_of_comp_eq + (weightedSplitTraceLaurentNormalizationRingHom beta alpha d e) + (weightedSplitTraceRightInversionLaurentNormalizationEquiv alpha beta d e).toRingHom + (weightedSplitTraceRightInversionLaurentEquiv alpha beta d e).toRingHom + (weightedSplitTraceLaurentNormalizationRingHom alpha beta d e) + (weightedSplitTraceRightLaurentNormalizationRingSquare alpha beta d e) + +/-- Inverse form of second-coordinate naturality, oriented for the swapped affine charts. -/ +@[reassoc] +theorem weightedSplitTraceRightLaurentNormalizationInverseSquare + (alpha beta : K) (d e : ℕ) + [IsDomain (WeightedSplitTraceLaurentCoordinateRing alpha beta d e)] + [IsDomain (WeightedSplitTraceLaurentCoordinateRing beta alpha d e)] : + (weightedSplitTraceRightInversionLaurentNormalizationSchemeIso alpha beta d e).inv ≫ + weightedSplitTraceLaurentNormalizationToCurve alpha beta d e ≫ + (weightedSplitTraceRightInversionLaurentCurveSchemeIso alpha beta d e).hom = + weightedSplitTraceLaurentNormalizationToCurve beta alpha d e := by + rw [← weightedSplitTraceRightLaurentNormalizationSquare alpha beta d e] + simp + +/-- Compatibility square for the chart obtained by inverting the first coordinate. -/ +theorem weightedSplitTraceFirstInvertedNormalizationSquare + (alpha beta : K) (d e : ℕ) (hd : 0 < d) (he : 0 < e) + (halpha : alpha ≠ 0) (hbeta : beta ≠ 0) + (h : Irreducible (splitTraceCoverPolynomial alpha beta d e)) + (hswap : Irreducible (splitTraceCoverPolynomial beta alpha d e)) : + weightedSplitTraceAffineNormalizationLaurentOpenImmersion alpha beta d e ≫ + weightedSplitTraceAffineIntegralClosureToCurve alpha beta d e = + ((weightedSplitTraceAffineNormalizationLaurentOpenSchemeIso_of_irreducible + alpha beta d e hd he hbeta h).symm.trans + (weightedSplitTraceLeftInversionLaurentNormalizationSchemeIso alpha beta d e)).hom ≫ + weightedSplitTraceLaurentNormalizationToCurve alpha beta d e ≫ + (weightedSplitTraceLeftInversionLaurentCurveSchemeIso alpha beta d e).inv ≫ + weightedSplitTraceLaurentCurveOpenImmersion alpha beta d e := by + let : IsDomain (WeightedSplitTraceLaurentCoordinateRing alpha beta d e) := + weightedSplitTraceLaurentCoordinateRing_isDomain alpha beta d e hd he hbeta h + let : IsDomain (WeightedSplitTraceLaurentCoordinateRing beta alpha d e) := + weightedSplitTraceLaurentCoordinateRing_isDomain beta alpha d e hd he halpha hswap + calc + _ = (weightedSplitTraceAffineNormalizationLaurentOpenSchemeIso_of_irreducible + alpha beta d e hd he hbeta h).inv ≫ + weightedSplitTraceLaurentNormalizationToCurve alpha beta d e ≫ + weightedSplitTraceLaurentCurveOpenImmersion alpha beta d e := + weightedSplitTraceAffineNormalizationSquare alpha beta d e hd he hbeta h + _ = _ := by + simp only [Iso.trans_hom, Iso.symm_hom, Category.assoc] + rw [weightedSplitTraceLeftLaurentNormalizationSquare_assoc alpha beta d e] + simp + +/-- Compatibility square for the chart obtained by inverting the second coordinate. -/ +theorem weightedSplitTraceSecondInvertedNormalizationSquare + (alpha beta : K) (d e : ℕ) (hd : 0 < d) (he : 0 < e) + (halpha : alpha ≠ 0) (hbeta : beta ≠ 0) + (h : Irreducible (splitTraceCoverPolynomial alpha beta d e)) + (hswap : Irreducible (splitTraceCoverPolynomial beta alpha d e)) : + weightedSplitTraceAffineNormalizationLaurentOpenImmersion beta alpha d e ≫ + weightedSplitTraceAffineIntegralClosureToCurve beta alpha d e = + ((weightedSplitTraceAffineNormalizationLaurentOpenSchemeIso_of_irreducible + beta alpha d e hd he halpha hswap).symm.trans + (weightedSplitTraceRightInversionLaurentNormalizationSchemeIso alpha beta d e).symm).hom ≫ + weightedSplitTraceLaurentNormalizationToCurve alpha beta d e ≫ + (weightedSplitTraceRightInversionLaurentCurveSchemeIso alpha beta d e).hom ≫ + weightedSplitTraceLaurentCurveOpenImmersion beta alpha d e := by + let : IsDomain (WeightedSplitTraceLaurentCoordinateRing alpha beta d e) := + weightedSplitTraceLaurentCoordinateRing_isDomain alpha beta d e hd he hbeta h + let : IsDomain (WeightedSplitTraceLaurentCoordinateRing beta alpha d e) := + weightedSplitTraceLaurentCoordinateRing_isDomain beta alpha d e hd he halpha hswap + calc + _ = (weightedSplitTraceAffineNormalizationLaurentOpenSchemeIso_of_irreducible + beta alpha d e hd he halpha hswap).inv ≫ + weightedSplitTraceLaurentNormalizationToCurve beta alpha d e ≫ + weightedSplitTraceLaurentCurveOpenImmersion beta alpha d e := + weightedSplitTraceAffineNormalizationSquare beta alpha d e hd he halpha hswap + _ = _ := by + simp only [Iso.trans_hom, Iso.symm_hom, Category.assoc] + rw [weightedSplitTraceRightLaurentNormalizationInverseSquare_assoc alpha beta d e] + +/-- Compatibility square for the chart obtained by inverting both coordinates. -/ +theorem weightedSplitTraceBothInvertedNormalizationSquare + (alpha beta : K) (d e : ℕ) (hd : 0 < d) (he : 0 < e) + (halpha : alpha ≠ 0) (hbeta : beta ≠ 0) + (h : Irreducible (splitTraceCoverPolynomial alpha beta d e)) + (hswap : Irreducible (splitTraceCoverPolynomial beta alpha d e)) : + weightedSplitTraceAffineNormalizationLaurentOpenImmersion beta alpha d e ≫ + weightedSplitTraceAffineIntegralClosureToCurve beta alpha d e = + (((weightedSplitTraceAffineNormalizationLaurentOpenSchemeIso_of_irreducible + beta alpha d e hd he halpha hswap).symm.trans + (weightedSplitTraceRightInversionLaurentNormalizationSchemeIso alpha beta d e).symm).trans + (weightedSplitTraceLeftInversionLaurentNormalizationSchemeIso alpha beta d e)).hom ≫ + weightedSplitTraceLaurentNormalizationToCurve alpha beta d e ≫ + ((weightedSplitTraceRightInversionLaurentCurveSchemeIso alpha beta d e).symm.trans + (weightedSplitTraceLeftInversionLaurentCurveSchemeIso alpha beta d e)).inv ≫ + weightedSplitTraceLaurentCurveOpenImmersion beta alpha d e := by + let : IsDomain (WeightedSplitTraceLaurentCoordinateRing alpha beta d e) := + weightedSplitTraceLaurentCoordinateRing_isDomain alpha beta d e hd he hbeta h + let : IsDomain (WeightedSplitTraceLaurentCoordinateRing beta alpha d e) := + weightedSplitTraceLaurentCoordinateRing_isDomain beta alpha d e hd he halpha hswap + calc + _ = (weightedSplitTraceAffineNormalizationLaurentOpenSchemeIso_of_irreducible + beta alpha d e hd he halpha hswap).inv ≫ + weightedSplitTraceLaurentNormalizationToCurve beta alpha d e ≫ + weightedSplitTraceLaurentCurveOpenImmersion beta alpha d e := + weightedSplitTraceAffineNormalizationSquare beta alpha d e hd he halpha hswap + _ = _ := by + simp only [Iso.trans_hom, Iso.symm_hom, Iso.trans_inv, Iso.symm_inv, Category.assoc] + rw [weightedSplitTraceLeftLaurentNormalizationSquare_assoc alpha beta d e] + simp only [Iso.hom_inv_id_assoc] + rw [weightedSplitTraceRightLaurentNormalizationInverseSquare_assoc alpha beta d e] + +/-- Raw target map for each of the four affine normalization charts. -/ +def weightedSplitTraceNormalizationChartToProjectiveChart + (alpha beta : K) (d e : ℕ) : + (i : WeightedSplitTraceProjectiveChart) → + weightedSplitTraceNormalizationChartScheme alpha beta d e i ⟶ + weightedSplitTraceProjectiveChartScheme alpha beta d e i + | .affine | .invertFirst => weightedSplitTraceAffineIntegralClosureToCurve alpha beta d e + | .invertSecond | .invertBoth => weightedSplitTraceAffineIntegralClosureToCurve beta alpha d e + +/-- All four affine normalization maps restrict to the same raw Laurent normalization map under +the chosen common-overlap identifications. -/ +theorem weightedSplitTraceNormalizationChartCompatibility + (alpha beta : K) (d e : ℕ) (hd : 0 < d) (he : 0 < e) + (halpha : alpha ≠ 0) (hbeta : beta ≠ 0) + (h : Irreducible (splitTraceCoverPolynomial alpha beta d e)) + (hswap : Irreducible (splitTraceCoverPolynomial beta alpha d e)) + (i : WeightedSplitTraceProjectiveChart) : + weightedSplitTraceNormalizationChartOpenImmersion alpha beta d e i ≫ + weightedSplitTraceNormalizationChartToProjectiveChart alpha beta d e i = + (weightedSplitTraceNormalizationChartOpenIsoCommon + alpha beta d e hd he halpha hbeta h hswap i).hom ≫ + weightedSplitTraceLaurentNormalizationToCurve alpha beta d e ≫ + (weightedSplitTraceProjectiveChartOpenIsoCommon alpha beta d e i).inv ≫ + weightedSplitTraceProjectiveChartOpenImmersion alpha beta d e i := by + cases i with + | affine => + exact weightedSplitTraceAffineNormalizationSquare alpha beta d e hd he hbeta h + | invertFirst => + dsimp [weightedSplitTraceNormalizationChartOpenImmersion, + weightedSplitTraceNormalizationChartToProjectiveChart, + weightedSplitTraceNormalizationChartOpenIsoCommon, + weightedSplitTraceProjectiveChartOpenIsoCommon, + weightedSplitTraceProjectiveChartOpenImmersion] + exact weightedSplitTraceFirstInvertedNormalizationSquare + alpha beta d e hd he halpha hbeta h hswap + | invertSecond => + dsimp [weightedSplitTraceNormalizationChartOpenImmersion, + weightedSplitTraceNormalizationChartToProjectiveChart, + weightedSplitTraceNormalizationChartOpenIsoCommon, + weightedSplitTraceProjectiveChartOpenIsoCommon, + weightedSplitTraceProjectiveChartOpenImmersion] + exact weightedSplitTraceSecondInvertedNormalizationSquare + alpha beta d e hd he halpha hbeta h hswap + | invertBoth => + dsimp [weightedSplitTraceNormalizationChartOpenImmersion, + weightedSplitTraceNormalizationChartToProjectiveChart, + weightedSplitTraceNormalizationChartOpenIsoCommon, + weightedSplitTraceProjectiveChartOpenIsoCommon, + weightedSplitTraceProjectiveChartOpenImmersion] + exact weightedSplitTraceBothInvertedNormalizationSquare + alpha beta d e hd he halpha hbeta h hswap + +/-- The global morphism from the glued integral-closure charts to the raw biprojective trace +curve, descended from the four compatible affine normalization maps. -/ +def weightedSplitTraceProjectiveNormalizationToBiprojectiveCurve + (alpha beta : K) (d e : ℕ) (hd : 0 < d) (he : 0 < e) + (halpha : alpha ≠ 0) (hbeta : beta ≠ 0) + (h : Irreducible (splitTraceCoverPolynomial alpha beta d e)) + (hswap : Irreducible (splitTraceCoverPolynomial beta alpha d e)) : + weightedSplitTraceProjectiveNormalization + alpha beta d e hd he halpha hbeta h hswap ⟶ + weightedSplitTraceBiprojectiveCurve alpha beta d e := + BGS.constantOpenGlueDataOfCommonTargetMap + (fun i : WeightedSplitTraceProjectiveChartIndex ↦ + weightedSplitTraceNormalizationChartScheme alpha beta d e i.down) + (fun i : WeightedSplitTraceProjectiveChartIndex ↦ + weightedSplitTraceNormalizationChartOpen alpha beta d e i.down) + (fun i : WeightedSplitTraceProjectiveChartIndex ↦ + weightedSplitTraceProjectiveChartScheme alpha beta d e i.down) + (fun i : WeightedSplitTraceProjectiveChartIndex ↦ + weightedSplitTraceProjectiveChartOpen alpha beta d e i.down) + (fun i : WeightedSplitTraceProjectiveChartIndex ↦ + weightedSplitTraceNormalizationChartOpenImmersion alpha beta d e i.down) + (fun i : WeightedSplitTraceProjectiveChartIndex ↦ + weightedSplitTraceProjectiveChartOpenImmersion alpha beta d e i.down) + (Spec (CommRingCat.of (WeightedSplitTraceLaurentNormalizationRing alpha beta d e))) + (weightedSplitTraceLaurentCurveSpec alpha beta d e) + (fun i : WeightedSplitTraceProjectiveChartIndex ↦ + weightedSplitTraceNormalizationChartOpenIsoCommon + alpha beta d e hd he halpha hbeta h hswap i.down) + (fun i : WeightedSplitTraceProjectiveChartIndex ↦ + weightedSplitTraceProjectiveChartOpenIsoCommon alpha beta d e i.down) + (fun i : WeightedSplitTraceProjectiveChartIndex ↦ + weightedSplitTraceNormalizationChartToProjectiveChart alpha beta d e i.down) + (weightedSplitTraceLaurentNormalizationToCurve alpha beta d e) + (fun i : WeightedSplitTraceProjectiveChartIndex ↦ + weightedSplitTraceNormalizationChartCompatibility + alpha beta d e hd he halpha hbeta h hswap i.down) + +/-- On every standard affine chart, the global normalization morphism is the canonical affine +integral-closure map followed by the corresponding raw chart inclusion. -/ +@[reassoc] +theorem weightedSplitTraceNormalizationChartMap_toBiprojectiveCurve + (alpha beta : K) (d e : ℕ) (hd : 0 < d) (he : 0 < e) + (halpha : alpha ≠ 0) (hbeta : beta ≠ 0) + (h : Irreducible (splitTraceCoverPolynomial alpha beta d e)) + (hswap : Irreducible (splitTraceCoverPolynomial beta alpha d e)) + (i : WeightedSplitTraceProjectiveChartIndex) : + weightedSplitTraceNormalizationChartMap + alpha beta d e hd he halpha hbeta h hswap i ≫ + weightedSplitTraceProjectiveNormalizationToBiprojectiveCurve + alpha beta d e hd he halpha hbeta h hswap = + weightedSplitTraceNormalizationChartToProjectiveChart alpha beta d e i.down ≫ + weightedSplitTraceProjectiveChartMap alpha beta d e i := by + exact BGS.constantOpenGlueDataOfCommonTargetMap_chart + (fun i : WeightedSplitTraceProjectiveChartIndex ↦ + weightedSplitTraceNormalizationChartScheme alpha beta d e i.down) + (fun i : WeightedSplitTraceProjectiveChartIndex ↦ + weightedSplitTraceNormalizationChartOpen alpha beta d e i.down) + (fun i : WeightedSplitTraceProjectiveChartIndex ↦ + weightedSplitTraceProjectiveChartScheme alpha beta d e i.down) + (fun i : WeightedSplitTraceProjectiveChartIndex ↦ + weightedSplitTraceProjectiveChartOpen alpha beta d e i.down) + (fun i : WeightedSplitTraceProjectiveChartIndex ↦ + weightedSplitTraceNormalizationChartOpenImmersion alpha beta d e i.down) + (fun i : WeightedSplitTraceProjectiveChartIndex ↦ + weightedSplitTraceProjectiveChartOpenImmersion alpha beta d e i.down) + (Spec (CommRingCat.of (WeightedSplitTraceLaurentNormalizationRing alpha beta d e))) + (weightedSplitTraceLaurentCurveSpec alpha beta d e) + (fun i : WeightedSplitTraceProjectiveChartIndex ↦ + weightedSplitTraceNormalizationChartOpenIsoCommon + alpha beta d e hd he halpha hbeta h hswap i.down) + (fun i : WeightedSplitTraceProjectiveChartIndex ↦ + weightedSplitTraceProjectiveChartOpenIsoCommon alpha beta d e i.down) + (fun i : WeightedSplitTraceProjectiveChartIndex ↦ + weightedSplitTraceNormalizationChartToProjectiveChart alpha beta d e i.down) + (weightedSplitTraceLaurentNormalizationToCurve alpha beta d e) + (fun i : WeightedSplitTraceProjectiveChartIndex ↦ + weightedSplitTraceNormalizationChartCompatibility + alpha beta d e hd he halpha hbeta h hswap i.down) + i + +end + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/ProjectivePointEstimate.lean b/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/ProjectivePointEstimate.lean new file mode 100644 index 0000000000..ffc8dba05a --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/ProjectivePointEstimate.lean @@ -0,0 +1,271 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.BiprojectiveClosure +public import Mathlib.Analysis.SpecialFunctions.Pow.Real + +/-! +# The exact projective-to-torus point-count bridge + +Mathlib currently has no general smooth-projective curve, genus, normalization, +and Hasse--Weil package from which the endgame estimate can be derived. This +module therefore starts at the first honest arithmetic interface: + +* an explicit equivalence between affine cover zeros and projective rational + points away from an explicit boundary finset; +* the Hasse inequality for that projective model, passed as a proposition; +* independent numerical genus and boundary bounds. + +The conclusion is the desired `O(sqrt (#K) * d * e)` estimate for the actual +Laurent trace-solution finset. No target estimate is hidden in a typeclass. +-/ + +@[expose] public section + +namespace BGS.Markoff + +noncomputable section + +variable (K : Type*) [Field K] [Fintype K] [DecidableEq K] + +/-- An explicit projective comparison, Hasse inequality, genus bound, and +boundary bound imply the split trace-cover estimate on the original torus. + +`projectivePoints` is intended to be the rational-point finset of the smooth +projective normalization, and `projectiveBoundary` its complement of the +affine chart. Requiring an actual equivalence of finite types prevents the +model comparison from being replaced by a cardinality assertion about the +desired torus count. -/ +theorem splitTraceCurveSolutions_count_error_le_of_projectiveComparison_and_hasse + {P : Type*} [DecidableEq P] + (alpha beta : K) (d e : ℕ) (hd : 0 < d) (he : 0 < e) (hbeta : beta ≠ 0) + (projectivePoints projectiveBoundary : Finset P) + (hboundarySubset : projectiveBoundary ⊆ projectivePoints) + (modelComparison : + ↥(affineSplitTraceCoverZeros K alpha beta d e) ≃ + ↥(projectivePoints \ projectiveBoundary)) + (genus genusCoefficient boundaryCoefficient : ℕ) + (hprojectiveHasse : + |(projectivePoints.card : ℝ) - ((Fintype.card K : ℝ) + 1)| ≤ + 2 * (genus : ℝ) * Real.sqrt (Fintype.card K : ℝ)) + (hgenus : genus ≤ genusCoefficient * d * e) + (hboundary : projectiveBoundary.card ≤ boundaryCoefficient * d * e) : + |((splitTraceCurveSolutions K alpha beta d e).card : ℝ) - + (Fintype.card K : ℝ)| ≤ + ((2 * (genusCoefficient : ℝ) * Real.sqrt (Fintype.card K : ℝ)) + + (boundaryCoefficient : ℝ)) * (d : ℝ) * (e : ℝ) := by + have hmodelCard : + (affineSplitTraceCoverZeros K alpha beta d e).card = + (projectivePoints \ projectiveBoundary).card := by + calc + (affineSplitTraceCoverZeros K alpha beta d e).card = + Fintype.card ↥(affineSplitTraceCoverZeros K alpha beta d e) := + (Fintype.card_coe _).symm + _ = Fintype.card ↥(projectivePoints \ projectiveBoundary) := + Fintype.card_congr modelComparison + _ = (projectivePoints \ projectiveBoundary).card := Fintype.card_coe _ + have hprojectivePartition : + (projectivePoints \ projectiveBoundary).card + projectiveBoundary.card = + projectivePoints.card := + Finset.card_sdiff_add_card_eq_card hboundarySubset + have haffineBoundary := + affineSplitTraceCoverZeros_card_eq_torus_card_add_one + K alpha beta d e hd he hbeta + have htorusSolutions := + torusSplitTraceCoverZeros_card_eq_splitTraceCurveSolutions_card + K alpha beta d e + have hcardIdentity : + projectivePoints.card = + (splitTraceCurveSolutions K alpha beta d e).card + 1 + + projectiveBoundary.card := by + omega + have herrorIdentity : + ((splitTraceCurveSolutions K alpha beta d e).card : ℝ) - + (Fintype.card K : ℝ) = + ((projectivePoints.card : ℝ) - ((Fintype.card K : ℝ) + 1)) - + (projectiveBoundary.card : ℝ) := by + have hcardReal : + (projectivePoints.card : ℝ) = + (splitTraceCurveSolutions K alpha beta d e).card + 1 + + projectiveBoundary.card := by + exact_mod_cast hcardIdentity + rw [hcardReal] + ring + have hboundaryReal : + (projectiveBoundary.card : ℝ) ≤ + (boundaryCoefficient : ℝ) * d * e := by + exact_mod_cast hboundary + have hgenusReal : + (genus : ℝ) ≤ (genusCoefficient : ℝ) * d * e := by + exact_mod_cast hgenus + have hsqrtNonnegative : + 0 ≤ Real.sqrt (Fintype.card K : ℝ) := Real.sqrt_nonneg _ + rw [herrorIdentity] + calc + |((projectivePoints.card : ℝ) - ((Fintype.card K : ℝ) + 1)) - + (projectiveBoundary.card : ℝ)| ≤ + |(projectivePoints.card : ℝ) - ((Fintype.card K : ℝ) + 1)| + + |(projectiveBoundary.card : ℝ)| := abs_sub _ _ + _ = |(projectivePoints.card : ℝ) - ((Fintype.card K : ℝ) + 1)| + + (projectiveBoundary.card : ℝ) := by simp + _ ≤ 2 * (genus : ℝ) * Real.sqrt (Fintype.card K : ℝ) + + (projectiveBoundary.card : ℝ) := + add_le_add hprojectiveHasse le_rfl + _ ≤ 2 * ((genusCoefficient : ℝ) * d * e) * + Real.sqrt (Fintype.card K : ℝ) + + ((boundaryCoefficient : ℝ) * d * e) := by + gcongr + _ = ((2 * (genusCoefficient : ℝ) * Real.sqrt (Fintype.card K : ℝ)) + + (boundaryCoefficient : ℝ)) * (d : ℝ) * (e : ℝ) := by ring + +/-- Since a finite field is nonempty, its square-root cardinality is at least +one. Thus the separate projective-boundary contribution can be absorbed into +the same `sqrt (#K) * d * e` error term used in the paper. -/ +theorem splitTraceCurveSolutions_count_error_le_sqrt_mul_de_of_projectiveComparison_and_hasse + {P : Type*} [DecidableEq P] + (alpha beta : K) (d e : ℕ) (hd : 0 < d) (he : 0 < e) (hbeta : beta ≠ 0) + (projectivePoints projectiveBoundary : Finset P) + (hboundarySubset : projectiveBoundary ⊆ projectivePoints) + (modelComparison : + ↥(affineSplitTraceCoverZeros K alpha beta d e) ≃ + ↥(projectivePoints \ projectiveBoundary)) + (genus genusCoefficient boundaryCoefficient : ℕ) + (hprojectiveHasse : + |(projectivePoints.card : ℝ) - ((Fintype.card K : ℝ) + 1)| ≤ + 2 * (genus : ℝ) * Real.sqrt (Fintype.card K : ℝ)) + (hgenus : genus ≤ genusCoefficient * d * e) + (hboundary : projectiveBoundary.card ≤ boundaryCoefficient * d * e) : + |((splitTraceCurveSolutions K alpha beta d e).card : ℝ) - + (Fintype.card K : ℝ)| ≤ + (2 * (genusCoefficient : ℝ) + (boundaryCoefficient : ℝ)) * + Real.sqrt (Fintype.card K : ℝ) * (d : ℝ) * (e : ℝ) := by + have hbridge := + splitTraceCurveSolutions_count_error_le_of_projectiveComparison_and_hasse + K alpha beta d e hd he hbeta projectivePoints projectiveBoundary + hboundarySubset modelComparison genus genusCoefficient boundaryCoefficient + hprojectiveHasse hgenus hboundary + have hcardOneNat : 1 ≤ Fintype.card K := Fintype.card_pos + have hcardOneReal : (1 : ℝ) ≤ Fintype.card K := by exact_mod_cast hcardOneNat + have hsqrtOne : (1 : ℝ) ≤ Real.sqrt (Fintype.card K : ℝ) := + Real.one_le_sqrt.mpr hcardOneReal + have hboundaryAbsorb : + (boundaryCoefficient : ℝ) ≤ + (boundaryCoefficient : ℝ) * Real.sqrt (Fintype.card K : ℝ) := by + simpa using mul_le_mul_of_nonneg_left hsqrtOne + (Nat.cast_nonneg boundaryCoefficient) + calc + |((splitTraceCurveSolutions K alpha beta d e).card : ℝ) - + (Fintype.card K : ℝ)| ≤ + ((2 * (genusCoefficient : ℝ) * Real.sqrt (Fintype.card K : ℝ)) + + (boundaryCoefficient : ℝ)) * (d : ℝ) * (e : ℝ) := hbridge + _ ≤ (2 * (genusCoefficient : ℝ) * Real.sqrt (Fintype.card K : ℝ) + + (boundaryCoefficient : ℝ) * Real.sqrt (Fintype.card K : ℝ)) * + (d : ℝ) * (e : ℝ) := by gcongr + _ = (2 * (genusCoefficient : ℝ) + (boundaryCoefficient : ℝ)) * + Real.sqrt (Fintype.card K : ℝ) * (d : ℝ) * (e : ℝ) := by ring + +/-- Square-form Hasse interface, matching the form used by the explicit +Legendre development and the standard Hasse--Weil statement. -/ +theorem splitTraceCurveSolutions_count_error_le_sqrt_mul_de_of_projectiveComparison_and_hasseSquare + {P : Type*} [DecidableEq P] + (alpha beta : K) (d e : ℕ) (hd : 0 < d) (he : 0 < e) (hbeta : beta ≠ 0) + (projectivePoints projectiveBoundary : Finset P) + (hboundarySubset : projectiveBoundary ⊆ projectivePoints) + (modelComparison : + ↥(affineSplitTraceCoverZeros K alpha beta d e) ≃ + ↥(projectivePoints \ projectiveBoundary)) + (genus genusCoefficient boundaryCoefficient : ℕ) + (hprojectiveHasseSquare : + ((projectivePoints.card : ℝ) - ((Fintype.card K : ℝ) + 1)) ^ 2 ≤ + 4 * (genus : ℝ) ^ 2 * (Fintype.card K : ℝ)) + (hgenus : genus ≤ genusCoefficient * d * e) + (hboundary : projectiveBoundary.card ≤ boundaryCoefficient * d * e) : + |((splitTraceCurveSolutions K alpha beta d e).card : ℝ) - + (Fintype.card K : ℝ)| ≤ + (2 * (genusCoefficient : ℝ) + (boundaryCoefficient : ℝ)) * + Real.sqrt (Fintype.card K : ℝ) * (d : ℝ) * (e : ℝ) := by + let projectiveError : ℝ := + (projectivePoints.card : ℝ) - ((Fintype.card K : ℝ) + 1) + have hcardNonnegative : (0 : ℝ) ≤ Fintype.card K := Nat.cast_nonneg _ + have htargetNonnegative : + 0 ≤ 2 * (genus : ℝ) * Real.sqrt (Fintype.card K : ℝ) := by positivity + have hprojectiveHasse : + |projectiveError| ≤ + 2 * (genus : ℝ) * Real.sqrt (Fintype.card K : ℝ) := by + apply (sq_le_sq₀ (abs_nonneg _) htargetNonnegative).mp + calc + |projectiveError| ^ 2 = projectiveError ^ 2 := sq_abs projectiveError + _ ≤ 4 * (genus : ℝ) ^ 2 * (Fintype.card K : ℝ) := by + simpa [projectiveError] using hprojectiveHasseSquare + _ = (2 * (genus : ℝ) * Real.sqrt (Fintype.card K : ℝ)) ^ 2 := by + rw [mul_pow, mul_pow, Real.sq_sqrt hcardNonnegative] + ring + exact splitTraceCurveSolutions_count_error_le_sqrt_mul_de_of_projectiveComparison_and_hasse + K alpha beta d e hd he hbeta projectivePoints projectiveBoundary + hboundarySubset modelComparison genus genusCoefficient boundaryCoefficient + (by simpa [projectiveError] using hprojectiveHasse) hgenus hboundary + +/-! ### Boundary labels supplied by the corner initial forms -/ + +/-- Four raw projective corners, with one label for each factor of the corresponding weighted +initial form. A normalization proof should inject its boundary points into this finite type. -/ +abbrev splitTraceNormalizationBoundaryLabels (d e : ℕ) := + Fin 4 × Fin (Nat.gcd d e) + +/-- An injective labeling of normalization-boundary points by a corner and an initial factor gives +the explicit `4de` boundary bound required by the point-count bridge. This premise is structural: +it does not assume the desired cardinal inequality. -/ +theorem projectiveBoundary_card_le_four_mul_de_of_injective_normalizationLabels + {P : Type*} [DecidableEq P] (boundary : Finset P) + (d e : ℕ) (hd : 0 < d) (he : 0 < e) + (labels : ↥boundary → splitTraceNormalizationBoundaryLabels d e) + (hlabels : Function.Injective labels) : + boundary.card ≤ 4 * d * e := by + have hgcd : Nat.gcd d e ≤ d := Nat.gcd_le_left e hd + have hdde : d ≤ d * e := Nat.le_mul_of_pos_right d he + calc + boundary.card = Fintype.card ↥boundary := (Fintype.card_coe boundary).symm + _ ≤ Fintype.card (splitTraceNormalizationBoundaryLabels d e) := + Fintype.card_le_of_injective labels hlabels + _ = 4 * Nat.gcd d e := by simp + _ ≤ 4 * d := Nat.mul_le_mul_left 4 hgcd + _ ≤ 4 * d * e := by simpa [Nat.mul_assoc] using Nat.mul_le_mul_left 4 hdde + +/-- The projective point estimate with boundary control supplied by actual normalization labels. +The remaining inputs are the affine-chart comparison, the genus bound, and Hasse--Weil for the +smooth projective normalization. -/ +theorem splitTraceCurveSolutions_count_error_le_of_normalizationLabels_and_hasse + {P : Type*} [DecidableEq P] + (alpha beta : K) (d e : ℕ) (hd : 0 < d) (he : 0 < e) (hbeta : beta ≠ 0) + (projectivePoints projectiveBoundary : Finset P) + (hboundarySubset : projectiveBoundary ⊆ projectivePoints) + (modelComparison : + ↥(affineSplitTraceCoverZeros K alpha beta d e) ≃ + ↥(projectivePoints \ projectiveBoundary)) + (boundaryLabels : + ↥projectiveBoundary → splitTraceNormalizationBoundaryLabels d e) + (hboundaryLabels : Function.Injective boundaryLabels) + (genus genusCoefficient : ℕ) + (hprojectiveHasse : + |(projectivePoints.card : ℝ) - ((Fintype.card K : ℝ) + 1)| ≤ + 2 * (genus : ℝ) * Real.sqrt (Fintype.card K : ℝ)) + (hgenus : genus ≤ genusCoefficient * d * e) : + |((splitTraceCurveSolutions K alpha beta d e).card : ℝ) - + (Fintype.card K : ℝ)| ≤ + (2 * (genusCoefficient : ℝ) + 4) * + Real.sqrt (Fintype.card K : ℝ) * (d : ℝ) * (e : ℝ) := by + exact splitTraceCurveSolutions_count_error_le_sqrt_mul_de_of_projectiveComparison_and_hasse + K alpha beta d e hd he hbeta projectivePoints projectiveBoundary + hboundarySubset modelComparison genus genusCoefficient 4 hprojectiveHasse hgenus + (projectiveBoundary_card_le_four_mul_de_of_injective_normalizationLabels + projectiveBoundary d e hd he boundaryLabels hboundaryLabels) + +end + + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/SemanticNormalForm.lean b/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/SemanticNormalForm.lean new file mode 100644 index 0000000000..dd2d712f9e --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/SemanticNormalForm.lean @@ -0,0 +1,259 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.NormalForm + +/-! +# Semantic normal forms for the split trace cover + +The iterated monic `AdjoinRoot` presentation gives every element of the Kummer top algebra a +unique rectangular coefficient vector. Composing this representation with the affine and +Laurent comparison maps gives semantic normal forms for trace-cover classes, and evaluation of +those coefficients recovers the comparison-map image exactly. + +This does not identify two source classes with the same semantic normal form. That remaining +injectivity statement is the syntactic quotient-division wall and is kept explicit below. +-/ + +@[expose] public section + +namespace BGS.Markoff + +open Polynomial + +noncomputable section + +/-- Rectangular coefficients of an element in a two-stage monic `AdjoinRoot` tower. -/ +def adjoinRootTowerSemanticNormalForm + {R : Type*} [CommRing R] (f : R[X]) (hf : f.Monic) + (g : Polynomial (AdjoinRoot f)) (hg : g.Monic) (z : AdjoinRoot g) : + Fin f.natDegree × Fin g.natDegree →₀ R := + (((AdjoinRoot.powerBasis' hf).basis.smulTower + (AdjoinRoot.powerBasis' hg).basis).repr z) + +/-- Evaluate a rectangular coefficient vector in the two-stage `AdjoinRoot` tower. -/ +def adjoinRootTowerSemanticNormalFormEvaluation + {R : Type*} [CommRing R] (f : R[X]) (hf : f.Monic) + (g : Polynomial (AdjoinRoot f)) (hg : g.Monic) + (c : Fin f.natDegree × Fin g.natDegree →₀ R) : AdjoinRoot g := + (((AdjoinRoot.powerBasis' hf).basis.smulTower + (AdjoinRoot.powerBasis' hg).basis).repr.symm c) + +@[simp] +theorem adjoinRootTowerSemanticNormalForm_evaluation + {R : Type*} [CommRing R] (f : R[X]) (hf : f.Monic) + (g : Polynomial (AdjoinRoot f)) (hg : g.Monic) (z : AdjoinRoot g) : + adjoinRootTowerSemanticNormalFormEvaluation f hf g hg + (adjoinRootTowerSemanticNormalForm f hf g hg z) = z := by + exact LinearEquiv.symm_apply_apply _ z + +@[simp] +theorem adjoinRootTowerSemanticNormalForm_evaluation_inverse + {R : Type*} [CommRing R] (f : R[X]) (hf : f.Monic) + (g : Polynomial (AdjoinRoot f)) (hg : g.Monic) + (c : Fin f.natDegree × Fin g.natDegree →₀ R) : + adjoinRootTowerSemanticNormalForm f hf g hg + (adjoinRootTowerSemanticNormalFormEvaluation f hf g hg c) = c := by + exact LinearEquiv.apply_symm_apply _ c + +@[simp] +theorem adjoinRootTowerSemanticNormalForm_zero + {R : Type*} [CommRing R] (f : R[X]) (hf : f.Monic) + (g : Polynomial (AdjoinRoot f)) (hg : g.Monic) : + adjoinRootTowerSemanticNormalForm f hf g hg 0 = 0 := by + exact map_zero _ + +@[simp] +theorem adjoinRootTowerSemanticNormalFormEvaluation_zero + {R : Type*} [CommRing R] (f : R[X]) (hf : f.Monic) + (g : Polynomial (AdjoinRoot f)) (hg : g.Monic) : + adjoinRootTowerSemanticNormalFormEvaluation f hf g hg 0 = 0 := by + exact map_zero _ + +theorem adjoinRootTowerSemanticNormalForm_injective + {R : Type*} [CommRing R] (f : R[X]) (hf : f.Monic) + (g : Polynomial (AdjoinRoot f)) (hg : g.Monic) : + Function.Injective (adjoinRootTowerSemanticNormalForm f hf g hg) := + ((AdjoinRoot.powerBasis' hf).basis.smulTower + (AdjoinRoot.powerBasis' hg).basis).repr.injective + +variable {K : Type*} [Field K] + +section TraceCover + +variable (sigma : K) (hsigma : sigma ≠ 0) (e d : ℕ) + (heOdd : Odd e) (hdOdd : Odd d) (hde : d.Coprime e) + +private lemma etaExponent_ne_zero (e : ℕ) (heOdd : Odd e) : e ≠ 0 := by + rintro rfl + simp at heOdd + +private lemma xiExponent_ne_zero (d : ℕ) (hdOdd : Odd d) : d ≠ 0 := by + rintro rfl + simp at hdOdd + +/-- Semantic rectangular coefficients of an affine trace-cover class. -/ +def splitTraceAffineSemanticNormalForm + (a : SplitTraceAffineCoordinateRing K sigma d e) : + Fin (splitTraceEtaKummerPolynomial sigma e).natDegree × + Fin (splitTraceXiKummerPolynomial sigma e d).natDegree →₀ + AdjoinRoot (splitTraceBaseKummerPolynomial sigma) := + adjoinRootTowerSemanticNormalForm + (splitTraceEtaKummerPolynomial sigma e) + (splitTraceEtaKummerPolynomial_monic sigma e + (by exact etaExponent_ne_zero e heOdd)) + (splitTraceXiKummerPolynomial sigma e d) + (splitTraceXiKummerPolynomial_monic sigma e d + (by exact xiExponent_ne_zero d hdOdd)) + (splitTraceAffineToKummerTop sigma hsigma e d heOdd hdOdd hde a) + +/-- Evaluating the affine semantic normal form recovers the affine comparison-map image. -/ +theorem splitTraceAffineSemanticNormalForm_evaluation + (a : SplitTraceAffineCoordinateRing K sigma d e) : + adjoinRootTowerSemanticNormalFormEvaluation + (splitTraceEtaKummerPolynomial sigma e) + (splitTraceEtaKummerPolynomial_monic sigma e + (by exact etaExponent_ne_zero e heOdd)) + (splitTraceXiKummerPolynomial sigma e d) + (splitTraceXiKummerPolynomial_monic sigma e d + (by exact xiExponent_ne_zero d hdOdd)) + (splitTraceAffineSemanticNormalForm sigma hsigma e d heOdd hdOdd hde a) = + splitTraceAffineToKummerTop sigma hsigma e d heOdd hdOdd hde a := by + exact adjoinRootTowerSemanticNormalForm_evaluation _ _ _ _ _ + +/-- The affine semantic normal form has zero coefficients exactly when its Kummer image is zero. -/ +theorem splitTraceAffineSemanticNormalForm_eq_zero_iff + (a : SplitTraceAffineCoordinateRing K sigma d e) : + splitTraceAffineSemanticNormalForm sigma hsigma e d heOdd hdOdd hde a = 0 ↔ + splitTraceAffineToKummerTop sigma hsigma e d heOdd hdOdd hde a = 0 := by + let f := splitTraceEtaKummerPolynomial sigma e + let hf := splitTraceEtaKummerPolynomial_monic sigma e (by exact etaExponent_ne_zero e heOdd) + let g := splitTraceXiKummerPolynomial sigma e d + let hg := splitTraceXiKummerPolynomial_monic sigma e d (by exact xiExponent_ne_zero d hdOdd) + change adjoinRootTowerSemanticNormalForm f hf g hg + (splitTraceAffineToKummerTop sigma hsigma e d heOdd hdOdd hde a) = 0 ↔ _ + constructor + · intro h + have hEval := congrArg (adjoinRootTowerSemanticNormalFormEvaluation f hf g hg) h + simpa only [adjoinRootTowerSemanticNormalForm_evaluation, + adjoinRootTowerSemanticNormalFormEvaluation_zero] using hEval + · intro h + rw [h] + exact map_zero _ + +/-- Affine comparison-map injectivity is now exactly injectivity of the semantic coefficient map. +The forward implication is useful once a syntactic quotient reduction proves coefficient-map +injectivity; the converse prevents semantic coordinates from concealing the original wall. -/ +theorem splitTraceAffineSemanticNormalForm_injective_iff : + Function.Injective + (splitTraceAffineSemanticNormalForm sigma hsigma e d heOdd hdOdd hde) ↔ + Function.Injective + (splitTraceAffineToKummerTop sigma hsigma e d heOdd hdOdd hde) := by + let f := splitTraceEtaKummerPolynomial sigma e + let hf := splitTraceEtaKummerPolynomial_monic sigma e (by exact etaExponent_ne_zero e heOdd) + let g := splitTraceXiKummerPolynomial sigma e d + let hg := splitTraceXiKummerPolynomial_monic sigma e d (by exact xiExponent_ne_zero d hdOdd) + change Function.Injective + (fun a ↦ adjoinRootTowerSemanticNormalForm f hf g hg + (splitTraceAffineToKummerTop sigma hsigma e d heOdd hdOdd hde a)) ↔ _ + constructor + · intro hSemantic a b hab + apply hSemantic + exact congrArg (adjoinRootTowerSemanticNormalForm f hf g hg) hab + · intro hAffine + exact (adjoinRootTowerSemanticNormalForm_injective f hf g hg).comp hAffine + +/-- Semantic rectangular coefficients of a Laurent trace-cover class. -/ +def splitTraceLaurentSemanticNormalForm + (a : SplitTraceLaurentCoordinateRing K sigma d e) : + Fin (splitTraceEtaKummerPolynomial sigma e).natDegree × + Fin (splitTraceXiKummerPolynomial sigma e d).natDegree →₀ + AdjoinRoot (splitTraceBaseKummerPolynomial sigma) := by + let hBaseIrred := splitTraceBaseKummerPolynomial_irreducible sigma hsigma + letI : Fact (Irreducible (splitTraceBaseKummerPolynomial sigma)) := ⟨hBaseIrred⟩ + let hEtaIrred := splitTraceEtaKummerPolynomial_irreducible' sigma hsigma e heOdd + letI : Fact (Irreducible (splitTraceEtaKummerPolynomial sigma e)) := ⟨hEtaIrred⟩ + let hXiIrred := + splitTraceXiKummerPolynomial_irreducible sigma hsigma e d heOdd hdOdd hde + letI : Fact (Irreducible (splitTraceXiKummerPolynomial sigma e d)) := ⟨hXiIrred⟩ + exact adjoinRootTowerSemanticNormalForm + (splitTraceEtaKummerPolynomial sigma e) + (splitTraceEtaKummerPolynomial_monic sigma e + (by exact etaExponent_ne_zero e heOdd)) + (splitTraceXiKummerPolynomial sigma e d) + (splitTraceXiKummerPolynomial_monic sigma e d + (by exact xiExponent_ne_zero d hdOdd)) + (splitTraceLaurentToKummerTop sigma hsigma e d heOdd hdOdd hde a) + +/-- Evaluating the Laurent semantic normal form recovers the Laurent comparison-map image. -/ +theorem splitTraceLaurentSemanticNormalForm_evaluation + (a : SplitTraceLaurentCoordinateRing K sigma d e) : + letI : Fact (Irreducible (splitTraceBaseKummerPolynomial sigma)) := + ⟨splitTraceBaseKummerPolynomial_irreducible sigma hsigma⟩ + letI : Fact (Irreducible (splitTraceEtaKummerPolynomial sigma e)) := + ⟨splitTraceEtaKummerPolynomial_irreducible' sigma hsigma e heOdd⟩ + letI : Fact (Irreducible (splitTraceXiKummerPolynomial sigma e d)) := + ⟨splitTraceXiKummerPolynomial_irreducible sigma hsigma e d heOdd hdOdd hde⟩ + adjoinRootTowerSemanticNormalFormEvaluation + (splitTraceEtaKummerPolynomial sigma e) + (splitTraceEtaKummerPolynomial_monic sigma e + (by exact etaExponent_ne_zero e heOdd)) + (splitTraceXiKummerPolynomial sigma e d) + (splitTraceXiKummerPolynomial_monic sigma e d + (by exact xiExponent_ne_zero d hdOdd)) + (splitTraceLaurentSemanticNormalForm sigma hsigma e d heOdd hdOdd hde a) = + splitTraceLaurentToKummerTop sigma hsigma e d heOdd hdOdd hde a := by + let hBaseIrred := splitTraceBaseKummerPolynomial_irreducible sigma hsigma + let : Fact (Irreducible (splitTraceBaseKummerPolynomial sigma)) := ⟨hBaseIrred⟩ + let hEtaIrred := splitTraceEtaKummerPolynomial_irreducible' sigma hsigma e heOdd + let : Fact (Irreducible (splitTraceEtaKummerPolynomial sigma e)) := ⟨hEtaIrred⟩ + let hXiIrred := + splitTraceXiKummerPolynomial_irreducible sigma hsigma e d heOdd hdOdd hde + let : Fact (Irreducible (splitTraceXiKummerPolynomial sigma e d)) := ⟨hXiIrred⟩ + exact adjoinRootTowerSemanticNormalForm_evaluation _ _ _ _ _ + +/-- Laurent comparison-map injectivity is equivalent to injectivity of its semantic coefficient +map. Thus localization introduces no new target-side ambiguity; the unsolved source-side task is +still the syntactic quotient normal-form theorem. -/ +theorem splitTraceLaurentSemanticNormalForm_injective_iff : + letI : Fact (Irreducible (splitTraceBaseKummerPolynomial sigma)) := + ⟨splitTraceBaseKummerPolynomial_irreducible sigma hsigma⟩ + letI : Fact (Irreducible (splitTraceEtaKummerPolynomial sigma e)) := + ⟨splitTraceEtaKummerPolynomial_irreducible' sigma hsigma e heOdd⟩ + letI : Fact (Irreducible (splitTraceXiKummerPolynomial sigma e d)) := + ⟨splitTraceXiKummerPolynomial_irreducible sigma hsigma e d heOdd hdOdd hde⟩ + Function.Injective + (splitTraceLaurentSemanticNormalForm sigma hsigma e d heOdd hdOdd hde) ↔ + Function.Injective + (splitTraceLaurentToKummerTop sigma hsigma e d heOdd hdOdd hde) := by + let hBaseIrred := splitTraceBaseKummerPolynomial_irreducible sigma hsigma + let : Fact (Irreducible (splitTraceBaseKummerPolynomial sigma)) := ⟨hBaseIrred⟩ + let hEtaIrred := splitTraceEtaKummerPolynomial_irreducible' sigma hsigma e heOdd + let : Fact (Irreducible (splitTraceEtaKummerPolynomial sigma e)) := ⟨hEtaIrred⟩ + let hXiIrred := + splitTraceXiKummerPolynomial_irreducible sigma hsigma e d heOdd hdOdd hde + let : Fact (Irreducible (splitTraceXiKummerPolynomial sigma e d)) := ⟨hXiIrred⟩ + let f := splitTraceEtaKummerPolynomial sigma e + let hf := splitTraceEtaKummerPolynomial_monic sigma e (by exact etaExponent_ne_zero e heOdd) + let g := splitTraceXiKummerPolynomial sigma e d + let hg := splitTraceXiKummerPolynomial_monic sigma e d (by exact xiExponent_ne_zero d hdOdd) + change Function.Injective + (fun a ↦ adjoinRootTowerSemanticNormalForm f hf g hg + (splitTraceLaurentToKummerTop sigma hsigma e d heOdd hdOdd hde a)) ↔ _ + constructor + · intro hSemantic a b hab + apply hSemantic + exact congrArg (adjoinRootTowerSemanticNormalForm f hf g hg) hab + · intro hLaurent + exact (adjoinRootTowerSemanticNormalForm_injective f hf g hg).comp hLaurent + +end TraceCover + +end + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/SyntacticDivisionCriterion.lean b/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/SyntacticDivisionCriterion.lean new file mode 100644 index 0000000000..ba229f274e --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/SyntacticDivisionCriterion.lean @@ -0,0 +1,236 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.SyntacticDivisionObstruction +public import Mathlib.RingTheory.UniqueFactorizationDomain.Basic + +/-! +# An exact criterion for the remaining split trace-cover division theorem + +For `sigma != 0, 1` and odd coprime cover degrees, the source-side syntactic division theorem is +equivalent to two concrete algebraic facts: irreducibility of the cleared affine cover polynomial +and injectivity of the comparison map after inverting the two coordinates. The reverse direction +uses primeness to prove that localization has not killed an affine class. Thus the `sigma = 1` +counterexample cannot be hidden by moving to the Laurent model. +-/ + +@[expose] public section + +namespace BGS.Markoff + +open Polynomial + +noncomputable section + +variable {K : Type*} [Field K] + +section OddCoprime + +variable (sigma : K) (hsigma : sigma ≠ 0) (e d : ℕ) + (heOdd : Odd e) (hdOdd : Odd d) (hde : d.Coprime e) + +private lemma splitTraceCoverPolynomial_ne_zero (hdOdd : Odd d) : + splitTraceCoverPolynomial (1 : K) sigma d e ≠ 0 := by + have hd : d ≠ 0 := by + rintro rfl + simp at hdOdd + intro hzero + have heval := congrArg (MvPolynomial.eval ![0, 1]) hzero + rw [eval_splitTraceCoverPolynomial] at heval + simp [hd] at heval + +private lemma coordinateZero_not_dvd_splitTraceCoverPolynomial + (hdOdd : Odd d) : + ¬ MvPolynomial.X 0 ∣ splitTraceCoverPolynomial (1 : K) sigma d e := by + have hd : d ≠ 0 := by + rintro rfl + simp at hdOdd + intro hdiv + have hmap := map_dvd (MvPolynomial.eval ![0, 1]) hdiv + simp [eval_splitTraceCoverPolynomial, hd] at hmap + +private lemma coordinateOne_not_dvd_splitTraceCoverPolynomial + (hsigma : sigma ≠ 0) (heOdd : Odd e) : + ¬ MvPolynomial.X 1 ∣ splitTraceCoverPolynomial (1 : K) sigma d e := by + have he : e ≠ 0 := by + rintro rfl + simp at heOdd + intro hdiv + have hmap := map_dvd (MvPolynomial.eval ![1, 0]) hdiv + simp [eval_splitTraceCoverPolynomial, he, hsigma] at hmap + +/-- The cleared affine cover polynomial has no coordinate-axis factor. This is the exact +saturation fact needed to pass faithfully from the affine quotient to the Laurent open; it uses +only `sigma ≠ 0` and positivity of the odd cover degrees, not irreducibility. -/ +theorem splitTraceCoverPolynomial_isRelPrime_coordinateProduct : + sigma ≠ 0 → Odd e → Odd d → + IsRelPrime (splitTraceCoverPolynomial (1 : K) sigma d e) + (MvPolynomial.X 0 * MvPolynomial.X 1) := by + intro hsigma heOdd hdOdd + apply (UniqueFactorizationMonoid.isRelPrime_iff_no_prime_factors + (splitTraceCoverPolynomial_ne_zero sigma e d hdOdd)).2 + intro q hqCover hqProduct hqPrime + rcases hqPrime.dvd_mul.mp hqProduct with hqZero | hqOne + · have hassociated := hqPrime.associated_of_dvd + (MvPolynomial.X_prime (i := (0 : Fin 2))) hqZero + exact coordinateZero_not_dvd_splitTraceCoverPolynomial sigma e d hdOdd + (hassociated.dvd_iff_dvd_left.mp hqCover) + · have hassociated := hqPrime.associated_of_dvd + (MvPolynomial.X_prime (i := (1 : Fin 2))) hqOne + exact coordinateOne_not_dvd_splitTraceCoverPolynomial sigma e d hsigma heOdd + (hassociated.dvd_iff_dvd_left.mp hqCover) + +/-- Inverting the coordinate product does not kill any affine trace-cover class. This affine +saturation theorem is independent of the unresolved irreducibility statement. -/ +theorem splitTraceAffineToLaurent_injective : + sigma ≠ 0 → Odd e → Odd d → + Function.Injective + (algebraMap (SplitTraceAffineCoordinateRing K sigma d e) + (SplitTraceLaurentCoordinateRing K sigma d e)) := by + intro hsigma heOdd hdOdd + let I : Ideal (MvPolynomial (Fin 2) K) := + Ideal.span {splitTraceCoverPolynomial (1 : K) sigma d e} + have hregular : splitTraceAffineCoordinateProduct sigma d e ∈ + nonZeroDivisors (SplitTraceAffineCoordinateRing K sigma d e) := by + rw [mem_nonZeroDivisors_iff] + constructor + · intro x hx + obtain ⟨p, rfl⟩ := Ideal.Quotient.mk_surjective x + have hmultiple : splitTraceCoverPolynomial (1 : K) sigma d e ∣ + (MvPolynomial.X 0 * MvPolynomial.X 1) * p := by + rw [← Ideal.mem_span_singleton] + apply Ideal.Quotient.eq_zero_iff_mem.mp + simpa [I, splitTraceAffineCoordinateProduct] using hx + have hp : splitTraceCoverPolynomial (1 : K) sigma d e ∣ p := + (splitTraceCoverPolynomial_isRelPrime_coordinateProduct + sigma e d hsigma heOdd hdOdd).dvd_of_dvd_mul_left hmultiple + apply Ideal.Quotient.eq_zero_iff_mem.mpr + rwa [Ideal.mem_span_singleton] + · intro x hx + obtain ⟨p, rfl⟩ := Ideal.Quotient.mk_surjective x + have hmultiple : splitTraceCoverPolynomial (1 : K) sigma d e ∣ + (MvPolynomial.X 0 * MvPolynomial.X 1) * p := by + rw [← Ideal.mem_span_singleton] + apply Ideal.Quotient.eq_zero_iff_mem.mp + simpa [I, splitTraceAffineCoordinateProduct, mul_comm] using hx + have hp : splitTraceCoverPolynomial (1 : K) sigma d e ∣ p := + (splitTraceCoverPolynomial_isRelPrime_coordinateProduct + sigma e d hsigma heOdd hdOdd).dvd_of_dvd_mul_left hmultiple + apply Ideal.Quotient.eq_zero_iff_mem.mpr + rwa [Ideal.mem_span_singleton] + exact IsLocalization.injective (SplitTraceLaurentCoordinateRing K sigma d e) (by + rw [Submonoid.powers_le] + exact hregular) + +/-- Injectivity of the Laurent comparison already forces injectivity of the affine comparison: +the coordinate-product localization is faithful by the explicit saturation theorem above. -/ +theorem splitTraceAffineToKummerTop_injective_of_laurentInjective + (hLaurent : Function.Injective + (splitTraceLaurentToKummerTop sigma hsigma e d heOdd hdOdd hde)) : + Function.Injective + (splitTraceAffineToKummerTop sigma hsigma e d heOdd hdOdd hde) := by + have hlocalization : Function.Injective + (algebraMap (SplitTraceAffineCoordinateRing K sigma d e) + (SplitTraceLaurentCoordinateRing K sigma d e)) := + splitTraceAffineToLaurent_injective sigma e d hsigma heOdd hdOdd + intro x y hxy + apply hlocalization + apply hLaurent + rw [splitTraceLaurentToKummerTop_algebraMap_apply, + splitTraceLaurentToKummerTop_algebraMap_apply] + exact hxy + +/-- Injectivity on the Laurent open implies the exact source-side syntactic division theorem. -/ +theorem splitTracePolynomialSyntacticNormalForm_division_of_laurentInjective + (hLaurent : Function.Injective + (splitTraceLaurentToKummerTop sigma hsigma e d heOdd hdOdd hde)) + (p : MvPolynomial (Fin 2) K) + (hnormal : splitTracePolynomialSyntacticNormalForm + sigma hsigma e d heOdd hdOdd p = 0) : + p ∈ Ideal.span {splitTraceCoverPolynomial (1 : K) sigma d e} := by + let I : Ideal (MvPolynomial (Fin 2) K) := + Ideal.span {splitTraceCoverPolynomial (1 : K) sigma d e} + have hAffine := + splitTraceAffineToKummerTop_injective_of_laurentInjective + sigma hsigma e d heOdd hdOdd hde hLaurent + have heval : splitTracePolynomialToKummerTop + sigma hsigma e d heOdd hdOdd hde p = 0 := + (splitTracePolynomialSyntacticNormalForm_eq_zero_iff + sigma hsigma e d heOdd hdOdd hde p).1 hnormal + have hclass : Ideal.Quotient.mk I p = 0 := by + apply hAffine + change splitTracePolynomialToKummerTop sigma hsigma e d heOdd hdOdd hde p = 0 + exact heval + exact Ideal.Quotient.eq_zero_iff_mem.mp hclass + +/-- Laurent-to-Kummer injectivity also forces irreducibility of the cleared affine cover. +Indeed the affine quotient injects into the Kummer function field, hence is a domain. -/ +theorem splitTraceCoverPolynomial_irreducible_of_laurentInjective + (hLaurent : Function.Injective + (splitTraceLaurentToKummerTop sigma hsigma e d heOdd hdOdd hde)) : + Irreducible (splitTraceCoverPolynomial (1 : K) sigma d e) := by + let hBaseIrred := splitTraceBaseKummerPolynomial_irreducible sigma hsigma + let : Fact (Irreducible (splitTraceBaseKummerPolynomial sigma)) := ⟨hBaseIrred⟩ + let hEtaIrred := splitTraceEtaKummerPolynomial_irreducible' sigma hsigma e heOdd + let : Fact (Irreducible (splitTraceEtaKummerPolynomial sigma e)) := ⟨hEtaIrred⟩ + let hXiIrred := + splitTraceXiKummerPolynomial_irreducible sigma hsigma e d heOdd hdOdd hde + let : Fact (Irreducible (splitTraceXiKummerPolynomial sigma e d)) := ⟨hXiIrred⟩ + let : IsDomain (SplitTraceXiFunctionField K sigma e d) := + AdjoinRoot.isDomain_of_prime hXiIrred.prime + let I : Ideal (MvPolynomial (Fin 2) K) := + Ideal.span {splitTraceCoverPolynomial (1 : K) sigma d e} + have hAffine := splitTraceAffineToKummerTop_injective_of_laurentInjective + sigma hsigma e d heOdd hdOdd hde hLaurent + let : IsDomain (SplitTraceAffineCoordinateRing K sigma d e) := + hAffine.isDomain + (splitTraceAffineToKummerTop sigma hsigma e d heOdd hdOdd hde).toRingHom + have hprimeIdeal : I.IsPrime := by + exact (Ideal.Quotient.isDomain_iff_prime I).mp inferInstance + have hprimeElement : Prime (splitTraceCoverPolynomial (1 : K) sigma d e) := + (Ideal.span_singleton_prime + (splitTraceCoverPolynomial_ne_zero sigma e d hdOdd)).1 (by + simpa [I] using hprimeIdeal) + exact irreducible_iff_prime.mpr hprimeElement + +/-- Exact characterization of the remaining source-division wall. In the nondegenerate case, +division by the cleared cover polynomial is equivalent to injectivity of the explicit +Laurent-to-Kummer comparison; the affine-to-Laurent map has already been proved faithful. -/ +theorem splitTracePolynomialSyntacticNormalForm_division_iff_laurentInjective + (hnondegenerate : sigma ≠ 1) : + (∀ p : MvPolynomial (Fin 2) K, + splitTracePolynomialSyntacticNormalForm sigma hsigma e d heOdd hdOdd p = 0 → + p ∈ Ideal.span {splitTraceCoverPolynomial (1 : K) sigma d e}) ↔ + Function.Injective + (splitTraceLaurentToKummerTop sigma hsigma e d heOdd hdOdd hde) := by + let hBaseIrred := splitTraceBaseKummerPolynomial_irreducible sigma hsigma + let : Fact (Irreducible (splitTraceBaseKummerPolynomial sigma)) := ⟨hBaseIrred⟩ + let hEtaIrred := splitTraceEtaKummerPolynomial_irreducible' sigma hsigma e heOdd + let : Fact (Irreducible (splitTraceEtaKummerPolynomial sigma e)) := ⟨hEtaIrred⟩ + let hXiIrred := + splitTraceXiKummerPolynomial_irreducible sigma hsigma e d heOdd hdOdd hde + let : Fact (Irreducible (splitTraceXiKummerPolynomial sigma e d)) := ⟨hXiIrred⟩ + let : IsDomain (SplitTraceXiFunctionField K sigma e d) := + AdjoinRoot.isDomain_of_prime hXiIrred.prime + constructor + · intro hdivision + have hAffine := + splitTraceAffineToKummerTop_injective_of_syntacticNormalForm_division + sigma hsigma e d heOdd hdOdd hde hnondegenerate hdivision + have hLaurent := splitTraceLaurentToKummerTop_injective_of_affine_injective + sigma hsigma e d heOdd hdOdd hde hAffine + exact hLaurent + · intro hLaurent p hnormal + exact splitTracePolynomialSyntacticNormalForm_division_of_laurentInjective + sigma hsigma e d heOdd hdOdd hde hLaurent p hnormal + +end OddCoprime + +end + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/SyntacticDivisionObstruction.lean b/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/SyntacticDivisionObstruction.lean new file mode 100644 index 0000000000..4c819272cb --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/SyntacticDivisionObstruction.lean @@ -0,0 +1,144 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.SyntacticNormalForm + +/-! +# The degenerate split trace cover has no principal syntactic division theorem + +At `sigma = 1` and `d = e = 1`, the cleared cover polynomial is the product +`(y - x) * (x * y - 1)`. The Kummer tower selects the component `x * y = 1`. +Consequently its evaluation kernel strictly contains the ideal generated by the whole cleared +polynomial. This file records that obstruction explicitly: the source-side division statement +must assume the nondegeneracy condition `sigma != 1`. +-/ + +@[expose] public section + +namespace BGS.Markoff + +open Polynomial + +noncomputable section + +variable {K : Type*} [Field K] + +/-- The component selected by the Kummer parametrization when `sigma = d = e = 1`. -/ +def splitTraceDegenerateKummerComponent : MvPolynomial (Fin 2) K := + MvPolynomial.X 0 * MvPolynomial.X 1 - 1 + +private lemma ratFunc_X_mul_splitTraceRadicand_one : + RatFunc.X * splitTraceRadicand (1 : K) = 1 := by + have h := splitTraceRadicand_equation (K := K) (1 : K) + norm_num at h + have hne : (1 : RatFunc K) - RatFunc.X ≠ 0 := by + intro hzero + have hx : (1 : RatFunc K) = RatFunc.X := sub_eq_zero.mp hzero + have hdegree := congrArg RatFunc.intDegree hx + norm_num at hdegree + have hfactor : + ((1 : RatFunc K) - RatFunc.X) * + (RatFunc.X * splitTraceRadicand (1 : K) - 1) = 0 := by + linear_combination h + exact sub_eq_zero.mp ((mul_eq_zero.mp hfactor).resolve_left hne) + +private lemma splitTraceBaseU_mul_V_sq_one : + splitTraceBaseU (1 : K) * splitTraceBaseV (1 : K) ^ 2 = 1 := by + rw [splitTraceBaseV_sq] + rw [splitTraceBaseU, ← map_mul, ratFunc_X_mul_splitTraceRadicand_one] + simp + +private lemma splitTraceKummer_roots_mul_one : + splitTraceXiRoot (1 : K) 1 1 * splitTraceEtaRootInXiField (1 : K) 1 1 = 1 := by + have hxi := splitTraceXiRoot_pow (K := K) (1 : K) 1 1 + have heta := splitTraceEtaRootInXiField_pow (K := K) (1 : K) 1 1 + simp only [pow_one] at hxi heta + rw [hxi, heta] + simp only [splitTraceXiRadicand, splitTraceBaseElementInXiField, map_mul] + rw [← map_mul] + rw [← map_mul] + rw [← map_mul] + rw [← map_mul] + rw [show splitTraceBaseU (1 : K) * splitTraceBaseV (1 : K) * + splitTraceBaseV (1 : K) = + splitTraceBaseU (1 : K) * splitTraceBaseV (1 : K) ^ 2 by ring] + rw [splitTraceBaseU_mul_V_sq_one] + simp + +/-- The Kummer-selected component has zero syntactic normal form. -/ +theorem splitTraceDegenerateKummerComponent_syntacticNormalForm_eq_zero : + splitTracePolynomialSyntacticNormalForm (1 : K) one_ne_zero 1 1 + (by decide) (by decide) (splitTraceDegenerateKummerComponent (K := K)) = 0 := by + apply (splitTracePolynomialSyntacticNormalForm_eq_zero_iff + (1 : K) one_ne_zero 1 1 (by decide) (by decide) (by decide) + (splitTraceDegenerateKummerComponent (K := K))).2 + simp [splitTraceDegenerateKummerComponent, splitTracePolynomialToKummerTop, + splitTraceKummer_roots_mul_one] + +/-- The Kummer-selected component is not a multiple of the full degenerate cover polynomial. +Evaluation at the affine origin separates them. -/ +theorem splitTraceDegenerateKummerComponent_not_mem_coverIdeal : + splitTraceDegenerateKummerComponent (K := K) ∉ + Ideal.span {splitTraceCoverPolynomial (1 : K) 1 1 1} := by + intro hmem + let ev : MvPolynomial (Fin 2) K →+* K := MvPolynomial.eval ![0, 0] + have hle : Ideal.span {splitTraceCoverPolynomial (1 : K) 1 1 1} ≤ RingHom.ker ev := by + rw [Ideal.span_le] + intro p hp + simp only [Set.mem_singleton_iff] at hp + subst p + simp [ev, splitTraceCoverPolynomial] + have hzero := hle hmem + have hone : ev (splitTraceDegenerateKummerComponent (K := K)) = -1 := by + simp [ev, splitTraceDegenerateKummerComponent] + rw [RingHom.mem_ker, hone] at hzero + exact one_ne_zero (neg_eq_zero.mp hzero) + +/-- Therefore the source-side division assertion used by the affine injectivity endpoint is false +without the paper's nondegeneracy hypothesis `sigma != 1`. -/ +theorem not_splitTraceSyntacticNormalForm_division_at_degenerateParameter : + ¬ (∀ p : MvPolynomial (Fin 2) K, + splitTracePolynomialSyntacticNormalForm (1 : K) one_ne_zero 1 1 + (by decide) (by decide) p = 0 → + p ∈ Ideal.span {splitTraceCoverPolynomial (1 : K) 1 1 1}) := by + intro hdivision + exact splitTraceDegenerateKummerComponent_not_mem_coverIdeal (K := K) + (hdivision (splitTraceDegenerateKummerComponent (K := K)) + splitTraceDegenerateKummerComponent_syntacticNormalForm_eq_zero) + +/-- At the degenerate parameter, the affine comparison map itself is not injective: the nonzero +class of `x * y - 1` maps to zero. -/ +theorem not_splitTraceAffineToKummerTop_injective_at_degenerateParameter : + ¬ Function.Injective + (splitTraceAffineToKummerTop (1 : K) one_ne_zero 1 1 + (by decide) (by decide) (by decide)) := by + intro hinjective + let I : Ideal (MvPolynomial (Fin 2) K) := + Ideal.span {splitTraceCoverPolynomial (1 : K) 1 1 1} + let q : MvPolynomial (Fin 2) K := splitTraceDegenerateKummerComponent + have hqeval : + splitTracePolynomialToKummerTop (1 : K) one_ne_zero 1 1 + (by decide) (by decide) (by decide) q = 0 := + (splitTracePolynomialSyntacticNormalForm_eq_zero_iff + (1 : K) one_ne_zero 1 1 (by decide) (by decide) (by decide) q).1 + splitTraceDegenerateKummerComponent_syntacticNormalForm_eq_zero + have hqmap : + splitTraceAffineToKummerTop (1 : K) one_ne_zero 1 1 + (by decide) (by decide) (by decide) (Ideal.Quotient.mk I q) = 0 := by + change splitTracePolynomialToKummerTop (1 : K) one_ne_zero 1 1 + (by decide) (by decide) (by decide) q = 0 + exact hqeval + have hqclass : Ideal.Quotient.mk I q = 0 := by + apply hinjective + simpa using hqmap + have hqmem : q ∈ I := Ideal.Quotient.eq_zero_iff_mem.mp hqclass + exact splitTraceDegenerateKummerComponent_not_mem_coverIdeal hqmem + +end + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/SyntacticNormalForm.lean b/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/SyntacticNormalForm.lean new file mode 100644 index 0000000000..47252dff84 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/SyntacticNormalForm.lean @@ -0,0 +1,396 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.SemanticNormalForm +public import Mathlib.RingTheory.Ideal.Quotient.Operations + +/-! +# Syntactic monomial reduction for the split trace cover + +This file starts the source-side quotient reduction. A monomial `xi^i * eta^j` is reduced by +Euclidean division of `i` by `d` and `j` by `e`. Its rectangular basis index is +`(j % e, i % d)`, and its coefficient in the quadratic base function field is +`u^(i / d) * v^(i / d + j / e)`. +-/ + +@[expose] public section + +namespace BGS.Markoff + +open Polynomial + +noncomputable section + +theorem pow_eq_pow_div_mul_pow_mod + {M : Type*} [Monoid M] (x : M) (n q : ℕ) : + x ^ n = (x ^ q) ^ (n / q) * x ^ (n % q) := by + calc + x ^ n = x ^ (q * (n / q) + n % q) := by rw [Nat.div_add_mod n q] + _ = x ^ (q * (n / q)) * x ^ (n % q) := by rw [pow_add] + _ = (x ^ q) ^ (n / q) * x ^ (n % q) := by + rw [pow_mul] + +variable {K : Type*} [Field K] + +section OddCoprime + +variable (sigma : K) (hsigma : sigma ≠ 0) (e d : ℕ) + (heOdd : Odd e) (hdOdd : Odd d) (hde : d.Coprime e) + +private lemma etaExponent_pos (e : ℕ) (heOdd : Odd e) : 0 < e := by + rcases heOdd with ⟨k, rfl⟩ + omega + +private lemma xiExponent_pos (d : ℕ) (hdOdd : Odd d) : 0 < d := by + rcases hdOdd with ⟨k, rfl⟩ + omega + +private lemma etaExponent_ne_zero (e : ℕ) (heOdd : Odd e) : e ≠ 0 := + (etaExponent_pos e heOdd).ne' + +private lemma xiExponent_ne_zero (d : ℕ) (hdOdd : Odd d) : d ≠ 0 := + (xiExponent_pos d hdOdd).ne' + +theorem splitTraceEtaKummerPolynomial_natDegree + (sigma : K) (hsigma : sigma ≠ 0) (e : ℕ) : + letI : Fact (Irreducible (splitTraceBaseKummerPolynomial sigma)) := + ⟨splitTraceBaseKummerPolynomial_irreducible sigma hsigma⟩ + (splitTraceEtaKummerPolynomial sigma e).natDegree = e := by + let hBaseIrred := splitTraceBaseKummerPolynomial_irreducible sigma hsigma + let : Fact (Irreducible (splitTraceBaseKummerPolynomial sigma)) := ⟨hBaseIrred⟩ + change (X ^ e - C (splitTraceBaseV sigma)).natDegree = e + exact natDegree_X_pow_sub_C + +theorem splitTraceXiKummerPolynomial_natDegree + (sigma : K) (hsigma : sigma ≠ 0) (e d : ℕ) (heOdd : Odd e) : + letI : Fact (Irreducible (splitTraceBaseKummerPolynomial sigma)) := + ⟨splitTraceBaseKummerPolynomial_irreducible sigma hsigma⟩ + letI : Fact (Irreducible (splitTraceEtaKummerPolynomial sigma e)) := + ⟨splitTraceEtaKummerPolynomial_irreducible' sigma hsigma e heOdd⟩ + (splitTraceXiKummerPolynomial sigma e d).natDegree = d := by + let hBaseIrred := splitTraceBaseKummerPolynomial_irreducible sigma hsigma + let : Fact (Irreducible (splitTraceBaseKummerPolynomial sigma)) := ⟨hBaseIrred⟩ + let hEtaIrred := splitTraceEtaKummerPolynomial_irreducible' sigma hsigma e heOdd + let : Fact (Irreducible (splitTraceEtaKummerPolynomial sigma e)) := ⟨hEtaIrred⟩ + change (X ^ d - C (splitTraceXiRadicand sigma e)).natDegree = d + exact natDegree_X_pow_sub_C + +/-- Residual rectangular index of the monomial `xi^i * eta^j`. -/ +def splitTraceMonomialNormalIndex (i j : ℕ) : + Fin (splitTraceEtaKummerPolynomial sigma e).natDegree × + Fin (splitTraceXiKummerPolynomial sigma e d).natDegree := by + let hBaseIrred := splitTraceBaseKummerPolynomial_irreducible sigma hsigma + letI : Fact (Irreducible (splitTraceBaseKummerPolynomial sigma)) := ⟨hBaseIrred⟩ + let hEtaIrred := splitTraceEtaKummerPolynomial_irreducible' sigma hsigma e heOdd + letI : Fact (Irreducible (splitTraceEtaKummerPolynomial sigma e)) := ⟨hEtaIrred⟩ + exact (⟨j % e, by + rw [splitTraceEtaKummerPolynomial_natDegree sigma hsigma e] + exact Nat.mod_lt _ (etaExponent_pos e heOdd)⟩, + ⟨i % d, by + rw [splitTraceXiKummerPolynomial_natDegree sigma hsigma e d heOdd] + exact Nat.mod_lt _ (xiExponent_pos d hdOdd)⟩) + +@[simp] +theorem splitTraceMonomialNormalIndex_fst_val (i j : ℕ) : + (splitTraceMonomialNormalIndex sigma hsigma e d heOdd hdOdd i j).1.val = j % e := by + rfl + +@[simp] +theorem splitTraceMonomialNormalIndex_snd_val (i j : ℕ) : + (splitTraceMonomialNormalIndex sigma hsigma e d heOdd hdOdd i j).2.val = i % d := by + rfl + +/-- Base-function-field coefficient extracted from `xi^i * eta^j`. -/ +def splitTraceMonomialNormalCoefficient (i j : ℕ) : + SplitTraceBaseFunctionField K sigma := + splitTraceBaseU sigma ^ (i / d) * + splitTraceBaseV sigma ^ (i / d + j / e) + +/-- Evaluate a rectangular coefficient vector by the explicit normal monomial family. -/ +def splitTraceExplicitNormalFormEvaluation + (c : (Fin (splitTraceEtaKummerPolynomial sigma e).natDegree × + Fin (splitTraceXiKummerPolynomial sigma e d).natDegree) →₀ + AdjoinRoot (splitTraceBaseKummerPolynomial sigma)) : + SplitTraceXiFunctionField K sigma e d := by + letI : CommRing (AdjoinRoot (splitTraceBaseKummerPolynomial sigma)) := + AdjoinRoot.instCommRing _ + letI : CommRing (AdjoinRoot (splitTraceEtaKummerPolynomial sigma e)) := + AdjoinRoot.instCommRing _ + letI : CommRing (AdjoinRoot (splitTraceXiKummerPolynomial sigma e d)) := + AdjoinRoot.instCommRing _ + exact Finsupp.linearCombination (AdjoinRoot (splitTraceBaseKummerPolynomial sigma)) + (fun ji ↦ splitTraceEtaRootInXiField sigma e d ^ (ji.1 : ℕ) * + splitTraceXiRoot sigma e d ^ (ji.2 : ℕ)) c + +/-- Explicit source-side rectangular coefficients of a polynomial in the two affine coordinates. +Each source monomial is reduced independently by quotient and remainder of its two exponents. -/ +def splitTracePolynomialSyntacticNormalForm + (sigma : K) (hsigma : sigma ≠ 0) (e d : ℕ) + (heOdd : Odd e) (hdOdd : Odd d) + (p : MvPolynomial (Fin 2) K) : + (Fin (splitTraceEtaKummerPolynomial sigma e).natDegree × + Fin (splitTraceXiKummerPolynomial sigma e d).natDegree) →₀ + AdjoinRoot (splitTraceBaseKummerPolynomial sigma) := + (AddMonoidAlgebra.coeff p).sum fun ex c ↦ + Finsupp.single + (splitTraceMonomialNormalIndex sigma hsigma e d heOdd hdOdd (ex 0) (ex 1)) + (algebraMap K (AdjoinRoot (splitTraceBaseKummerPolynomial sigma)) c * + splitTraceMonomialNormalCoefficient sigma e d (ex 0) (ex 1)) + +@[simp] +theorem splitTracePolynomialSyntacticNormalForm_zero : + splitTracePolynomialSyntacticNormalForm sigma hsigma e d heOdd hdOdd 0 = 0 := by + simp [splitTracePolynomialSyntacticNormalForm] + +theorem splitTracePolynomialSyntacticNormalForm_add + (p q : MvPolynomial (Fin 2) K) : + splitTracePolynomialSyntacticNormalForm sigma hsigma e d heOdd hdOdd (p + q) = + splitTracePolynomialSyntacticNormalForm sigma hsigma e d heOdd hdOdd p + + splitTracePolynomialSyntacticNormalForm sigma hsigma e d heOdd hdOdd q := by + classical + simp only [splitTracePolynomialSyntacticNormalForm] + apply Finsupp.sum_add_index + · intro ex + simp + · intro ex _ a b + simp only [map_add, add_mul, Finsupp.single_add] + +@[simp] +theorem splitTracePolynomialSyntacticNormalForm_monomial + (ex : Fin 2 →₀ ℕ) (c : K) : + splitTracePolynomialSyntacticNormalForm sigma hsigma e d heOdd hdOdd + (MvPolynomial.monomial ex c) = + Finsupp.single + (splitTraceMonomialNormalIndex sigma hsigma e d heOdd hdOdd (ex 0) (ex 1)) + (algebraMap K (AdjoinRoot (splitTraceBaseKummerPolynomial sigma)) c * + splitTraceMonomialNormalCoefficient sigma e d (ex 0) (ex 1)) := by + rw [splitTracePolynomialSyntacticNormalForm] + apply MvPolynomial.sum_monomial_eq + simp + +lemma splitTraceEtaRootInXiField_pow : + splitTraceEtaRootInXiField sigma e d ^ e = + splitTraceBaseElementInXiField sigma e d (splitTraceBaseV sigma) := by + have h := congrArg + (algebraMap (SplitTraceEtaFunctionField K sigma e) + (SplitTraceXiFunctionField K sigma e d)) + (splitTraceEtaRoot_pow (K := K) sigma e) + simpa [splitTraceEtaRootInXiField, splitTraceBaseElementInXiField] using h + +/-- Explicit source-side monomial reduction in the Kummer top algebra. -/ +theorem splitTraceKummer_monomial_reduction + (sigma : K) (e d i j : ℕ) : + splitTraceXiRoot sigma e d ^ i * splitTraceEtaRootInXiField sigma e d ^ j = + splitTraceBaseElementInXiField sigma e d + (splitTraceMonomialNormalCoefficient sigma e d i j) * + (splitTraceEtaRootInXiField sigma e d ^ (j % e) * + splitTraceXiRoot sigma e d ^ (i % d)) := by + rw [pow_eq_pow_div_mul_pow_mod _ i d, + pow_eq_pow_div_mul_pow_mod _ j e, + splitTraceXiRoot_pow, splitTraceEtaRootInXiField_pow] + simp only [splitTraceXiRadicand, splitTraceMonomialNormalCoefficient, + splitTraceBaseElementInXiField, map_mul, map_pow] + ring + +/-- The explicit normal-form evaluation of the singleton produced from a source monomial is the +original monomial in the Kummer top algebra. -/ +theorem splitTraceExplicitNormalFormEvaluation_single_monomial (i j : ℕ) : + splitTraceExplicitNormalFormEvaluation sigma e d + (Finsupp.single + (splitTraceMonomialNormalIndex sigma hsigma e d heOdd hdOdd i j) + (splitTraceMonomialNormalCoefficient sigma e d i j)) = + splitTraceXiRoot sigma e d ^ i * splitTraceEtaRootInXiField sigma e d ^ j := by + let : CommRing (AdjoinRoot (splitTraceBaseKummerPolynomial sigma)) := + AdjoinRoot.instCommRing _ + let : CommRing (AdjoinRoot (splitTraceEtaKummerPolynomial sigma e)) := + AdjoinRoot.instCommRing _ + let : CommRing (AdjoinRoot (splitTraceXiKummerPolynomial sigma e d)) := + AdjoinRoot.instCommRing _ + rw [splitTraceExplicitNormalFormEvaluation, Finsupp.linearCombination_single] + simp only [Algebra.smul_def, splitTraceMonomialNormalIndex_fst_val, + splitTraceMonomialNormalIndex_snd_val] + rw [IsScalarTower.algebraMap_apply + (AdjoinRoot (splitTraceBaseKummerPolynomial sigma)) + (AdjoinRoot (splitTraceEtaKummerPolynomial sigma e)) + (AdjoinRoot (splitTraceXiKummerPolynomial sigma e d))] + simpa [splitTraceBaseElementInXiField] using + (splitTraceKummer_monomial_reduction (K := K) sigma e d i j).symm + +/-- Including the source coefficient, explicit evaluation of the syntactic singleton agrees with +evaluation of the original source monomial. -/ +theorem splitTraceExplicitNormalFormEvaluation_single_scaled_monomial + (c : K) (i j : ℕ) : + splitTraceExplicitNormalFormEvaluation sigma e d + (Finsupp.single + (splitTraceMonomialNormalIndex sigma hsigma e d heOdd hdOdd i j) + (algebraMap K (AdjoinRoot (splitTraceBaseKummerPolynomial sigma)) c * + splitTraceMonomialNormalCoefficient sigma e d i j)) = + algebraMap K (SplitTraceXiFunctionField K sigma e d) c * + (splitTraceXiRoot sigma e d ^ i * splitTraceEtaRootInXiField sigma e d ^ j) := by + let : CommRing (AdjoinRoot (splitTraceBaseKummerPolynomial sigma)) := + AdjoinRoot.instCommRing _ + let : CommRing (AdjoinRoot (splitTraceEtaKummerPolynomial sigma e)) := + AdjoinRoot.instCommRing _ + let : CommRing (AdjoinRoot (splitTraceXiKummerPolynomial sigma e d)) := + AdjoinRoot.instCommRing _ + rw [splitTraceExplicitNormalFormEvaluation, Finsupp.linearCombination_single] + simp only [Algebra.smul_def, splitTraceMonomialNormalIndex_fst_val, + splitTraceMonomialNormalIndex_snd_val, map_mul] + have hred := (splitTraceKummer_monomial_reduction + (K := K) sigma e d i j).symm + rw [← hred] + simp only [splitTraceBaseElementInXiField] + simp_rw [IsScalarTower.algebraMap_apply K + (AdjoinRoot (splitTraceBaseKummerPolynomial sigma)) + (AdjoinRoot (splitTraceXiKummerPolynomial sigma e d))] + simp_rw [IsScalarTower.algebraMap_apply + (AdjoinRoot (splitTraceBaseKummerPolynomial sigma)) + (AdjoinRoot (splitTraceEtaKummerPolynomial sigma e)) + (AdjoinRoot (splitTraceXiKummerPolynomial sigma e d))] + ring + +theorem splitTracePolynomialToKummerTop_monomial + (ex : Fin 2 →₀ ℕ) (c : K) : + splitTracePolynomialToKummerTop sigma hsigma e d heOdd hdOdd hde + (MvPolynomial.monomial ex c) = + algebraMap K (SplitTraceXiFunctionField K sigma e d) c * + (splitTraceXiRoot sigma e d ^ (ex 0) * + splitTraceEtaRootInXiField sigma e d ^ (ex 1)) := by + simp [splitTracePolynomialToKummerTop, MvPolynomial.aeval_def, + MvPolynomial.eval₂_monomial, Fin.prod_univ_two] + +/-- Evaluation of the explicit syntactic coefficient vector agrees with direct polynomial +evaluation at the two Kummer roots. -/ +theorem splitTracePolynomialSyntacticNormalForm_evaluation + (p : MvPolynomial (Fin 2) K) : + splitTraceExplicitNormalFormEvaluation sigma e d + (splitTracePolynomialSyntacticNormalForm sigma hsigma e d heOdd hdOdd p) = + splitTracePolynomialToKummerTop sigma hsigma e d heOdd hdOdd hde p := by + induction p using MvPolynomial.induction_on' with + | monomial ex c => + rw [splitTracePolynomialSyntacticNormalForm_monomial, + splitTraceExplicitNormalFormEvaluation_single_scaled_monomial, + splitTracePolynomialToKummerTop_monomial] + | add p q hp hq => + rw [splitTracePolynomialSyntacticNormalForm_add] + change Finsupp.linearCombination + (AdjoinRoot (splitTraceBaseKummerPolynomial sigma)) + (fun ji ↦ splitTraceEtaRootInXiField sigma e d ^ (ji.1 : ℕ) * + splitTraceXiRoot sigma e d ^ (ji.2 : ℕ)) + (splitTracePolynomialSyntacticNormalForm sigma hsigma e d heOdd hdOdd p + + splitTracePolynomialSyntacticNormalForm sigma hsigma e d heOdd hdOdd q) = _ + change Finsupp.linearCombination + (AdjoinRoot (splitTraceBaseKummerPolynomial sigma)) + (fun ji ↦ splitTraceEtaRootInXiField sigma e d ^ (ji.1 : ℕ) * + splitTraceXiRoot sigma e d ^ (ji.2 : ℕ)) + (splitTracePolynomialSyntacticNormalForm sigma hsigma e d heOdd hdOdd p) = _ at hp + change Finsupp.linearCombination + (AdjoinRoot (splitTraceBaseKummerPolynomial sigma)) + (fun ji ↦ splitTraceEtaRootInXiField sigma e d ^ (ji.1 : ℕ) * + splitTraceXiRoot sigma e d ^ (ji.2 : ℕ)) + (splitTracePolynomialSyntacticNormalForm sigma hsigma e d heOdd hdOdd q) = _ at hq + rw [map_add, hp, hq, map_add] + +/-- The committed normal-monomial independence theorem makes explicit normal-form evaluation +injective. -/ +theorem splitTraceExplicitNormalFormEvaluation_eq_zero_iff + (sigma : K) (e d : ℕ) (heOdd : Odd e) (hdOdd : Odd d) (hde : d.Coprime e) + (c : (Fin (splitTraceEtaKummerPolynomial sigma e).natDegree × + Fin (splitTraceXiKummerPolynomial sigma e d).natDegree) →₀ + AdjoinRoot (splitTraceBaseKummerPolynomial sigma)) : + letI : CommRing (AdjoinRoot (splitTraceBaseKummerPolynomial sigma)) := + AdjoinRoot.instCommRing _ + letI : CommRing (AdjoinRoot (splitTraceEtaKummerPolynomial sigma e)) := + AdjoinRoot.instCommRing _ + letI : CommRing (AdjoinRoot (splitTraceXiKummerPolynomial sigma e d)) := + AdjoinRoot.instCommRing _ + splitTraceExplicitNormalFormEvaluation sigma e d c = 0 ↔ c = 0 := by + let : CommRing (AdjoinRoot (splitTraceBaseKummerPolynomial sigma)) := + AdjoinRoot.instCommRing _ + let : CommRing (AdjoinRoot (splitTraceEtaKummerPolynomial sigma e)) := + AdjoinRoot.instCommRing _ + let : CommRing (AdjoinRoot (splitTraceXiKummerPolynomial sigma e d)) := + AdjoinRoot.instCommRing _ + change Finsupp.linearCombination (AdjoinRoot (splitTraceBaseKummerPolynomial sigma)) + (fun ji ↦ splitTraceEtaRootInXiField sigma e d ^ (ji.1 : ℕ) * + splitTraceXiRoot sigma e d ^ (ji.2 : ℕ)) c = 0 ↔ c = 0 + exact splitTraceEtaXiNormalForm_evaluation_eq_zero_iff + sigma e d heOdd hdOdd hde c + +/-- A source polynomial has zero syntactic normal form exactly when its evaluation at the Kummer +roots vanishes. The remaining injectivity wall is to identify this explicit zero condition with +membership in the principal ideal generated by the trace-cover polynomial. -/ +theorem splitTracePolynomialSyntacticNormalForm_eq_zero_iff + (p : MvPolynomial (Fin 2) K) : + splitTracePolynomialSyntacticNormalForm sigma hsigma e d heOdd hdOdd p = 0 ↔ + splitTracePolynomialToKummerTop sigma hsigma e d heOdd hdOdd hde p = 0 := by + rw [← splitTracePolynomialSyntacticNormalForm_evaluation + sigma hsigma e d heOdd hdOdd hde p] + exact (splitTraceExplicitNormalFormEvaluation_eq_zero_iff + sigma e d heOdd hdOdd hde + (splitTracePolynomialSyntacticNormalForm sigma hsigma e d heOdd hdOdd p)).symm + +/-- For a nondegenerate trace parameter, the remaining source-side division theorem is sufficient +for injectivity of the affine comparison map. The division hypothesis is deliberately an ordinary +explicit proposition: it is not an assumed declaration, typeclass, or structure field. The +condition `sigma ≠ 1` is essential: at `sigma = 1` the cleared cover factors and the Kummer tower +selects only one component; see `TraceCurveSyntacticDivisionObstruction`. -/ +theorem splitTraceAffineToKummerTop_injective_of_syntacticNormalForm_division + (_hnondegenerate : sigma ≠ 1) + (hdivision : ∀ p : MvPolynomial (Fin 2) K, + splitTracePolynomialSyntacticNormalForm sigma hsigma e d heOdd hdOdd p = 0 → + p ∈ Ideal.span {splitTraceCoverPolynomial (1 : K) sigma d e}) : + Function.Injective + (splitTraceAffineToKummerTop sigma hsigma e d heOdd hdOdd hde) := by + let hBaseIrred := splitTraceBaseKummerPolynomial_irreducible sigma hsigma + let : Fact (Irreducible (splitTraceBaseKummerPolynomial sigma)) := ⟨hBaseIrred⟩ + let hEtaIrred := splitTraceEtaKummerPolynomial_irreducible' sigma hsigma e heOdd + let : Fact (Irreducible (splitTraceEtaKummerPolynomial sigma e)) := ⟨hEtaIrred⟩ + let hXiIrred := + splitTraceXiKummerPolynomial_irreducible sigma hsigma e d heOdd hdOdd hde + let : Fact (Irreducible (splitTraceXiKummerPolynomial sigma e d)) := ⟨hXiIrred⟩ + let I : Ideal (MvPolynomial (Fin 2) K) := + Ideal.span {splitTraceCoverPolynomial (1 : K) sigma d e} + let f : MvPolynomial (Fin 2) K →+* + SplitTraceXiFunctionField K sigma e d := + (splitTracePolynomialToKummerTop sigma hsigma e d heOdd hdOdd hde).toRingHom + have hIdeal : ∀ p : MvPolynomial (Fin 2) K, p ∈ I → f p = 0 := by + have hle : I ≤ RingHom.ker f := by + dsimp [I] + rw [Ideal.span_le] + intro q hq + simp only [Set.mem_singleton_iff] at hq + subst q + exact splitTracePolynomialToKummerTop_relation sigma hsigma e d heOdd hdOdd hde + intro p hp + exact hle hp + have hKernel : RingHom.ker f ≤ I := by + intro p hp + apply hdivision p + apply (splitTracePolynomialSyntacticNormalForm_eq_zero_iff + sigma hsigma e d heOdd hdOdd hde p).2 + exact hp + have hinjective := RingHom.lift_injective_of_ker_le_ideal I hIdeal hKernel + have hsame : + (splitTraceAffineToKummerTop sigma hsigma e d heOdd hdOdd hde).toRingHom = + Ideal.Quotient.lift I f hIdeal := by + apply Ideal.Quotient.ringHom_ext + apply DFunLike.ext _ _ + intro p + change f p = Ideal.Quotient.lift I f hIdeal (Ideal.Quotient.mk I p) + rw [Ideal.Quotient.lift_mk] + intro x y hxy + apply hinjective + rw [← hsame] + exact hxy + +end OddCoprime + +end + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/WeightedBidegree.lean b/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/WeightedBidegree.lean new file mode 100644 index 0000000000..60a9784456 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/WeightedBidegree.lean @@ -0,0 +1,83 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.WeightedIrreducibility + +/-! +# Exact bidegree of the weighted middle-game trace curve + +Corvaja--Zannier Corollary 2 uses the two coordinate degrees of the affine +torus curve. This module computes those degrees for the actual reduced +weighted trace closure. The two-variable polynomial is transported through +the explicit `Fin 2` multivariate-to-iterated-polynomial equivalence already +used in the irreducibility proof; swapping the two polynomial variables +computes the second coordinate degree. +-/ + +@[expose] public section + +namespace BGS.Markoff + +open Polynomial + +variable {K : Type*} [Field K] + +/-- The weighted trace closure has degree two in the right trace coordinate. -/ +theorem weightedTraceIteratedPolynomial_right_natDegree (alpha beta : K) : + (weightedTraceIteratedPolynomial alpha beta).natDegree = 2 := by + apply Nat.le_antisymm + · rw [natDegree_le_iff_coeff_eq_zero] + intro N hN + have hn0 : N ≠ 0 := by omega + have h1 : 1 ≠ N := by omega + have h2 : 2 ≠ N := by omega + simp [weightedTraceIteratedPolynomial, coeff_monomial, h1, h2, + coeff_C_of_ne_zero hn0] + · apply le_natDegree_of_ne_zero + simp [weightedTraceIteratedPolynomial, coeff_monomial] + +/-- The weighted trace closure has degree two in the left weighted coordinate +when its leading weight is nonzero. -/ +theorem weightedTraceIteratedPolynomial_left_natDegree + (alpha beta : K) (halpha : alpha ≠ 0) : + (Polynomial.Bivariate.swap + (weightedTraceIteratedPolynomial alpha beta)).natDegree = 2 := by + have hswap : + Polynomial.Bivariate.swap (weightedTraceIteratedPolynomial alpha beta) = + monomial 2 (C alpha * X) + + monomial 1 (-(X ^ 2 + 1)) + C (C beta * X) := by + simp [weightedTraceIteratedPolynomial, Polynomial.Bivariate.swap_apply, + ← Polynomial.C_mul_X_pow_eq_monomial] + ring + rw [hswap] + apply Nat.le_antisymm + · rw [natDegree_le_iff_coeff_eq_zero] + intro N hN + have hn0 : N ≠ 0 := by omega + have h1 : 1 ≠ N := by omega + have h2 : 2 ≠ N := by omega + simp [coeff_monomial, h1, h2, coeff_C_of_ne_zero hn0] + · apply le_natDegree_of_ne_zero + simp [coeff_monomial, halpha] + +/-- In the nonzero-weight branch used by the Markoff middle game, the reduced +torus closure has exact bidegree `(2, 2)`. The pair is expressed through the +explicit iterated-polynomial presentation, so no informal support convention +is hidden in the statement. -/ +theorem weightedTraceTorusClosurePolynomial_iteratedBidegree + (alpha beta : K) (halpha : alpha ≠ 0) (hbeta : beta ≠ 0) : + let p := finTwoToIteratedPolynomial (K := K) + (weightedTraceTorusClosurePolynomial alpha beta) + (p.natDegree, (Polynomial.Bivariate.swap p).natDegree) = (2, 2) := by + rw [finTwoToIteratedPolynomial_weightedTraceTorusClosurePolynomial + alpha beta hbeta] + exact Prod.ext + (weightedTraceIteratedPolynomial_right_natDegree alpha beta) + (weightedTraceIteratedPolynomial_left_natDegree alpha beta halpha) + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/WeightedEllipticModel.lean b/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/WeightedEllipticModel.lean new file mode 100644 index 0000000000..7d9405e26e --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/WeightedEllipticModel.lean @@ -0,0 +1,105 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.Geometry +public import Mathlib.AlgebraicGeometry.EllipticCurve.Weierstrass + +/-! +# An explicit elliptic model for the weighted trace curve + +For the normalized trace equation, the birational coordinate `u = x / y` +gives + +`u * (1 - u) * y^2 + sigma * u - 1 = 0`. + +On the open set where `sigma * u * (1 - u)` is nonzero, the change + +`X = sigma * u`, `Y = sigma * u * (1 - u) * y` + +identifies this equation with + +`Y^2 = X^3 - (sigma + 1) * X^2 + sigma * X + = X * (X - 1) * (X - sigma)`. + +This module proves the coordinate identity and the exact Weierstrass +discriminant. It does not disguise the remaining algebraic-geometry wall: +the project still needs an in-repository bridge from this nonsingular +Weierstrass model to the genus and Euler-characteristic data used by +Corvaja--Zannier. +-/ + +@[expose] public section + +namespace BGS.Markoff + +variable {K : Type*} [Field K] + +/-- The Weierstrass model birational to the normalized weighted trace curve. -/ +noncomputable def weightedTraceWeierstrassCurve (sigma : K) : + WeierstrassCurve K := + WeierstrassCurve.mk 0 (-(sigma + 1)) 0 sigma 0 + +/-- The exact discriminant of the weighted trace Weierstrass model. -/ +theorem weightedTraceWeierstrassCurve_discriminant (sigma : K) : + (weightedTraceWeierstrassCurve sigma).Δ = + 16 * sigma ^ 2 * (sigma - 1) ^ 2 := by + simp [weightedTraceWeierstrassCurve, WeierstrassCurve.Δ, + WeierstrassCurve.b₂, WeierstrassCurve.b₄, WeierstrassCurve.b₆, + WeierstrassCurve.b₈] + ring + +/-- Away from characteristic two and the degenerate parameters `0, 1`, the +explicit Weierstrass model is elliptic. -/ +theorem weightedTraceWeierstrassCurve_isElliptic + (sigma : K) (htwo : (2 : K) ≠ 0) (hsigma : sigma ≠ 0) + (hnondegenerate : sigma ≠ 1) : + (weightedTraceWeierstrassCurve sigma).IsElliptic := by + constructor + rw [weightedTraceWeierstrassCurve_discriminant] + apply isUnit_iff_ne_zero.mpr + have h16 : (16 : K) ≠ 0 := by + simpa only [show (16 : K) = (2 : K) ^ 4 by norm_num] using + pow_ne_zero 4 htwo + exact mul_ne_zero (mul_ne_zero h16 (pow_ne_zero 2 hsigma)) + (pow_ne_zero 2 (sub_ne_zero.mpr hnondegenerate)) + +/-- The normalized birational trace equation maps to the explicit +Weierstrass equation. -/ +theorem normalizedSplitTraceBirational_to_weightedTraceWeierstrass + (sigma u y : K) + (htrace : u * (1 - u) * y ^ 2 + sigma * u - 1 = 0) : + (sigma * u * (1 - u) * y) ^ 2 = + (sigma * u) ^ 3 - (sigma + 1) * (sigma * u) ^ 2 + + sigma * (sigma * u) := by + linear_combination sigma ^ 2 * u * (1 - u) * htrace + +/-- On the natural birational open, the normalized trace equation and the +explicit Weierstrass equation are equivalent. -/ +theorem normalizedSplitTraceBirational_iff_weightedTraceWeierstrass + (sigma u y : K) (hsigma : sigma ≠ 0) (hu : u ≠ 0) + (huOne : 1 - u ≠ 0) : + u * (1 - u) * y ^ 2 + sigma * u - 1 = 0 ↔ + (sigma * u * (1 - u) * y) ^ 2 = + (sigma * u) ^ 3 - (sigma + 1) * (sigma * u) ^ 2 + + sigma * (sigma * u) := by + constructor + · exact normalizedSplitTraceBirational_to_weightedTraceWeierstrass sigma u y + · intro hWeierstrass + have hidentity : + (sigma * u * (1 - u) * y) ^ 2 - + ((sigma * u) ^ 3 - (sigma + 1) * (sigma * u) ^ 2 + + sigma * (sigma * u)) = + sigma ^ 2 * u * (1 - u) * + (u * (1 - u) * y ^ 2 + sigma * u - 1) := by + ring + rw [hWeierstrass, sub_self] at hidentity + have hcoefficient : sigma ^ 2 * u * (1 - u) ≠ 0 := + mul_ne_zero (mul_ne_zero (pow_ne_zero 2 hsigma) hu) huOne + exact (mul_eq_zero.mp hidentity.symm).resolve_left hcoefficient + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/WeightedIrreducibility.lean b/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/WeightedIrreducibility.lean new file mode 100644 index 0000000000..648640ca31 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/WeightedIrreducibility.lean @@ -0,0 +1,336 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.CorvajaZannierGeometry +public import Mathlib.Algebra.MvPolynomial.Equiv +public import Mathlib.Algebra.Polynomial.Bivariate +public import Mathlib.RingTheory.Polynomial.GaussLemma + +/-! +# Absolute irreducibility of the weighted middle-game trace curve + +This module proves the absolute-irreducibility hypothesis exposed by +`MiddleGameCorvajaZannierGeometry`. The proof uses the published torus change of variables +honestly: the weighted left parameter is first scaled by `alpha`, and then the invertible +birational coordinate `u = x / y` is used after passage to the coefficient fraction field. +The resulting polynomial is the Eisenstein polynomial already proved irreducible in +`TraceCurveGeometry`. +-/ + +@[expose] public section + +namespace BGS.Markoff + +open Polynomial + +section Scaling + +variable {R : Type*} [CommRing R] + +/-- Scaling the variable of a polynomial by a unit is an algebra automorphism. -/ +noncomputable def polynomialVariableScaleEquiv (c : Rˣ) : R[X] ≃ₐ[R] R[X] := by + let forward : R[X] →ₐ[R] R[X] := Polynomial.aeval (C (c : R) * X) + let backward : R[X] →ₐ[R] R[X] := Polynomial.aeval (C ((c⁻¹ : Rˣ) : R) * X) + refine AlgEquiv.ofAlgHom forward backward ?_ ?_ + · apply Polynomial.algHom_ext + simp only [AlgHom.comp_apply, forward, backward, Polynomial.aeval_X, + map_mul, Polynomial.aeval_C] + change C (((c⁻¹ : Rˣ) : R)) * (C (c : R) * X) = X + rw [← mul_assoc, ← C_mul] + simp + · apply Polynomial.algHom_ext + simp only [AlgHom.comp_apply, forward, backward, Polynomial.aeval_X, + map_mul, Polynomial.aeval_C] + change C (c : R) * (C (((c⁻¹ : Rˣ) : R)) * X) = X + rw [← mul_assoc, ← C_mul] + simp + +@[simp] +theorem polynomialVariableScaleEquiv_X (c : Rˣ) : + polynomialVariableScaleEquiv c X = C (c : R) * X := by + simp [polynomialVariableScaleEquiv] + +@[simp] +theorem polynomialVariableScaleEquiv_C (c : Rˣ) (r : R) : + polynomialVariableScaleEquiv c (C r) = C r := by + simp [polynomialVariableScaleEquiv] + +end Scaling + +section IteratedPolynomial + +variable {K : Type*} [Field K] + +/-- View a two-variable polynomial as a polynomial in variable `0`, whose coefficients are +ordinary polynomials in variable `1`. -/ +noncomputable def finTwoToIteratedPolynomial : + MvPolynomial (Fin 2) K ≃ₐ[K] Polynomial K[X] := + (MvPolynomial.finSuccEquiv K 1).trans + (Polynomial.mapAlgEquiv (MvPolynomial.uniqueAlgEquiv K (Fin 1))) + +@[simp] +theorem finTwoToIteratedPolynomial_X_zero : + finTwoToIteratedPolynomial (K := K) (MvPolynomial.X 0) = X := by + have hinner : + MvPolynomial.finSuccEquiv K 1 (MvPolynomial.X 0) = + (Polynomial.X : Polynomial (MvPolynomial (Fin 1) K)) := by + rw [MvPolynomial.finSuccEquiv_apply] + simp + rw [finTwoToIteratedPolynomial] + change Polynomial.map (MvPolynomial.uniqueAlgEquiv K (Fin 1)).toRingHom + (MvPolynomial.finSuccEquiv K 1 (MvPolynomial.X 0)) = X + rw [hinner] + simp + +@[simp] +theorem finTwoToIteratedPolynomial_X_one : + finTwoToIteratedPolynomial (K := K) (MvPolynomial.X 1) = C X := by + have hinner : + MvPolynomial.finSuccEquiv K 1 (MvPolynomial.X 1) = + Polynomial.C (MvPolynomial.X (0 : Fin 1)) := by + rw [MvPolynomial.finSuccEquiv_apply] + simp only [MvPolynomial.coe_eval₂Hom, MvPolynomial.eval₂_X] + rw [show (1 : Fin 2) = Fin.succ (0 : Fin 1) by decide] + rfl + rw [finTwoToIteratedPolynomial] + change Polynomial.map (MvPolynomial.uniqueAlgEquiv K (Fin 1)).toRingHom + (MvPolynomial.finSuccEquiv K 1 (MvPolynomial.X 1)) = C X + rw [hinner] + simp [MvPolynomial.uniqueAlgEquiv] + +@[simp] +theorem finTwoToIteratedPolynomial_C (r : K) : + finTwoToIteratedPolynomial (K := K) (MvPolynomial.C r) = C (C r) := by + have hinner : + MvPolynomial.finSuccEquiv K 1 (MvPolynomial.C r) = + Polynomial.C (MvPolynomial.C r) := by + rw [MvPolynomial.finSuccEquiv_apply] + simp + rw [finTwoToIteratedPolynomial] + change Polynomial.map (MvPolynomial.uniqueAlgEquiv K (Fin 1)).toRingHom + (MvPolynomial.finSuccEquiv K 1 (MvPolynomial.C r)) = C (C r) + rw [hinner] + simp [MvPolynomial.uniqueAlgEquiv] + +/-- The weighted trace curve in the iterated-polynomial presentation. -/ +noncomputable def weightedTraceIteratedPolynomial (alpha beta : K) : Polynomial K[X] := + monomial 2 (-X) + monomial 1 (C alpha * X ^ 2 + C beta) + C (-X) + +theorem finTwoToIteratedPolynomial_weightedTraceTorusClosurePolynomial + (alpha beta : K) (hbeta : beta ≠ 0) : + finTwoToIteratedPolynomial (K := K) + (weightedTraceTorusClosurePolynomial alpha beta) = + weightedTraceIteratedPolynomial alpha beta := by + rw [weightedTraceTorusClosurePolynomial, ite_eq_right hbeta] + simp [splitTraceCoverPolynomial, weightedTraceIteratedPolynomial, + ← Polynomial.C_mul_X_pow_eq_monomial] + ring + +private theorem weightedTraceIteratedPolynomial_isPrimitive + (alpha beta : K) (hbeta : beta ≠ 0) : + (weightedTraceIteratedPolynomial alpha beta).IsPrimitive := by + rw [Polynomial.isPrimitive_iff_isUnit_of_C_dvd] + intro r hr + have hcoeff := (Polynomial.C_dvd_iff_dvd_coeff r + (weightedTraceIteratedPolynomial alpha beta)).mp hr + have hrY : r ∣ X := by + have := hcoeff 0 + have hrNegY : r ∣ -X := by + simpa [weightedTraceIteratedPolynomial] using this + exact dvd_neg.mp hrNegY + have hrMiddle : r ∣ C alpha * X ^ 2 + C beta := by + have hpcoeff : + (weightedTraceIteratedPolynomial alpha beta).coeff 1 = + C alpha * X ^ 2 + C beta := by + norm_num [weightedTraceIteratedPolynomial, Polynomial.coeff_monomial] + rw [← hpcoeff] + exact hcoeff 1 + rcases hrY with ⟨q, hq⟩ + rcases hrMiddle with ⟨s, hs⟩ + have hrBeta : r ∣ C beta := by + refine ⟨s - C alpha * q * X, ?_⟩ + calc + C beta = (C alpha * X ^ 2 + C beta) - C alpha * X * X := by ring + _ = r * s - C alpha * (r * q) * X := by rw [hs, hq] + _ = r * (s - C alpha * q * X) := by ring + exact isUnit_of_dvd_unit hrBeta + (Polynomial.isUnit_C.mpr (isUnit_iff_ne_zero.mpr hbeta)) + +/-- The swapped Eisenstein polynomial after the invertible scaling `y ↦ alpha * y`. +It is a polynomial in the birational coordinate `u`, with coefficients in `K[y]`. -/ +noncomputable def weightedTraceScaledBirationalPolynomial + (alpha : Kˣ) (beta : K) : Polynomial K[X] := + let ay : K[X] := C (alpha : K) * X + monomial 2 (-(ay ^ 2)) + + monomial 1 (ay ^ 2 + C ((alpha : K) * beta)) + + C (-1) + +theorem weightedTraceScaledBirationalPolynomial_eq_map_swap + (alpha : Kˣ) (beta : K) : + weightedTraceScaledBirationalPolynomial alpha beta = + Polynomial.mapAlgEquiv (polynomialVariableScaleEquiv alpha) + (Polynomial.Bivariate.swap + (normalizedSplitTraceBirationalPolynomial ((alpha : K) * beta))) := by + simp [weightedTraceScaledBirationalPolynomial, + normalizedSplitTraceBirationalPolynomial, normalizedSplitTraceLeadingCoefficient, + normalizedSplitTraceEisensteinPrime, polynomialVariableScaleEquiv, + Polynomial.Bivariate.swap_apply, ← Polynomial.C_mul_X_pow_eq_monomial] + ring + +/-- The scaled-and-swapped birational polynomial remains irreducible. -/ +theorem weightedTraceScaledBirationalPolynomial_irreducible + (alpha : Kˣ) (beta : K) (hbeta : beta ≠ 0) + (hnondegenerate : (alpha : K) * beta ≠ 1) : + Irreducible (weightedTraceScaledBirationalPolynomial alpha beta) := by + rw [weightedTraceScaledBirationalPolynomial_eq_map_swap] + exact ((normalizedSplitTraceBirationalPolynomial_irreducible + ((alpha : K) * beta) (mul_ne_zero alpha.ne_zero hbeta) hnondegenerate).map + (Polynomial.Bivariate.swap)).map + (Polynomial.mapAlgEquiv (polynomialVariableScaleEquiv alpha)) + +private theorem weightedTraceScaledBirationalPolynomial_natDegree_ne_zero + (alpha : Kˣ) (beta : K) : + (weightedTraceScaledBirationalPolynomial alpha beta).natDegree ≠ 0 := by + let ay : K[X] := C (alpha : K) * X + have hay : ay ≠ 0 := mul_ne_zero (C_ne_zero.mpr alpha.ne_zero) X_ne_zero + have hcoeff : + (weightedTraceScaledBirationalPolynomial alpha beta).coeff 2 = -(ay ^ 2) := by + simp [weightedTraceScaledBirationalPolynomial, ay, Polynomial.coeff_monomial, + Polynomial.coeff_one] + have hcoeffNe : + (weightedTraceScaledBirationalPolynomial alpha beta).coeff 2 ≠ 0 := by + rw [hcoeff] + exact neg_ne_zero.mpr (pow_ne_zero 2 hay) + have hle : 2 ≤ (weightedTraceScaledBirationalPolynomial alpha beta).natDegree := + Polynomial.le_natDegree_of_ne_zero hcoeffNe + omega + +/-- The scaled birational polynomial stays irreducible over the coefficient fraction field. -/ +theorem weightedTraceScaledBirationalPolynomial_irreducible_fractionMap + (alpha : Kˣ) (beta : K) (hbeta : beta ≠ 0) + (hnondegenerate : (alpha : K) * beta ≠ 1) : + Irreducible + ((weightedTraceScaledBirationalPolynomial alpha beta).map + (algebraMap K[X] (FractionRing K[X]))) := by + have hirr := weightedTraceScaledBirationalPolynomial_irreducible + alpha beta hbeta hnondegenerate + have hprimitive := hirr.isPrimitive + (weightedTraceScaledBirationalPolynomial_natDegree_ne_zero alpha beta) + exact hprimitive.irreducible_iff_irreducible_map_fraction_map.mp hirr + +/-- The unit `alpha * y` in the rational function field `K(y)`. -/ +noncomputable def weightedTraceFractionScaleUnit (alpha : Kˣ) : + (FractionRing K[X])ˣ := + Units.mk0 + (algebraMap K[X] (FractionRing K[X]) (C (alpha : K) * X)) + ((map_ne_zero_iff (algebraMap K[X] (FractionRing K[X])) + (IsFractionRing.injective K[X] (FractionRing K[X]))).mpr + (mul_ne_zero (C_ne_zero.mpr alpha.ne_zero) X_ne_zero)) + +@[simp] +theorem weightedTraceFractionScaleUnit_val (alpha : Kˣ) : + (weightedTraceFractionScaleUnit alpha : FractionRing K[X]) = + algebraMap K[X] (FractionRing K[X]) (C (alpha : K) * X) := by + rfl + +/-- After passing to `K(y)` and scaling `x` by the invertible element `alpha * y`, the +weighted trace polynomial is `y` times the scaled Eisenstein polynomial. -/ +theorem polynomialVariableScaleEquiv_map_weightedTraceIteratedPolynomial + (alpha : Kˣ) (beta : K) : + polynomialVariableScaleEquiv (weightedTraceFractionScaleUnit alpha) + ((weightedTraceIteratedPolynomial (alpha : K) beta).map + (algebraMap K[X] (FractionRing K[X]))) = + C (algebraMap K[X] (FractionRing K[X]) X) * + (weightedTraceScaledBirationalPolynomial alpha beta).map + (algebraMap K[X] (FractionRing K[X])) := by + simp [polynomialVariableScaleEquiv, weightedTraceFractionScaleUnit_val, + weightedTraceIteratedPolynomial, weightedTraceScaledBirationalPolynomial, + ← Polynomial.C_mul_X_pow_eq_monomial] + ring + +/-- The actual weighted trace polynomial is irreducible in the iterated presentation. -/ +theorem weightedTraceIteratedPolynomial_irreducible + (alpha beta : K) (halpha : alpha ≠ 0) (hbeta : beta ≠ 0) + (hnondegenerate : alpha * beta ≠ 1) : + Irreducible (weightedTraceIteratedPolynomial alpha beta) := by + let alphaUnit : Kˣ := Units.mk0 alpha halpha + have hBirationalFraction : + Irreducible + ((weightedTraceScaledBirationalPolynomial alphaUnit beta).map + (algebraMap K[X] (FractionRing K[X]))) := + weightedTraceScaledBirationalPolynomial_irreducible_fractionMap + alphaUnit beta hbeta (by simpa [alphaUnit] using hnondegenerate) + have hyNe : algebraMap K[X] (FractionRing K[X]) X ≠ 0 := + (map_ne_zero_iff (algebraMap K[X] (FractionRing K[X])) + (IsFractionRing.injective K[X] (FractionRing K[X]))).mpr X_ne_zero + have hyUnit : IsUnit + (C (algebraMap K[X] (FractionRing K[X]) X) : + Polynomial (FractionRing K[X])) := + Polynomial.isUnit_C.mpr (isUnit_iff_ne_zero.mpr hyNe) + have hScaled : Irreducible + (polynomialVariableScaleEquiv (weightedTraceFractionScaleUnit alphaUnit) + ((weightedTraceIteratedPolynomial alpha beta).map + (algebraMap K[X] (FractionRing K[X])))) := by + rw [show alpha = (alphaUnit : K) by rfl, + polynomialVariableScaleEquiv_map_weightedTraceIteratedPolynomial] + exact (irreducible_isUnit_mul hyUnit).2 hBirationalFraction + have hFraction : Irreducible + ((weightedTraceIteratedPolynomial alpha beta).map + (algebraMap K[X] (FractionRing K[X]))) := by + have hback := hScaled.map + (polynomialVariableScaleEquiv (weightedTraceFractionScaleUnit alphaUnit)).symm + simpa using hback + have hprimitive := weightedTraceIteratedPolynomial_isPrimitive alpha beta hbeta + exact hprimitive.irreducible_iff_irreducible_map_fraction_map.mpr hFraction + +/-- The reduced torus closure commutes with injective scalar extension in the nonzero +`beta` branch used by the `(2,2)` middle-game curve. -/ +theorem map_weightedTraceTorusClosurePolynomial_of_beta_ne_zero + {L : Type*} [Field L] (phi : K →+* L) (alpha beta : K) (hbeta : beta ≠ 0) : + MvPolynomial.map phi (weightedTraceTorusClosurePolynomial alpha beta) = + weightedTraceTorusClosurePolynomial (phi alpha) (phi beta) := by + have hMapBeta : phi beta ≠ 0 := (map_ne_zero_iff phi phi.injective).mpr hbeta + rw [weightedTraceTorusClosurePolynomial, ite_eq_right hbeta, + weightedTraceTorusClosurePolynomial, ite_eq_right hMapBeta] + simp [splitTraceCoverPolynomial] + +/-- Irreducibility over the ground field, obtained from the iterated-polynomial proof by +the explicit two-variable polynomial equivalence. -/ +theorem weightedTraceTorusClosurePolynomial_irreducible + (alpha beta : K) (halpha : alpha ≠ 0) (hbeta : beta ≠ 0) + (hnondegenerate : alpha * beta ≠ 1) : + Irreducible (weightedTraceTorusClosurePolynomial alpha beta) := by + have hImage := + finTwoToIteratedPolynomial_weightedTraceTorusClosurePolynomial alpha beta hbeta + have hIterated := weightedTraceIteratedPolynomial_irreducible + alpha beta halpha hbeta hnondegenerate + rw [← hImage] at hIterated + have hback := hIterated.map (finTwoToIteratedPolynomial (K := K)).symm + simpa using hback + +/-- The actual weighted trace curve is absolutely irreducible when both weights are nonzero +and their product is not one. Every coordinate change used in the proof is an explicit +algebra equivalence or a Gauss-lemma passage to a fraction field. -/ +theorem weightedTraceCurve_absolutelyIrreducible + (alpha beta : K) (halpha : alpha ≠ 0) (hbeta : beta ≠ 0) + (hnondegenerate : alpha * beta ≠ 1) : + WeightedTraceCurveAbsolutelyIrreducible alpha beta := by + unfold WeightedTraceCurveAbsolutelyIrreducible + let phi : K →+* AlgebraicClosure K := algebraMap K (AlgebraicClosure K) + rw [map_weightedTraceTorusClosurePolynomial_of_beta_ne_zero phi alpha beta hbeta] + apply weightedTraceTorusClosurePolynomial_irreducible + · exact (map_ne_zero_iff phi phi.injective).mpr halpha + · exact (map_ne_zero_iff phi phi.injective).mpr hbeta + · intro h + apply hnondegenerate + apply phi.injective + simpa [phi] using h + +end IteratedPolynomial + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/WeightedNotSubtorus.lean b/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/WeightedNotSubtorus.lean new file mode 100644 index 0000000000..304b159998 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/WeightedNotSubtorus.lean @@ -0,0 +1,258 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.MiddleGame.CorvajaZannierGeometry + +/-! +# The weighted trace curve is not a subtorus translate + +This module proves the non-specialness condition needed by the +Corvaja--Zannier torsion-point bound. The proof uses the two deck involutions +of the weighted trace curve and keeps all degenerate parameters explicit. +-/ + +@[expose] public section + +namespace BGS.Markoff + +section CharacterPowers + +variable {F : Type*} [Field F] [Infinite F] + +/-- No fixed nonzero integer power is identically one on the units of an +infinite field. -/ +private theorem exists_unit_zpow_ne_one (n : ℤ) (hn : n ≠ 0) : + ∃ u : Fˣ, u ^ n ≠ 1 := by + by_contra h + push Not at h + let m := n.natAbs + let q : Polynomial F := Polynomial.X ^ m - 1 + have hm : m ≠ 0 := Int.natAbs_ne_zero.mpr hn + have hqDegree : q.natDegree = m := by + simpa [q] using (Polynomial.natDegree_X_pow_sub_C (R := F) (n := m) (r := 1)) + have hq : q ≠ 0 := by + intro hzero + have : q.natDegree = 0 := by simp [hzero] + omega + have hXq : Polynomial.X * q ≠ 0 := mul_ne_zero Polynomial.X_ne_zero hq + apply hXq + apply Polynomial.zero_of_eval_zero + intro x + by_cases hx : x = 0 + · simp [hx] + · let u : Fˣ := Units.mk0 x hx + have hu : u ^ m = 1 := pow_natAbs_eq_one.mpr (h u) + have hxpow : x ^ m = 1 := by + have := congrArg (fun v : Fˣ ↦ (v : F)) hu + simpa [u] using this + simp [q, hxpow] + +end CharacterPowers + +section CurveProjections + +variable {F : Type*} [Field F] [IsAlgClosed F] + +/-- Every right torus coordinate occurs on a nondegenerate weighted trace +curve. The other coordinate is obtained from its quadratic equation. -/ +private theorem exists_weightedTraceCurve_point_over_right + (alpha beta : F) (halpha : alpha ≠ 0) (hbeta : beta ≠ 0) (k : Fˣ) : + ∃ h : Fˣ, + weightedSplitTorusTrace alpha beta h = splitTorusTrace k := by + let trace := splitTorusTrace k + let q : Polynomial F := + Polynomial.C alpha * Polynomial.X ^ 2 - + Polynomial.C trace * Polynomial.X + Polynomial.C beta + have hqDegree : q.natDegree = 2 := by + rw [show q = Polynomial.C alpha * Polynomial.X ^ 2 + + Polynomial.C (-trace) * Polynomial.X + Polynomial.C beta by + simp only [q, Polynomial.C_neg] + ring] + exact Polynomial.natDegree_quadratic halpha + have hq : q ≠ 0 := by + intro hzero + have : q.natDegree = 0 := by simp [hzero] + omega + have hqDegreeBot : q.degree ≠ 0 := by + rw [Polynomial.degree_eq_natDegree hq, hqDegree] + norm_num + obtain ⟨x, hx⟩ := IsAlgClosed.exists_root q hqDegreeBot + have hxzero : x ≠ 0 := by + intro hzero + subst x + simp [Polynomial.IsRoot.def, q, hbeta] at hx + refine ⟨Units.mk0 x hxzero, ?_⟩ + change alpha * x + beta * x⁻¹ = trace + have hxeq : alpha * x ^ 2 - trace * x + beta = 0 := by + simpa [Polynomial.IsRoot.def, q] using hx + field_simp [hxzero] + linear_combination hxeq + +/-- Every left torus coordinate occurs on the weighted trace curve. -/ +private theorem exists_weightedTraceCurve_point_over_left + (alpha beta : F) (h : Fˣ) : + ∃ k : Fˣ, + weightedSplitTorusTrace alpha beta h = splitTorusTrace k := by + let trace := weightedSplitTorusTrace alpha beta h + let q : Polynomial F := + Polynomial.X ^ 2 - Polynomial.C trace * Polynomial.X + 1 + have hqDegree : q.natDegree = 2 := by + rw [show q = Polynomial.C (1 : F) * Polynomial.X ^ 2 + + Polynomial.C (-trace) * Polynomial.X + Polynomial.C 1 by + simp only [q, Polynomial.C_neg, Polynomial.C_1] + ring] + exact Polynomial.natDegree_quadratic one_ne_zero + have hq : q ≠ 0 := by + intro hzero + have : q.natDegree = 0 := by simp [hzero] + omega + have hqDegreeBot : q.degree ≠ 0 := by + rw [Polynomial.degree_eq_natDegree hq, hqDegree] + norm_num + obtain ⟨x, hx⟩ := IsAlgClosed.exists_root q hqDegreeBot + have hxzero : x ≠ 0 := by + intro hzero + subst x + simp [Polynomial.IsRoot.def, q] at hx + refine ⟨Units.mk0 x hxzero, ?_⟩ + change trace = x + x⁻¹ + have hxeq : x ^ 2 - trace * x + 1 = 0 := by + simpa [Polynomial.IsRoot.def, q] using hx + field_simp [hxzero] + linear_combination -hxeq + +end CurveProjections + +section DeckInvolutions + +variable {F : Type*} [Field F] + +private theorem splitTorusTrace_inv (k : Fˣ) : + splitTorusTrace k⁻¹ = splitTorusTrace k := by + simp only [splitTorusTrace, Units.val_inv_eq_inv_val, inv_inv] + exact add_comm _ _ + +/-- The second deck involution exchanges the two roots of the quadratic in +the weighted coordinate. -/ +private theorem weightedSplitTorusTrace_deck_involution + (alpha beta : F) (halpha : alpha ≠ 0) (hbeta : beta ≠ 0) (h : Fˣ) : + let q : Fˣ := Units.mk0 (beta / alpha) (div_ne_zero hbeta halpha) + weightedSplitTorusTrace alpha beta (q * h⁻¹) = + weightedSplitTorusTrace alpha beta h := by + dsimp + simp only [weightedSplitTorusTrace, Units.val_mul, Units.val_inv_eq_inv_val, + Units.val_mk0, div_eq_mul_inv] + field_simp [halpha, hbeta, Units.ne_zero h] + ring + +end DeckInvolutions + +section NonSubtorus + +variable {K : Type*} [Field K] + +/-- If both weights are nonzero, the complete weighted trace curve is not a +character fiber in the two-dimensional torus. No characteristic restriction +is needed. + +This deliberately does not assume `alpha * beta ≠ 1`. When the product is +one the curve is reducible into two subtorus translates, but no single +character is constant on their union. Thus this proposition is the correct +non-specialness condition only when paired with the separate absolute +irreducibility hypothesis, exactly as it is in +`WeightedTraceCurveIsCorvajaZannierAdmissible`. -/ +theorem weightedTraceCurve_notSubtorusTranslate_of_weights_ne_zero + (alpha beta : K) (halpha : alpha ≠ 0) (hbeta : beta ≠ 0) : + WeightedTraceCurveNotSubtorusTranslate alpha beta := by + let alphaL : AlgebraicClosure K := algebraMap K (AlgebraicClosure K) alpha + let betaL : AlgebraicClosure K := algebraMap K (AlgebraicClosure K) beta + have halphaL : alphaL ≠ 0 := by + exact (map_ne_zero_iff (algebraMap K (AlgebraicClosure K)) + (algebraMap K (AlgebraicClosure K)).injective).mpr halpha + have hbetaL : betaL ≠ 0 := by + exact (map_ne_zero_iff (algebraMap K (AlgebraicClosure K)) + (algebraMap K (AlgebraicClosure K)).injective).mpr hbeta + intro a b hab c + by_contra hvaries + push Not at hvaries + have haUniversal : ∀ k : (AlgebraicClosure K)ˣ, k ^ (2 * a) = 1 := by + intro k + obtain ⟨h, hcurve⟩ := + exists_weightedTraceCurve_point_over_right alphaL betaL halphaL hbetaL k + have hcurveInv : + weightedSplitTorusTrace alphaL betaL h = splitTorusTrace k⁻¹ := by + rw [splitTorusTrace_inv] + exact hcurve + have hvalue := hvaries k h hcurve + have hvalueInv := hvaries k⁻¹ h hcurveInv + have hpower : k ^ a = (k⁻¹) ^ a := by + exact mul_right_cancel (hvalue.trans hvalueInv.symm) + have hpowerInv : k ^ a = (k ^ a)⁻¹ := by + simpa only [inv_zpow] using hpower + have hsquare : k ^ a * k ^ a = 1 := eq_inv_iff_mul_eq_one.mp hpowerInv + calc + k ^ (2 * a) = k ^ (a + a) := by (congr 1; ring) + _ = k ^ a * k ^ a := zpow_add k a a + _ = 1 := hsquare + have ha : a = 0 := by + by_contra ha + have htwoa : 2 * a ≠ 0 := mul_ne_zero (by norm_num) ha + obtain ⟨k, hk⟩ := exists_unit_zpow_ne_one (F := AlgebraicClosure K) (2 * a) htwoa + exact hk (haUniversal k) + have hbUniversal : ∀ h : (AlgebraicClosure K)ˣ, h ^ (2 * b) = 1 := by + let q : (AlgebraicClosure K)ˣ := + Units.mk0 (betaL / alphaL) (div_ne_zero hbetaL halphaL) + have hconstant : ∀ h : (AlgebraicClosure K)ˣ, h ^ (2 * b) = q ^ b := by + intro h + obtain ⟨k, hcurve⟩ := exists_weightedTraceCurve_point_over_left alphaL betaL h + have hcurveDeck : + weightedSplitTorusTrace alphaL betaL (q * h⁻¹) = splitTorusTrace k := by + rw [weightedSplitTorusTrace_deck_involution alphaL betaL halphaL hbetaL] + exact hcurve + have hvalue := hvaries k h hcurve + have hvalueDeck := hvaries k (q * h⁻¹) hcurveDeck + have hpower : h ^ b = (q * h⁻¹) ^ b := by + exact mul_left_cancel (hvalue.trans hvalueDeck.symm) + have hpowerExpanded : h ^ b = q ^ b * (h ^ b)⁻¹ := by + simpa only [mul_zpow, inv_zpow] using hpower + have hsquare : h ^ b * h ^ b = q ^ b := by + calc + h ^ b * h ^ b = (q ^ b * (h ^ b)⁻¹) * h ^ b := by + exact congrArg (fun z ↦ z * h ^ b) hpowerExpanded + _ = q ^ b := by simp + calc + h ^ (2 * b) = h ^ (b + b) := by (congr 1; ring) + _ = h ^ b * h ^ b := zpow_add h b b + _ = q ^ b := hsquare + have hq : q ^ b = 1 := by + have hone := hconstant (1 : (AlgebraicClosure K)ˣ) + simpa using hone.symm + intro h + exact (hconstant h).trans hq + have hb : b = 0 := by + by_contra hb + have htwob : 2 * b ≠ 0 := mul_ne_zero (by norm_num) hb + obtain ⟨h, hh⟩ := exists_unit_zpow_ne_one + (F := AlgebraicClosure K) (2 * b) htwob + exact hh (hbUniversal h) + exact hab.elim (fun hne ↦ hne ha) (fun hne ↦ hne hb) + +/-- Once absolute irreducibility is supplied, all remaining geometric +admissibility conditions are discharged by the explicit parameter +hypotheses. -/ +theorem weightedTraceCurve_isCorvajaZannierAdmissible_of_absoluteIrreducible + (alpha beta : K) (halpha : alpha ≠ 0) (hbeta : beta ≠ 0) + (hnondegenerate : alpha * beta ≠ 1) + (hirreducible : WeightedTraceCurveAbsolutelyIrreducible alpha beta) : + WeightedTraceCurveIsCorvajaZannierAdmissible alpha beta := by + exact ⟨halpha, hbeta, hnondegenerate, hirreducible, + weightedTraceCurve_notSubtorusTranslate_of_weights_ne_zero alpha beta halpha hbeta⟩ + +end NonSubtorus + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/WeightedOddCoprimeIrreducibility.lean b/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/WeightedOddCoprimeIrreducibility.lean new file mode 100644 index 0000000000..322aba1482 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/Markoff/TraceCurve/WeightedOddCoprimeIrreducibility.lean @@ -0,0 +1,207 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.TraceCurve.CommonPrimeKummerTower +public import Mathlib.FieldTheory.IsAlgClosed.Basic +public import Mathlib.RingTheory.RootsOfUnity.AlgebraicallyClosed + +/-! +# Absolute irreducibility of weighted odd-coprime split trace covers + +The residue-block proof gives irreducibility first for the normalized coefficients `(1, sigma)`. +This file connects that result to the paper's actual weights `(alpha, beta)`. Over the algebraic +closure choose `c` with `c ^ e = alpha`; the reversible coordinate scaling `y ↦ c * y` carries the +normalized cover with `sigma = alpha * beta` to `alpha` times the weighted cover. Thus no new +irreducibility assumption is introduced at the normalization step. +-/ + +@[expose] public section + +namespace BGS.Markoff + +open Polynomial + +noncomputable section + +variable {K : Type*} [Field K] + +/-- Scaling the second variable of a two-variable polynomial by a unit. -/ +noncomputable def finTwoSecondVariableScaleEquiv (c : Kˣ) : + MvPolynomial (Fin 2) K ≃ₐ[K] MvPolynomial (Fin 2) K := by + let forward : MvPolynomial (Fin 2) K →ₐ[K] MvPolynomial (Fin 2) K := + MvPolynomial.aeval ![MvPolynomial.X 0, MvPolynomial.C (c : K) * MvPolynomial.X 1] + let backward : MvPolynomial (Fin 2) K →ₐ[K] MvPolynomial (Fin 2) K := + MvPolynomial.aeval + ![MvPolynomial.X 0, MvPolynomial.C ((c⁻¹ : Kˣ) : K) * MvPolynomial.X 1] + refine AlgEquiv.ofAlgHom forward backward ?_ ?_ + · apply MvPolynomial.algHom_ext + intro i + fin_cases i + · simp [forward, backward] + · simp [forward, backward, ← mul_assoc] + rw [← map_mul] + simp + · apply MvPolynomial.algHom_ext + intro i + fin_cases i + · simp [forward, backward] + · simp [forward, backward, ← mul_assoc] + rw [← map_mul] + simp + +@[simp] +theorem finTwoSecondVariableScaleEquiv_X_zero (c : Kˣ) : + finTwoSecondVariableScaleEquiv c (MvPolynomial.X 0) = MvPolynomial.X 0 := by + simp [finTwoSecondVariableScaleEquiv] + +@[simp] +theorem finTwoSecondVariableScaleEquiv_X_one (c : Kˣ) : + finTwoSecondVariableScaleEquiv c (MvPolynomial.X 1) = + MvPolynomial.C (c : K) * MvPolynomial.X 1 := by + simp [finTwoSecondVariableScaleEquiv] + +@[simp] +theorem finTwoSecondVariableScaleEquiv_C (c : Kˣ) (a : K) : + finTwoSecondVariableScaleEquiv c (MvPolynomial.C a) = MvPolynomial.C a := by + simp [finTwoSecondVariableScaleEquiv] + +/-- Exact scaling identity between the normalized and weighted covers. -/ +theorem finTwoSecondVariableScaleEquiv_normalizedCover + (alpha beta : K) (e d : ℕ) (c : Kˣ) (hc : (c : K) ^ e = alpha) : + finTwoSecondVariableScaleEquiv c + (splitTraceCoverPolynomial (1 : K) (alpha * beta) d e) = + MvPolynomial.C alpha * splitTraceCoverPolynomial alpha beta d e := by + simp only [splitTraceCoverPolynomial, map_add, map_sub, map_mul, map_pow, + finTwoSecondVariableScaleEquiv_C, finTwoSecondVariableScaleEquiv_X_zero, + finTwoSecondVariableScaleEquiv_X_one, map_one] + simp only [mul_pow, ← map_pow] + rw [Nat.mul_comm 2 e, pow_mul, hc] + rw [map_pow] + ring + +/-- The cleared split trace-cover polynomial commutes with scalar extension. -/ +theorem map_splitTraceCoverPolynomial + {L : Type*} [Field L] (phi : K →+* L) (alpha beta : K) (d e : ℕ) : + MvPolynomial.map phi (splitTraceCoverPolynomial alpha beta d e) = + splitTraceCoverPolynomial (phi alpha) (phi beta) d e := by + simp [splitTraceCoverPolynomial] + +/-- The paper's weighted split trace cover is absolutely irreducible for arbitrary positive +covering exponents when the first-stage exponent is nonzero in the ground field. This is the +characteristic condition satisfied by the endgame exponents dividing `p - 1` or `p + 1`. -/ +theorem splitTraceCoverPolynomial_absolutelyIrreducible_of_positiveExponents + (alpha beta : K) (halpha : alpha ≠ 0) (hbeta : beta ≠ 0) + (hnondegenerate : alpha * beta ≠ 1) + (e d : ℕ) (he : 0 < e) (hd : 0 < d) (heChar : (e : K) ≠ 0) : + Irreducible + (MvPolynomial.map (algebraMap K (AlgebraicClosure K)) + (splitTraceCoverPolynomial alpha beta d e)) := by + let phi : K →+* AlgebraicClosure K := algebraMap K (AlgebraicClosure K) + rw [map_splitTraceCoverPolynomial phi alpha beta d e] + have halphaL : phi alpha ≠ 0 := (map_ne_zero_iff phi phi.injective).mpr halpha + have hbetaL : phi beta ≠ 0 := (map_ne_zero_iff phi phi.injective).mpr hbeta + have hproductL : phi alpha * phi beta ≠ 1 := by + intro h + apply hnondegenerate + apply phi.injective + simpa [phi] using h + have heCharL : (e : AlgebraicClosure K) ≠ 0 := by + change phi (e : K) ≠ 0 + exact (map_ne_zero_iff phi phi.injective).mpr heChar + let : NeZero e := ⟨he.ne'⟩ + let : NeZero (e : AlgebraicClosure K) := ⟨heCharL⟩ + obtain ⟨zeta, hzeta⟩ := + HasEnoughRootsOfUnity.exists_primitiveRoot (AlgebraicClosure K) e + obtain ⟨sqrtNegOne, hsqrtNegOne⟩ := + IsAlgClosed.exists_pow_nat_eq (-1 : AlgebraicClosure K) zero_lt_two + obtain ⟨c, hc⟩ := IsAlgClosed.exists_pow_nat_eq (phi alpha) he + have hcne : c ≠ 0 := by + intro hc0 + apply halphaL + rw [← hc] + simp [hc0, Nat.ne_of_gt he] + let cUnit : (AlgebraicClosure K)ˣ := Units.mk0 c hcne + have hnormalized : Irreducible + (splitTraceCoverPolynomial (1 : AlgebraicClosure K) (phi alpha * phi beta) d e) := + splitTraceCoverPolynomial_irreducible_of_primitiveRoot + (phi alpha * phi beta) (mul_ne_zero halphaL hbetaL) hproductL + sqrtNegOne hsqrtNegOne e d he hd zeta hzeta + have hscaled := hnormalized.map (finTwoSecondVariableScaleEquiv cUnit) + have hscaleIdentity : + finTwoSecondVariableScaleEquiv cUnit + (splitTraceCoverPolynomial (1 : AlgebraicClosure K) (phi alpha * phi beta) d e) = + MvPolynomial.C (phi alpha) * + splitTraceCoverPolynomial (phi alpha) (phi beta) d e := by + apply finTwoSecondVariableScaleEquiv_normalizedCover + simpa [cUnit] using hc + rw [hscaleIdentity] at hscaled + exact (irreducible_isUnit_mul + (halphaL.isUnit.map (MvPolynomial.C : AlgebraicClosure K →+* + MvPolynomial (Fin 2) (AlgebraicClosure K)))).mp hscaled + +/-- The paper's weighted split trace cover is absolutely irreducible for nonzero weights with +nondegenerate product and arbitrary positive coprime covering exponents. Passing to the +algebraic closure supplies both the required square root of `-1` and the root used to normalize +the first weight. -/ +theorem splitTraceCoverPolynomial_absolutelyIrreducible_of_coprime + (alpha beta : K) (halpha : alpha ≠ 0) (hbeta : beta ≠ 0) + (hnondegenerate : alpha * beta ≠ 1) + (e d : ℕ) (he : 0 < e) (hd : 0 < d) (hde : d.Coprime e) : + Irreducible + (MvPolynomial.map (algebraMap K (AlgebraicClosure K)) + (splitTraceCoverPolynomial alpha beta d e)) := by + let phi : K →+* AlgebraicClosure K := algebraMap K (AlgebraicClosure K) + rw [map_splitTraceCoverPolynomial phi alpha beta d e] + have halphaL : phi alpha ≠ 0 := (map_ne_zero_iff phi phi.injective).mpr halpha + have hbetaL : phi beta ≠ 0 := (map_ne_zero_iff phi phi.injective).mpr hbeta + have hproductL : phi alpha * phi beta ≠ 1 := by + intro h + apply hnondegenerate + apply phi.injective + simpa [phi] using h + obtain ⟨sqrtNegOne, hsqrtNegOne⟩ := + IsAlgClosed.exists_pow_nat_eq (-1 : AlgebraicClosure K) zero_lt_two + obtain ⟨c, hc⟩ := IsAlgClosed.exists_pow_nat_eq (phi alpha) he + have hcne : c ≠ 0 := by + intro hc0 + apply halphaL + rw [← hc] + simp [hc0, Nat.ne_of_gt he] + let cUnit : (AlgebraicClosure K)ˣ := Units.mk0 c hcne + have hnormalized : Irreducible + (splitTraceCoverPolynomial (1 : AlgebraicClosure K) (phi alpha * phi beta) d e) := + splitTraceCoverPolynomial_irreducible_of_sqrt_neg_one_coprime + (phi alpha * phi beta) (mul_ne_zero halphaL hbetaL) + sqrtNegOne hsqrtNegOne e d he hd hde hproductL + have hscaled := hnormalized.map (finTwoSecondVariableScaleEquiv cUnit) + have hscaleIdentity : + finTwoSecondVariableScaleEquiv cUnit + (splitTraceCoverPolynomial (1 : AlgebraicClosure K) (phi alpha * phi beta) d e) = + MvPolynomial.C (phi alpha) * + splitTraceCoverPolynomial (phi alpha) (phi beta) d e := by + apply finTwoSecondVariableScaleEquiv_normalizedCover + simpa [cUnit] using hc + rw [hscaleIdentity] at hscaled + exact (irreducible_isUnit_mul + (halphaL.isUnit.map (MvPolynomial.C : AlgebraicClosure K →+* + MvPolynomial (Fin 2) (AlgebraicClosure K)))).mp hscaled + +/-- Backwards-compatible odd-coprime specialization of the positive-coprime theorem. -/ +theorem splitTraceCoverPolynomial_absolutelyIrreducible_of_oddCoprime + (alpha beta : K) (halpha : alpha ≠ 0) (hbeta : beta ≠ 0) + (hnondegenerate : alpha * beta ≠ 1) + (e d : ℕ) (heOdd : Odd e) (hdOdd : Odd d) (hde : d.Coprime e) : + Irreducible + (MvPolynomial.map (algebraMap K (AlgebraicClosure K)) + (splitTraceCoverPolynomial alpha beta d e)) := + splitTraceCoverPolynomial_absolutelyIrreducible_of_coprime + alpha beta halpha hbeta hnondegenerate e d heOdd.pos hdOdd.pos hde + +end + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/NumberTheory/DivisorBound.lean b/LeanPool/MarkoffModP/BGS/NumberTheory/DivisorBound.lean new file mode 100644 index 0000000000..95dd9491e5 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/NumberTheory/DivisorBound.lean @@ -0,0 +1,143 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import Mathlib.Analysis.SpecificLimits.Normed +public import Mathlib.Analysis.SpecialFunctions.Pow.Asymptotics +public import Mathlib.NumberTheory.ArithmeticFunction.Misc + +/-! +# Subpolynomial growth of the divisor-counting function + +This module develops the analytic-number-theory input used by the BGS +middle- and end-game union bounds. The public target is an eventual real +power bound for `Nat.divisors.card`. +-/ + +@[expose] public section + +namespace BGS.NumberTheory + +open Filter +open scoped BigOperators Topology + +/-- A fixed power of `a + 1` is bounded by a constant times `2 ^ a`. +The constant is allowed to depend on the power. -/ +private lemma exists_pow_succ_le_constant_mul_two_pow (k : ℕ) : + ∃ D : ℕ, 0 < D ∧ ∀ a : ℕ, (a + 1) ^ k ≤ D * 2 ^ a := by + have h := + (isLittleO_pow_const_const_pow_of_one_lt (R := ℝ) k + (by norm_num : (1 : ℝ) < 2)).bound zero_lt_one + rw [eventually_atTop] at h + obtain ⟨N, hN⟩ := h + refine ⟨2 * (N + 1) ^ k, by positivity, fun a ↦ ?_⟩ + by_cases ha : N ≤ a + 1 + · have hreal := hN (a + 1) ha + simp only [Real.norm_eq_abs, one_mul, abs_pow] at hreal + simp only [Nat.cast_add, Nat.cast_one, Nat.abs_ofNat] at hreal + have hnat : (a + 1) ^ k ≤ 2 ^ (a + 1) := by exact_mod_cast hreal + calc + (a + 1) ^ k ≤ 2 ^ (a + 1) := hnat + _ = 2 * 2 ^ a := by simp [pow_succ, Nat.mul_comm] + _ ≤ (2 * (N + 1) ^ k) * 2 ^ a := by + gcongr + simpa using Nat.mul_le_mul_left 2 (Nat.one_le_pow' k N) + · have haN : a + 1 ≤ N + 1 := by omega + calc + (a + 1) ^ k ≤ (N + 1) ^ k := Nat.pow_le_pow_left haN k + _ ≤ (2 * (N + 1) ^ k) * 2 ^ a := by + have hpow : 1 ≤ 2 ^ a := by simpa using Nat.one_le_pow' a 1 + nlinarith [Nat.zero_le ((N + 1) ^ k)] + +/-- Raising the divisor count to a fixed natural power costs only a constant +times `n`. This is the arithmetic core of the subpolynomial estimate. -/ +private lemma exists_card_divisors_pow_le_constant_mul (k : ℕ) : + ∃ C : ℕ, 0 < C ∧ ∀ n : ℕ, n ≠ 0 → n.divisors.card ^ k ≤ C * n := by + obtain ⟨D, hD, hDpow⟩ := exists_pow_succ_le_constant_mul_two_pow k + refine ⟨D ^ (2 ^ k), pow_pos hD _, fun n hn ↦ ?_⟩ + have hfactor : ∀ p ∈ n.primeFactors, + (n.factorization p + 1) ^ k ≤ + (if p < 2 ^ k then D else 1) * p ^ n.factorization p := by + intro p hp + have hpPrime := Nat.prime_of_mem_primeFactors hp + have hpTwo : 2 ≤ p := hpPrime.two_le + have haPos : 0 < n.factorization p := + hpPrime.factorization_pos_of_dvd hn (Nat.dvd_of_mem_primeFactors hp) + by_cases hpSmall : p < 2 ^ k + · rw [ite_eq_left hpSmall] + exact (hDpow (n.factorization p)).trans <| + Nat.mul_le_mul_left D (Nat.pow_le_pow_left hpTwo _) + · rw [ite_eq_right hpSmall, one_mul] + have hsucc : n.factorization p + 1 ≤ 2 ^ n.factorization p := + Nat.succ_le_of_lt (n.factorization p).lt_two_pow_self + calc + (n.factorization p + 1) ^ k ≤ (2 ^ n.factorization p) ^ k := + Nat.pow_le_pow_left hsucc k + _ = (2 ^ k) ^ n.factorization p := by + rw [← pow_mul, ← pow_mul, Nat.mul_comm] + _ ≤ p ^ n.factorization p := + Nat.pow_le_pow_left (le_of_not_gt hpSmall) _ + have hsmallCard : + (n.primeFactors.filter fun p ↦ p < 2 ^ k).card ≤ 2 ^ k := by + calc + (n.primeFactors.filter fun p ↦ p < 2 ^ k).card ≤ (Finset.range (2 ^ k)).card := + Finset.card_le_card (by + intro p hp + exact Finset.mem_range.mpr (Finset.mem_filter.mp hp).2) + _ = 2 ^ k := Finset.card_range _ + rw [Nat.card_divisors hn, ← Finset.prod_pow] + calc + (∏ p ∈ n.primeFactors, (n.factorization p + 1) ^ k) ≤ + ∏ p ∈ n.primeFactors, + ((if p < 2 ^ k then D else 1) * p ^ n.factorization p) := + Finset.prod_le_prod hfactor + _ = D ^ (n.primeFactors.filter fun p ↦ p < 2 ^ k).card * n := by + rw [Finset.prod_mul_distrib, ← Nat.prod_primeFactors_pow_factorization hn] + simp [Finset.prod_ite] + _ ≤ D ^ (2 ^ k) * n := by + exact Nat.mul_le_mul_right n (Nat.pow_le_pow_right hD hsmallCard) + +/-- The divisor-counting function is eventually bounded by every positive +real power. The cast and `Real.rpow` formulation is designed for direct use +in the real-valued union bounds for divisors of `p - 1` and `p + 1`. -/ +theorem eventually_card_divisors_le_rpow {ε : ℝ} (hε : 0 < ε) : + ∀ᶠ n : ℕ in atTop, (n.divisors.card : ℝ) ≤ (n : ℝ) ^ ε := by + obtain ⟨k, hk⟩ := exists_nat_gt (1 / ε) + have hkRealPos : (0 : ℝ) < k := (one_div_pos.mpr hε).trans hk + have hkPos : 0 < k := by exact_mod_cast hkRealPos + have hExponent : 0 < ε * (k : ℝ) - 1 := by + have := (div_lt_iff₀ hε).mp hk + nlinarith + obtain ⟨C, hC, hbound⟩ := exists_card_divisors_pow_le_constant_mul k + have hEventuallyConstant : + ∀ᶠ n : ℕ in atTop, (C : ℝ) ≤ (n : ℝ) ^ (ε * (k : ℝ) - 1) := + ((tendsto_rpow_atTop hExponent).comp tendsto_natCast_atTop_atTop).eventually + (eventually_ge_atTop (C : ℝ)) + filter_upwards [hEventuallyConstant, eventually_gt_atTop 0] with n hConstant hn + have hNatural := hbound n (Nat.ne_of_gt hn) + have hCast : (n.divisors.card : ℝ) ^ k ≤ (C : ℝ) * n := by + exact_mod_cast hNatural + have hnRealPos : (0 : ℝ) < n := by exact_mod_cast hn + have hPowers : (n.divisors.card : ℝ) ^ k ≤ ((n : ℝ) ^ ε) ^ k := by + calc + (n.divisors.card : ℝ) ^ k ≤ (C : ℝ) * n := hCast + _ ≤ (n : ℝ) ^ (ε * (k : ℝ) - 1) * n := + mul_le_mul_of_nonneg_right hConstant (Nat.cast_nonneg n) + _ = (n : ℝ) ^ (ε * (k : ℝ) - 1 + 1) := by + simpa using (Real.rpow_add hnRealPos (ε * (k : ℝ) - 1) 1).symm + _ = (n : ℝ) ^ (ε * (k : ℝ)) := by ring_nf + _ = ((n : ℝ) ^ ε) ^ k := Real.rpow_mul_natCast hnRealPos.le ε k + exact le_of_pow_le_pow_left₀ hkPos.ne' (Real.rpow_nonneg hnRealPos.le ε) hPowers + +/-- Threshold form of `eventually_card_divisors_le_rpow`, convenient when a +downstream argument already carries explicit lower bounds for `p - 1` and +`p + 1`. -/ +theorem exists_threshold_card_divisors_le_rpow {ε : ℝ} (hε : 0 < ε) : + ∃ N : ℕ, ∀ n : ℕ, N ≤ n → (n.divisors.card : ℝ) ≤ (n : ℝ) ^ ε := + eventually_atTop.mp (eventually_card_divisors_le_rpow hε) + +end BGS.NumberTheory diff --git a/LeanPool/MarkoffModP/BGS/NumberTheory/ExplicitDivisorBound.lean b/LeanPool/MarkoffModP/BGS/NumberTheory/ExplicitDivisorBound.lean new file mode 100644 index 0000000000..5e646d9332 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/NumberTheory/ExplicitDivisorBound.lean @@ -0,0 +1,150 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.NumberTheory.DivisorBound + +/-! +# An explicit divisor-counting bound + +The asymptotic divisor bound used by the original assembly hides a threshold in a +little-oh argument. This file keeps the same elementary factorization proof but +uses a concrete polynomial-versus-exponential estimate. Its specialization at +`k = 32` is the numerical input for explicit strong approximation. +-/ + +@[expose] public section + +namespace BGS.NumberTheory + +open scoped BigOperators + +/-- A completely explicit replacement for the polynomial-versus-exponential +constant in `DivisorBound.lean`. -/ +theorem pow_succ_le_self_pow_mul_two_pow + (k : ℕ) (hk : 0 < k) (a : ℕ) : + (a + 1) ^ k ≤ k ^ k * 2 ^ a := by + let q := a / k + have haq : a + 1 ≤ k * (q + 1) := by + exact Nat.succ_le_of_lt (by + simpa [q, Nat.mul_comm] using Nat.lt_mul_div_succ a hk) + have hq : q + 1 ≤ 2 ^ q := Nat.succ_le_of_lt q.lt_two_pow_self + calc + (a + 1) ^ k ≤ (k * (q + 1)) ^ k := Nat.pow_le_pow_left haq _ + _ = k ^ k * (q + 1) ^ k := by rw [mul_pow] + _ ≤ k ^ k * (2 ^ q) ^ k := + Nat.mul_le_mul_left _ (Nat.pow_le_pow_left hq _) + _ = k ^ k * 2 ^ (q * k) := by rw [pow_mul] + _ ≤ k ^ k * 2 ^ a := Nat.mul_le_mul_left _ <| + Nat.pow_le_pow_right (by norm_num) (Nat.div_mul_le_self a k) + +/-- Explicit factorization bound for the divisor-counting function. -/ +theorem card_divisors_pow_le_explicit_constant_mul + (k : ℕ) (hk : 0 < k) (n : ℕ) (hn : n ≠ 0) : + n.divisors.card ^ k ≤ (k ^ k) ^ (2 ^ k) * n := by + let D := k ^ k + have hD : 0 < D := pow_pos hk _ + have hfactor : ∀ p ∈ n.primeFactors, + (n.factorization p + 1) ^ k ≤ + (if p < 2 ^ k then D else 1) * p ^ n.factorization p := by + intro p hp + have hpPrime := Nat.prime_of_mem_primeFactors hp + have hpTwo : 2 ≤ p := hpPrime.two_le + have haPos : 0 < n.factorization p := + hpPrime.factorization_pos_of_dvd hn (Nat.dvd_of_mem_primeFactors hp) + by_cases hpSmall : p < 2 ^ k + · rw [ite_eq_left hpSmall] + exact (pow_succ_le_self_pow_mul_two_pow k hk (n.factorization p)).trans <| + Nat.mul_le_mul_left D (Nat.pow_le_pow_left hpTwo _) + · rw [ite_eq_right hpSmall, one_mul] + have hsucc : n.factorization p + 1 ≤ 2 ^ n.factorization p := + Nat.succ_le_of_lt (n.factorization p).lt_two_pow_self + calc + (n.factorization p + 1) ^ k ≤ (2 ^ n.factorization p) ^ k := + Nat.pow_le_pow_left hsucc k + _ = (2 ^ k) ^ n.factorization p := by + rw [← pow_mul, ← pow_mul, Nat.mul_comm] + _ ≤ p ^ n.factorization p := + Nat.pow_le_pow_left (le_of_not_gt hpSmall) _ + have hsmallCard : + (n.primeFactors.filter fun p => p < 2 ^ k).card ≤ 2 ^ k := by + calc + (n.primeFactors.filter fun p => p < 2 ^ k).card ≤ + (Finset.range (2 ^ k)).card := + Finset.card_le_card (by + intro p hp + exact Finset.mem_range.mpr (Finset.mem_filter.mp hp).2) + _ = 2 ^ k := Finset.card_range _ + rw [Nat.card_divisors hn, ← Finset.prod_pow] + calc + (∏ p ∈ n.primeFactors, (n.factorization p + 1) ^ k) ≤ + ∏ p ∈ n.primeFactors, + ((if p < 2 ^ k then D else 1) * p ^ n.factorization p) := + Finset.prod_le_prod hfactor + _ = D ^ (n.primeFactors.filter fun p => p < 2 ^ k).card * n := by + rw [Finset.prod_mul_distrib, ← Nat.prod_primeFactors_pow_factorization hn] + simp [Finset.prod_ite] + _ ≤ D ^ (2 ^ k) * n := by + exact Nat.mul_le_mul_right n (Nat.pow_le_pow_right hD hsmallCard) + _ = (k ^ k) ^ (2 ^ k) * n := by rfl + +/-- Sealed data for the closed factorization constant. The subtype equation +lets downstream proofs rewrite the value without asking the kernel to +repeatedly normalize its enormous exponentiation. -/ +noncomputable def explicitDivisorConstantData : + {n : ℕ // n = (32 ^ 32) ^ (2 ^ 32)} := + Classical.choice ⟨⟨(32 ^ 32) ^ (2 ^ 32), rfl⟩⟩ + +/-- The closed factorization constant used by the explicit Markoff proof. -/ +noncomputable def explicitDivisorConstant : ℕ := explicitDivisorConstantData.1 + +theorem explicitDivisorConstant_eq : + explicitDivisorConstant = (32 ^ 32) ^ (2 ^ 32) := + explicitDivisorConstantData.2 + +private theorem positive_of_eq_iterated_pow {n a b c : ℕ} + (ha : 0 < a) (h : n = (a ^ b) ^ c) : 0 < n := + h.symm ▸ pow_pos (pow_pos ha _) _ + +theorem explicitDivisorConstant_pos : 0 < explicitDivisorConstant := + positive_of_eq_iterated_pow (by decide : 0 < 32) explicitDivisorConstant_eq + +theorem explicitDivisorConstant_le_pow_thirtyTwo : + explicitDivisorConstant ≤ explicitDivisorConstant ^ 32 := by + have hOne : 1 ≤ explicitDivisorConstant := explicitDivisorConstant_pos + simpa only [pow_one] using + (pow_le_pow_right₀ hOne (show (1 : ℕ) ≤ 32 by norm_num)) + +/-- Above the concrete constant, the divisor count is bounded by the +sixteenth root. -/ +theorem card_divisors_le_rpow_one_div_sixteen + (n : ℕ) (hn : explicitDivisorConstant ≤ n) : + (n.divisors.card : ℝ) ≤ (n : ℝ) ^ (1 / 16 : ℝ) := by + have hnPos : 0 < n := explicitDivisorConstant_pos.trans_le hn + have hNatural := card_divisors_pow_le_explicit_constant_mul + 32 (by norm_num) n hnPos.ne' + have hNatural' : n.divisors.card ^ 32 ≤ n ^ 2 := by + calc + n.divisors.card ^ 32 ≤ explicitDivisorConstant * n := by + rw [explicitDivisorConstant_eq] + exact hNatural + _ ≤ n * n := Nat.mul_le_mul_right n hn + _ = n ^ 2 := by ring + have hCast : (n.divisors.card : ℝ) ^ 32 ≤ (n : ℝ) ^ 2 := by + exact_mod_cast hNatural' + have hnNonnegative : (0 : ℝ) ≤ n := by positivity + have hPowers : (n.divisors.card : ℝ) ^ 32 ≤ + ((n : ℝ) ^ (1 / 16 : ℝ)) ^ 32 := by + calc + (n.divisors.card : ℝ) ^ 32 ≤ (n : ℝ) ^ 2 := hCast + _ = (n : ℝ) ^ ((1 / 16 : ℝ) * 32) := by norm_num + _ = ((n : ℝ) ^ (1 / 16 : ℝ)) ^ 32 := + Real.rpow_mul_natCast hnNonnegative (1 / 16 : ℝ) 32 + exact le_of_pow_le_pow_left₀ (by norm_num : (32 : ℕ) ≠ 0) + (Real.rpow_nonneg hnNonnegative _) hPowers + +end BGS.NumberTheory diff --git a/LeanPool/MarkoffModP/BGS/NumberTheory/JointMaximalDivisorCertificate.lean b/LeanPool/MarkoffModP/BGS/NumberTheory/JointMaximalDivisorCertificate.lean new file mode 100644 index 0000000000..49be0575b6 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/NumberTheory/JointMaximalDivisorCertificate.lean @@ -0,0 +1,70 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.NumberTheory.MaximalDivisorBounds + +/-! +# Exact certificate at the paper's terminal obstruction + +The published maximal-divisor computation stops at the reduced integer + +`(863#)(53#)(13#)(7#)(5#) 3^3 2^5`. + +Its central divisor-lattice coefficient is the paper's exact value +`C₉₃(n)`. The paper treats the two neighboring maximal-divisor counts +independently and therefore uses the square envelope `4 C^2`. The joint +`p - 1`, `p + 1` moment instead supplies `C^2 + 3J`, where the displayed +integer `J` is an exact tenth-root upper certificate. + +All comparisons below are closed integer computations checked by Lean. +-/ + +@[expose] public section + +namespace BGS.NumberTheory + +/-- The reduced integer responsible for the published cutoff. -/ +def publishedTerminalReducedInteger : ℕ := + 344804838267768169319048795913558858218204726396462226085672206158143793783042367351629064411158183411576729661579236952954769470091851501268371488892117339245604283407662126578103043374612406105548170775523572783919769072224460076452087116657499868482554599063664473247688943813839202042578341146702180498643671937922409423337669168695270728922856540751624236363557097567988640618308214400000 + +/-- The exact value `C₉₃(n)` reported in the paper. -/ +def publishedTerminalCentralCoefficient : ℕ := + 3013671869689423302959704266406116383317724743440 + +/-- A tenth-root upper certificate for the joint neighboring divisor count. -/ +def publishedTerminalJointProductEnvelope : ℕ := + 183901584895411967004110876962572064564281061869576148842985488012286272296193902480021778244 + +/-- The new squared-sum envelope `C^2 + 3J`. -/ +def publishedTerminalJointSquareEnvelope : ℕ := + publishedTerminalCentralCoefficient ^ 2 + + 3 * publishedTerminalJointProductEnvelope + +/-- The displayed `J` really dominates the joint tenth-moment radicand. +The slightly looser `(n + 1)^2` form avoids any hidden square-root rounding. -/ +theorem publishedTerminalJointProductEnvelope_certificate : + 2 ^ 457 * (publishedTerminalReducedInteger + 1) ^ 2 ≤ + publishedTerminalJointProductEnvelope ^ 10 := by + decide +kernel + +/-- The new envelope makes the paper's first-interval obstruction empty at +the exact reduced integer that caused the published algorithm to stop. -/ +theorem publishedTerminalJointSquareEnvelope_succeeds : + 3 ^ 8 * publishedTerminalJointSquareEnvelope ^ 4 ≤ + 32 * (publishedTerminalReducedInteger + 2) := by + decide +kernel + +/-- In contrast, the paper's independent envelope `4C^2` fails at this same +integer. This records that the improvement is structural, not a re-rounding +of the published computation. -/ +theorem publishedTerminalIndependentSquareEnvelope_fails : + 32 * (publishedTerminalReducedInteger + 2) < + 3 ^ 8 * (4 * publishedTerminalCentralCoefficient ^ 2) ^ 4 := by + decide +kernel + +end BGS.NumberTheory diff --git a/LeanPool/MarkoffModP/BGS/NumberTheory/JointMaximalDivisorCriterion.lean b/LeanPool/MarkoffModP/BGS/NumberTheory/JointMaximalDivisorCriterion.lean new file mode 100644 index 0000000000..bc96ca5122 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/NumberTheory/JointMaximalDivisorCriterion.lean @@ -0,0 +1,75 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.NumberTheory.JointMaximalDivisorCertificate + +/-! +# Arithmetic core of the joint maximal-divisor algorithm + +The paper's independent `2C` estimate is replaced by a certified square +envelope `M^2 ≤ S`. This removes square roots and division from both the +connectivity test and the rank-refinement bound. +-/ + +@[expose] public section + +namespace BGS.NumberTheory + +/-- A paper-style first-interval witness forces failure of the joint square +test. -/ +theorem jointSquareEnvelope_failure_of_firstInterval + {p n M S : ℕ} + (hn : n + 2 ≤ 4 * p) + (hfirst : 128 * p < (3 * M) ^ 8) + (hSquare : M ^ 2 ≤ S) : + 32 * (n + 2) < 3 ^ 8 * S ^ 4 := by + calc + 32 * (n + 2) ≤ 32 * (4 * p) := Nat.mul_le_mul_left 32 hn + _ = 128 * p := by ring + _ < (3 * M) ^ 8 := hfirst + _ = 3 ^ 8 * (M ^ 2) ^ 4 := by ring + _ ≤ 3 ^ 8 * S ^ 4 := by + gcongr + +/-- The joint envelope shrinks the divisor range in the rank-refinement +step from the paper's `162 C^3` to the root-free bound `81 C S / 2`. -/ +theorem jointRankRefinement_of_firstInterval + {d M C S : ℕ} + (hfirst : 4 * d < 81 * M ^ 3) + (hLinear : M ≤ 2 * C) + (hSquare : M ^ 2 ≤ S) : + 2 * d < 81 * C * S := by + have hCube : M ^ 3 ≤ 2 * C * S := by + calc + M ^ 3 = M * M ^ 2 := by ring + _ ≤ (2 * C) * S := Nat.mul_le_mul hLinear hSquare + _ = 2 * C * S := rfl + have hscaled : 4 * d < 81 * (2 * C * S) := + hfirst.trans_le (Nat.mul_le_mul_left 81 hCube) + by_contra hnot + have hreverse : 81 * C * S ≤ 2 * d := Nat.le_of_not_gt hnot + have hdouble : 81 * (2 * C * S) ≤ 4 * d := by + calc + 81 * (2 * C * S) = 2 * (81 * C * S) := by ring + _ ≤ 2 * (2 * d) := Nat.mul_le_mul_left 2 hreverse + _ = 4 * d := by ring + exact (Nat.not_le_of_lt hscaled) hdouble + +/-- If the joint square test succeeds, no first-interval witness can +exist. -/ +theorem no_firstInterval_of_jointSquareEnvelope + {p n M S : ℕ} + (hn : n + 2 ≤ 4 * p) + (hSquare : M ^ 2 ≤ S) + (hpasses : 3 ^ 8 * S ^ 4 ≤ 32 * (n + 2)) : + ¬ 128 * p < (3 * M) ^ 8 := by + intro hfirst + exact (not_lt_of_ge hpasses) + (jointSquareEnvelope_failure_of_firstInterval hn hfirst hSquare) + +end BGS.NumberTheory diff --git a/LeanPool/MarkoffModP/BGS/NumberTheory/JointNeighborDivisorBound.lean b/LeanPool/MarkoffModP/BGS/NumberTheory/JointNeighborDivisorBound.lean new file mode 100644 index 0000000000..97b35b99cf --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/NumberTheory/JointNeighborDivisorBound.lean @@ -0,0 +1,291 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.NumberTheory.PreliminaryDivisorBound +public import Mathlib.NumberTheory.ArithmeticFunction.Misc + +/-! +# Joint divisor bounds for neighboring even integers + +For an odd natural number `p`, the two torus orders `p - 1` and `p + 1` +have gcd exactly two. Consequently their divisor counts are not independent: + +`τ(p - 1) τ(p + 1) = 2 τ((p^2 - 1) / 2)`. + +Combining this identity with the elementary tenth-moment divisor bound gives +a joint estimate with one copy, rather than two copies, of the prime-factor +penalty. This is the arithmetic input for improving the maximal-divisor +cutoff. +-/ + +@[expose] public section + +namespace BGS.NumberTheory + +private theorem card_divisors_two_mul_of_odd {n : ℕ} (hn : Odd n) : + (2 * n).divisors.card = 2 * n.divisors.card := by + have htwo : (2 : ℕ).divisors.card = 2 := by decide + rw [hn.coprime_two_left.card_divisors_mul] + rw [htwo] + +/-- Exact joint divisor-count identity for the neighboring torus orders. -/ +theorem card_divisors_pred_mul_card_divisors_succ_of_odd + {p : ℕ} (hp : Odd p) : + (p - 1).divisors.card * (p + 1).divisors.card = + 2 * (((p ^ 2 - 1) / 2).divisors.card) := by + rcases hp with ⟨k, rfl⟩ + have hcore : + (((2 * k + 1) ^ 2 - 1) / 2) = 2 * k * (k + 1) := by + have hsquare : + (2 * k + 1) ^ 2 = 2 * (2 * k * (k + 1)) + 1 := by ring + rw [hsquare] + omega + have hconsecutive : k.Coprime (k + 1) := by + rw [Nat.coprime_self_add_right] + exact Nat.coprime_one_right k + have hpred : 2 * k + 1 - 1 = 2 * k := by omega + have hsucc : 2 * k + 1 + 1 = 2 * (k + 1) := by omega + rcases k.even_or_odd with hkEven | hkOdd + · have hkSuccOdd : Odd (k + 1) := hkEven.add_one + have hcoprime : (2 * k).Coprime (k + 1) := + hkSuccOdd.coprime_two_left.mul_left hconsecutive + have hmul := hcoprime.card_divisors_mul + have htwo := card_divisors_two_mul_of_odd hkSuccOdd + rw [hcore, hpred, hsucc] + rw [htwo, hmul] + ring + · have hcoprime : k.Coprime (2 * (k + 1)) := + hkOdd.coprime_two_right.mul_right hconsecutive + have hmul := hcoprime.card_divisors_mul + have htwo := card_divisors_two_mul_of_odd hkOdd + have hfactor : 2 * k * (k + 1) = k * (2 * (k + 1)) := by ring + rw [hcore, hpred, hsucc, hfactor] + rw [htwo, hmul] + ring + +/-- The product of the two neighboring divisor counts has a single +prime-penalty factor in its tenth moment. -/ +theorem card_divisors_pred_mul_card_divisors_succ_pow_ten_le + {p : ℕ} (hp : Odd p) (hpTwo : 2 < p) : + ((p - 1).divisors.card * (p + 1).divisors.card) ^ 10 ≤ + 2 ^ 456 * (p ^ 2 - 1) := by + let core := (p ^ 2 - 1) / 2 + have hpSq : 9 ≤ p ^ 2 := by nlinarith + have hcorePos : 0 < core := by + apply Nat.div_pos + · omega + · norm_num + have hmoment := + card_divisors_pow_ten_le_preliminary_constant_mul core hcorePos.ne' + have htwiceCore : 2 * core = p ^ 2 - 1 := by + rcases hp with ⟨k, rfl⟩ + dsimp [core] + have hsquare : (2 * k + 1) ^ 2 = 2 * (2 * k * (k + 1)) + 1 := by ring + rw [hsquare] + omega + have hexponent : 10 + 447 = 456 + 1 := by norm_num + calc + ((p - 1).divisors.card * (p + 1).divisors.card) ^ 10 = + (2 * core.divisors.card) ^ 10 := by + rw [card_divisors_pred_mul_card_divisors_succ_of_odd hp] + _ = 2 ^ 10 * core.divisors.card ^ 10 := by rw [mul_pow] + _ ≤ 2 ^ 10 * (2 ^ 447 * core) := Nat.mul_le_mul_left _ hmoment + _ = (2 ^ 10 * 2 ^ 447) * core := (Nat.mul_assoc _ _ _).symm + _ = 2 ^ (10 + 447) * core := by rw [pow_add] + _ = 2 ^ (456 + 1) * core := by rw [hexponent] + _ = (2 ^ 456 * 2) * core := by rw [pow_succ] + _ = 2 ^ 456 * (2 * core) := Nat.mul_assoc _ _ _ + _ = 2 ^ 456 * (p ^ 2 - 1) := by rw [htwiceCore] + +/-- Joint tenth-moment constant for the sum of the neighboring divisor counts. +The leading term is the one-number prime penalty; the smaller correction pays +for the transition between the balanced and dominant cases. -/ +def neighboringDivisorSumMomentConstant : Nat := + 2 ^ 447 + 2 ^ 429 + +/-- Split point used to combine the product moment with the two individual +moments. It is chosen so that both resulting integer inequalities hold. -/ +theorem neighboringDivisorSumMomentConstant_eq : + neighboringDivisorSumMomentConstant = 2 ^ 429 * 262145 := by + decide +kernel + +private def neighboringDivisorSumSplit : Nat := + 3913424 + +private theorem neighboringDivisorSum_balanced_constant : + (neighboringDivisorSumSplit + 1) ^ 10 * 2 ^ 228 ≤ + neighboringDivisorSumMomentConstant := by + decide +kernel + +private theorem neighboringDivisorSum_dominant_constant + {p : Nat} (hp : 794039 ≤ p) : + (neighboringDivisorSumSplit + 1) ^ 10 * 2 ^ 447 * (p + 1) ≤ + neighboringDivisorSumSplit ^ 10 * + neighboringDivisorSumMomentConstant * p := by + norm_num [neighboringDivisorSumSplit, neighboringDivisorSumMomentConstant] at * + omega + +/-- Square-root form of the joint product moment. -/ +theorem card_divisors_pred_mul_card_divisors_succ_pow_five_le + {p : Nat} (hp : Odd p) (hpTwo : 2 < p) : + ((p - 1).divisors.card * (p + 1).divisors.card) ^ 5 ≤ + 2 ^ 228 * p := by + apply (Nat.pow_le_pow_iff_left (by norm_num : 2 ≠ 0)).mp + calc + (((p - 1).divisors.card * (p + 1).divisors.card) ^ 5) ^ 2 = + ((p - 1).divisors.card * (p + 1).divisors.card) ^ 10 := by ring + _ ≤ 2 ^ 456 * (p ^ 2 - 1) := + card_divisors_pred_mul_card_divisors_succ_pow_ten_le hp hpTwo + _ ≤ 2 ^ 456 * p ^ 2 := by + gcongr + omega + _ = (2 ^ 228 * p) ^ 2 := by + rw [show (456 : Nat) = 228 * 2 by norm_num, pow_mul] + ring + +private theorem nat_le_of_pos_mul_le_mul_left + {c x y : Nat} (hc : 0 < c) (h : c * x ≤ c * y) : + x ≤ y := + Nat.le_of_mul_le_mul_left h hc + +/-- A joint tenth moment for the sum of the neighboring divisor counts. + +The usual power-of-a-sum inequality loses a factor of (2^9). Here comparable +counts are controlled by the product moment, while in the dominant case the +larger individual count controls the sum. -/ +theorem card_divisors_pred_add_card_divisors_succ_pow_ten_le + {p : Nat} (hp : Odd p) (hpLarge : 794039 ≤ p) : + ((p - 1).divisors.card + (p + 1).divisors.card) ^ 10 ≤ + neighboringDivisorSumMomentConstant * p := by + let a := (p - 1).divisors.card + let b := (p + 1).divisors.card + let R := neighboringDivisorSumSplit + let K := 2 ^ 447 + let D := neighboringDivisorSumMomentConstant + have hpTwo : 2 < p := by omega + have hminus : a ^ 10 ≤ K * (p - 1) := by + simpa [a, K] using + card_divisors_pow_ten_le_preliminary_constant_mul (p - 1) (by omega) + have hplus : b ^ 10 ≤ K * (p + 1) := by + simpa [b, K] using + card_divisors_pow_ten_le_preliminary_constant_mul (p + 1) (by omega) + have hminusCommon : a ^ 10 ≤ K * (p + 1) := + hminus.trans (Nat.mul_le_mul_left K (by omega)) + have hproductFive : (a * b) ^ 5 ≤ 2 ^ 228 * p := by + simpa [a, b] using + card_divisors_pred_mul_card_divisors_succ_pow_five_le hp hpTwo + have hbalanced : (R + 1) ^ 10 * 2 ^ 228 ≤ D := by + simpa [R, D] using neighboringDivisorSum_balanced_constant + have hRPos : 0 < R := by norm_num [R, neighboringDivisorSumSplit] + have hRpowPos : 0 < R ^ 10 := pow_pos hRPos 10 + have hdominant : + (R + 1) ^ 10 * K * (p + 1) ≤ R ^ 10 * D * p := by + simpa [R, K, D] using neighboringDivisorSum_dominant_constant hpLarge + rcases le_total a b with hab | hba + · by_cases hfar : R * a ≤ b + · have hlinear : R * (a + b) ≤ (R + 1) * b := by + calc + R * (a + b) = R * a + R * b := by ring + _ ≤ b + R * b := Nat.add_le_add_right hfar _ + _ = (R + 1) * b := by ring + have hpow := Nat.pow_le_pow_left hlinear 10 + have hscaled : R ^ 10 * (a + b) ^ 10 ≤ R ^ 10 * (D * p) := by + calc + R ^ 10 * (a + b) ^ 10 = (R * (a + b)) ^ 10 := by ring + _ ≤ ((R + 1) * b) ^ 10 := hpow + _ = (R + 1) ^ 10 * b ^ 10 := by ring + _ ≤ (R + 1) ^ 10 * (K * (p + 1)) := + Nat.mul_le_mul_left _ hplus + _ = (R + 1) ^ 10 * K * (p + 1) := by ring + _ ≤ R ^ 10 * (D * p) := by + simpa only [Nat.mul_assoc] using hdominant + exact nat_le_of_pos_mul_le_mul_left + (c := R ^ 10) (x := (a + b) ^ 10) (y := D * p) + hRpowPos hscaled + · have hnear : b ≤ R * a := by omega + have hlinear : a + b ≤ (R + 1) * a := by + calc + a + b ≤ a + R * a := Nat.add_le_add_left hnear _ + _ = (R + 1) * a := by ring + have haa : a * a ≤ a * b := Nat.mul_le_mul_left a hab + calc + (a + b) ^ 10 ≤ ((R + 1) * a) ^ 10 := + Nat.pow_le_pow_left hlinear 10 + _ = (R + 1) ^ 10 * (a * a) ^ 5 := by ring + _ ≤ (R + 1) ^ 10 * (a * b) ^ 5 := + Nat.mul_le_mul_left _ (Nat.pow_le_pow_left haa 5) + _ ≤ (R + 1) ^ 10 * (2 ^ 228 * p) := + Nat.mul_le_mul_left _ hproductFive + _ = ((R + 1) ^ 10 * 2 ^ 228) * p := by ring + _ ≤ D * p := Nat.mul_le_mul_right p hbalanced + · by_cases hfar : R * b ≤ a + · have hlinear : R * (a + b) ≤ (R + 1) * a := by + calc + R * (a + b) = R * a + R * b := by ring + _ = R * b + R * a := by ring + _ ≤ a + R * a := Nat.add_le_add_right hfar _ + _ = (R + 1) * a := by ring + have hpow := Nat.pow_le_pow_left hlinear 10 + have hscaled : R ^ 10 * (a + b) ^ 10 ≤ R ^ 10 * (D * p) := by + calc + R ^ 10 * (a + b) ^ 10 = (R * (a + b)) ^ 10 := by ring + _ ≤ ((R + 1) * a) ^ 10 := hpow + _ = (R + 1) ^ 10 * a ^ 10 := by ring + _ ≤ (R + 1) ^ 10 * (K * (p + 1)) := + Nat.mul_le_mul_left _ hminusCommon + _ = (R + 1) ^ 10 * K * (p + 1) := by ring + _ ≤ R ^ 10 * (D * p) := by + simpa only [Nat.mul_assoc] using hdominant + exact nat_le_of_pos_mul_le_mul_left + (c := R ^ 10) (x := (a + b) ^ 10) (y := D * p) + hRpowPos hscaled + · have hnear : a ≤ R * b := by omega + have hlinear : a + b ≤ (R + 1) * b := by + calc + a + b ≤ R * b + b := Nat.add_le_add_right hnear _ + _ = (R + 1) * b := by ring + have hbb : b * b ≤ a * b := by + simpa [Nat.mul_comm] using Nat.mul_le_mul_left b hba + calc + (a + b) ^ 10 ≤ ((R + 1) * b) ^ 10 := + Nat.pow_le_pow_left hlinear 10 + _ = (R + 1) ^ 10 * (b * b) ^ 5 := by ring + _ ≤ (R + 1) ^ 10 * (a * b) ^ 5 := + Nat.mul_le_mul_left _ (Nat.pow_le_pow_left hbb 5) + _ ≤ (R + 1) ^ 10 * (2 ^ 228 * p) := + Nat.mul_le_mul_left _ hproductFive + _ = ((R + 1) ^ 10 * 2 ^ 228) * p := by ring + _ ≤ D * p := Nat.mul_le_mul_right p hbalanced + +/-- If two nonnegative counts are individually at most `C` and their product +is at most `J`, their squared sum is bounded by `C^2 + 3J`. This is the +elementary inequality that replaces the paper's independent `4C^2` bound. -/ +theorem add_sq_le_sq_add_three_mul_of_le_of_mul_le + {a b C J : ℕ} (ha : a ≤ C) (hb : b ≤ C) (hab : a * b ≤ J) : + (a + b) ^ 2 ≤ C ^ 2 + 3 * J := by + rcases le_total a b with habOrder | hbaOrder + · have haSq : a * a ≤ a * b := Nat.mul_le_mul_left a habOrder + have hbSq : b * b ≤ C * C := Nat.mul_le_mul hb hb + nlinarith [hab] + · have hbSq : b * b ≤ a * b := by + simpa [Nat.mul_comm] using Nat.mul_le_mul_left b hbaOrder + have haSq : a * a ≤ C * C := Nat.mul_le_mul ha ha + nlinarith [hab] + +/-- Convert a certified tenth-moment envelope into the joint squared-sum +bound used by the improved maximal-divisor algorithm. -/ +theorem add_sq_le_sq_add_three_mul_of_pow_ten_envelope + {a b C J K : ℕ} + (ha : a ≤ C) (hb : b ≤ C) + (hmoment : (a * b) ^ 10 ≤ K) (henvelope : K ≤ J ^ 10) : + (a + b) ^ 2 ≤ C ^ 2 + 3 * J := by + apply add_sq_le_sq_add_three_mul_of_le_of_mul_le ha hb + apply (Nat.pow_le_pow_iff_left (by norm_num : 10 ≠ 0)).mp + exact hmoment.trans henvelope + +end BGS.NumberTheory diff --git a/LeanPool/MarkoffModP/BGS/NumberTheory/MaximalDivisorBounds.lean b/LeanPool/MarkoffModP/BGS/NumberTheory/MaximalDivisorBounds.lean new file mode 100644 index 0000000000..ecb78ecfd1 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/NumberTheory/MaximalDivisorBounds.lean @@ -0,0 +1,172 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.NumberTheory.JointNeighborDivisorBound +public import Mathlib.GroupTheory.SpecificGroups.Cyclic.Basic + +/-! +# Maximal-divisor bounds + +This file proves the finite-poset cover behind the paper's maximal-divisor +improvement and combines it with the new joint `p - 1`, `p + 1` estimate. +-/ + +@[expose] public section + +namespace BGS.NumberTheory + +/-- Divisors of `n` maximal under divisibility among those strictly below +`bound`. -/ +def maximalDivisorsBelow (n bound : ℕ) : Finset ℕ := + n.divisors.filter fun d => + d < bound ∧ + ∀ e ∈ n.divisors, e < bound → d ∣ e → e = d + +@[simp] +theorem mem_maximalDivisorsBelow_iff + {n bound d : ℕ} : + d ∈ maximalDivisorsBelow n bound ↔ + d ∈ n.divisors ∧ d < bound ∧ + ∀ e ∈ n.divisors, e < bound → d ∣ e → e = d := by + simp [maximalDivisorsBelow] + +theorem maximalDivisorsBelow_subset_divisors (n bound : ℕ) : + maximalDivisorsBelow n bound ⊆ n.divisors := by + intro d hd + exact (mem_maximalDivisorsBelow_iff.mp hd).1 + +theorem maximalDivisorsBelow_card_le_card_divisors (n bound : ℕ) : + (maximalDivisorsBelow n bound).card ≤ n.divisors.card := + Finset.card_le_card (maximalDivisorsBelow_subset_divisors n bound) + +/-- Every divisor below the cutoff divides a maximal divisor below it. -/ +theorem exists_dvd_maximalDivisorBelow + {n bound d : ℕ} (hn : n ≠ 0) (hdn : d ∣ n) (hdbound : d < bound) : + ∃ m ∈ maximalDivisorsBelow n bound, d ∣ m := by + let candidates := n.divisors.filter fun m => m < bound ∧ d ∣ m + have hdmem : d ∈ n.divisors := Nat.mem_divisors.mpr ⟨hdn, hn⟩ + have hnonempty : candidates.Nonempty := by + refine ⟨d, ?_⟩ + simp [candidates, hdmem, hdbound] + let m := candidates.max' hnonempty + have hmmem : m ∈ candidates := Finset.max'_mem candidates hnonempty + have hmdata : m ∈ n.divisors ∧ m < bound ∧ d ∣ m := by + simpa [candidates] using hmmem + refine ⟨m, ?_, hmdata.2.2⟩ + rw [mem_maximalDivisorsBelow_iff] + refine ⟨hmdata.1, hmdata.2.1, ?_⟩ + intro e hediv hebound hme + have hde : d ∣ e := hmdata.2.2.trans hme + have hemem : e ∈ candidates := by + simp only [candidates, Finset.mem_filter] + exact ⟨hediv, hebound, hde⟩ + have hem : e ≤ m := Finset.le_max' candidates e hemem + have hepos : 0 < e := + Nat.pos_of_dvd_of_pos (Nat.mem_divisors.mp hediv).1 (Nat.pos_of_ne_zero hn) + have hme' : m ≤ e := Nat.le_of_dvd hepos hme + exact Nat.le_antisymm hem hme' + +section CyclicCover + +variable (G : Type*) [Group G] [Fintype G] [DecidableEq G] + +/-- Elements killed by the `m`-th power map. -/ +def elementsWithPowOne (m : ℕ) : Finset G := + Finset.univ.filter fun g => g ^ m = 1 + +@[simp] +theorem mem_elementsWithPowOne_iff {m : ℕ} {g : G} : + g ∈ elementsWithPowOne G m ↔ g ^ m = 1 := by + simp [elementsWithPowOne] + +/-- Low-order elements in a cyclic group are covered by roots-of-unity sets +indexed by maximal divisors. -/ +theorem elementsOfOrderLessThan_subset_maximalDivisorCover + [IsCyclic G] (bound : ℕ) : + (Finset.univ.filter fun g : G => orderOf g < bound) ⊆ + (maximalDivisorsBelow (Fintype.card G) bound).biUnion + (elementsWithPowOne G) := by + intro g hg + have hgorder : orderOf g < bound := (Finset.mem_filter.mp hg).2 + obtain ⟨m, hmmax, horderDvd⟩ := + exists_dvd_maximalDivisorBelow Fintype.card_ne_zero orderOf_dvd_card hgorder + rw [Finset.mem_biUnion] + refine ⟨m, hmmax, ?_⟩ + rw [mem_elementsWithPowOne_iff] + exact orderOf_dvd_iff_pow_eq_one.mp horderDvd + +/-- The cyclic low-order count using only maximal divisors. -/ +theorem elementsOfOrderLessThan_card_le_maximalDivisors + [IsCyclic G] (bound : ℕ) : + (Finset.univ.filter fun g : G => orderOf g < bound).card ≤ + (bound - 1) * + (maximalDivisorsBelow (Fintype.card G) bound).card := by + calc + (Finset.univ.filter fun g : G => orderOf g < bound).card ≤ + ((maximalDivisorsBelow (Fintype.card G) bound).biUnion + (elementsWithPowOne G)).card := + Finset.card_le_card + (elementsOfOrderLessThan_subset_maximalDivisorCover G bound) + _ ≤ (maximalDivisorsBelow (Fintype.card G) bound).card * + (bound - 1) := by + apply Finset.card_biUnion_le_card_mul + intro m hm + have hmLt : m < bound := + (mem_maximalDivisorsBelow_iff.mp hm).2.1 + have hmPos : 0 < m := by + have hmDvd : m ∣ Fintype.card G := + (Nat.mem_divisors.mp + (mem_maximalDivisorsBelow_iff.mp hm).1).1 + exact Nat.pos_of_dvd_of_pos hmDvd Fintype.card_pos + calc + (elementsWithPowOne G m).card ≤ m := + IsCyclic.card_pow_eq_one_le hmPos + _ ≤ bound - 1 := Nat.le_sub_one_of_lt hmLt + _ = (bound - 1) * + (maximalDivisorsBelow (Fintype.card G) bound).card := + Nat.mul_comm _ _ + +end CyclicCover + +/-- The two maximal-divisor counts inherit the exact joint tenth moment. -/ +theorem maximalDivisorCounts_product_pow_ten_le + {p bound : ℕ} (hp : Odd p) (hpTwo : 2 < p) : + ((maximalDivisorsBelow (p - 1) bound).card * + (maximalDivisorsBelow (p + 1) bound).card) ^ 10 ≤ + 2 ^ 457 * (p ^ 2 - 1) := by + have hminus : + (maximalDivisorsBelow (p - 1) bound).card ≤ + (p - 1).divisors.card := + maximalDivisorsBelow_card_le_card_divisors _ _ + have hplus : + (maximalDivisorsBelow (p + 1) bound).card ≤ + (p + 1).divisors.card := + maximalDivisorsBelow_card_le_card_divisors _ _ + calc + ((maximalDivisorsBelow (p - 1) bound).card * + (maximalDivisorsBelow (p + 1) bound).card) ^ 10 ≤ + ((p - 1).divisors.card * (p + 1).divisors.card) ^ 10 := + Nat.pow_le_pow_left (Nat.mul_le_mul hminus hplus) 10 + _ ≤ 2 ^ 456 * (p ^ 2 - 1) := + card_divisors_pred_mul_card_divisors_succ_pow_ten_le hp hpTwo + _ ≤ 2 ^ 457 * (p ^ 2 - 1) := by gcongr; norm_num + +/-- The new square envelope for the sum of the two maximal-divisor counts. -/ +theorem maximalDivisorCounts_add_sq_le + {p bound C J : ℕ} + (hminus : (maximalDivisorsBelow (p - 1) bound).card ≤ C) + (hplus : (maximalDivisorsBelow (p + 1) bound).card ≤ C) + (hproduct : + (maximalDivisorsBelow (p - 1) bound).card * + (maximalDivisorsBelow (p + 1) bound).card ≤ J) : + ((maximalDivisorsBelow (p - 1) bound).card + + (maximalDivisorsBelow (p + 1) bound).card) ^ 2 ≤ + C ^ 2 + 3 * J := + add_sq_le_sq_add_three_mul_of_le_of_mul_le hminus hplus hproduct + +end BGS.NumberTheory diff --git a/LeanPool/MarkoffModP/BGS/NumberTheory/NonparabolicComplementCriterion.lean b/LeanPool/MarkoffModP/BGS/NumberTheory/NonparabolicComplementCriterion.lean new file mode 100644 index 0000000000..a62c7dfbc5 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/NumberTheory/NonparabolicComplementCriterion.lean @@ -0,0 +1,64 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.NumberTheory.JointMaximalDivisorCriterion + +/-! +# Arithmetic criterion for the nonparabolic complement route + +The complement count supplies `8 * p ≤ (d * M) ^ 2`. The exact +Euler-characteristic coefficient anticipated by the strengthened +Corvaja--Zannier step gives `d ≤ 189 * M ^ 3`. Eliminating `d` yields the +integer obstruction `8 * p ≤ 189 ^ 2 * M ^ 8`. + +A root-free square envelope `M ^ 2 ≤ S` then gives +`8 * p ≤ 35721 * S ^ 4`. +-/ + +@[expose] public section + +namespace BGS.NumberTheory + +/-- Eliminate the maximal order `d` from the nonparabolic complement count +using the exact coefficient `189`. -/ +theorem eight_mul_le_189_sq_mul_eighth_of_le_square_of_le_189_mul_cube + {p d M : ℕ} + (hcount : 8 * p ≤ (d * M) ^ 2) + (hdegree : d ≤ 189 * M ^ 3) : + 8 * p ≤ 189 ^ 2 * M ^ 8 := by + calc + 8 * p ≤ (d * M) ^ 2 := hcount + _ ≤ ((189 * M ^ 3) * M) ^ 2 := by + gcongr + _ = 189 ^ 2 * M ^ 8 := by ring + +/-- Replace `M` by any certified square envelope `S`; `189^2 = 35721`. -/ +theorem eight_mul_le_35721_mul_fourth_of_le_189_sq_mul_eighth + {p M S : ℕ} + (hbad : 8 * p ≤ 189 ^ 2 * M ^ 8) + (hSquare : M ^ 2 ≤ S) : + 8 * p ≤ 35721 * S ^ 4 := by + calc + 8 * p ≤ 189 ^ 2 * M ^ 8 := hbad + _ = 35721 * (M ^ 2) ^ 4 := by ring + _ ≤ 35721 * S ^ 4 := by + gcongr + +/-- Combined root-free obstruction for the nonparabolic complement route. -/ +theorem eight_mul_le_35721_mul_fourth_of_count_degree_squareEnvelope + {p d M S : ℕ} + (hcount : 8 * p ≤ (d * M) ^ 2) + (hdegree : d ≤ 189 * M ^ 3) + (hSquare : M ^ 2 ≤ S) : + 8 * p ≤ 35721 * S ^ 4 := + eight_mul_le_35721_mul_fourth_of_le_189_sq_mul_eighth + (eight_mul_le_189_sq_mul_eighth_of_le_square_of_le_189_mul_cube + hcount hdegree) + hSquare + +end BGS.NumberTheory diff --git a/LeanPool/MarkoffModP/BGS/NumberTheory/OneSidedPrimitiveWitness.lean b/LeanPool/MarkoffModP/BGS/NumberTheory/OneSidedPrimitiveWitness.lean new file mode 100644 index 0000000000..0a18f2a067 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/NumberTheory/OneSidedPrimitiveWitness.lean @@ -0,0 +1,325 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Endgame.PrimitiveInclusionExclusion +public import LeanPool.MarkoffModP.BGS.Markoff.Endgame.PowerCoverCounting + +/-! +# One-sided primitive extraction with witness multiplicities + +The cage fiber-product count has an arbitrary finite witness type on the left +and a cyclic multiplicative group on the right. This file performs Möbius +inversion without erasing the left witness. +-/ + +@[expose] public section + +namespace BGS + +open scoped ArithmeticFunction.Moebius BigOperators + +noncomputable section + +variable {A H T : Type*} [CommGroup H] + +/-- Witness/parameter pairs satisfying a relation. -/ +noncomputable def rightTraceRelationPairs + [Finite A] [Finite H] (leftTrace : A → T) (rightTrace : H → T) : + Finset (A × H) := by + classical + letI := Fintype.ofFinite A + letI := Fintype.ofFinite H + exact Finset.univ.filter fun z => leftTrace z.1 = rightTrace z.2 + +/-- Relation pairs whose right parameter has exact multiplicative order. -/ +noncomputable def rightTraceExactOrderSolutions + [Finite A] [Finite H] (leftTrace : A → T) (rightTrace : H → T) + (order : ℕ) : Finset (A × H) := by + classical + exact (rightTraceRelationPairs leftTrace rightTrace).filter fun z => + orderOf z.2 = order + +/-- Relation pairs whose right parameter is killed by a specified power. -/ +noncomputable def rightTracePowerKernelSolutions + [Finite A] [Finite H] (leftTrace : A → T) (rightTrace : H → T) + (exponent : ℕ) : Finset (A × H) := by + classical + exact (rightTraceRelationPairs leftTrace rightTrace).filter fun z => + z.2 ^ exponent = 1 + +/-- Relation pairs with the right parameter restricted to a power-map image. -/ +def rightPowerTraceRangeSolutions + (leftTrace : A → T) (rightTrace : H → T) (exponent : ℕ) := + {z : A × (powMonoidHom exponent : H →* H).range // + leftTrace z.1 = rightTrace z.2} + +/-- The one-sided power cover before quotienting by the power-map fibers. -/ +def rightPowerTraceCoverSolutions + (leftTrace : A → T) (rightTrace : H → T) (exponent : ℕ) := + {z : A × H // leftTrace z.1 = rightTrace (z.2 ^ exponent)} + +/-- A one-sided cover point is a range solution together with a point in the +corresponding power-map fiber. -/ +def rightPowerTraceCoverEquivSigmaFiber + (leftTrace : A → T) (rightTrace : H → T) (exponent : ℕ) : + rightPowerTraceCoverSolutions leftTrace rightTrace exponent ≃ + Σ s : rightPowerTraceRangeSolutions leftTrace rightTrace exponent, + ((powMonoidHom exponent : H →* H) ⁻¹' {(s.1.2 : H)} : Set H) where + toFun z := + ⟨⟨(z.1.1, ⟨z.1.2 ^ exponent, ⟨z.1.2, by simp⟩⟩), z.2⟩, + ⟨z.1.2, by simp⟩⟩ + invFun z := ⟨(z.1.1.1, z.2.1), by + have hz : (powMonoidHom exponent : H →* H) z.2.1 = (z.1.1.2 : H) := z.2.2 + change leftTrace z.1.1.1 = rightTrace (z.2.1 ^ exponent) + rw [show z.2.1 ^ exponent = z.1.1.2 by exact hz] + exact z.1.2⟩ + left_inv z := by rfl + right_inv z := by + rcases z with ⟨⟨⟨a, ⟨u, huRange⟩⟩, htrace⟩, ⟨root, hroot⟩⟩ + simp only [Set.mem_preimage, Set.mem_singleton_iff] at hroot + dsimp at hroot ⊢ + subst u + rfl + +/-- Exact one-sided power-cover multiplicity. -/ +theorem natCard_rightPowerTraceCoverSolutions + [Finite A] [Finite H] + (leftTrace : A → T) (rightTrace : H → T) (exponent : ℕ) : + Nat.card (rightPowerTraceCoverSolutions leftTrace rightTrace exponent) = + Nat.card (powMonoidHom exponent : H →* H).ker * + Nat.card (rightPowerTraceRangeSolutions leftTrace rightTrace exponent) := by + let : Finite (powMonoidHom exponent : H →* H).range := + Finite.of_injective Subtype.val Subtype.val_injective + let : Finite (rightPowerTraceRangeSolutions leftTrace rightTrace exponent) := + Finite.of_injective Subtype.val Subtype.val_injective + let := Fintype.ofFinite + (rightPowerTraceRangeSolutions leftTrace rightTrace exponent) + rw [Nat.card_congr + (rightPowerTraceCoverEquivSigmaFiber leftTrace rightTrace exponent), + Nat.card_sigma] + simp_rw [BGS.Markoff.natCard_powerMapFiber_eq_ker] + simp [Nat.mul_comm] + +/-- For a divisor exponent in a finite cyclic group, the one-sided cover has +exactly `d` points above every power-range solution. -/ +theorem natCard_rightPowerTraceCoverSolutions_of_dvd + [Finite A] [Finite H] [IsCyclic H] + (leftTrace : A → T) (rightTrace : H → T) (d : ℕ) + (hd : d ∣ Nat.card H) : + Nat.card (rightPowerTraceCoverSolutions leftTrace rightTrace d) = + d * Nat.card (rightPowerTraceRangeSolutions leftTrace rightTrace d) := by + rw [natCard_rightPowerTraceCoverSolutions, + IsCyclic.card_powMonoidHom_ker, + Nat.gcd_eq_right_iff_dvd.mpr hd] + +@[simp] +theorem mem_rightTraceExactOrderSolutions_iff + [Finite A] [Finite H] (leftTrace : A → T) (rightTrace : H → T) + (order : ℕ) (z : A × H) : + z ∈ rightTraceExactOrderSolutions leftTrace rightTrace order ↔ + leftTrace z.1 = rightTrace z.2 ∧ orderOf z.2 = order := by + classical + simp [rightTraceExactOrderSolutions, rightTraceRelationPairs] + +@[simp] +theorem mem_rightTracePowerKernelSolutions_iff + [Finite A] [Finite H] (leftTrace : A → T) (rightTrace : H → T) + (exponent : ℕ) (z : A × H) : + z ∈ rightTracePowerKernelSolutions leftTrace rightTrace exponent ↔ + leftTrace z.1 = rightTrace z.2 ∧ z.2 ^ exponent = 1 := by + classical + simp [rightTracePowerKernelSolutions, rightTraceRelationPairs] + +/-- Exact-order classes partition the relation pairs killed by one power. -/ +theorem sum_rightTraceExactOrderSolutions_card_eq_powerKernel_card + [Finite A] [Finite H] (leftTrace : A → T) (rightTrace : H → T) + (m : ℕ) (hm : 0 < m) : + ∑ order ∈ m.divisors, + (rightTraceExactOrderSolutions leftTrace rightTrace order).card = + (rightTracePowerKernelSolutions leftTrace rightTrace m).card := by + classical + simp only [rightTraceExactOrderSolutions] + rw [Finset.sum_card_fiberwise_eq_card_filter] + apply congrArg Finset.card + ext z + simp [rightTracePowerKernelSolutions, Nat.mem_divisors, hm.ne', + orderOf_dvd_iff_pow_eq_one] + +/-- Möbius inversion recovers the witness-bearing exact-order count. -/ +theorem moebius_sum_rightTracePowerKernel_card_eq_exactOrder_card + [Finite A] [Finite H] (leftTrace : A → T) (rightTrace : H → T) + (n : ℕ) (hn : 0 < n) : + ∑ x ∈ n.divisorsAntidiagonal, + (μ x.fst : ℤ) * + (rightTracePowerKernelSolutions leftTrace rightTrace x.snd).card = + (rightTraceExactOrderSolutions leftTrace rightTrace n).card := by + have hinversion := + (ArithmeticFunction.sum_eq_iff_sum_mul_moebius_eq + (R := ℤ) + (f := fun order => + ((rightTraceExactOrderSolutions leftTrace rightTrace order).card : ℤ)) + (g := fun exponent => + ((rightTracePowerKernelSolutions leftTrace rightTrace exponent).card : ℤ))).mp + (fun m hm => by + exact_mod_cast + sum_rightTraceExactOrderSolutions_card_eq_powerKernel_card + leftTrace rightTrace m hm) + exact hinversion n hn + +/-- A right power-range witness is a right power-kernel witness when the +corresponding subgroups agree. -/ +def rightPowerTraceRangeSolutionsEquivPowerKernelSolutions + [Finite A] [Finite H] + (leftTrace : A → T) (rightTrace : H → T) + (rangeExponent kernelExponent : ℕ) + (hsubgroup : + (powMonoidHom rangeExponent : H →* H).range = + (powMonoidHom kernelExponent : H →* H).ker) : + rightPowerTraceRangeSolutions leftTrace rightTrace rangeExponent ≃ + ↥(rightTracePowerKernelSolutions leftTrace rightTrace kernelExponent) where + toFun z := ⟨(z.1.1, z.1.2.1), by + rw [mem_rightTracePowerKernelSolutions_iff] + refine ⟨z.2, ?_⟩ + have hzker : z.1.2.1 ∈ (powMonoidHom kernelExponent : H →* H).ker := by + rw [← hsubgroup] + exact z.1.2.2 + exact hzker⟩ + invFun z := ⟨(z.1.1, ⟨z.1.2, by + rw [hsubgroup] + exact (mem_rightTracePowerKernelSolutions_iff + leftTrace rightTrace kernelExponent z.1).mp z.2 |>.2⟩), + (mem_rightTracePowerKernelSolutions_iff + leftTrace rightTrace kernelExponent z.1).mp z.2 |>.1⟩ + left_inv z := by rfl + right_inv z := by rfl + +theorem natCard_rightPowerTraceRangeSolutions_eq_powerKernel_card + [Finite A] [Finite H] + (leftTrace : A → T) (rightTrace : H → T) + (rangeExponent kernelExponent : ℕ) + (hsubgroup : + (powMonoidHom rangeExponent : H →* H).range = + (powMonoidHom kernelExponent : H →* H).ker) : + Nat.card (rightPowerTraceRangeSolutions leftTrace rightTrace rangeExponent) = + (rightTracePowerKernelSolutions leftTrace rightTrace kernelExponent).card := by + calc + Nat.card (rightPowerTraceRangeSolutions leftTrace rightTrace rangeExponent) = + Nat.card ↥(rightTracePowerKernelSolutions + leftTrace rightTrace kernelExponent) := + Nat.card_congr + (rightPowerTraceRangeSolutionsEquivPowerKernelSolutions + leftTrace rightTrace rangeExponent kernelExponent hsubgroup) + _ = (rightTracePowerKernelSolutions + leftTrace rightTrace kernelExponent).card := by + rw [Nat.card_eq_fintype_card, Fintype.card_coe] + +/-- Published one-sided inclusion--exclusion, retaining every left witness. -/ +theorem moebius_sum_rightPowerTraceRange_card_eq_exactOrder_card + [Finite A] [Finite H] [IsCyclic H] + (leftTrace : A → T) (rightTrace : H → T) : + ∑ x ∈ (Nat.card H).divisorsAntidiagonal, + (μ x.fst : ℤ) * + Nat.card (rightPowerTraceRangeSolutions + leftTrace rightTrace x.fst) = + (rightTraceExactOrderSolutions + leftTrace rightTrace (Nat.card H)).card := by + rw [← moebius_sum_rightTracePowerKernel_card_eq_exactOrder_card + leftTrace rightTrace (Nat.card H) Nat.card_pos] + apply Finset.sum_congr rfl + intro x hx + congr 1 + have hproduct := (Nat.mem_divisorsAntidiagonal.mp hx).1 + have hleftNe : x.fst ≠ 0 := Nat.left_ne_zero_of_mem_divisorsAntidiagonal hx + have hdvd : x.fst ∣ Nat.card H := ⟨x.snd, hproduct.symm⟩ + have hquotient : Nat.card H / x.fst = x.snd := by + rw [← hproduct, Nat.mul_comm x.fst x.snd, + Nat.mul_div_left x.snd (Nat.pos_of_ne_zero hleftNe)] + rw [natCard_rightPowerTraceRangeSolutions_eq_powerKernel_card + leftTrace rightTrace x.fst x.snd] + simpa [hquotient] using + BGS.Markoff.powMonoidHom_range_eq_ker_complementaryExponent + (H := H) x.fst hdvd + +/-- Pointwise range-count estimates give the divisor-count error envelope for +the witness-bearing primitive count. -/ +theorem rightTraceExactOrderSolutions_card_error_le_moebiusMain + [Finite A] [Finite H] [IsCyclic H] + (leftTrace : A → T) (rightTrace : H → T) + (mainTerm : ℕ → ℝ) (error : ℝ) + (hRange : ∀ d : ℕ, d ∣ Nat.card H → 0 < d → + |(Nat.card (rightPowerTraceRangeSolutions + leftTrace rightTrace d) : ℝ) - mainTerm d| ≤ error) : + |((rightTraceExactOrderSolutions + leftTrace rightTrace (Nat.card H)).card : ℝ) - + ∑ x ∈ (Nat.card H).divisorsAntidiagonal, + (μ x.fst : ℝ) * mainTerm x.fst| ≤ + ((Nat.card H).divisors.card : ℝ) * error := by + have hExact := + moebius_sum_rightPowerTraceRange_card_eq_exactOrder_card + leftTrace rightTrace + have hExactReal : + ((rightTraceExactOrderSolutions + leftTrace rightTrace (Nat.card H)).card : ℝ) = + ∑ x ∈ (Nat.card H).divisorsAntidiagonal, + (μ x.fst : ℝ) * + (Nat.card (rightPowerTraceRangeSolutions + leftTrace rightTrace x.fst) : ℝ) := by + exact_mod_cast hExact.symm + rw [hExactReal] + apply BGS.Markoff.abs_moebius_weighted_sum_sub_le_divisors_card_mul + (Nat.card H) + (fun x => (Nat.card (rightPowerTraceRangeSolutions + leftTrace rightTrace x.fst) : ℝ)) + (fun x => mainTerm x.fst) error + intro x hx + have hproduct := (Nat.mem_divisorsAntidiagonal.mp hx).1 + have hdvd : x.fst ∣ Nat.card H := ⟨x.snd, hproduct.symm⟩ + exact hRange x.fst hdvd + (Nat.pos_of_ne_zero (Nat.left_ne_zero_of_mem_divisorsAntidiagonal hx)) + +/-- If the Möbius main term dominates the divisor error, a primitive right +parameter exists together with a genuine left witness. -/ +theorem rightTraceExactOrderSolutions_nonempty_of_divisorsError_lt_moebiusMain + [Finite A] [Finite H] [IsCyclic H] + (leftTrace : A → T) (rightTrace : H → T) + (mainTerm : ℕ → ℝ) (error : ℝ) + (hRange : ∀ d : ℕ, d ∣ Nat.card H → 0 < d → + |(Nat.card (rightPowerTraceRangeSolutions + leftTrace rightTrace d) : ℝ) - mainTerm d| ≤ error) + (hpositive : + ((Nat.card H).divisors.card : ℝ) * error < + ∑ x ∈ (Nat.card H).divisorsAntidiagonal, + (μ x.fst : ℝ) * mainTerm x.fst) : + (rightTraceExactOrderSolutions + leftTrace rightTrace (Nat.card H)).Nonempty := by + have henvelope := rightTraceExactOrderSolutions_card_error_le_moebiusMain + leftTrace rightTrace mainTerm error hRange + have hcardReal : + 0 < ((rightTraceExactOrderSolutions + leftTrace rightTrace (Nat.card H)).card : ℝ) := by + have hlower : + (∑ x ∈ (Nat.card H).divisorsAntidiagonal, + (μ x.fst : ℝ) * mainTerm x.fst) - + ((rightTraceExactOrderSolutions + leftTrace rightTrace (Nat.card H)).card : ℝ) ≤ + |((rightTraceExactOrderSolutions + leftTrace rightTrace (Nat.card H)).card : ℝ) - + ∑ x ∈ (Nat.card H).divisorsAntidiagonal, + (μ x.fst : ℝ) * mainTerm x.fst| := by + simpa only [neg_sub] using + neg_le_abs + (((rightTraceExactOrderSolutions + leftTrace rightTrace (Nat.card H)).card : ℝ) - + ∑ x ∈ (Nat.card H).divisorsAntidiagonal, + (μ x.fst : ℝ) * mainTerm x.fst) + linarith + exact Finset.card_pos.mp (by exact_mod_cast hcardReal) + +end + +end BGS diff --git a/LeanPool/MarkoffModP/BGS/NumberTheory/PreliminaryDivisorBound.lean b/LeanPool/MarkoffModP/BGS/NumberTheory/PreliminaryDivisorBound.lean new file mode 100644 index 0000000000..0b9a388a03 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/NumberTheory/PreliminaryDivisorBound.lean @@ -0,0 +1,469 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.NumberTheory.ExplicitDivisorBound +public import Mathlib.Tactic.IntervalCases + +/-! +# An elementary tenth-moment divisor bound + +For the paper's preliminary all-divisors route, the generic factorization +constant in `ExplicitDivisorBound.lean` is much too large. Here each prime +factor is charged a small power-of-two penalty. The penalties over primes below +`1024` sum exactly to `447`; primes at least `1024` need no penalty. +-/ + +@[expose] public section + +namespace BGS.NumberTheory + +open scoped BigOperators + +/-- If the tenth-power ratio is controlled at one exponent, it remains +controlled at every later exponent. -/ +private theorem pow_ten_succ_ratio_le + (base A a : ℕ) (ha : A ≤ a) + (hbase : (A + 2) ^ 10 ≤ base * (A + 1) ^ 10) : + (a + 2) ^ 10 ≤ base * (a + 1) ^ 10 := by + have hlinear : (A + 1) * (a + 2) ≤ (A + 2) * (a + 1) := by + nlinarith + have hpow := Nat.pow_le_pow_left hlinear 10 + have hscaled : + (A + 1) ^ 10 * (a + 2) ^ 10 ≤ + (A + 1) ^ 10 * (base * (a + 1) ^ 10) := by + calc + (A + 1) ^ 10 * (a + 2) ^ 10 = + ((A + 1) * (a + 2)) ^ 10 := by rw [mul_pow] + _ ≤ ((A + 2) * (a + 1)) ^ 10 := hpow + _ = (A + 2) ^ 10 * (a + 1) ^ 10 := by rw [mul_pow] + _ ≤ (base * (A + 1) ^ 10) * (a + 1) ^ 10 := + Nat.mul_le_mul_right _ hbase + _ = (A + 1) ^ 10 * (base * (a + 1) ^ 10) := by ring + exact Nat.le_of_mul_le_mul_left hscaled (by positivity) + +/-- Induction from a finite threshold for a fixed prime-size band. -/ +private theorem pow_ten_le_band_of_threshold + (base c A : ℕ) + (hbase : (A + 1) ^ 10 ≤ 2 ^ c * base ^ A) + (hratio : (A + 2) ^ 10 ≤ base * (A + 1) ^ 10) + (a : ℕ) (ha : A ≤ a) : + (a + 1) ^ 10 ≤ 2 ^ c * base ^ a := by + induction a, ha using Nat.le_induction with + | base => exact hbase + | succ a ha ih => + calc + (a + 1 + 1) ^ 10 ≤ base * (a + 1) ^ 10 := + pow_ten_succ_ratio_le base A a ha hratio + _ ≤ base * (2 ^ c * base ^ a) := + Nat.mul_le_mul_left _ ih + _ = 2 ^ c * base ^ (a + 1) := by ring + +private theorem pow_ten_le_base_two (a : ℕ) : + (a + 1) ^ 10 ≤ 2 ^ 26 * 2 ^ a := by + by_cases ha : 13 ≤ a + · simpa using pow_ten_le_band_of_threshold 2 26 13 + (by norm_num) (by norm_num) a ha + · have ha' : a ≤ 12 := by omega + interval_cases a <;> norm_num + +private theorem pow_ten_le_base_three (a : ℕ) : + (a + 1) ^ 10 ≤ 2 ^ 20 * 3 ^ a := by + by_cases ha : 8 ≤ a + · simpa using pow_ten_le_band_of_threshold 3 20 8 + (by norm_num) (by norm_num) a ha + · have ha' : a ≤ 7 := by omega + interval_cases a <;> norm_num + +private theorem pow_ten_le_base_five (a : ℕ) : + (a + 1) ^ 10 ≤ 2 ^ 15 * 5 ^ a := by + by_cases ha : 5 ≤ a + · simpa using pow_ten_le_band_of_threshold 5 15 5 + (by norm_num) (by norm_num) a ha + · have ha' : a ≤ 4 := by omega + interval_cases a <;> norm_num + +private theorem pow_ten_le_base_seven (a : ℕ) : + (a + 1) ^ 10 ≤ 2 ^ 12 * 7 ^ a := by + by_cases ha : 4 ≤ a + · simpa using pow_ten_le_band_of_threshold 7 12 4 + (by norm_num) (by norm_num) a ha + · have ha' : a ≤ 3 := by omega + interval_cases a <;> norm_num + +private theorem pow_ten_le_base_eleven (a : ℕ) : + (a + 1) ^ 10 ≤ 2 ^ 10 * 11 ^ a := by + by_cases ha : 3 ≤ a + · simpa using pow_ten_le_band_of_threshold 11 10 3 + (by norm_num) (by norm_num) a ha + · have ha' : a ≤ 2 := by omega + interval_cases a <;> norm_num + +private theorem pow_ten_le_base_thirteen (a : ℕ) : + (a + 1) ^ 10 ≤ 2 ^ 9 * 13 ^ a := by + by_cases ha : 3 ≤ a + · simpa using pow_ten_le_band_of_threshold 13 9 3 + (by norm_num) (by norm_num) a ha + · have ha' : a ≤ 2 := by omega + interval_cases a <;> norm_num + +private theorem pow_ten_le_base_seventeen (a : ℕ) : + (a + 1) ^ 10 ≤ 2 ^ 8 * 17 ^ a := by + by_cases ha : 3 ≤ a + · simpa using pow_ten_le_band_of_threshold 17 8 3 + (by norm_num) (by norm_num) a ha + · have ha' : a ≤ 2 := by omega + interval_cases a <;> norm_num + +private theorem pow_ten_le_base_twentyThree (a : ℕ) : + (a + 1) ^ 10 ≤ 2 ^ 7 * 23 ^ a := by + by_cases ha : 2 ≤ a + · simpa using pow_ten_le_band_of_threshold 23 7 2 + (by norm_num) (by norm_num) a ha + · have ha' : a ≤ 1 := by omega + interval_cases a <;> norm_num + +private theorem pow_ten_le_base_thirtyOne (a : ℕ) : + (a + 1) ^ 10 ≤ 2 ^ 6 * 31 ^ a := by + by_cases ha : 2 ≤ a + · simpa using pow_ten_le_band_of_threshold 31 6 2 + (by norm_num) (by norm_num) a ha + · have ha' : a ≤ 1 := by omega + interval_cases a <;> norm_num + +private theorem pow_ten_le_base_fortyThree (a : ℕ) : + (a + 1) ^ 10 ≤ 2 ^ 5 * 43 ^ a := by + by_cases ha : 2 ≤ a + · simpa using pow_ten_le_band_of_threshold 43 5 2 + (by norm_num) (by norm_num) a ha + · have ha' : a ≤ 1 := by omega + interval_cases a <;> norm_num + +private theorem pow_ten_le_base_sixtySeven (a : ℕ) : + (a + 1) ^ 10 ≤ 2 ^ 4 * 67 ^ a := by + by_cases ha : 1 ≤ a + · simpa using pow_ten_le_band_of_threshold 67 4 1 + (by norm_num) (by norm_num) a ha + · have ha' : a ≤ 0 := by omega + interval_cases a; norm_num + +private theorem pow_ten_le_base_oneHundredThirtyOne (a : ℕ) : + (a + 1) ^ 10 ≤ 2 ^ 3 * 131 ^ a := by + by_cases ha : 1 ≤ a + · simpa using pow_ten_le_band_of_threshold 131 3 1 + (by norm_num) (by norm_num) a ha + · have ha' : a ≤ 0 := by omega + interval_cases a; norm_num + +private theorem pow_ten_le_base_twoHundredFiftySeven (a : ℕ) : + (a + 1) ^ 10 ≤ 2 ^ 2 * 257 ^ a := by + by_cases ha : 1 ≤ a + · simpa using pow_ten_le_band_of_threshold 257 2 1 + (by norm_num) (by norm_num) a ha + · have ha' : a ≤ 0 := by omega + interval_cases a; norm_num + +private theorem pow_ten_le_base_fiveHundredTwentyOne (a : ℕ) : + (a + 1) ^ 10 ≤ 2 * 521 ^ a := by + by_cases ha : 1 ≤ a + · simpa using pow_ten_le_band_of_threshold 521 1 1 + (by norm_num) (by norm_num) a ha + · have ha' : a ≤ 0 := by omega + interval_cases a; norm_num + +private theorem pow_ten_le_base_oneThousandTwentyFour (a : ℕ) : + (a + 1) ^ 10 ≤ 1024 ^ a := by + simpa using pow_ten_le_band_of_threshold 1024 0 0 + (by norm_num) (by norm_num) a (Nat.zero_le a) +/-- Power-of-two penalty assigned to a prime factor. The thresholds are the +first primes at which the optimal integer penalty decreases. -/ +def preliminaryPrimePenalty (p : ℕ) : ℕ := + if p < 3 then 26 + else if p < 5 then 20 + else if p < 7 then 15 + else if p < 11 then 12 + else if p < 13 then 10 + else if p < 17 then 9 + else if p < 23 then 8 + else if p < 31 then 7 + else if p < 43 then 6 + else if p < 67 then 5 + else if p < 131 then 4 + else if p < 257 then 3 + else if p < 521 then 2 + else if p < 1024 then 1 + else 0 + +private theorem preliminaryPrimePenalty_eq_zero_of_le + {p : ℕ} (hp : 1024 ≤ p) : + preliminaryPrimePenalty p = 0 := by + simp [preliminaryPrimePenalty, + show ¬p < 3 by omega, + show ¬p < 5 by omega, + show ¬p < 7 by omega, + show ¬p < 11 by omega, + show ¬p < 13 by omega, + show ¬p < 17 by omega, + show ¬p < 23 by omega, + show ¬p < 31 by omega, + show ¬p < 43 by omega, + show ¬p < 67 by omega, + show ¬p < 131 by omega, + show ¬p < 257 by omega, + show ¬p < 521 by omega, + show ¬p < 1024 by omega] + +/-- Factorwise tenth-moment estimate, using the penalty band containing the +prime. -/ +private theorem factorization_succ_pow_ten_le + {p a : ℕ} (hpPrime : p.Prime) : + (a + 1) ^ 10 ≤ + 2 ^ preliminaryPrimePenalty p * p ^ a := by + have hpTwo : 2 ≤ p := hpPrime.two_le + by_cases hp3 : p < 3 + · simp only [preliminaryPrimePenalty, ite_eq_left hp3] + exact (pow_ten_le_base_two a).trans <| + Nat.mul_le_mul_left _ (Nat.pow_le_pow_left hpTwo a) + · by_cases hp5 : p < 5 + · have hpLower : 3 ≤ p := by omega + simp only [preliminaryPrimePenalty, ite_eq_right hp3, ite_eq_left hp5] + exact (pow_ten_le_base_three a).trans <| + Nat.mul_le_mul_left _ (Nat.pow_le_pow_left hpLower a) + · by_cases hp7 : p < 7 + · have hpLower : 5 ≤ p := by omega + simp only [preliminaryPrimePenalty, ite_eq_right hp3, ite_eq_right hp5, ite_eq_left hp7] + exact (pow_ten_le_base_five a).trans <| + Nat.mul_le_mul_left _ (Nat.pow_le_pow_left hpLower a) + · by_cases hp11 : p < 11 + · have hpLower : 7 ≤ p := by omega + simp only [preliminaryPrimePenalty, ite_eq_right hp3, ite_eq_right hp5, + ite_eq_right hp7, ite_eq_left hp11] + exact (pow_ten_le_base_seven a).trans <| + Nat.mul_le_mul_left _ (Nat.pow_le_pow_left hpLower a) + · by_cases hp13 : p < 13 + · have hpLower : 11 ≤ p := by omega + simp only [preliminaryPrimePenalty, ite_eq_right hp3, ite_eq_right hp5, + ite_eq_right hp7, ite_eq_right hp11, ite_eq_left hp13] + exact (pow_ten_le_base_eleven a).trans <| + Nat.mul_le_mul_left _ (Nat.pow_le_pow_left hpLower a) + · by_cases hp17 : p < 17 + · have hpLower : 13 ≤ p := by omega + simp only [preliminaryPrimePenalty, ite_eq_right hp3, ite_eq_right hp5, + ite_eq_right hp7, ite_eq_right hp11, ite_eq_right hp13, ite_eq_left hp17] + exact (pow_ten_le_base_thirteen a).trans <| + Nat.mul_le_mul_left _ (Nat.pow_le_pow_left hpLower a) + · by_cases hp23 : p < 23 + · have hpLower : 17 ≤ p := by omega + simp only [preliminaryPrimePenalty, ite_eq_right hp3, ite_eq_right hp5, + ite_eq_right hp7, ite_eq_right hp11, ite_eq_right hp13, ite_eq_right hp17, + ite_eq_left hp23] + exact (pow_ten_le_base_seventeen a).trans <| + Nat.mul_le_mul_left _ (Nat.pow_le_pow_left hpLower a) + · by_cases hp31 : p < 31 + · have hpLower : 23 ≤ p := by omega + simp only [preliminaryPrimePenalty, ite_eq_right hp3, ite_eq_right hp5, + ite_eq_right hp7, ite_eq_right hp11, ite_eq_right hp13, ite_eq_right hp17, + ite_eq_right hp23, ite_eq_left hp31] + exact (pow_ten_le_base_twentyThree a).trans <| + Nat.mul_le_mul_left _ (Nat.pow_le_pow_left hpLower a) + · by_cases hp43 : p < 43 + · have hpLower : 31 ≤ p := by omega + simp only [preliminaryPrimePenalty, ite_eq_right hp3, ite_eq_right hp5, + ite_eq_right hp7, ite_eq_right hp11, ite_eq_right hp13, ite_eq_right hp17, + ite_eq_right hp23, ite_eq_right hp31, ite_eq_left hp43] + exact (pow_ten_le_base_thirtyOne a).trans <| + Nat.mul_le_mul_left _ (Nat.pow_le_pow_left hpLower a) + · by_cases hp67 : p < 67 + · have hpLower : 43 ≤ p := by omega + simp only [preliminaryPrimePenalty, ite_eq_right hp3, ite_eq_right hp5, + ite_eq_right hp7, ite_eq_right hp11, ite_eq_right hp13, ite_eq_right hp17, + ite_eq_right hp23, ite_eq_right hp31, ite_eq_right hp43, ite_eq_left hp67] + exact (pow_ten_le_base_fortyThree a).trans <| + Nat.mul_le_mul_left _ (Nat.pow_le_pow_left hpLower a) + · by_cases hp131 : p < 131 + · have hpLower : 67 ≤ p := by omega + simp only [preliminaryPrimePenalty, ite_eq_right hp3, + ite_eq_right hp5, ite_eq_right hp7, ite_eq_right hp11, ite_eq_right hp13, + ite_eq_right hp17, ite_eq_right hp23, ite_eq_right hp31, ite_eq_right hp43, + ite_eq_right hp67, ite_eq_left hp131] + exact (pow_ten_le_base_sixtySeven a).trans <| + Nat.mul_le_mul_left _ (Nat.pow_le_pow_left hpLower a) + · by_cases hp257 : p < 257 + · have hpLower : 131 ≤ p := by omega + simp only [preliminaryPrimePenalty, ite_eq_right hp3, + ite_eq_right hp5, ite_eq_right hp7, ite_eq_right hp11, ite_eq_right hp13, + ite_eq_right hp17, ite_eq_right hp23, ite_eq_right hp31, ite_eq_right hp43, + ite_eq_right hp67, ite_eq_right hp131, ite_eq_left hp257] + exact (pow_ten_le_base_oneHundredThirtyOne a).trans <| + Nat.mul_le_mul_left _ + (Nat.pow_le_pow_left hpLower a) + · by_cases hp521 : p < 521 + · have hpLower : 257 ≤ p := by omega + simp only [preliminaryPrimePenalty, ite_eq_right hp3, + ite_eq_right hp5, ite_eq_right hp7, ite_eq_right hp11, ite_eq_right hp13, + ite_eq_right hp17, ite_eq_right hp23, ite_eq_right hp31, ite_eq_right hp43, + ite_eq_right hp67, ite_eq_right hp131, ite_eq_right hp257, + ite_eq_left hp521] + exact (pow_ten_le_base_twoHundredFiftySeven a).trans <| + Nat.mul_le_mul_left _ + (Nat.pow_le_pow_left hpLower a) + · by_cases hp1024 : p < 1024 + · have hpLower : 521 ≤ p := by omega + simp only [preliminaryPrimePenalty, ite_eq_right hp3, + ite_eq_right hp5, ite_eq_right hp7, ite_eq_right hp11, ite_eq_right hp13, + ite_eq_right hp17, ite_eq_right hp23, ite_eq_right hp31, ite_eq_right hp43, + ite_eq_right hp67, ite_eq_right hp131, ite_eq_right hp257, + ite_eq_right hp521, ite_eq_left hp1024] + exact (pow_ten_le_base_fiveHundredTwentyOne a).trans <| + Nat.mul_le_mul_left _ + (Nat.pow_le_pow_left hpLower a) + · have hpLower : 1024 ≤ p := by omega + simp only [preliminaryPrimePenalty, ite_eq_right hp3, + ite_eq_right hp5, ite_eq_right hp7, ite_eq_right hp11, ite_eq_right hp13, + ite_eq_right hp17, ite_eq_right hp23, ite_eq_right hp31, ite_eq_right hp43, + ite_eq_right hp67, ite_eq_right hp131, ite_eq_right hp257, + ite_eq_right hp521, ite_eq_right hp1024, pow_zero, one_mul] + exact + (pow_ten_le_base_oneThousandTwentyFour a).trans <| + Nat.pow_le_pow_left hpLower a + +-- Separate closed computations keep each kernel check within the default limit. +private def preliminaryPrimePenaltyBlock (k : ℕ) : ℕ := + ∑ p ∈ Finset.range 64, if Nat.Prime (k * 64 + p) then preliminaryPrimePenalty (k * 64 + p) else 0 +private theorem preliminaryPrimePenaltyBlock_value_0 : preliminaryPrimePenaltyBlock 0 = 165 := by + decide +kernel + +private theorem preliminaryPrimePenaltyBlock_value_1 : preliminaryPrimePenaltyBlock 1 = 52 := by + decide +kernel + +private theorem preliminaryPrimePenaltyBlock_value_2 : preliminaryPrimePenaltyBlock 2 = 36 := by + decide +kernel + +private theorem preliminaryPrimePenaltyBlock_value_3 : preliminaryPrimePenaltyBlock 3 = 33 := by + decide +kernel + +private theorem preliminaryPrimePenaltyBlock_value_4 : preliminaryPrimePenaltyBlock 4 = 24 := by + decide +kernel + +private theorem preliminaryPrimePenaltyBlock_value_5 : preliminaryPrimePenaltyBlock 5 = 20 := by + decide +kernel + +private theorem preliminaryPrimePenaltyBlock_value_6 : preliminaryPrimePenaltyBlock 6 = 20 := by + decide +kernel + +private theorem preliminaryPrimePenaltyBlock_value_7 : preliminaryPrimePenaltyBlock 7 = 22 := by + decide +kernel + +private theorem preliminaryPrimePenaltyBlock_value_8 : preliminaryPrimePenaltyBlock 8 = 8 := by + decide +kernel + +private theorem preliminaryPrimePenaltyBlock_value_9 : preliminaryPrimePenaltyBlock 9 = 10 := by + decide +kernel + +private theorem preliminaryPrimePenaltyBlock_value_10 : preliminaryPrimePenaltyBlock 10 = 11 := by + decide +kernel + +private theorem preliminaryPrimePenaltyBlock_value_11 : preliminaryPrimePenaltyBlock 11 = 9 := by + decide +kernel + +private theorem preliminaryPrimePenaltyBlock_value_12 : preliminaryPrimePenaltyBlock 12 = 10 := by + decide +kernel + +private theorem preliminaryPrimePenaltyBlock_value_13 : preliminaryPrimePenaltyBlock 13 = 9 := by + decide +kernel + +private theorem preliminaryPrimePenaltyBlock_value_14 : preliminaryPrimePenaltyBlock 14 = 8 := by + decide +kernel + +private theorem preliminaryPrimePenaltyBlock_value_15 : preliminaryPrimePenaltyBlock 15 = 10 := by + decide +kernel + +private theorem sum_preliminaryPrimePenalty_blocks (k : ℕ) : + (∑ p ∈ Finset.range (k * 64), if Nat.Prime p then preliminaryPrimePenalty p else 0) = + ∑ i ∈ Finset.range k, preliminaryPrimePenaltyBlock i := by + induction k with + | zero => simp + | succ k ih => + rw [Nat.succ_mul, Finset.sum_range_add, ih] + rw [Finset.sum_range_succ (f := preliminaryPrimePenaltyBlock)] + rfl + +private theorem sum_preliminaryPrimePenalty_le (n : ℕ) : + ∑ p ∈ n.primeFactors, preliminaryPrimePenalty p ≤ 447 := by + let smallFactors := + n.primeFactors.filter fun p ↦ p < 1024 + let allSmallPrimes := + (Finset.range 1024).filter Nat.Prime + have hsumEq : + (∑ p ∈ smallFactors, preliminaryPrimePenalty p) = + ∑ p ∈ n.primeFactors, preliminaryPrimePenalty p := by + apply Finset.sum_subset (Finset.filter_subset _ _) + intro p hpFactors hpNotSmall + have hpLarge : 1024 ≤ p := by + by_contra hpNotLarge + have hpSmall : p < 1024 := by omega + exact hpNotSmall (Finset.mem_filter.mpr ⟨hpFactors, hpSmall⟩) + exact preliminaryPrimePenalty_eq_zero_of_le hpLarge + have hsubset : smallFactors ⊆ allSmallPrimes := by + intro p hp + have hp' := Finset.mem_filter.mp hp + exact Finset.mem_filter.mpr + ⟨Finset.mem_range.mpr hp'.2, + Nat.prime_of_mem_primeFactors hp'.1⟩ + have hle : + (∑ p ∈ smallFactors, preliminaryPrimePenalty p) ≤ + ∑ p ∈ allSmallPrimes, preliminaryPrimePenalty p := + Finset.sum_le_sum_of_subset_of_nonneg hsubset + (fun _ _ _ ↦ Nat.zero_le _) + have htotal : + (∑ p ∈ allSmallPrimes, preliminaryPrimePenalty p) ≤ 447 := by + apply le_of_eq + rw [Finset.sum_filter] + change (∑ p ∈ Finset.range (16 * 64), if Nat.Prime p then preliminaryPrimePenalty p else 0) = _ + rw [sum_preliminaryPrimePenalty_blocks] + simp only [Finset.sum_range_succ, Finset.sum_range_zero] + rw [preliminaryPrimePenaltyBlock_value_0, preliminaryPrimePenaltyBlock_value_1, + preliminaryPrimePenaltyBlock_value_2, + preliminaryPrimePenaltyBlock_value_3, + preliminaryPrimePenaltyBlock_value_4, + preliminaryPrimePenaltyBlock_value_5, + preliminaryPrimePenaltyBlock_value_6, + preliminaryPrimePenaltyBlock_value_7, + preliminaryPrimePenaltyBlock_value_8, + preliminaryPrimePenaltyBlock_value_9, + preliminaryPrimePenaltyBlock_value_10, + preliminaryPrimePenaltyBlock_value_11, + preliminaryPrimePenaltyBlock_value_12, + preliminaryPrimePenaltyBlock_value_13, + preliminaryPrimePenaltyBlock_value_14, + preliminaryPrimePenaltyBlock_value_15] + rw [← hsumEq] + exact hle.trans htotal + +/-- The divisor function satisfies the uniform elementary estimate +`τ(n)^10 ≤ 2^447 n`. -/ +theorem card_divisors_pow_ten_le_preliminary_constant_mul + (n : ℕ) (hn : n ≠ 0) : + n.divisors.card ^ 10 ≤ 2 ^ 447 * n := by + rw [Nat.card_divisors hn, ← Finset.prod_pow] + calc + (∏ p ∈ n.primeFactors, (n.factorization p + 1) ^ 10) ≤ + ∏ p ∈ n.primeFactors, + (2 ^ preliminaryPrimePenalty p * p ^ n.factorization p) := + Finset.prod_le_prod + (fun p hp ↦ factorization_succ_pow_ten_le + (Nat.prime_of_mem_primeFactors hp)) + _ = 2 ^ (∑ p ∈ n.primeFactors, preliminaryPrimePenalty p) * n := by + rw [Finset.prod_mul_distrib, + Finset.prod_pow_eq_pow_sum, + ← Nat.prod_primeFactors_pow_factorization hn] + _ ≤ 2 ^ 447 * n := + Nat.mul_le_mul_right n <| + Nat.pow_le_pow_right (by norm_num) + (sum_preliminaryPrimePenalty_le n) + +end BGS.NumberTheory diff --git a/LeanPool/MarkoffModP/BGS/NumberTheory/PrimePowerFactorization.lean b/LeanPool/MarkoffModP/BGS/NumberTheory/PrimePowerFactorization.lean new file mode 100644 index 0000000000..599b7c3c43 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/NumberTheory/PrimePowerFactorization.lean @@ -0,0 +1,136 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import Mathlib.Algebra.BigOperators.Group.Finset.Defs +public import Mathlib.Data.Nat.Prime.Defs +public import Mathlib.Tactic + +/-! +# Prime-power factorization data + +This module contains the certificate-independent data and executable +recurrences used to describe a finite prime-power factorization and the ranks +of its divisor lattice. +-/ + +@[expose] public section + +namespace BGS.NumberTheory + +/-- One claimed prime power `prime ^ exponent`. -/ +structure PrimePowerFactor where + prime : ℕ + exponent : ℕ + deriving DecidableEq, Repr + +namespace PrimePowerFactor + +/-- A factor is meaningful when its base is prime and its exponent is +positive. -/ +def Valid (factor : PrimePowerFactor) : Prop := + factor.prime.Prime ∧ 0 < factor.exponent + +/-- Executable checker for one prime-power factor. -/ +def check (factor : PrimePowerFactor) : Bool := + decide factor.prime.Prime && decide (0 < factor.exponent) + +@[simp] +theorem check_eq_true_iff (factor : PrimePowerFactor) : + factor.check = true ↔ factor.Valid := by + simp [check, Valid] + +end PrimePowerFactor + +/-- Every supplied prime-power entry is individually valid. -/ +def allPrimePowerFactorsValid : List PrimePowerFactor → Prop + | [] => True + | factor :: factors => + factor.Valid ∧ allPrimePowerFactorsValid factors + +/-- Executable counterpart of `allPrimePowerFactorsValid`. -/ +def allPrimePowerFactorsCheck : List PrimePowerFactor → Bool + | [] => true + | factor :: factors => + factor.check && allPrimePowerFactorsCheck factors + +@[simp] +theorem allPrimePowerFactorsCheck_eq_true_iff + (factors : List PrimePowerFactor) : + allPrimePowerFactorsCheck factors = true ↔ + allPrimePowerFactorsValid factors := by + induction factors with + | nil => simp [allPrimePowerFactorsCheck, allPrimePowerFactorsValid] + | cons factor factors ih => + simp [allPrimePowerFactorsCheck, allPrimePowerFactorsValid, ih] + +/-- The prime bases occur in strict increasing order. `List.Pairwise` rejects +duplicates and checks all later bases, not only adjacent entries. -/ +def primePowerBasesStrictlyIncreasing + (factors : List PrimePowerFactor) : Prop := + factors.Pairwise fun left right => left.prime < right.prime + +/-- Executable strict-order checker. -/ +def primePowerBasesStrictlyIncreasingCheck + (factors : List PrimePowerFactor) : Bool := + decide (factors.Pairwise fun left right => left.prime < right.prime) + +@[simp] +theorem primePowerBasesStrictlyIncreasingCheck_eq_true_iff + (factors : List PrimePowerFactor) : + primePowerBasesStrictlyIncreasingCheck factors = true ↔ + primePowerBasesStrictlyIncreasing factors := by + simp [primePowerBasesStrictlyIncreasingCheck, + primePowerBasesStrictlyIncreasing] + +/-- Canonical prime-power input: valid entries with distinct, increasing +prime bases. -/ +def canonicalPrimePowerFactors (factors : List PrimePowerFactor) : Prop := + allPrimePowerFactorsValid factors ∧ + primePowerBasesStrictlyIncreasing factors + +/-- Executable counterpart of `canonicalPrimePowerFactors`. -/ +def canonicalPrimePowerFactorsCheck + (factors : List PrimePowerFactor) : Bool := + allPrimePowerFactorsCheck factors && + primePowerBasesStrictlyIncreasingCheck factors + +@[simp] +theorem canonicalPrimePowerFactorsCheck_eq_true_iff + (factors : List PrimePowerFactor) : + canonicalPrimePowerFactorsCheck factors = true ↔ + canonicalPrimePowerFactors factors := by + simp [canonicalPrimePowerFactorsCheck, canonicalPrimePowerFactors] + +/-- The integer represented by a supplied prime-power list. -/ +def primePowerFactorizationValue : List PrimePowerFactor → ℕ + | [] => 1 + | factor :: factors => + factor.prime ^ factor.exponent * + primePowerFactorizationValue factors + +/-- The total exponent, i.e. the top rank of the divisor lattice. -/ +def primePowerTotalExponent : List PrimePowerFactor → ℕ + | [] => 0 + | factor :: factors => + factor.exponent + primePowerTotalExponent factors + +/-- Coefficient recurrence for `∏ (1 + X + ... + X^e)`. -/ +def divisorRankCoefficient : + List PrimePowerFactor → ℕ → ℕ + | [], 0 => 1 + | [], _ + 1 => 0 + | factor :: factors, rank => + ∑ exponent ∈ Finset.range (min factor.exponent rank + 1), + divisorRankCoefficient factors (rank - exponent) + +/-- The central rank coefficient recomputed from the supplied exponents. -/ +def centralDivisorRankCoefficient + (factors : List PrimePowerFactor) : ℕ := + divisorRankCoefficient factors (primePowerTotalExponent factors / 2) + +end BGS.NumberTheory diff --git a/LeanPool/MarkoffModP/BGS/NumberTheory/RankinCanonicalProfile.lean b/LeanPool/MarkoffModP/BGS/NumberTheory/RankinCanonicalProfile.lean new file mode 100644 index 0000000000..2682f7ab68 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/NumberTheory/RankinCanonicalProfile.lean @@ -0,0 +1,301 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.NumberTheory.RankinProfileMatching +public import LeanPool.MarkoffModP.BGS.NumberTheory.RankinJointEnvelopeCertificate + +/-! +# Canonical Rankin profile attached to a neighboring factorization + +The numerical certificate will choose rational caps. This file fixes the +mathematical coverage map independently of those choices: every odd prime in +the globally sorted support is sent to its actual side and exponent, while the +cap assignment and the twelfth-root cap remain explicit parameters. +-/ + +@[expose] public section + +namespace BGS.NumberTheory + +private theorem factorization_two_mul_of_odd + {n : ℕ} (hn : Odd n) : + (2 * n).factorization 2 = 1 := by + have hnNe : n ≠ 0 := hn.pos.ne' + have hfactorization := Nat.factorization_mul (by norm_num : 2 ≠ 0) hnNe + have happly := congrArg (fun factorization : ℕ →₀ ℕ => + factorization 2) hfactorization + simpa [Nat.Prime.factorization_self Nat.prime_two, + Nat.factorization_eq_zero_of_not_dvd hn.not_two_dvd_nat] using happly + +/-- For an odd prime, exactly one neighboring two-adic exponent is one and +the other is at least two. -/ +theorem neighboring_twoFactorization_shape + {p : ℕ} (hpPrime : p.Prime) (hpTwo : 2 < p) : + (((p - 1).factorization 2 = 1 ∧ + 2 ≤ (p + 1).factorization 2) ∨ + ((p + 1).factorization 2 = 1 ∧ + 2 ≤ (p - 1).factorization 2)) := by + have hpOdd : Odd p := hpPrime.odd_iff.mpr (by omega) + rcases hpOdd with ⟨k, rfl⟩ + rcases k.even_or_odd with hkEven | hkOdd + · right + have hkPlusOdd : Odd (k + 1) := hkEven.add_one + constructor + · have hplusEq : 2 * k + 1 + 1 = 2 * (k + 1) := by omega + rw [hplusEq] + exact factorization_two_mul_of_odd hkPlusOdd + · have hminusEq : 2 * k + 1 - 1 = 2 * k := by omega + rw [hminusEq] + have hne : 2 * k ≠ 0 := by + rcases hkEven with ⟨j, hj⟩ + omega + apply (Nat.prime_two.pow_dvd_iff_le_factorization hne).mp + rcases hkEven with ⟨j, hj⟩ + refine ⟨j, ?_⟩ + norm_num + omega + · left + have hkPlusEven : Even (k + 1) := hkOdd.add_one + constructor + · have hminusEq : 2 * k + 1 - 1 = 2 * k := by omega + rw [hminusEq] + exact factorization_two_mul_of_odd hkOdd + · have hplusEq : 2 * k + 1 + 1 = 2 * (k + 1) := by omega + rw [hplusEq] + have hne : 2 * (k + 1) ≠ 0 := by omega + apply (Nat.prime_two.pow_dvd_iff_le_factorization hne).mp + rcases hkPlusEven with ⟨j, hj⟩ + refine ⟨j, ?_⟩ + norm_num + omega + +theorem actualNeighborExponent_pos + {p prime : ℕ} (hp : 1 < p) + (hprime : prime ∈ jointOddPrimeList p) : + 0 < actualNeighborExponent p prime := by + have hdata := mem_jointOddPrimeList.mp hprime + have hprimePrime : prime.Prime := by + rcases hdata.2 with hminus | hplus + · exact Nat.prime_of_mem_primeFactors hminus + · exact Nat.prime_of_mem_primeFactors hplus + by_cases hminus : prime ∈ (p - 1).primeFactors + · simp only [actualNeighborExponent, ite_eq_left hminus] + exact hprimePrime.factorization_pos_of_dvd (by omega) + (Nat.dvd_of_mem_primeFactors hminus) + · have hplus : prime ∈ (p + 1).primeFactors := + hdata.2.resolve_left hminus + simp only [actualNeighborExponent, ite_eq_right hminus] + exact hprimePrime.factorization_pos_of_dvd (by omega) + (Nat.dvd_of_mem_primeFactors hplus) + +/-- The exact odd factor produced from one actual support prime and one chosen +rational cap. -/ +def canonicalRankinOddFactor + (p : ℕ) (oddCap : ℕ → RationalPrimeWeightCap) + (prime : ℕ) : RankinOddFactor where + side := actualNeighborSide p prime + exponent := actualNeighborExponent p prime + weightCap := oddCap prime + +/-- The complete canonical profile for `p`, parameterized by cap choices. -/ +def canonicalRankinNeighborProfile + (p : ℕ) (twoCap : RationalPrimeWeightCap) + (oddCap : ℕ → RationalPrimeWeightCap) + (rootCap : ℕ) : RankinNeighborProfile where + minusTwoExponent := (p - 1).factorization 2 + plusTwoExponent := (p + 1).factorization 2 + twoWeightCap := twoCap + oddFactors := (jointOddPrimeList p).map + (canonicalRankinOddFactor p oddCap) + rootCap := rootCap + +theorem canonicalRankinNeighborProfile_matches + {p : ℕ} {twoCap : RationalPrimeWeightCap} + {oddCap : ℕ → RationalPrimeWeightCap} {rootCap : ℕ} + (hfloor : + ∀ prime ∈ jointOddPrimeList p, + (oddCap prime).lowerPrime ≤ prime) : + (canonicalRankinNeighborProfile p twoCap oddCap rootCap).Matches p := by + refine ⟨rfl, rfl, canonicalRankinOddFactor p oddCap, rfl, ?_⟩ + intro prime hprime + exact ⟨rfl, rfl, hfloor prime hprime⟩ + +private theorem allRankinOddFactorsValid_map_canonical + {p : ℕ} (hp : 1 < p) + {oddCap : ℕ → RationalPrimeWeightCap} + (hcap : + ∀ prime ∈ jointOddPrimeList p, + (oddCap prime).Valid ∧ + (oddCap prime).lowerPrime.Prime ∧ + 3 ≤ (oddCap prime).lowerPrime) : + allRankinOddFactorsValid + ((jointOddPrimeList p).map + (canonicalRankinOddFactor p oddCap)) := by + have hpos : + ∀ prime ∈ jointOddPrimeList p, + 0 < actualNeighborExponent p prime := + fun prime hprime => actualNeighborExponent_pos hp hprime + generalize jointOddPrimeList p = primes at hcap hpos ⊢ + induction primes with + | nil => simp [allRankinOddFactorsValid] + | cons prime primes ih => + simp only [List.map_cons, allRankinOddFactorsValid] + constructor + · exact ⟨hpos prime (by simp), + (hcap prime (by simp)).1, + (hcap prime (by simp)).2.1, + (hcap prime (by simp)).2.2⟩ + · apply ih + · intro q hq + exact hcap q (by simp [hq]) + · intro q hq + exact hpos q (by simp [hq]) + +/-- The exact assumptions on generated caps under which the canonical profile +is structurally and arithmetically valid. -/ +theorem canonicalRankinNeighborProfile_valid + {p : ℕ} (hpPrime : p.Prime) (hpTwo : 2 < p) + {twoCap : RationalPrimeWeightCap} + {oddCap : ℕ → RationalPrimeWeightCap} {rootCap : ℕ} + (htwoValid : twoCap.Valid) + (htwoFloor : twoCap.lowerPrime = 2) + (hoddValid : + ∀ prime ∈ jointOddPrimeList p, + (oddCap prime).Valid ∧ + (oddCap prime).lowerPrime.Prime ∧ + 3 ≤ (oddCap prime).lowerPrime) + (hfloorStrict : + (jointOddPrimeList p).Pairwise fun left right => + (oddCap left).lowerPrime < (oddCap right).lowerPrime) + (hrootPos : 0 < rootCap) + (hroot : + (canonicalRankinNeighborProfile p twoCap oddCap rootCap).witnessCap ≤ + rootCap ^ 12) : + (canonicalRankinNeighborProfile p twoCap oddCap rootCap).Valid := by + refine ⟨neighboring_twoFactorization_shape hpPrime hpTwo, + htwoValid, htwoFloor, ?_, ?_, hrootPos, hroot⟩ + · exact allRankinOddFactorsValid_map_canonical (by omega) hoddValid + · rw [rankinOddFloorsStrictlyIncreasing, + canonicalRankinNeighborProfile, List.pairwise_map] + simpa [canonicalRankinOddFactor] using hfloorStrict + +/-- The side-erased joint root condition is sufficient for validity of the +actual side assignment. This lets a finite certificate choose its root cap +without branching over which neighboring factor receives each odd prime. -/ +theorem canonicalRankinNeighborProfile_valid_of_jointEnvelope + {p : ℕ} (hpPrime : p.Prime) (hpTwo : 2 < p) + {twoCap : RationalPrimeWeightCap} + {oddCap : ℕ → RationalPrimeWeightCap} {rootCap : ℕ} + (htwoValid : twoCap.Valid) + (htwoFloor : twoCap.lowerPrime = 2) + (hoddValid : + ∀ prime ∈ jointOddPrimeList p, + (oddCap prime).Valid ∧ + (oddCap prime).lowerPrime.Prime ∧ + 3 ≤ (oddCap prime).lowerPrime) + (hfloorStrict : + (jointOddPrimeList p).Pairwise fun left right => + (oddCap left).lowerPrime < (oddCap right).lowerPrime) + (hrootPos : 0 < rootCap) + (hjointRoot : + RankinNeighborProfile.JointEnvelopeValid + (canonicalRankinNeighborProfile p twoCap oddCap rootCap)) : + (canonicalRankinNeighborProfile p twoCap oddCap rootCap).Valid := by + apply canonicalRankinNeighborProfile_valid hpPrime hpTwo + htwoValid htwoFloor hoddValid hfloorStrict hrootPos + exact + (RankinNeighborProfile.witnessCap_le_jointEnvelopeWitnessCap_of_shape + (canonicalRankinNeighborProfile p twoCap oddCap rootCap) + (neighboring_twoFactorization_shape hpPrime hpTwo)).trans + hjointRoot + +/-- A deliberately loose but universally available cap: weight one at the +actual prime. It is used only to prove that the profile representation is +total; optimized certificates replace it by smaller rational caps. -/ +def unitRationalPrimeWeightCap (prime : ℕ) : RationalPrimeWeightCap where + lowerPrime := prime + numerator := 1 + denominator := 1 + +theorem unitRationalPrimeWeightCap_valid + {prime : ℕ} (hprime : 0 < prime) : + (unitRationalPrimeWeightCap prime).Valid := by + simp [unitRationalPrimeWeightCap, RationalPrimeWeightCap.Valid] + omega + +private theorem pairwise_lt_of_pairwise_le_of_nodup + {values : List ℕ} + (hle : values.Pairwise (· ≤ ·)) (hnodup : values.Nodup) : + values.Pairwise (· < ·) := by + induction values with + | nil => simp + | cons value values ih => + rw [List.pairwise_cons] at hle ⊢ + rw [List.nodup_cons] at hnodup + constructor + · intro later hlater + exact lt_of_le_of_ne (hle.1 later hlater) (by + intro heq + exact hnodup.1 (heq ▸ hlater)) + · exact ih hle.2 hnodup.2 + +theorem jointOddPrimeList_pairwise_lt (p : ℕ) : + (jointOddPrimeList p).Pairwise (· < ·) := by + apply pairwise_lt_of_pairwise_le_of_nodup + · exact Finset.pairwise_sort (jointOddPrimeSupport p) (· ≤ ·) + · exact Finset.sort_nodup (jointOddPrimeSupport p) (· ≤ ·) + +/-- A concrete canonical profile exists for every `p`: exact-prime unit +weights and a deliberately oversized root cap make validity unconditional. +This theorem is a coverage sanity check, not the optimized numerical +certificate. -/ +def unitCanonicalRankinNeighborProfile (p : ℕ) : RankinNeighborProfile := + let seed := canonicalRankinNeighborProfile p + (unitRationalPrimeWeightCap 2) + unitRationalPrimeWeightCap 1 + canonicalRankinNeighborProfile p + (unitRationalPrimeWeightCap 2) + unitRationalPrimeWeightCap (seed.witnessCap + 1) + +theorem unitCanonicalRankinNeighborProfile_matches (p : ℕ) : + (unitCanonicalRankinNeighborProfile p).Matches p := by + apply canonicalRankinNeighborProfile_matches + intro prime hprime + simp [unitRationalPrimeWeightCap] + +theorem unitCanonicalRankinNeighborProfile_valid + {p : ℕ} (hpPrime : p.Prime) (hpTwo : 2 < p) : + (unitCanonicalRankinNeighborProfile p).Valid := by + let seed := canonicalRankinNeighborProfile p + (unitRationalPrimeWeightCap 2) + unitRationalPrimeWeightCap 1 + change (canonicalRankinNeighborProfile p + (unitRationalPrimeWeightCap 2) + unitRationalPrimeWeightCap (seed.witnessCap + 1)).Valid + apply canonicalRankinNeighborProfile_valid hpPrime hpTwo + · exact unitRationalPrimeWeightCap_valid (by norm_num) + · rfl + · intro prime hprime + have hprimePrime : prime.Prime := by + rcases (mem_jointOddPrimeList.mp hprime).2 with hminus | hplus + · exact Nat.prime_of_mem_primeFactors hminus + · exact Nat.prime_of_mem_primeFactors hplus + have hthree : 3 ≤ prime := by + have hneTwo := (mem_jointOddPrimeList.mp hprime).1 + have htwo := hprimePrime.two_le + omega + exact ⟨unitRationalPrimeWeightCap_valid hprimePrime.pos, + hprimePrime, hthree⟩ + · simpa [unitRationalPrimeWeightCap] using + jointOddPrimeList_pairwise_lt p + · omega + · change seed.witnessCap ≤ (seed.witnessCap + 1) ^ 12 + exact (Nat.le_succ seed.witnessCap).trans + (Nat.le_pow (by norm_num : 0 < 12)) + +end BGS.NumberTheory diff --git a/LeanPool/MarkoffModP/BGS/NumberTheory/RankinCutoff1248Data.lean b/LeanPool/MarkoffModP/BGS/NumberTheory/RankinCutoff1248Data.lean new file mode 100644 index 0000000000..cee4417f8a --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/NumberTheory/RankinCutoff1248Data.lean @@ -0,0 +1,87 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.NumberTheory.RankinPositionalSupportBound + +/-! +# Concrete positional data below `2^1248` + +The table contains the first 275 odd primes, ending at 1783. Its product is +strictly larger than `2^2496`. Hence the joint odd support of every +`p < 2^1248` has fewer than 275 entries. The precision is intentionally only +a coarse starting choice; later certificate generation may increase it +without changing the support argument. +-/ + +@[expose] public section + +namespace BGS.NumberTheory + +def rankinCutoff1248CapTable : RankinPositionalCapTable where + precision := 1000000 + oddPrimeFloors := [ + 3, 5, 7, 11, 13, 17, 19, 23, 29, 31, 37, 41, 43, 47, 53, 59, 61, + 67, 71, 73, 79, 83, 89, 97, 101, 103, 107, 109, 113, 127, 131, 137, + 139, 149, 151, 157, 163, 167, 173, 179, 181, 191, 193, 197, 199, 211, + 223, 227, 229, 233, 239, 241, 251, 257, 263, 269, 271, 277, 281, 283, + 293, 307, 311, 313, 317, 331, 337, 347, 349, 353, 359, 367, 373, 379, + 383, 389, 397, 401, 409, 419, 421, 431, 433, 439, 443, 449, 457, 461, + 463, 467, 479, 487, 491, 499, 503, 509, 521, 523, 541, 547, 557, 563, + 569, 571, 577, 587, 593, 599, 601, 607, 613, 617, 619, 631, 641, 643, + 647, 653, 659, 661, 673, 677, 683, 691, 701, 709, 719, 727, 733, 739, + 743, 751, 757, 761, 769, 773, 787, 797, 809, 811, 821, 823, 827, 829, + 839, 853, 857, 859, 863, 877, 881, 883, 887, 907, 911, 919, 929, 937, + 941, 947, 953, 967, 971, 977, 983, 991, 997, 1009, 1013, 1019, 1021, + 1031, 1033, 1039, 1049, 1051, 1061, 1063, 1069, 1087, 1091, 1093, + 1097, 1103, 1109, 1117, 1123, 1129, 1151, 1153, 1163, 1171, 1181, + 1187, 1193, 1201, 1213, 1217, 1223, 1229, 1231, 1237, 1249, 1259, + 1277, 1279, 1283, 1289, 1291, 1297, 1301, 1303, 1307, 1319, 1321, + 1327, 1361, 1367, 1373, 1381, 1399, 1409, 1423, 1427, 1429, 1433, + 1439, 1447, 1451, 1453, 1459, 1471, 1481, 1483, 1487, 1489, 1493, + 1499, 1511, 1523, 1531, 1543, 1549, 1553, 1559, 1567, 1571, 1579, + 1583, 1597, 1601, 1607, 1609, 1613, 1619, 1621, 1627, 1637, 1657, + 1663, 1667, 1669, 1693, 1697, 1699, 1709, 1721, 1723, 1733, 1741, + 1747, 1753, 1759, 1777, 1783] + +theorem rankinCutoff1248CapTable_check : + rankinCutoff1248CapTable.check = true := by + decide +kernel + +theorem rankinCutoff1248CapTable_valid : + rankinCutoff1248CapTable.Valid := + (RankinPositionalCapTable.check_eq_true_iff + rankinCutoff1248CapTable).mp + rankinCutoff1248CapTable_check + +theorem rankinCutoff1248CapTable_product : + 2 ^ (2 * 1248) < rankinCutoff1248CapTable.oddPrimeFloors.prod := by + decide +kernel + +theorem rankinCutoff1248CapTable_length : + rankinCutoff1248CapTable.oddPrimeFloors.length = 275 := by + decide +kernel + +/-- Uniform support-size coverage for the proposed new cutoff. -/ +theorem jointOddPrimeList_length_lt_275_of_lt_two_pow_1248 + {p : ℕ} (hpOne : 1 < p) (hp : p < 2 ^ 1248) : + (jointOddPrimeList p).length < 275 := by + have hlength := jointOddPrimeList_length_lt_of_lt_pow_of_capTable + hpOne hp rankinCutoff1248CapTable_valid + rankinCutoff1248CapTable_product + rw [rankinCutoff1248CapTable_length] at hlength + exact hlength + +theorem jointOddPrimeList_length_le_rankinCutoff1248CapTable + {p : ℕ} (hpOne : 1 < p) (hp : p < 2 ^ 1248) : + (jointOddPrimeList p).length ≤ + rankinCutoff1248CapTable.oddPrimeFloors.length := by + exact (jointOddPrimeList_length_lt_of_lt_pow_of_capTable + hpOne hp rankinCutoff1248CapTable_valid + rankinCutoff1248CapTable_product).le + +end BGS.NumberTheory diff --git a/LeanPool/MarkoffModP/BGS/NumberTheory/RankinCutoff1248Profile.lean b/LeanPool/MarkoffModP/BGS/NumberTheory/RankinCutoff1248Profile.lean new file mode 100644 index 0000000000..17c9391330 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/NumberTheory/RankinCutoff1248Profile.lean @@ -0,0 +1,120 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.NumberTheory.RankinCutoff1248Skeleton +public import LeanPool.MarkoffModP.BGS.NumberTheory.RankinJointEnvelopeSummaryCoverage + +/-! +# Certified actual Rankin profiles below `2^1248` + +The finite exponent skeleton by itself does not choose the auxiliary twelfth +root used by the Rankin inequality. This module chooses one canonically from +the side-erased witness cap. It then proves that the actual positional +profile is structurally valid, matches `p`, and is dominated by the exact +scalar summary of its skeleton representative. +-/ + +@[expose] public section + +namespace BGS.NumberTheory + +namespace RankinExponentSkeleton + +/-- One more than the integral twelfth root of the joint witness cap. -/ +def jointEnvelopeRootCap (skeleton : RankinExponentSkeleton) + (table : RankinPositionalCapTable) : Nat := + Nat.nthRoot 12 + ((skeleton.toProfile table 1).jointEnvelopeWitnessCap) + 1 + +/-- The side-erased profile with its canonical twelfth-root cap installed. -/ +def certifiedProfile (skeleton : RankinExponentSkeleton) + (table : RankinPositionalCapTable) : RankinNeighborProfile := + skeleton.toProfile table (skeleton.jointEnvelopeRootCap table) + +@[simp] theorem certifiedProfile_jointEnvelopeWitnessCap + (skeleton : RankinExponentSkeleton) + (table : RankinPositionalCapTable) : + (skeleton.certifiedProfile table).jointEnvelopeWitnessCap = + (skeleton.toProfile table 1).jointEnvelopeWitnessCap := by + rfl + +theorem jointEnvelopeRootCap_pos + (skeleton : RankinExponentSkeleton) + (table : RankinPositionalCapTable) : + 0 < skeleton.jointEnvelopeRootCap table := by + exact Nat.zero_lt_succ _ + +theorem certifiedProfile_jointEnvelopeValid + (skeleton : RankinExponentSkeleton) + (table : RankinPositionalCapTable) : + (skeleton.certifiedProfile table).JointEnvelopeValid := by + rw [RankinNeighborProfile.JointEnvelopeValid, + certifiedProfile_jointEnvelopeWitnessCap] + exact (Nat.lt_pow_nthRoot_add_one (by norm_num : Ne 12 0) + ((skeleton.toProfile table 1).jointEnvelopeWitnessCap)).le + +end RankinExponentSkeleton + +/-- The canonical matched profile of `p`, using the cap determined by its +side-erased exponent skeleton. -/ +def actualRankinProfile1248 (p : Nat) : RankinNeighborProfile := + positionalCanonicalRankinNeighborProfile p + rankinCutoff1248CapTable.twoCap + rankinCutoff1248CapTable.oddCapAt + ((actualRankinExponentSkeleton p).jointEnvelopeRootCap + rankinCutoff1248CapTable) + +/-- The corresponding exact scalar summary, computed without side labels. -/ +def actualRankinSkeletonSummary1248 (p : Nat) : + RankinJointEnvelopeSummary := + RankinJointEnvelopeSummary.ofProfile + ((actualRankinExponentSkeleton p).certifiedProfile + rankinCutoff1248CapTable) + +theorem actualRankinProfile1248_matches + {p : Nat} (hp : p < 2 ^ 1248) (hpOne : 1 < p) : + (actualRankinProfile1248 p).Matches p := by + apply positionalCanonicalRankinNeighborProfile_matches_of_capTable + rankinCutoff1248CapTable_valid + · exact jointOddPrimeList_length_le_rankinCutoff1248CapTable hpOne hp + +theorem eraseSides_actualRankinProfile1248 + (p : Nat) : + (actualRankinProfile1248 p).eraseSides = + (actualRankinExponentSkeleton p).certifiedProfile + rankinCutoff1248CapTable := by + exact eraseSides_positionalCanonicalRankinNeighborProfile p + rankinCutoff1248CapTable.twoCap + rankinCutoff1248CapTable.oddCapAt + ((actualRankinExponentSkeleton p).jointEnvelopeRootCap + rankinCutoff1248CapTable) + +theorem actualRankinProfile1248_valid + {p : Nat} (hpPrime : p.Prime) (hpTwo : 2 < p) + (hp : p < 2 ^ 1248) : + (actualRankinProfile1248 p).Valid := by + apply positionalCanonicalRankinNeighborProfile_valid_of_capTable + hpPrime hpTwo rankinCutoff1248CapTable_valid + (jointOddPrimeList_length_le_rankinCutoff1248CapTable (by omega) hp) + · exact (actualRankinExponentSkeleton p).jointEnvelopeRootCap_pos + rankinCutoff1248CapTable + · exact (actualRankinExponentSkeleton p).certifiedProfile_jointEnvelopeValid + rankinCutoff1248CapTable + +/-- The exact skeleton summary dominates the actual side-assigned profile. +This is the semantic handoff from actual primes to scalar search rows. -/ +theorem actualRankinSkeletonSummary1248_dominates + (p : Nat) : + (actualRankinSkeletonSummary1248 p).Dominates + (actualRankinProfile1248 p) := by + rw [actualRankinSkeletonSummary1248, + RankinJointEnvelopeSummary.Dominates] + rw [← eraseSides_actualRankinProfile1248 p] + simp [RankinJointEnvelopeSummary.ofProfile] + +end BGS.NumberTheory diff --git a/LeanPool/MarkoffModP/BGS/NumberTheory/RankinCutoff1248Skeleton.lean b/LeanPool/MarkoffModP/BGS/NumberTheory/RankinCutoff1248Skeleton.lean new file mode 100644 index 0000000000..e9490d4431 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/NumberTheory/RankinCutoff1248Skeleton.lean @@ -0,0 +1,173 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.NumberTheory.RankinCutoff1248Data + +/-! +# Finite exponent skeletons below `2^1248` + +After side erasure and positional prime caps, the only varying arithmetic data +are two two-adic exponents and a list of positive odd exponents. This module +records an executable admissibility predicate. Every actual prime below the +target cutoff satisfies it, including the strong global product budget +`jointLowerNeighborProduct < 2^2496`. +-/ + +@[expose] public section + +namespace BGS.NumberTheory + +structure RankinExponentSkeleton where + minusTwoExponent : ℕ + plusTwoExponent : ℕ + oddExponents : List ℕ + deriving DecidableEq, Repr + +namespace RankinExponentSkeleton + +def toProfile (skeleton : RankinExponentSkeleton) + (table : RankinPositionalCapTable) (rootCap : ℕ) : + RankinNeighborProfile := + positionalRankinSkeletonProfile table.twoCap table.oddCapAt + skeleton.minusTwoExponent skeleton.plusTwoExponent + skeleton.oddExponents rootCap + +def TwoFactorizationShape (skeleton : RankinExponentSkeleton) : Prop := + (skeleton.minusTwoExponent = 1 ∧ + 2 ≤ skeleton.plusTwoExponent) ∨ + (skeleton.plusTwoExponent = 1 ∧ + 2 ≤ skeleton.minusTwoExponent) + +def twoFactorizationShapeCheck + (skeleton : RankinExponentSkeleton) : Bool := + (decide (skeleton.minusTwoExponent = 1) && + decide (2 ≤ skeleton.plusTwoExponent)) || + (decide (skeleton.plusTwoExponent = 1) && + decide (2 ≤ skeleton.minusTwoExponent)) + +@[simp] theorem twoFactorizationShapeCheck_eq_true_iff + (skeleton : RankinExponentSkeleton) : + skeleton.twoFactorizationShapeCheck = true ↔ + skeleton.TwoFactorizationShape := by + simp [twoFactorizationShapeCheck, TwoFactorizationShape] + +def OddExponentsPositive (skeleton : RankinExponentSkeleton) : Prop := + ∀ exponent ∈ skeleton.oddExponents, 0 < exponent + +def oddExponentsPositiveCheck (skeleton : RankinExponentSkeleton) : Bool := + skeleton.oddExponents.all fun exponent => decide (0 < exponent) + +@[simp] theorem oddExponentsPositiveCheck_eq_true_iff + (skeleton : RankinExponentSkeleton) : + skeleton.oddExponentsPositiveCheck = true ↔ + skeleton.OddExponentsPositive := by + simp [oddExponentsPositiveCheck, OddExponentsPositive] + +def Admissible (skeleton : RankinExponentSkeleton) + (table : RankinPositionalCapTable) + (slotBound productBound : ℕ) : Prop := + skeleton.TwoFactorizationShape ∧ + skeleton.OddExponentsPositive ∧ + skeleton.oddExponents.length < slotBound ∧ + (skeleton.toProfile table 1).jointLowerNeighborProduct < productBound + +def admissibleCheck (skeleton : RankinExponentSkeleton) + (table : RankinPositionalCapTable) + (slotBound productBound : ℕ) : Bool := + skeleton.twoFactorizationShapeCheck && + skeleton.oddExponentsPositiveCheck && + decide (skeleton.oddExponents.length < slotBound) && + decide + ((skeleton.toProfile table 1).jointLowerNeighborProduct < productBound) + +@[simp] theorem admissibleCheck_eq_true_iff + (skeleton : RankinExponentSkeleton) + (table : RankinPositionalCapTable) + (slotBound productBound : ℕ) : + skeleton.admissibleCheck table slotBound productBound = true ↔ + skeleton.Admissible table slotBound productBound := by + simp [admissibleCheck, Admissible, and_assoc] + +end RankinExponentSkeleton + +def actualRankinExponentSkeleton (p : ℕ) : RankinExponentSkeleton where + minusTwoExponent := (p - 1).factorization 2 + plusTwoExponent := (p + 1).factorization 2 + oddExponents := actualOddExponentSkeleton p + +@[simp] theorem actualRankinExponentSkeleton_toProfile + (p : ℕ) (table : RankinPositionalCapTable) (rootCap : ℕ) : + (actualRankinExponentSkeleton p).toProfile table rootCap = + positionalRankinSkeletonProfile table.twoCap table.oddCapAt + ((p - 1).factorization 2) ((p + 1).factorization 2) + (actualOddExponentSkeleton p) rootCap := by + rfl + +theorem actualRankinExponentSkeleton_oddExponentsPositive + {p : ℕ} (hpOne : 1 < p) : + (actualRankinExponentSkeleton p).OddExponentsPositive := by + intro exponent hexponent + simp only [actualRankinExponentSkeleton] at hexponent ⊢ + rw [actualOddExponentSkeleton] at hexponent + obtain ⟨prime, hprime, rfl⟩ := List.mem_map.mp hexponent + exact actualNeighborExponent_pos hpOne hprime + +theorem actualRankinExponentSkeleton_productBudget_1248 + {p : ℕ} (hpPrime : p.Prime) (hpTwo : 2 < p) + (hp : p < 2 ^ 1248) : + ((actualRankinExponentSkeleton p).toProfile + rankinCutoff1248CapTable 1).jointLowerNeighborProduct < + 2 ^ (2 * 1248) := by + have hlength : (jointOddPrimeList p).length ≤ + rankinCutoff1248CapTable.oddPrimeFloors.length := by + apply jointOddPrimeList_length_le_rankinCutoff1248CapTable + · omega + · exact hp + let actualProfile := positionalCanonicalRankinNeighborProfile p + rankinCutoff1248CapTable.twoCap + rankinCutoff1248CapTable.oddCapAt 1 + have hmatch : actualProfile.Matches p := by + exact positionalCanonicalRankinNeighborProfile_matches_of_capTable + rankinCutoff1248CapTable_valid hlength 1 + have hlower := actualProfile.lowerNeighborProducts_le + hpPrime hpTwo hmatch + have hjointLower : actualProfile.jointLowerNeighborProduct ≤ + (p - 1) * (p + 1) := by + rw [RankinNeighborProfile.jointLowerNeighborProduct_eq_mul] + exact Nat.mul_le_mul hlower.1 hlower.2 + have hneighbors := neighbors_mul_lt_two_pow_two_mul (by omega) hp + have herase := eraseSides_positionalCanonicalRankinNeighborProfile p + rankinCutoff1248CapTable.twoCap + rankinCutoff1248CapTable.oddCapAt 1 + calc + ((actualRankinExponentSkeleton p).toProfile + rankinCutoff1248CapTable 1).jointLowerNeighborProduct = + actualProfile.eraseSides.jointLowerNeighborProduct := by + rw [herase] + rfl + _ = actualProfile.jointLowerNeighborProduct := by + exact RankinNeighborProfile.eraseSides_jointLowerNeighborProduct + actualProfile + _ ≤ (p - 1) * (p + 1) := hjointLower + _ < 2 ^ (2 * 1248) := hneighbors + +/-- Every actual prime below the target lies in the executable finite search +domain. This theorem is coverage, not yet the terminal leaf check. -/ +theorem actualRankinExponentSkeleton_admissible_1248 + {p : ℕ} (hpPrime : p.Prime) (hpTwo : 2 < p) + (hp : p < 2 ^ 1248) : + (actualRankinExponentSkeleton p).Admissible + rankinCutoff1248CapTable 275 (2 ^ (2 * 1248)) := by + refine ⟨neighboring_twoFactorization_shape hpPrime hpTwo, + actualRankinExponentSkeleton_oddExponentsPositive (by omega), ?_, ?_⟩ + · simpa [actualRankinExponentSkeleton, actualOddExponentSkeleton] using + jointOddPrimeList_length_lt_275_of_lt_two_pow_1248 + (by omega) hp + · exact actualRankinExponentSkeleton_productBudget_1248 hpPrime hpTwo hp + +end BGS.NumberTheory diff --git a/LeanPool/MarkoffModP/BGS/NumberTheory/RankinJointEnvelopeCertificate.lean b/LeanPool/MarkoffModP/BGS/NumberTheory/RankinJointEnvelopeCertificate.lean new file mode 100644 index 0000000000..8cd5227822 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/NumberTheory/RankinJointEnvelopeCertificate.lean @@ -0,0 +1,589 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.NumberTheory.RankinProfileCertificate + +/-! +# Side-erased joint Rankin envelopes + +The complete profile remembers whether every odd prime power belongs to +`p - 1` or `p + 1`. Exhaustive certification should not branch over that +binary word. Multiplying the two side divisor counts, Euler products, and +factorization lower bounds erases the word. Since both side divisor counts +are at least two and both coarse Euler products are at least one, the sums +appearing in the exact-order obstruction are controlled by these products. + +This is the proof-facing arithmetic layer for a substantially smaller finite +profile search. It contains no generated data and no coverage assumption. +-/ + +@[expose] public section + +namespace BGS.NumberTheory + +namespace RankinNeighborProfile + +/-- Side-free product of all odd divisor-lattice lengths. -/ +def oddJointDivisorProduct : List RankinOddFactor → ℕ + | [] => 1 + | factor :: factors => + (factor.exponent + 1) * oddJointDivisorProduct factors + +/-- Product of the divisor counts of the two neighboring factorizations, +written in a form that does not inspect any side labels. -/ +def jointDivisorProduct (profile : RankinNeighborProfile) : ℕ := + (profile.minusTwoExponent + 1) * + (profile.plusTwoExponent + 1) * + oddJointDivisorProduct profile.oddFactors + +/-- Side-free product of all odd coarse Euler factors. -/ +def oddJointCoarseEulerProductProduct : List RankinOddFactor → ℚ + | [] => 1 + | factor :: factors => + coarseRankinPrimePowerFactor factor.exponent factor.weightCap.weight * + oddJointCoarseEulerProductProduct factors + +/-- Product of the two coarse Rankin Euler products, again computed without +examining the side labels. -/ +def jointCoarseEulerProductProduct + (profile : RankinNeighborProfile) : ℚ := + coarseRankinPrimePowerFactor profile.minusTwoExponent + profile.twoWeightCap.weight * + coarseRankinPrimePowerFactor profile.plusTwoExponent + profile.twoWeightCap.weight * + oddJointCoarseEulerProductProduct profile.oddFactors + +/-- Side-free product of all odd factorization floors. -/ +def oddJointLowerNeighborProduct : List RankinOddFactor → ℕ + | [] => 1 + | factor :: factors => + factor.weightCap.lowerPrime ^ factor.exponent * + oddJointLowerNeighborProduct factors + +/-- Product of the two factorization lower bounds. -/ +def jointLowerNeighborProduct (profile : RankinNeighborProfile) : ℕ := + 2 ^ (profile.minusTwoExponent + profile.plusTwoExponent) * + oddJointLowerNeighborProduct profile.oddFactors + +/-- Side-erased witness cap. The sum of the two divisor counts is at most +their product because each neighboring even integer has at least two +divisors. -/ +def jointEnvelopeWitnessCap (profile : RankinNeighborProfile) : ℕ := + 189 * profile.jointDivisorProduct ^ 3 + +/-- The extra validity condition for the side-erased envelope. -/ +def JointEnvelopeValid (profile : RankinNeighborProfile) : Prop := + profile.jointEnvelopeWitnessCap ≤ profile.rootCap ^ 12 + +/-- Failure square after replacing both side sums by side-erased products. -/ +def jointEnvelopeFailureSquare (profile : RankinNeighborProfile) : ℚ := + ((profile.jointEnvelopeWitnessCap : ℚ) * profile.rootCap * + (2 * profile.jointCoarseEulerProductProduct)) ^ 2 + +def JointEnvelopeClosesCutoff + (profile : RankinNeighborProfile) (cutoff : ℕ) : Prop := + profile.jointEnvelopeFailureSquare < (8 * (cutoff + 1) : ℕ) + +def JointEnvelopeExcludesFailure + (profile : RankinNeighborProfile) : Prop := + profile.jointEnvelopeFailureSquare ^ 2 < + (64 * profile.jointLowerNeighborProduct : ℕ) + +def jointEnvelopeValidCheck (profile : RankinNeighborProfile) : Bool := + decide (profile.jointEnvelopeWitnessCap ≤ profile.rootCap ^ 12) + +def jointEnvelopeClosesCutoffCheck + (profile : RankinNeighborProfile) (cutoff : ℕ) : Bool := + decide + (profile.jointEnvelopeFailureSquare < + ((8 * (cutoff + 1) : ℕ) : ℚ)) + +def jointEnvelopeExcludesFailureCheck + (profile : RankinNeighborProfile) : Bool := + decide + (profile.jointEnvelopeFailureSquare ^ 2 < + ((64 * profile.jointLowerNeighborProduct : ℕ) : ℚ)) + +/-- Complete executable leaf predicate for generated side-erased profiles. -/ +def JointEnvelopeLeafValid + (profile : RankinNeighborProfile) (cutoff : ℕ) : Prop := + profile.Valid ∧ profile.JointEnvelopeValid ∧ + (profile.JointEnvelopeClosesCutoff cutoff ∨ + profile.JointEnvelopeExcludesFailure) + +def jointEnvelopeLeafCheck + (profile : RankinNeighborProfile) (cutoff : ℕ) : Bool := + profile.check && profile.jointEnvelopeValidCheck && + (profile.jointEnvelopeClosesCutoffCheck cutoff || + profile.jointEnvelopeExcludesFailureCheck) + +@[simp] theorem jointEnvelopeValidCheck_eq_true_iff + (profile : RankinNeighborProfile) : + profile.jointEnvelopeValidCheck = true ↔ + profile.JointEnvelopeValid := by + simp [jointEnvelopeValidCheck, JointEnvelopeValid] + +@[simp] theorem jointEnvelopeClosesCutoffCheck_eq_true_iff + (profile : RankinNeighborProfile) (cutoff : ℕ) : + profile.jointEnvelopeClosesCutoffCheck cutoff = true ↔ + profile.JointEnvelopeClosesCutoff cutoff := by + simp [jointEnvelopeClosesCutoffCheck, JointEnvelopeClosesCutoff] + +@[simp] theorem jointEnvelopeExcludesFailureCheck_eq_true_iff + (profile : RankinNeighborProfile) : + profile.jointEnvelopeExcludesFailureCheck = true ↔ + profile.JointEnvelopeExcludesFailure := by + simp [jointEnvelopeExcludesFailureCheck, JointEnvelopeExcludesFailure] + +@[simp] theorem jointEnvelopeLeafCheck_eq_true_iff + (profile : RankinNeighborProfile) (cutoff : ℕ) : + profile.jointEnvelopeLeafCheck cutoff = true ↔ + profile.JointEnvelopeLeafValid cutoff := by + simp [jointEnvelopeLeafCheck, JointEnvelopeLeafValid, and_assoc] + +/-- Canonical representative of an odd slot after forgetting its side. -/ +def eraseOddFactorSide (factor : RankinOddFactor) : RankinOddFactor where + side := .minus + exponent := factor.exponent + weightCap := factor.weightCap + +/-- Canonical all-minus representative of a profile. The joint envelope +checker is invariant under this operation. -/ +def eraseSides (profile : RankinNeighborProfile) : RankinNeighborProfile where + minusTwoExponent := profile.minusTwoExponent + plusTwoExponent := profile.plusTwoExponent + twoWeightCap := profile.twoWeightCap + oddFactors := profile.oddFactors.map eraseOddFactorSide + rootCap := profile.rootCap + +private theorem oddJointDivisorProduct_map_eraseOddFactorSide + (factors : List RankinOddFactor) : + oddJointDivisorProduct (factors.map eraseOddFactorSide) = + oddJointDivisorProduct factors := by + induction factors with + | nil => simp [oddJointDivisorProduct] + | cons factor factors ih => + simp [oddJointDivisorProduct, eraseOddFactorSide, ih] + +private theorem oddJointCoarseProduct_map_eraseOddFactorSide + (factors : List RankinOddFactor) : + oddJointCoarseEulerProductProduct + (factors.map eraseOddFactorSide) = + oddJointCoarseEulerProductProduct factors := by + induction factors with + | nil => simp [oddJointCoarseEulerProductProduct] + | cons factor factors ih => + simp [oddJointCoarseEulerProductProduct, eraseOddFactorSide, ih] + +private theorem oddJointLowerProduct_map_eraseOddFactorSide + (factors : List RankinOddFactor) : + oddJointLowerNeighborProduct (factors.map eraseOddFactorSide) = + oddJointLowerNeighborProduct factors := by + induction factors with + | nil => simp [oddJointLowerNeighborProduct] + | cons factor factors ih => + simp [oddJointLowerNeighborProduct, eraseOddFactorSide, ih] + +@[simp] theorem eraseSides_jointDivisorProduct + (profile : RankinNeighborProfile) : + profile.eraseSides.jointDivisorProduct = + profile.jointDivisorProduct := by + simp [eraseSides, jointDivisorProduct, + oddJointDivisorProduct_map_eraseOddFactorSide] + +@[simp] theorem eraseSides_jointCoarseEulerProductProduct + (profile : RankinNeighborProfile) : + profile.eraseSides.jointCoarseEulerProductProduct = + profile.jointCoarseEulerProductProduct := by + simp [eraseSides, jointCoarseEulerProductProduct, + oddJointCoarseProduct_map_eraseOddFactorSide] + +@[simp] theorem eraseSides_jointLowerNeighborProduct + (profile : RankinNeighborProfile) : + profile.eraseSides.jointLowerNeighborProduct = + profile.jointLowerNeighborProduct := by + simp [eraseSides, jointLowerNeighborProduct, + oddJointLowerProduct_map_eraseOddFactorSide] + +@[simp] theorem eraseSides_jointEnvelopeWitnessCap + (profile : RankinNeighborProfile) : + profile.eraseSides.jointEnvelopeWitnessCap = + profile.jointEnvelopeWitnessCap := by + simp [jointEnvelopeWitnessCap] + +@[simp] theorem eraseSides_jointEnvelopeFailureSquare + (profile : RankinNeighborProfile) : + profile.eraseSides.jointEnvelopeFailureSquare = + profile.jointEnvelopeFailureSquare := by + change + (((profile.eraseSides.jointEnvelopeWitnessCap : ℚ) * + profile.eraseSides.rootCap * + (2 * profile.eraseSides.jointCoarseEulerProductProduct)) ^ 2) = + (((profile.jointEnvelopeWitnessCap : ℚ) * profile.rootCap * + (2 * profile.jointCoarseEulerProductProduct)) ^ 2) + rw [eraseSides_jointEnvelopeWitnessCap, + eraseSides_jointCoarseEulerProductProduct] + rfl + +@[simp] theorem eraseSides_jointEnvelopeValid_iff + (profile : RankinNeighborProfile) : + profile.eraseSides.JointEnvelopeValid ↔ + profile.JointEnvelopeValid := by + change + profile.eraseSides.jointEnvelopeWitnessCap ≤ + profile.eraseSides.rootCap ^ 12 ↔ + profile.jointEnvelopeWitnessCap ≤ profile.rootCap ^ 12 + rw [eraseSides_jointEnvelopeWitnessCap] + rfl + +@[simp] theorem eraseSides_jointEnvelopeClosesCutoff_iff + (profile : RankinNeighborProfile) (cutoff : ℕ) : + profile.eraseSides.JointEnvelopeClosesCutoff cutoff ↔ + profile.JointEnvelopeClosesCutoff cutoff := by + simp [JointEnvelopeClosesCutoff] + +@[simp] theorem eraseSides_jointEnvelopeExcludesFailure_iff + (profile : RankinNeighborProfile) : + profile.eraseSides.JointEnvelopeExcludesFailure ↔ + profile.JointEnvelopeExcludesFailure := by + simp [JointEnvelopeExcludesFailure] + +private theorem allRankinOddFactorsValid_map_eraseOddFactorSide + {factors : List RankinOddFactor} + (hvalid : allRankinOddFactorsValid factors) : + allRankinOddFactorsValid (factors.map eraseOddFactorSide) := by + induction factors with + | nil => simp [allRankinOddFactorsValid] + | cons factor factors ih => + simp only [allRankinOddFactorsValid] at hvalid + simp only [List.map_cons, allRankinOddFactorsValid] + exact ⟨by simpa [RankinOddFactor.Valid, eraseOddFactorSide] using hvalid.1, + ih hvalid.2⟩ + +private theorem rankinOddFloorsStrictlyIncreasing_map_eraseOddFactorSide + {factors : List RankinOddFactor} + (hstrict : rankinOddFloorsStrictlyIncreasing factors) : + rankinOddFloorsStrictlyIncreasing + (factors.map eraseOddFactorSide) := by + rw [rankinOddFloorsStrictlyIncreasing] at hstrict ⊢ + rw [List.pairwise_map] + simpa [eraseOddFactorSide] using hstrict + +/-- Checking the canonical all-minus representative is exactly equivalent to +checking the joint arithmetic leaf of the actual side assignment. -/ +theorem jointEnvelope_leaf_of_eraseSides_leaf + (profile : RankinNeighborProfile) {cutoff : ℕ} + (hleaf : profile.eraseSides.JointEnvelopeClosesCutoff cutoff ∨ + profile.eraseSides.JointEnvelopeExcludesFailure) : + profile.JointEnvelopeClosesCutoff cutoff ∨ + profile.JointEnvelopeExcludesFailure := by + simpa using hleaf + +private theorem oddDivisorCount_pos + (side : NeighborSide) (factors : List RankinOddFactor) : + 0 < oddDivisorCount side factors := by + induction factors with + | nil => simp [oddDivisorCount] + | cons factor factors ih => + simp only [oddDivisorCount] + split_ifs <;> positivity + +private theorem oddDivisorCount_mul_eq_oddJointDivisorProduct + (factors : List RankinOddFactor) : + oddDivisorCount .minus factors * oddDivisorCount .plus factors = + oddJointDivisorProduct factors := by + induction factors with + | nil => simp [oddDivisorCount, oddJointDivisorProduct] + | cons factor factors ih => + rcases factor with ⟨side, exponent, weightCap⟩ + cases side <;> + simp only [oddDivisorCount, oddJointDivisorProduct, + reduceCtorEq, ↓reduceIte] <;> + simpa [mul_assoc, mul_left_comm, mul_comm] using + congrArg (fun value : ℕ => (exponent + 1) * value) ih + +theorem jointDivisorProduct_eq_mul + (profile : RankinNeighborProfile) : + profile.jointDivisorProduct = + profile.divisorCount .minus * profile.divisorCount .plus := by + simp only [jointDivisorProduct, divisorCount, twoExponent] + rw [← oddDivisorCount_mul_eq_oddJointDivisorProduct] + ring + +theorem two_le_divisorCount_of_shape + (profile : RankinNeighborProfile) + (hshape : + (profile.minusTwoExponent = 1 ∧ + 2 ≤ profile.plusTwoExponent) ∨ + (profile.plusTwoExponent = 1 ∧ + 2 ≤ profile.minusTwoExponent)) + (side : NeighborSide) : + 2 ≤ profile.divisorCount side := by + have htwo : 1 ≤ profile.twoExponent side := by + rcases hshape with hshape | hshape + · cases side with + | minus => simp [twoExponent, hshape.1] + | plus => simp [twoExponent]; omega + · cases side with + | minus => simp [twoExponent]; omega + | plus => simp [twoExponent, hshape.1] + simp only [divisorCount] + have hodd : 0 < oddDivisorCount side profile.oddFactors := + oddDivisorCount_pos side profile.oddFactors + nlinarith + +theorem two_le_divisorCount_of_valid + (profile : RankinNeighborProfile) (hprofile : profile.Valid) + (side : NeighborSide) : + 2 ≤ profile.divisorCount side := + profile.two_le_divisorCount_of_shape hprofile.1 side + +/-- The side divisor-count sum is bounded by the side-erased product. -/ +theorem jointDivisorCount_le_jointDivisorProduct + (profile : RankinNeighborProfile) (hprofile : profile.Valid) : + profile.jointDivisorCount ≤ profile.jointDivisorProduct := by + rw [profile.jointDivisorProduct_eq_mul] + exact Nat.add_le_mul + (profile.two_le_divisorCount_of_valid hprofile .minus) + (profile.two_le_divisorCount_of_valid hprofile .plus) + +theorem jointDivisorCount_le_jointDivisorProduct_of_shape + (profile : RankinNeighborProfile) + (hshape : + (profile.minusTwoExponent = 1 ∧ + 2 ≤ profile.plusTwoExponent) ∨ + (profile.plusTwoExponent = 1 ∧ + 2 ≤ profile.minusTwoExponent)) : + profile.jointDivisorCount ≤ profile.jointDivisorProduct := by + rw [profile.jointDivisorProduct_eq_mul] + exact Nat.add_le_mul + (profile.two_le_divisorCount_of_shape hshape .minus) + (profile.two_le_divisorCount_of_shape hshape .plus) + +theorem witnessCap_le_jointEnvelopeWitnessCap_of_shape + (profile : RankinNeighborProfile) + (hshape : + (profile.minusTwoExponent = 1 ∧ + 2 ≤ profile.plusTwoExponent) ∨ + (profile.plusTwoExponent = 1 ∧ + 2 ≤ profile.minusTwoExponent)) : + profile.witnessCap ≤ profile.jointEnvelopeWitnessCap := by + simp only [witnessCap, jointEnvelopeWitnessCap] + exact Nat.mul_le_mul_left 189 + (Nat.pow_le_pow_left + (profile.jointDivisorCount_le_jointDivisorProduct_of_shape hshape) 3) + +private theorem one_le_oddCoarseEulerProduct + (side : NeighborSide) (factors : List RankinOddFactor) : + 1 ≤ oddCoarseEulerProduct side factors := by + induction factors with + | nil => simp [oddCoarseEulerProduct] + | cons factor factors ih => + simp only [oddCoarseEulerProduct] + split_ifs with hside + · have hlocal : + (1 : ℚ) ≤ coarseRankinPrimePowerFactor factor.exponent + factor.weightCap.weight := by + simp only [coarseRankinPrimePowerFactor] + exact le_add_of_nonneg_right + (Finset.sum_nonneg fun index _ => + pow_nonneg factor.weightCap.weight_nonneg (index + 1)) + exact one_le_mul_of_one_le_of_one_le hlocal ih + · simpa using ih + +theorem one_le_coarseEulerProduct + (profile : RankinNeighborProfile) (side : NeighborSide) : + 1 ≤ profile.coarseEulerProduct side := by + simp only [coarseEulerProduct] + have htwo : + (1 : ℚ) ≤ coarseRankinPrimePowerFactor + (profile.twoExponent side) profile.twoWeightCap.weight := by + simp only [coarseRankinPrimePowerFactor] + exact le_add_of_nonneg_right + (Finset.sum_nonneg fun index _ => + pow_nonneg profile.twoWeightCap.weight_nonneg (index + 1)) + exact one_le_mul_of_one_le_of_one_le htwo + (one_le_oddCoarseEulerProduct side profile.oddFactors) + +private theorem oddCoarseEulerProduct_mul_eq_oddJointProduct + (factors : List RankinOddFactor) : + oddCoarseEulerProduct .minus factors * + oddCoarseEulerProduct .plus factors = + oddJointCoarseEulerProductProduct factors := by + induction factors with + | nil => + simp [oddCoarseEulerProduct, oddJointCoarseEulerProductProduct] + | cons factor factors ih => + rcases factor with ⟨side, exponent, weightCap⟩ + cases side <;> + simp only [oddCoarseEulerProduct, + oddJointCoarseEulerProductProduct, reduceCtorEq, ↓reduceIte] <;> + simpa [mul_assoc, mul_left_comm, mul_comm] using + congrArg (fun value : ℚ => + coarseRankinPrimePowerFactor exponent weightCap.weight * value) ih + +theorem jointCoarseEulerProductProduct_eq_mul + (profile : RankinNeighborProfile) : + profile.jointCoarseEulerProductProduct = + profile.coarseEulerProduct .minus * + profile.coarseEulerProduct .plus := by + simp only [jointCoarseEulerProductProduct, coarseEulerProduct, twoExponent] + rw [← oddCoarseEulerProduct_mul_eq_oddJointProduct] + ring + +private theorem oddLowerNeighborProduct_mul_eq_oddJointProduct + (factors : List RankinOddFactor) : + oddLowerNeighborProduct .minus factors * + oddLowerNeighborProduct .plus factors = + oddJointLowerNeighborProduct factors := by + induction factors with + | nil => + simp [oddLowerNeighborProduct, oddJointLowerNeighborProduct] + | cons factor factors ih => + rcases factor with ⟨side, exponent, weightCap⟩ + cases side <;> + simp only [oddLowerNeighborProduct, + oddJointLowerNeighborProduct, reduceCtorEq, ↓reduceIte] <;> + simpa [mul_assoc, mul_left_comm, mul_comm] using + congrArg (fun value : ℕ => + weightCap.lowerPrime ^ exponent * value) ih + +theorem jointLowerNeighborProduct_eq_mul + (profile : RankinNeighborProfile) : + profile.jointLowerNeighborProduct = + profile.lowerNeighborProduct .minus * + profile.lowerNeighborProduct .plus := by + simp only [jointLowerNeighborProduct, lowerNeighborProduct, twoExponent] + rw [← oddLowerNeighborProduct_mul_eq_oddJointProduct] + rw [pow_add] + ring + +/-- The sum of the two Euler products is at most twice their product. -/ +theorem jointCoarseEulerProduct_le_two_mul_product + (profile : RankinNeighborProfile) : + profile.jointCoarseEulerProduct ≤ + 2 * profile.jointCoarseEulerProductProduct := by + have hminus := profile.one_le_coarseEulerProduct .minus + have hplus := profile.one_le_coarseEulerProduct .plus + rw [profile.jointCoarseEulerProductProduct_eq_mul] + simp only [jointCoarseEulerProduct] + calc + profile.coarseEulerProduct .minus + + profile.coarseEulerProduct .plus ≤ + profile.coarseEulerProduct .minus * + profile.coarseEulerProduct .plus + + profile.coarseEulerProduct .minus * + profile.coarseEulerProduct .plus := by + exact add_le_add + (calc + profile.coarseEulerProduct .minus = + profile.coarseEulerProduct .minus * 1 := by ring + _ ≤ profile.coarseEulerProduct .minus * + profile.coarseEulerProduct .plus := + mul_le_mul_of_nonneg_left hplus (by linarith)) + (calc + profile.coarseEulerProduct .plus = + 1 * profile.coarseEulerProduct .plus := by ring + _ ≤ profile.coarseEulerProduct .minus * + profile.coarseEulerProduct .plus := + mul_le_mul_of_nonneg_right hminus (by linarith)) + _ = 2 * (profile.coarseEulerProduct .minus * + profile.coarseEulerProduct .plus) := by ring + +/-- The ordinary profile failure square is dominated by the side-erased +joint envelope. -/ +theorem failureSquare_le_jointEnvelopeFailureSquare + (profile : RankinNeighborProfile) (hprofile : profile.Valid) : + profile.failureSquare ≤ profile.jointEnvelopeFailureSquare := by + have hwitnessNat : + profile.witnessCap ≤ profile.jointEnvelopeWitnessCap := by + exact profile.witnessCap_le_jointEnvelopeWitnessCap_of_shape hprofile.1 + have hwitness : + (profile.witnessCap : ℚ) ≤ profile.jointEnvelopeWitnessCap := by + exact_mod_cast hwitnessNat + have hroot : (0 : ℚ) ≤ profile.rootCap := by positivity + have hEulerNonneg : + (0 : ℚ) ≤ profile.jointCoarseEulerProduct := by + have hminus := profile.one_le_coarseEulerProduct .minus + have hplus := profile.one_le_coarseEulerProduct .plus + simp only [jointCoarseEulerProduct] + linarith + have hproductEulerNonneg : + (0 : ℚ) ≤ 2 * profile.jointCoarseEulerProductProduct := by + have hminus := profile.one_le_coarseEulerProduct .minus + have hplus := profile.one_le_coarseEulerProduct .plus + rw [profile.jointCoarseEulerProductProduct_eq_mul] + exact mul_nonneg (by norm_num) + (mul_nonneg (by linarith) (by linarith)) + have hbase : + (profile.witnessCap : ℚ) * profile.rootCap * + profile.jointCoarseEulerProduct ≤ + (profile.jointEnvelopeWitnessCap : ℚ) * profile.rootCap * + (2 * profile.jointCoarseEulerProductProduct) := by + exact mul_le_mul + (mul_le_mul_of_nonneg_right hwitness hroot) + profile.jointCoarseEulerProduct_le_two_mul_product + hEulerNonneg + (mul_nonneg (by positivity) hroot) + have hleftNonneg : + (0 : ℚ) ≤ (profile.witnessCap : ℚ) * profile.rootCap * + profile.jointCoarseEulerProduct := + mul_nonneg (mul_nonneg (by positivity) hroot) hEulerNonneg + have hrightNonneg : + (0 : ℚ) ≤ (profile.jointEnvelopeWitnessCap : ℚ) * + profile.rootCap * + (2 * profile.jointCoarseEulerProductProduct) := + mul_nonneg (mul_nonneg (by positivity) hroot) hproductEulerNonneg + simpa [failureSquare, jointEnvelopeFailureSquare] using + (sq_le_sq₀ hleftNonneg hrightNonneg).2 hbase + +theorem jointEnvelopeClosesCutoff_implies_closesCutoff + (profile : RankinNeighborProfile) (hprofile : profile.Valid) + {cutoff : ℕ} (hcloses : profile.JointEnvelopeClosesCutoff cutoff) : + profile.ClosesCutoff cutoff := by + exact (profile.failureSquare_le_jointEnvelopeFailureSquare hprofile).trans_lt + hcloses + +theorem jointEnvelopeExcludesFailure_implies_excludesFailure + (profile : RankinNeighborProfile) (hprofile : profile.Valid) + (hexcludes : profile.JointEnvelopeExcludesFailure) : + profile.ExcludesFailure := by + right + right + have hsquare : + profile.failureSquare ^ 2 ≤ + profile.jointEnvelopeFailureSquare ^ 2 := + pow_le_pow_left₀ (by + rw [failureSquare] + exact sq_nonneg _) + (profile.failureSquare_le_jointEnvelopeFailureSquare hprofile) 2 + have hexcludes' := hexcludes + rw [JointEnvelopeExcludesFailure, + profile.jointLowerNeighborProduct_eq_mul] at hexcludes' + exact hsquare.trans_lt hexcludes' + +/-- A valid actual profile with a side-erased root certificate yields a valid +canonical all-minus profile. -/ +theorem eraseSides_valid_of_valid_of_jointEnvelopeValid + (profile : RankinNeighborProfile) (hprofile : profile.Valid) + (hjoint : profile.JointEnvelopeValid) : + profile.eraseSides.Valid := by + refine ⟨hprofile.1, hprofile.2.1, hprofile.2.2.1, + allRankinOddFactorsValid_map_eraseOddFactorSide hprofile.2.2.2.1, + rankinOddFloorsStrictlyIncreasing_map_eraseOddFactorSide + hprofile.2.2.2.2.1, + ?_, ?_⟩ + · simpa [eraseSides] using hprofile.2.2.2.2.2.1 + · exact + (profile.eraseSides.witnessCap_le_jointEnvelopeWitnessCap_of_shape + hprofile.1).trans + ((eraseSides_jointEnvelopeValid_iff profile).mpr hjoint) + +end RankinNeighborProfile + +end BGS.NumberTheory diff --git a/LeanPool/MarkoffModP/BGS/NumberTheory/RankinJointEnvelopeCoverage.lean b/LeanPool/MarkoffModP/BGS/NumberTheory/RankinJointEnvelopeCoverage.lean new file mode 100644 index 0000000000..09e440e52d --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/NumberTheory/RankinJointEnvelopeCoverage.lean @@ -0,0 +1,218 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.ExactOrderRankinEnvelope + +/-! +# Finite coverage for side-erased Rankin envelopes + +A generated profile need not equal the canonical profile of `p`. It is +enough that it has a larger failure square and a smaller factorization floor. +Those two inequalities transport both kinds of terminal leaf. This replaces +exact enumeration by domination: one checked profile can close an entire +family of exponent/floor skeletons. + +The certificate below contains only data. Lean checks every leaf, while a +separate coverage theorem must exhibit a dominating row for the actual +profile. Thus generated arithmetic and mathematical exhaustiveness remain +distinct proof obligations. +-/ + +@[expose] public section + +namespace BGS.NumberTheory + +namespace RankinNeighborProfile + +/-- `major` is a safe arithmetic representative for `actual`: its obstruction +upper bound is no smaller, and its factorization lower bound is no larger. -/ +def JointEnvelopeDominates + (major actual : RankinNeighborProfile) : Prop := + actual.jointEnvelopeFailureSquare ≤ + major.jointEnvelopeFailureSquare ∧ + major.jointLowerNeighborProduct ≤ + actual.jointLowerNeighborProduct + +def jointEnvelopeDominatesCheck + (major actual : RankinNeighborProfile) : Bool := + decide + (actual.jointEnvelopeFailureSquare ≤ + major.jointEnvelopeFailureSquare ∧ + major.jointLowerNeighborProduct ≤ + actual.jointLowerNeighborProduct) + +@[simp] theorem jointEnvelopeDominatesCheck_eq_true_iff + (major actual : RankinNeighborProfile) : + major.jointEnvelopeDominatesCheck actual = true ↔ + major.JointEnvelopeDominates actual := by + simp [jointEnvelopeDominatesCheck, JointEnvelopeDominates] + +theorem jointEnvelopeDominates_refl + (profile : RankinNeighborProfile) : + profile.JointEnvelopeDominates profile := by + exact ⟨le_rfl, le_rfl⟩ + +theorem JointEnvelopeDominates.trans + {first middle last : RankinNeighborProfile} + (hfirst : first.JointEnvelopeDominates middle) + (hmiddle : middle.JointEnvelopeDominates last) : + first.JointEnvelopeDominates last := by + exact ⟨hmiddle.1.trans hfirst.1, hfirst.2.trans hmiddle.2⟩ + +theorem eraseSides_jointEnvelopeDominates + (profile : RankinNeighborProfile) : + profile.eraseSides.JointEnvelopeDominates profile := by + constructor + · rw [eraseSides_jointEnvelopeFailureSquare] + · rw [eraseSides_jointLowerNeighborProduct] + +theorem jointEnvelopeClosesCutoff_of_dominates + {major actual : RankinNeighborProfile} {cutoff : ℕ} + (hdom : major.JointEnvelopeDominates actual) + (hcloses : major.JointEnvelopeClosesCutoff cutoff) : + actual.JointEnvelopeClosesCutoff cutoff := by + exact hdom.1.trans_lt hcloses + +theorem jointEnvelopeExcludesFailure_of_dominates + {major actual : RankinNeighborProfile} + (hdom : major.JointEnvelopeDominates actual) + (hexcludes : major.JointEnvelopeExcludesFailure) : + actual.JointEnvelopeExcludesFailure := by + have hactualNonneg : + (0 : ℚ) ≤ actual.jointEnvelopeFailureSquare := by + rw [jointEnvelopeFailureSquare] + positivity + have hsquare : + actual.jointEnvelopeFailureSquare ^ 2 ≤ + major.jointEnvelopeFailureSquare ^ 2 := + pow_le_pow_left₀ hactualNonneg hdom.1 2 + have hlower : + ((64 * major.jointLowerNeighborProduct : ℕ) : ℚ) ≤ + ((64 * actual.jointLowerNeighborProduct : ℕ) : ℚ) := by + exact_mod_cast Nat.mul_le_mul_left 64 hdom.2 + exact hsquare.trans_lt (hexcludes.trans_le hlower) + +theorem jointEnvelope_leaf_of_dominates + {major actual : RankinNeighborProfile} {cutoff : ℕ} + (hdom : major.JointEnvelopeDominates actual) + (hleaf : major.JointEnvelopeClosesCutoff cutoff ∨ + major.JointEnvelopeExcludesFailure) : + actual.JointEnvelopeClosesCutoff cutoff ∨ + actual.JointEnvelopeExcludesFailure := by + rcases hleaf with hcloses | hexcludes + · exact Or.inl (jointEnvelopeClosesCutoff_of_dominates hdom hcloses) + · exact Or.inr (jointEnvelopeExcludesFailure_of_dominates hdom hexcludes) + +end RankinNeighborProfile + +def allRankinJointEnvelopeLeavesValid + (cutoff : ℕ) : List RankinNeighborProfile → Prop + | [] => True + | profile :: profiles => + profile.JointEnvelopeLeafValid cutoff ∧ + allRankinJointEnvelopeLeavesValid cutoff profiles + +def allRankinJointEnvelopeLeavesCheck + (cutoff : ℕ) : List RankinNeighborProfile → Bool + | [] => true + | profile :: profiles => + profile.jointEnvelopeLeafCheck cutoff && + allRankinJointEnvelopeLeavesCheck cutoff profiles + +@[simp] theorem allRankinJointEnvelopeLeavesCheck_eq_true_iff + (cutoff : ℕ) (profiles : List RankinNeighborProfile) : + allRankinJointEnvelopeLeavesCheck cutoff profiles = true ↔ + allRankinJointEnvelopeLeavesValid cutoff profiles := by + induction profiles with + | nil => + simp [allRankinJointEnvelopeLeavesCheck, + allRankinJointEnvelopeLeavesValid] + | cons profile profiles ih => + simp [allRankinJointEnvelopeLeavesCheck, + allRankinJointEnvelopeLeavesValid, ih] + +private theorem jointEnvelopeLeafValid_of_all_of_mem + {cutoff : ℕ} {profiles : List RankinNeighborProfile} + (hall : allRankinJointEnvelopeLeavesValid cutoff profiles) + {profile : RankinNeighborProfile} (hmem : profile ∈ profiles) : + profile.JointEnvelopeLeafValid cutoff := by + induction profiles with + | nil => simp at hmem + | cons head tail ih => + simp only [allRankinJointEnvelopeLeavesValid] at hall + simp only [List.mem_cons] at hmem + rcases hmem with rfl | hmem + · exact hall.1 + · exact ih hall.2 hmem + +/-- Pure generated data for a domination cover. There are deliberately no +proof fields: the list is checked by reduction, and exhaustiveness is proved +separately through `Covers`. -/ +structure RankinJointEnvelopeFiniteCertificate where + cutoff : ℕ + profiles : List RankinNeighborProfile + deriving DecidableEq, Repr + +namespace RankinJointEnvelopeFiniteCertificate + +def LeavesValid (cert : RankinJointEnvelopeFiniteCertificate) : Prop := + allRankinJointEnvelopeLeavesValid cert.cutoff cert.profiles + +def check (cert : RankinJointEnvelopeFiniteCertificate) : Bool := + allRankinJointEnvelopeLeavesCheck cert.cutoff cert.profiles + +/-- Mathematical coverage of one actual profile by the generated rows. -/ +def Covers + (cert : RankinJointEnvelopeFiniteCertificate) + (actual : RankinNeighborProfile) : Prop := + ∃ major ∈ cert.profiles, major.JointEnvelopeDominates actual + +@[simp] theorem check_eq_true_iff + (cert : RankinJointEnvelopeFiniteCertificate) : + cert.check = true ↔ cert.LeavesValid := by + simp [check, LeavesValid] + +theorem jointEnvelope_leaf_of_check_of_covers + {cert : RankinJointEnvelopeFiniteCertificate} + {actual : RankinNeighborProfile} + (hcheck : cert.check = true) (hcover : cert.Covers actual) : + actual.JointEnvelopeClosesCutoff cert.cutoff ∨ + actual.JointEnvelopeExcludesFailure := by + obtain ⟨major, hmem, hdom⟩ := hcover + have hall : cert.LeavesValid := cert.check_eq_true_iff.mp hcheck + have hmajor := jointEnvelopeLeafValid_of_all_of_mem hall hmem + exact RankinNeighborProfile.jointEnvelope_leaf_of_dominates + hdom hmajor.2.2 + +end RankinJointEnvelopeFiniteCertificate + +end BGS.NumberTheory + +namespace BGS.Markoff + +open BGS.NumberTheory + +/-- A checked finite domination cover discharges the arithmetic leaf in the +exact-order Rankin endpoint. -/ +theorem prime_le_of_rankinJointEnvelopeFiniteCertificate + {p bound : ℕ} + (hpPrime : p.Prime) (hpTwo : 2 < p) + (hroot : + 8 * p ≤ (combinedTruncatedOrderTotientSum p bound) ^ 2) + (hboundWitness : + bound ≤ 189 * (middleGameMaximalOrders p bound).card ^ 3) + (actual : RankinNeighborProfile) + (hactual : actual.Valid) (hmatch : actual.Matches p) + (cert : RankinJointEnvelopeFiniteCertificate) + (hcheck : cert.check = true) (hcover : cert.Covers actual) : + p ≤ cert.cutoff := by + apply prime_le_of_matching_rankinNeighborProfile_jointEnvelope_leaf + hpPrime hpTwo hroot hboundWitness actual hactual hmatch + exact cert.jointEnvelope_leaf_of_check_of_covers hcheck hcover + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/NumberTheory/RankinJointEnvelopeSummaryCoverage.lean b/LeanPool/MarkoffModP/BGS/NumberTheory/RankinJointEnvelopeSummaryCoverage.lean new file mode 100644 index 0000000000..8019d1cd88 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/NumberTheory/RankinJointEnvelopeSummaryCoverage.lean @@ -0,0 +1,239 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.NumberTheory.RankinJointEnvelopeCoverage + +/-! +# Scalar summaries for Rankin-envelope coverage + +A domination leaf does not need to be a structurally valid neighbor profile. +The exact-order endpoint only uses an upper bound for the joint failure square +and a lower bound for the joint factorization product. Recording just those +two monotone quantities lets one generated row summarize a whole box of +exponent skeletons. + +The generated list remains pure data. Lean checks every terminal inequality, +while a separate coverage theorem must prove that an actual profile is +dominated by one of the summaries. +-/ + +@[expose] public section + +namespace BGS.NumberTheory + +/-- The two scalar quantities needed to transport a joint-envelope leaf. -/ +structure RankinJointEnvelopeSummary where + /-- A rational upper bound for every represented failure square. -/ + failureSquareUpper : Rat + /-- A natural lower bound for every represented joint neighbor product. -/ + lowerNeighborProductFloor : Nat + deriving DecidableEq, Repr + +namespace RankinJointEnvelopeSummary + +/-- A summary safely contains an actual profile when its failure-square bound +is larger and its factorization floor is smaller. -/ +def Dominates (summary : RankinJointEnvelopeSummary) + (actual : RankinNeighborProfile) : Prop := + actual.jointEnvelopeFailureSquare <= summary.failureSquareUpper /\ + summary.lowerNeighborProductFloor <= actual.jointLowerNeighborProduct + +def dominatesCheck (summary : RankinJointEnvelopeSummary) + (actual : RankinNeighborProfile) : Bool := + decide + (actual.jointEnvelopeFailureSquare <= summary.failureSquareUpper /\ + summary.lowerNeighborProductFloor <= actual.jointLowerNeighborProduct) + +/-- Direct cutoff closure for a scalar summary. -/ +def ClosesCutoff + (summary : RankinJointEnvelopeSummary) (cutoff : Nat) : Prop := + summary.failureSquareUpper < (8 * (cutoff + 1) : Nat) + +/-- Product-budget exclusion for a scalar summary. -/ +def ExcludesFailure (summary : RankinJointEnvelopeSummary) : Prop := + summary.failureSquareUpper ^ 2 < + (64 * summary.lowerNeighborProductFloor : Nat) + +def LeafValid + (summary : RankinJointEnvelopeSummary) (cutoff : Nat) : Prop := + summary.ClosesCutoff cutoff \/ summary.ExcludesFailure + +def leafCheck + (summary : RankinJointEnvelopeSummary) (cutoff : Nat) : Bool := + decide + (summary.failureSquareUpper < (8 * (cutoff + 1) : Nat) \/ + summary.failureSquareUpper ^ 2 < + (64 * summary.lowerNeighborProductFloor : Nat)) + +@[simp] theorem dominatesCheck_eq_true_iff + (summary : RankinJointEnvelopeSummary) + (actual : RankinNeighborProfile) : + summary.dominatesCheck actual = true <-> summary.Dominates actual := by + simp [dominatesCheck, Dominates] + +@[simp] theorem leafCheck_eq_true_iff + (summary : RankinJointEnvelopeSummary) (cutoff : Nat) : + summary.leafCheck cutoff = true <-> summary.LeafValid cutoff := by + simp [leafCheck, LeafValid, ClosesCutoff, ExcludesFailure] + +/-- Every profile gives an exact scalar summary. -/ +def ofProfile (profile : RankinNeighborProfile) : + RankinJointEnvelopeSummary where + failureSquareUpper := profile.jointEnvelopeFailureSquare + lowerNeighborProductFloor := profile.jointLowerNeighborProduct + +theorem ofProfile_dominates (profile : RankinNeighborProfile) : + (ofProfile profile).Dominates profile := by + exact And.intro le_rfl le_rfl + +theorem jointEnvelopeClosesCutoff_of_dominates + {summary : RankinJointEnvelopeSummary} + {actual : RankinNeighborProfile} {cutoff : Nat} + (hdom : summary.Dominates actual) + (hcloses : summary.ClosesCutoff cutoff) : + actual.JointEnvelopeClosesCutoff cutoff := by + exact hdom.1.trans_lt hcloses + +theorem jointEnvelopeExcludesFailure_of_dominates + {summary : RankinJointEnvelopeSummary} + {actual : RankinNeighborProfile} + (hdom : summary.Dominates actual) + (hexcludes : summary.ExcludesFailure) : + actual.JointEnvelopeExcludesFailure := by + have hactualNonneg : + (0 : Rat) <= actual.jointEnvelopeFailureSquare := by + rw [RankinNeighborProfile.jointEnvelopeFailureSquare] + positivity + have hsummaryNonneg : (0 : Rat) <= summary.failureSquareUpper := + hactualNonneg.trans hdom.1 + have hsquare : + actual.jointEnvelopeFailureSquare ^ 2 <= + summary.failureSquareUpper ^ 2 := by + exact pow_le_pow_left₀ hactualNonneg hdom.1 2 + have hlower : + ((64 * summary.lowerNeighborProductFloor : Nat) : Rat) <= + ((64 * actual.jointLowerNeighborProduct : Nat) : Rat) := by + exact_mod_cast Nat.mul_le_mul_left 64 hdom.2 + exact hsquare.trans_lt (hexcludes.trans_le hlower) + +theorem jointEnvelope_leaf_of_dominates + {summary : RankinJointEnvelopeSummary} + {actual : RankinNeighborProfile} {cutoff : Nat} + (hdom : summary.Dominates actual) + (hleaf : summary.LeafValid cutoff) : + actual.JointEnvelopeClosesCutoff cutoff \/ + actual.JointEnvelopeExcludesFailure := by + rcases hleaf with hcloses | hexcludes + · exact Or.inl (jointEnvelopeClosesCutoff_of_dominates hdom hcloses) + · exact Or.inr (jointEnvelopeExcludesFailure_of_dominates hdom hexcludes) + +end RankinJointEnvelopeSummary + +def allRankinJointEnvelopeSummariesValid + (cutoff : Nat) : List RankinJointEnvelopeSummary -> Prop + | [] => True + | summary :: summaries => + summary.LeafValid cutoff /\ + allRankinJointEnvelopeSummariesValid cutoff summaries + +def allRankinJointEnvelopeSummariesCheck + (cutoff : Nat) : List RankinJointEnvelopeSummary -> Bool + | [] => true + | summary :: summaries => + summary.leafCheck cutoff && + allRankinJointEnvelopeSummariesCheck cutoff summaries + +@[simp] theorem allRankinJointEnvelopeSummariesCheck_eq_true_iff + (cutoff : Nat) (summaries : List RankinJointEnvelopeSummary) : + allRankinJointEnvelopeSummariesCheck cutoff summaries = true <-> + allRankinJointEnvelopeSummariesValid cutoff summaries := by + induction summaries with + | nil => + simp [allRankinJointEnvelopeSummariesCheck, + allRankinJointEnvelopeSummariesValid] + | cons summary summaries ih => + simp [allRankinJointEnvelopeSummariesCheck, + allRankinJointEnvelopeSummariesValid, ih] + +private theorem summaryLeafValid_of_all_of_mem + {cutoff : Nat} {summaries : List RankinJointEnvelopeSummary} + (hall : allRankinJointEnvelopeSummariesValid cutoff summaries) + {summary : RankinJointEnvelopeSummary} (hmem : summary ∈ summaries) : + summary.LeafValid cutoff := by + induction summaries with + | nil => simp at hmem + | cons head tail ih => + simp only [allRankinJointEnvelopeSummariesValid] at hall + simp only [List.mem_cons] at hmem + rcases hmem with rfl | hmem + · exact hall.1 + · exact ih hall.2 hmem + +/-- Pure scalar data for a compressed domination cover. -/ +structure RankinJointEnvelopeSummaryCertificate where + cutoff : Nat + summaries : List RankinJointEnvelopeSummary + deriving DecidableEq, Repr + +namespace RankinJointEnvelopeSummaryCertificate + +def LeavesValid (cert : RankinJointEnvelopeSummaryCertificate) : Prop := + allRankinJointEnvelopeSummariesValid cert.cutoff cert.summaries + +def check (cert : RankinJointEnvelopeSummaryCertificate) : Bool := + allRankinJointEnvelopeSummariesCheck cert.cutoff cert.summaries + +/-- Mathematical coverage of one actual profile by the generated summaries. -/ +def Covers (cert : RankinJointEnvelopeSummaryCertificate) + (actual : RankinNeighborProfile) : Prop := + Exists fun summary => + summary ∈ cert.summaries /\ summary.Dominates actual + +@[simp] theorem check_eq_true_iff + (cert : RankinJointEnvelopeSummaryCertificate) : + cert.check = true <-> cert.LeavesValid := by + simp [check, LeavesValid] + +theorem jointEnvelope_leaf_of_check_of_covers + {cert : RankinJointEnvelopeSummaryCertificate} + {actual : RankinNeighborProfile} + (hcheck : cert.check = true) (hcover : cert.Covers actual) : + actual.JointEnvelopeClosesCutoff cert.cutoff \/ + actual.JointEnvelopeExcludesFailure := by + obtain ⟨summary, hmem, hdom⟩ := hcover + have hall : cert.LeavesValid := cert.check_eq_true_iff.mp hcheck + have hsummary := summaryLeafValid_of_all_of_mem hall hmem + exact summary.jointEnvelope_leaf_of_dominates hdom hsummary + +end RankinJointEnvelopeSummaryCertificate + +end BGS.NumberTheory + +namespace BGS.Markoff + +open BGS.NumberTheory + +/-- A checked scalar summary cover discharges the arithmetic leaf without +requiring generated rows to be valid neighbor profiles. -/ +theorem prime_le_of_rankinJointEnvelopeSummaryCertificate + {p bound : Nat} + (hpPrime : p.Prime) (hpTwo : 2 < p) + (hroot : + 8 * p <= (combinedTruncatedOrderTotientSum p bound) ^ 2) + (hboundWitness : + bound <= 189 * (middleGameMaximalOrders p bound).card ^ 3) + (actual : RankinNeighborProfile) + (hactual : actual.Valid) (hmatch : actual.Matches p) + (cert : RankinJointEnvelopeSummaryCertificate) + (hcheck : cert.check = true) (hcover : cert.Covers actual) : + p <= cert.cutoff := by + apply prime_le_of_matching_rankinNeighborProfile_jointEnvelope_leaf + hpPrime hpTwo hroot hboundWitness actual hactual hmatch + exact cert.jointEnvelope_leaf_of_check_of_covers hcheck hcover + +end BGS.Markoff diff --git a/LeanPool/MarkoffModP/BGS/NumberTheory/RankinPositionalCoverage.lean b/LeanPool/MarkoffModP/BGS/NumberTheory/RankinPositionalCoverage.lean new file mode 100644 index 0000000000..a9a9e4d10e --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/NumberTheory/RankinPositionalCoverage.lean @@ -0,0 +1,317 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.NumberTheory.RankinPositionalProfile +public import Mathlib.Data.List.GetD +public import Mathlib.Data.Nat.PrimeFin + +/-! +# Finite positional cap ladders + +A finite certificate can store the first `k` odd primes as literal data. The +checker verifies each entry by primality and `primeCounting'`, so no +noncomputable prime enumeration occurs in the payload. Every increasing list +of odd primes of length at most `k` is then pointwise bounded below by this +ladder. Consequently the positional canonical profile really matches the +actual neighboring factorization. + +The remaining global coverage obligation is deliberately visible: one must +prove that the actual joint odd support has length at most the stored ladder. +-/ + +@[expose] public section + +namespace BGS.NumberTheory + +open scoped Nat.Prime + +/-- A strictly increasing list of odd primes has its entry in position `i` at +least the `(i + 1)`-st prime. The initial prime `2` supplies the shift. -/ +theorem nthPrime_succ_idxOf_le_of_pairwise + (values : List ℕ) (hnodup : values.Nodup) + (hpair : values.Pairwise (· < ·)) + (hprime : ∀ q ∈ values, q.Prime) + (htwo : 2 ∉ values) {q : ℕ} (hq : q ∈ values) : + Nat.nth Nat.Prime (values.idxOf q + 1) ≤ q := by + have hqPrime : q.Prime := hprime q hq + have hqThree : 3 ≤ q := by + have hqTwo := hqPrime.two_le + have hqNeTwo : q ≠ 2 := by + intro heq + subst q + exact htwo hq + omega + let earlier := values.take (values.idxOf q) + have hearlierNodup : earlier.Nodup := hnodup.take + have htwoEarlier : 2 ∉ earlier := by + intro hmem + exact htwo (List.mem_of_mem_take hmem) + have hsubset : insert 2 earlier.toFinset ⊆ q.primesBelow := by + intro r hr + rw [Finset.mem_insert] at hr + rcases hr with rfl | hr + · exact Nat.mem_primesBelow.mpr ⟨by omega, Nat.prime_two⟩ + · have hrEarlier : r ∈ earlier := by simpa using hr + have hrValues : r ∈ values := List.mem_of_mem_take hrEarlier + have hrIndex : values.idxOf r < values.idxOf q := by + exact (List.mem_take_iff_idxOf_lt hrValues).mp hrEarlier + have hrlt : r < q := by + have hrel := hpair.rel_get_of_lt + (a := ⟨values.idxOf r, List.idxOf_lt_length_of_mem hrValues⟩) + (b := ⟨values.idxOf q, List.idxOf_lt_length_of_mem hq⟩) + hrIndex + simpa [List.getElem_idxOf + (List.idxOf_lt_length_of_mem hrValues), + List.getElem_idxOf (List.idxOf_lt_length_of_mem hq)] using hrel + exact Nat.mem_primesBelow.mpr ⟨hrlt, hprime r hrValues⟩ + have hcard := Finset.card_le_card hsubset + have hindexCard : values.idxOf q + 1 ≤ q.primeCounting' := by + simpa [earlier, Finset.card_insert_of_notMem, + htwoEarlier, List.toFinset_card_of_nodup hearlierNodup, + List.length_take, Nat.min_eq_left + (List.idxOf_lt_length_of_mem hq).le, + Nat.primesBelow_card_eq_primeCounting'] using hcard + calc + Nat.nth Nat.Prime (values.idxOf q + 1) ≤ + Nat.nth Nat.Prime q.primeCounting' := + Nat.nth_monotone Nat.infinite_setOfPred_prime hindexCard + _ = q := by + simpa [Nat.primeCounting'] using Nat.nth_count hqPrime + +/-- The universal positional prime bound specialized to the canonical joint +odd support of `p`. -/ +theorem nthPrime_succ_idxOf_le_jointOddPrimeList + (p : ℕ) {q : ℕ} (hq : q ∈ jointOddPrimeList p) : + Nat.nth Nat.Prime ((jointOddPrimeList p).idxOf q + 1) ≤ q := by + apply nthPrime_succ_idxOf_le_of_pairwise + (jointOddPrimeList p) + (Finset.sort_nodup (jointOddPrimeSupport p) (· ≤ ·)) + (jointOddPrimeList_pairwise_lt p) + · intro prime hprime + rcases (mem_jointOddPrimeList.mp hprime).2 with hminus | hplus + · exact Nat.prime_of_mem_primeFactors hminus + · exact Nat.prime_of_mem_primeFactors hplus + · intro htwo + exact (mem_jointOddPrimeList.mp htwo).1 rfl + · exact hq + +/-- Proof predicate for a literal prime-floor ladder, starting at prime index +`start`. -/ +def primeFloorLadderValidFrom : ℕ → List ℕ → Prop + | _, [] => True + | start, floor :: floors => + floor.Prime ∧ floor.primeCounting' = start + 1 ∧ + primeFloorLadderValidFrom (start + 1) floors + +/-- Executable checker corresponding to `primeFloorLadderValidFrom`. -/ +def primeFloorLadderCheckFrom : ℕ → List ℕ → Bool + | _, [] => true + | start, floor :: floors => + decide floor.Prime && decide (floor.primeCounting' = start + 1) && + primeFloorLadderCheckFrom (start + 1) floors + +@[simp] theorem primeFloorLadderCheckFrom_eq_true_iff + (start : ℕ) (floors : List ℕ) : + primeFloorLadderCheckFrom start floors = true ↔ + primeFloorLadderValidFrom start floors := by + induction floors generalizing start with + | nil => simp [primeFloorLadderCheckFrom, primeFloorLadderValidFrom] + | cons floor floors ih => + simp [primeFloorLadderCheckFrom, primeFloorLadderValidFrom, ih, + and_assoc] + +private theorem primeFloorLadderValidFrom_getD + {start : ℕ} {floors : List ℕ} + (hvalid : primeFloorLadderValidFrom start floors) + {index : ℕ} (hindex : index < floors.length) : + (floors.getD index 0).Prime ∧ + (floors.getD index 0).primeCounting' = start + index + 1 := by + induction floors generalizing start index with + | nil => simp at hindex + | cons floor floors ih => + cases index with + | zero => + simpa [primeFloorLadderValidFrom] using + And.intro hvalid.1 hvalid.2.1 + | succ index => + have htail : primeFloorLadderValidFrom (start + 1) floors := by + simpa [primeFloorLadderValidFrom] using hvalid.2.2 + have hindexTail : index < floors.length := by + simpa using hindex + have hdata := ih htail hindexTail + simpa [Nat.add_assoc, Nat.add_left_comm, Nat.add_comm] using hdata + +/-- Literal data used to generate all rational prime-weight caps in a +positional search. -/ +structure RankinPositionalCapTable where + precision : ℕ + oddPrimeFloors : List ℕ + deriving DecidableEq, Repr + +namespace RankinPositionalCapTable + +def Valid (table : RankinPositionalCapTable) : Prop := + 0 < table.precision ∧ + primeFloorLadderValidFrom 0 table.oddPrimeFloors + +def check (table : RankinPositionalCapTable) : Bool := + decide (0 < table.precision) && + primeFloorLadderCheckFrom 0 table.oddPrimeFloors + +@[simp] theorem check_eq_true_iff (table : RankinPositionalCapTable) : + table.check = true ↔ table.Valid := by + simp [check, Valid] + +def twoCap (table : RankinPositionalCapTable) : RationalPrimeWeightCap := + rationalPrimeWeightCapForFloor table.precision 2 + +def oddCapAt (table : RankinPositionalCapTable) + (index : ℕ) : RationalPrimeWeightCap := + rationalPrimeWeightCapForFloor table.precision + (table.oddPrimeFloors.getD index 0) + +theorem oddFloor_data_of_valid + {table : RankinPositionalCapTable} (hvalid : table.Valid) + {index : ℕ} (hindex : index < table.oddPrimeFloors.length) : + (table.oddPrimeFloors.getD index 0).Prime ∧ + (table.oddPrimeFloors.getD index 0).primeCounting' = index + 1 := by + simpa [Nat.add_assoc, Nat.add_left_comm, Nat.add_comm] using + primeFloorLadderValidFrom_getD hvalid.2 hindex + +theorem oddCapAt_lowerPrime_eq_nthPrime + {table : RankinPositionalCapTable} (hvalid : table.Valid) + {index : ℕ} (hindex : index < table.oddPrimeFloors.length) : + (table.oddCapAt index).lowerPrime = + Nat.nth Nat.Prime (index + 1) := by + have hdata := table.oddFloor_data_of_valid hvalid hindex + change table.oddPrimeFloors.getD index 0 = + Nat.nth Nat.Prime (index + 1) + calc + table.oddPrimeFloors.getD index 0 = + Nat.nth Nat.Prime + (table.oddPrimeFloors.getD index 0).primeCounting' := by + simpa [Nat.primeCounting'] using (Nat.nth_count hdata.1).symm + _ = Nat.nth Nat.Prime (index + 1) := by rw [hdata.2] + +end RankinPositionalCapTable + +/-- A checked literal prime prefix covers every actual odd support whose +length fits in the table. -/ +theorem positionalCanonicalRankinNeighborProfile_matches_of_capTable + {p : ℕ} {table : RankinPositionalCapTable} + (hvalid : table.Valid) + (hlength : (jointOddPrimeList p).length ≤ + table.oddPrimeFloors.length) + (rootCap : ℕ) : + (positionalCanonicalRankinNeighborProfile p table.twoCap + table.oddCapAt rootCap).Matches p := by + apply canonicalRankinNeighborProfile_matches + intro prime hprime + have hindexActual : (jointOddPrimeList p).idxOf prime < + (jointOddPrimeList p).length := + List.idxOf_lt_length_of_mem hprime + have hindexTable : (jointOddPrimeList p).idxOf prime < + table.oddPrimeFloors.length := hindexActual.trans_le hlength + change (table.oddCapAt ((jointOddPrimeList p).idxOf prime)).lowerPrime ≤ prime + rw [table.oddCapAt_lowerPrime_eq_nthPrime hvalid hindexTable] + exact nthPrime_succ_idxOf_le_jointOddPrimeList p hprime + +private theorem idxOf_lt_idxOf_of_pairwise_lt + (values : List ℕ) (hpair : values.Pairwise (· < ·)) + {left right : ℕ} (hleft : left ∈ values) (hright : right ∈ values) + (hlr : left < right) : + values.idxOf left < values.idxOf right := by + have hindexNe : values.idxOf left ≠ values.idxOf right := by + intro heq + have hvalueEq : left = right := (List.idxOf_inj hleft).mp heq + exact hvalueEq.not_lt hlr + have hnotReverse : ¬values.idxOf right < values.idxOf left := by + intro hreverse + have hrel := hpair.rel_get_of_lt + (a := ⟨values.idxOf right, List.idxOf_lt_length_of_mem hright⟩) + (b := ⟨values.idxOf left, List.idxOf_lt_length_of_mem hleft⟩) + hreverse + have hrightLeft : right < left := by + simpa [List.getElem_idxOf + (List.idxOf_lt_length_of_mem hright), + List.getElem_idxOf (List.idxOf_lt_length_of_mem hleft)] using hrel + exact hlr.asymm hrightLeft + omega + +theorem jointOddPrimeList_pairwise_positionalCapFloor_lt + {p : ℕ} {table : RankinPositionalCapTable} + (hvalid : table.Valid) + (hlength : (jointOddPrimeList p).length ≤ + table.oddPrimeFloors.length) : + (jointOddPrimeList p).Pairwise fun left right => + (table.oddCapAt ((jointOddPrimeList p).idxOf left)).lowerPrime < + (table.oddCapAt ((jointOddPrimeList p).idxOf right)).lowerPrime := by + apply (jointOddPrimeList_pairwise_lt p).imp_of_mem + intro left right hleft hright hlr + have hleftIndex : (jointOddPrimeList p).idxOf left < + table.oddPrimeFloors.length := + (List.idxOf_lt_length_of_mem hleft).trans_le hlength + have hrightIndex : (jointOddPrimeList p).idxOf right < + table.oddPrimeFloors.length := + (List.idxOf_lt_length_of_mem hright).trans_le hlength + rw [table.oddCapAt_lowerPrime_eq_nthPrime hvalid hleftIndex, + table.oddCapAt_lowerPrime_eq_nthPrime hvalid hrightIndex] + apply Nat.nth_strictMono Nat.infinite_setOfPred_prime + exact Nat.add_lt_add_right + (idxOf_lt_idxOf_of_pairwise_lt (jointOddPrimeList p) + (jointOddPrimeList_pairwise_lt p) hleft hright hlr) 1 + +/-- The table also supplies every structural validity condition for the +actual positional profile. The only profile-dependent root obligation is +stated on the side-erased exponent skeleton that the finite search checks. -/ +theorem positionalCanonicalRankinNeighborProfile_valid_of_capTable + {p rootCap : ℕ} {table : RankinPositionalCapTable} + (hpPrime : p.Prime) (hpTwo : 2 < p) + (hvalid : table.Valid) + (hlength : (jointOddPrimeList p).length ≤ + table.oddPrimeFloors.length) + (hrootPos : 0 < rootCap) + (hjointRoot : + RankinNeighborProfile.JointEnvelopeValid + (positionalRankinSkeletonProfile table.twoCap table.oddCapAt + ((p - 1).factorization 2) ((p + 1).factorization 2) + (actualOddExponentSkeleton p) rootCap)) : + (positionalCanonicalRankinNeighborProfile p table.twoCap + table.oddCapAt rootCap).Valid := by + apply canonicalRankinNeighborProfile_valid_of_jointEnvelope + hpPrime hpTwo + · exact rationalPrimeWeightCapForFloor_valid hvalid.1 (by norm_num) + · rfl + · intro prime hprime + have hindexActual : (jointOddPrimeList p).idxOf prime < + (jointOddPrimeList p).length := + List.idxOf_lt_length_of_mem hprime + have hindexTable : (jointOddPrimeList p).idxOf prime < + table.oddPrimeFloors.length := hindexActual.trans_le hlength + have hdata := table.oddFloor_data_of_valid hvalid hindexTable + change (table.oddCapAt ((jointOddPrimeList p).idxOf prime)).Valid ∧ + (table.oddCapAt + ((jointOddPrimeList p).idxOf prime)).lowerPrime.Prime ∧ + 3 ≤ (table.oddCapAt + ((jointOddPrimeList p).idxOf prime)).lowerPrime + refine ⟨?_, ?_, ?_⟩ + · exact rationalPrimeWeightCapForFloor_valid hvalid.1 hdata.1.pos + · exact hdata.1 + · rw [table.oddCapAt_lowerPrime_eq_nthPrime hvalid hindexTable] + have hbound := Nat.add_two_le_nth_prime + ((jointOddPrimeList p).idxOf prime + 1) + omega + · exact jointOddPrimeList_pairwise_positionalCapFloor_lt hvalid hlength + · exact hrootPos + · apply (RankinNeighborProfile.eraseSides_jointEnvelopeValid_iff _).mp + change (positionalCanonicalRankinNeighborProfile p table.twoCap + table.oddCapAt rootCap).eraseSides.JointEnvelopeValid + rw [eraseSides_positionalCanonicalRankinNeighborProfile] + exact hjointRoot + +end BGS.NumberTheory diff --git a/LeanPool/MarkoffModP/BGS/NumberTheory/RankinPositionalProfile.lean b/LeanPool/MarkoffModP/BGS/NumberTheory/RankinPositionalProfile.lean new file mode 100644 index 0000000000..08ca0a738d --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/NumberTheory/RankinPositionalProfile.lean @@ -0,0 +1,154 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.NumberTheory.RankinCanonicalProfile +public import LeanPool.MarkoffModP.BGS.NumberTheory.RankinJointEnvelopeCoverage +public import Mathlib.Analysis.SpecialFunctions.Pow.NthRootLemmas +public import Mathlib.Algebra.Order.Floor.Div +public import Mathlib.NumberTheory.PrimeCounting +public import Mathlib.Data.List.Indexes + +/-! +# Positional Rankin profiles + +The globally sorted odd support has a canonical position. We attach the +`i`-th generated cap to the `i`-th support prime, rather than selecting a cap +from the prime value. After side erasure the resulting profile is determined +only by the two-adic exponents and the list of odd exponents. + +Caps are generated by integer arithmetic. For a denominator `D` and prime +floor `q`, the numerator is one more than the integral twelfth root of +`ceil(D^12 / q)`. The extra one makes the required twelfth-power inequality +immediate and keeps the checker independent of floating-point arithmetic. +-/ + +@[expose] public section + +namespace BGS.NumberTheory + +/-- Executable numerator for a rational upper approximation to +`floor ^ (-1/12)`. -/ +def rankinCapNumerator (precision floor : ℕ) : ℕ := + Nat.nthRoot 12 + (precision ^ 12 ⌈/⌉ floor) + 1 + +def rationalPrimeWeightCapForFloor + (precision floor : ℕ) : RationalPrimeWeightCap where + lowerPrime := floor + numerator := rankinCapNumerator precision floor + denominator := precision + +theorem rationalPrimeWeightCapForFloor_valid + {precision floor : ℕ} (hprecision : 0 < precision) + (hfloor : 0 < floor) : + (rationalPrimeWeightCapForFloor precision floor).Valid := by + refine ⟨hfloor, ?_, hprecision, ?_⟩ + · simp [rationalPrimeWeightCapForFloor, rankinCapNumerator] + · have hceil : + precision ^ 12 ≤ floor * (precision ^ 12 ⌈/⌉ floor) := by + simpa [nsmul_eq_mul] using + (le_smul_ceilDiv (α := ℕ) (β := ℕ) + hfloor : + precision ^ 12 ≤ floor • (precision ^ 12 ⌈/⌉ floor)) + have hroot : + (precision ^ 12 ⌈/⌉ floor) ≤ + rankinCapNumerator precision floor ^ 12 := by + exact (Nat.lt_pow_nthRoot_add_one (by norm_num : 12 ≠ 0) + (precision ^ 12 ⌈/⌉ floor)).le + exact hceil.trans (Nat.mul_le_mul_left _ hroot) + +/-- The odd factor in position `index`, with side already erased. -/ +def positionalRankinOddFactor + (oddCapAt : ℕ → RationalPrimeWeightCap) + (index exponent : ℕ) : RankinOddFactor where + side := .minus + exponent := exponent + weightCap := oddCapAt index + +/-- The finite-search representative determined by an exponent skeleton. -/ +def positionalRankinSkeletonProfile + (twoCap : RationalPrimeWeightCap) + (oddCapAt : ℕ → RationalPrimeWeightCap) + (minusTwoExponent plusTwoExponent : ℕ) + (oddExponents : List ℕ) (rootCap : ℕ) : RankinNeighborProfile where + minusTwoExponent := minusTwoExponent + plusTwoExponent := plusTwoExponent + twoWeightCap := twoCap + oddFactors := oddExponents.mapIdx + (fun index exponent => + positionalRankinOddFactor oddCapAt index exponent) + rootCap := rootCap + +/-- Position-dependent cap assignment on the actual sorted support. -/ +def positionalOddCap + (p : ℕ) (oddCapAt : ℕ → RationalPrimeWeightCap) + (prime : ℕ) : RationalPrimeWeightCap := + oddCapAt ((jointOddPrimeList p).idxOf prime) + +/-- Canonical actual profile using the same cap ladder as the skeleton +representatives. -/ +def positionalCanonicalRankinNeighborProfile + (p : ℕ) (twoCap : RationalPrimeWeightCap) + (oddCapAt : ℕ → RationalPrimeWeightCap) + (rootCap : ℕ) : RankinNeighborProfile := + canonicalRankinNeighborProfile p + twoCap (positionalOddCap p oddCapAt) rootCap + +/-- The odd exponent skeleton of the actual neighboring factorization. -/ +def actualOddExponentSkeleton (p : ℕ) : List ℕ := + (jointOddPrimeList p).map (actualNeighborExponent p) + +private theorem mapIdx_eq_map_idxOf + {α β : Type*} [BEq α] [LawfulBEq α] + (values : List α) (hnodup : values.Nodup) + (f : ℕ → α → β) : + values.mapIdx f = + values.map (fun value => f (values.idxOf value) value) := by + rw [List.mapIdx_eq_ofFn] + apply List.ext_getElem + · simp + · intro index hleft hright + simp only [List.getElem_ofFn, List.getElem_map] + congr 1 + simpa using + (List.get_idxOf hnodup ⟨index, by simpa using hleft⟩).symm + +private theorem mapIdx_map + {α β γ : Type*} (values : List α) (g : α → β) + (f : ℕ → β → γ) : + (values.map g).mapIdx f = + values.mapIdx (fun index value => f index (g value)) := by + rw [List.mapIdx_eq_ofFn, List.mapIdx_eq_ofFn] + apply List.ext_getElem + · simp + · intro index hleft hright + simp only [List.getElem_ofFn] + rw [List.get_eq_getElem, List.getElem_map, List.get_eq_getElem] + +/-- Side erasure turns the positional canonical profile into exactly the +finite-search exponent skeleton. -/ +theorem eraseSides_positionalCanonicalRankinNeighborProfile + (p : ℕ) (twoCap : RationalPrimeWeightCap) + (oddCapAt : ℕ → RationalPrimeWeightCap) (rootCap : ℕ) : + (positionalCanonicalRankinNeighborProfile + p twoCap oddCapAt rootCap).eraseSides = + positionalRankinSkeletonProfile twoCap oddCapAt + ((p - 1).factorization 2) ((p + 1).factorization 2) + (actualOddExponentSkeleton p) rootCap := by + simp only [positionalCanonicalRankinNeighborProfile, + canonicalRankinNeighborProfile, RankinNeighborProfile.eraseSides, + positionalRankinSkeletonProfile] + congr 1 + rw [actualOddExponentSkeleton, List.map_map] + rw [mapIdx_map] + rw [mapIdx_eq_map_idxOf (jointOddPrimeList p) + (Finset.sort_nodup (jointOddPrimeSupport p) (· ≤ ·))] + simp [positionalRankinOddFactor, canonicalRankinOddFactor, + RankinNeighborProfile.eraseOddFactorSide, positionalOddCap] + +end BGS.NumberTheory diff --git a/LeanPool/MarkoffModP/BGS/NumberTheory/RankinPositionalSupportBound.lean b/LeanPool/MarkoffModP/BGS/NumberTheory/RankinPositionalSupportBound.lean new file mode 100644 index 0000000000..45cfb1044c --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/NumberTheory/RankinPositionalSupportBound.lean @@ -0,0 +1,159 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.NumberTheory.RankinPositionalCoverage +public import Mathlib.Algebra.Order.BigOperators.Group.List + +/-! +# Product bounds for finite positional prime ladders + +The product of the globally sorted odd support divides, up to harmless +overlap, `(p - 1) * (p + 1)`. A checked literal prefix of the odd primes is +pointwise no larger than any support of the same length. Combining these two +facts turns one exact primorial comparison into a uniform bound on the number +of exponent slots below a power cutoff. +-/ + +@[expose] public section + +open scoped BigOperators + +namespace BGS.NumberTheory + +theorem jointOddPrimeList_prod_le_neighbors_mul + {p : ℕ} (hp : 1 < p) : + (jointOddPrimeList p).prod ≤ (p - 1) * (p + 1) := by + let minusSupport := (p - 1).primeFactors + let plusSupport := (p + 1).primeFactors + have hminusProd : (∏ q ∈ minusSupport, q) ∣ p - 1 := by + simpa [minusSupport] using Nat.prod_primeFactors_dvd (p - 1) + have hplusProd : (∏ q ∈ plusSupport, q) ∣ p + 1 := by + simpa [plusSupport] using Nat.prod_primeFactors_dvd (p + 1) + have hunionProd : + (∏ q ∈ minusSupport ∪ plusSupport, q) ∣ + (∏ q ∈ minusSupport, q) * (∏ q ∈ plusSupport, q) := by + refine ⟨∏ q ∈ minusSupport ∩ plusSupport, q, ?_⟩ + simpa [mul_comm] using + (Finset.prod_union_inter (s₁ := minusSupport) (s₂ := plusSupport) + (f := fun q : ℕ => q)).symm + have heraseProd : + (∏ q ∈ (minusSupport ∪ plusSupport).erase 2, q) ∣ + ∏ q ∈ minusSupport ∪ plusSupport, q := by + apply Finset.prod_dvd_prod_of_subset + exact Finset.erase_subset 2 (minusSupport ∪ plusSupport) + have hdiv : + (∏ q ∈ (minusSupport ∪ plusSupport).erase 2, q) ∣ + (p - 1) * (p + 1) := + heraseProd.trans (hunionProd.trans (Nat.mul_dvd_mul hminusProd hplusProd)) + have hminusPositive : 0 < p - 1 := by omega + have hplusPositive : 0 < p + 1 := by omega + have hpositive : 0 < (p - 1) * (p + 1) := + Nat.mul_pos hminusPositive hplusPositive + have hle := Nat.le_of_dvd hpositive hdiv + change ((jointOddPrimeSupport p).sort (· ≤ ·)).prod ≤ + (p - 1) * (p + 1) + rw [show ((jointOddPrimeSupport p).sort (· ≤ ·)).prod = + ∏ q ∈ jointOddPrimeSupport p, q by + calc + ((jointOddPrimeSupport p).sort (· ≤ ·)).prod = + (jointOddPrimeSupport p).toList.prod := + (Finset.sort_perm_toList (jointOddPrimeSupport p) (· ≤ ·)).prod_eq + _ = ∏ q ∈ jointOddPrimeSupport p, q := + Finset.prod_toList (jointOddPrimeSupport p)] + simpa [jointOddPrimeSupport, minusSupport, plusSupport] using hle + +theorem capTable_oddPrimeFloors_prod_le_jointOddPrimeList_prod + {p : ℕ} {table : RankinPositionalCapTable} + (hvalid : table.Valid) + (hlength : table.oddPrimeFloors.length ≤ + (jointOddPrimeList p).length) : + table.oddPrimeFloors.prod ≤ (jointOddPrimeList p).prod := by + let actual := jointOddPrimeList p + have hactualNodup : actual.Nodup := + Finset.sort_nodup (jointOddPrimeSupport p) (· ≤ ·) + have hpointwise : List.Forall₂ (· ≤ ·) table.oddPrimeFloors + (actual.take table.oddPrimeFloors.length) := by + rw [List.forall₂_iff_get] + constructor + · simp [actual, List.length_take, Nat.min_eq_left hlength] + · intro index hfloorIndex htakeIndex + have hactualIndex : index < actual.length := + hfloorIndex.trans_le hlength + have hcapEq := table.oddCapAt_lowerPrime_eq_nthPrime + hvalid hfloorIndex + change table.oddPrimeFloors.getD index 0 = + Nat.nth Nat.Prime (index + 1) at hcapEq + rw [List.getD_eq_getElem table.oddPrimeFloors 0 hfloorIndex] at hcapEq + have hmember : actual.get ⟨index, hactualIndex⟩ ∈ actual := + List.get_mem actual ⟨index, hactualIndex⟩ + have hbound := nthPrime_succ_idxOf_le_jointOddPrimeList p hmember + have hindexEq : + actual.idxOf (actual.get ⟨index, hactualIndex⟩) = index := by + simpa using List.get_idxOf hactualNodup ⟨index, hactualIndex⟩ + rw [hindexEq] at hbound + have htakeEq : + (actual.take table.oddPrimeFloors.length).get + ⟨index, htakeIndex⟩ = + actual.get ⟨index, hactualIndex⟩ := by + rw [List.get_eq_getElem, List.get_eq_getElem] + exact (List.getElem_take' hactualIndex hfloorIndex).symm + rw [htakeEq] + exact hcapEq.le.trans hbound + have hprefix := hpointwise.prod_le_prod + have htakeSublist : List.Sublist + (actual.take table.oddPrimeFloors.length) actual := + List.take_sublist _ _ + have hactualOne : ∀ prime ∈ actual, 1 ≤ prime := by + intro prime hprime + rcases (mem_jointOddPrimeList.mp hprime).2 with hminus | hplus + · exact (Nat.prime_of_mem_primeFactors hminus).one_le + · exact (Nat.prime_of_mem_primeFactors hplus).one_le + exact hprefix.trans (htakeSublist.prod_le_prod hactualOne) + +theorem jointOddPrimeList_length_lt_of_capTable_prod_gt + {p : ℕ} {table : RankinPositionalCapTable} + (hp : 1 < p) (hvalid : table.Valid) + (hproduct : (p - 1) * (p + 1) < table.oddPrimeFloors.prod) : + (jointOddPrimeList p).length < table.oddPrimeFloors.length := by + by_contra hnot + have hlength : table.oddPrimeFloors.length ≤ + (jointOddPrimeList p).length := by omega + have htableSupport := + capTable_oddPrimeFloors_prod_le_jointOddPrimeList_prod hvalid hlength + have hsupportNeighbors := jointOddPrimeList_prod_le_neighbors_mul hp + exact (not_lt_of_ge (htableSupport.trans hsupportNeighbors)) hproduct + +theorem neighbors_mul_lt_two_pow_two_mul + {p exponent : ℕ} (hpOne : 1 < p) (hp : p < 2 ^ exponent) : + (p - 1) * (p + 1) < 2 ^ (2 * exponent) := by + have hminus : p - 1 < 2 ^ exponent := + (Nat.sub_le p 1).trans_lt hp + have hplus : p + 1 ≤ 2 ^ exponent := by omega + have hplusPos : 0 < p + 1 := by omega + have hneighbors : (p - 1) * (p + 1) < + (2 ^ exponent) * (2 ^ exponent) := + (Nat.mul_lt_mul_of_pos_right hminus hplusPos).trans_le + (Nat.mul_le_mul_left (2 ^ exponent) hplus) + have hpower : (2 ^ exponent) * (2 ^ exponent) = + 2 ^ (2 * exponent) := by + rw [← pow_add] + congr 1 + omega + rwa [hpower] at hneighbors + +theorem jointOddPrimeList_length_lt_of_lt_pow_of_capTable + {p exponent : ℕ} {table : RankinPositionalCapTable} + (hpOne : 1 < p) (hp : p < 2 ^ exponent) + (hvalid : table.Valid) + (hproduct : 2 ^ (2 * exponent) < table.oddPrimeFloors.prod) : + (jointOddPrimeList p).length < table.oddPrimeFloors.length := by + have hneighbors := neighbors_mul_lt_two_pow_two_mul hpOne hp + apply jointOddPrimeList_length_lt_of_capTable_prod_gt hpOne hvalid + exact hneighbors.trans hproduct + +end BGS.NumberTheory diff --git a/LeanPool/MarkoffModP/BGS/NumberTheory/RankinProfileCertificate.lean b/LeanPool/MarkoffModP/BGS/NumberTheory/RankinProfileCertificate.lean new file mode 100644 index 0000000000..4693f954c5 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/NumberTheory/RankinProfileCertificate.lean @@ -0,0 +1,306 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.NumberTheory.TruncatedOrderTotientRankinFactorization + +/-! +# Certificates for neighboring Rankin profiles + +Define rational weight caps and finite profile checks, and connect the Boolean checks with their +mathematical validity predicates. +-/ + +@[expose] public section + +namespace BGS.NumberTheory + +structure RationalPrimeWeightCap where + lowerPrime : ℕ + numerator : ℕ + denominator : ℕ + deriving DecidableEq, Repr + +namespace RationalPrimeWeightCap + +def weight (cap : RationalPrimeWeightCap) : ℚ := + cap.numerator / cap.denominator + +def Valid (cap : RationalPrimeWeightCap) : Prop := + 0 < cap.lowerPrime ∧ + 0 < cap.numerator ∧ + 0 < cap.denominator ∧ + cap.denominator ^ 12 ≤ cap.lowerPrime * cap.numerator ^ 12 + +def check (cap : RationalPrimeWeightCap) : Bool := + decide (0 < cap.lowerPrime) && + decide (0 < cap.numerator) && + decide (0 < cap.denominator) && + decide (cap.denominator ^ 12 ≤ + cap.lowerPrime * cap.numerator ^ 12) + +@[simp] theorem check_eq_true_iff (cap : RationalPrimeWeightCap) : + cap.check = true ↔ cap.Valid := by + simp [check, Valid, and_assoc] + +theorem weight_nonneg (cap : RationalPrimeWeightCap) : + 0 ≤ cap.weight := by + exact div_nonneg (by positivity) (by positivity) + +theorem one_le_prime_mul_weight_pow_twelve + (cap : RationalPrimeWeightCap) (hcap : cap.Valid) + {prime : ℕ} (hfloor : cap.lowerPrime ≤ prime) : + 1 ≤ (prime : ℚ) * cap.weight ^ 12 := by + have hnat : + cap.denominator ^ 12 ≤ prime * cap.numerator ^ 12 := by + exact hcap.2.2.2.trans (Nat.mul_le_mul_right _ hfloor) + have hdenPos : (0 : ℚ) < cap.denominator ^ 12 := by + have : (0 : ℚ) < cap.denominator := by + exact_mod_cast hcap.2.2.1 + positivity + rw [weight, div_pow] + rw [← mul_div_assoc] + apply (le_div_iff₀ hdenPos).2 + rw [one_mul] + exact_mod_cast hnat + +end RationalPrimeWeightCap + +/-- Which neighboring group order, `p - 1` or `p + 1`, contains an odd +prime-power factor. -/ +inductive NeighborSide where + | minus + | plus + deriving DecidableEq, Repr + +/-- One globally ordered odd-prime slot in a joint factorization profile. -/ +structure RankinOddFactor where + side : NeighborSide + exponent : ℕ + weightCap : RationalPrimeWeightCap + deriving DecidableEq, Repr + +namespace RankinOddFactor + +def Valid (factor : RankinOddFactor) : Prop := + 0 < factor.exponent ∧ + factor.weightCap.Valid ∧ + factor.weightCap.lowerPrime.Prime ∧ + 3 ≤ factor.weightCap.lowerPrime + +def check (factor : RankinOddFactor) : Bool := + decide (0 < factor.exponent) && + factor.weightCap.check && + decide factor.weightCap.lowerPrime.Prime && + decide (3 ≤ factor.weightCap.lowerPrime) + +@[simp] theorem check_eq_true_iff (factor : RankinOddFactor) : + factor.check = true ↔ factor.Valid := by + simp [check, Valid, and_assoc] + +end RankinOddFactor + +def allRankinOddFactorsValid : List RankinOddFactor → Prop + | [] => True + | factor :: factors => + factor.Valid ∧ allRankinOddFactorsValid factors + +def allRankinOddFactorsCheck : List RankinOddFactor → Bool + | [] => true + | factor :: factors => + factor.check && allRankinOddFactorsCheck factors + +@[simp] theorem allRankinOddFactorsCheck_eq_true_iff + (factors : List RankinOddFactor) : + allRankinOddFactorsCheck factors = true ↔ + allRankinOddFactorsValid factors := by + induction factors with + | nil => simp [allRankinOddFactorsCheck, allRankinOddFactorsValid] + | cons factor factors ih => + simp [allRankinOddFactorsCheck, allRankinOddFactorsValid, ih] + +def rankinOddFloorsStrictlyIncreasing + (factors : List RankinOddFactor) : Prop := + factors.Pairwise fun left right => + left.weightCap.lowerPrime < right.weightCap.lowerPrime + +def rankinOddFloorsStrictlyIncreasingCheck : + List RankinOddFactor → Bool + | [] => true + | factor :: factors => + factors.all (fun later => + decide (factor.weightCap.lowerPrime < + later.weightCap.lowerPrime)) && + rankinOddFloorsStrictlyIncreasingCheck factors + +@[simp] theorem rankinOddFloorsStrictlyIncreasingCheck_eq_true_iff + (factors : List RankinOddFactor) : + rankinOddFloorsStrictlyIncreasingCheck factors = true ↔ + rankinOddFloorsStrictlyIncreasing factors := by + induction factors with + | nil => + simp [rankinOddFloorsStrictlyIncreasingCheck, + rankinOddFloorsStrictlyIncreasing] + | cons factor factors ih => + simp [rankinOddFloorsStrictlyIncreasingCheck, + rankinOddFloorsStrictlyIncreasing, ih] + +/-- The two-adic data and globally sorted odd support of a possible pair +`p - 1`, `p + 1`. -/ +structure RankinNeighborProfile where + minusTwoExponent : ℕ + plusTwoExponent : ℕ + twoWeightCap : RationalPrimeWeightCap + oddFactors : List RankinOddFactor + rootCap : ℕ + deriving DecidableEq, Repr + +namespace RankinNeighborProfile + +def twoExponent + (profile : RankinNeighborProfile) : NeighborSide → ℕ + | .minus => profile.minusTwoExponent + | .plus => profile.plusTwoExponent + +def oddDivisorCount : NeighborSide → List RankinOddFactor → ℕ + | _, [] => 1 + | side, factor :: factors => + (if factor.side = side then factor.exponent + 1 else 1) * + oddDivisorCount side factors + +def divisorCount + (profile : RankinNeighborProfile) (side : NeighborSide) : ℕ := + (profile.twoExponent side + 1) * + oddDivisorCount side profile.oddFactors + +def jointDivisorCount (profile : RankinNeighborProfile) : ℕ := + profile.divisorCount .minus + profile.divisorCount .plus + +def oddCoarseEulerProduct : + NeighborSide → List RankinOddFactor → ℚ + | _, [] => 1 + | side, factor :: factors => + (if factor.side = side then + coarseRankinPrimePowerFactor factor.exponent + factor.weightCap.weight + else 1) * + oddCoarseEulerProduct side factors + +def coarseEulerProduct + (profile : RankinNeighborProfile) (side : NeighborSide) : ℚ := + coarseRankinPrimePowerFactor (profile.twoExponent side) + profile.twoWeightCap.weight * + oddCoarseEulerProduct side profile.oddFactors + +def jointCoarseEulerProduct (profile : RankinNeighborProfile) : ℚ := + profile.coarseEulerProduct .minus + + profile.coarseEulerProduct .plus + +/-- Product lower bound contributed by the odd factors assigned to one side. -/ +def oddLowerNeighborProduct : + NeighborSide → List RankinOddFactor → ℕ + | _, [] => 1 + | side, factor :: factors => + (if factor.side = side then + factor.weightCap.lowerPrime ^ factor.exponent + else 1) * + oddLowerNeighborProduct side factors + +/-- Factorization lower bound for `p - 1` or `p + 1` represented by a +profile. Unlike the failure square, this grows exponentially in large exact +exponents and will support sound branch exclusion. -/ +def lowerNeighborProduct + (profile : RankinNeighborProfile) (side : NeighborSide) : ℕ := + 2 ^ profile.twoExponent side * + oddLowerNeighborProduct side profile.oddFactors + +def witnessCap (profile : RankinNeighborProfile) : ℕ := + 189 * profile.jointDivisorCount ^ 3 + +/-- Structural and arithmetic validity of one complete profile payload. -/ +def Valid (profile : RankinNeighborProfile) : Prop := + ((profile.minusTwoExponent = 1 ∧ + 2 ≤ profile.plusTwoExponent) ∨ + (profile.plusTwoExponent = 1 ∧ + 2 ≤ profile.minusTwoExponent)) ∧ + profile.twoWeightCap.Valid ∧ + profile.twoWeightCap.lowerPrime = 2 ∧ + allRankinOddFactorsValid profile.oddFactors ∧ + rankinOddFloorsStrictlyIncreasing profile.oddFactors ∧ + 0 < profile.rootCap ∧ + profile.witnessCap ≤ profile.rootCap ^ 12 + +/-- A profile closes a proposed cutoff when its rational failure square lies +strictly below `8 * (cutoff + 1)`. -/ +def failureSquare (profile : RankinNeighborProfile) : ℚ := + ((profile.witnessCap : ℚ) * profile.rootCap * + profile.jointCoarseEulerProduct) ^ 2 + +def ClosesCutoff + (profile : RankinNeighborProfile) (cutoff : ℕ) : Prop := + profile.failureSquare < (8 * (cutoff + 1) : ℕ) + +/-- A profile excludes the failure obstruction when one represented +neighboring product already forces `p` above the profile failure square. -/ +def ExcludesFailure (profile : RankinNeighborProfile) : Prop := + profile.failureSquare < + (8 * (profile.lowerNeighborProduct .minus + 1) : ℕ) ∨ + profile.failureSquare < + (8 * (profile.lowerNeighborProduct .plus - 1) : ℕ) ∨ + profile.failureSquare ^ 2 < + (64 * (profile.lowerNeighborProduct .minus * + profile.lowerNeighborProduct .plus) : ℕ) + +def check (profile : RankinNeighborProfile) : Bool := + (decide + ((profile.minusTwoExponent = 1 ∧ + 2 ≤ profile.plusTwoExponent) ∨ + (profile.plusTwoExponent = 1 ∧ + 2 ≤ profile.minusTwoExponent))) && + profile.twoWeightCap.check && + decide (profile.twoWeightCap.lowerPrime = 2) && + allRankinOddFactorsCheck profile.oddFactors && + rankinOddFloorsStrictlyIncreasingCheck profile.oddFactors && + decide (0 < profile.rootCap) && + decide (profile.witnessCap ≤ profile.rootCap ^ 12) + +def closesCutoffCheck + (profile : RankinNeighborProfile) (cutoff : ℕ) : Bool := + decide + ((((profile.witnessCap : ℚ) * profile.rootCap * + profile.jointCoarseEulerProduct) ^ 2) < + ((8 * (cutoff + 1) : ℕ) : ℚ)) + +def excludesFailureCheck (profile : RankinNeighborProfile) : Bool := + decide + (profile.failureSquare < + ((8 * (profile.lowerNeighborProduct .minus + 1) : ℕ) : ℚ) ∨ + profile.failureSquare < + ((8 * (profile.lowerNeighborProduct .plus - 1) : ℕ) : ℚ) ∨ + profile.failureSquare ^ 2 < + ((64 * (profile.lowerNeighborProduct .minus * + profile.lowerNeighborProduct .plus) : ℕ) : ℚ)) + +@[simp] theorem check_eq_true_iff (profile : RankinNeighborProfile) : + profile.check = true ↔ profile.Valid := by + simp [check, Valid, and_assoc] + +@[simp] theorem closesCutoffCheck_eq_true_iff + (profile : RankinNeighborProfile) (cutoff : ℕ) : + profile.closesCutoffCheck cutoff = true ↔ + profile.ClosesCutoff cutoff := by + simp [closesCutoffCheck, ClosesCutoff, failureSquare] + +@[simp] theorem excludesFailureCheck_eq_true_iff + (profile : RankinNeighborProfile) : + profile.excludesFailureCheck = true ↔ + profile.ExcludesFailure := by + simp [excludesFailureCheck, ExcludesFailure] + +end RankinNeighborProfile + +end BGS.NumberTheory diff --git a/LeanPool/MarkoffModP/BGS/NumberTheory/RankinProfileMatching.lean b/LeanPool/MarkoffModP/BGS/NumberTheory/RankinProfileMatching.lean new file mode 100644 index 0000000000..44b14e80ee --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/NumberTheory/RankinProfileMatching.lean @@ -0,0 +1,777 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.NumberTheory.RankinProfileCertificate +public import Mathlib.NumberTheory.ArithmeticFunction.Misc + +/-! +# Matching an actual neighboring factorization to a Rankin profile + +This file is the semantic layer between an executable profile payload and the +actual prime factorizations of `p - 1` and `p + 1`. Odd primes are placed in +one globally increasing support list. A matching assignment records, at each +actual prime, its side, exact exponent, and a rational weight cap whose lower +prime is no larger than the actual prime. +-/ + +@[expose] public section + +namespace BGS.NumberTheory + +open scoped BigOperators + +/-- The odd prime support appearing in either neighboring integer. -/ +def jointOddPrimeSupport (p : ℕ) : Finset ℕ := + ((p - 1).primeFactors ∪ (p + 1).primeFactors).erase 2 + +/-- The canonical globally increasing list of odd neighboring prime factors. -/ +def jointOddPrimeList (p : ℕ) : List ℕ := + (jointOddPrimeSupport p).sort (· ≤ ·) + +@[simp] theorem mem_jointOddPrimeList {p prime : ℕ} : + prime ∈ jointOddPrimeList p ↔ + prime ≠ 2 ∧ + (prime ∈ (p - 1).primeFactors ∨ + prime ∈ (p + 1).primeFactors) := by + simp [jointOddPrimeList, jointOddPrimeSupport, and_or_left] + +/-- The neighboring side selected by an actual odd prime. -/ +def actualNeighborSide (p prime : ℕ) : NeighborSide := + if prime ∈ (p - 1).primeFactors then .minus else .plus + +/-- The exact exponent on the side selected by `actualNeighborSide`. -/ +def actualNeighborExponent (p prime : ℕ) : ℕ := + if prime ∈ (p - 1).primeFactors then + (p - 1).factorization prime + else + (p + 1).factorization prime + +namespace RankinOddFactor + +/-- One profile factor matches one actual odd neighboring prime. -/ +def Matches (factor : RankinOddFactor) (p prime : ℕ) : Prop := + factor.side = actualNeighborSide p prime ∧ + factor.exponent = actualNeighborExponent p prime ∧ + factor.weightCap.lowerPrime ≤ prime + +end RankinOddFactor + +namespace RankinNeighborProfile + +/-- A profile matches the complete actual factorization pair. The total +assignment function is harmless away from the canonical support; its map on +that support is exactly the supplied odd-factor list. -/ +def Matches (profile : RankinNeighborProfile) (p : ℕ) : Prop := + profile.minusTwoExponent = (p - 1).factorization 2 ∧ + profile.plusTwoExponent = (p + 1).factorization 2 ∧ + ∃ assignment : ℕ → RankinOddFactor, + profile.oddFactors = (jointOddPrimeList p).map assignment ∧ + ∀ prime ∈ jointOddPrimeList p, + (assignment prime).Matches p prime + +end RankinNeighborProfile + +private theorem rankinOddFactor_valid_of_allValid_of_mem + {factor : RankinOddFactor} {factors : List RankinOddFactor} + (hall : allRankinOddFactorsValid factors) + (hmem : factor ∈ factors) : + factor.Valid := by + induction factors with + | nil => simp at hmem + | cons head tail ih => + simp only [allRankinOddFactorsValid] at hall + simp only [List.mem_cons] at hmem + rcases hmem with rfl | hmem + · exact hall.1 + · exact ih hall.2 hmem + +/-- A matching assignment turns profile weight caps into a total rational +prime-weight function. Primes outside the neighboring supports get weight +one. -/ +def assignedPrimeWeight + (p : ℕ) (profile : RankinNeighborProfile) + (assignment : ℕ → RankinOddFactor) (prime : ℕ) : ℚ := + if prime = 2 then profile.twoWeightCap.weight + else if prime ∈ jointOddPrimeSupport p then + (assignment prime).weightCap.weight + else 1 + +theorem assignedPrimeWeight_nonneg + {p : ℕ} {profile : RankinNeighborProfile} + (hprofile : profile.Valid) + {assignment : ℕ → RankinOddFactor} + (hlist : + profile.oddFactors = (jointOddPrimeList p).map assignment) + (prime : ℕ) : + 0 ≤ assignedPrimeWeight p profile assignment prime := by + by_cases htwo : prime = 2 + · simp [assignedPrimeWeight, htwo, + RationalPrimeWeightCap.weight_nonneg] + by_cases hsupport : prime ∈ jointOddPrimeSupport p + · have hprimeList : prime ∈ jointOddPrimeList p := by + simpa [jointOddPrimeList] using hsupport + have hfactorMem : assignment prime ∈ profile.oddFactors := by + rw [hlist] + exact List.mem_map_of_mem hprimeList + have hfactorValid : (assignment prime).Valid := + rankinOddFactor_valid_of_allValid_of_mem hprofile.2.2.2.1 hfactorMem + simp [assignedPrimeWeight, htwo, hsupport, + RationalPrimeWeightCap.weight_nonneg] + · simp [assignedPrimeWeight, htwo, hsupport] + +theorem assignedPrimeWeight_power + {p : ℕ} {profile : RankinNeighborProfile} + (hprofile : profile.Valid) + {assignment : ℕ → RankinOddFactor} + (hlist : + profile.oddFactors = (jointOddPrimeList p).map assignment) + (hmatch : + ∀ prime ∈ jointOddPrimeList p, + (assignment prime).Matches p prime) + (prime : ℕ) (hprime : prime.Prime) : + 1 ≤ (prime : ℚ) * + (assignedPrimeWeight p profile assignment prime) ^ 12 := by + by_cases htwo : prime = 2 + · subst prime + simp only [assignedPrimeWeight, ite_eq_left] + apply profile.twoWeightCap.one_le_prime_mul_weight_pow_twelve + hprofile.2.1 + rw [hprofile.2.2.1] + by_cases hsupport : prime ∈ jointOddPrimeSupport p + · have hprimeList : prime ∈ jointOddPrimeList p := by + simpa [jointOddPrimeList] using hsupport + have hfactorMem : assignment prime ∈ profile.oddFactors := by + rw [hlist] + exact List.mem_map_of_mem hprimeList + have hfactorValid : (assignment prime).Valid := + rankinOddFactor_valid_of_allValid_of_mem hprofile.2.2.2.1 hfactorMem + have hfloor : + (assignment prime).weightCap.lowerPrime ≤ prime := + (hmatch prime hprimeList).2.2 + simpa [assignedPrimeWeight, htwo, hsupport] using + (assignment prime).weightCap.one_le_prime_mul_weight_pow_twelve + hfactorValid.2.1 hfloor + · simp [assignedPrimeWeight, htwo, hsupport] + exact_mod_cast hprime.one_le + +private theorem jointOddPrimeList_map_prod + {M : Type*} [CommMonoid M] + (p : ℕ) (f : ℕ → M) : + ((jointOddPrimeList p).map f).prod = + ∏ prime ∈ jointOddPrimeSupport p, f prime := by + exact + (((jointOddPrimeSupport p).sort_perm_toList (· ≤ ·)).map f).prod_eq.trans + ((jointOddPrimeSupport p).prod_map_toList f) + +private theorem oddDivisorCount_map_assignment + (p : ℕ) (side : NeighborSide) + (primes : List ℕ) (assignment : ℕ → RankinOddFactor) + (hmatch : + ∀ prime ∈ primes, (assignment prime).Matches p prime) : + RankinNeighborProfile.oddDivisorCount side + (primes.map assignment) = + (primes.map fun prime => + if actualNeighborSide p prime = side then + actualNeighborExponent p prime + 1 + else 1).prod := by + induction primes with + | nil => simp [RankinNeighborProfile.oddDivisorCount] + | cons prime primes ih => + have hhead := hmatch prime (by simp) + have htail : + ∀ q ∈ primes, (assignment q).Matches p q := by + intro q hq + exact hmatch q (by simp [hq]) + simp only [List.map_cons, RankinNeighborProfile.oddDivisorCount, + List.prod_cons] + rw [ih htail] + simp [RankinOddFactor.Matches] at hhead + rw [hhead.1, hhead.2.1] + +private theorem odd_prime_not_mem_both_neighbors + {p prime : ℕ} (hp : 1 < p) (hodd : prime ≠ 2) + (hminus : prime ∈ (p - 1).primeFactors) + (hplus : prime ∈ (p + 1).primeFactors) : False := by + have hdivMinus : prime ∣ p - 1 := + Nat.dvd_of_mem_primeFactors hminus + have hdivPlus : prime ∣ p + 1 := + Nat.dvd_of_mem_primeFactors hplus + have hdivTwo : prime ∣ 2 := by + have hdiv := Nat.dvd_sub hdivPlus hdivMinus + have hsub : p + 1 - (p - 1) = 2 := by omega + simpa [hsub] using hdiv + rcases (Nat.dvd_prime Nat.prime_two).mp hdivTwo with hone | htwo + · exact (Nat.prime_of_mem_primeFactors hminus).ne_one hone + · exact hodd htwo + +private theorem jointOddPrimeList_factor_product_minus + (p : ℕ) : + ((jointOddPrimeList p).map fun prime => + if actualNeighborSide p prime = .minus then + actualNeighborExponent p prime + 1 + else 1).prod = + ∏ prime ∈ (p - 1).primeFactors.erase 2, + ((p - 1).factorization prime + 1) := by + rw [jointOddPrimeList_map_prod] + symm + calc + (∏ prime ∈ (p - 1).primeFactors.erase 2, + ((p - 1).factorization prime + 1)) = + ∏ prime ∈ (p - 1).primeFactors.erase 2, + (if actualNeighborSide p prime = .minus then + actualNeighborExponent p prime + 1 + else 1) := by + apply Finset.prod_congr rfl + intro prime hprime + have hminus : prime ∈ (p - 1).primeFactors := + Finset.mem_of_mem_erase hprime + simp [actualNeighborSide, actualNeighborExponent, hminus] + _ = ∏ prime ∈ jointOddPrimeSupport p, + (if actualNeighborSide p prime = .minus then + actualNeighborExponent p prime + 1 + else 1) := by + apply Finset.prod_subset + · intro prime hprime + simp only [jointOddPrimeSupport, Finset.mem_erase, + Finset.mem_union] + exact ⟨(Finset.mem_erase.mp hprime).1, + Or.inl (Finset.mem_of_mem_erase hprime)⟩ + · intro prime hsupport hnot + have hodd : prime ≠ 2 := by + exact (Finset.mem_erase.mp hsupport).1 + have hnotMinus : prime ∉ (p - 1).primeFactors := by + intro hminus + exact hnot (Finset.mem_erase.mpr ⟨hodd, hminus⟩) + simp [actualNeighborSide, hnotMinus] + +private theorem jointOddPrimeList_factor_product_plus + (p : ℕ) (hp : 1 < p) : + ((jointOddPrimeList p).map fun prime => + if actualNeighborSide p prime = .plus then + actualNeighborExponent p prime + 1 + else 1).prod = + ∏ prime ∈ (p + 1).primeFactors.erase 2, + ((p + 1).factorization prime + 1) := by + rw [jointOddPrimeList_map_prod] + symm + calc + (∏ prime ∈ (p + 1).primeFactors.erase 2, + ((p + 1).factorization prime + 1)) = + ∏ prime ∈ (p + 1).primeFactors.erase 2, + (if actualNeighborSide p prime = .plus then + actualNeighborExponent p prime + 1 + else 1) := by + apply Finset.prod_congr rfl + intro prime hprime + have hplus : prime ∈ (p + 1).primeFactors := + Finset.mem_of_mem_erase hprime + have hodd : prime ≠ 2 := (Finset.mem_erase.mp hprime).1 + have hnotMinus : prime ∉ (p - 1).primeFactors := by + intro hminus + exact odd_prime_not_mem_both_neighbors hp hodd hminus hplus + simp [actualNeighborSide, actualNeighborExponent, hnotMinus] + _ = ∏ prime ∈ jointOddPrimeSupport p, + (if actualNeighborSide p prime = .plus then + actualNeighborExponent p prime + 1 + else 1) := by + apply Finset.prod_subset + · intro prime hprime + simp only [jointOddPrimeSupport, Finset.mem_erase, + Finset.mem_union] + exact ⟨(Finset.mem_erase.mp hprime).1, + Or.inr (Finset.mem_of_mem_erase hprime)⟩ + · intro prime hsupport hnot + have hodd : prime ≠ 2 := + (Finset.mem_erase.mp hsupport).1 + have hnotPlus : prime ∉ (p + 1).primeFactors := by + intro hplus + exact hnot (Finset.mem_erase.mpr ⟨hodd, hplus⟩) + have hminus : prime ∈ (p - 1).primeFactors := by + rcases (Finset.mem_union.mp + (Finset.mem_of_mem_erase hsupport)) with hminus | hplus + · exact hminus + · exact False.elim (hnotPlus hplus) + simp [actualNeighborSide, hminus] + +theorem RankinNeighborProfile.divisorCount_eq_neighborCards + {p : ℕ} (hpPrime : p.Prime) (hpTwo : 2 < p) + {profile : RankinNeighborProfile} + (hmatch : profile.Matches p) : + profile.divisorCount .minus = (p - 1).divisors.card ∧ + profile.divisorCount .plus = (p + 1).divisors.card := by + rcases hmatch with + ⟨hminusTwo, hplusTwo, assignment, hlist, hoddMatch⟩ + have hp : 1 < p := by omega + have hpOdd : p % 2 = 1 := + hpPrime.eq_two_or_odd.resolve_left (by omega) + have hminusNe : p - 1 ≠ 0 := by omega + have hplusNe : p + 1 ≠ 0 := by omega + have htwoMinus : 2 ∈ (p - 1).primeFactors := by + apply Nat.prime_two.mem_primeFactors _ hminusNe + omega + have htwoPlus : 2 ∈ (p + 1).primeFactors := by + apply Nat.prime_two.mem_primeFactors _ hplusNe + omega + constructor + · rw [Nat.card_divisors hminusNe] + rw [← Finset.mul_prod_erase + (p - 1).primeFactors (fun prime => + (p - 1).factorization prime + 1) htwoMinus] + simp only [RankinNeighborProfile.divisorCount, + RankinNeighborProfile.twoExponent, hminusTwo, hlist] + rw [oddDivisorCount_map_assignment p .minus + (jointOddPrimeList p) assignment hoddMatch] + rw [jointOddPrimeList_factor_product_minus p] + · rw [Nat.card_divisors hplusNe] + rw [← Finset.mul_prod_erase + (p + 1).primeFactors (fun prime => + (p + 1).factorization prime + 1) htwoPlus] + simp only [RankinNeighborProfile.divisorCount, + RankinNeighborProfile.twoExponent, hplusTwo, hlist] + rw [oddDivisorCount_map_assignment p .plus + (jointOddPrimeList p) assignment hoddMatch] + rw [jointOddPrimeList_factor_product_plus p hp] + +theorem RankinNeighborProfile.jointDivisorCount_eq_neighborCards + {p : ℕ} (hpPrime : p.Prime) (hpTwo : 2 < p) + {profile : RankinNeighborProfile} + (hmatch : profile.Matches p) : + profile.jointDivisorCount = + (p - 1).divisors.card + (p + 1).divisors.card := by + rcases profile.divisorCount_eq_neighborCards hpPrime hpTwo hmatch with + ⟨hminus, hplus⟩ + simp [RankinNeighborProfile.jointDivisorCount, hminus, hplus] + +private theorem oddLowerNeighborProduct_map_assignment_le + (p : ℕ) (side : NeighborSide) + (primes : List ℕ) (assignment : ℕ → RankinOddFactor) + (hmatch : + ∀ prime ∈ primes, (assignment prime).Matches p prime) : + RankinNeighborProfile.oddLowerNeighborProduct side + (primes.map assignment) ≤ + (primes.map fun prime => + if actualNeighborSide p prime = side then + prime ^ actualNeighborExponent p prime + else 1).prod := by + induction primes with + | nil => simp [RankinNeighborProfile.oddLowerNeighborProduct] + | cons prime primes ih => + have hhead := hmatch prime (by simp) + have htail : + ∀ q ∈ primes, (assignment q).Matches p q := by + intro q hq + exact hmatch q (by simp [hq]) + simp only [List.map_cons, + RankinNeighborProfile.oddLowerNeighborProduct, + List.prod_cons] + rw [hhead.1, hhead.2.1] + by_cases hside : actualNeighborSide p prime = side + · simp only [hside, ite_eq_left] + exact Nat.mul_le_mul + (Nat.pow_le_pow_left hhead.2.2 _) + (ih htail) + · simpa [hside] using ih htail + +private theorem jointOddPrimeList_power_product_minus + (p : ℕ) : + ((jointOddPrimeList p).map fun prime => + if actualNeighborSide p prime = .minus then + prime ^ actualNeighborExponent p prime + else 1).prod = + ∏ prime ∈ (p - 1).primeFactors.erase 2, + prime ^ (p - 1).factorization prime := by + rw [jointOddPrimeList_map_prod] + symm + calc + (∏ prime ∈ (p - 1).primeFactors.erase 2, + prime ^ (p - 1).factorization prime) = + ∏ prime ∈ (p - 1).primeFactors.erase 2, + (if actualNeighborSide p prime = .minus then + prime ^ actualNeighborExponent p prime + else 1) := by + apply Finset.prod_congr rfl + intro prime hprime + have hminus : prime ∈ (p - 1).primeFactors := + Finset.mem_of_mem_erase hprime + simp [actualNeighborSide, actualNeighborExponent, hminus] + _ = ∏ prime ∈ jointOddPrimeSupport p, + (if actualNeighborSide p prime = .minus then + prime ^ actualNeighborExponent p prime + else 1) := by + apply Finset.prod_subset + · intro prime hprime + exact Finset.mem_erase.mpr + ⟨(Finset.mem_erase.mp hprime).1, + Finset.mem_union_left _ (Finset.mem_of_mem_erase hprime)⟩ + · intro prime hsupport hnot + have hodd : prime ≠ 2 := (Finset.mem_erase.mp hsupport).1 + have hnotMinus : prime ∉ (p - 1).primeFactors := by + intro hminus + exact hnot (Finset.mem_erase.mpr ⟨hodd, hminus⟩) + simp [actualNeighborSide, hnotMinus] + +private theorem jointOddPrimeList_power_product_plus + (p : ℕ) (hp : 1 < p) : + ((jointOddPrimeList p).map fun prime => + if actualNeighborSide p prime = .plus then + prime ^ actualNeighborExponent p prime + else 1).prod = + ∏ prime ∈ (p + 1).primeFactors.erase 2, + prime ^ (p + 1).factorization prime := by + rw [jointOddPrimeList_map_prod] + symm + calc + (∏ prime ∈ (p + 1).primeFactors.erase 2, + prime ^ (p + 1).factorization prime) = + ∏ prime ∈ (p + 1).primeFactors.erase 2, + (if actualNeighborSide p prime = .plus then + prime ^ actualNeighborExponent p prime + else 1) := by + apply Finset.prod_congr rfl + intro prime hprime + have hplus : prime ∈ (p + 1).primeFactors := + Finset.mem_of_mem_erase hprime + have hodd : prime ≠ 2 := (Finset.mem_erase.mp hprime).1 + have hnotMinus : prime ∉ (p - 1).primeFactors := by + intro hminus + exact odd_prime_not_mem_both_neighbors hp hodd hminus hplus + simp [actualNeighborSide, actualNeighborExponent, hnotMinus] + _ = ∏ prime ∈ jointOddPrimeSupport p, + (if actualNeighborSide p prime = .plus then + prime ^ actualNeighborExponent p prime + else 1) := by + apply Finset.prod_subset + · intro prime hprime + exact Finset.mem_erase.mpr + ⟨(Finset.mem_erase.mp hprime).1, + Finset.mem_union_right _ (Finset.mem_of_mem_erase hprime)⟩ + · intro prime hsupport hnot + have hodd : prime ≠ 2 := (Finset.mem_erase.mp hsupport).1 + have hnotPlus : prime ∉ (p + 1).primeFactors := by + intro hplus + exact hnot (Finset.mem_erase.mpr ⟨hodd, hplus⟩) + have hminus : prime ∈ (p - 1).primeFactors := by + rcases Finset.mem_union.mp + (Finset.mem_of_mem_erase hsupport) with hminus | hplus + · exact hminus + · exact False.elim (hnotPlus hplus) + simp [actualNeighborSide, hminus] + +/-- Matching profiles give genuine lower bounds for both neighboring +integers. -/ +theorem RankinNeighborProfile.lowerNeighborProducts_le + {p : ℕ} (hpPrime : p.Prime) (hpTwo : 2 < p) + {profile : RankinNeighborProfile} + (hmatch : profile.Matches p) : + profile.lowerNeighborProduct .minus ≤ p - 1 ∧ + profile.lowerNeighborProduct .plus ≤ p + 1 := by + rcases hmatch with + ⟨hminusTwo, hplusTwo, assignment, hlist, hoddMatch⟩ + have hp : 1 < p := by omega + have hpOdd : p % 2 = 1 := + hpPrime.eq_two_or_odd.resolve_left (by omega) + have hminusNe : p - 1 ≠ 0 := by omega + have hplusNe : p + 1 ≠ 0 := by omega + have htwoMinus : 2 ∈ (p - 1).primeFactors := by + apply Nat.prime_two.mem_primeFactors _ hminusNe + omega + have htwoPlus : 2 ∈ (p + 1).primeFactors := by + apply Nat.prime_two.mem_primeFactors _ hplusNe + omega + constructor + · simp only [RankinNeighborProfile.lowerNeighborProduct, + RankinNeighborProfile.twoExponent, hminusTwo, hlist] + calc + 2 ^ (p - 1).factorization 2 * + RankinNeighborProfile.oddLowerNeighborProduct .minus + ((jointOddPrimeList p).map assignment) ≤ + 2 ^ (p - 1).factorization 2 * + ((jointOddPrimeList p).map fun prime => + if actualNeighborSide p prime = .minus then + prime ^ actualNeighborExponent p prime + else 1).prod := + Nat.mul_le_mul_left _ + (oddLowerNeighborProduct_map_assignment_le + p .minus (jointOddPrimeList p) assignment hoddMatch) + _ = 2 ^ (p - 1).factorization 2 * + ∏ prime ∈ (p - 1).primeFactors.erase 2, + prime ^ (p - 1).factorization prime := by + rw [jointOddPrimeList_power_product_minus p] + _ = ∏ prime ∈ (p - 1).primeFactors, + prime ^ (p - 1).factorization prime := + Finset.mul_prod_erase (p - 1).primeFactors + (fun prime => prime ^ (p - 1).factorization prime) htwoMinus + _ = p - 1 := (Nat.prod_primeFactors_pow_factorization hminusNe).symm + · simp only [RankinNeighborProfile.lowerNeighborProduct, + RankinNeighborProfile.twoExponent, hplusTwo, hlist] + calc + 2 ^ (p + 1).factorization 2 * + RankinNeighborProfile.oddLowerNeighborProduct .plus + ((jointOddPrimeList p).map assignment) ≤ + 2 ^ (p + 1).factorization 2 * + ((jointOddPrimeList p).map fun prime => + if actualNeighborSide p prime = .plus then + prime ^ actualNeighborExponent p prime + else 1).prod := + Nat.mul_le_mul_left _ + (oddLowerNeighborProduct_map_assignment_le + p .plus (jointOddPrimeList p) assignment hoddMatch) + _ = 2 ^ (p + 1).factorization 2 * + ∏ prime ∈ (p + 1).primeFactors.erase 2, + prime ^ (p + 1).factorization prime := by + rw [jointOddPrimeList_power_product_plus p hp] + _ = ∏ prime ∈ (p + 1).primeFactors, + prime ^ (p + 1).factorization prime := + Finset.mul_prod_erase (p + 1).primeFactors + (fun prime => prime ^ (p + 1).factorization prime) htwoPlus + _ = p + 1 := (Nat.prod_primeFactors_pow_factorization hplusNe).symm + +private theorem oddCoarseEulerProduct_map_assignment + (p : ℕ) (side : NeighborSide) + (primes : List ℕ) (assignment : ℕ → RankinOddFactor) + (hmatch : + ∀ prime ∈ primes, (assignment prime).Matches p prime) : + RankinNeighborProfile.oddCoarseEulerProduct side + (primes.map assignment) = + (primes.map fun prime => + if actualNeighborSide p prime = side then + coarseRankinPrimePowerFactor + (actualNeighborExponent p prime) + (assignment prime).weightCap.weight + else 1).prod := by + induction primes with + | nil => simp [RankinNeighborProfile.oddCoarseEulerProduct] + | cons prime primes ih => + have hhead := hmatch prime (by simp) + have htail : + ∀ q ∈ primes, (assignment q).Matches p q := by + intro q hq + exact hmatch q (by simp [hq]) + simp only [List.map_cons, + RankinNeighborProfile.oddCoarseEulerProduct, + List.prod_cons] + rw [ih htail] + simp [RankinOddFactor.Matches] at hhead + rw [hhead.1, hhead.2.1] + +private theorem jointOddPrimeList_coarse_product_minus + (p : ℕ) + (profile : RankinNeighborProfile) + (assignment : ℕ → RankinOddFactor) : + ((jointOddPrimeList p).map fun prime => + if actualNeighborSide p prime = .minus then + coarseRankinPrimePowerFactor + (actualNeighborExponent p prime) + (assignment prime).weightCap.weight + else 1).prod = + ∏ prime ∈ (p - 1).primeFactors.erase 2, + coarseRankinPrimePowerFactor ((p - 1).factorization prime) + (assignedPrimeWeight p profile assignment prime) := by + rw [jointOddPrimeList_map_prod] + symm + calc + (∏ prime ∈ (p - 1).primeFactors.erase 2, + coarseRankinPrimePowerFactor ((p - 1).factorization prime) + (assignedPrimeWeight p profile assignment prime)) = + ∏ prime ∈ (p - 1).primeFactors.erase 2, + (if actualNeighborSide p prime = .minus then + coarseRankinPrimePowerFactor + (actualNeighborExponent p prime) + (assignment prime).weightCap.weight + else 1) := by + apply Finset.prod_congr rfl + intro prime hprime + have hodd : prime ≠ 2 := (Finset.mem_erase.mp hprime).1 + have hminus : prime ∈ (p - 1).primeFactors := + Finset.mem_of_mem_erase hprime + have hsupport : prime ∈ jointOddPrimeSupport p := by + exact Finset.mem_erase.mpr ⟨hodd, + Finset.mem_union_left _ hminus⟩ + simp [actualNeighborSide, actualNeighborExponent, + assignedPrimeWeight, hodd, hminus, hsupport] + _ = ∏ prime ∈ jointOddPrimeSupport p, + (if actualNeighborSide p prime = .minus then + coarseRankinPrimePowerFactor + (actualNeighborExponent p prime) + (assignment prime).weightCap.weight + else 1) := by + apply Finset.prod_subset + · intro prime hprime + exact Finset.mem_erase.mpr + ⟨(Finset.mem_erase.mp hprime).1, + Finset.mem_union_left _ (Finset.mem_of_mem_erase hprime)⟩ + · intro prime hsupport hnot + have hodd : prime ≠ 2 := (Finset.mem_erase.mp hsupport).1 + have hnotMinus : prime ∉ (p - 1).primeFactors := by + intro hminus + exact hnot (Finset.mem_erase.mpr ⟨hodd, hminus⟩) + simp [actualNeighborSide, hnotMinus] + +private theorem jointOddPrimeList_coarse_product_plus + (p : ℕ) (hp : 1 < p) + (profile : RankinNeighborProfile) + (assignment : ℕ → RankinOddFactor) : + ((jointOddPrimeList p).map fun prime => + if actualNeighborSide p prime = .plus then + coarseRankinPrimePowerFactor + (actualNeighborExponent p prime) + (assignment prime).weightCap.weight + else 1).prod = + ∏ prime ∈ (p + 1).primeFactors.erase 2, + coarseRankinPrimePowerFactor ((p + 1).factorization prime) + (assignedPrimeWeight p profile assignment prime) := by + rw [jointOddPrimeList_map_prod] + symm + calc + (∏ prime ∈ (p + 1).primeFactors.erase 2, + coarseRankinPrimePowerFactor ((p + 1).factorization prime) + (assignedPrimeWeight p profile assignment prime)) = + ∏ prime ∈ (p + 1).primeFactors.erase 2, + (if actualNeighborSide p prime = .plus then + coarseRankinPrimePowerFactor + (actualNeighborExponent p prime) + (assignment prime).weightCap.weight + else 1) := by + apply Finset.prod_congr rfl + intro prime hprime + have hodd : prime ≠ 2 := (Finset.mem_erase.mp hprime).1 + have hplus : prime ∈ (p + 1).primeFactors := + Finset.mem_of_mem_erase hprime + have hnotMinus : prime ∉ (p - 1).primeFactors := by + intro hminus + exact odd_prime_not_mem_both_neighbors hp hodd hminus hplus + have hsupport : prime ∈ jointOddPrimeSupport p := by + exact Finset.mem_erase.mpr ⟨hodd, + Finset.mem_union_right _ hplus⟩ + simp [actualNeighborSide, actualNeighborExponent, + assignedPrimeWeight, hodd, hnotMinus, hsupport] + _ = ∏ prime ∈ jointOddPrimeSupport p, + (if actualNeighborSide p prime = .plus then + coarseRankinPrimePowerFactor + (actualNeighborExponent p prime) + (assignment prime).weightCap.weight + else 1) := by + apply Finset.prod_subset + · intro prime hprime + exact Finset.mem_erase.mpr + ⟨(Finset.mem_erase.mp hprime).1, + Finset.mem_union_right _ (Finset.mem_of_mem_erase hprime)⟩ + · intro prime hsupport hnot + have hodd : prime ≠ 2 := (Finset.mem_erase.mp hsupport).1 + have hnotPlus : prime ∉ (p + 1).primeFactors := by + intro hplus + exact hnot (Finset.mem_erase.mpr ⟨hodd, hplus⟩) + have hminus : prime ∈ (p - 1).primeFactors := by + rcases Finset.mem_union.mp + (Finset.mem_of_mem_erase hsupport) with hminus | hplus + · exact hminus + · exact False.elim (hnotPlus hplus) + simp [actualNeighborSide, hminus] + +theorem RankinNeighborProfile.factorizationCoarse_eq_coarseEulerProduct + {p : ℕ} (hpPrime : p.Prime) (hpTwo : 2 < p) + {profile : RankinNeighborProfile} + (hmatch : profile.Matches p) : + ∃ assignment : ℕ → RankinOddFactor, + profile.oddFactors = (jointOddPrimeList p).map assignment ∧ + (∀ prime ∈ jointOddPrimeList p, + (assignment prime).Matches p prime) ∧ + (p - 1).factorization.prod (fun prime exponent => + coarseRankinPrimePowerFactor exponent + (assignedPrimeWeight p profile assignment prime)) = + profile.coarseEulerProduct .minus ∧ + (p + 1).factorization.prod (fun prime exponent => + coarseRankinPrimePowerFactor exponent + (assignedPrimeWeight p profile assignment prime)) = + profile.coarseEulerProduct .plus := by + rcases hmatch with + ⟨hminusTwo, hplusTwo, assignment, hlist, hoddMatch⟩ + have hp : 1 < p := by omega + have hpOdd : p % 2 = 1 := + hpPrime.eq_two_or_odd.resolve_left (by omega) + have hminusNe : p - 1 ≠ 0 := by omega + have hplusNe : p + 1 ≠ 0 := by omega + have htwoMinus : 2 ∈ (p - 1).primeFactors := by + apply Nat.prime_two.mem_primeFactors _ hminusNe + omega + have htwoPlus : 2 ∈ (p + 1).primeFactors := by + apply Nat.prime_two.mem_primeFactors _ hplusNe + omega + refine ⟨assignment, hlist, hoddMatch, ?_, ?_⟩ + · simp only [Finsupp.prod] + rw [Nat.support_factorization] + rw [← Finset.mul_prod_erase + (p - 1).primeFactors + (fun prime => coarseRankinPrimePowerFactor + ((p - 1).factorization prime) + (assignedPrimeWeight p profile assignment prime)) htwoMinus] + simp only [assignedPrimeWeight, ite_eq_left, + RankinNeighborProfile.coarseEulerProduct, + RankinNeighborProfile.twoExponent, hminusTwo, hlist] + rw [oddCoarseEulerProduct_map_assignment p .minus + (jointOddPrimeList p) assignment hoddMatch] + rw [jointOddPrimeList_coarse_product_minus + p profile assignment] + rfl + · simp only [Finsupp.prod] + rw [Nat.support_factorization] + rw [← Finset.mul_prod_erase + (p + 1).primeFactors + (fun prime => coarseRankinPrimePowerFactor + ((p + 1).factorization prime) + (assignedPrimeWeight p profile assignment prime)) htwoPlus] + simp only [assignedPrimeWeight, ite_eq_left, + RankinNeighborProfile.coarseEulerProduct, + RankinNeighborProfile.twoExponent, hplusTwo, hlist] + rw [oddCoarseEulerProduct_map_assignment p .plus + (jointOddPrimeList p) assignment hoddMatch] + rw [jointOddPrimeList_coarse_product_plus + p hp profile assignment] + rfl + +/-- A valid matching profile supplies one total rational weight assignment +whose two exact Euler products are bounded by the profile's two coarse +products. -/ +theorem RankinNeighborProfile.exists_assignedPrimeWeight_bounds + {p : ℕ} (hpPrime : p.Prime) (hpTwo : 2 < p) + {profile : RankinNeighborProfile} + (hprofile : profile.Valid) (hmatch : profile.Matches p) : + ∃ assignment : ℕ → RankinOddFactor, + (∀ prime, + 0 ≤ assignedPrimeWeight p profile assignment prime) ∧ + (∀ prime : ℕ, prime.Prime → + 1 ≤ (prime : ℚ) * + (assignedPrimeWeight p profile assignment prime) ^ 12) ∧ + (p - 1).factorization.prod (fun prime exponent => + rankinPrimePowerFactor prime exponent + (assignedPrimeWeight p profile assignment prime)) ≤ + profile.coarseEulerProduct .minus ∧ + (p + 1).factorization.prod (fun prime exponent => + rankinPrimePowerFactor prime exponent + (assignedPrimeWeight p profile assignment prime)) ≤ + profile.coarseEulerProduct .plus := by + obtain ⟨assignment, hlist, hoddMatch, hminusEq, hplusEq⟩ := + profile.factorizationCoarse_eq_coarseEulerProduct + hpPrime hpTwo hmatch + have hnonneg : + ∀ prime, 0 ≤ assignedPrimeWeight p profile assignment prime := + assignedPrimeWeight_nonneg hprofile hlist + have hpower : + ∀ prime : ℕ, prime.Prime → + 1 ≤ (prime : ℚ) * + (assignedPrimeWeight p profile assignment prime) ^ 12 := + assignedPrimeWeight_power hprofile hlist hoddMatch + refine ⟨assignment, hnonneg, hpower, ?_, ?_⟩ + · exact (factorizationEulerProduct_le_coarse + (p - 1) (assignedPrimeWeight p profile assignment) hnonneg).trans_eq + hminusEq + · exact (factorizationEulerProduct_le_coarse + (p + 1) (assignedPrimeWeight p profile assignment) hnonneg).trans_eq + hplusEq + +end BGS.NumberTheory diff --git a/LeanPool/MarkoffModP/BGS/NumberTheory/TruncatedOrderTotient.lean b/LeanPool/MarkoffModP/BGS/NumberTheory/TruncatedOrderTotient.lean new file mode 100644 index 0000000000..3e28ce2d95 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/NumberTheory/TruncatedOrderTotient.lean @@ -0,0 +1,86 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import Mathlib.GroupTheory.SpecificGroups.Cyclic +public import Mathlib.Tactic + +/-! +# Exact truncated order budgets in finite cyclic groups + +For a cyclic group of order `N`, the number of elements of exact order `e` +is `φ(e)` when `e ∣ N`. Summing only the non-two-torsion orders at most a +cutoff gives the exact root budget used by the improved Markoff count. +-/ + +@[expose] public section + +namespace BGS.NumberTheory + +/-- Root count contributed by divisor orders strictly above two and at most +`bound`. -/ +def truncatedOrderTotientSum (N bound : ℕ) : ℕ := + ∑ order ∈ N.divisors.filter + (fun order ↦ 2 < order ∧ order ≤ bound), + order.totient + +/-- Elements whose exact order is in the non-two-torsion truncated range. -/ +noncomputable def elementsOfOrderBetweenThreeAnd + (G : Type*) [Group G] [Fintype G] (bound : ℕ) : Finset G := + Finset.univ.filter fun g ↦ 2 < orderOf g ∧ orderOf g ≤ bound + +@[simp] +theorem mem_elementsOfOrderBetweenThreeAnd_iff + {G : Type*} [Group G] [Fintype G] {bound : ℕ} {g : G} : + g ∈ elementsOfOrderBetweenThreeAnd G bound ↔ + 2 < orderOf g ∧ orderOf g ≤ bound := by + classical + simp [elementsOfOrderBetweenThreeAnd] + +/-- Exact cyclic root count for the truncated non-two-torsion order range. -/ +theorem elementsOfOrderBetweenThreeAnd_card_eq_truncatedOrderTotientSum + (G : Type*) [Group G] [Fintype G] [IsCyclic G] (bound : ℕ) : + (elementsOfOrderBetweenThreeAnd G bound).card = + truncatedOrderTotientSum (Fintype.card G) bound := by + classical + let orders := + (Fintype.card G).divisors.filter + (fun order ↦ 2 < order ∧ order ≤ bound) + have hcard : Fintype.card G ≠ 0 := Fintype.card_ne_zero + rw [elementsOfOrderBetweenThreeAnd] + rw [Finset.card_eq_sum_card_fiberwise + (t := orders) (f := orderOf) (by + intro g hg + have hgRange := (Finset.mem_filter.mp hg).2 + apply Finset.mem_filter.mpr + refine ⟨Nat.mem_divisors.mpr ⟨orderOf_dvd_card, hcard⟩, hgRange⟩)] + rw [truncatedOrderTotientSum] + change + (∑ order ∈ orders, + ((Finset.univ.filter fun g : G ↦ + 2 < orderOf g ∧ orderOf g ≤ bound).filter + fun g ↦ orderOf g = order).card) = + ∑ order ∈ orders, order.totient + apply Finset.sum_congr rfl + intro order horder + have horderData := (Finset.mem_filter.mp horder) + have horderDvd : order ∣ Fintype.card G := + (Nat.mem_divisors.mp horderData.1).1 + have hfiber : + ((Finset.univ.filter fun g : G ↦ + 2 < orderOf g ∧ orderOf g ≤ bound).filter + fun g ↦ orderOf g = order) = + Finset.univ.filter (fun g : G ↦ orderOf g = order) := by + ext g + simp only [Finset.mem_filter, Finset.mem_univ, true_and] + constructor + · exact fun hg ↦ hg.2 + · intro hg + exact ⟨by simpa [hg] using horderData.2, hg⟩ + rw [hfiber, IsCyclic.card_orderOf_eq_totient horderDvd] + +end BGS.NumberTheory diff --git a/LeanPool/MarkoffModP/BGS/NumberTheory/TruncatedOrderTotientRankin.lean b/LeanPool/MarkoffModP/BGS/NumberTheory/TruncatedOrderTotientRankin.lean new file mode 100644 index 0000000000..00c40ca163 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/NumberTheory/TruncatedOrderTotientRankin.lean @@ -0,0 +1,174 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.NumberTheory.TruncatedOrderTotient +public import Mathlib.Tactic + +/-! +# Rational Rankin bounds for truncated exact-order sums + +This isolates the analytic inequality from any particular factorization +certificate. Rational weights make every later finite certificate exactly +checkable. +-/ + +@[expose] public section + +namespace BGS.NumberTheory + +/-- The weighted divisor sum used by the rational Rankin estimate. -/ +def weightedTotientDivisorSum + (N : ℕ) (weight : ℕ → ℚ) : ℚ := + ∑ order ∈ N.divisors, + (order.totient : ℚ) / order * weight order + +private theorem one_le_cap_mul_weight_of_twelfthPower + {order bound : ℕ} {weight cap : ℚ} + (horderPos : 0 < order) + (horderBound : order ≤ bound) + (hweightNonneg : 0 ≤ weight) + (hweightPower : 1 ≤ (order : ℚ) * weight ^ 12) + (hcapNonneg : 0 ≤ cap) + (hboundCap : (bound : ℚ) ≤ cap ^ 12) : + 1 ≤ cap * weight := by + have hboundNonneg : (0 : ℚ) ≤ bound := by positivity + have hproduct : + (bound : ℚ) ≤ + (order : ℚ) * (cap * weight) ^ 12 := by + calc + (bound : ℚ) = (bound : ℚ) * 1 := by ring + _ ≤ cap ^ 12 * ((order : ℚ) * weight ^ 12) := by + gcongr + _ = (order : ℚ) * (cap * weight) ^ 12 := by ring + have horderCast : (order : ℚ) ≤ bound := by + exact_mod_cast horderBound + have horderProduct : + (order : ℚ) ≤ + (order : ℚ) * (cap * weight) ^ 12 := + horderCast.trans hproduct + have hpower : (1 : ℚ) ≤ (cap * weight) ^ 12 := by + apply + (mul_le_mul_iff_right₀ + (show (0 : ℚ) < order by exact_mod_cast horderPos)).mp + simpa using horderProduct + have hcapWeightNonneg : 0 ≤ cap * weight := + mul_nonneg hcapNonneg hweightNonneg + apply + (pow_le_pow_iff_left₀ + (show (0 : ℚ) ≤ 1 by norm_num) + hcapWeightNonneg + (show (12 : ℕ) ≠ 0 by norm_num)).mp + simpa using hpower + +/-- Abstract rational-weight Rankin bound. + +For every divisor order in the truncated range, the hypotheses say that +`weight(order)` is at least its inverse twelfth root, while `cap` is at +least the twelfth root of `bound`. The conclusion bounds the exact +truncated root count by a weighted sum over all divisors of `N`. -/ +theorem truncatedOrderTotientSum_cast_le_weightedRankin + (N bound : ℕ) (weight : ℕ → ℚ) (cap : ℚ) + (hweightNonneg : + ∀ order ∈ N.divisors, 0 ≤ weight order) + (hweightPower : + ∀ order ∈ N.divisors, + 1 ≤ (order : ℚ) * (weight order) ^ 12) + (hcapNonneg : 0 ≤ cap) + (hboundCap : (bound : ℚ) ≤ cap ^ 12) : + (truncatedOrderTotientSum N bound : ℚ) ≤ + (bound : ℚ) * cap * + weightedTotientDivisorSum N weight := by + let selected := + N.divisors.filter + (fun order ↦ 2 < order ∧ order ≤ bound) + let summand : ℕ → ℚ := fun order ↦ + (order.totient : ℚ) / order * weight order + have hsummandNonneg : + ∀ order ∈ N.divisors, 0 ≤ summand order := by + intro order horder + exact mul_nonneg + (div_nonneg (by positivity) (by positivity)) + (hweightNonneg order horder) + have hselectedWeighted : + (∑ order ∈ selected, summand order) ≤ + ∑ order ∈ N.divisors, summand order := by + apply Finset.sum_le_sum_of_subset_of_nonneg + (Finset.filter_subset _ _) + intro order horder _hnotSelected + exact hsummandNonneg order horder + have hterm : + ∀ order ∈ selected, + (order.totient : ℚ) ≤ + (bound : ℚ) * cap * summand order := by + intro order horder + have horderData := (Finset.mem_filter.mp horder) + have horderDvd := (Nat.mem_divisors.mp horderData.1).1 + have hNNe := (Nat.mem_divisors.mp horderData.1).2 + have horderNe : order ≠ 0 := by + intro hzero + subst order + simp only [zero_dvd_iff] at horderDvd + exact hNNe horderDvd + have horderPos : 0 < order := Nat.pos_of_ne_zero horderNe + have hone : + (1 : ℚ) ≤ cap * weight order := + one_le_cap_mul_weight_of_twelfthPower + horderPos horderData.2.2 + (hweightNonneg order horderData.1) + (hweightPower order horderData.1) + hcapNonneg hboundCap + have horderLe : + (order : ℚ) ≤ (bound : ℚ) * cap * weight order := by + calc + (order : ℚ) ≤ bound := by exact_mod_cast horderData.2.2 + _ = (bound : ℚ) * 1 := by ring + _ ≤ (bound : ℚ) * (cap * weight order) := + mul_le_mul_of_nonneg_left hone (by positivity) + _ = (bound : ℚ) * cap * weight order := by ring + have hratioNonneg : + 0 ≤ (order.totient : ℚ) / order := + div_nonneg (by positivity) (by positivity) + calc + (order.totient : ℚ) = + ((order.totient : ℚ) / order) * order := by + rw [div_mul_cancel₀] + exact_mod_cast horderNe + _ ≤ ((order.totient : ℚ) / order) * + ((bound : ℚ) * cap * weight order) := + mul_le_mul_of_nonneg_left horderLe hratioNonneg + _ = (bound : ℚ) * cap * summand order := by + simp only [summand] + ring + have hselected : + (∑ order ∈ selected, (order.totient : ℚ)) ≤ + (bound : ℚ) * cap * + (∑ order ∈ selected, summand order) := by + calc + (∑ order ∈ selected, (order.totient : ℚ)) ≤ + ∑ order ∈ selected, + ((bound : ℚ) * cap * summand order) := + Finset.sum_le_sum hterm + _ = (bound : ℚ) * cap * + (∑ order ∈ selected, summand order) := by + rw [Finset.mul_sum] + calc + (truncatedOrderTotientSum N bound : ℚ) = + ∑ order ∈ selected, (order.totient : ℚ) := by + simp only [truncatedOrderTotientSum, selected, Nat.cast_sum] + _ ≤ (bound : ℚ) * cap * + (∑ order ∈ selected, summand order) := + hselected + _ ≤ (bound : ℚ) * cap * + (∑ order ∈ N.divisors, summand order) := + mul_le_mul_of_nonneg_left hselectedWeighted + (mul_nonneg (by positivity) hcapNonneg) + _ = (bound : ℚ) * cap * + weightedTotientDivisorSum N weight := by + simp only [weightedTotientDivisorSum, summand] + +end BGS.NumberTheory diff --git a/LeanPool/MarkoffModP/BGS/NumberTheory/TruncatedOrderTotientRankinFactorization.lean b/LeanPool/MarkoffModP/BGS/NumberTheory/TruncatedOrderTotientRankinFactorization.lean new file mode 100644 index 0000000000..2d61978f32 --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/NumberTheory/TruncatedOrderTotientRankinFactorization.lean @@ -0,0 +1,298 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.NumberTheory.TruncatedOrderTotientRankin +public import Mathlib.NumberTheory.ArithmeticFunction.Zeta +public import Mathlib.NumberTheory.ArithmeticFunction.Misc +public import Mathlib.Data.Nat.Factorization.Basic +public import Mathlib.Tactic + +/-! +# Rankin factorization of weighted totient sums + +Express the multiplicative weighted totient sum as a product over prime powers and bound its +local Rankin factors. +-/ + +@[expose] public section + +namespace BGS.NumberTheory + +open ArithmeticFunction +open scoped ArithmeticFunction.zeta + +/-- Completely multiplicative rational weight determined by its prime values. -/ +def factorizationWeight (primeWeight : ℕ → ℚ) (n : ℕ) : ℚ := + if n = 0 then 0 else + n.factorization.prod fun prime exponent => + (primeWeight prime) ^ exponent + +@[simp] +theorem factorizationWeight_zero (primeWeight : ℕ → ℚ) : + factorizationWeight primeWeight 0 = 0 := by + simp [factorizationWeight] + +@[simp] +theorem factorizationWeight_one (primeWeight : ℕ → ℚ) : + factorizationWeight primeWeight 1 = 1 := by + simp [factorizationWeight] + +theorem factorizationWeight_mul + (primeWeight : ℕ → ℚ) {m n : ℕ} + (hm : m ≠ 0) (hn : n ≠ 0) : + factorizationWeight primeWeight (m * n) = + factorizationWeight primeWeight m * + factorizationWeight primeWeight n := by + simp only [factorizationWeight, mul_eq_zero, hm, hn, or_false, ↓reduceIte] + rw [Nat.factorization_mul hm hn] + exact Finsupp.prod_add_index' (fun _ => pow_zero _) (fun _ => pow_add _) + +/-- The weighted totient ratio as an arithmetic function. -/ +def weightedTotientRatio + (primeWeight : ℕ → ℚ) : ArithmeticFunction ℚ := + ⟨fun n => + if n = 0 then 0 else + (n.totient : ℚ) / n * factorizationWeight primeWeight n, + by simp⟩ + +@[simp] +theorem weightedTotientRatio_apply_ne_zero + (primeWeight : ℕ → ℚ) {n : ℕ} (hn : n ≠ 0) : + weightedTotientRatio primeWeight n = + (n.totient : ℚ) / n * factorizationWeight primeWeight n := by + simp [weightedTotientRatio, hn] + +theorem weightedTotientRatio_isMultiplicative + (primeWeight : ℕ → ℚ) : + (weightedTotientRatio primeWeight).IsMultiplicative := by + refine ⟨by simp [weightedTotientRatio], ?_⟩ + intro m n hcoprime + by_cases hm : m = 0 + · subst m + simp + by_cases hn : n = 0 + · subst n + simp + simp only [weightedTotientRatio_apply_ne_zero _ hm, + weightedTotientRatio_apply_ne_zero _ hn, + weightedTotientRatio_apply_ne_zero _ (mul_ne_zero hm hn), + Nat.totient_mul hcoprime, + factorizationWeight_mul primeWeight hm hn, + Nat.cast_mul] + field_simp + +/-- Exact local Euler factor for one prime power. -/ +def rankinPrimePowerFactor + (prime exponent : ℕ) (weight : ℚ) : ℚ := + 1 + ((prime - 1 : ℕ) : ℚ) / prime * + ∑ index ∈ Finset.range exponent, weight ^ (index + 1) + +/-- Prime-independent upper local factor. Dropping `1 - 1 / prime` is +important for profile certificates: a lower bound on the prime controls the +weight, while this coarser factor is monotone-free. -/ +def coarseRankinPrimePowerFactor + (exponent : ℕ) (weight : ℚ) : ℚ := + 1 + ∑ index ∈ Finset.range exponent, weight ^ (index + 1) + +theorem rankinPrimePowerFactor_nonneg + {prime exponent : ℕ} (_hprime : prime.Prime) + {weight : ℚ} (hweight : 0 ≤ weight) : + 0 ≤ rankinPrimePowerFactor prime exponent weight := by + simp only [rankinPrimePowerFactor] + positivity + +theorem rankinPrimePowerFactor_le_coarse + {prime exponent : ℕ} (hprime : prime.Prime) + {weight : ℚ} (hweight : 0 ≤ weight) : + rankinPrimePowerFactor prime exponent weight ≤ + coarseRankinPrimePowerFactor exponent weight := by + have hsumNonneg : + (0 : ℚ) ≤ + ∑ index ∈ Finset.range exponent, weight ^ (index + 1) := by + positivity + have hratio : (((prime - 1 : ℕ) : ℚ) / prime) ≤ 1 := by + apply (div_le_one (by exact_mod_cast hprime.pos)).2 + exact_mod_cast Nat.sub_le prime 1 + simp only [rankinPrimePowerFactor, coarseRankinPrimePowerFactor] + gcongr + simpa using mul_le_mul_of_nonneg_right hratio hsumNonneg + +private theorem weightedTotientRatio_primePowerSum + (prime exponent : ℕ) (hprime : prime.Prime) + (primeWeight : ℕ → ℚ) : + ∑ order ∈ (prime ^ exponent).divisors, + weightedTotientRatio primeWeight order = + rankinPrimePowerFactor prime exponent (primeWeight prime) := by + rw [Nat.sum_divisors_prime_pow hprime] + rw [Finset.sum_range_succ'] + simp only [rankinPrimePowerFactor] + rw [show weightedTotientRatio primeWeight (prime ^ 0) = 1 by + simp [weightedTotientRatio, factorizationWeight]] + rw [add_comm _ 1] + rw [add_left_cancel_iff] + rw [Finset.mul_sum] + apply Finset.sum_congr rfl + intro index hindex + simp only [weightedTotientRatio_apply_ne_zero _ + (pow_ne_zero _ hprime.ne_zero), factorizationWeight, + pow_ne_zero _ hprime.ne_zero, ite_false, hprime.factorization_pow] + rw [Finsupp.prod_single_index] + rw [Nat.totient_prime_pow_succ hprime] + push_cast + field_simp [hprime.ne_zero] + ring + all_goals simp + +theorem weightedTotientDivisorSum_eq_factorizationEulerProduct + (N : ℕ) (hN : N ≠ 0) (primeWeight : ℕ → ℚ) : + weightedTotientDivisorSum N (factorizationWeight primeWeight) = + N.factorization.prod fun prime exponent => + rankinPrimePowerFactor prime exponent (primeWeight prime) := by + have hmult := weightedTotientRatio_isMultiplicative primeWeight + have hzetaMult : + ((ζ : ArithmeticFunction ℕ) : ArithmeticFunction ℚ).IsMultiplicative := + ArithmeticFunction.isMultiplicative_zeta.natCast + calc + weightedTotientDivisorSum N (factorizationWeight primeWeight) = + ∑ order ∈ N.divisors, + weightedTotientRatio primeWeight order := by + apply Finset.sum_congr rfl + intro order horder + have horderNe : order ≠ 0 := + ne_zero_of_dvd_ne_zero hN (Nat.mem_divisors.mp horder).1 + simp [weightedTotientRatio_apply_ne_zero _ horderNe] + _ = (((ζ : ArithmeticFunction ℕ) : ArithmeticFunction ℚ) * + weightedTotientRatio primeWeight) N := by + rw [ArithmeticFunction.coe_zeta_mul_apply] + _ = N.factorization.prod fun prime exponent => + ((((ζ : ArithmeticFunction ℕ) : ArithmeticFunction ℚ) * + weightedTotientRatio primeWeight) (prime ^ exponent)) := by + exact (hzetaMult.mul hmult).multiplicative_factorization _ hN + _ = N.factorization.prod fun prime exponent => + rankinPrimePowerFactor prime exponent (primeWeight prime) := by + apply Finsupp.prod_congr + intro prime hprime + rw [ArithmeticFunction.coe_zeta_mul_apply] + exact weightedTotientRatio_primePowerSum prime _ + (Nat.prime_of_mem_primeFactors hprime) primeWeight + +/-- Nonnegative prime weights give a nonnegative multiplicative weight on +every positive integer. -/ +theorem factorizationWeight_nonneg + (primeWeight : ℕ → ℚ) + (hprimeWeightNonneg : ∀ prime, 0 ≤ primeWeight prime) + (n : ℕ) : + 0 ≤ factorizationWeight primeWeight n := by + by_cases hn : n = 0 + · simp [hn] + simp only [factorizationWeight, hn, ↓reduceIte, Finsupp.prod] + apply Finset.prod_nonneg + intro prime hprime + exact pow_nonneg (hprimeWeightNonneg prime) _ + +/-- The exact Euler product is nonnegative when all supplied prime weights +are nonnegative. -/ +theorem factorizationEulerProduct_nonneg + (N : ℕ) (hN : N ≠ 0) (primeWeight : ℕ → ℚ) + (hprimeWeightNonneg : ∀ prime, 0 ≤ primeWeight prime) : + 0 ≤ N.factorization.prod fun prime exponent => + rankinPrimePowerFactor prime exponent (primeWeight prime) := by + rw [← weightedTotientDivisorSum_eq_factorizationEulerProduct + N hN primeWeight] + apply Finset.sum_nonneg + intro order horder + exact mul_nonneg + (div_nonneg (by positivity) (by positivity)) + (factorizationWeight_nonneg primeWeight hprimeWeightNonneg order) + +/-- The exact Euler product is bounded by the product of the +prime-independent coarse local factors. -/ +theorem factorizationEulerProduct_le_coarse + (N : ℕ) (primeWeight : ℕ → ℚ) + (hprimeWeightNonneg : ∀ prime, 0 ≤ primeWeight prime) : + (N.factorization.prod fun prime exponent => + rankinPrimePowerFactor prime exponent (primeWeight prime)) ≤ + (N.factorization.prod fun prime exponent => + coarseRankinPrimePowerFactor exponent (primeWeight prime)) := by + simp only [Finsupp.prod] + apply Finset.prod_le_prod₀ + · intro prime hprime + exact rankinPrimePowerFactor_nonneg + (Nat.prime_of_mem_primeFactors hprime) + (hprimeWeightNonneg prime) + · intro prime hprime + exact rankinPrimePowerFactor_le_coarse + (Nat.prime_of_mem_primeFactors hprime) + (hprimeWeightNonneg prime) + +/-- A primewise twelfth-power lower bound multiplies to the exact Rankin +weight hypothesis for every positive integer. -/ +theorem factorizationWeight_twelfthPower + (primeWeight : ℕ → ℚ) + (hprimeWeightPower : + ∀ prime : ℕ, prime.Prime → + 1 ≤ (prime : ℚ) * (primeWeight prime) ^ 12) + {n : ℕ} (hn : n ≠ 0) : + 1 ≤ (n : ℚ) * (factorizationWeight primeWeight n) ^ 12 := by + have hnCast : + (n : ℚ) = n.factorization.prod fun prime exponent => + (prime : ℚ) ^ exponent := by + calc + (n : ℚ) = + ((n.factorization.prod fun prime exponent => + prime ^ exponent : ℕ) : ℚ) := by + exact congrArg (fun value : ℕ => (value : ℚ)) + (Nat.prod_factorization_pow_eq_self hn).symm + _ = n.factorization.prod fun prime exponent => + (prime : ℚ) ^ exponent := by + push_cast + rfl + rw [hnCast] + simp only [factorizationWeight, hn, ↓reduceIte, Finsupp.prod] + rw [← Finset.prod_pow, ← Finset.prod_mul_distrib] + apply Finset.one_le_prod₀ + intro prime hprime + rw [show (prime : ℚ) ^ n.factorization prime * + (primeWeight prime ^ n.factorization prime) ^ 12 = + ((prime : ℚ) * primeWeight prime ^ 12) ^ + n.factorization prime by + rw [mul_pow] + congr 1 + rw [← pow_mul, ← pow_mul, Nat.mul_comm]] + exact one_le_pow₀ + (hprimeWeightPower prime (Nat.prime_of_mem_primeFactors hprime)) + +/-- Primewise rational weights specialize the abstract Rankin inequality to +an exact Euler product over the factorization of `N`. -/ +theorem truncatedOrderTotientSum_cast_le_factorizationRankin + (N bound : ℕ) (primeWeight : ℕ → ℚ) (cap : ℚ) + (hprimeWeightNonneg : ∀ prime, 0 ≤ primeWeight prime) + (hprimeWeightPower : + ∀ prime : ℕ, prime.Prime → + 1 ≤ (prime : ℚ) * (primeWeight prime) ^ 12) + (hcapNonneg : 0 ≤ cap) + (hboundCap : (bound : ℚ) ≤ cap ^ 12) + (hN : N ≠ 0) : + (truncatedOrderTotientSum N bound : ℚ) ≤ + (bound : ℚ) * cap * + (N.factorization.prod fun prime exponent => + rankinPrimePowerFactor prime exponent (primeWeight prime)) := by + rw [← weightedTotientDivisorSum_eq_factorizationEulerProduct + N hN primeWeight] + apply truncatedOrderTotientSum_cast_le_weightedRankin + · intro order horder + exact factorizationWeight_nonneg primeWeight hprimeWeightNonneg order + · intro order horder + have horderNe : order ≠ 0 := + ne_zero_of_dvd_ne_zero hN (Nat.mem_divisors.mp horder).1 + exact factorizationWeight_twelfthPower primeWeight + hprimeWeightPower horderNe + · exact hcapNonneg + · exact hboundCap + +end BGS.NumberTheory diff --git a/LeanPool/MarkoffModP/BGS/NumberTheory/WeightedDivisorMoment.lean b/LeanPool/MarkoffModP/BGS/NumberTheory/WeightedDivisorMoment.lean new file mode 100644 index 0000000000..6c961d508d --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/NumberTheory/WeightedDivisorMoment.lean @@ -0,0 +1,751 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.NumberTheory.PreliminaryDivisorBound +public import Mathlib.Tactic.IntervalCases + +/-! +# A weighted twentieth-moment divisor bound + +Squaring the elementary tenth-moment estimate would give +`τ(n)^20 ≤ 2^894 n^2`. That loses the fractional part of every +prime-factor penalty before the square is taken. Charging the doubled +weight directly preserves those fractional parts and gives the stronger +uniform estimate + +`τ(n)^20 ≤ 2^796 n^2`. + +The proof uses the same finite-band induction as the tenth-moment bound. +It does not enumerate integers, factorizations, or neighboring divisor +profiles. +-/ + +@[expose] public section + +namespace BGS.NumberTheory + +open scoped BigOperators + +/-- Tenth-power ratio monotonicity used before squaring the weighted estimate. -/ +private theorem weighted_pow_ten_succ_ratio_le + (base A a : ℕ) (ha : A ≤ a) + (hbase : (A + 2) ^ 10 ≤ base * (A + 1) ^ 10) : + (a + 2) ^ 10 ≤ base * (a + 1) ^ 10 := by + have hlinear : (A + 1) * (a + 2) ≤ (A + 2) * (a + 1) := by + nlinarith + have hpow := Nat.pow_le_pow_left hlinear 10 + have hscaled : + (A + 1) ^ 10 * (a + 2) ^ 10 ≤ + (A + 1) ^ 10 * (base * (a + 1) ^ 10) := by + calc + (A + 1) ^ 10 * (a + 2) ^ 10 = + ((A + 1) * (a + 2)) ^ 10 := by rw [mul_pow] + _ ≤ ((A + 2) * (a + 1)) ^ 10 := hpow + _ = (A + 2) ^ 10 * (a + 1) ^ 10 := by rw [mul_pow] + _ ≤ (base * (A + 1) ^ 10) * (a + 1) ^ 10 := + Nat.mul_le_mul_right _ hbase + _ = (A + 1) ^ 10 * (base * (a + 1) ^ 10) := by ring + exact Nat.le_of_mul_le_mul_left hscaled (by positivity) + +/-- Once the twentieth-power ratio is controlled, it remains controlled +at every later exponent. -/ +private theorem pow_twenty_succ_ratio_le + (base A a : ℕ) (ha : A ≤ a) + (hbase : (A + 2) ^ 20 ≤ base ^ 2 * (A + 1) ^ 20) : + (a + 2) ^ 20 ≤ base ^ 2 * (a + 1) ^ 20 := by + have hbaseTenSq : ((A + 2) ^ 10) ^ 2 ≤ + (base * (A + 1) ^ 10) ^ 2 := by + calc + ((A + 2) ^ 10) ^ 2 = (A + 2) ^ 20 := by + rw [← pow_mul] + _ ≤ base ^ 2 * (A + 1) ^ 20 := hbase + _ = base ^ 2 * ((A + 1) ^ 10) ^ 2 := by + rw [← pow_mul] + _ = (base * (A + 1) ^ 10) ^ 2 := by rw [mul_pow] + have hbaseTen : (A + 2) ^ 10 ≤ base * (A + 1) ^ 10 := + (Nat.pow_le_pow_iff_left (by norm_num : 2 ≠ 0)).mp hbaseTenSq + have hten := weighted_pow_ten_succ_ratio_le base A a ha hbaseTen + have hsq := Nat.pow_le_pow_left hten 2 + calc + (a + 2) ^ 20 = ((a + 2) ^ 10) ^ 2 := by + rw [← pow_mul] + _ ≤ (base * (a + 1) ^ 10) ^ 2 := hsq + _ = base ^ 2 * ((a + 1) ^ 10) ^ 2 := by rw [mul_pow] + _ = base ^ 2 * (a + 1) ^ 20 := by + rw [← pow_mul] + +/-- Induction from a finite threshold for a fixed prime-size band. -/ +private theorem pow_twenty_le_band_of_threshold + (base c A : ℕ) + (hbase : (A + 1) ^ 20 ≤ 2 ^ c * base ^ (2 * A)) + (hratio : (A + 2) ^ 20 ≤ base ^ 2 * (A + 1) ^ 20) + (a : ℕ) (ha : A ≤ a) : + (a + 1) ^ 20 ≤ 2 ^ c * base ^ (2 * a) := by + induction a, ha using Nat.le_induction with + | base => exact hbase + | succ a ha ih => + calc + (a + 1 + 1) ^ 20 ≤ base ^ 2 * (a + 1) ^ 20 := + pow_twenty_succ_ratio_le base A a ha hratio + _ ≤ base ^ 2 * (2 ^ c * base ^ (2 * a)) := + Nat.mul_le_mul_left _ ih + _ = 2 ^ c * base ^ (2 * (a + 1)) := by + rw [show 2 * (a + 1) = 2 * a + 2 by omega, pow_add] + ring + +private theorem pow_twenty_le_base_two (a : ℕ) : + (a + 1) ^ 20 ≤ 2 ^ 51 * 2 ^ (2 * a) := by + by_cases ha : 13 ≤ a + · simpa using pow_twenty_le_band_of_threshold 2 51 13 + (by norm_num) (by norm_num) a ha + · have ha' : a ≤ 12 := by omega + interval_cases a <;> norm_num + +private theorem pow_twenty_le_base_three (a : ℕ) : + (a + 1) ^ 20 ≤ 2 ^ 39 * 3 ^ (2 * a) := by + by_cases ha : 8 ≤ a + · simpa using pow_twenty_le_band_of_threshold 3 39 8 + (by norm_num) (by norm_num) a ha + · have ha' : a ≤ 7 := by omega + interval_cases a <;> norm_num + +private theorem pow_twenty_le_base_five (a : ℕ) : + (a + 1) ^ 20 ≤ 2 ^ 29 * 5 ^ (2 * a) := by + by_cases ha : 5 ≤ a + · simpa using pow_twenty_le_band_of_threshold 5 29 5 + (by norm_num) (by norm_num) a ha + · have ha' : a ≤ 4 := by omega + interval_cases a <;> norm_num + +private theorem pow_twenty_le_base_seven (a : ℕ) : + (a + 1) ^ 20 ≤ 2 ^ 24 * 7 ^ (2 * a) := by + by_cases ha : 4 ≤ a + · simpa using pow_twenty_le_band_of_threshold 7 24 4 + (by norm_num) (by norm_num) a ha + · have ha' : a ≤ 3 := by omega + interval_cases a <;> norm_num + +private theorem pow_twenty_le_base_eleven (a : ℕ) : + (a + 1) ^ 20 ≤ 2 ^ 20 * 11 ^ (2 * a) := by + by_cases ha : 3 ≤ a + · simpa using pow_twenty_le_band_of_threshold 11 20 3 + (by norm_num) (by norm_num) a ha + · have ha' : a ≤ 2 := by omega + interval_cases a <;> norm_num + +private theorem pow_twenty_le_base_thirteen (a : ℕ) : + (a + 1) ^ 20 ≤ 2 ^ 18 * 13 ^ (2 * a) := by + by_cases ha : 3 ≤ a + · simpa using pow_twenty_le_band_of_threshold 13 18 3 + (by norm_num) (by norm_num) a ha + · have ha' : a ≤ 2 := by omega + interval_cases a <;> norm_num + +private theorem pow_twenty_le_base_seventeen (a : ℕ) : + (a + 1) ^ 20 ≤ 2 ^ 16 * 17 ^ (2 * a) := by + by_cases ha : 3 ≤ a + · simpa using pow_twenty_le_band_of_threshold 17 16 3 + (by norm_num) (by norm_num) a ha + · have ha' : a ≤ 2 := by omega + interval_cases a <;> norm_num + +private theorem pow_twenty_le_base_nineteen (a : ℕ) : + (a + 1) ^ 20 ≤ 2 ^ 15 * 19 ^ (2 * a) := by + by_cases ha : 2 ≤ a + · simpa using pow_twenty_le_band_of_threshold 19 15 2 + (by norm_num) (by norm_num) a ha + · have ha' : a ≤ 1 := by omega + interval_cases a <;> norm_num + +private theorem pow_twenty_le_base_twentyThree (a : ℕ) : + (a + 1) ^ 20 ≤ 2 ^ 14 * 23 ^ (2 * a) := by + by_cases ha : 2 ≤ a + · simpa using pow_twenty_le_band_of_threshold 23 14 2 + (by norm_num) (by norm_num) a ha + · have ha' : a ≤ 1 := by omega + interval_cases a <;> norm_num + +private theorem pow_twenty_le_base_twentyNine (a : ℕ) : + (a + 1) ^ 20 ≤ 2 ^ 13 * 29 ^ (2 * a) := by + by_cases ha : 2 ≤ a + · simpa using pow_twenty_le_band_of_threshold 29 13 2 + (by norm_num) (by norm_num) a ha + · have ha' : a ≤ 1 := by omega + interval_cases a <;> norm_num + +private theorem pow_twenty_le_base_thirtyOne (a : ℕ) : + (a + 1) ^ 20 ≤ 2 ^ 12 * 31 ^ (2 * a) := by + by_cases ha : 2 ≤ a + · simpa using pow_twenty_le_band_of_threshold 31 12 2 + (by norm_num) (by norm_num) a ha + · have ha' : a ≤ 1 := by omega + interval_cases a <;> norm_num + +private theorem pow_twenty_le_base_thirtySeven (a : ℕ) : + (a + 1) ^ 20 ≤ 2 ^ 11 * 37 ^ (2 * a) := by + by_cases ha : 2 ≤ a + · simpa using pow_twenty_le_band_of_threshold 37 11 2 + (by norm_num) (by norm_num) a ha + · have ha' : a ≤ 1 := by omega + interval_cases a <;> norm_num + +private theorem pow_twenty_le_base_fortyThree (a : ℕ) : + (a + 1) ^ 20 ≤ 2 ^ 10 * 43 ^ (2 * a) := by + by_cases ha : 2 ≤ a + · simpa using pow_twenty_le_band_of_threshold 43 10 2 + (by norm_num) (by norm_num) a ha + · have ha' : a ≤ 1 := by omega + interval_cases a <;> norm_num + +private theorem pow_twenty_le_base_fiftyThree (a : ℕ) : + (a + 1) ^ 20 ≤ 2 ^ 9 * 53 ^ (2 * a) := by + by_cases ha : 2 ≤ a + · simpa using pow_twenty_le_band_of_threshold 53 9 2 + (by norm_num) (by norm_num) a ha + · have ha' : a ≤ 1 := by omega + interval_cases a <;> norm_num + +private theorem pow_twenty_le_base_sixtySeven (a : ℕ) : + (a + 1) ^ 20 ≤ 2 ^ 8 * 67 ^ (2 * a) := by + by_cases ha : 1 ≤ a + · simpa using pow_twenty_le_band_of_threshold 67 8 1 + (by norm_num) (by norm_num) a ha + · have ha' : a ≤ 0 := by omega + interval_cases a + norm_num + +private theorem pow_twenty_le_base_ninetySeven (a : ℕ) : + (a + 1) ^ 20 ≤ 2 ^ 7 * 97 ^ (2 * a) := by + by_cases ha : 1 ≤ a + · simpa using pow_twenty_le_band_of_threshold 97 7 1 + (by norm_num) (by norm_num) a ha + · have ha' : a ≤ 0 := by omega + interval_cases a + norm_num + +private theorem pow_twenty_le_base_oneHundredThirtyOne (a : ℕ) : + (a + 1) ^ 20 ≤ 2 ^ 6 * 131 ^ (2 * a) := by + by_cases ha : 1 ≤ a + · simpa using pow_twenty_le_band_of_threshold 131 6 1 + (by norm_num) (by norm_num) a ha + · have ha' : a ≤ 0 := by omega + interval_cases a + norm_num + +private theorem pow_twenty_le_base_oneHundredNinetyOne (a : ℕ) : + (a + 1) ^ 20 ≤ 2 ^ 5 * 191 ^ (2 * a) := by + by_cases ha : 1 ≤ a + · simpa using pow_twenty_le_band_of_threshold 191 5 1 + (by norm_num) (by norm_num) a ha + · have ha' : a ≤ 0 := by omega + interval_cases a + norm_num + +private theorem pow_twenty_le_base_twoHundredFiftySeven (a : ℕ) : + (a + 1) ^ 20 ≤ 2 ^ 4 * 257 ^ (2 * a) := by + by_cases ha : 1 ≤ a + · simpa using pow_twenty_le_band_of_threshold 257 4 1 + (by norm_num) (by norm_num) a ha + · have ha' : a ≤ 0 := by omega + interval_cases a + norm_num + +private theorem pow_twenty_le_base_threeHundredSixtySeven (a : ℕ) : + (a + 1) ^ 20 ≤ 2 ^ 3 * 367 ^ (2 * a) := by + by_cases ha : 1 ≤ a + · simpa using pow_twenty_le_band_of_threshold 367 3 1 + (by norm_num) (by norm_num) a ha + · have ha' : a ≤ 0 := by omega + interval_cases a + norm_num + +private theorem pow_twenty_le_base_fiveHundredTwentyOne (a : ℕ) : + (a + 1) ^ 20 ≤ 2 ^ 2 * 521 ^ (2 * a) := by + by_cases ha : 1 ≤ a + · simpa using pow_twenty_le_band_of_threshold 521 2 1 + (by norm_num) (by norm_num) a ha + · have ha' : a ≤ 0 := by omega + interval_cases a + norm_num + +private theorem pow_twenty_le_base_sevenHundredTwentySeven (a : ℕ) : + (a + 1) ^ 20 ≤ 2 * 727 ^ (2 * a) := by + by_cases ha : 1 ≤ a + · simpa using pow_twenty_le_band_of_threshold 727 1 1 + (by norm_num) (by norm_num) a ha + · have ha' : a ≤ 0 := by omega + interval_cases a + norm_num + +private theorem pow_twenty_le_base_oneThousandTwentyFour (a : ℕ) : + (a + 1) ^ 20 ≤ 1024 ^ (2 * a) := by + simpa using pow_twenty_le_band_of_threshold 1024 0 0 + (by norm_num) (by norm_num) a (Nat.zero_le a) + +/-- The exact integer penalty bands for the weight pair `(20, 2)`. -/ +def weightedPrimePenaltyTwenty (p : ℕ) : ℕ := + if p < 3 then 51 + else if p < 5 then 39 + else if p < 7 then 29 + else if p < 11 then 24 + else if p < 13 then 20 + else if p < 17 then 18 + else if p < 19 then 16 + else if p < 23 then 15 + else if p < 29 then 14 + else if p < 31 then 13 + else if p < 37 then 12 + else if p < 43 then 11 + else if p < 53 then 10 + else if p < 67 then 9 + else if p < 97 then 8 + else if p < 131 then 7 + else if p < 191 then 6 + else if p < 257 then 5 + else if p < 367 then 4 + else if p < 521 then 3 + else if p < 727 then 2 + else if p < 1024 then 1 + else 0 + +private theorem weightedPrimePenaltyTwenty_eq_zero_of_le + {p : ℕ} (hp : 1024 ≤ p) : + weightedPrimePenaltyTwenty p = 0 := by + simp [weightedPrimePenaltyTwenty, + show ¬p < 3 by omega, show ¬p < 5 by omega, + show ¬p < 7 by omega, show ¬p < 11 by omega, + show ¬p < 13 by omega, show ¬p < 17 by omega, + show ¬p < 19 by omega, show ¬p < 23 by omega, + show ¬p < 29 by omega, show ¬p < 31 by omega, + show ¬p < 37 by omega, show ¬p < 43 by omega, + show ¬p < 53 by omega, show ¬p < 67 by omega, + show ¬p < 97 by omega, show ¬p < 131 by omega, + show ¬p < 191 by omega, show ¬p < 257 by omega, + show ¬p < 367 by omega, show ¬p < 521 by omega, + show ¬p < 727 by omega, show ¬p < 1024 by omega] + +private theorem pow_twenty_le_of_base_le + {base p c a : ℕ} + (h : (a + 1) ^ 20 ≤ 2 ^ c * base ^ (2 * a)) + (hbase : base ≤ p) : + (a + 1) ^ 20 ≤ 2 ^ c * p ^ (2 * a) := + h.trans (Nat.mul_le_mul_left _ (Nat.pow_le_pow_left hbase _)) + +/-- Factorwise twentieth-moment estimate for the doubled number weight. -/ +private theorem factorization_succ_pow_twenty_le_large + {p a : ℕ} (hp257 : ¬p < 257) : + (a + 1) ^ 20 ≤ + 2 ^ weightedPrimePenaltyTwenty p * p ^ (2 * a) := by + have hp3 : ¬p < 3 := by omega + have hp5 : ¬p < 5 := by omega + have hp7 : ¬p < 7 := by omega + have hp11 : ¬p < 11 := by omega + have hp13 : ¬p < 13 := by omega + have hp17 : ¬p < 17 := by omega + have hp19 : ¬p < 19 := by omega + have hp23 : ¬p < 23 := by omega + have hp29 : ¬p < 29 := by omega + have hp31 : ¬p < 31 := by omega + have hp37 : ¬p < 37 := by omega + have hp43 : ¬p < 43 := by omega + have hp53 : ¬p < 53 := by omega + have hp67 : ¬p < 67 := by omega + have hp97 : ¬p < 97 := by omega + have hp131 : ¬p < 131 := by omega + have hp191 : ¬p < 191 := by omega + by_cases hp367 : p < 367 + · have hpLower : 257 ≤ p := by omega + simp only [weightedPrimePenaltyTwenty, + ite_eq_right hp3, ite_eq_right hp5, ite_eq_right hp7, + ite_eq_right hp11, ite_eq_right hp13, ite_eq_right hp17, + ite_eq_right hp19, ite_eq_right hp23, ite_eq_right hp29, + ite_eq_right hp31, ite_eq_right hp37, ite_eq_right hp43, + ite_eq_right hp53, ite_eq_right hp67, ite_eq_right hp97, + ite_eq_right hp131, ite_eq_right hp191, + ite_eq_right hp257, ite_eq_left hp367] + exact pow_twenty_le_of_base_le + (pow_twenty_le_base_twoHundredFiftySeven a) + hpLower + · by_cases hp521 : p < 521 + · have hpLower : 367 ≤ p := by omega + simp only [weightedPrimePenaltyTwenty, + ite_eq_right hp3, ite_eq_right hp5, ite_eq_right hp7, + ite_eq_right hp11, ite_eq_right hp13, ite_eq_right hp17, + ite_eq_right hp19, ite_eq_right hp23, ite_eq_right hp29, + ite_eq_right hp31, ite_eq_right hp37, ite_eq_right hp43, + ite_eq_right hp53, ite_eq_right hp67, ite_eq_right hp97, + ite_eq_right hp131, ite_eq_right hp191, + ite_eq_right hp257, ite_eq_right hp367, + ite_eq_left hp521] + exact pow_twenty_le_of_base_le + (pow_twenty_le_base_threeHundredSixtySeven a) + hpLower + · by_cases hp727 : p < 727 + · have hpLower : 521 ≤ p := by omega + simp only [weightedPrimePenaltyTwenty, + ite_eq_right hp3, ite_eq_right hp5, ite_eq_right hp7, + ite_eq_right hp11, ite_eq_right hp13, + ite_eq_right hp17, ite_eq_right hp19, + ite_eq_right hp23, ite_eq_right hp29, + ite_eq_right hp31, ite_eq_right hp37, + ite_eq_right hp43, ite_eq_right hp53, + ite_eq_right hp67, ite_eq_right hp97, + ite_eq_right hp131, ite_eq_right hp191, + ite_eq_right hp257, ite_eq_right hp367, + ite_eq_right hp521, ite_eq_left hp727] + exact pow_twenty_le_of_base_le + (pow_twenty_le_base_fiveHundredTwentyOne a) + hpLower + · by_cases hp1024 : p < 1024 + · have hpLower : 727 ≤ p := by omega + simp only [weightedPrimePenaltyTwenty, + ite_eq_right hp3, ite_eq_right hp5, + ite_eq_right hp7, ite_eq_right hp11, + ite_eq_right hp13, ite_eq_right hp17, + ite_eq_right hp19, ite_eq_right hp23, + ite_eq_right hp29, ite_eq_right hp31, + ite_eq_right hp37, ite_eq_right hp43, + ite_eq_right hp53, ite_eq_right hp67, + ite_eq_right hp97, ite_eq_right hp131, + ite_eq_right hp191, ite_eq_right hp257, + ite_eq_right hp367, ite_eq_right hp521, + ite_eq_right hp727, ite_eq_left hp1024] + exact pow_twenty_le_of_base_le + (pow_twenty_le_base_sevenHundredTwentySeven a) + hpLower + · have hpLower : 1024 ≤ p := by omega + simp only [weightedPrimePenaltyTwenty, + ite_eq_right hp3, ite_eq_right hp5, + ite_eq_right hp7, ite_eq_right hp11, + ite_eq_right hp13, ite_eq_right hp17, + ite_eq_right hp19, ite_eq_right hp23, + ite_eq_right hp29, ite_eq_right hp31, + ite_eq_right hp37, ite_eq_right hp43, + ite_eq_right hp53, ite_eq_right hp67, + ite_eq_right hp97, ite_eq_right hp131, + ite_eq_right hp191, ite_eq_right hp257, + ite_eq_right hp367, ite_eq_right hp521, + ite_eq_right hp727, ite_eq_right hp1024, + pow_zero, one_mul] + simpa only [pow_zero, one_mul] using + (pow_twenty_le_of_base_le (c := 0) + (by simpa only [pow_zero, one_mul] using + pow_twenty_le_base_oneThousandTwentyFour a) + hpLower) + +private theorem factorization_succ_pow_twenty_le + {p a : ℕ} (hpPrime : p.Prime) : + (a + 1) ^ 20 ≤ + 2 ^ weightedPrimePenaltyTwenty p * p ^ (2 * a) := by + have hpTwo : 2 ≤ p := hpPrime.two_le + by_cases hp3 : p < 3 + · simp only [weightedPrimePenaltyTwenty, hp3] + exact pow_twenty_le_of_base_le (pow_twenty_le_base_two a) hpTwo + · by_cases hp5 : p < 5 + · have hpLower : 3 ≤ p := by omega + simp only [weightedPrimePenaltyTwenty, hp3, hp5] + exact pow_twenty_le_of_base_le (pow_twenty_le_base_three a) hpLower + · by_cases hp7 : p < 7 + · have hpLower : 5 ≤ p := by omega + simp only [weightedPrimePenaltyTwenty, hp3, hp5, hp7] + exact pow_twenty_le_of_base_le (pow_twenty_le_base_five a) hpLower + · by_cases hp11 : p < 11 + · have hpLower : 7 ≤ p := by omega + simp only [weightedPrimePenaltyTwenty, hp3, hp5, + hp7, hp11] + exact pow_twenty_le_of_base_le (pow_twenty_le_base_seven a) hpLower + · by_cases hp13 : p < 13 + · have hpLower : 11 ≤ p := by omega + simp only [weightedPrimePenaltyTwenty, hp3, hp5, + hp7, hp11, hp13] + exact pow_twenty_le_of_base_le (pow_twenty_le_base_eleven a) hpLower + · by_cases hp17 : p < 17 + · have hpLower : 13 ≤ p := by omega + simp only [weightedPrimePenaltyTwenty, hp3, hp5, + hp7, hp11, hp13, hp17] + exact pow_twenty_le_of_base_le (pow_twenty_le_base_thirteen a) hpLower + · by_cases hp19 : p < 19 + · have hpLower : 17 ≤ p := by omega + simp only [weightedPrimePenaltyTwenty, hp3, hp5, + hp7, hp11, hp13, hp17, hp19] + exact pow_twenty_le_of_base_le + (pow_twenty_le_base_seventeen a) hpLower + · by_cases hp23 : p < 23 + · have hpLower : 19 ≤ p := by omega + simp only [weightedPrimePenaltyTwenty, hp3, hp5, + hp7, hp11, hp13, hp17, + hp19, hp23] + exact pow_twenty_le_of_base_le + (pow_twenty_le_base_nineteen a) hpLower + · by_cases hp29 : p < 29 + · have hpLower : 23 ≤ p := by omega + simp only [weightedPrimePenaltyTwenty, hp3, hp5, + hp7, hp11, hp13, hp17, + hp19, hp23, hp29] + exact pow_twenty_le_of_base_le + (pow_twenty_le_base_twentyThree a) hpLower + · by_cases hp31 : p < 31 + · have hpLower : 29 ≤ p := by omega + simp only [weightedPrimePenaltyTwenty, hp3, hp5, + hp7, hp11, hp13, hp17, + hp19, hp23, hp29, hp31] + exact pow_twenty_le_of_base_le + (pow_twenty_le_base_twentyNine a) hpLower + · by_cases hp37 : p < 37 + · have hpLower : 31 ≤ p := by omega + simp only [weightedPrimePenaltyTwenty, hp3, + hp5, hp7, hp11, hp13, + hp17, hp19, hp23, hp29, + hp31, hp37] + exact pow_twenty_le_of_base_le + (pow_twenty_le_base_thirtyOne a) hpLower + · by_cases hp43 : p < 43 + · have hpLower : 37 ≤ p := by omega + simp only [weightedPrimePenaltyTwenty, hp3, + hp5, hp7, hp11, hp13, + hp17, hp19, hp23, hp29, + hp31, hp37, hp43] + exact pow_twenty_le_of_base_le + (pow_twenty_le_base_thirtySeven a) hpLower + · by_cases hp53 : p < 53 + · have hpLower : 43 ≤ p := by omega + simp only [weightedPrimePenaltyTwenty, hp3, + hp5, hp7, hp11, hp13, + hp17, hp19, hp23, hp29, + hp31, hp37, hp43, hp53] + exact pow_twenty_le_of_base_le + (pow_twenty_le_base_fortyThree a) hpLower + · by_cases hp67 : p < 67 + · have hpLower : 53 ≤ p := by omega + simp only [weightedPrimePenaltyTwenty, hp3, + hp5, hp7, hp11, hp13, + hp17, hp19, hp23, hp29, + hp31, hp37, hp43, hp53, + hp67] + exact pow_twenty_le_of_base_le + (pow_twenty_le_base_fiftyThree a) hpLower + · by_cases hp97 : p < 97 + · have hpLower : 67 ≤ p := by omega + simp only [weightedPrimePenaltyTwenty, hp3, + hp5, hp7, hp11, + hp13, hp17, hp19, + hp23, hp29, hp31, + hp37, hp43, hp53, + hp67, hp97] + exact pow_twenty_le_of_base_le + (pow_twenty_le_base_sixtySeven a) hpLower + · by_cases hp131 : p < 131 + · have hpLower : 97 ≤ p := by omega + simp only [weightedPrimePenaltyTwenty, + hp3, hp5, hp7, + hp11, hp13, hp17, + hp19, hp23, hp29, + hp31, hp37, hp43, + hp53, hp67, hp97, + hp131] + exact pow_twenty_le_of_base_le + (pow_twenty_le_base_ninetySeven a) hpLower + · by_cases hp191 : p < 191 + · have hpLower : 131 ≤ p := by omega + simp only [weightedPrimePenaltyTwenty, + hp3, hp5, hp7, + hp11, hp13, hp17, + hp19, hp23, hp29, + hp31, hp37, hp43, + hp53, hp67, hp97, + hp131, hp191] + exact pow_twenty_le_of_base_le + (pow_twenty_le_base_oneHundredThirtyOne a) + hpLower + · by_cases hp257 : p < 257 + · have hpLower : 191 ≤ p := by omega + simp only [weightedPrimePenaltyTwenty, + hp3, hp5, hp7, + hp11, hp13, hp17, + hp19, hp23, hp29, + hp31, hp37, hp43, + hp53, hp67, hp97, + hp131, hp191, hp257] + exact pow_twenty_le_of_base_le + (pow_twenty_le_base_oneHundredNinetyOne a) + hpLower + · exact factorization_succ_pow_twenty_le_large hp257 + +-- Separate closed computations keep each kernel check within the default limit. +private def weightedPrimePenaltyTwentyBlock (k : ℕ) : ℕ := + ∑ p ∈ Finset.range 64, + if Nat.Prime (k * 64 + p) then weightedPrimePenaltyTwenty (k * 64 + p) else 0 +private theorem weightedPrimePenaltyTwentyBlock_value_0 : + weightedPrimePenaltyTwentyBlock 0 = 320 := by + decide +kernel + +private theorem weightedPrimePenaltyTwentyBlock_value_1 : + weightedPrimePenaltyTwentyBlock 1 = 97 := by + decide +kernel + +private theorem weightedPrimePenaltyTwentyBlock_value_2 : + weightedPrimePenaltyTwentyBlock 2 = 71 := by + decide +kernel + +private theorem weightedPrimePenaltyTwentyBlock_value_3 : + weightedPrimePenaltyTwentyBlock 3 = 55 := by + decide +kernel + +private theorem weightedPrimePenaltyTwentyBlock_value_4 : + weightedPrimePenaltyTwentyBlock 4 = 48 := by + decide +kernel + +private theorem weightedPrimePenaltyTwentyBlock_value_5 : + weightedPrimePenaltyTwentyBlock 5 = 36 := by + decide +kernel + +private theorem weightedPrimePenaltyTwentyBlock_value_6 : + weightedPrimePenaltyTwentyBlock 6 = 30 := by + decide +kernel + +private theorem weightedPrimePenaltyTwentyBlock_value_7 : + weightedPrimePenaltyTwentyBlock 7 = 33 := by + decide +kernel + +private theorem weightedPrimePenaltyTwentyBlock_value_8 : + weightedPrimePenaltyTwentyBlock 8 = 16 := by + decide +kernel + +private theorem weightedPrimePenaltyTwentyBlock_value_9 : + weightedPrimePenaltyTwentyBlock 9 = 20 := by + decide +kernel + +private theorem weightedPrimePenaltyTwentyBlock_value_10 : + weightedPrimePenaltyTwentyBlock 10 = 22 := by + decide +kernel + +private theorem weightedPrimePenaltyTwentyBlock_value_11 : + weightedPrimePenaltyTwentyBlock 11 = 11 := by + decide +kernel + +private theorem weightedPrimePenaltyTwentyBlock_value_12 : + weightedPrimePenaltyTwentyBlock 12 = 10 := by + decide +kernel + +private theorem weightedPrimePenaltyTwentyBlock_value_13 : + weightedPrimePenaltyTwentyBlock 13 = 9 := by + decide +kernel + +private theorem weightedPrimePenaltyTwentyBlock_value_14 : + weightedPrimePenaltyTwentyBlock 14 = 8 := by + decide +kernel + +private theorem weightedPrimePenaltyTwentyBlock_value_15 : + weightedPrimePenaltyTwentyBlock 15 = 10 := by + decide +kernel + +private theorem sum_weightedPrimePenaltyTwenty_blocks (k : ℕ) : + (∑ p ∈ Finset.range (k * 64), if Nat.Prime p then weightedPrimePenaltyTwenty p else 0) = + ∑ i ∈ Finset.range k, weightedPrimePenaltyTwentyBlock i := by + induction k with + | zero => simp + | succ k ih => + rw [Nat.succ_mul, Finset.sum_range_add, ih] + rw [Finset.sum_range_succ (f := weightedPrimePenaltyTwentyBlock)] + rfl + +private theorem sum_weightedPrimePenaltyTwenty_le (n : ℕ) : + ∑ p ∈ n.primeFactors, weightedPrimePenaltyTwenty p ≤ 796 := by + let smallFactors := + n.primeFactors.filter fun p ↦ p < 1024 + let allSmallPrimes := + (Finset.range 1024).filter Nat.Prime + have hsumEq : + (∑ p ∈ smallFactors, weightedPrimePenaltyTwenty p) = + ∑ p ∈ n.primeFactors, weightedPrimePenaltyTwenty p := by + apply Finset.sum_subset (Finset.filter_subset _ _) + intro p hpFactors hpNotSmall + have hpLarge : 1024 ≤ p := by + by_contra hpNotLarge + have hpSmall : p < 1024 := by omega + exact hpNotSmall (Finset.mem_filter.mpr ⟨hpFactors, hpSmall⟩) + exact weightedPrimePenaltyTwenty_eq_zero_of_le hpLarge + have hsubset : smallFactors ⊆ allSmallPrimes := by + intro p hp + have hp' := Finset.mem_filter.mp hp + exact Finset.mem_filter.mpr + ⟨Finset.mem_range.mpr hp'.2, + Nat.prime_of_mem_primeFactors hp'.1⟩ + have hle : + (∑ p ∈ smallFactors, weightedPrimePenaltyTwenty p) ≤ + ∑ p ∈ allSmallPrimes, weightedPrimePenaltyTwenty p := + Finset.sum_le_sum_of_subset_of_nonneg hsubset + (fun _ _ _ ↦ Nat.zero_le _) + have htotal : + (∑ p ∈ allSmallPrimes, weightedPrimePenaltyTwenty p) ≤ 796 := by + apply le_of_eq + rw [Finset.sum_filter] + change (∑ p ∈ Finset.range (16 * 64), + if Nat.Prime p then weightedPrimePenaltyTwenty p else 0) = _ + rw [sum_weightedPrimePenaltyTwenty_blocks] + simp only [Finset.sum_range_succ, Finset.sum_range_zero] + rw [weightedPrimePenaltyTwentyBlock_value_0, weightedPrimePenaltyTwentyBlock_value_1, + weightedPrimePenaltyTwentyBlock_value_2, + weightedPrimePenaltyTwentyBlock_value_3, + weightedPrimePenaltyTwentyBlock_value_4, + weightedPrimePenaltyTwentyBlock_value_5, + weightedPrimePenaltyTwentyBlock_value_6, + weightedPrimePenaltyTwentyBlock_value_7, + weightedPrimePenaltyTwentyBlock_value_8, + weightedPrimePenaltyTwentyBlock_value_9, + weightedPrimePenaltyTwentyBlock_value_10, + weightedPrimePenaltyTwentyBlock_value_11, + weightedPrimePenaltyTwentyBlock_value_12, + weightedPrimePenaltyTwentyBlock_value_13, + weightedPrimePenaltyTwentyBlock_value_14, + weightedPrimePenaltyTwentyBlock_value_15] + rw [← hsumEq] + exact hle.trans htotal + +private theorem card_divisors_pow_twenty_le_of_penalty_bound + (n bound : ℕ) (hn : n ≠ 0) + (hbound : (∑ p ∈ n.primeFactors, weightedPrimePenaltyTwenty p) ≤ bound) : + n.divisors.card ^ 20 ≤ 2 ^ bound * n ^ 2 := by + rw [Nat.card_divisors hn, ← Finset.prod_pow] + have hfactor : + (∏ p ∈ n.primeFactors, (n.factorization p + 1) ^ 20) ≤ + ∏ p ∈ n.primeFactors, + (2 ^ weightedPrimePenaltyTwenty p * p ^ (2 * n.factorization p)) := + Finset.prod_le_prod + (fun p hp ↦ factorization_succ_pow_twenty_le + (Nat.prime_of_mem_primeFactors hp)) + have hproduct : + (∏ p ∈ n.primeFactors, + (2 ^ weightedPrimePenaltyTwenty p * p ^ (2 * n.factorization p))) = + 2 ^ (∑ p ∈ n.primeFactors, weightedPrimePenaltyTwenty p) * n ^ 2 := by + rw [Finset.prod_mul_distrib, Finset.prod_pow_eq_pow_sum] + congr 1 + calc + (∏ p ∈ n.primeFactors, p ^ (2 * n.factorization p)) = + ∏ p ∈ n.primeFactors, (p ^ n.factorization p) ^ 2 := by + apply Finset.prod_congr rfl + intro p hp + rw [show 2 * n.factorization p = n.factorization p * 2 by omega, pow_mul] + _ = (∏ p ∈ n.primeFactors, p ^ n.factorization p) ^ 2 := by + exact Finset.prod_pow n.primeFactors 2 (fun p => p ^ n.factorization p) + _ = n ^ 2 := by rw [← Nat.prod_primeFactors_pow_factorization hn] + have hpower : (2 : ℕ) ^ (∑ p ∈ n.primeFactors, weightedPrimePenaltyTwenty p) ≤ + 2 ^ bound := Nat.pow_le_pow_right (n := 2) + (i := ∑ p ∈ n.primeFactors, weightedPrimePenaltyTwenty p) (j := bound) + (by decide) hbound + exact (hfactor.trans_eq hproduct).trans (Nat.mul_le_mul_right (n ^ 2) hpower) + +/-- Weighted elementary divisor estimate: +`τ(n)^20 ≤ 2^796 n^2`. -/ +theorem card_divisors_pow_twenty_le_weighted_constant_mul_sq + (n : ℕ) (hn : n ≠ 0) : + n.divisors.card ^ 20 ≤ 2 ^ 796 * n ^ 2 := + card_divisors_pow_twenty_le_of_penalty_bound n 796 hn + (sum_weightedPrimePenaltyTwenty_le n) + +end BGS.NumberTheory diff --git a/LeanPool/MarkoffModP/BGS/NumberTheory/WeightedNeighborDivisorBound.lean b/LeanPool/MarkoffModP/BGS/NumberTheory/WeightedNeighborDivisorBound.lean new file mode 100644 index 0000000000..6731181bef --- /dev/null +++ b/LeanPool/MarkoffModP/BGS/NumberTheory/WeightedNeighborDivisorBound.lean @@ -0,0 +1,255 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.NumberTheory.JointNeighborDivisorBound +public import LeanPool.MarkoffModP.BGS.NumberTheory.WeightedDivisorMoment + +/-! +# A weighted joint divisor bound for neighboring integers + +The weighted divisor estimate `τ(n)^20 ≤ 2^796 n^2` retains substantially +more information than the square of the tenth-moment bound. For the +neighboring even integers `p - 1` and `p + 1`, their exact gcd-two identity +also controls the product of their divisor counts. Splitting into balanced +and dominant cases then gives a twentieth moment for their sum whose leading +constant is still `2^796`. +-/ + +@[expose] public section + +namespace BGS.NumberTheory + +/-- The product of the two neighboring divisor counts has only one weighted +prime-penalty factor in its twentieth moment. -/ +theorem card_divisors_pred_mul_card_divisors_succ_pow_twenty_le + {p : ℕ} (hp : Odd p) (hpTwo : 2 < p) : + ((p - 1).divisors.card * (p + 1).divisors.card) ^ 20 ≤ + 2 ^ 814 * (p ^ 2 - 1) ^ 2 := by + let core := (p ^ 2 - 1) / 2 + have hpSq : 9 ≤ p ^ 2 := by nlinarith + have hcorePos : 0 < core := by + apply Nat.div_pos + · omega + · norm_num + have hmoment := + card_divisors_pow_twenty_le_weighted_constant_mul_sq + core hcorePos.ne' + have htwiceCore : 2 * core = p ^ 2 - 1 := by + rcases hp with ⟨k, rfl⟩ + dsimp [core] + have hsquare : + (2 * k + 1) ^ 2 = 2 * (2 * k * (k + 1)) + 1 := by ring + rw [hsquare] + omega + calc + ((p - 1).divisors.card * (p + 1).divisors.card) ^ 20 = + (2 * core.divisors.card) ^ 20 := by + rw [card_divisors_pred_mul_card_divisors_succ_of_odd hp] + _ = 2 ^ 20 * core.divisors.card ^ 20 := by rw [mul_pow] + _ ≤ 2 ^ 20 * (2 ^ 796 * core ^ 2) := + Nat.mul_le_mul_left _ hmoment + _ = 2 ^ 816 * core ^ 2 := by + rw [show (816 : ℕ) = 20 + 796 by norm_num, pow_add] + ring + _ = 2 ^ 814 * (2 * core) ^ 2 := by + rw [show (816 : ℕ) = 814 + 2 by norm_num, pow_add] + norm_num + ring + _ = 2 ^ 814 * (p ^ 2 - 1) ^ 2 := by rw [htwiceCore] + +/-- Square-root form of the weighted joint product moment. -/ +theorem card_divisors_pred_mul_card_divisors_succ_pow_ten_weighted_le + {p : ℕ} (hp : Odd p) (hpTwo : 2 < p) : + ((p - 1).divisors.card * (p + 1).divisors.card) ^ 10 ≤ + 2 ^ 407 * p ^ 2 := by + apply (Nat.pow_le_pow_iff_left (by norm_num : 2 ≠ 0)).mp + have htwo : (2 ^ 407) ^ 2 = 2 ^ 814 := by + rw [← pow_mul] + calc + (((p - 1).divisors.card * (p + 1).divisors.card) ^ 10) ^ 2 = + ((p - 1).divisors.card * (p + 1).divisors.card) ^ 20 := by + rw [← pow_mul] + _ ≤ 2 ^ 814 * (p ^ 2 - 1) ^ 2 := + card_divisors_pred_mul_card_divisors_succ_pow_twenty_le hp hpTwo + _ ≤ 2 ^ 814 * (p ^ 2) ^ 2 := + Nat.mul_le_mul_left _ (Nat.pow_le_pow_left (by omega) 2) + _ = (2 ^ 407 * p ^ 2) ^ 2 := by rw [mul_pow, htwo] + +/-- Joint weighted twentieth-moment constant for the sum of the neighboring +divisor counts. -/ +def neighboringDivisorSumWeightedMomentConstant : ℕ := + 2 ^ 796 + 2 ^ 781 + +theorem neighboringDivisorSumWeightedMomentConstant_eq : + neighboringDivisorSumWeightedMomentConstant = 2 ^ 781 * 32769 := by + decide +kernel + +private def neighboringDivisorSumWeightedSplit : ℕ := + 716198 + +private theorem neighboringDivisorSumWeighted_balanced_constant : + (neighboringDivisorSumWeightedSplit + 1) ^ 20 * 2 ^ 407 ≤ + neighboringDivisorSumWeightedMomentConstant := by + decide +kernel + +private theorem neighboringDivisorSumWeighted_dominant_constant + {p : ℕ} (hp : 794039 ≤ p) : + (neighboringDivisorSumWeightedSplit + 1) ^ 20 * 2 ^ 796 * + (p + 1) ^ 2 ≤ + neighboringDivisorSumWeightedSplit ^ 20 * + neighboringDivisorSumWeightedMomentConstant * p ^ 2 := by + let R := neighboringDivisorSumWeightedSplit + let K := 2 ^ 796 + let D := neighboringDivisorSumWeightedMomentConstant + let P := 794039 + have hground : + (R + 1) ^ 20 * K * (P + 1) ^ 2 ≤ + R ^ 20 * D * P ^ 2 := by + decide +kernel + have hlinear : P * (p + 1) ≤ (P + 1) * p := by + dsimp [P] + omega + have hratioPow := + Nat.pow_le_pow_left hlinear 2 + have hratio : + P ^ 2 * (p + 1) ^ 2 ≤ (P + 1) ^ 2 * p ^ 2 := by + simpa only [mul_pow] using hratioPow + have hcombined : + P ^ 2 * ((R + 1) ^ 20 * K * (p + 1) ^ 2) ≤ + P ^ 2 * (R ^ 20 * D * p ^ 2) := by + calc + P ^ 2 * ((R + 1) ^ 20 * K * (p + 1) ^ 2) = + ((R + 1) ^ 20 * K) * (P ^ 2 * (p + 1) ^ 2) := by ring + _ ≤ ((R + 1) ^ 20 * K) * ((P + 1) ^ 2 * p ^ 2) := + Nat.mul_le_mul_left _ hratio + _ = ((R + 1) ^ 20 * K * (P + 1) ^ 2) * p ^ 2 := by ring + _ ≤ (R ^ 20 * D * P ^ 2) * p ^ 2 := + Nat.mul_le_mul_right _ hground + _ = P ^ 2 * (R ^ 20 * D * p ^ 2) := by ring + exact Nat.le_of_mul_le_mul_left hcombined (pow_pos (by norm_num : 0 < P) 2) + +private theorem nat_le_of_pos_mul_le_mul_left_weighted + {c x y : ℕ} (hc : 0 < c) (h : c * x ≤ c * y) : + x ≤ y := + Nat.le_of_mul_le_mul_left h hc + +/-- Weighted joint twentieth moment for the sum of the neighboring divisor +counts. Comparable counts are controlled by their product; a dominant count +is controlled by its individual weighted moment. -/ +theorem card_divisors_pred_add_card_divisors_succ_pow_twenty_le + {p : ℕ} (hp : Odd p) (hpLarge : 794039 ≤ p) : + ((p - 1).divisors.card + (p + 1).divisors.card) ^ 20 ≤ + neighboringDivisorSumWeightedMomentConstant * p ^ 2 := by + let a := (p - 1).divisors.card + let b := (p + 1).divisors.card + let R := neighboringDivisorSumWeightedSplit + let K := 2 ^ 796 + let D := neighboringDivisorSumWeightedMomentConstant + have hpTwo : 2 < p := by omega + have hminus : a ^ 20 ≤ K * (p - 1) ^ 2 := by + simpa [a, K] using + card_divisors_pow_twenty_le_weighted_constant_mul_sq + (p - 1) (by omega) + have hplus : b ^ 20 ≤ K * (p + 1) ^ 2 := by + simpa [b, K] using + card_divisors_pow_twenty_le_weighted_constant_mul_sq + (p + 1) (by omega) + have hminusCommon : a ^ 20 ≤ K * (p + 1) ^ 2 := + hminus.trans (Nat.mul_le_mul_left K + (Nat.pow_le_pow_left (by omega) 2)) + have hproductTen : (a * b) ^ 10 ≤ 2 ^ 407 * p ^ 2 := by + simpa [a, b] using + card_divisors_pred_mul_card_divisors_succ_pow_ten_weighted_le hp hpTwo + have hbalanced : (R + 1) ^ 20 * 2 ^ 407 ≤ D := by + simpa [R, D] using neighboringDivisorSumWeighted_balanced_constant + have hRPos : 0 < R := by + norm_num [R, neighboringDivisorSumWeightedSplit] + have hRpowPos : 0 < R ^ 20 := pow_pos hRPos 20 + have hdominant : + (R + 1) ^ 20 * K * (p + 1) ^ 2 ≤ R ^ 20 * D * p ^ 2 := by + simpa [R, K, D] using + neighboringDivisorSumWeighted_dominant_constant hpLarge + rcases le_total a b with hab | hba + · by_cases hfar : R * a ≤ b + · have hlinear : R * (a + b) ≤ (R + 1) * b := by + calc + R * (a + b) = R * a + R * b := by ring + _ ≤ b + R * b := Nat.add_le_add_right hfar _ + _ = (R + 1) * b := by ring + have hpow := Nat.pow_le_pow_left hlinear 20 + have hscaled : + R ^ 20 * (a + b) ^ 20 ≤ R ^ 20 * (D * p ^ 2) := by + calc + R ^ 20 * (a + b) ^ 20 = (R * (a + b)) ^ 20 := by ring + _ ≤ ((R + 1) * b) ^ 20 := hpow + _ = (R + 1) ^ 20 * b ^ 20 := by ring + _ ≤ (R + 1) ^ 20 * (K * (p + 1) ^ 2) := + Nat.mul_le_mul_left _ hplus + _ = (R + 1) ^ 20 * K * (p + 1) ^ 2 := by ring + _ ≤ R ^ 20 * (D * p ^ 2) := by + simpa only [Nat.mul_assoc] using hdominant + exact nat_le_of_pos_mul_le_mul_left_weighted + (c := R ^ 20) (x := (a + b) ^ 20) (y := D * p ^ 2) + hRpowPos hscaled + · have hnear : b ≤ R * a := by omega + have hlinear : a + b ≤ (R + 1) * a := by + calc + a + b ≤ a + R * a := Nat.add_le_add_left hnear _ + _ = (R + 1) * a := by ring + have haa : a * a ≤ a * b := Nat.mul_le_mul_left a hab + calc + (a + b) ^ 20 ≤ ((R + 1) * a) ^ 20 := + Nat.pow_le_pow_left hlinear 20 + _ = (R + 1) ^ 20 * (a * a) ^ 10 := by ring + _ ≤ (R + 1) ^ 20 * (a * b) ^ 10 := + Nat.mul_le_mul_left _ (Nat.pow_le_pow_left haa 10) + _ ≤ (R + 1) ^ 20 * (2 ^ 407 * p ^ 2) := + Nat.mul_le_mul_left _ hproductTen + _ = ((R + 1) ^ 20 * 2 ^ 407) * p ^ 2 := by ring + _ ≤ D * p ^ 2 := Nat.mul_le_mul_right (p ^ 2) hbalanced + · by_cases hfar : R * b ≤ a + · have hlinear : R * (a + b) ≤ (R + 1) * a := by + calc + R * (a + b) = R * a + R * b := by ring + _ = R * b + R * a := by ring + _ ≤ a + R * a := Nat.add_le_add_right hfar _ + _ = (R + 1) * a := by ring + have hpow := Nat.pow_le_pow_left hlinear 20 + have hscaled : + R ^ 20 * (a + b) ^ 20 ≤ R ^ 20 * (D * p ^ 2) := by + calc + R ^ 20 * (a + b) ^ 20 = (R * (a + b)) ^ 20 := by ring + _ ≤ ((R + 1) * a) ^ 20 := hpow + _ = (R + 1) ^ 20 * a ^ 20 := by ring + _ ≤ (R + 1) ^ 20 * (K * (p + 1) ^ 2) := + Nat.mul_le_mul_left _ hminusCommon + _ = (R + 1) ^ 20 * K * (p + 1) ^ 2 := by ring + _ ≤ R ^ 20 * (D * p ^ 2) := by + simpa only [Nat.mul_assoc] using hdominant + exact nat_le_of_pos_mul_le_mul_left_weighted + (c := R ^ 20) (x := (a + b) ^ 20) (y := D * p ^ 2) + hRpowPos hscaled + · have hnear : a ≤ R * b := by omega + have hlinear : a + b ≤ (R + 1) * b := by + calc + a + b ≤ R * b + b := Nat.add_le_add_right hnear _ + _ = (R + 1) * b := by ring + have hbb : b * b ≤ a * b := by + simpa [Nat.mul_comm] using Nat.mul_le_mul_left b hba + calc + (a + b) ^ 20 ≤ ((R + 1) * b) ^ 20 := + Nat.pow_le_pow_left hlinear 20 + _ = (R + 1) ^ 20 * (b * b) ^ 10 := by ring + _ ≤ (R + 1) ^ 20 * (a * b) ^ 10 := + Nat.mul_le_mul_left _ (Nat.pow_le_pow_left hbb 10) + _ ≤ (R + 1) ^ 20 * (2 ^ 407 * p ^ 2) := + Nat.mul_le_mul_left _ hproductTen + _ = ((R + 1) ^ 20 * 2 ^ 407) * p ^ 2 := by ring + _ ≤ D * p ^ 2 := Nat.mul_le_mul_right (p ^ 2) hbalanced + +end BGS.NumberTheory diff --git a/LeanPool/MarkoffModP/Comparator/Solution.lean b/LeanPool/MarkoffModP/Comparator/Solution.lean new file mode 100644 index 0000000000..28e30870bc --- /dev/null +++ b/LeanPool/MarkoffModP/Comparator/Solution.lean @@ -0,0 +1,35 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +public import LeanPool.MarkoffModP.BGS.Markoff.Assembly.ReductionSurjectivity + +@[expose] public section + +namespace Challenge + +abbrev MarkoffNat := + {⟨x, y, z⟩ : ℕ × ℕ × ℕ | x ^ 2 + y ^ 2 + z ^ 2 = 3 * x * y * z} + +abbrev MarkoffModp (p : ℕ) := + {⟨x, y, z⟩ : ZMod p × ZMod p × ZMod p | x ^ 2 + y ^ 2 + z ^ 2 = 3 * x * y * z} + +abbrev markoffNatToModp (p : ℕ) : MarkoffNat → MarkoffModp p := + fun ⟨⟨x, y, z⟩, h⟩ ↦ ⟨⟨x, y, z⟩, by simpa using congrArg (fun n : ℕ ↦ (n : ZMod p)) h⟩ + +theorem markoff_reduction_surjective_of_large_prime : + let p₀ := 35721 ^ 5 * 2 ^ 1547 * 32769 ^ 2 + 1 + ∀ (p : ℕ), p.Prime → p₀ ≤ p → Function.Surjective (markoffNatToModp p) := by + dsimp only + intro p hpPrime hp y + obtain ⟨x, hx⟩ := + BGS.Markoff.reduction_surjective_of_explicitBound p hpPrime hp y + refine ⟨x, ?_⟩ + apply Subtype.ext + exact congrArg Subtype.val hx + +end Challenge diff --git a/LeanPool/MarkoffModP/RiemannRoch/AdeleSpace/Basic.lean b/LeanPool/MarkoffModP/RiemannRoch/AdeleSpace/Basic.lean new file mode 100644 index 0000000000..c36d7145d0 --- /dev/null +++ b/LeanPool/MarkoffModP/RiemannRoch/AdeleSpace/Basic.lean @@ -0,0 +1,247 @@ +/- +Copyright (c) 2026 Guanghao Li. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Guanghao Li +-/ + +module + +public import LeanPool.MarkoffModP.RiemannRoch.RRspace.Basic +public import Mathlib.Algebra.Module.MinimalAxioms +public import Mathlib.LinearAlgebra.Quotient.Basic +public import Mathlib.RingTheory.DedekindDomain.FiniteAdeleRing + +/-! +# K-valued adele space of a function field +Definitions and basic structure for Stichtenoth's adele space. +-/ + +@[expose] public section + +open scoped nonZeroDivisors Polynomial RatFunc WithZero +open Filter + +noncomputable section + +namespace FunctionField.Chart + +variable (k K : Type*) [Field k] [Field K] + +variable [Algebra k K] [Algebra k[X] K] [Algebra k⟮X⟯ K] [IsScalarTower k k[X] K] + [IsScalarTower k[X] k⟮X⟯ K] [_root_.FunctionField k K] + [Algebra.IsSeparable k⟮X⟯ K] + +/-- The classical decidable equality on `k(X)` used by the coordinate places. -/ +local instance instDecidableEqRatFuncAdele : DecidableEq k⟮X⟯ := Classical.decEq _ +/-- The classical decidable equality on coordinate places used for adele surgery. -/ +local instance instDecidableEqPlaceAAdele : DecidableEq (PlaceA k K) := Classical.decEq _ + +/-- The `k`-submodule of the full product consisting of tuples integral at all but finitely many +places. -/ +def adeleSubmodule : Submodule k (PlaceA k K → K) where + carrier := {α | ∀ᶠ v in cofinite, α v ∈ placeValuationSubring k K v} + zero_mem' := by simp + add_mem' {a b} ha hb := by + change ∀ᶠ v in cofinite, a v ∈ placeValuationSubring k K v at ha + change ∀ᶠ v in cofinite, b v ∈ placeValuationSubring k K v at hb + change ∀ᶠ v in cofinite, (a + b) v ∈ placeValuationSubring k K v + exact (ha.and hb).mono fun _ h => add_mem h.1 h.2 + smul_mem' c a ha := by + change ∀ᶠ v in cofinite, a v ∈ placeValuationSubring k K v at ha + change ∀ᶠ v in cofinite, (c • a) v ∈ placeValuationSubring k K v + filter_upwards [ha] with v hv + rw [Pi.smul_apply, Algebra.smul_def] + exact mul_mem (by + change placeValuation k K v (algebraMap k K c) ≤ 1 + exact placeValuation_algebraMap_le_one k K v c) hv + +omit [Algebra k K] [IsScalarTower k k[X] K] in +/-- Every element of `K` is integral at all but finitely many coordinate places. -/ +theorem eventually_mem_placeValuationSubring (f : K) : + ∀ᶠ v : PlaceA k K in cofinite, f ∈ placeValuationSubring k K v := by + rw [Filter.eventually_cofinite] + refine ((IsDedekindDomain.HeightOneSpectrum.Support.finite + (R := ringOfIntegers k K) f).image Sum.inl).union + ((IsDedekindDomain.HeightOneSpectrum.Support.finite + (R := infiniteIntegers k K) f).image Sum.inr) |>.subset ?_ + intro v hv + rcases v with v | v + · left + refine ⟨v, ?_, rfl⟩ + simpa [IsDedekindDomain.HeightOneSpectrum.Support, placeValuationSubring, + placeValuation, not_le] using hv + · right + refine ⟨v, ?_, rfl⟩ + simpa [IsDedekindDomain.HeightOneSpectrum.Support, placeValuationSubring, + placeValuation, not_le] using hv + +/-- The K-valued adele space `A_K = Πʳ_{v} [K, O_v]`. -/ +abbrev AdeleSpace := adeleSubmodule k K + +/-- Pointwise multiplication of an adele by an element of `K`. -/ +def smulAdele (x : K) (a : AdeleSpace k K) : AdeleSpace k K := ⟨fun v => x * a.val v, by + have hx := eventually_mem_placeValuationSubring k K x + have ha := a.property + change ∀ᶠ v : PlaceA k K in cofinite, a.val v ∈ placeValuationSubring k K v at ha + change ∀ᶠ v : PlaceA k K in cofinite, x * a.val v ∈ placeValuationSubring k K v + exact (hx.and ha).mono fun _ h => mul_mem h.1 h.2⟩ + +instance : SMul K (AdeleSpace k K) := ⟨smulAdele k K⟩ + +instance : Module K (AdeleSpace k K) := + Module.ofMinimalAxioms + (fun _ _ _ => Subtype.ext <| funext fun _ => mul_add _ _ _) + (fun _ _ _ => Subtype.ext <| funext fun _ => add_mul _ _ _) + (fun _ _ _ => Subtype.ext <| funext fun _ => mul_assoc _ _ _) + (fun _ => Subtype.ext <| funext fun _ => one_mul _) + +/-- Multiplication by `x ∈ K` as a `k`-linear endomorphism of the adele space. -/ +def mulAdeleLinear (x : K) : AdeleSpace k K →ₗ[k] AdeleSpace k K where + toFun a := x • a + map_add' _ _ := smul_add x _ _ + map_smul' c a := by + ext v + change x * (c • a.val v) = c • (x * a.val v) + simp only [Algebra.smul_def] + ring + +/-- An adele lies in the filtration piece `A(D)` when its component at every place `v` has +valuation at most `WithZero.exp (D v)`. -/ +def memAdeleFilt (D : DivisorA k K) (α : AdeleSpace k K) : Prop := + ∀ v, placeValuation k K v (α.val v) ≤ WithZero.exp (D v) + +/-- The filtration piece `A(D)` of the adele space. -/ +def adeleFilt (D : DivisorA k K) : Submodule k (AdeleSpace k K) where + carrier := {a | memAdeleFilt k K D a} + zero_mem' := fun v => by simp + add_mem' {a b} ha hb := by + change memAdeleFilt k K D a at ha + change memAdeleFilt k K D b at hb + change memAdeleFilt k K D (a + b) + exact fun v => (Valuation.map_add _ (a.val v) (b.val v)).trans (max_le (ha v) (hb v)) + smul_mem' c a ha := by + change memAdeleFilt k K D a at ha + change memAdeleFilt k K D (c • a) + intro v + change placeValuation k K v (c • a.val v) ≤ _ + rw [Algebra.smul_def, map_mul] + exact (mul_le_mul' (placeValuation_algebraMap_le_one k K v c) (ha v)).trans_eq + (one_mul _) + +/-- The diagonal embedding `K → A_K` of principal adeles. -/ +def diagonal : K →ₗ[k] AdeleSpace k K where + toFun f := ⟨fun _ => f, by + simpa [adeleSubmodule] using + eventually_mem_placeValuationSubring k K f⟩ + map_add' _ _ := rfl + map_smul' _ _ := rfl + +/-- The image `K̃` of the diagonal embedding. -/ +def diagonalSubmodule : Submodule k (AdeleSpace k K) := LinearMap.range (diagonal k K) + +theorem adeleFilt_inf_diagonal (D : DivisorA k K) : + adeleFilt k K D ⊓ diagonalSubmodule k K = + Submodule.map (diagonal k K : K →ₗ[k] AdeleSpace k K) (RRspace k K D) := by + ext a + constructor + · rintro ⟨ha, f, rfl⟩ + refine ⟨f, ?_, rfl⟩ + simpa [adeleFilt, memAdeleFilt, RRspace, memRRspace, diagonal] using ha + · rintro ⟨f, hf, rfl⟩ + refine ⟨?_, ⟨f, rfl⟩⟩ + simpa [adeleFilt, memAdeleFilt, RRspace, memRRspace, diagonal] using hf + +/-- The adele filtration is monotone in the divisor. -/ +theorem adeleFilt_mono {D D' : DivisorA k K} (h : D ≤ D') : + adeleFilt k K D ≤ adeleFilt k K D' := by + intro a ha v + exact (ha v).trans (WithZero.exp_le_exp.mpr (h v)) + +/-- `A(D)` as a submodule of `A(D')`, for `D ≤ D'`. -/ +def adeleFiltWithin {D D' : DivisorA k K} (_h : D ≤ D') : + Submodule k (adeleFilt k K D') := + Submodule.comap (adeleFilt k K D').subtype (adeleFilt k K D) + +/-- Finite-rank increment `finrank k (A(D') ⧸ A(D))`. -/ +noncomputable def finrankAdeleFiltDiff (D D' : DivisorA k K) : ℕ := by + letI : AddCommGroup (adeleFilt k K D') := Submodule.addCommGroup _ + letI : Module k (adeleFilt k K D') := Submodule.module _ + exact Module.finrank k <| + (adeleFilt k K D') ⧸ + Submodule.comap (adeleFilt k K D').subtype (adeleFilt k K D) + +/-- Rank of `(A(D') + K̃) ⧸ (A(D) + K̃)` from the sandwich bookkeeping. -/ +noncomputable def sandwichRank (D D' : DivisorA k K) (_h : D ≤ D') : ℤ := + by + letI : AddCommGroup (adeleFilt k K D' + diagonalSubmodule k K) := + Submodule.addCommGroup _ + letI : Module k (adeleFilt k K D' + diagonalSubmodule k K) := Submodule.module _ + exact Int.ofNat (Module.finrank k <| + (adeleFilt k K D' + diagonalSubmodule k K) ⧸ + Submodule.comap (adeleFilt k K D' + diagonalSubmodule k K).subtype + (adeleFilt k K D + diagonalSubmodule k K)) + +/-- Component update for adele surgery (`A(D₁ ⊔ D₂) = A(D₁) + A(D₂)`). -/ +def adeleUpdate (α : AdeleSpace k K) (v : PlaceA k K) (a : K) : AdeleSpace k K := + ⟨Function.update α.val v a, by + change ∀ᶠ w : PlaceA k K in cofinite, + Function.update α.val v a w ∈ placeValuationSubring k K w + filter_upwards [α.property, Filter.eventually_cofinite_ne v] with w hw hwv + simpa [Function.update_of_ne hwv] using hw⟩ + +theorem adeleFilt_sup_eq_add {D₁ D₂ : DivisorA k K} : + adeleFilt k K (D₁ ⊔ D₂) = adeleFilt k K D₁ + adeleFilt k K D₂ := by + classical + rw [Submodule.add_eq_sup] + apply le_antisymm + · intro a ha + have haevent := a.property + change ∀ᶠ v : PlaceA k K in cofinite, + a.val v ∈ placeValuationSubring k K v at haevent + let a₁ : AdeleSpace k K := ⟨fun v => if D₂ v ≤ D₁ v then a.val v else 0, by + simpa [adeleSubmodule] using haevent.mono fun v hv => by + by_cases h : D₂ v ≤ D₁ v + · rw [ite_eq_left h] + exact hv + · rw [ite_eq_right h] + exact zero_mem _⟩ + let a₂ : AdeleSpace k K := ⟨fun v => if D₂ v ≤ D₁ v then 0 else a.val v, by + simpa [adeleSubmodule] using haevent.mono fun v hv => by + by_cases h : D₂ v ≤ D₁ v + · rw [ite_eq_left h] + exact zero_mem _ + · rw [ite_eq_right h] + exact hv⟩ + have ha₁ : a₁ ∈ adeleFilt k K D₁ := by + change memAdeleFilt k K D₁ a₁ + intro v + by_cases h : D₂ v ≤ D₁ v + · change placeValuation k K v (if D₂ v ≤ D₁ v then a.val v else 0) ≤ _ + rw [ite_eq_left h] + simpa [Finsupp.sup_apply, sup_eq_left.mpr h] using ha v + · simp [a₁, h] + have ha₂ : a₂ ∈ adeleFilt k K D₂ := by + change memAdeleFilt k K D₂ a₂ + intro v + by_cases h : D₂ v ≤ D₁ v + · simp [a₂, h] + · have hv : D₁ v ≤ D₂ v := le_of_not_ge h + change placeValuation k K v (if D₂ v ≤ D₁ v then 0 else a.val v) ≤ _ + rw [ite_eq_right h] + simpa [Finsupp.sup_apply, sup_eq_right.mpr hv] using ha v + refine Submodule.mem_sup.mpr ⟨a₁, ha₁, a₂, ha₂, ?_⟩ + ext v + by_cases h : D₂ v ≤ D₁ v <;> simp [a₁, a₂, h] + · apply sup_le + · intro a ha + change memAdeleFilt k K (D₁ ⊔ D₂) a + intro v + exact (ha v).trans (WithZero.exp_le_exp.mpr le_sup_left) + · intro a ha + change memAdeleFilt k K (D₁ ⊔ D₂) a + intro v + exact (ha v).trans (WithZero.exp_le_exp.mpr le_sup_right) + +end FunctionField.Chart + +end diff --git a/LeanPool/MarkoffModP/RiemannRoch/AdeleSpace/FilterChain.lean b/LeanPool/MarkoffModP/RiemannRoch/AdeleSpace/FilterChain.lean new file mode 100644 index 0000000000..49afe05142 --- /dev/null +++ b/LeanPool/MarkoffModP/RiemannRoch/AdeleSpace/FilterChain.lean @@ -0,0 +1,1114 @@ +/- +Copyright (c) 2026 Guanghao Li. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Guanghao Li +-/ + +module + +public import LeanPool.MarkoffModP.RiemannRoch.AdeleSpace.Basic +public import Mathlib.Algebra.Order.GroupWithZero.Canonical +public import Mathlib.LinearAlgebra.Isomorphisms +public import Mathlib.LinearAlgebra.Dimension.Finite +public import Mathlib.LinearAlgebra.Dimension.RankNullity +public import Mathlib.LinearAlgebra.Quotient.Basic +public import Mathlib.RingTheory.LocalRing.ResidueField.Basic +public import Mathlib.RingTheory.Finiteness.Finsupp + +/-! +# Exact dimensions of adele divisor quotients + +This file proves the exact rank formula for the adele filtration and the sandwich identity. +-/ + +@[expose] public section + +open scoped nonZeroDivisors Polynomial RatFunc WithZero +open IsDedekindDomain Cardinal + + +noncomputable section + +namespace FunctionField.Chart + +variable (k K : Type*) [Field k] [Field K] + +variable [Algebra k K] [Algebra k[X] K] [Algebra k⟮X⟯ K] [IsScalarTower k k[X] K] + [IsScalarTower k[X] k⟮X⟯ K] [_root_.FunctionField k K] + [Algebra.IsSeparable k⟮X⟯ K] + +/-- Decidable equality on `k(X)` for adele filter proofs. -/ +local instance instDecidableEqRatFuncAdeleFilter : DecidableEq k⟮X⟯ := Classical.decEq _ +/-- Decidable equality on coordinate places for adele filter proofs. -/ +local instance instDecidableEqPlaceAAdeleFilter : DecidableEq (PlaceA k K) := Classical.decEq _ +/-- Additive group structure on adele filtration pieces. -/ +local instance adeleFiltAddCommGroup (D' : DivisorA k K) : AddCommGroup (adeleFilt k K D') := + Submodule.addCommGroup _ +/-- Module structure on adele filtration pieces. -/ +local instance adeleFiltModule (D' : DivisorA k K) : Module k (adeleFilt k K D') := + Submodule.module _ + +/-- The zero adele. -/ +def zeroAdele : AdeleSpace k K := ⟨0, by simp⟩ + +/-- Lift an adele to the valuation subring at a finite place, scaled by a uniformizer power. -/ +noncomputable def finiteAdeleLocalResidueToSubring (D : DivisorA k K) + (v : IsDedekindDomain.HeightOneSpectrum (ringOfIntegers k K)) + (a : adeleFilt k K (D + Finsupp.single (Sum.inl v) 1)) : + IsDedekindDomain.HeightOneSpectrum.valuationSubringAtPrime K v := by + let π : K := Classical.choose (v.valuation_exists_uniformizer K) + let n : ℤ := D (Sum.inl v) + 1 + refine ⟨π ^ n * (a.val : AdeleSpace k K).val (Sum.inl v), ?_⟩ + have hmem : v.valuation K (π ^ n * (a.val : AdeleSpace k K).val (Sum.inl v)) ≤ 1 := by + have hπpow : v.valuation K (π ^ n) = WithZero.exp (-1) ^ n := by + rw [map_zpow₀, Classical.choose_spec (v.valuation_exists_uniformizer K)] + rw [map_mul, hπpow] + have hf : v.valuation K ((a.val : AdeleSpace k K).val (Sum.inl v)) ≤ WithZero.exp n := by + have := a.property (Sum.inl v) + simpa [memAdeleFilt, placeValuation, n, Finsupp.add_apply, Finsupp.single_apply, + add_comm] using this + calc + WithZero.exp (-1) ^ n * v.valuation K ((a.val : AdeleSpace k K).val (Sum.inl v)) + ≤ WithZero.exp (-1) ^ n * WithZero.exp n := mul_le_mul_right hf _ + _ = 1 := by + rw [← WithZero.exp_zsmul, ← WithZero.exp_add] + convert WithZero.exp_zero + simp + rw [IsDedekindDomain.HeightOneSpectrum.valuationSubringAtPrime_eq_valuationSubring, + Valuation.mem_valuationSubring_iff] + exact hmem + +/-- One-step local residue map on adeles at a finite coordinate place. -/ +noncomputable def finiteAdeleLocalResidueMap (D : DivisorA k K) + (v : IsDedekindDomain.HeightOneSpectrum (ringOfIntegers k K)) : + adeleFilt k K (D + Finsupp.single (Sum.inl v) 1) →ₗ[k] v.asIdeal.ResidueField := + let A := IsDedekindDomain.HeightOneSpectrum.valuationSubringAtPrime K v + letI : Algebra k A := + ((algebraMap (ringOfIntegers k K) A).comp + (algebraMap k (ringOfIntegers k K))).toAlgebra + letI : IsScalarTower k (ringOfIntegers k K) A := + IsScalarTower.of_algebraMap_eq fun _ => rfl + { + toFun := fun a => + IsDedekindDomain.HeightOneSpectrum.residueHom (K := K) v + (finiteAdeleLocalResidueToSubring k K D v a) + map_add' := fun a b => by + rw [← map_add] + congr 1 + simp [finiteAdeleLocalResidueToSubring, mul_add] + map_smul' := fun c a => by + let π : K := Classical.choose (v.valuation_exists_uniformizer K) + let n : ℤ := D (Sum.inl v) + 1 + have hz : + finiteAdeleLocalResidueToSubring k K D v (c • a) = + algebraMap k A c * finiteAdeleLocalResidueToSubring k K D v a := by + apply Subtype.ext + simp only [finiteAdeleLocalResidueToSubring, Submodule.coe_smul_of_tower, Algebra.smul_def, + Pi.smul_apply] + let α : PlaceA k K → K := (a.val : AdeleSpace k K).val + change π ^ n * (algebraMap k K c * α (Sum.inl v)) = + (↑(algebraMap k A c) : K) * (π ^ n * α (Sum.inl v)) + have hcA : (↑(algebraMap k A c) : K) = algebraMap k K c := by + calc + (↑(algebraMap k A c) : K) = + ↑(algebraMap (ringOfIntegers k K) A + (algebraMap k (ringOfIntegers k K) c)) := by + rw [IsScalarTower.algebraMap_apply k (ringOfIntegers k K) A] + _ = algebraMap (ringOfIntegers k K) K + (algebraMap k (ringOfIntegers k K) c) := rfl + _ = algebraMap k K c := + (IsScalarTower.algebraMap_apply k (ringOfIntegers k K) K c).symm + rw [hcA] + ring + rw [hz, map_mul, Algebra.smul_def] + congr 1 + rw [IsScalarTower.algebraMap_apply k (ringOfIntegers k K) A] + rw [IsDedekindDomain.HeightOneSpectrum.residueHom, IsLocalization.lift_eq] + exact (IsScalarTower.algebraMap_apply k (ringOfIntegers k K) + v.asIdeal.ResidueField c).symm } + +theorem finiteAdeleLocalResidueMap_ker (D : DivisorA k K) + (v : IsDedekindDomain.HeightOneSpectrum (ringOfIntegers k K)) : + (finiteAdeleLocalResidueMap k K D v).ker = + Submodule.comap (adeleFilt k K (D + Finsupp.single (Sum.inl v) 1)).subtype + (adeleFilt k K D) := by + ext a + simp only [LinearMap.mem_ker, Submodule.mem_comap, Submodule.coe_subtype, + finiteAdeleLocalResidueMap, finiteAdeleLocalResidueToSubring] + change IsDedekindDomain.HeightOneSpectrum.residueHom (K := K) v + ⟨(Classical.choose (v.valuation_exists_uniformizer K)) ^ + (D (Sum.inl v) + 1) * ((a.val : AdeleSpace k K).val (Sum.inl v)), _⟩ = 0 ↔ + ∀ w, placeValuation k K w ((a.val : AdeleSpace k K).val w) ≤ WithZero.exp (D w) + rw [IsDedekindDomain.HeightOneSpectrum.residueHom_eq_zero_iff] + have hπ := Classical.choose_spec (v.valuation_exists_uniformizer K) + rw [map_mul, map_zpow₀, hπ] + rw [← WithZero.exp_zsmul] + have hnsmul : (D (Sum.inl v) + 1) • (-1 : ℤ) = -(D (Sum.inl v) + 1) := by simp + rw [hnsmul] + have hlocal : WithZero.exp (-(D (Sum.inl v) + 1)) * + v.valuation K ((a.val : AdeleSpace k K).val (Sum.inl v)) < 1 ↔ + v.valuation K ((a.val : AdeleSpace k K).val (Sum.inl v)) ≤ + WithZero.exp (D (Sum.inl v)) := by + simpa using exp_neg_mul_lt_one_iff_le + (v.valuation K ((a.val : AdeleSpace k K).val (Sum.inl v))) (D (Sum.inl v) + 1) + rw [hlocal] + constructor + · intro hv w + by_cases hw : w = Sum.inl v + · subst hw + exact hv + · simpa [placeValuation, hw] using a.property w + · intro hf + simpa [placeValuation] using hf (Sum.inl v) + +theorem finiteAdeleLocalResidueMap_surjective (D : DivisorA k K) + (v : IsDedekindDomain.HeightOneSpectrum (ringOfIntegers k K)) : + Function.Surjective (finiteAdeleLocalResidueMap k K D v) := by + let π : K := Classical.choose (v.valuation_exists_uniformizer K) + let n : ℤ := D (Sum.inl v) + 1 + intro y + obtain ⟨x, hx⟩ := IsLocalRing.residue_surjective y + let z : IsDedekindDomain.HeightOneSpectrum.valuationSubringAtPrime K v := + IsDedekindDomain.HeightOneSpectrum.localizationAlgEquiv (K := K) v x + have hz : IsDedekindDomain.HeightOneSpectrum.residueHom (K := K) v z = y := by + rwa [IsDedekindDomain.HeightOneSpectrum.residueHom_apply_localizationAlgEquiv] + let xK : K := π ^ (-n) * (z : K) + let a₀ : AdeleSpace k K := adeleUpdate k K (zeroAdele k K) (Sum.inl v) xK + have ha₀ : a₀ ∈ adeleFilt k K (D + Finsupp.single (Sum.inl v) 1) := by + intro w + by_cases hw : w = Sum.inl v + · subst hw + simp only [placeValuation, Finsupp.add_apply, Finsupp.single_apply] + have hπpow : v.valuation K (π ^ (-n)) = WithZero.exp (-1) ^ (-n) := by + rw [map_zpow₀, Classical.choose_spec (v.valuation_exists_uniformizer K)] + have hzle : v.valuation K (z : K) ≤ 1 := by + simpa [IsDedekindDomain.HeightOneSpectrum.valuationSubringAtPrime_eq_valuationSubring, + Valuation.mem_valuationSubring_iff] using z.property + have hval : + (v.valuation K) (a₀.val (Sum.inl v)) ≤ WithZero.exp (D (Sum.inl v) + 1) := by + have hmul' : (v.valuation K) (a₀.val (Sum.inl v)) = + (v.valuation K) (π ^ (-n)) * (v.valuation K) (z : K) := by + change (v.valuation K) + (Function.update (0 : PlaceA k K → K) (Sum.inl v) xK (Sum.inl v)) = _ + simp only [Function.update_self, xK] + exact Valuation.map_mul (v.valuation K) _ _ + have hbound : + (v.valuation K) (π ^ (-n)) * (v.valuation K) (z : K) ≤ WithZero.exp n := by + have hπpow : v.valuation K (π ^ (-n)) = WithZero.exp (-1) ^ (-n) := by + rw [map_zpow₀, Classical.choose_spec (v.valuation_exists_uniformizer K)] + rw [hπpow] + have hzle0 : (v.valuation K) (z : K) ≤ WithZero.exp (0 : ℤ) := by + simpa [WithZero.exp_zero] using hzle + calc + WithZero.exp (-1) ^ (-n) * (v.valuation K) (z : K) + ≤ WithZero.exp (-1) ^ (-n) * WithZero.exp 0 := mul_le_mul_right hzle0 _ + _ = WithZero.exp n := by + rw [← WithZero.exp_zsmul, ← WithZero.exp_add] + simp + simpa [n] using (le_of_eq hmul').trans hbound + exact hval + · simp only [placeValuation, zeroAdele, adeleUpdate, a₀, + Function.update_of_ne hw, Pi.zero_apply, Valuation.map_zero, + Finsupp.add_apply, Finsupp.single_apply] + exact zero_le + refine ⟨⟨a₀, ha₀⟩, ?_⟩ + have hmul : (finiteAdeleLocalResidueToSubring k K D v ⟨a₀, ha₀⟩ : K) = (z : K) := by + dsimp [finiteAdeleLocalResidueToSubring, a₀, adeleUpdate, xK, zeroAdele, n, π] + simp only [Function.update_self] + have hπne : π ≠ 0 := by + intro h0 + have huniform := Classical.choose_spec (v.valuation_exists_uniformizer K) + have hπdef : v.valuation K π = WithZero.exp (-1) := by dsimp [π]; exact huniform + rw [h0, Valuation.map_zero] at hπdef + exact absurd hπdef.symm WithZero.exp_ne_zero + have h1 : π ^ (D (Sum.inl v) + 1) * π ^ (-(D (Sum.inl v) + 1)) = (1 : K) := by + rw [← zpow_add₀ hπne, add_neg_cancel, zpow_zero] + calc + π ^ (D (Sum.inl v) + 1) * (π ^ (-(D (Sum.inl v) + 1)) * (z : K)) + = (π ^ (D (Sum.inl v) + 1) * π ^ (-(D (Sum.inl v) + 1))) * (z : K) := by ring + _ = (z : K) := by rw [h1, one_mul] + simp only [finiteAdeleLocalResidueMap, finiteAdeleLocalResidueToSubring] + exact congr_arg (IsDedekindDomain.HeightOneSpectrum.residueHom (K := K) v) + (Subtype.ext_iff.mpr hmul) ▸ hz + +theorem finrankAdeleFiltDiff_single_finite (D : DivisorA k K) + (v : IsDedekindDomain.HeightOneSpectrum (ringOfIntegers k K)) : + finrankAdeleFiltDiff k K D (D + Finsupp.single (Sum.inl v) 1) = + placeDegree k K (Sum.inl v) := by + let f := finiteAdeleLocalResidueMap k K D v + let e : (ringOfIntegers k K ⧸ v.asIdeal) ≃ₗ[k] v.asIdeal.ResidueField := + LinearEquiv.ofBijective + ((Algebra.linearMap (ringOfIntegers k K ⧸ v.asIdeal) + v.asIdeal.ResidueField).restrictScalars k) + (Ideal.bijective_algebraMap_quotient_residueField v.asIdeal) + let : FiniteDimensional k v.asIdeal.ResidueField := e.finiteDimensional + have hker := finiteAdeleLocalResidueMap_ker k K D v + have hsurj := finiteAdeleLocalResidueMap_surjective k K D v + rw [finrankAdeleFiltDiff, ← hker, f.quotKerEquivRange.finrank_eq] + rw [LinearMap.range_eq_top.mpr hsurj, finrank_top] + calc + Module.finrank k v.asIdeal.ResidueField = Module.finrank k (ringOfIntegers k K ⧸ v.asIdeal) := + e.finrank_eq.symm + _ = placeDegree k K (Sum.inl v) := rfl + +/-- Lift an adele to the valuation subring at an infinite place, scaled by a uniformizer power. -/ +noncomputable def infiniteAdeleLocalResidueToSubring (D : DivisorA k K) + (v : IsDedekindDomain.HeightOneSpectrum (infiniteIntegers k K)) + (a : adeleFilt k K (D + Finsupp.single (Sum.inr v) 1)) : + IsDedekindDomain.HeightOneSpectrum.valuationSubringAtPrime K v := by + let π : K := Classical.choose (v.valuation_exists_uniformizer K) + let n : ℤ := D (Sum.inr v) + 1 + refine ⟨π ^ n * (a.val : AdeleSpace k K).val (Sum.inr v), ?_⟩ + have hmem : v.valuation K (π ^ n * (a.val : AdeleSpace k K).val (Sum.inr v)) ≤ 1 := by + have hπpow : v.valuation K (π ^ n) = WithZero.exp (-1) ^ n := by + rw [map_zpow₀, Classical.choose_spec (v.valuation_exists_uniformizer K)] + rw [map_mul, hπpow] + have hf : v.valuation K ((a.val : AdeleSpace k K).val (Sum.inr v)) ≤ WithZero.exp n := by + have h := a.property (Sum.inr v) + change v.valuation K ((a.val : AdeleSpace k K).val (Sum.inr v)) ≤ + WithZero.exp ((D + Finsupp.single (Sum.inr v) 1 : DivisorA k K) (Sum.inr v)) at h + simpa only [Finsupp.add_apply, Finsupp.single_eq_same] using h + calc + WithZero.exp (-1) ^ n * v.valuation K ((a.val : AdeleSpace k K).val (Sum.inr v)) + ≤ WithZero.exp (-1) ^ n * WithZero.exp n := mul_le_mul_right hf _ + _ = 1 := by + rw [← WithZero.exp_zsmul, ← WithZero.exp_add] + convert WithZero.exp_zero + simp + rw [IsDedekindDomain.HeightOneSpectrum.valuationSubringAtPrime_eq_valuationSubring, + Valuation.mem_valuationSubring_iff] + exact hmem + +/-- One-step local residue map on adeles at an infinite coordinate place. -/ +noncomputable def infiniteAdeleLocalResidueMap (D : DivisorA k K) + (v : IsDedekindDomain.HeightOneSpectrum (infiniteIntegers k K)) : + adeleFilt k K (D + Finsupp.single (Sum.inr v) 1) →ₗ[k] v.asIdeal.ResidueField := + let A := IsDedekindDomain.HeightOneSpectrum.valuationSubringAtPrime K v + letI : Algebra k A := + ((algebraMap (infiniteIntegers k K) A).comp + (algebraMap k (infiniteIntegers k K))).toAlgebra + letI : IsScalarTower k (infiniteIntegers k K) A := + IsScalarTower.of_algebraMap_eq fun _ => rfl + { + toFun := fun a => + IsDedekindDomain.HeightOneSpectrum.residueHom (K := K) v + (infiniteAdeleLocalResidueToSubring k K D v a) + map_add' := fun a b => by + rw [← map_add] + congr 1 + simp [infiniteAdeleLocalResidueToSubring, mul_add] + map_smul' := fun c a => by + let π : K := Classical.choose (v.valuation_exists_uniformizer K) + let n : ℤ := D (Sum.inr v) + 1 + have hz : + infiniteAdeleLocalResidueToSubring k K D v (c • a) = + algebraMap k A c * infiniteAdeleLocalResidueToSubring k K D v a := by + apply Subtype.ext + simp only [infiniteAdeleLocalResidueToSubring, Submodule.coe_smul_of_tower, + Algebra.smul_def, + Pi.smul_apply] + let α : PlaceA k K → K := (a.val : AdeleSpace k K).val + change π ^ n * (algebraMap k K c * α (Sum.inr v)) = + (↑(algebraMap k A c) : K) * (π ^ n * α (Sum.inr v)) + have hcA : (↑(algebraMap k A c) : K) = algebraMap k K c := by + calc + (↑(algebraMap k A c) : K) = + ↑(algebraMap (infiniteIntegers k K) A + (algebraMap k (infiniteIntegers k K) c)) := by + rw [IsScalarTower.algebraMap_apply k (infiniteIntegers k K) A] + _ = algebraMap (infiniteIntegers k K) K + (algebraMap k (infiniteIntegers k K) c) := rfl + _ = algebraMap k K c := + (IsScalarTower.algebraMap_apply k (infiniteIntegers k K) K c).symm + rw [hcA] + ring + rw [hz, map_mul, Algebra.smul_def] + congr 1 + rw [IsScalarTower.algebraMap_apply k (infiniteIntegers k K) A] + rw [IsDedekindDomain.HeightOneSpectrum.residueHom, IsLocalization.lift_eq] + exact (IsScalarTower.algebraMap_apply k (infiniteIntegers k K) + v.asIdeal.ResidueField c).symm } + +theorem infiniteAdeleLocalResidueMap_ker (D : DivisorA k K) + (v : IsDedekindDomain.HeightOneSpectrum (infiniteIntegers k K)) : + (infiniteAdeleLocalResidueMap k K D v).ker = + Submodule.comap (adeleFilt k K (D + Finsupp.single (Sum.inr v) 1)).subtype + (adeleFilt k K D) := by + ext a + simp only [LinearMap.mem_ker, Submodule.mem_comap, Submodule.coe_subtype, + infiniteAdeleLocalResidueMap, infiniteAdeleLocalResidueToSubring] + change IsDedekindDomain.HeightOneSpectrum.residueHom (K := K) v + ⟨(Classical.choose (v.valuation_exists_uniformizer K)) ^ + (D (Sum.inr v) + 1) * ((a.val : AdeleSpace k K).val (Sum.inr v)), _⟩ = 0 ↔ + ∀ w, placeValuation k K w ((a.val : AdeleSpace k K).val w) ≤ WithZero.exp (D w) + rw [IsDedekindDomain.HeightOneSpectrum.residueHom_eq_zero_iff] + have hπ := Classical.choose_spec (v.valuation_exists_uniformizer K) + rw [map_mul, map_zpow₀, hπ] + rw [← WithZero.exp_zsmul] + have hnsmul : (D (Sum.inr v) + 1) • (-1 : ℤ) = -(D (Sum.inr v) + 1) := by simp + rw [hnsmul] + have hlocal : WithZero.exp (-(D (Sum.inr v) + 1)) * + v.valuation K ((a.val : AdeleSpace k K).val (Sum.inr v)) < 1 ↔ + v.valuation K ((a.val : AdeleSpace k K).val (Sum.inr v)) ≤ + WithZero.exp (D (Sum.inr v)) := by + simpa using exp_neg_mul_lt_one_iff_le + (v.valuation K ((a.val : AdeleSpace k K).val (Sum.inr v))) (D (Sum.inr v) + 1) + rw [hlocal] + constructor + · intro hv w + by_cases hw : w = Sum.inr v + · subst hw + exact hv + · simpa [placeValuation, hw] using a.property w + · intro hf + simpa [placeValuation] using hf (Sum.inr v) + +theorem infiniteAdeleLocalResidueMap_surjective (D : DivisorA k K) + (v : IsDedekindDomain.HeightOneSpectrum (infiniteIntegers k K)) : + Function.Surjective (infiniteAdeleLocalResidueMap k K D v) := by + let π : K := Classical.choose (v.valuation_exists_uniformizer K) + let n : ℤ := D (Sum.inr v) + 1 + intro y + obtain ⟨x, hx⟩ := IsLocalRing.residue_surjective y + let z : IsDedekindDomain.HeightOneSpectrum.valuationSubringAtPrime K v := + IsDedekindDomain.HeightOneSpectrum.localizationAlgEquiv (K := K) v x + have hz : IsDedekindDomain.HeightOneSpectrum.residueHom (K := K) v z = y := by + rwa [IsDedekindDomain.HeightOneSpectrum.residueHom_apply_localizationAlgEquiv] + let xK : K := π ^ (-n) * (z : K) + let a₀ : AdeleSpace k K := adeleUpdate k K (zeroAdele k K) (Sum.inr v) xK + have ha₀ : a₀ ∈ adeleFilt k K (D + Finsupp.single (Sum.inr v) 1) := by + intro w + by_cases hw : w = Sum.inr v + · subst hw + simp only [placeValuation, Finsupp.add_apply, Finsupp.single_apply] + have hπpow : v.valuation K (π ^ (-n)) = WithZero.exp (-1) ^ (-n) := by + rw [map_zpow₀, Classical.choose_spec (v.valuation_exists_uniformizer K)] + have hzle : v.valuation K (z : K) ≤ 1 := by + simpa [IsDedekindDomain.HeightOneSpectrum.valuationSubringAtPrime_eq_valuationSubring, + Valuation.mem_valuationSubring_iff] using z.property + have hval : + (v.valuation K) (a₀.val (Sum.inr v)) ≤ WithZero.exp (D (Sum.inr v) + 1) := by + have hmul' : (v.valuation K) (a₀.val (Sum.inr v)) = + (v.valuation K) (π ^ (-n)) * (v.valuation K) (z : K) := by + change (v.valuation K) + (Function.update (0 : PlaceA k K → K) (Sum.inr v) xK (Sum.inr v)) = _ + simp only [Function.update_self, xK] + exact Valuation.map_mul (v.valuation K) _ _ + have hbound : + (v.valuation K) (π ^ (-n)) * (v.valuation K) (z : K) ≤ WithZero.exp n := by + have hπpow : v.valuation K (π ^ (-n)) = WithZero.exp (-1) ^ (-n) := by + rw [map_zpow₀, Classical.choose_spec (v.valuation_exists_uniformizer K)] + rw [hπpow] + have hzle0 : (v.valuation K) (z : K) ≤ WithZero.exp (0 : ℤ) := by + simpa [WithZero.exp_zero] using hzle + calc + WithZero.exp (-1) ^ (-n) * (v.valuation K) (z : K) + ≤ WithZero.exp (-1) ^ (-n) * WithZero.exp 0 := mul_le_mul_right hzle0 _ + _ = WithZero.exp n := by + rw [← WithZero.exp_zsmul, ← WithZero.exp_add] + simp + simpa [n] using (le_of_eq hmul').trans hbound + exact hval + · simp only [placeValuation, zeroAdele, adeleUpdate, a₀, + Function.update_of_ne hw, Pi.zero_apply, Valuation.map_zero, + Finsupp.add_apply, Finsupp.single_apply] + exact zero_le + refine ⟨⟨a₀, ha₀⟩, ?_⟩ + have hmul : (infiniteAdeleLocalResidueToSubring k K D v ⟨a₀, ha₀⟩ : K) = (z : K) := by + dsimp [infiniteAdeleLocalResidueToSubring, a₀, adeleUpdate, xK, zeroAdele, n, π] + simp only [Function.update_self] + have hπne : π ≠ 0 := by + intro h0 + have huniform := Classical.choose_spec (v.valuation_exists_uniformizer K) + have hπdef : v.valuation K π = WithZero.exp (-1) := by dsimp [π]; exact huniform + rw [h0, Valuation.map_zero] at hπdef + exact absurd hπdef.symm WithZero.exp_ne_zero + have h1 : π ^ (D (Sum.inr v) + 1) * π ^ (-(D (Sum.inr v) + 1)) = (1 : K) := by + rw [← zpow_add₀ hπne, add_neg_cancel, zpow_zero] + calc + π ^ (D (Sum.inr v) + 1) * (π ^ (-(D (Sum.inr v) + 1)) * (z : K)) + = (π ^ (D (Sum.inr v) + 1) * π ^ (-(D (Sum.inr v) + 1))) * (z : K) := by ring + _ = (z : K) := by rw [h1, one_mul] + simp only [infiniteAdeleLocalResidueMap, infiniteAdeleLocalResidueToSubring] + exact congr_arg (IsDedekindDomain.HeightOneSpectrum.residueHom (K := K) v) + (Subtype.ext_iff.mpr hmul) ▸ hz + +theorem finrankAdeleFiltDiff_single_infinite (D : DivisorA k K) + (v : IsDedekindDomain.HeightOneSpectrum (infiniteIntegers k K)) : + finrankAdeleFiltDiff k K D (D + Finsupp.single (Sum.inr v) 1) = + placeDegree k K (Sum.inr v) := by + let f := infiniteAdeleLocalResidueMap k K D v + let e : (infiniteIntegers k K ⧸ v.asIdeal) ≃ₗ[k] v.asIdeal.ResidueField := + LinearEquiv.ofBijective + ((Algebra.linearMap (infiniteIntegers k K ⧸ v.asIdeal) + v.asIdeal.ResidueField).restrictScalars k) + (Ideal.bijective_algebraMap_quotient_residueField v.asIdeal) + let : FiniteDimensional k v.asIdeal.ResidueField := e.finiteDimensional + have hker := infiniteAdeleLocalResidueMap_ker k K D v + have hsurj := infiniteAdeleLocalResidueMap_surjective k K D v + rw [finrankAdeleFiltDiff, ← hker, f.quotKerEquivRange.finrank_eq] + rw [LinearMap.range_eq_top.mpr hsurj, finrank_top] + calc + Module.finrank k v.asIdeal.ResidueField = + Module.finrank k (infiniteIntegers k K ⧸ v.asIdeal) := + e.finrank_eq.symm + _ = placeDegree k K (Sum.inr v) := rfl + +theorem finrankAdeleFiltDiff_single_one (D : DivisorA k K) (v : PlaceA k K) : + finrankAdeleFiltDiff k K D (D + Finsupp.single v 1) = placeDegree k K v := by + rcases v with v | v + · exact finrankAdeleFiltDiff_single_finite k K D v + · exact finrankAdeleFiltDiff_single_infinite k K D v + +theorem finiteAdeleFiltDiff_quotient_single (D : DivisorA k K) (v : PlaceA k K) : + Module.Finite k ((adeleFilt k K (D + Finsupp.single v 1)) ⧸ + Submodule.comap (adeleFilt k K (D + Finsupp.single v 1)).subtype (adeleFilt k K D)) := by + classical + rcases v with v | v + · let : AddCommGroup (adeleFilt k K (D + Finsupp.single (Sum.inl v) 1)) := + Submodule.addCommGroup _ + let : Module k (adeleFilt k K (D + Finsupp.single (Sum.inl v) 1)) := Submodule.module _ + let f := finiteAdeleLocalResidueMap k K D v + let e : (ringOfIntegers k K ⧸ v.asIdeal) ≃ₗ[k] v.asIdeal.ResidueField := + LinearEquiv.ofBijective + ((Algebra.linearMap (ringOfIntegers k K ⧸ v.asIdeal) + v.asIdeal.ResidueField).restrictScalars k) + (Ideal.bijective_algebraMap_quotient_residueField v.asIdeal) + let : FiniteDimensional k v.asIdeal.ResidueField := e.finiteDimensional + let p := Submodule.comap (adeleFilt k K (D + Finsupp.single (Sum.inl v) 1)).subtype + (adeleFilt k K D) + have : Module.Finite k f.range := inferInstance + have : Module.Finite k + (adeleFilt k K (D + Finsupp.single (Sum.inl v) 1) ⧸ f.ker) := + Module.Finite.equiv f.quotKerEquivRange.symm + exact Module.Finite.equiv (Submodule.quotEquivOfEq f.ker p + (finiteAdeleLocalResidueMap_ker k K D v)) + · let : AddCommGroup (adeleFilt k K (D + Finsupp.single (Sum.inr v) 1)) := + Submodule.addCommGroup _ + let : Module k (adeleFilt k K (D + Finsupp.single (Sum.inr v) 1)) := Submodule.module _ + let f := infiniteAdeleLocalResidueMap k K D v + let e : (infiniteIntegers k K ⧸ v.asIdeal) ≃ₗ[k] v.asIdeal.ResidueField := + LinearEquiv.ofBijective + ((Algebra.linearMap (infiniteIntegers k K ⧸ v.asIdeal) + v.asIdeal.ResidueField).restrictScalars k) + (Ideal.bijective_algebraMap_quotient_residueField v.asIdeal) + let : FiniteDimensional k v.asIdeal.ResidueField := e.finiteDimensional + let p := Submodule.comap (adeleFilt k K (D + Finsupp.single (Sum.inr v) 1)).subtype + (adeleFilt k K D) + have : Module.Finite k f.range := inferInstance + have : Module.Finite k + (adeleFilt k K (D + Finsupp.single (Sum.inr v) 1) ⧸ f.ker) := + Module.Finite.equiv f.quotKerEquivRange.symm + exact Module.Finite.equiv (Submodule.quotEquivOfEq f.ker p + (infiniteAdeleLocalResidueMap_ker k K D v)) + +theorem finiteAdeleFiltDiff_quotient_self (D : DivisorA k K) : + Module.Finite k ((adeleFilt k K D) ⧸ + Submodule.comap (adeleFilt k K D).subtype (adeleFilt k K D)) := by + rw [show Submodule.comap (adeleFilt k K D).subtype (adeleFilt k K D) = ⊤ from + Submodule.comap_subtype_self (adeleFilt k K D)] + exact inferInstanceAs + (Module.Finite k ((adeleFilt k K D) ⧸ (⊤ : Submodule k (adeleFilt k K D)))) + +theorem finiteAdeleFiltDiff_quotient_mono_add {D M N : DivisorA k K} + (hDM : D ≤ M) (hMN : M ≤ N) + [Module.Finite k ((adeleFilt k K N) ⧸ + Submodule.comap (adeleFilt k K N).subtype (adeleFilt k K M))] + [Module.Finite k ((adeleFilt k K M) ⧸ + Submodule.comap (adeleFilt k K M).subtype (adeleFilt k K D))] : + Module.Finite k ((adeleFilt k K N) ⧸ + Submodule.comap (adeleFilt k K N).subtype (adeleFilt k K D)) := by + let p := adeleFilt k K N + let q := Submodule.comap p.subtype (adeleFilt k K D) + let r := Submodule.comap p.subtype (adeleFilt k K M) + let pM := adeleFilt k K M + let qM := Submodule.comap pM.subtype (adeleFilt k K D) + have hqr : q ≤ r := Submodule.comap_mono (adeleFilt_mono k K hDM) + let eR := Submodule.comapSubtypeEquivOfLe (adeleFilt_mono k K hMN) + let qInR : Submodule k ↥r := Submodule.comap r.subtype q + have hqmap : qM.map (eR.symm : pM →ₗ[k] r) = qInR := by + rw [Submodule.map_equiv_eq_comap_symm eR.symm qM] + rfl + have eMq : (pM ⧸ qM) ≃ₗ[k] (r ⧸ qInR) := Submodule.Quotient.equiv qM qInR eR.symm hqmap + have : Module.Finite k (r ⧸ qInR) := Module.Finite.equiv eMq + have hker : (q.mkQ.comp (r.subtype : r →ₗ[k] p)).ker = qInR := by + rw [LinearMap.ker_comp, Submodule.ker_mkQ] + have hrange : (q.mkQ.comp (r.subtype : r →ₗ[k] p)).range = r.map q.mkQ := by + rw [LinearMap.range_comp, Submodule.range_subtype] + have eQuot : (r ⧸ qInR) ≃ₗ[k] r.map q.mkQ := by + rw [← hker, ← hrange] + exact LinearMap.quotKerEquivRange (q.mkQ.comp (r.subtype : r →ₗ[k] p)) + have : Module.Finite k (r.map q.mkQ) := Module.Finite.equiv eQuot + have eThird := Submodule.quotientQuotientEquivQuotient q r hqr + have : Module.Finite k (p ⧸ r) := by dsimp only [p, r]; infer_instance + have : Module.Finite k ((p ⧸ q) ⧸ Submodule.map q.mkQ r) := Module.Finite.equiv eThird.symm + exact Module.Finite.of_submodule_quotient (Submodule.map q.mkQ r) + +theorem finiteAdeleFiltDiff_quotient_single_nat (D : DivisorA k K) (v : PlaceA k K) (n : ℕ) : + Module.Finite k ((adeleFilt k K (D + Finsupp.single v (n : ℤ))) ⧸ + Submodule.comap (adeleFilt k K (D + Finsupp.single v (n : ℤ))).subtype + (adeleFilt k K D)) := by + induction n with + | zero => + have heq : D + Finsupp.single v ((0 : ℕ) : ℤ) = D := by simp + rw [heq] + exact finiteAdeleFiltDiff_quotient_self k K D + | succ n ih => + have heq : D + Finsupp.single v ((n + 1 : ℕ) : ℤ) = + D + Finsupp.single v (n : ℤ) + Finsupp.single v 1 := by + ext w + simp only [Finsupp.add_apply, Finsupp.single_apply] + split <;> omega + have hDM : D ≤ D + Finsupp.single v (n : ℤ) := by + intro w + simp only [Finsupp.add_apply] + exact le_add_of_nonneg_right (by + simp only [Finsupp.single_apply] + split <;> omega) + have hMN : D + Finsupp.single v (n : ℤ) ≤ + D + Finsupp.single v (n : ℤ) + Finsupp.single v 1 := by + intro w + simp only [Finsupp.add_apply] + exact le_add_of_nonneg_right (by + simp only [Finsupp.single_apply] + split <;> omega) + let := ih + have := finiteAdeleFiltDiff_quotient_single k K (D + Finsupp.single v (n : ℤ)) v + rw [heq] + exact finiteAdeleFiltDiff_quotient_mono_add k K hDM hMN + +theorem finiteAdeleFiltDiff_quotient_add_effective (D E : DivisorA k K) + (hE : IsEffective k K E) : + Module.Finite k ((adeleFilt k K (D + E)) ⧸ + Submodule.comap (adeleFilt k K (D + E)).subtype (adeleFilt k K D)) := by + classical + induction E using Finsupp.induction generalizing D with + | zero => + rw [add_zero] + exact finiteAdeleFiltDiff_quotient_self k K D + | single_add a b f ha hb ih => + have hfa : f a = 0 := Finsupp.notMem_support_iff.mp ha + have hff : IsEffective k K f := by + intro w + by_cases hw : w = a + · subst w + rw [hfa] + · simpa [Finsupp.single_apply, hw] using hE w + have hb0 : 0 ≤ b := by + simpa [Finsupp.single_apply, hfa] using hE a + let := ih D hff + have := finiteAdeleFiltDiff_quotient_single_nat k K (D + f) a b.toNat + have hbcast : (b.toNat : ℤ) = b := Int.toNat_of_nonneg hb0 + have heq : D + (Finsupp.single a b + f) = + (D + f) + Finsupp.single a (b.toNat : ℤ) := by + rw [hbcast] + abel + have hDM : D ≤ D + f := by + intro w + simp only [Finsupp.add_apply] + exact le_add_of_nonneg_right (hff w) + have hMN : D + f ≤ (D + f) + Finsupp.single a (b.toNat : ℤ) := by + intro w + simp only [Finsupp.add_apply] + exact le_add_of_nonneg_right (by + simp only [Finsupp.single_apply] + split <;> omega) + rw [heq] + exact finiteAdeleFiltDiff_quotient_mono_add k K hDM hMN + +theorem finiteAdeleFiltDiff_quotient_add_eq {M N : DivisorA k K} + (hN : N = M + (N - M)) (hE : IsEffective k K (N - M)) : + Module.Finite k ((adeleFilt k K N) ⧸ + Submodule.comap (adeleFilt k K N).subtype (adeleFilt k K M)) := + hN ▸ finiteAdeleFiltDiff_quotient_add_effective k K M (N - M) hE + +theorem finrankAdeleFiltDiff_mono_add {D M N : DivisorA k K} + (hDM : D ≤ M) (hMN : M ≤ N) : + finrankAdeleFiltDiff k K D N = + finrankAdeleFiltDiff k K D M + finrankAdeleFiltDiff k K M N := by + let p := adeleFilt k K N + let q := Submodule.comap p.subtype (adeleFilt k K D) + let r := Submodule.comap p.subtype (adeleFilt k K M) + have hqr : q ≤ r := Submodule.comap_mono (adeleFilt_mono k K hDM) + have hDN : D ≤ N := hDM.trans hMN + have hE := (le_iff_sub_effective k K).mp hDN + have hEN := (le_iff_sub_effective k K).mp hMN + have hND : D + (N - D) = N := by ext w; simp [sub_eq_add_neg] + have hNM : M + (N - M) = N := by ext w; simp [sub_eq_add_neg] + have : Module.Finite k (p ⧸ q) := + finiteAdeleFiltDiff_quotient_add_eq k K (M := D) hND.symm hE + have : Module.Finite k (p ⧸ r) := + finiteAdeleFiltDiff_quotient_add_eq k K (M := M) hNM.symm hEN + dsimp only [finrankAdeleFiltDiff] + have e := Submodule.quotientQuotientEquivQuotient q r hqr + have hadd := Submodule.finrank_quotient_add_finrank (r.map q.mkQ) + have hrmap : Module.finrank k (r.map q.mkQ) = finrankAdeleFiltDiff k K D M := by + let pM := adeleFilt k K M + let qM := Submodule.comap pM.subtype (adeleFilt k K D) + let qInR : Submodule k ↥r := Submodule.comap r.subtype q + let eR := Submodule.comapSubtypeEquivOfLe (adeleFilt_mono k K hMN) + have hqmap : qM.map (eR.symm : pM →ₗ[k] r) = qInR := by + rw [Submodule.map_equiv_eq_comap_symm eR.symm qM] + rfl + have eM : (pM ⧸ qM) ≃ₗ[k] (r ⧸ qInR) := Submodule.Quotient.equiv qM qInR eR.symm hqmap + have hker : (q.mkQ.comp (r.subtype : r →ₗ[k] p)).ker = qInR := by + rw [LinearMap.ker_comp, Submodule.ker_mkQ] + have hrange : (q.mkQ.comp (r.subtype : r →ₗ[k] p)).range = r.map q.mkQ := by + rw [LinearMap.range_comp, Submodule.range_subtype] + have eQuot : (r ⧸ qInR) ≃ₗ[k] r.map q.mkQ := by + rw [← hker, ← hrange] + exact LinearMap.quotKerEquivRange (q.mkQ.comp (r.subtype : r →ₗ[k] p)) + dsimp [finrankAdeleFiltDiff] + rw [← eQuot.finrank_eq, eM.finrank_eq] + calc + Module.finrank k (↥p ⧸ q) + = Module.finrank k ((↥p ⧸ q) ⧸ Submodule.map q.mkQ r) + + Module.finrank k ↥(Submodule.map q.mkQ r) := hadd.symm + _ = Module.finrank k (↥p ⧸ r) + finrankAdeleFiltDiff k K D M := by + rw [e.finrank_eq, hrmap] + _ = finrankAdeleFiltDiff k K D M + finrankAdeleFiltDiff k K M N := by + dsimp only [finrankAdeleFiltDiff] + rw [add_comm] + +theorem finrankAdeleFiltDiff_add_one {D M : DivisorA k K} (v : PlaceA k K) (hDM : D ≤ M) : + finrankAdeleFiltDiff k K D (M + Finsupp.single v 1) = + finrankAdeleFiltDiff k K D M + placeDegree k K v := by + have hMN : M ≤ M + Finsupp.single v 1 := by + intro w + simp only [Finsupp.add_apply] + exact le_add_of_nonneg_right (by + simp only [Finsupp.single_apply] + split <;> omega) + rw [finrankAdeleFiltDiff_mono_add k K hDM hMN, finrankAdeleFiltDiff_single_one] + +theorem finrankAdeleFiltDiff_add_effective (D E : DivisorA k K) + (hE : IsEffective k K E) : + finrankAdeleFiltDiff k K D (D + E) = (deg k K E).toNat := by + classical + induction E using Finsupp.induction generalizing D with + | zero => + rw [add_zero, finrankAdeleFiltDiff, deg_zero] + have hp : Submodule.comap (adeleFilt k K D).subtype (adeleFilt k K D) = ⊤ := by + ext a + simp + rw [hp] + exact Module.finrank_eq_zero_of_subsingleton k _ + | single_add a b f ha hb ih => + have hfa : f a = 0 := Finsupp.notMem_support_iff.mp ha + have hff : IsEffective k K f := by + intro w + by_cases hw : w = a + · subst w + rw [hfa] + · have hwE := hE w + simpa [Finsupp.single_apply, hw] using hwE + have hb0 : 0 ≤ b := by + have haE := hE a + simpa [Finsupp.single_apply, hfa] using haE + let M := D + f + let N := M + Finsupp.single a (b.toNat : ℤ) + have hDM : D ≤ M := by + intro w + dsimp only [M] + simp only [Finsupp.add_apply] + exact le_add_of_nonneg_right (hff w) + have hMN : M ≤ N := by + intro w + dsimp only [N] + simp only [Finsupp.add_apply] + exact le_add_of_nonneg_right (by + simp only [Finsupp.single_apply] + split <;> omega) + have hfirst := ih D hff + have hsecond : finrankAdeleFiltDiff k K M N = b.toNat * placeDegree k K a := by + have hbcast : (b.toNat : ℤ) = b := Int.toNat_of_nonneg hb0 + have heq : N = M + Finsupp.single a (b.toNat : ℤ) := rfl + rw [heq] + induction b.toNat with + | zero => + simp only [Nat.cast_zero, Finsupp.single_zero, add_zero, zero_mul] + rw [finrankAdeleFiltDiff] + have hp : Submodule.comap (adeleFilt k K M).subtype (adeleFilt k K M) = ⊤ := by + ext a + simp + rw [hp] + exact Module.finrank_eq_zero_of_subsingleton k _ + | succ n ihN => + let P := M + Finsupp.single a (n : ℤ) + have hMP : M ≤ P := by + intro w + dsimp only [P] + simp only [Finsupp.add_apply] + exact le_add_of_nonneg_right (by + simp only [Finsupp.single_apply] + split <;> omega) + have heqP : M + Finsupp.single a ((n + 1 : ℕ) : ℤ) = P + Finsupp.single a 1 := by + dsimp [P] + ext w + simp only [Finsupp.add_apply, Finsupp.single_apply] + split <;> omega + have hadd := finrankAdeleFiltDiff_add_one k K (M := P) a hMP + have hcast : M + Finsupp.single a (Int.ofNat (n + 1)) = + M + Finsupp.single a ((n + 1 : ℕ) : ℤ) := by simp [Int.ofNat_eq_natCast] + calc + finrankAdeleFiltDiff k K M (M + Finsupp.single a ↑(n + 1)) + = finrankAdeleFiltDiff k K M (M + Finsupp.single a (Int.ofNat (n + 1))) := by + simp [Int.ofNat_eq_natCast] + _ = finrankAdeleFiltDiff k K M (M + Finsupp.single a ((n + 1 : ℕ) : ℤ)) := by + rw [hcast] + _ = finrankAdeleFiltDiff k K M (P + Finsupp.single a 1) := by rw [heqP] + _ = finrankAdeleFiltDiff k K M P + placeDegree k K a := hadd + _ = n * placeDegree k K a + placeDegree k K a := by + rw [← ihN] + _ = (n + 1) * placeDegree k K a := by ring + have hdegf : 0 ≤ deg k K f := deg_nonneg k K hff + have hdegE : deg k K (Finsupp.single a b + f) = + b * (placeDegree k K a : ℤ) + deg k K f := by + rw [deg_add] + simp [deg] + have hdegE0 : 0 ≤ deg k K (Finsupp.single a b + f) := deg_nonneg k K hE + have hdegNat : (deg k K (Finsupp.single a b + f)).toNat = + b.toNat * placeDegree k K a + (deg k K f).toNat := by + have hfcast : ((deg k K f).toNat : ℤ) = deg k K f := Int.toNat_of_nonneg hdegf + have hEcast : ((deg k K (Finsupp.single a b + f)).toNat : ℤ) = + deg k K (Finsupp.single a b + f) := Int.toNat_of_nonneg hdegE0 + apply Int.ofNat_injective + change ((deg k K (Finsupp.single a b + f)).toNat : ℤ) = + ((b.toNat * placeDegree k K a + (deg k K f).toNat : ℕ) : ℤ) + rw [hEcast, Nat.cast_add, Nat.cast_mul, Int.toNat_of_nonneg hb0, hfcast] + exact hdegE + have htotal : finrankAdeleFiltDiff k K D N = + (deg k K (Finsupp.single a b + f)).toNat := by + have hadd := finrankAdeleFiltDiff_mono_add k K hDM hMN + rw [hadd, hfirst, hsecond, hdegNat, Nat.add_comm] + have heq : D + (Finsupp.single a b + f) = N := by + dsimp only [N, M] + rw [Int.toNat_of_nonneg hb0] + abel + rw [heq] + exact htotal + +theorem finrank_adeleFilt_quotient {D D' : DivisorA k K} (h : D ≤ D') : + finrankAdeleFiltDiff k K D D' = (deg k K (D' - D)).toNat := by + have hE : IsEffective k K (D' - D) := (le_iff_sub_effective k K).mp h + have hrank := finrankAdeleFiltDiff_add_effective k K D (D' - D) hE + have heq : D + (D' - D) = D' := by abel + rw [heq] at hrank + exact hrank + +theorem finrank_map_comap_mkQ_eq_quotient {D' : DivisorA k K} + {s t : Submodule k (AdeleSpace k K)} (_hs : s ≤ adeleFilt k K D') + (ht : t ≤ adeleFilt k K D') (_hst : s ≤ t) : + Module.finrank k (Submodule.map (Submodule.comap (adeleFilt k K D').subtype s).mkQ + (Submodule.comap (adeleFilt k K D').subtype t)) = + Module.finrank k + (↥(Submodule.comap (adeleFilt k K D').subtype t) ⧸ + Submodule.comap (Submodule.comap (adeleFilt k K D').subtype t).subtype + (Submodule.comap (adeleFilt k K D').subtype s)) := by + classical + let p := adeleFilt k K D' + let qp := Submodule.comap p.subtype s + let qt := Submodule.comap p.subtype t + let st := Submodule.comap t.subtype s + let qpInQt := Submodule.comap qt.subtype qp + let : AddCommGroup ↥t := Submodule.addCommGroup _ + let : Module k ↥t := Submodule.module _ + let : AddCommGroup ↥qt := Submodule.addCommGroup _ + let : Module k ↥qt := Submodule.module _ + let eT := Submodule.comapSubtypeEquivOfLe ht + have hmap : st.map (eT.symm : ↥t →ₗ[k] ↥qt) = qpInQt := by + ext x + simp [Submodule.mem_comap, st, qpInQt, qp, qt, eT] + have hker : (qp.mkQ.comp (qt.subtype : qt →ₗ[k] p)).ker = qpInQt := by + rw [LinearMap.ker_comp, Submodule.ker_mkQ] + have hrange : (qp.mkQ.comp (qt.subtype : qt →ₗ[k] p)).range = Submodule.map qp.mkQ qt := by + rw [LinearMap.range_comp, Submodule.range_subtype] + have eQuot : (↥qt ⧸ qpInQt) ≃ₗ[k] Submodule.map qp.mkQ qt := by + rw [← hker, ← hrange] + exact LinearMap.quotKerEquivRange (qp.mkQ.comp (qt.subtype : qt →ₗ[k] p)) + have eTS : ((↥t) ⧸ st) ≃ₗ[k] ((↥qt) ⧸ qpInQt) := + Submodule.Quotient.equiv st qpInQt eT.symm hmap + rw [← eQuot.finrank_eq, ← eTS.finrank_eq] + +theorem sandwich {D D' : DivisorA k K} (h : D ≤ D') : + sandwichRank k K D D' h = deg k K D' - ell k K D' - (deg k K D - ell k K D) := by + let p := adeleFilt k K D' + let s := adeleFilt k K D + let r := diagonalSubmodule k K + let l := Submodule.map (diagonal k K) (RRspace k K D') + let t := l ⊔ s + have hs_le_p : s ≤ p := adeleFilt_mono k K h + have hst : s ≤ t := le_sup_right + have htp : t ≤ p := by + rintro x hx + rcases Submodule.mem_sup.mp hx with ⟨y, hy, z, hz, rfl⟩ + rcases hy with ⟨f, hf, rfl⟩ + exact Submodule.add_mem p + (by simpa [adeleFilt, memAdeleFilt, memRRspace, RRspace, diagonal, p] using hf) (hs_le_p hz) + have hmod : p ⊓ (s + r) = s + p ⊓ r := by + apply le_antisymm + · rintro x ⟨hxp, hxsr⟩ + rcases Submodule.mem_sup.mp hxsr with ⟨a, has, y, hy, rfl⟩ + obtain ⟨f, rfl⟩ := LinearMap.mem_range.mp hy + refine Submodule.mem_sup.mpr ⟨a, has, (diagonal k K f), ?_, rfl⟩ + exact Submodule.mem_inf.mpr + ⟨(by simpa [sub_add_cancel] using Submodule.sub_mem p hxp (hs_le_p has)), hy⟩ + · rintro x hx + rcases Submodule.mem_sup.mp hx with ⟨a, has, y, hy, rfl⟩ + rcases Submodule.mem_inf.mp hy with ⟨hyp, hyr⟩ + refine ⟨Submodule.add_mem p (hs_le_p has) hyp, + Submodule.add_mem (s + r) (Submodule.mem_sup_left has) (Submodule.mem_sup_right hyr)⟩ + have hinter : p ⊓ (s + r) = t := by + have hpr : p ⊓ r = l := adeleFilt_inf_diagonal k K D' + calc p ⊓ (s + r) = s + (p ⊓ r) := hmod + _ = s + l := by rw [hpr] + _ = t := by simp [t, Submodule.add_eq_sup, sup_comm] + let : AddCommGroup ↥p := Submodule.addCommGroup _ + let : Module k ↥p := Submodule.module _ + let : AddCommGroup ↥(p + r) := Submodule.addCommGroup _ + let : Module k ↥(p + r) := Submodule.module _ + let qp := Submodule.comap p.subtype s + let qt := Submodule.comap p.subtype t + have hqp : qp ≤ qt := Submodule.comap_mono hst + have hpsum : p ⊔ (s + r) = p + r := by + rw [← Submodule.add_eq_sup] + apply le_antisymm + · refine sup_le le_sup_left (add_le_add hs_le_p le_rfl) + · intro x hx + rcases Submodule.mem_sup.mp hx with ⟨a, ha, b, hb, rfl⟩ + have hb' : b ∈ s + r := Submodule.mem_sup_right hb + exact Submodule.add_mem _ (Submodule.mem_sup_left ha) (Submodule.mem_sup_right hb') + have : AddCommGroup ↥(p ⊔ (s + r)) := Submodule.addCommGroup _ + have : Module k ↥(p ⊔ (s + r)) := Submodule.module _ + have e1 := LinearMap.quotientInfEquivSupQuotient p (s + r) + have hsand : + Module.finrank k (↥(p + r) ⧸ Submodule.comap (p + r).subtype (s + r)) = + Module.finrank k (↥p ⧸ qt) := by + have hinfl : + Submodule.comap p.subtype p ⊓ Submodule.comap p.subtype (s + r) = qt := by + rw [← Submodule.comap_inf, hinter] + have hfin := e1.symm.finrank_eq + rw [← hpsum.symm, hinfl] at hfin + exact hfin + have hE : IsEffective k K (D' - D) := (le_iff_sub_effective k K).mp h + have e2 := Submodule.quotientQuotientEquivQuotient qp qt hqp + have hdiv : D + (D' - D) = D' := by ext w; simp [sub_eq_add_neg] + have : Module.Finite k (↥p ⧸ qp) := + finiteAdeleFiltDiff_quotient_add_eq k K (M := D) hdiv.symm hE + have hsecond : Module.finrank k (Submodule.map qp.mkQ qt) = finrankRRspaceDiff k K D D' := by + have hld : l ⊓ s = Submodule.map (diagonal k K) (RRspace k K D) := by + refine Submodule.ext fun a => ⟨?_, ?_⟩ + · rintro ⟨hxl, hxs⟩ + rcases hxl with ⟨f, hf, rfl⟩ + refine ⟨f, fun v => ?_, rfl⟩ + have hxv := hxs v + simpa [memRRspace, memAdeleFilt, placeValuation, diagonal, adeleFilt, s] using hxv + · rintro ⟨f, hf, rfl⟩ + refine ⟨⟨f, RRspace_mono k K h hf, rfl⟩, fun v => ?_⟩ + simpa [memRRspace, memAdeleFilt, placeValuation, diagonal, adeleFilt, s] using hf v + have hfin_map := finrank_map_comap_mkQ_eq_quotient k K hs_le_p htp hst + let st := Submodule.comap t.subtype s + let qpInQt := Submodule.comap qt.subtype qp + let : AddCommGroup ↥t := Submodule.addCommGroup _ + let : Module k ↥t := Submodule.module _ + let eT := Submodule.comapSubtypeEquivOfLe htp + have hmap : st.map (eT.symm : ↥t →ₗ[k] ↥qt) = qpInQt := by + ext x + simp [Submodule.mem_comap, st, qpInQt, qp, qt, eT] + have eTS : ((↥t) ⧸ st) ≃ₗ[k] ((↥qt) ⧸ qpInQt) := + Submodule.Quotient.equiv st qpInQt eT.symm hmap + have e3 := LinearMap.quotientInfEquivSupQuotient l s + let : AddCommGroup ↥(l ⊔ s) := Submodule.addCommGroup _ + let : Module k ↥(l ⊔ s) := Submodule.module _ + let : AddCommGroup ↥l := Submodule.addCommGroup _ + let : Module k ↥l := Submodule.module _ + dsimp [finrankRRspaceDiff] + calc + Module.finrank k (Submodule.map qp.mkQ qt) + = Module.finrank k (↥qt ⧸ Submodule.comap qt.subtype qp) := hfin_map + _ = Module.finrank k (↥t ⧸ st) := eTS.finrank_eq.symm + _ = Module.finrank k (↥(l ⊔ s) ⧸ Submodule.comap (l ⊔ s).subtype s) := rfl + _ = Module.finrank k + (↥l ⧸ (Submodule.comap l.subtype l ⊓ Submodule.comap l.subtype s)) := + e3.symm.finrank_eq + _ = Module.finrank k + ((RRspace k K D') ⧸ Submodule.comap (RRspace k K D').subtype (RRspace k K D)) := by + let pR := RRspace k K D' + let qR := Submodule.comap pR.subtype (RRspace k K D) + let qInL : Submodule k ↥l := + Submodule.comap l.subtype (Submodule.map (diagonal k K) (RRspace k K D)) + let f' := (diagonal k K).comp pR.subtype + have hf' : ∀ g, f' g ∈ l := fun g => Submodule.mem_map.mpr ⟨g, g.property, rfl⟩ + let f : pR →ₗ[k] l := f'.codRestrict l hf' + have hf_ker : f.ker = ⊥ := by + rw [eq_bot_iff] + intro g hg + apply Subtype.ext + let w : PlaceA k K := Classical.choice (nonempty_placeA k K) + have hfg := LinearMap.mem_ker.mp hg + have hzero : (f g : AdeleSpace k K) = 0 := congrArg Subtype.val hfg + have hz : ((f g : AdeleSpace k K).val : PlaceA k K → K) w = 0 := by + rw [hzero] + simp + simpa [f, f', diagonal, LinearMap.comp_apply, Submodule.coe_subtype] using hz + have hf_inj : Function.Injective f := by + intro g₁ g₂ hfg + have hmem : g₁ - g₂ ∈ f.ker := by + rw [LinearMap.mem_ker, map_sub, hfg, sub_self] + rw [hf_ker] at hmem + exact sub_eq_zero.mp hmem + have hf_surj : Function.Surjective f := by + rintro ⟨a, g, hg, rfl⟩ + exact ⟨⟨g, hg⟩, rfl⟩ + let eL : pR ≃ₗ[k] l := LinearEquiv.ofBijective f ⟨hf_inj, hf_surj⟩ + have hmap : qR.map f = qInL := by + ext x + simp only [Submodule.mem_map, Submodule.mem_comap, qR, qInL, l] + constructor + · rintro ⟨g, hg, heq⟩ + refine ⟨g.val, ?_, ?_⟩ + · simpa [mem_RRspace_iff] using hg + · rw [← heq] + rfl + · rintro ⟨y, hy, hxy⟩ + refine ⟨⟨y, RRspace_mono k K h hy⟩, ?_, ?_⟩ + · simpa [mem_RRspace_iff] using hy + · apply Subtype.ext + exact hxy + have eQuot : (pR ⧸ qR) ≃ₗ[k] (l ⧸ qInL) := Submodule.Quotient.equiv qR qInL eL hmap + rw [← Submodule.comap_inf, hld, eQuot.finrank_eq] + have hsplit : + Module.finrank k (↥p ⧸ qt) = + finrankAdeleFiltDiff k K D D' - finrankRRspaceDiff k K D D' := by + unfold finrankAdeleFiltDiff + have hfin := finrank_adeleFilt_quotient k K h + have hle' : finrankRRspaceDiff k K D D' ≤ finrankAdeleFiltDiff k K D D' := by + rw [hfin] + exact finrank_RRspace_quotient_le k K h + have hadd := Submodule.finrank_quotient_add_finrank (Submodule.map qp.mkQ qt) + rw [e2.finrank_eq, hsecond] at hadd + exact (Nat.sub_eq_of_eq_add hadd.symm).symm + have hfin := finrank_adeleFilt_quotient k K h + have hdeg : 0 ≤ deg k K (D' - D) := deg_nonneg k K hE + have htoNat : ((deg k K (D' - D)).toNat : ℤ) = deg k K (D' - D) := + Int.toNat_of_nonneg hdeg + have hrr := finrankRRspaceDiff_add_ell k K h + have hle : finrankRRspaceDiff k K D D' ≤ finrankAdeleFiltDiff k K D D' := by + rw [hfin] + exact finrank_RRspace_quotient_le k K h + dsimp only [sandwichRank] + have hmain : + (Int.ofNat (Module.finrank k (↥(p + r) ⧸ Submodule.comap (p + r).subtype (s + r)))) = + (finrankAdeleFiltDiff k K D D' - finrankRRspaceDiff k K D D') := by + rw [hsand, hsplit] + simp only [Int.ofNat_eq_natCast, Nat.cast_sub hle] + rw [hmain, hfin, htoNat] + have hrrZ : (finrankRRspaceDiff k K D D' : ℤ) = ell k K D' - ell k K D := by + rw [finrankRRspaceDiff, ell, ell, + ← (Submodule.comapSubtypeEquivOfLe (RRspace_mono k K h)).finrank_eq] at hrr ⊢ + omega + rw [hrrZ, deg_sub k K D' D] + omega + +theorem sandwichDiagonal_inter {D D' : DivisorA k K} (h : D ≤ D') : + adeleFilt k K D' ⊓ (adeleFilt k K D + diagonalSubmodule k K) = + Submodule.map (diagonal k K) (RRspace k K D') ⊔ adeleFilt k K D := by + let p := adeleFilt k K D' + let s := adeleFilt k K D + let r := diagonalSubmodule k K + let l := Submodule.map (diagonal k K) (RRspace k K D') + let t := l ⊔ s + have hs_le_p : s ≤ p := adeleFilt_mono k K h + have hmod : p ⊓ (s + r) = s + p ⊓ r := by + apply le_antisymm + · rintro x ⟨hxp, hxsr⟩ + rcases Submodule.mem_sup.mp hxsr with ⟨a, has, y, hy, rfl⟩ + obtain ⟨f, rfl⟩ := LinearMap.mem_range.mp hy + refine Submodule.mem_sup.mpr ⟨a, has, (diagonal k K f), ?_, rfl⟩ + exact Submodule.mem_inf.mpr + ⟨(by simpa [sub_add_cancel] using Submodule.sub_mem p hxp (hs_le_p has)), hy⟩ + · rintro x hx + rcases Submodule.mem_sup.mp hx with ⟨a, has, y, hy, rfl⟩ + rcases Submodule.mem_inf.mp hy with ⟨hyp, hyr⟩ + refine ⟨Submodule.add_mem p (hs_le_p has) hyp, + Submodule.add_mem (s + r) (Submodule.mem_sup_left has) (Submodule.mem_sup_right hyr)⟩ + have hpr : p ⊓ r = l := adeleFilt_inf_diagonal k K D' + calc + p ⊓ (s + r) = s + p ⊓ r := hmod + _ = s + l := by rw [hpr] + _ = t := by simp [t, Submodule.add_eq_sup, sup_comm] + +theorem sandwichDiagonalSubmodule_eq_of_rank_zero {D D' : DivisorA k K} (hle : D ≤ D') + (h0 : sandwichRank k K D D' hle = 0) : + adeleFilt k K D' + diagonalSubmodule k K = adeleFilt k K D + diagonalSubmodule k K := by + let p := adeleFilt k K D' + let s := adeleFilt k K D + let r := diagonalSubmodule k K + let t := Submodule.map (diagonal k K) (RRspace k K D') ⊔ s + let qp := Submodule.comap p.subtype s + let qt := Submodule.comap p.subtype t + have hqp_le : qp ≤ qt := Submodule.comap_mono le_sup_right + have hE : IsEffective k K (D' - D) := (le_iff_sub_effective k K).mp hle + have hdiv : D + (D' - D) = D' := by abel + have : Module.Finite k (↥p ⧸ qp) := + finiteAdeleFiltDiff_quotient_add_eq k K (M := D) hdiv.symm hE + have htp : t ≤ p := by + rintro x hx + rcases Submodule.mem_sup.mp hx with ⟨y, hy, z, hz, rfl⟩ + rcases hy with ⟨f, hf, rfl⟩ + exact Submodule.add_mem p + (by simpa [adeleFilt, memAdeleFilt, memRRspace, RRspace, diagonal, p] using hf) + (adeleFilt_mono k K hle hz) + let : AddCommGroup ↥p := Submodule.addCommGroup _ + let : Module k ↥p := Submodule.module _ + let : AddCommGroup ↥(p + r) := Submodule.addCommGroup _ + let : Module k ↥(p + r) := Submodule.module _ + let : AddCommGroup ↥(adeleFilt k K D' + diagonalSubmodule k K) := Submodule.addCommGroup _ + let : Module k ↥(adeleFilt k K D' + diagonalSubmodule k K) := Submodule.module _ + have hfin_qt : Module.finrank k (↥p ⧸ qt) = 0 := by + have hfin_sandwich : + Module.finrank k + (↥(adeleFilt k K D' + diagonalSubmodule k K) ⧸ + Submodule.comap (adeleFilt k K D' + diagonalSubmodule k K).subtype + (adeleFilt k K D + diagonalSubmodule k K)) = 0 := + Int.ofNat_eq_zero.mp (by simpa [sandwichRank] using h0) + have hinter := sandwichDiagonal_inter k K hle + have hinfl : Submodule.comap p.subtype p ⊓ Submodule.comap p.subtype (s + r) = qt := by + rw [← Submodule.comap_inf, hinter] + have hpsum : p ⊔ (s + r) = p + r := by + rw [← Submodule.add_eq_sup] + apply le_antisymm + · refine sup_le le_sup_left (add_le_add (adeleFilt_mono k K hle) le_rfl) + · intro x hx + rcases Submodule.mem_sup.mp hx with ⟨a, ha, b, hb, rfl⟩ + have hb' : b ∈ s + r := Submodule.mem_sup_right hb + exact Submodule.add_mem _ (Submodule.mem_sup_left ha) (Submodule.mem_sup_right hb') + have hsand := + (LinearMap.quotientInfEquivSupQuotient p (s + r)).symm.finrank_eq + rw [hpsum, hinfl] at hsand + exact hsand.symm.trans hfin_sandwich + have : Module.Finite k (↥p ⧸ qt) := + Module.Finite.equiv (Submodule.quotientQuotientEquivQuotient qp qt hqp_le) + have hrk : Module.rank k (↥p ⧸ qt) = 0 := by + rw [← Module.finrank_eq_rank, hfin_qt, Nat.cast_zero] + have hsub : Subsingleton (↥p ⧸ qt) := rank_zero_iff.mp hrk + have htopqt : qt = ⊤ := Submodule.Quotient.subsingleton_iff.mp hsub + have hp_le_t : p ≤ t := Submodule.comap_subtype_eq_top.mp htopqt + have hp_eq_t : p = t := le_antisymm hp_le_t htp + have hinter := sandwichDiagonal_inter k K hle + have hp_le_sr : p ≤ s + r := by + have h := inf_le_right (a := p) (b := s + r) + rw [hinter] at h + exact hp_eq_t.symm ▸ h + have hsr_le_pr : s + r ≤ p + r := add_le_add (adeleFilt_mono k K hle) le_rfl + have hpr_le_sr : p + r ≤ s + r := by + intro x hx + rcases Submodule.mem_sup.mp hx with ⟨a, hap, y, hyr, rfl⟩ + rcases Submodule.mem_sup.mp (hp_le_sr hap) with ⟨b, hbs, w, hwr, hbc⟩ + refine Submodule.mem_sup.mpr + ⟨b, hbs, w + y, Submodule.add_mem r hwr hyr, by rw [← hbc, add_assoc]⟩ + exact le_antisymm hpr_le_sr hsr_le_pr + +end FunctionField.Chart + +end diff --git a/LeanPool/MarkoffModP/RiemannRoch/AxiomCheck.lean b/LeanPool/MarkoffModP/RiemannRoch/AxiomCheck.lean new file mode 100644 index 0000000000..26aabca336 --- /dev/null +++ b/LeanPool/MarkoffModP/RiemannRoch/AxiomCheck.lean @@ -0,0 +1,13 @@ +/- +Copyright (c) 2026 Yuma Mizuno. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuma Mizuno +-/ +module + + +/- +Kernel-level axiom audit for the vendored coordinate-free Riemann--Roch core. +-/ + +public import LeanPool.MarkoffModP.RiemannRoch.CoordinateFree.RiemannRoch diff --git a/LeanPool/MarkoffModP/RiemannRoch/Basic.lean b/LeanPool/MarkoffModP/RiemannRoch/Basic.lean new file mode 100644 index 0000000000..de906ce43a --- /dev/null +++ b/LeanPool/MarkoffModP/RiemannRoch/Basic.lean @@ -0,0 +1,86 @@ +/- +Copyright (c) 2026 Guanghao Li. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Guanghao Li +-/ + +module + +public import LeanPool.MarkoffModP.RiemannRoch.FunctionField.Divisor +public import Mathlib.FieldTheory.AlgebraicClosure +public import Mathlib.FieldTheory.RatFunc.Basic + +/-! +# Basic divisor API aliases + +This file re-exports the coordinate divisor API from `FunctionField.Divisor` under the names +used in downstream modules (`degA`, `placeDegA`), and hosts the standing +`IsFullConstantField` hypothesis. +-/ + +@[expose] public section + +open scoped nonZeroDivisors Polynomial RatFunc + +noncomputable section + +namespace FunctionField + +open Chart + +variable (k K : Type*) [Field k] [Field K] + [Algebra k K] [Algebra k[X] K] [Algebra k⟮X⟯ K] + [IsScalarTower k[X] k⟮X⟯ K] [_root_.FunctionField k K] + [Algebra.IsSeparable k⟮X⟯ K] + +/-- Backward-compatible alias for `placeDegree`. -/ +abbrev placeDegA (v : PlaceA k K) : ℕ := placeDegree k K v + +/-- Backward-compatible alias for `deg`. -/ +noncomputable abbrev degA (D : DivisorA k K) : ℤ := deg k K D + +/-- Every element of `K` that is algebraic over the base field `k` is already in `k`. + +This is the standing hypothesis for the Stichtenoth/Serre adelic proof track. It is equivalent +to `k` being relatively algebraically closed in `K`, i.e. Mathlib's `algebraicClosure k K = ⊥`; +see `FunctionField.isFullConstantField_iff_algebraicClosure_eq_bot`. -/ +class IsFullConstantField (k K : Type*) [Field k] [Field K] [Algebra k K] : Prop where + /-- Every element of `K` that is algebraic over `k` already lies in the image of `k`. -/ + algebraic_mem : ∀ x : K, IsAlgebraic k x → ∃ c : k, x = algebraMap k K c + +namespace IsFullConstantField + +variable (k K : Type*) [Field k] [Field K] [Algebra k K] [IsFullConstantField k K] + +theorem mem_range {x : K} (hx : IsAlgebraic k x) : + x ∈ Set.range (algebraMap k K) := by + obtain ⟨c, hc⟩ := IsFullConstantField.algebraic_mem (k := k) (K := K) x hx + exact ⟨c, hc.symm⟩ + +end IsFullConstantField + +/-- `IsFullConstantField k K` is exactly the statement that `k` is relatively algebraically +closed in `K`, i.e. it coincides with Mathlib's `algebraicClosure k K = ⊥`. This identifies the +standing hypothesis with the standard field-theoretic notion. -/ +theorem isFullConstantField_iff_algebraicClosure_eq_bot (k K : Type*) [Field k] [Field K] + [Algebra k K] : IsFullConstantField k K ↔ algebraicClosure k K = ⊥ := by + constructor + · intro h + rw [eq_bot_iff] + intro x hx + obtain ⟨c, rfl⟩ := h.algebraic_mem x (mem_algebraicClosure_iff.mp hx) + exact (⊥ : IntermediateField k K).algebraMap_mem c + · intro h + refine ⟨fun x hx => ?_⟩ + have hxb : x ∈ (⊥ : IntermediateField k K) := h ▸ mem_algebraicClosure_iff.mpr hx + obtain ⟨c, hc⟩ := IntermediateField.mem_bot.mp hxb + exact ⟨c, hc.symm⟩ + +instance ratFuncIsFullConstantField : IsFullConstantField k (RatFunc k) where + algebraic_mem x hx := by + by_contra h + exact RatFunc.transcendental_of_ne_C x h hx + +end FunctionField + +end diff --git a/LeanPool/MarkoffModP/RiemannRoch/CoordinateFree/AdeleSpace.lean b/LeanPool/MarkoffModP/RiemannRoch/CoordinateFree/AdeleSpace.lean new file mode 100644 index 0000000000..b425880bd5 --- /dev/null +++ b/LeanPool/MarkoffModP/RiemannRoch/CoordinateFree/AdeleSpace.lean @@ -0,0 +1,246 @@ +/- +Copyright (c) 2026 Guanghao Li. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Guanghao Li +-/ + +module + +public import LeanPool.MarkoffModP.RiemannRoch.AdeleSpace.Basic +public import LeanPool.MarkoffModP.RiemannRoch.CoordinateFree.Divisor + +/-! +# Adeles indexed by intrinsic places + +This file defines the function-field adele space directly as a restricted product over +coordinate-free places. The equivalence `adeleEquivChart` identifies it with the two-chart +construction and transports the filtration and diagonal embedding. +-/ + +@[expose] public section + +open scoped nonZeroDivisors Polynomial RatFunc WithZero +open Filter + +noncomputable section + +namespace FunctionField + +open Chart + +variable (k K : Type*) [Field k] [Field K] +variable [Algebra k K] [Algebra k[X] K] [Algebra k⟮X⟯ K] + [IsScalarTower k k[X] K] [IsScalarTower k[X] k⟮X⟯ K] [_root_.FunctionField k K] + [Algebra.IsSeparable k⟮X⟯ K] + +/-- The `k`-submodule of tuples over intrinsic places that are integral almost everywhere. -/ +def adeleSubmodule : Submodule k (Place k K → K) where + carrier := {a | ∀ᶠ v in cofinite, a v ∈ v.toValuationSubring} + zero_mem' := by + change ∀ᶠ v : Place k K in cofinite, (0 : K) ∈ v.toValuationSubring + exact Filter.Eventually.of_forall fun v => v.toValuationSubring.zero_mem + add_mem' {a b} ha hb := by + change ∀ᶠ v in cofinite, a v ∈ v.toValuationSubring at ha + change ∀ᶠ v in cofinite, b v ∈ v.toValuationSubring at hb + change ∀ᶠ v in cofinite, (a + b) v ∈ v.toValuationSubring + exact (ha.and hb).mono fun _ h => add_mem h.1 h.2 + smul_mem' c a ha := by + change ∀ᶠ v in cofinite, a v ∈ v.toValuationSubring at ha + change ∀ᶠ v in cofinite, (c • a) v ∈ v.toValuationSubring + filter_upwards [ha] with v hv + rw [Pi.smul_apply, Algebra.smul_def] + exact mul_mem (v.triv_on_k c) hv + +/-- The intrinsic, `K`-valued adele space. -/ +abbrev AdeleSpace := adeleSubmodule k K + +/-- Every element of the function field is integral at all but finitely many intrinsic places. -/ +theorem eventually_mem_place (f : K) : + ∀ᶠ v : Place k K in cofinite, f ∈ v.toValuationSubring := by + have h := Chart.eventually_mem_placeValuationSubring k K f + have h' := (chartToPlace k K).symm.injective.tendsto_cofinite.eventually h + filter_upwards [h'] with v hv + rw [← (chartToPlace k K).apply_symm_apply v, chartToPlace_apply, + Place.ofChart_toValuationSubring] + exact hv + +/-- Reindex an intrinsic adele along the equivalence between chart and intrinsic places. -/ +noncomputable def adeleEquivChart : AdeleSpace k K ≃ₗ[k] Chart.AdeleSpace k K where + toFun a := ⟨fun w => a.1 (chartToPlace k K w), by + have ha := (chartToPlace k K).injective.tendsto_cofinite.eventually a.property + filter_upwards [ha] with w hw + rw [placeValuationSubring, ← Place.ofChart_toValuationSubring] + exact hw⟩ + invFun a := ⟨fun v => a.1 ((chartToPlace k K).symm v), by + have ha := (chartToPlace k K).symm.injective.tendsto_cofinite.eventually a.property + filter_upwards [ha] with v hv + have hs : v.toValuationSubring = + placeValuationSubring k K ((chartToPlace k K).symm v) := by + rw [placeValuationSubring, ← Place.ofChart_toValuationSubring] + exact congrArg Place.toValuationSubring + ((chartToPlace k K).apply_symm_apply v).symm + rw [hs] + exact hv⟩ + left_inv a := by + apply Subtype.ext + funext v + exact congrArg a.1 ((chartToPlace k K).apply_symm_apply v) + right_inv a := by + apply Subtype.ext + funext w + exact congrArg a.1 ((chartToPlace k K).symm_apply_apply w) + map_add' _ _ := rfl + map_smul' _ _ := rfl + +@[simp] +theorem adeleEquivChart_apply (a : AdeleSpace k K) (w : PlaceA k K) : + (adeleEquivChart k K a).1 w = a.1 (chartToPlace k K w) := + rfl + +@[simp] +theorem adeleEquivChart_symm_apply (a : Chart.AdeleSpace k K) (v : Place k K) : + ((adeleEquivChart k K).symm a).1 v = a.1 ((chartToPlace k K).symm v) := + rfl + +/-- Pointwise multiplication of an intrinsic adele by an element of `K`. -/ +def smulAdele (x : K) (a : AdeleSpace k K) : AdeleSpace k K := + ⟨fun v => x * a.1 v, (eventually_mem_place k K x).and a.property |>.mono + fun _ h => mul_mem h.1 h.2⟩ + +instance : SMul K (AdeleSpace k K) := ⟨smulAdele k K⟩ + +instance : Module K (AdeleSpace k K) := + Module.ofMinimalAxioms + (fun _ _ _ => Subtype.ext <| funext fun _ => mul_add _ _ _) + (fun _ _ _ => Subtype.ext <| funext fun _ => add_mul _ _ _) + (fun _ _ _ => Subtype.ext <| funext fun _ => mul_assoc _ _ _) + (fun _ => Subtype.ext <| funext fun _ => one_mul _) + +/-- The intrinsic-to-chart adele equivalence commutes with multiplication by `K`. -/ +@[simp] +theorem adeleEquivChart_smul (x : K) (a : AdeleSpace k K) : + adeleEquivChart k K (x • a) = x • adeleEquivChart k K a := by + ext w + change x * a.1 (chartToPlace k K w) = x * a.1 (chartToPlace k K w) + rfl + +/-- Multiplication by an element of `K` as a `k`-linear endomorphism of intrinsic adeles. -/ +def mulAdeleLinear (x : K) : AdeleSpace k K →ₗ[k] AdeleSpace k K where + toFun a := x • a + map_add' _ _ := smul_add x _ _ + map_smul' c a := by + ext v + change x * (c • a.1 v) = c • (x * a.1 v) + simp only [Algebra.smul_def] + ring + +/-- An intrinsic adele satisfies the bound prescribed by a divisor. -/ +def memAdeleFilt (D : Divisor k K) (a : AdeleSpace k K) : Prop := + ∀ v, v.valuation (a.1 v) ≤ WithZero.exp (D v) + +/-- The intrinsic adele filtration piece `A(D)`. -/ +def adeleFilt (D : Divisor k K) : Submodule k (AdeleSpace k K) where + carrier := {a | memAdeleFilt k K D a} + zero_mem' := fun _ => by simp + add_mem' {a b} ha hb := fun v => + (v.valuation.map_add (a.1 v) (b.1 v)).trans (max_le (ha v) (hb v)) + smul_mem' c a ha := by + intro v + change v.valuation (c • a.1 v) ≤ _ + rw [Algebra.smul_def, map_mul] + have hc : v.valuation (algebraMap k K c) ≤ 1 := by + rw [← Valuation.mem_valuationSubring_iff, Place.valuationSubring_valuation] + exact v.triv_on_k c + exact (mul_le_mul' hc (ha v)).trans_eq (one_mul _) + +/-- Membership in the intrinsic filtration agrees with chart filtration membership. -/ +theorem mem_adeleFilt_equivChart (D : Divisor k K) (a : AdeleSpace k K) : + adeleEquivChart k K a ∈ + Chart.adeleFilt k K ((divisorEquivChart k K).symm D) ↔ + a ∈ adeleFilt k K D := by + constructor + · intro ha v + let w := (chartToPlace k K).symm v + have hw := ha w + rw [← placeValuation_eq] at hw + simpa [w, divisorEquivChart, Finsupp.domCongr_apply] using hw + · intro ha w + have hv := ha (chartToPlace k K w) + rw [placeValuation_eq] at hv + simpa [divisorEquivChart, Finsupp.domCongr_apply] using hv + +omit [Algebra k[X] K] [Algebra k⟮X⟯ K] [IsScalarTower k k[X] K] + [IsScalarTower k[X] k⟮X⟯ K] [_root_.FunctionField k K] + [Algebra.IsSeparable k⟮X⟯ K] in +/-- The intrinsic adele filtration is monotone in the divisor. -/ +theorem adeleFilt_mono {D E : Divisor k K} (h : D ≤ E) : + adeleFilt k K D ≤ adeleFilt k K E := by + intro a ha v + exact (ha v).trans (WithZero.exp_le_exp.mpr (h v)) + +/-- The diagonal embedding of the function field into intrinsic adeles. -/ +def diagonal : K →ₗ[k] AdeleSpace k K where + toFun f := ⟨fun _ => f, eventually_mem_place k K f⟩ + map_add' _ _ := rfl + map_smul' _ _ := rfl + +/-- The image of the intrinsic diagonal embedding. -/ +def diagonalSubmodule : Submodule k (AdeleSpace k K) := + LinearMap.range (diagonal k K) + +@[simp] +theorem adeleEquivChart_diagonal (f : K) : + adeleEquivChart k K (diagonal k K f) = Chart.diagonal k K f := by + ext w + change f = f + rfl + +/-- The chart equivalence maps the intrinsic filtration onto the chart filtration. -/ +theorem map_adeleFilt_equivChart (D : Divisor k K) : + Submodule.map (adeleEquivChart k K).toLinearMap (adeleFilt k K D) = + Chart.adeleFilt k K ((divisorEquivChart k K).symm D) := by + ext a + constructor + · rintro ⟨b, hb, rfl⟩ + exact (mem_adeleFilt_equivChart k K D b).2 hb + · intro ha + refine ⟨(adeleEquivChart k K).symm a, ?_, by simp⟩ + exact (mem_adeleFilt_equivChart k K D _).1 (by simpa using ha) + +/-- The chart equivalence maps the intrinsic diagonal submodule onto the chart diagonal. -/ +theorem map_diagonalSubmodule_equivChart : + Submodule.map (adeleEquivChart k K).toLinearMap (diagonalSubmodule k K) = + Chart.diagonalSubmodule k K := by + ext a + constructor + · rintro ⟨b, ⟨f, rfl⟩, rfl⟩ + exact ⟨f, (adeleEquivChart_diagonal k K f).symm⟩ + · rintro ⟨f, rfl⟩ + exact ⟨diagonal k K f, ⟨f, rfl⟩, adeleEquivChart_diagonal k K f⟩ + +/-- The chart equivalence maps `A(D)` plus the diagonal onto the corresponding chart submodule. -/ +theorem map_adeleFilt_add_diagonal_equivChart (D : Divisor k K) : + Submodule.map (adeleEquivChart k K).toLinearMap + (adeleFilt k K D + diagonalSubmodule k K) = + Chart.adeleFilt k K ((divisorEquivChart k K).symm D) + + Chart.diagonalSubmodule k K := by + rw [Submodule.add_eq_sup, + Submodule.map_sup (adeleFilt k K D) (diagonalSubmodule k K) + (adeleEquivChart k K).toLinearMap, + map_adeleFilt_equivChart, + map_diagonalSubmodule_equivChart, ← Submodule.add_eq_sup] + +/-- Membership in `A(D)` plus the diagonal is preserved by the chart equivalence. -/ +theorem mem_adeleFilt_add_diagonal_equivChart (D : Divisor k K) (a : AdeleSpace k K) : + adeleEquivChart k K a ∈ + Chart.adeleFilt k K ((divisorEquivChart k K).symm D) + + Chart.diagonalSubmodule k K ↔ + a ∈ adeleFilt k K D + diagonalSubmodule k K := by + rw [← map_adeleFilt_add_diagonal_equivChart k K D] + constructor + · rintro ⟨b, hb, hba⟩ + exact (adeleEquivChart k K).injective hba |>.symm ▸ hb + · intro ha + exact ⟨a, ha, rfl⟩ + +end FunctionField diff --git a/LeanPool/MarkoffModP/RiemannRoch/CoordinateFree/AlgEquiv.lean b/LeanPool/MarkoffModP/RiemannRoch/CoordinateFree/AlgEquiv.lean new file mode 100644 index 0000000000..fc78ce4a53 --- /dev/null +++ b/LeanPool/MarkoffModP/RiemannRoch/CoordinateFree/AlgEquiv.lean @@ -0,0 +1,290 @@ +/- +Copyright (c) 2026 Guanghao Li. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Guanghao Li +-/ + +module + +public import LeanPool.MarkoffModP.RiemannRoch.CoordinateFree.RiemannRoch + +/-! +# Coordinate-free transport along algebra equivalences + +This file proves that intrinsic places, divisors, Riemann--Roch spaces, and genus are invariant +under an equivalence of function fields over the constant field. No rational-function chart or +function-field hypotheses are needed: the intrinsic definitions only use the two field structures +and their algebras over the common constant field. +-/ + +@[expose] public section + +open scoped WithZero + +noncomputable section + +namespace FunctionField + +open MonoidWithZeroHom + +namespace Place + +variable {k K L : Type*} [Field k] [Field K] [Field L] + [Algebra k K] [Algebra k L] + +/-- The normalized valuation associated to an intrinsic place is surjective. -/ +theorem valuation_surjective (v : Place k K) : + Function.Surjective v.valuation := by + intro z + obtain ⟨y, rfl⟩ := v.normalization.surjective z + obtain ⟨x, hx⟩ := + (ValueGroup₀.restrict₀_surjective + v.toValuationSubring.valuation.toMonoidWithZeroHom) y + refine ⟨x, ?_⟩ + change v.normalization + (v.toValuationSubring.valuation.restrict x) = v.normalization y + exact congrArg v.normalization hx + +/-- Transport an intrinsic place through an algebra equivalence. -/ +noncomputable def mapAlgEquiv (e : K ≃ₐ[k] L) (v : Place k K) : Place k L := by + let q : Valuation L (WithZero (Multiplicative ℤ)) := + v.valuation.comap e.symm.toRingHom + have hqnontrivial : q.IsNontrivial := by + obtain ⟨x, hx0, hx1⟩ := + (inferInstance : v.valuation.IsNontrivial).exists_val_nontrivial + refine ⟨e x, ?_, ?_⟩ + · simpa [q] using hx0 + · simpa [q] using hx1 + letI : q.IsNontrivial := hqnontrivial + letI : q.IsRankOneDiscrete := Valuation.IsRankOneDiscrete.mk' q + refine + { toValuationSubring := q.valuationSubring + ne_top := by + intro htop + exact (Valuation.valuationSubring_eq_top_iff q).mp htop hqnontrivial + triv_on_k := fun c => by + rw [Valuation.mem_valuationSubring_iff] + have hc : v.valuation (algebraMap k K c) ≤ 1 := by + rw [← Valuation.mem_valuationSubring_iff, + Place.valuationSubring_valuation] + exact v.triv_on_k c + change v.valuation (e.symm (algebraMap k L c)) ≤ 1 + rw [e.symm.commutes] + exact hc + isDiscrete := by + let h := Valuation.isEquiv_valuation_valuationSubring q + exact ⟨h.orderMonoidIso.symm.trans + (Valuation.IsRankOneDiscrete.valueGroup₀_equiv_withZeroMulInt q)⟩ } + +/-- The valuation subring of a transported place is the corresponding pullback. -/ +@[simp] +theorem mapAlgEquiv_toValuationSubring (e : K ≃ₐ[k] L) (v : Place k K) : + (mapAlgEquiv e v).toValuationSubring = + v.toValuationSubring.comap e.symm.toRingHom := by + ext x + change v.valuation (e.symm x) ≤ 1 ↔ e.symm x ∈ v.toValuationSubring + rw [← Place.valuationSubring_valuation v] + rw [Valuation.mem_valuationSubring_iff] + +/-- Intrinsic places are equivalent under an equivalence of their ambient fields. -/ +noncomputable def algEquiv (e : K ≃ₐ[k] L) : Place k K ≃ Place k L where + toFun := mapAlgEquiv e + invFun := mapAlgEquiv e.symm + left_inv v := by + apply Place.ext + rw [mapAlgEquiv_toValuationSubring, mapAlgEquiv_toValuationSubring] + ext x + simp + right_inv v := by + apply Place.ext + rw [mapAlgEquiv_toValuationSubring, mapAlgEquiv_toValuationSubring] + ext x + simp + +/-- Transporting a place preserves its normalized valuation exactly. -/ +theorem mapAlgEquiv_valuation_eq_comap (e : K ≃ₐ[k] L) (v : Place k K) : + (mapAlgEquiv e v).valuation = + v.valuation.comap e.symm.toRingHom := by + let q : Valuation L (WithZero (Multiplicative ℤ)) := + v.valuation.comap e.symm.toRingHom + have hqsurj : Function.Surjective q := by + intro z + obtain ⟨x, hx⟩ := valuation_surjective v z + refine ⟨e x, ?_⟩ + simpa [q] using hx + have hqnontrivial : q.IsNontrivial := by + obtain ⟨x, hx0, hx1⟩ := + (inferInstance : v.valuation.IsNontrivial).exists_val_nontrivial + refine ⟨e x, ?_, ?_⟩ + · simpa [q] using hx0 + · simpa [q] using hx1 + let : q.IsNontrivial := hqnontrivial + let : q.IsRankOneDiscrete := Valuation.IsRankOneDiscrete.mk' q + let V := q.valuationSubring + let h := Valuation.isEquiv_valuation_valuationSubring q + let ε : ValueGroup₀ (.ofClass V.valuation) ≃*o + WithZero (Multiplicative ℤ) := + h.orderMonoidIso.symm.trans + (Valuation.IsRankOneDiscrete.valueGroup₀_equiv_withZeroMulInt q) + have hnorm : (mapAlgEquiv e v).normalization = ε := + orderMonoidIso_withZeroMulInt_unique _ _ + ext x + change (mapAlgEquiv e v).normalization + (V.valuation.restrict x) = q x + rw [hnorm] + change (Valuation.IsRankOneDiscrete.valueGroup₀_equiv_withZeroMulInt q) + (h.orderMonoidIso.symm (V.valuation.restrict x)) = q x + rw [show h.orderMonoidIso.symm (V.valuation.restrict x) = q.restrict x by + change h.orderMonoidIso.symm + (q.valuationSubring.valuation.restrict x) = q.restrict x + exact h.orderMonoidIso.symm_apply_eq.mpr + (h.orderMonoidIso_spec x).symm] + exact + Valuation.IsRankOneDiscrete.valueGroup₀_equiv_withZeroMulInt_restrict_apply_of_surjective + hqsurj x + +/-- Evaluation of normalized valuations is preserved by transport. -/ +@[simp] +theorem algEquiv_valuation_apply (e : K ≃ₐ[k] L) (v : Place k K) (x : K) : + ((algEquiv e) v).valuation (e x) = v.valuation x := by + change (mapAlgEquiv e v).valuation (e x) = v.valuation x + rw [mapAlgEquiv_valuation_eq_comap] + simp + +/-- The valuation subrings at corresponding places are equivalent as constant-field algebras. -/ +noncomputable def valuationSubringAlgEquiv (e : K ≃ₐ[k] L) (v : Place k K) : + v.toValuationSubring ≃ₐ[k] ((algEquiv e) v).toValuationSubring := by + let f : v.toValuationSubring →ₐ[k] + ((algEquiv e) v).toValuationSubring := + { toFun := fun x => ⟨e x, by + change e x ∈ (mapAlgEquiv e v).toValuationSubring + rw [mapAlgEquiv_toValuationSubring] + change e.symm (e x) ∈ v.toValuationSubring + rw [e.symm_apply_apply] + exact x.property⟩ + map_one' := by ext; simp + map_mul' := by intro x y; ext; simp + map_zero' := by ext; simp + map_add' := by intro x y; ext; simp + commutes' := fun c => by + apply Subtype.ext + change e (algebraMap k K c) = algebraMap k L c + exact e.commutes c } + apply AlgEquiv.ofBijective f + constructor + · intro x y hxy + apply Subtype.ext + exact e.injective (congrArg Subtype.val hxy) + · intro y + refine ⟨⟨e.symm y, ?_⟩, ?_⟩ + · have hy := y.property + change y.1 ∈ (mapAlgEquiv e v).toValuationSubring at hy + rw [mapAlgEquiv_toValuationSubring] at hy + exact hy + · apply Subtype.ext + simp [f] + +/-- Residue fields at corresponding places are equivalent over the constant field. -/ +noncomputable def residueFieldAlgEquiv (e : K ≃ₐ[k] L) (v : Place k K) : + v.residueField ≃ₐ[k] ((algEquiv e) v).residueField := + IsLocalRing.ResidueField.mapAlgEquiv (valuationSubringAlgEquiv e v) + +/-- Place degree is preserved under an equivalence of ambient fields. -/ +@[simp] +theorem degree_algEquiv (e : K ≃ₐ[k] L) (v : Place k K) : + ((algEquiv e) v).degree = v.degree := + (residueFieldAlgEquiv e v).toLinearEquiv.finrank_eq.symm + +end Place + +variable {k K L : Type*} [Field k] [Field K] [Field L] + [Algebra k K] [Algebra k L] + +/-- Reindex intrinsic divisors through an equivalence of their ambient fields. -/ +noncomputable def divisorAlgEquiv (e : K ≃ₐ[k] L) : + Divisor k K ≃+ Divisor k L := + Finsupp.domCongr (Place.algEquiv e) + +/-- Intrinsic divisor degree is preserved by ambient-field equivalence. -/ +@[simp] +theorem Divisor.deg_algEquiv (e : K ≃ₐ[k] L) (D : Divisor k K) : + Divisor.deg k L (divisorAlgEquiv e D) = Divisor.deg k K D := by + classical + induction D using Finsupp.induction with + | zero => simp [Divisor.deg, divisorAlgEquiv] + | single_add a b f ha hb ih => + rw [map_add, Divisor.deg_add, Divisor.deg_add, ih] + congr 1 + simp [Divisor.deg, divisorAlgEquiv, Finsupp.domCongr_apply, + Finsupp.equivMapDomain_single] + +/-- Riemann--Roch membership is preserved by ambient-field equivalence. -/ +theorem memRRspace_algEquiv_iff (e : K ≃ₐ[k] L) (D : Divisor k K) (x : K) : + memRRspace k L (divisorAlgEquiv e D) (e x) ↔ memRRspace k K D x := by + constructor + · intro hx v + have hv := hx ((Place.algEquiv e) v) + simpa [divisorAlgEquiv, Finsupp.domCongr_apply] using hv + · intro hx w + let v := (Place.algEquiv e).symm w + have hv := hx v + have hw : (Place.algEquiv e) v = w := + (Place.algEquiv e).apply_symm_apply w + rw [← hw] + simpa [divisorAlgEquiv, Finsupp.domCongr_apply] using hv + +/-- The image of an intrinsic Riemann--Roch space is the transported space. -/ +theorem RRspace_map_algEquiv (e : K ≃ₐ[k] L) (D : Divisor k K) : + Submodule.map e.toLinearEquiv.toLinearMap (RRspace k K D) = + RRspace k L (divisorAlgEquiv e D) := by + ext y + constructor + · rintro ⟨x, hx, rfl⟩ + change memRRspace k K D x at hx + change memRRspace k L (divisorAlgEquiv e D) (e x) + exact (memRRspace_algEquiv_iff e D x).2 hx + · intro hy + change memRRspace k L (divisorAlgEquiv e D) y at hy + refine ⟨e.symm y, ?_, e.apply_symm_apply y⟩ + change memRRspace k K D (e.symm y) + apply (memRRspace_algEquiv_iff e D (e.symm y)).1 + simpa using hy + +/-- Corresponding intrinsic Riemann--Roch spaces are linearly equivalent. -/ +noncomputable def RRspaceAlgEquiv (e : K ≃ₐ[k] L) (D : Divisor k K) : + RRspace k K D ≃ₗ[k] RRspace k L (divisorAlgEquiv e D) := + e.toLinearEquiv.ofSubmodules _ _ (RRspace_map_algEquiv e D) + +/-- Riemann--Roch dimension is invariant under ambient-field equivalence. -/ +@[simp] +theorem ell_algEquiv (e : K ≃ₐ[k] L) (D : Divisor k K) : + ell k L (divisorAlgEquiv e D) = ell k K D := by + exact (RRspaceAlgEquiv e D).finrank_eq.symm + +/-- Divisor defect is invariant under ambient-field equivalence. -/ +@[simp] +theorem defect_algEquiv (e : K ≃ₐ[k] L) (D : Divisor k K) : + defect k L (divisorAlgEquiv e D) = defect k K D := by + rw [defect, defect, Divisor.deg_algEquiv, ell_algEquiv] + +/-- Intrinsic function-field genus is invariant under an equivalence over the constant field. -/ +theorem genus_eq_of_algEquiv (e : K ≃ₐ[k] L) : + genus k K = genus k L := by + let E := divisorAlgEquiv e + have hsets : + {d : ℤ | ∃ D : Divisor k K, defect k K D = d} = + {d : ℤ | ∃ D : Divisor k L, defect k L D = d} := by + ext d + constructor + · rintro ⟨D, hD⟩ + refine ⟨E D, ?_⟩ + rw [defect_algEquiv] + exact hD + · rintro ⟨D, hD⟩ + refine ⟨E.symm D, ?_⟩ + rw [← defect_algEquiv e (E.symm D), E.apply_symm_apply] + exact hD + unfold genus + rw [hsets] + +end FunctionField diff --git a/LeanPool/MarkoffModP/RiemannRoch/CoordinateFree/Divisor.lean b/LeanPool/MarkoffModP/RiemannRoch/CoordinateFree/Divisor.lean new file mode 100644 index 0000000000..542e93d7c7 --- /dev/null +++ b/LeanPool/MarkoffModP/RiemannRoch/CoordinateFree/Divisor.lean @@ -0,0 +1,221 @@ +/- +Copyright (c) 2026 Guanghao Li. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Guanghao Li +-/ + +module + +public import LeanPool.MarkoffModP.RiemannRoch.LocalResidue +public import LeanPool.MarkoffModP.RiemannRoch.PlaceEquiv + +/-! +# Coordinate-free divisors and degree + +This file transports the two-chart divisor group to intrinsic places and identifies the transported +degree with the residue-field weighted sum. + +## Main definitions + +* `FunctionField.Divisor`: divisors indexed by intrinsic places. +* `FunctionField.divisorEquivChart`: equivalence with the two-chart divisor group. +* `FunctionField.Divisor.deg`: intrinsic divisor degree. +* `FunctionField.principalDivisor`: coordinate-free principal divisors. +-/ + +@[expose] public section + +open scoped nonZeroDivisors Polynomial RatFunc WithZero + +noncomputable section + +namespace FunctionField + +open Chart + +variable (k K : Type*) [Field k] [Field K] + [Algebra k K] [Algebra k[X] K] [Algebra k⟮X⟯ K] + [IsScalarTower k k[X] K] [IsScalarTower k[X] k⟮X⟯ K] [FunctionField k K] + [Algebra.IsSeparable k⟮X⟯ K] + +/-- Classical decidable equality for the coordinate rational function field. -/ +local instance instDecidableEqRatFuncCoordinateFreeDivisor : DecidableEq k⟮X⟯ := + Classical.decEq _ + +namespace Place + +/-- Constant-field algebra structure on a finite-place valuation subring. -/ +noncomputable local instance finiteVspAlgebra + (w : IsDedekindDomain.HeightOneSpectrum (ringOfIntegers k K)) : + Algebra k (IsDedekindDomain.HeightOneSpectrum.valuationSubringAtPrime K w) := + ((algebraMap (ringOfIntegers k K) + (IsDedekindDomain.HeightOneSpectrum.valuationSubringAtPrime K w)).comp + (algebraMap k (ringOfIntegers k K))).toAlgebra + +/-- Scalar-tower compatibility for a finite-place valuation subring. -/ +local instance finiteVspTower + (w : IsDedekindDomain.HeightOneSpectrum (ringOfIntegers k K)) : + IsScalarTower k (ringOfIntegers k K) + (IsDedekindDomain.HeightOneSpectrum.valuationSubringAtPrime K w) := + IsScalarTower.of_algebraMap_eq fun _ => rfl + +/-- The finite-chart valuation subring is the valuation subring of the intrinsic place. -/ +noncomputable def finiteValuationSubringAlgEquiv + (w : IsDedekindDomain.HeightOneSpectrum (ringOfIntegers k K)) : + IsDedekindDomain.HeightOneSpectrum.valuationSubringAtPrime K w ≃ₐ[k] + (Place.ofChart k K (Sum.inl w)).toValuationSubring := by + let e : (IsDedekindDomain.HeightOneSpectrum.valuationSubringAtPrime K w).toSubring ≃+* + (Place.ofChart k K (Sum.inl w)).toValuationSubring.toSubring := + RingEquiv.subringCongr <| congrArg ValuationSubring.toSubring <| + (IsDedekindDomain.HeightOneSpectrum.valuationSubringAtPrime_eq_valuationSubring + (K := K) (v := w)).trans (Place.ofChart_toValuationSubring k K (Sum.inl w)).symm + exact + { __ := e + commutes' := fun c => by + apply Subtype.ext + change algebraMap (ringOfIntegers k K) K + (algebraMap k (ringOfIntegers k K) c) = algebraMap k K c + exact (IsScalarTower.algebraMap_apply k (ringOfIntegers k K) K c).symm } + +/-- The finite-chart residue field is the intrinsic residue field. -/ +noncomputable def finiteResidueAlgEquiv + (w : IsDedekindDomain.HeightOneSpectrum (ringOfIntegers k K)) : + (ringOfIntegers k K ⧸ w.asIdeal) ≃ₐ[k] + (Place.ofChart k K (Sum.inl w)).residueField := by + let e₀ : (ringOfIntegers k K ⧸ w.asIdeal) ≃ₐ[k] w.asIdeal.ResidueField := + AlgEquiv.ofBijective + (IsScalarTower.toAlgHom k (ringOfIntegers k K ⧸ w.asIdeal) w.asIdeal.ResidueField) + (Ideal.bijective_algebraMap_quotient_residueField w.asIdeal) + let e₁ : w.asIdeal.ResidueField ≃ₐ[k] + IsLocalRing.ResidueField + (IsDedekindDomain.HeightOneSpectrum.valuationSubringAtPrime K w) := + IsLocalRing.ResidueField.mapAlgEquiv + ((IsDedekindDomain.HeightOneSpectrum.localizationAlgEquiv (K := K) w).restrictScalars k) + let e₂ : IsLocalRing.ResidueField + (IsDedekindDomain.HeightOneSpectrum.valuationSubringAtPrime K w) ≃ₐ[k] + (Place.ofChart k K (Sum.inl w)).residueField := + IsLocalRing.ResidueField.mapAlgEquiv (finiteValuationSubringAlgEquiv k K w) + exact e₀.trans (e₁.trans e₂) + +theorem finite_degree_eq (w : IsDedekindDomain.HeightOneSpectrum (ringOfIntegers k K)) : + (Place.ofChart k K (Sum.inl w)).degree = placeDegree k K (Sum.inl w) := by + exact (finiteResidueAlgEquiv k K w).toLinearEquiv.finrank_eq.symm + +/-- Constant-field algebra structure on an infinite-place valuation subring. -/ +noncomputable local instance infiniteVspAlgebra + (w : IsDedekindDomain.HeightOneSpectrum (infiniteIntegers k K)) : + Algebra k (IsDedekindDomain.HeightOneSpectrum.valuationSubringAtPrime K w) := + ((algebraMap (infiniteIntegers k K) + (IsDedekindDomain.HeightOneSpectrum.valuationSubringAtPrime K w)).comp + (algebraMap k (infiniteIntegers k K))).toAlgebra + +/-- Scalar-tower compatibility for an infinite-place valuation subring. -/ +local instance infiniteVspTower + (w : IsDedekindDomain.HeightOneSpectrum (infiniteIntegers k K)) : + IsScalarTower k (infiniteIntegers k K) + (IsDedekindDomain.HeightOneSpectrum.valuationSubringAtPrime K w) := + IsScalarTower.of_algebraMap_eq fun _ => rfl + +/-- The infinite-chart valuation subring is the valuation subring of the intrinsic place. -/ +noncomputable def infiniteValuationSubringAlgEquiv + (w : IsDedekindDomain.HeightOneSpectrum (infiniteIntegers k K)) : + IsDedekindDomain.HeightOneSpectrum.valuationSubringAtPrime K w ≃ₐ[k] + (Place.ofChart k K (Sum.inr w)).toValuationSubring := by + let e : (IsDedekindDomain.HeightOneSpectrum.valuationSubringAtPrime K w).toSubring ≃+* + (Place.ofChart k K (Sum.inr w)).toValuationSubring.toSubring := + RingEquiv.subringCongr <| congrArg ValuationSubring.toSubring <| + (IsDedekindDomain.HeightOneSpectrum.valuationSubringAtPrime_eq_valuationSubring + (K := K) (v := w)).trans (Place.ofChart_toValuationSubring k K (Sum.inr w)).symm + exact + { __ := e + commutes' := fun c => by + apply Subtype.ext + change algebraMap (infiniteIntegers k K) K + (algebraMap k (infiniteIntegers k K) c) = algebraMap k K c + exact (IsScalarTower.algebraMap_apply k (infiniteIntegers k K) K c).symm } + +/-- The infinite-chart residue field is the intrinsic residue field. -/ +noncomputable def infiniteResidueAlgEquiv + (w : IsDedekindDomain.HeightOneSpectrum (infiniteIntegers k K)) : + (infiniteIntegers k K ⧸ w.asIdeal) ≃ₐ[k] + (Place.ofChart k K (Sum.inr w)).residueField := by + let e₀ : (infiniteIntegers k K ⧸ w.asIdeal) ≃ₐ[k] w.asIdeal.ResidueField := + AlgEquiv.ofBijective + (IsScalarTower.toAlgHom k (infiniteIntegers k K ⧸ w.asIdeal) w.asIdeal.ResidueField) + (Ideal.bijective_algebraMap_quotient_residueField w.asIdeal) + let e₁ : w.asIdeal.ResidueField ≃ₐ[k] + IsLocalRing.ResidueField + (IsDedekindDomain.HeightOneSpectrum.valuationSubringAtPrime K w) := + IsLocalRing.ResidueField.mapAlgEquiv + ((IsDedekindDomain.HeightOneSpectrum.localizationAlgEquiv (K := K) w).restrictScalars k) + let e₂ : IsLocalRing.ResidueField + (IsDedekindDomain.HeightOneSpectrum.valuationSubringAtPrime K w) ≃ₐ[k] + (Place.ofChart k K (Sum.inr w)).residueField := + IsLocalRing.ResidueField.mapAlgEquiv (infiniteValuationSubringAlgEquiv k K w) + exact e₀.trans (e₁.trans e₂) + +theorem infinite_degree_eq (w : IsDedekindDomain.HeightOneSpectrum (infiniteIntegers k K)) : + (Place.ofChart k K (Sum.inr w)).degree = placeDegree k K (Sum.inr w) := by + exact (infiniteResidueAlgEquiv k K w).toLinearEquiv.finrank_eq.symm + +end Place + +/-- The chart degree agrees with the intrinsic residue-field degree. -/ +theorem placeDegree_eq (w : PlaceA k K) : + placeDegree k K w = (chartToPlace k K w).degree := by + rcases w with w | w + · exact (Place.finite_degree_eq k K w).symm + · exact (Place.infinite_degree_eq k K w).symm + +/-- Divisors indexed by coordinate-free places. -/ +abbrev Divisor := Place k K →₀ ℤ + +/-- Reindex a chart divisor by the chart/intrinsic place equivalence. -/ +noncomputable def divisorEquivChart : DivisorA k K ≃+ Divisor k K := + Finsupp.domCongr (chartToPlace k K) + +/-- The coordinate-free principal-divisor homomorphism. -/ +noncomputable def principalDivisor : Additive Kˣ →+ Divisor k K := + (divisorEquivChart k K).toAddMonoidHom.comp (principalDivisorA k K) + +namespace Divisor + +/-- The intrinsic weighted degree of a divisor. -/ +noncomputable def deg (D : Divisor k K) : ℤ := + D.sum fun v n => n * (v.degree : ℤ) + +omit [Algebra k[X] K] [Algebra k⟮X⟯ K] [IsScalarTower k k[X] K] + [IsScalarTower k[X] k⟮X⟯ K] [FunctionField k K] + [Algebra.IsSeparable k⟮X⟯ K] in +/-- The degree is the intrinsic residue-degree weighted sum. -/ +theorem deg_formula (D : Divisor k K) : + deg k K D = D.sum fun v n => n * (v.degree : ℤ) := rfl + +omit [Algebra k[X] K] [Algebra k⟮X⟯ K] [IsScalarTower k k[X] K] + [IsScalarTower k[X] k⟮X⟯ K] [FunctionField k K] + [Algebra.IsSeparable k⟮X⟯ K] in +theorem deg_add (D E : Divisor k K) : deg k K (D + E) = deg k K D + deg k K E := by + classical + simp [deg, Finsupp.sum_add_index, add_mul] + +theorem deg_equivChart (D : DivisorA k K) : + deg k K (divisorEquivChart k K D) = Chart.deg k K D := by + classical + induction D using Finsupp.induction with + | zero => simp [deg, Chart.deg, divisorEquivChart] + | single_add a b f ha hb ih => + rw [map_add, deg_add, Chart.deg_add, ih] + congr 1 + simp [deg, Chart.deg, divisorEquivChart, Finsupp.domCongr_apply, + Finsupp.equivMapDomain_single, placeDegree_eq] + +/-- Principal divisors have degree zero. -/ +theorem deg_principal_eq_zero (x : Kˣ) : + deg k K (principalDivisor k K (Additive.ofMul x)) = 0 := by + rw [principalDivisor] + exact (deg_equivChart k K (principalDivisorA k K (Additive.ofMul x))).trans + (deg_principalDivisorA_eq_zero k K x) + +end Divisor + +end FunctionField diff --git a/LeanPool/MarkoffModP/RiemannRoch/CoordinateFree/RiemannRoch.lean b/LeanPool/MarkoffModP/RiemannRoch/CoordinateFree/RiemannRoch.lean new file mode 100644 index 0000000000..43d2a1b85a --- /dev/null +++ b/LeanPool/MarkoffModP/RiemannRoch/CoordinateFree/RiemannRoch.lean @@ -0,0 +1,350 @@ +/- +Copyright (c) 2026 Guanghao Li. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Guanghao Li +-/ + +module + +public import LeanPool.MarkoffModP.RiemannRoch.CoordinateFree.WeilDifferential +public import LeanPool.MarkoffModP.RiemannRoch.RiemannRochTheorem.Corollaries + +/-! +# Coordinate-free Riemann–Roch + +This file exposes the Riemann–Roch stack over divisors indexed by intrinsic valuation-subring +places. The kernel-checked chart proofs are transported across `chartToPlace`. + +## Main definitions and results + +* `FunctionField.RRspace`, `FunctionField.ell`, and `FunctionField.genus`. +* `FunctionField.AdeleSpace` and `FunctionField.adeleFilt`. +* `FunctionField.IsCanonical` and `FunctionField.duality`. +* `FunctionField.riemann_roch` and coordinate-free corollaries C1–C6. +-/ + +@[expose] public section + +open scoped nonZeroDivisors Polynomial RatFunc WithZero + +noncomputable section + +namespace FunctionField + +open Chart + +variable (k K : Type*) [Field k] [Field K] [Algebra k K] + +/-- A function belongs to the intrinsic Riemann–Roch space of `D` when its normalized valuation +at every place is bounded by the coefficient of `D` there. -/ +def memRRspace (D : Divisor k K) (f : K) : Prop := + ∀ v, v.valuation f ≤ WithZero.exp (D v) + +namespace memRRspace + +variable {k K} {D : Divisor k K} + +theorem zero_mem (D : Divisor k K) : memRRspace k K D 0 := fun v => by simp + +theorem add_mem {f g : K} (hf : memRRspace k K D f) (hg : memRRspace k K D g) : + memRRspace k K D (f + g) := fun v => + (v.valuation.map_add f g).trans (max_le (hf v) (hg v)) + +theorem smul_mem (c : k) {f : K} (hf : memRRspace k K D f) : + memRRspace k K D (c • f) := fun v => by + by_cases hc : c = 0 + · simp [hc] + rw [Algebra.smul_def, map_mul, Valuation.IsTrivialOn.eq_one c hc, one_mul] + exact hf v + +end memRRspace + +/-- The Riemann–Roch space of an intrinsic divisor. -/ +def RRspace (D : Divisor k K) : Submodule k K := + { carrier := {f | memRRspace k K D f} + zero_mem' := memRRspace.zero_mem D + add_mem' := memRRspace.add_mem + smul_mem' := memRRspace.smul_mem } + +/-- The Riemann–Roch dimension of an intrinsic divisor. -/ +noncomputable def ell (D : Divisor k K) : ℕ := + Module.finrank k (RRspace k K D) + +/-- The defect of an intrinsic divisor. -/ +noncomputable def defect (D : Divisor k K) : ℤ := + D.deg + 1 - ell k K D + +/-- The intrinsic genus is the supremum of the defects of all intrinsic divisors. The +Riemann–Roch argument below proves that this supremum is attained and agrees with every chart +calculation. -/ +noncomputable def genus : ℕ := + (sSup {d : ℤ | ∃ D : Divisor k K, defect k K D = d}).toNat + +variable [Algebra k[X] K] [Algebra k⟮X⟯ K] + [IsScalarTower k k[X] K] [IsScalarTower k[X] k⟮X⟯ K] [_root_.FunctionField k K] + [Algebra.IsSeparable k⟮X⟯ K] [IsFullConstantField k K] + +omit [IsFullConstantField k K] in +/-- The intrinsic membership condition agrees with the coordinate construction. -/ +theorem memRRspace_equivChart (D : Divisor k K) (f : K) : + memRRspace k K D f ↔ + Chart.memRRspace k K ((divisorEquivChart k K).symm D) f := by + constructor + · intro hf w + have hv := hf (chartToPlace k K w) + rw [placeValuation_eq] at hv + simpa [divisorEquivChart, Finsupp.domCongr_apply] using hv + · intro hf v + let w := (chartToPlace k K).symm v + have hw := hf w + rw [← placeValuation_eq] at hw + simpa [w, divisorEquivChart, Finsupp.domCongr_apply] using hw + +omit [IsFullConstantField k K] in +/-- The intrinsic Riemann–Roch space is the chart space after reindexing divisors. -/ +theorem RRspace_eq_chart (D : Divisor k K) : + RRspace k K D = Chart.RRspace k K ((divisorEquivChart k K).symm D) := by + ext f + exact memRRspace_equivChart k K D f + +omit [IsFullConstantField k K] in +/-- Riemann–Roch dimension is preserved by the chart equivalence. -/ +theorem ell_eq_chart (D : Divisor k K) : + ell k K D = Chart.ell k K ((divisorEquivChart k K).symm D) := by + rw [ell, Chart.ell, RRspace_eq_chart k K D] + +/-- The index of specialty of an intrinsic divisor. -/ +noncomputable def indexOfSpecialty (D : Divisor k K) : ℕ := + (ell k K D - (D.deg + 1 - (genus k K : ℤ))).toNat + +/-- The dimension of the intrinsic adele quotient by `A(D)` plus the diagonal. -/ +noncomputable def finrankAdeleQuotient (D : Divisor k K) : ℕ := + Module.finrank k <| + AdeleSpace k K ⧸ (adeleFilt k K D + diagonalSubmodule k K) + +omit [IsFullConstantField k K] in +/-- Pulling an intrinsic divisor back to the chart preserves degree. -/ +@[simp] +theorem Divisor.chart_deg (D : Divisor k K) : + Chart.deg k K ((divisorEquivChart k K).symm D) = D.deg := by + have h := Divisor.deg_equivChart k K ((divisorEquivChart k K).symm D) + simpa using h.symm + +omit [IsFullConstantField k K] in +/-- Intrinsic defect is preserved by the chart equivalence. -/ +theorem defect_eq_chart (D : Divisor k K) : + defect k K D = Chart.defect k K ((divisorEquivChart k K).symm D) := by + rw [defect, Chart.defect, ell_eq_chart, Divisor.chart_deg] + +/-- The intrinsic supremum definition of genus agrees with the chart construction. -/ +theorem genus_eq_genusChart : genus k K = Chart.genus k K := by + let S : Set ℤ := {d | ∃ D : Divisor k K, defect k K D = d} + have hS : S.Nonempty := ⟨defect k K 0, ⟨0, rfl⟩⟩ + have hub : ∀ d ∈ S, d ≤ (Chart.genus k K : ℤ) := by + rintro d ⟨D, rfl⟩ + rw [defect_eq_chart] + exact Chart.defect_le k K _ + obtain ⟨E, hE⟩ := Chart.exists_defect_eq (k := k) (K := K) + have happ : ∀ z < (Chart.genus k K : ℤ), ∃ d ∈ S, z < d := by + intro z hz + refine ⟨defect k K (divisorEquivChart k K E), ⟨_, rfl⟩, ?_⟩ + rw [defect_eq_chart] + simpa [hE] using hz + have hsup : sSup S = (Chart.genus k K : ℤ) := + csSup_eq_of_forall_le_of_forall_lt_exists_gt hS hub happ + rw [genus] + change (sSup S).toNat = _ + rw [hsup] + simp + +/-- The numerical characterization of a canonical coordinate divisor. -/ +theorem chart_isCanonical_iff_degree_ell (E : DivisorA k K) : + Chart.IsCanonical k K E ↔ + Chart.deg k K E = 2 * (Chart.genus k K : ℤ) - 2 ∧ + Chart.ell k K E = Chart.genus k K := by + constructor + · intro hE + exact ⟨Chart.deg_canonical k K hE, Chart.ell_canonical k K hE⟩ + · rintro ⟨hdegE, hellE⟩ + obtain ⟨C, hC⟩ := Chart.exists_isCanonical k K + have hRR := Chart.riemann_roch k K hC E + have hpos : 0 < Chart.ell k K (C - E) := by + rw [hellE, hdegE] at hRR + omega + obtain ⟨x, hxeff⟩ := + Chart.exists_effective_add_principal_of_ell_pos k K (C - E) hpos + let P := principalDivisorA k K (Additive.ofMul x) + have hdegzero : Chart.deg k K ((C - E) + P) = 0 := by + rw [Chart.deg_add, Chart.deg_sub, + deg_principalDivisorA_eq_zero, Chart.deg_canonical k K hC, hdegE] + omega + have hzero : (C - E) + P = 0 := + eq_zero_of_effective_deg_zero k K hxeff hdegzero + have hCE : C + P = E := by + calc + C + P = E + ((C - E) + P) := by abel + _ = E := by rw [hzero, add_zero] + rcases hC with ⟨ω, hω, hdiv⟩ + have hxω : Chart.WeilDifferential.IsNonzero ((x : K) • ω) := by + intro hx + have hx0 : (x : K) • ω = 0 := by + apply Chart.WeilDifferential.ext + exact hx + have hω0 := (Chart.WeilDifferential.smulWeil_eq_zero_iff + (k := k) (K := K) (x : K) (Units.ne_zero x) ω).mp hx0 + apply hω + rw [hω0] + rfl + refine ⟨(x : K) • ω, hxω, ?_⟩ + rw [Chart.WeilDifferential.divOmega_smul (k := k) (K := K) x ω hω hxω, hdiv] + exact hCE + +/-- A divisor is canonical exactly when it has degree `2g - 2` and Riemann–Roch dimension `g`. -/ +theorem isCanonical_iff_deg_ell (W : Divisor k K) : + IsCanonical k K W ↔ + W.deg = 2 * (genus k K : ℤ) - 2 ∧ ell k K W = genus k K := by + rw [isCanonical_iff_chart, chart_isCanonical_iff_degree_ell] + simp only [Divisor.chart_deg, ell_eq_chart, genus_eq_genusChart] + +/-- The intrinsic specialty index agrees with the coordinate construction. -/ +theorem indexOfSpecialty_eq_chart (D : Divisor k K) : + indexOfSpecialty k K D = + Chart.indexOfSpecialty k K ((divisorEquivChart k K).symm D) := by + rw [indexOfSpecialty, Chart.indexOfSpecialty, ell_eq_chart, Divisor.chart_deg, + genus_eq_genusChart] + +/-- The intrinsic adele quotient is linearly equivalent to its chart presentation. -/ +noncomputable def adeleQuotientEquivChart (D : Divisor k K) : + (AdeleSpace k K ⧸ (adeleFilt k K D + diagonalSubmodule k K)) ≃ₗ[k] + (Chart.AdeleSpace k K ⧸ + (Chart.adeleFilt k K ((divisorEquivChart k K).symm D) + + Chart.diagonalSubmodule k K)) := + Submodule.Quotient.equiv _ _ (adeleEquivChart k K) + (map_adeleFilt_add_diagonal_equivChart k K D) + +omit [IsFullConstantField k K] in +/-- The intrinsic and chart adele quotients have the same dimension. -/ +theorem finrankAdeleQuotient_eq_chart (D : Divisor k K) : + finrankAdeleQuotient k K D = + Chart.finrankAdeleQuotient k K ((divisorEquivChart k K).symm D) := + (adeleQuotientEquivChart k K D).finrank_eq + +/-- The intrinsic adele quotient dimension is the index of specialty. -/ +theorem finrank_adele_quotient (D : Divisor k K) : + finrankAdeleQuotient k K D = indexOfSpecialty k K D := by + rw [finrankAdeleQuotient_eq_chart, Chart.finrank_adele_quotient, + indexOfSpecialty_eq_chart] + +/-- The rank change in the intrinsic filtration-and-diagonal sandwich. -/ +noncomputable def sandwichRank (D E : Divisor k K) (h : D ≤ E) : ℤ := by + have hchart : (divisorEquivChart k K).symm D ≤ + (divisorEquivChart k K).symm E := by + intro w + have hw := h (chartToPlace k K w) + simpa [divisorEquivChart, Finsupp.domCongr_apply] using hw + exact Chart.sandwichRank k K ((divisorEquivChart k K).symm D) + ((divisorEquivChart k K).symm E) hchart + +omit [IsFullConstantField k K] in +/-- The intrinsic sandwich rank is the change in `deg D - ell(D)`. -/ +theorem sandwich {D E : Divisor k K} (h : D ≤ E) : + sandwichRank k K D E h = E.deg - ell k K E - (D.deg - ell k K D) := by + simp only [sandwichRank] + rw [Chart.sandwich] + simp only [Divisor.chart_deg, ell_eq_chart] + +/-- The dimension of intrinsic `Omega(D)` is the index of specialty of `D`. -/ +theorem WeilDifferential.finrank_differentialSpace (D : Divisor k K) : + Module.finrank k (WeilDifferential.differentialSpace (k := k) (K := K) D) = + indexOfSpecialty k K D := by + rw [WeilDifferential.finrank_differentialSpace_eq_chart, + Chart.WeilDifferential.finrank_differentialSpace, indexOfSpecialty_eq_chart] + +/-- Every function field admits an intrinsic canonical divisor. -/ +theorem exists_isCanonical : ∃ W : Divisor k K, IsCanonical k K W := by + obtain ⟨W, hW⟩ := Chart.exists_isCanonical k K + refine ⟨divisorEquivChart k K W, ?_⟩ + apply (isCanonical_iff_chart k K _).mpr + simpa using hW + +/-- Coordinate-free duality. -/ +theorem duality {W : Divisor k K} (hW : IsCanonical k K W) (D : Divisor k K) : + ell k K (W - D) = indexOfSpecialty k K D := by + have hW' := (isCanonical_iff_chart k K W).mp hW + rw [ell_eq_chart, indexOfSpecialty_eq_chart] + simpa using Chart.duality k K hW' ((divisorEquivChart k K).symm D) + +/-- Riemann's inequality for intrinsic divisors. -/ +theorem riemann_ineq (D : Divisor k K) : + (ell k K D : ℤ) ≥ D.deg + 1 - (genus k K : ℤ) := by + rw [ell_eq_chart] + simpa [genus_eq_genusChart] using + Chart.riemann_ineq k K ((divisorEquivChart k K).symm D) + +/-- The coordinate-free Riemann–Roch theorem. -/ +theorem riemann_roch {W : Divisor k K} (hW : IsCanonical k K W) (D : Divisor k K) : + (ell k K D : ℤ) = D.deg + 1 - (genus k K : ℤ) + ell k K (W - D) := by + have hW' := (isCanonical_iff_chart k K W).mp hW + rw [ell_eq_chart, ell_eq_chart] + simpa [genus_eq_genusChart] using + Chart.riemann_roch k K hW' ((divisorEquivChart k K).symm D) + +section Canonical + +variable {W : Divisor k K} (hW : IsCanonical k K W) + +include hW + +/-- **C1**: a canonical divisor has Riemann–Roch dimension equal to the genus. -/ +theorem ell_canonical : ell k K W = genus k K := by + exact (isCanonical_iff_deg_ell k K W).mp hW |>.2 + +/-- **C2**: a canonical divisor has degree `2g - 2`. -/ +theorem deg_canonical : W.deg = 2 * (genus k K : ℤ) - 2 := by + exact (isCanonical_iff_deg_ell k K W).mp hW |>.1 + +/-- **C3**: divisors of degree at least `2g - 1` are nonspecial. -/ +theorem ell_eq_of_deg_ge (D : Divisor k K) + (hdeg : D.deg ≥ 2 * (genus k K : ℤ) - 1) : + (ell k K D : ℤ) = D.deg + 1 - (genus k K : ℤ) := by + have hW' := (isCanonical_iff_chart k K W).mp hW + have hdeg' : Chart.deg k K ((divisorEquivChart k K).symm D) ≥ + 2 * (Chart.genus k K : ℤ) - 1 := by simpa [genus_eq_genusChart] using hdeg + rw [ell_eq_chart] + simpa [genus_eq_genusChart] using + Chart.ell_eq_of_deg_ge k K hW' ((divisorEquivChart k K).symm D) hdeg' + +/-- **C4**: the specialty index is `ℓ(W-D)`. -/ +theorem indexOfSpecialty_eq_ell (D : Divisor k K) : + (indexOfSpecialty k K D : ℤ) = ell k K (W - D) := by + have hW' := (isCanonical_iff_chart k K W).mp hW + rw [indexOfSpecialty_eq_chart, ell_eq_chart] + simpa using Chart.indexOfSpecialty_eq_ell k K hW' + ((divisorEquivChart k K).symm D) + +end Canonical + +/-- **C5**: Clifford's inequality for intrinsic divisors. -/ +theorem clifford {W : Divisor k K} (hW : IsCanonical k K W) (D : Divisor k K) + (hdeg₀ : 0 ≤ D.deg) (hdeg₁ : D.deg ≤ 2 * (genus k K : ℤ) - 2) + (hℓD : 0 < ell k K D) (hℓW : 0 < ell k K (W - D)) : + 2 * ((ell k K D : ℤ) - 1) ≤ D.deg := by + have hW' := (isCanonical_iff_chart k K W).mp hW + have hdeg₀' : 0 ≤ Chart.deg k K ((divisorEquivChart k K).symm D) := by + simpa using hdeg₀ + have hdeg₁' : Chart.deg k K ((divisorEquivChart k K).symm D) ≤ + 2 * (Chart.genus k K : ℤ) - 2 := by simpa [genus_eq_genusChart] using hdeg₁ + rw [ell_eq_chart k K D] at hℓD ⊢ + rw [ell_eq_chart k K (W - D)] at hℓW + simpa [genus_eq_genusChart] using + Chart.clifford k K hW' ((divisorEquivChart k K).symm D) hdeg₀' hdeg₁' hℓD hℓW + +/-- **C6**: there exists an intrinsic nonspecial divisor. -/ +theorem exists_nonspecial_divisor : + ∃ D : Divisor k K, indexOfSpecialty k K D = 0 := by + obtain ⟨D, hD⟩ := Chart.exists_nonspecial_divisor k K + refine ⟨divisorEquivChart k K D, ?_⟩ + rw [indexOfSpecialty_eq_chart] + simpa using hD + +end FunctionField diff --git a/LeanPool/MarkoffModP/RiemannRoch/CoordinateFree/WeilDifferential.lean b/LeanPool/MarkoffModP/RiemannRoch/CoordinateFree/WeilDifferential.lean new file mode 100644 index 0000000000..de51abed45 --- /dev/null +++ b/LeanPool/MarkoffModP/RiemannRoch/CoordinateFree/WeilDifferential.lean @@ -0,0 +1,285 @@ +/- +Copyright (c) 2026 Guanghao Li. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Guanghao Li +-/ + +module + +public import LeanPool.MarkoffModP.RiemannRoch.CoordinateFree.AdeleSpace +public import LeanPool.MarkoffModP.RiemannRoch.WeilDifferential.Basic + +/-! +# Weil differentials over intrinsic places + +Weil differentials are defined here as linear functionals on the intrinsic adele space that +vanish on `A(D)` plus the diagonal for some intrinsic divisor. The equivalence +`weilDifferentialEquivChart` transports the existing chart proofs without exposing chart-indexed +carriers in the public statements. +-/ + +@[expose] public section + +open scoped nonZeroDivisors Polynomial RatFunc WithZero + +noncomputable section + +namespace FunctionField + +open Chart + +variable (k K : Type*) [Field k] [Field K] +variable [Algebra k K] [Algebra k[X] K] [Algebra k⟮X⟯ K] + [IsScalarTower k k[X] K] [IsScalarTower k[X] k⟮X⟯ K] [_root_.FunctionField k K] + [Algebra.IsSeparable k⟮X⟯ K] [IsFullConstantField k K] + +/-- A Weil differential is a functional on intrinsic adeles that vanishes on `A(D)` plus the +diagonal for some intrinsic divisor `D`. -/ +structure WeilDifferential where + /-- The underlying linear functional on intrinsic adeles. -/ + toFun : AdeleSpace k K →ₗ[k] k + /-- A filtration piece plus the diagonal on which the functional vanishes. -/ + vanishes_on : ∃ D : Divisor k K, + ∀ a ∈ adeleFilt k K D + diagonalSubmodule k K, toFun a = 0 + +namespace WeilDifferential + +variable {k K} + +/-- A Weil differential is nonzero when its underlying functional is nonzero. -/ +def IsNonzero (omega : WeilDifferential k K) : Prop := omega.toFun ≠ 0 + +/-- The space of functionals vanishing on `A(D)` plus the diagonal. -/ +def differentialSpace (D : Divisor k K) : + Submodule k (AdeleSpace k K →ₗ[k] k) where + carrier := {phi | ∀ a ∈ adeleFilt k K D + diagonalSubmodule k K, phi a = 0} + zero_mem' := by simp + add_mem' {phi psi} hphi hpsi := by + intro a ha + simp [hphi a ha, hpsi a ha] + smul_mem' c phi hphi := by + intro a ha + simp [hphi a ha] + +/-- The dual-space equivalence induced by reindexing intrinsic adeles to chart adeles. -/ +noncomputable def adeleDualEquivChart : + (AdeleSpace k K →ₗ[k] k) ≃ₗ[k] (Chart.AdeleSpace k K →ₗ[k] k) := + (adeleEquivChart k K).symm.dualMap + +omit [IsFullConstantField k K] in +@[simp] +theorem adeleDualEquivChart_apply (phi : AdeleSpace k K →ₗ[k] k) + (a : Chart.AdeleSpace k K) : + adeleDualEquivChart (k := k) (K := K) phi a = + phi ((adeleEquivChart k K).symm a) := + rfl + +omit [IsFullConstantField k K] in +@[simp] +theorem adeleDualEquivChart_symm_apply (phi : Chart.AdeleSpace k K →ₗ[k] k) + (a : AdeleSpace k K) : + (adeleDualEquivChart (k := k) (K := K)).symm phi a = + phi (adeleEquivChart k K a) := + rfl + +/-- Reindex an intrinsic Weil differential as a chart Weil differential. -/ +noncomputable def toChart (omega : WeilDifferential k K) : + Chart.WeilDifferential k K where + toFun := adeleDualEquivChart (k := k) (K := K) omega.toFun + vanishes_on := by + obtain ⟨D, hD⟩ := omega.vanishes_on + refine ⟨(divisorEquivChart k K).symm D, fun a ha => ?_⟩ + apply hD ((adeleEquivChart k K).symm a) + exact (mem_adeleFilt_add_diagonal_equivChart k K D _).mp (by simpa using ha) + +/-- Reindex a chart Weil differential as an intrinsic Weil differential. -/ +noncomputable def ofChart (omega : Chart.WeilDifferential k K) : + WeilDifferential k K where + toFun := (adeleDualEquivChart (k := k) (K := K)).symm omega.toFun + vanishes_on := by + obtain ⟨D, hD⟩ := omega.vanishes_on + refine ⟨divisorEquivChart k K D, fun a ha => ?_⟩ + apply hD (adeleEquivChart k K a) + have hmap := (mem_adeleFilt_add_diagonal_equivChart k K + (divisorEquivChart k K D) a).mpr ha + simpa using hmap + +omit [IsFullConstantField k K] in +@[ext] +theorem ext {omega eta : WeilDifferential k K} (h : omega.toFun = eta.toFun) : + omega = eta := by + cases omega + cases eta + cases h + rfl + +instance : Zero (WeilDifferential k K) := ⟨⟨0, ⟨0, by simp⟩⟩⟩ + +instance : Add (WeilDifferential k K) where + add omega eta := ⟨omega.toFun + eta.toFun, by + obtain ⟨Domega, homega⟩ := omega.vanishes_on + obtain ⟨Deta, heta⟩ := eta.vanishes_on + refine ⟨Domega ⊓ Deta, fun a ha => ?_⟩ + have hleft : adeleFilt k K (Domega ⊓ Deta) + diagonalSubmodule k K ≤ + adeleFilt k K Domega + diagonalSubmodule k K := by + simpa only [Submodule.add_eq_sup] using + sup_le_sup (adeleFilt_mono k K inf_le_left) le_rfl + have hright : adeleFilt k K (Domega ⊓ Deta) + diagonalSubmodule k K ≤ + adeleFilt k K Deta + diagonalSubmodule k K := by + simpa only [Submodule.add_eq_sup] using + sup_le_sup (adeleFilt_mono k K inf_le_right) le_rfl + simp [homega a (hleft ha), heta a (hright ha)]⟩ + +instance : Neg (WeilDifferential k K) where + neg omega := ⟨-omega.toFun, by + obtain ⟨D, hD⟩ := omega.vanishes_on + exact ⟨D, fun a ha => by simp [hD a ha]⟩⟩ + +instance : AddCommGroup (WeilDifferential k K) where + add_assoc _ _ _ := ext (add_assoc _ _ _) + zero_add _ := ext (zero_add _) + add_zero _ := ext (add_zero _) + add_comm _ _ := ext (add_comm _ _) + nsmul := nsmulRec + nsmul_zero _ := ext rfl + nsmul_succ _ _ := ext rfl + neg := Neg.neg + neg_add_cancel omega := ext (neg_add_cancel omega.toFun) + sub := fun omega eta => omega + -eta + sub_eq_add_neg _ _ := rfl + zsmul := zsmulRec + +/-- Intrinsic and chart Weil differentials are equivalent as additive groups. -/ +noncomputable def weilDifferentialAddEquivChart : + WeilDifferential k K ≃+ Chart.WeilDifferential k K where + toFun := toChart + invFun := ofChart + left_inv omega := by + apply ext + exact (adeleDualEquivChart (k := k) (K := K)).symm_apply_apply omega.toFun + right_inv omega := by + apply Chart.WeilDifferential.ext + exact (adeleDualEquivChart (k := k) (K := K)).apply_symm_apply omega.toFun + map_add' omega eta := by + apply Chart.WeilDifferential.ext + exact (adeleDualEquivChart (k := k) (K := K)).map_add omega.toFun eta.toFun + +noncomputable instance : SMul K (WeilDifferential k K) := + ⟨fun x omega => + (weilDifferentialAddEquivChart (k := k) (K := K)).symm + (x • weilDifferentialAddEquivChart (k := k) (K := K) omega)⟩ + +omit [IsFullConstantField k K] in +@[simp] +theorem weilDifferentialAddEquivChart_smul (x : K) (omega : WeilDifferential k K) : + weilDifferentialAddEquivChart (k := k) (K := K) (x • omega) = + x • weilDifferentialAddEquivChart (k := k) (K := K) omega := + (weilDifferentialAddEquivChart (k := k) (K := K)).apply_symm_apply _ + +noncomputable instance : Module K (WeilDifferential k K) := + Function.Injective.module K + (weilDifferentialAddEquivChart (k := k) (K := K)).toAddMonoidHom + (weilDifferentialAddEquivChart (k := k) (K := K)).injective + (weilDifferentialAddEquivChart_smul (k := k) (K := K)) + +/-- Intrinsic and chart Weil differentials are linearly equivalent over the function field. -/ +noncomputable def weilDifferentialEquivChart : + WeilDifferential k K ≃ₗ[K] Chart.WeilDifferential k K where + __ := weilDifferentialAddEquivChart (k := k) (K := K) + map_smul' := weilDifferentialAddEquivChart_smul (k := k) (K := K) + +/-- The intrinsic space `Omega(D)` is linearly equivalent to its chart presentation. -/ +noncomputable def differentialSpaceEquivChart (D : Divisor k K) : + differentialSpace (k := k) (K := K) D ≃ₗ[k] + Chart.WeilDifferential.differentialSpace + ((divisorEquivChart k K).symm D) where + toFun phi := ⟨adeleDualEquivChart (k := k) (K := K) phi.1, by + intro a ha + apply phi.2 ((adeleEquivChart k K).symm a) + exact (mem_adeleFilt_add_diagonal_equivChart k K D _).mp (by simpa using ha)⟩ + invFun phi := ⟨(adeleDualEquivChart (k := k) (K := K)).symm phi.1, by + intro a ha + apply phi.2 (adeleEquivChart k K a) + exact (mem_adeleFilt_add_diagonal_equivChart k K D a).mpr ha⟩ + left_inv phi := Subtype.ext + ((adeleDualEquivChart (k := k) (K := K)).symm_apply_apply phi.1) + right_inv phi := Subtype.ext + ((adeleDualEquivChart (k := k) (K := K)).apply_symm_apply phi.1) + map_add' _ _ := rfl + map_smul' _ _ := rfl + +omit [IsFullConstantField k K] in +/-- The intrinsic and chart differential spaces have the same dimension. -/ +theorem finrank_differentialSpace_eq_chart (D : Divisor k K) : + Module.finrank k (differentialSpace (k := k) (K := K) D) = + Module.finrank k (Chart.WeilDifferential.differentialSpace + ((divisorEquivChart k K).symm D)) := + (differentialSpaceEquivChart (k := k) (K := K) D).finrank_eq + +/-- The intrinsic space of Weil differentials is one-dimensional over `K`. -/ +theorem finrank_weilDifferential_eq_one : + Module.finrank K (WeilDifferential k K) = 1 := by + rw [(weilDifferentialEquivChart (k := k) (K := K)).finrank_eq] + exact Chart.WeilDifferential.finrank_weilDifferential_eq_one (k := k) (K := K) + +omit [IsFullConstantField k K] in +/-- Non-vanishing is preserved by the intrinsic-to-chart equivalence. -/ +theorem isNonzero_toChart (omega : WeilDifferential k K) : + IsNonzero omega ↔ Chart.WeilDifferential.IsNonzero (toChart omega) := by + change omega.toFun ≠ 0 ↔ + adeleDualEquivChart (k := k) (K := K) omega.toFun ≠ 0 + exact (adeleDualEquivChart (k := k) (K := K)).map_ne_zero_iff.symm + +/-- The divisor of a nonzero intrinsic Weil differential. -/ +noncomputable def divOmega (omega : WeilDifferential k K) (homega : IsNonzero omega) : + Divisor k K := + divisorEquivChart k K <| + Chart.WeilDifferential.divOmega (toChart omega) ((isNonzero_toChart omega).mp homega) + +/-- Multiplying a differential adds the corresponding intrinsic principal divisor. -/ +theorem divOmega_smul (x : Kˣ) (omega : WeilDifferential k K) (homega : IsNonzero omega) + (hxomega : IsNonzero ((x : K) • omega)) : + divOmega ((x : K) • omega) hxomega = + divOmega omega homega + principalDivisor k K (Additive.ofMul x) := by + apply (divisorEquivChart k K).symm.injective + simp only [divOmega, principalDivisor, map_add, AddEquiv.symm_apply_apply] + have hsmul : toChart ((x : K) • omega) = (x : K) • toChart omega := + weilDifferentialAddEquivChart_smul (k := k) (K := K) x omega + have hxchart : Chart.WeilDifferential.IsNonzero ((x : K) • toChart omega) := by + simpa only [hsmul] using + ((isNonzero_toChart ((x : K) • omega)).mp hxomega) + have hchart := Chart.WeilDifferential.divOmega_smul (k := k) (K := K) x + (toChart omega) ((isNonzero_toChart omega).mp homega) hxchart + simpa [hsmul, principalDivisor] using hchart + +end WeilDifferential + +/-- A divisor is canonical when it is the divisor of a nonzero intrinsic Weil differential. -/ +def IsCanonical (W : Divisor k K) : Prop := + ∃ (omega : WeilDifferential k K) (homega : WeilDifferential.IsNonzero omega), + WeilDifferential.divOmega omega homega = W + +/-- Intrinsic and chart definitions of canonical divisors agree. -/ +theorem isCanonical_iff_chart (W : Divisor k K) : + IsCanonical k K W ↔ + Chart.IsCanonical k K ((divisorEquivChart k K).symm W) := by + constructor + · rintro ⟨omega, homega, rfl⟩ + refine ⟨WeilDifferential.toChart omega, + (WeilDifferential.isNonzero_toChart omega).mp homega, ?_⟩ + simp [WeilDifferential.divOmega] + · rintro ⟨omega, homega, hdiv⟩ + let eta := WeilDifferential.ofChart omega + have hetaChart : WeilDifferential.toChart eta = omega := + (WeilDifferential.weilDifferentialAddEquivChart + (k := k) (K := K)).apply_symm_apply omega + have heta : WeilDifferential.IsNonzero eta := by + apply (WeilDifferential.isNonzero_toChart eta).mpr + rw [hetaChart] + exact homega + refine ⟨eta, heta, ?_⟩ + apply (divisorEquivChart k K).symm.injective + simp only [WeilDifferential.divOmega, AddEquiv.symm_apply_apply] + simpa only [hetaChart] using hdiv + +end FunctionField diff --git a/LeanPool/MarkoffModP/RiemannRoch/Divisor.lean b/LeanPool/MarkoffModP/RiemannRoch/Divisor.lean new file mode 100644 index 0000000000..21e38a8f65 --- /dev/null +++ b/LeanPool/MarkoffModP/RiemannRoch/Divisor.lean @@ -0,0 +1,236 @@ +/- +Copyright (c) 2026 Guanghao Li. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Guanghao Li +-/ + +module + +public import Mathlib.Data.Finsupp.Multiset +public import Mathlib.RingTheory.DedekindDomain.Factorization + +/-! +# Divisors of a Dedekind domain + +This file identifies the group of nonzero fractional ideals of a Dedekind domain with the free +abelian group on its height-one prime ideals. The coefficient of a prime `v` is the existing +function `FractionalIdeal.count K v`. + +## Main definitions + +* `IsDedekindDomain.Divisor`: the free abelian group on height-one prime ideals. +* `FractionalIdeal.divisor`: the divisor associated to a nonzero fractional ideal. +* `FractionalIdeal.divisorEquiv`: the additive equivalence between nonzero fractional ideals and + divisors. +* `FractionalIdeal.principalDivisor`: the divisor of a nonzero element of the fraction field. +-/ + +@[expose] public section + +open IsDedekindDomain +open scoped nonZeroDivisors + +namespace IsDedekindDomain + +/-- The group of divisors supported on height-one prime ideals of a ring. -/ +abbrev Divisor (R : Type*) [CommRing R] := HeightOneSpectrum R →₀ ℤ + +end IsDedekindDomain + +namespace FractionalIdeal + +variable {R K : Type*} [CommRing R] [IsDedekindDomain R] [Field K] + [Algebra R K] [IsFractionRing R K] + +/-- The divisor of a nonzero fractional ideal. -/ +noncomputable def divisor (I : (FractionalIdeal R⁰ K)ˣ) : Divisor R := + Finsupp.mk (finite_factors (I : FractionalIdeal R⁰ K)).toFinset + (fun v ↦ count K v I) fun _ ↦ (finite_factors (I : FractionalIdeal R⁰ K)).mem_toFinset + +@[simp] +theorem divisor_apply (I : (FractionalIdeal R⁰ K)ˣ) (v : HeightOneSpectrum R) : + divisor I v = count K v I := by + classical + simp [divisor] + +/-- Reconstruct a nonzero fractional ideal from a divisor. -/ +noncomputable def ofDivisor (K : Type*) [Field K] [Algebra R K] [IsFractionRing R K] + (D : Divisor R) : (FractionalIdeal R⁰ K)ˣ := + Units.mk0 (D.prod fun v n ↦ (v.asIdeal : FractionalIdeal R⁰ K) ^ n) <| by + classical + rw [Finsupp.prod] + exact Finset.prod_ne_zero_iff.mpr fun v _ ↦ + zpow_ne_zero _ (coeIdeal_ne_zero.mpr v.ne_bot) + +@[simp] +theorem count_ofDivisor (D : Divisor R) (v : HeightOneSpectrum R) : + count K v (ofDivisor K D : FractionalIdeal R⁰ K) = D v := by + classical + simpa [ofDivisor] using count_finsuppProd K v D + +private theorem eq_of_count_eq {I J : FractionalIdeal R⁰ K} (hI : I ≠ 0) (hJ : J ≠ 0) + (h : ∀ v, count K v I = count K v J) : I = J := by + rw [← finprod_heightOneSpectrum_factorization' K hI, + ← finprod_heightOneSpectrum_factorization' K hJ] + exact finprod_congr fun v ↦ congr_arg ((v.asIdeal : FractionalIdeal R⁰ K) ^ ·) (h v) + +/-- Nonzero fractional ideals of a Dedekind domain are additively equivalent to its divisors. + +Multiplication of fractional ideals corresponds to addition of divisors. +-/ +noncomputable def divisorEquiv : Additive (FractionalIdeal R⁰ K)ˣ ≃+ Divisor R where + toFun I := divisor I.toMul + invFun D := Additive.ofMul (ofDivisor K D) + left_inv I := by + apply Additive.toMul.injective + apply Units.ext + change (ofDivisor K (divisor I.toMul) : FractionalIdeal R⁰ K) = I.toMul + apply eq_of_count_eq (ofDivisor K (divisor I.toMul)).ne_zero I.toMul.ne_zero + intro v + rw [count_ofDivisor, divisor_apply] + right_inv D := by + ext v + change count K v (ofDivisor K D : FractionalIdeal R⁰ K) = D v + rw [count_ofDivisor] + map_add' I J := by + change divisor (I.toMul * J.toMul) = divisor I.toMul + divisor J.toMul + ext v + simp only [divisor_apply, Units.val_mul] + exact count_mul K v I.toMul.ne_zero J.toMul.ne_zero + +/-- The nonzero principal fractional ideal generated by an element of the fraction field. -/ +noncomputable def principalFractionalIdeal : Kˣ →* (FractionalIdeal R⁰ K)ˣ where + toFun x := Units.mk0 (spanSingleton R⁰ (x : K)) (spanSingleton_ne_zero_iff.mpr x.ne_zero) + map_one' := Units.ext spanSingleton_one + map_mul' x y := Units.ext (spanSingleton_mul_spanSingleton (R := R) (x : K) y).symm + +@[simp] +theorem principalFractionalIdeal_apply_coe (x : Kˣ) : + (principalFractionalIdeal (R := R) (K := K) x : FractionalIdeal R⁰ K) = + spanSingleton R⁰ (x : K) := rfl + +/-- The principal divisor of a nonzero element of the fraction field. -/ +noncomputable def principalDivisor : Additive Kˣ →+ Divisor R := + divisorEquiv.toAddMonoidHom.comp principalFractionalIdeal.toAdditive + +@[simp] +theorem principalDivisor_apply (x : Additive Kˣ) (v : HeightOneSpectrum R) : + principalDivisor (R := R) (K := K) x v = + count K v (spanSingleton R⁰ (x.toMul : K)) := by + change divisor (principalFractionalIdeal x.toMul) v = _ + rw [divisor_apply, principalFractionalIdeal_apply_coe] + +/-- A weighted degree on divisors of a Dedekind domain. -/ +noncomputable def weightedDegree (w : Ideal R → ℕ) : Divisor R →+ ℤ where + toFun D := D.sum fun v n => n * (w v.asIdeal : ℤ) + map_zero' := by simp + map_add' D E := by + classical + simp [Finsupp.sum_add_index, add_mul] + +omit [IsDedekindDomain R] in +@[simp] +theorem weightedDegree_apply (w : Ideal R → ℕ) (D : Divisor R) : + weightedDegree (R := R) w D = + D.sum fun v n => n * (w v.asIdeal : ℤ) := rfl + +/-- The weighted degree of the divisor of a nonzero integral ideal is the weighted sum of its +normalized prime factors. The weight is stated on ideals, so that it can later be chosen as a +residue-field degree or an inertia-weighted residue-field degree. -/ +theorem divisor_ideal_sum_eq_normalizedFactors_sum (J : Ideal R) (hJ : J ≠ ⊥) + (w : Ideal R → ℕ) : + let JU : (FractionalIdeal R⁰ K)ˣ := + Units.mk0 (J : FractionalIdeal R⁰ K) (coeIdeal_ne_zero.mpr hJ) + (divisor JU).sum (fun v n => n * (w v.asIdeal : ℤ)) = + (((UniqueFactorizationMonoid.normalizedFactors J).map w).sum : ℤ) := by + classical + dsimp only + rw [Finsupp.sum] + let s := UniqueFactorizationMonoid.normalizedFactors J + have hcoeff (v : HeightOneSpectrum R) : + divisor (Units.mk0 (J : FractionalIdeal R⁰ K) (coeIdeal_ne_zero.mpr hJ)) v = + (s.count v.asIdeal : ℤ) := by + rw [divisor_apply, Units.val_mk0, count_coe K v hJ, + Ideal.count_associates_factors_eq hJ v.isPrime v.ne_bot] + have hsum : + ∑ v ∈ (divisor + (Units.mk0 (J : FractionalIdeal R⁰ K) (coeIdeal_ne_zero.mpr hJ))).support, + divisor (Units.mk0 (J : FractionalIdeal R⁰ K) (coeIdeal_ne_zero.mpr hJ)) v * + (w v.asIdeal : ℤ) = + ∑ P ∈ s.toFinset, (s.count P : ℤ) * (w P : ℤ) := by + apply Finset.sum_bij (fun v _ => v.asIdeal) + · intro v hv + rw [Multiset.mem_toFinset, ← Multiset.count_ne_zero] + intro hz + have : divisor + (Units.mk0 (J : FractionalIdeal R⁰ K) (coeIdeal_ne_zero.mpr hJ)) v = 0 := by + rw [hcoeff, hz, Nat.cast_zero] + exact (Finsupp.mem_support_iff.mp hv) this + · intro v₁ _ v₂ _ hv + exact HeightOneSpectrum.ext hv + · intro P hP + rw [Multiset.mem_toFinset] at hP + have hprime : Prime P := + UniqueFactorizationMonoid.prime_of_normalized_factor P hP + let v : HeightOneSpectrum R := + ⟨P, Ideal.isPrime_of_prime hprime, hprime.ne_zero⟩ + refine ⟨v, ?_, rfl⟩ + rw [Finsupp.mem_support_iff, hcoeff] + exact_mod_cast (Multiset.count_pos.mpr hP).ne' + · intro v _ + rw [hcoeff] + rw [hsum, Finset.sum_multiset_map_count] + simp only [s, nsmul_eq_mul, Nat.cast_sum, Nat.cast_mul] + push_cast + rfl + +/-- Weighted degree of the divisor of a nonzero integral ideal. -/ +theorem weightedDegree_divisor_ideal (J : Ideal R) (hJ : J ≠ ⊥) + (w : Ideal R → ℕ) : + weightedDegree (R := R) w + (divisor (Units.mk0 (J : FractionalIdeal R⁰ K) (coeIdeal_ne_zero.mpr hJ))) = + (((UniqueFactorizationMonoid.normalizedFactors J).map w).sum : ℤ) := + divisor_ideal_sum_eq_normalizedFactors_sum J hJ w + +/-- If a nonzero fraction is represented by `n / d`, its weighted principal-divisor degree is +the weighted factor degree of `n` minus that of `d`. -/ +theorem weightedDegree_principal_mk' (w : Ideal R → ℕ) (x : Kˣ) (n : R) + (d : nonZeroDivisors R) (hnd : IsLocalization.mk' K n d = (x : K)) : + weightedDegree (R := R) w (principalDivisor (Additive.ofMul x)) = + (((UniqueFactorizationMonoid.normalizedFactors (Ideal.span {n})).map w).sum : ℤ) - + (((UniqueFactorizationMonoid.normalizedFactors + (Ideal.span {(d : R)})).map w).sum : ℤ) := by + classical + have hn : n ≠ 0 := by + intro hn + exact x.ne_zero (by simpa [hn] using hnd.symm) + have hd : (d : R) ≠ 0 := by + simpa only [mem_nonZeroDivisors_iff_ne_zero] using d.property + have hspan : spanSingleton R⁰ (x : K) = + spanSingleton R⁰ ((algebraMap R K) (d : R))⁻¹ * + (Ideal.span {n} : FractionalIdeal R⁰ K) := by + rw [← hnd, IsFractionRing.mk'_eq_div, coeIdeal_span_singleton, + spanSingleton_mul_spanSingleton] + congr 1 + simp only [div_eq_mul_inv] + ac_rfl + have hdiv : principalDivisor (R := R) (K := K) (Additive.ofMul x) = + divisor (Units.mk0 (Ideal.span {n} : FractionalIdeal R⁰ K) + (coeIdeal_ne_zero.mpr (Ideal.span_singleton_eq_bot.not.mpr hn))) - + divisor (Units.mk0 (Ideal.span {(d : R)} : FractionalIdeal R⁰ K) + (coeIdeal_ne_zero.mpr (Ideal.span_singleton_eq_bot.not.mpr hd))) := by + ext v + rw [principalDivisor_apply, Finsupp.sub_apply, divisor_apply, divisor_apply] + change count K v (spanSingleton R⁰ (x : K)) = + count K v (Ideal.span {n} : FractionalIdeal R⁰ K) - + count K v (Ideal.span {(d : R)} : FractionalIdeal R⁰ K) + rw [count_well_defined K v (spanSingleton_ne_zero_iff.mpr x.ne_zero) hspan, + count_coe K v (Ideal.span_singleton_eq_bot.not.mpr hn), + count_coe K v (Ideal.span_singleton_eq_bot.not.mpr hd)] + rw [hdiv, map_sub, + weightedDegree_divisor_ideal (K := K) (Ideal.span {n}) + (Ideal.span_singleton_eq_bot.not.mpr hn) w, + weightedDegree_divisor_ideal (K := K) (Ideal.span {(d : R)}) + (Ideal.span_singleton_eq_bot.not.mpr hd) w] + +end FractionalIdeal diff --git a/LeanPool/MarkoffModP/RiemannRoch/FunctionField/Divisor.lean b/LeanPool/MarkoffModP/RiemannRoch/FunctionField/Divisor.lean new file mode 100644 index 0000000000..a4ff46275b --- /dev/null +++ b/LeanPool/MarkoffModP/RiemannRoch/FunctionField/Divisor.lean @@ -0,0 +1,646 @@ +/- +Copyright (c) 2026 Guanghao Li. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Guanghao Li +-/ + +module + +public import LeanPool.MarkoffModP.RiemannRoch.Place +public import Mathlib.Data.Finsupp.Order +public import Mathlib.RingTheory.Valuation.Discrete.IsDiscreteValuationRing + +/-! +# Divisor degree and order on a function field + +This file completes the coordinate divisor API needed for Riemann–Roch spaces and adeles: +place degrees, global degree, and the partial order on `DivisorA`. + +## Main definitions + +* `FunctionField.placeDegree`: residue field dimension of a coordinate place. +* `FunctionField.deg`: global degree of a divisor. + +The partial order on `DivisorA` is the pointwise order on `Finsupp` from Mathlib +(`Finsupp.le_def`); no new order instance is introduced here. +-/ + +@[expose] public section + +open scoped nonZeroDivisors Polynomial RatFunc + +noncomputable section + +namespace FunctionField.Chart + +variable (k K : Type*) [Field k] [Field K] + [Algebra k[X] K] [Algebra k⟮X⟯ K] + [IsScalarTower k[X] k⟮X⟯ K] [FunctionField k K] + [Algebra.IsSeparable k⟮X⟯ K] + +/-- The classical decidable equality on `k(X)` used by the coordinate places. -/ +local instance instDecidableEqRatFuncDivisorFile : DecidableEq k⟮X⟯ := Classical.decEq _ + +/-- The degree of a coordinate place: the residue field dimension over `k`. -/ +noncomputable def placeDegree (v : PlaceA k K) : ℕ := + match v with + | Sum.inl w => + letI : Field (ringOfIntegers k K ⧸ w.asIdeal) := Ideal.Quotient.field w.asIdeal + Module.finrank k (ringOfIntegers k K ⧸ w.asIdeal) + | Sum.inr w => + letI : Field (infiniteIntegers k K ⧸ w.asIdeal) := Ideal.Quotient.field w.asIdeal + Module.finrank k (infiniteIntegers k K ⧸ w.asIdeal) + +/-- Every coordinate place has strictly positive degree. -/ +theorem placeDegree_pos (v : PlaceA k K) : 0 < placeDegree k K v := by + rcases v with v | v + · change 0 < Module.finrank k (ringOfIntegers k K ⧸ v.asIdeal) + exact Module.finrank_pos + · change 0 < Module.finrank k (infiniteIntegers k K ⧸ v.asIdeal) + exact Module.finrank_pos + +omit [IsScalarTower k[X] k⟮X⟯ K] in +/-- At an infinite coordinate place, the place degree is its inertia degree over the unique +place at infinity of `k(X)`. -/ +theorem placeDegree_infinite_eq_inertiaDeg + (v : IsDedekindDomain.HeightOneSpectrum (infiniteIntegers k K)) : + placeDegree k K (Sum.inr v) = + v.asIdeal.inertiaDeg (inftyValuationSubring k) := by + let A := inftyValuationSubring k + let S := infiniteIntegers k K + let p : Ideal A := v.asIdeal.under A + let : v.asIdeal.IsMaximal := v.isPrime.isMaximal v.ne_bot + let : p.IsMaximal := Ideal.IsMaximal.under A v.asIdeal + let : v.asIdeal.LiesOver p := ⟨rfl⟩ + let : Field (A ⧸ p) := Ideal.Quotient.field p + let : Field (S ⧸ v.asIdeal) := Ideal.Quotient.field v.asIdeal + let : Algebra (A ⧸ p) (S ⧸ v.asIdeal) := + Ideal.Quotient.algebraQuotientOfLEComap (Ideal.over_def v.asIdeal p).ge + have hp : p = IsLocalRing.maximalIdeal A := IsLocalRing.eq_maximalIdeal inferInstance + let : FiniteDimensional k (A ⧸ p) := by + rw [hp] + exact inftyValuationSubring.finiteDimensionalResidueField k + let : FiniteDimensional (A ⧸ p) (S ⧸ v.asIdeal) := by + have hfin := Ideal.inertiaDeg_pos v.asIdeal A + rw [Ideal.inertiaDeg_eq_of_isMaximal p v.asIdeal] at hfin + exact FiniteDimensional.of_finrank_pos hfin + let : IsScalarTower k (A ⧸ p) (S ⧸ v.asIdeal) := + IsScalarTower.of_algebraMap_eq fun _ => rfl + change Module.finrank k (S ⧸ v.asIdeal) = v.asIdeal.inertiaDeg A + rw [Ideal.inertiaDeg_eq_of_isMaximal p v.asIdeal] + have htower := Module.finrank_mul_finrank k (A ⧸ p) (S ⧸ v.asIdeal) + have hbase : Module.finrank k (A ⧸ p) = 1 := by + rw [hp] + exact inftyValuationSubring.finrank_residueField k + rw [hbase, one_mul] at htower + exact htower.symm + +/-- At a finite coordinate place, the place degree is the degree of the prime below times its +inertia degree. -/ +theorem placeDegree_finite_eq_base_mul_inertiaDeg + (v : IsDedekindDomain.HeightOneSpectrum (ringOfIntegers k K)) : + placeDegree k K (Sum.inl v) = + Module.finrank k (k[X] ⧸ v.asIdeal.under k[X]) * + v.asIdeal.inertiaDeg k[X] := by + let S := ringOfIntegers k K + let p : Ideal k[X] := v.asIdeal.under k[X] + let : v.asIdeal.IsMaximal := v.isPrime.isMaximal v.ne_bot + let : p.IsMaximal := Ideal.IsMaximal.under k[X] v.asIdeal + let : v.asIdeal.LiesOver p := ⟨rfl⟩ + let : Field (k[X] ⧸ p) := Ideal.Quotient.field p + let : Field (S ⧸ v.asIdeal) := Ideal.Quotient.field v.asIdeal + let : Algebra (k[X] ⧸ p) (S ⧸ v.asIdeal) := + Ideal.Quotient.algebraQuotientOfLEComap (Ideal.over_def v.asIdeal p).ge + let : FiniteDimensional k (k[X] ⧸ p) := + finite_of_finite_type_of_isJacobsonRing k _ + let : FiniteDimensional (k[X] ⧸ p) (S ⧸ v.asIdeal) := by + have hfin := Ideal.inertiaDeg_pos v.asIdeal k[X] + rw [Ideal.inertiaDeg_eq_of_isMaximal p v.asIdeal] at hfin + exact FiniteDimensional.of_finrank_pos hfin + let : IsScalarTower k (k[X] ⧸ p) (S ⧸ v.asIdeal) := + IsScalarTower.of_algebraMap_eq fun _ => rfl + change Module.finrank k (S ⧸ v.asIdeal) = + Module.finrank k (k[X] ⧸ p) * v.asIdeal.inertiaDeg k[X] + rw [Ideal.inertiaDeg_eq_of_isMaximal p v.asIdeal] + exact (Module.finrank_mul_finrank k (k[X] ⧸ p) (S ⧸ v.asIdeal)).symm + +/-- The relative ideal norm of a finite coordinate prime has exponent equal to its inertia +degree; unlike Mathlib's perfect-field version, this uses only the standing separability +hypothesis. -/ +theorem relNorm_asIdeal_finite + (v : IsDedekindDomain.HeightOneSpectrum (ringOfIntegers k K)) : + Ideal.relNorm k[X] v.asIdeal = + (v.asIdeal.under k[X]) ^ v.asIdeal.inertiaDeg k[X] := by + let S := ringOfIntegers k K + let : Algebra k[X] (FractionRing S) := inferInstance + let : FaithfulSMul k[X] (FractionRing S) := inferInstance + let : Algebra (FractionRing k[X]) (FractionRing S) := + FractionRing.liftAlgebra k[X] (FractionRing S) + let : IsScalarTower k[X] (FractionRing k[X]) (FractionRing S) := + FractionRing.isScalarTower_liftAlgebra k[X] (FractionRing S) + let : Algebra.IsSeparable (FractionRing k[X]) (FractionRing S) := by + refine Algebra.IsSeparable.of_equiv_equiv + (FractionRing.algEquiv k[X] k⟮X⟯).symm.toRingEquiv + (FractionRing.algEquiv S K).symm.toRingEquiv ?_ + ext x + exact IsFractionRing.algEquiv_commutes + (FractionRing.algEquiv k[X] k⟮X⟯).symm + (FractionRing.algEquiv S K).symm x + let : v.asIdeal.IsMaximal := v.isPrime.isMaximal v.ne_bot + let : (v.asIdeal.under k[X]).IsMaximal := Ideal.IsMaximal.under k[X] v.asIdeal + exact Ideal.relNorm_eq_pow_of_isMaximal_of_isSeparable + v.asIdeal (v.asIdeal.under k[X]) + +omit [Algebra k[X] K] [IsScalarTower k[X] k⟮X⟯ K] in +/-- The corresponding relative-norm formula on the infinity chart. -/ +theorem relNorm_asIdeal_infinite + (v : IsDedekindDomain.HeightOneSpectrum (infiniteIntegers k K)) : + Ideal.relNorm (inftyValuationSubring k) v.asIdeal = + (v.asIdeal.under (inftyValuationSubring k)) ^ + v.asIdeal.inertiaDeg (inftyValuationSubring k) := by + let A := inftyValuationSubring k + let S := infiniteIntegers k K + let : Algebra A (FractionRing S) := inferInstance + let : FaithfulSMul A (FractionRing S) := inferInstance + let : Algebra (FractionRing A) (FractionRing S) := + FractionRing.liftAlgebra A (FractionRing S) + let : IsScalarTower A (FractionRing A) (FractionRing S) := + FractionRing.isScalarTower_liftAlgebra A (FractionRing S) + let : Algebra.IsSeparable (FractionRing A) (FractionRing S) := by + refine Algebra.IsSeparable.of_equiv_equiv + (FractionRing.algEquiv A k⟮X⟯).symm.toRingEquiv + (FractionRing.algEquiv S K).symm.toRingEquiv ?_ + ext x + exact IsFractionRing.algEquiv_commutes + (FractionRing.algEquiv A k⟮X⟯).symm + (FractionRing.algEquiv S K).symm x + let : v.asIdeal.IsMaximal := v.isPrime.isMaximal v.ne_bot + let : (v.asIdeal.under A).IsMaximal := Ideal.IsMaximal.under A v.asIdeal + exact Ideal.relNorm_eq_pow_of_isMaximal_of_isSeparable + v.asIdeal (v.asIdeal.under A) + +/-- Weighted factor degree on the finite chart is preserved by relative ideal norm. -/ +theorem finite_factorDegree_eq_relNorm (I : Ideal (ringOfIntegers k K)) (hI : I ≠ ⊥) : + ((UniqueFactorizationMonoid.normalizedFactors I).map fun P => + Module.finrank k (k[X] ⧸ P.under k[X]) * P.inertiaDeg k[X]).sum = + ((UniqueFactorizationMonoid.normalizedFactors (Ideal.relNorm k[X] I)).map fun p => + Module.finrank k (k[X] ⧸ p)).sum := by + let S := ringOfIntegers k K + let : Algebra k[X] (FractionRing S) := inferInstance + let : FaithfulSMul k[X] (FractionRing S) := inferInstance + let : Algebra (FractionRing k[X]) (FractionRing S) := + FractionRing.liftAlgebra k[X] (FractionRing S) + let : IsScalarTower k[X] (FractionRing k[X]) (FractionRing S) := + FractionRing.isScalarTower_liftAlgebra k[X] (FractionRing S) + let : Algebra.IsSeparable (FractionRing k[X]) (FractionRing S) := by + refine Algebra.IsSeparable.of_equiv_equiv + (FractionRing.algEquiv k[X] k⟮X⟯).symm.toRingEquiv + (FractionRing.algEquiv S K).symm.toRingEquiv ?_ + ext x + exact IsFractionRing.algEquiv_commutes + (FractionRing.algEquiv k[X] k⟮X⟯).symm + (FractionRing.algEquiv S K).symm x + symm + simpa only [Nat.mul_comm] using + Ideal.sum_normalizedFactors_relNorm_of_isSeparable I hI + (fun p : Ideal k[X] => Module.finrank k (k[X] ⧸ p)) + +omit [Algebra k[X] K] [IsScalarTower k[X] k⟮X⟯ K] in +/-- The analogous relative-norm identity on the infinity chart. -/ +theorem infinite_factorDegree_eq_relNorm + (I : Ideal (infiniteIntegers k K)) (hI : I ≠ ⊥) : + ((UniqueFactorizationMonoid.normalizedFactors I).map fun P => + P.inertiaDeg (inftyValuationSubring k)).sum = + ((UniqueFactorizationMonoid.normalizedFactors + (Ideal.relNorm (inftyValuationSubring k) I)).map fun _ => 1).sum := by + let A := inftyValuationSubring k + let S := infiniteIntegers k K + let : Algebra A (FractionRing S) := inferInstance + let : FaithfulSMul A (FractionRing S) := inferInstance + let : Algebra (FractionRing A) (FractionRing S) := + FractionRing.liftAlgebra A (FractionRing S) + let : IsScalarTower A (FractionRing A) (FractionRing S) := + FractionRing.isScalarTower_liftAlgebra A (FractionRing S) + let : Algebra.IsSeparable (FractionRing A) (FractionRing S) := by + refine Algebra.IsSeparable.of_equiv_equiv + (FractionRing.algEquiv A k⟮X⟯).symm.toRingEquiv + (FractionRing.algEquiv S K).symm.toRingEquiv ?_ + ext x + exact IsFractionRing.algEquiv_commutes + (FractionRing.algEquiv A k⟮X⟯).symm + (FractionRing.algEquiv S K).symm x + symm + simpa using Ideal.sum_normalizedFactors_relNorm_of_isSeparable I hI + (fun _ : Ideal A => 1) + +/-- Over the finite chart of `k(X)`, the weighted prime-factor degree of a principal polynomial +ideal is the polynomial degree. -/ +theorem polynomial_factorDegree_span (p : k[X]) (hp : p ≠ 0) : + ((UniqueFactorizationMonoid.normalizedFactors (Ideal.span {p})).map + (fun P : Ideal k[X] => Module.finrank k (k[X] ⧸ P))).sum = p.natDegree := by + classical + rw [← UniqueFactorizationMonoid.factors_eq_normalizedFactors, + Ideal.factors_span_eq, Multiset.map_map] + simp_rw [Function.comp_apply, finrank_quotient_span_eq_natDegree] + have hassoc := UniqueFactorizationMonoid.factors_prod hp + have hprod : (UniqueFactorizationMonoid.factors p).prod ≠ 0 := + hassoc.ne_zero_iff.mpr hp + have hzero : (0 : k[X]) ∉ UniqueFactorizationMonoid.factors p := by + intro h + exact hprod (Multiset.prod_eq_zero_iff.mpr h) + rw [← Polynomial.natDegree_multiset_prod _ hzero] + exact Polynomial.natDegree_eq_of_degree_eq + (Polynomial.degree_eq_degree_of_associated hassoc) + +/-- Over the infinity chart of `k(X)`, the number of prime factors of a nonzero principal ideal +is the negative rational-function degree of its generator. -/ +theorem infinity_factorDegree_span (a : inftyValuationSubring k) (ha : a ≠ 0) : + ((((UniqueFactorizationMonoid.normalizedFactors (Ideal.span {a})).map + (fun _ : Ideal (inftyValuationSubring k) => (1 : ℕ))).sum : ℕ) : ℤ) = + -RatFunc.intDegree (a : k⟮X⟯) := by + classical + let v := RatFunc.inftyValuation k + let A := inftyValuationSubring k + have hmem : (1 / RatFunc.X : k⟮X⟯) ∈ v.valuationSubring := by + change v (1 / RatFunc.X) ≤ 1 + rw [RatFunc.inftyValuation.X_inv] + simpa only [← WithZero.exp_zero, WithZero.exp_le_exp] using (show (-1 : ℤ) ≤ 0 by omega) + let π : v.valuationSubring := ⟨1 / RatFunc.X, hmem⟩ + have hgen : (↑(Valuation.IsRankOneDiscrete.generator v) : WithZero (Multiplicative ℤ)) = + WithZero.exp (-1 : ℤ) := by + have h := Valuation.IsRankOneDiscrete.generator_eq_exp_neg_one_of_mem_range + (v := v) (show WithZero.exp (-1 : ℤ) ∈ Set.range v from + ⟨1 / RatFunc.X, RatFunc.inftyValuation.X_inv k⟩) + exact congrArg Units.val h + have hπval : v (π : k⟮X⟯) = WithZero.exp (-1 : ℤ) := by + exact RatFunc.inftyValuation.X_inv k + have hπ : v.IsUniformizer (π : k⟮X⟯) := by + rw [Valuation.IsUniformizer.iff, hgen] + exact hπval + let πu : v.Uniformizer := ⟨π, hπ⟩ + obtain ⟨n, u, hau⟩ := Valuation.exists_pow_Uniformizer ha πu + have hassocA : Associated a (π ^ n) := by + have hauA : a = π ^ n * (u : v.valuationSubring) := by + apply Subtype.ext + exact hau + rw [hauA] + exact associated_mul_unit_left _ _ u.isUnit + have hmaxpow : IsLocalRing.maximalIdeal A ^ n = Ideal.span {π ^ n} := by + exact Valuation.pow_Uniformizer_is_pow_generator πu n + have hideal : Ideal.span {a} = IsLocalRing.maximalIdeal A ^ n := by + rw [hmaxpow] + exact Ideal.span_singleton_eq_span_singleton.mpr hassocA + have hmaxIrred : Irreducible (IsLocalRing.maximalIdeal A) := by + exact (Ideal.prime_of_isPrime + (IsDiscreteValuationRing.maximalIdeal A).ne_bot + (IsLocalRing.maximalIdeal.isMaximal A).isPrime).irreducible + have hfactor : + UniqueFactorizationMonoid.normalizedFactors (Ideal.span {a}) = + Multiset.replicate n (IsLocalRing.maximalIdeal A) := by + rw [hideal, UniqueFactorizationMonoid.normalizedFactors_pow, + UniqueFactorizationMonoid.normalizedFactors_irreducible hmaxIrred, + normalize_eq, Multiset.nsmul_singleton] + have hleft : + ((UniqueFactorizationMonoid.normalizedFactors (Ideal.span {a})).map + (fun _ : Ideal A => 1)).sum = n := by + rw [hfactor] + simp + have huval : v ((u : v.valuationSubring) : k⟮X⟯) = 1 := by + exact (Valuation.Integers.isUnit_iff_valuation_eq_one + (Valuation.valuationSubring.integers v)).mp u.isUnit + have haval : v (a : k⟮X⟯) = WithZero.exp (RatFunc.intDegree (a : k⟮X⟯)) := by + rw [RatFunc.inftyValuation_apply, RatFunc.inftyValuation_of_nonzero] + simpa using ha + have hvrepr := congrArg v hau + have hexp : WithZero.exp (RatFunc.intDegree (a : k⟮X⟯)) = + WithZero.exp (-(n : ℤ)) := by + rw [← haval, hvrepr, map_mul] + change v ((π : k⟮X⟯) ^ n) * v ((u : v.valuationSubring) : k⟮X⟯) = _ + rw [map_pow, hπval, huval, mul_one] + calc + WithZero.exp (-1 : ℤ) ^ n = WithZero.exp (n • (-1 : ℤ)) := + (WithZero.exp_nsmul n (-1 : ℤ)).symm + _ = WithZero.exp (-(n : ℤ)) := by congr 1; simp + have hint : RatFunc.intDegree (a : k⟮X⟯) = -(n : ℤ) := + WithZero.exp_injective hexp + have hleftZ : + ((((UniqueFactorizationMonoid.normalizedFactors (Ideal.span {a})).map + (fun _ : Ideal A => (1 : ℕ))).sum : ℕ) : ℤ) = (n : ℤ) := by + exact congrArg (fun m : ℕ => (m : ℤ)) hleft + rw [hleftZ, hint] + omega + +/-- Compatibility of integral norm on the finite chart with the field norm after passing to +fraction fields. -/ +theorem finite_intNorm_div_eq_norm (x : Kˣ) (n : ringOfIntegers k K) + (d : nonZeroDivisors (ringOfIntegers k K)) + (hnd : IsLocalization.mk' K n d = (x : K)) : + algebraMap k[X] k⟮X⟯ (Algebra.intNorm k[X] (ringOfIntegers k K) n) / + algebraMap k[X] k⟮X⟯ + (Algebra.intNorm k[X] (ringOfIntegers k K) (d : ringOfIntegers k K)) = + Algebra.norm k⟮X⟯ (x : K) := by + have hn : algebraMap k[X] k⟮X⟯ (Algebra.intNorm k[X] (ringOfIntegers k K) n) = + Algebra.intNorm k⟮X⟯ K (algebraMap (ringOfIntegers k K) K n) := + Algebra.intNorm_eq_of_isLocalization k[X]⁰ (Bₘ := K) n + have hd : algebraMap k[X] k⟮X⟯ + (Algebra.intNorm k[X] (ringOfIntegers k K) (d : ringOfIntegers k K)) = + Algebra.intNorm k⟮X⟯ K + (algebraMap (ringOfIntegers k K) K (d : ringOfIntegers k K)) := + Algebra.intNorm_eq_of_isLocalization k[X]⁰ (Bₘ := K) (d : ringOfIntegers k K) + rw [Algebra.intNorm_eq_norm k[X] (ringOfIntegers k K), + Algebra.intNorm_eq_norm k⟮X⟯ K] at hn hd + let N : K →*₀ k⟮X⟯ := + { Algebra.norm k⟮X⟯ with + map_zero' := (Algebra.norm_eq_zero_iff (R := k⟮X⟯) (S := K)).mpr rfl } + have hx := congrArg N hnd + rw [IsFractionRing.mk'_eq_div, map_div₀] at hx + change Algebra.norm k⟮X⟯ (algebraMap (ringOfIntegers k K) K n) / + Algebra.norm k⟮X⟯ + (algebraMap (ringOfIntegers k K) K (d : ringOfIntegers k K)) = + Algebra.norm k⟮X⟯ (x : K) at hx + rw [← hn, ← hd] at hx + simpa [Algebra.intNorm_eq_norm k[X] (ringOfIntegers k K)] using hx + +omit [Algebra k[X] K] [IsScalarTower k[X] k⟮X⟯ K] in +/-- Compatibility of integral norm with field norm on the infinity chart. -/ +theorem infinite_intNorm_div_eq_norm (x : Kˣ) (n : infiniteIntegers k K) + (d : nonZeroDivisors (infiniteIntegers k K)) + (hnd : IsLocalization.mk' K n d = (x : K)) : + algebraMap (inftyValuationSubring k) k⟮X⟯ + (Algebra.intNorm (inftyValuationSubring k) (infiniteIntegers k K) n) / + algebraMap (inftyValuationSubring k) k⟮X⟯ + (Algebra.intNorm (inftyValuationSubring k) (infiniteIntegers k K) + (d : infiniteIntegers k K)) = + Algebra.norm k⟮X⟯ (x : K) := by + let A := inftyValuationSubring k + let S := infiniteIntegers k K + have hn : algebraMap A k⟮X⟯ (Algebra.intNorm A S n) = + Algebra.intNorm k⟮X⟯ K (algebraMap S K n) := + Algebra.intNorm_eq_of_isLocalization A⁰ (Bₘ := K) n + have hd : algebraMap A k⟮X⟯ (Algebra.intNorm A S (d : S)) = + Algebra.intNorm k⟮X⟯ K (algebraMap S K (d : S)) := + Algebra.intNorm_eq_of_isLocalization A⁰ (Bₘ := K) (d : S) + rw [Algebra.intNorm_eq_norm A S, Algebra.intNorm_eq_norm k⟮X⟯ K] at hn hd + let N : K →*₀ k⟮X⟯ := + { Algebra.norm k⟮X⟯ with + map_zero' := (Algebra.norm_eq_zero_iff (R := k⟮X⟯) (S := K)).mpr rfl } + have hx := congrArg N hnd + rw [IsFractionRing.mk'_eq_div, map_div₀] at hx + change Algebra.norm k⟮X⟯ (algebraMap S K n) / + Algebra.norm k⟮X⟯ (algebraMap S K (d : S)) = Algebra.norm k⟮X⟯ (x : K) at hx + rw [← hn, ← hd] at hx + simpa [A, S, Algebra.intNorm_eq_norm A S] using hx + +/-- The ideal-valued weight whose restriction to finite height-one primes is `placeDegree`. -/ +noncomputable def finiteIdealWeight (P : Ideal (ringOfIntegers k K)) : ℕ := + Module.finrank k (k[X] ⧸ P.under k[X]) * P.inertiaDeg k[X] + +/-- The ideal-valued weight whose restriction to infinite height-one primes is `placeDegree`. -/ +noncomputable def infiniteIdealWeight (P : Ideal (infiniteIntegers k K)) : ℕ := + P.inertiaDeg (inftyValuationSubring k) + +/-- The finite-chart contribution of a principal divisor is the degree at infinity of the field +norm. -/ +theorem finitePrincipalDegree_eq_intDegree_norm (x : Kˣ) : + (FractionalIdeal.principalDivisor + (R := ringOfIntegers k K) (K := K) (Additive.ofMul x)).sum + (fun v n => n * (placeDegree k K (Sum.inl v) : ℤ)) = + RatFunc.intDegree (Algebra.norm k⟮X⟯ (x : K)) := by + classical + let S := ringOfIntegers k K + obtain ⟨n, d, hnd⟩ := IsLocalization.exists_mk'_eq S⁰ (x : K) + have hn : n ≠ 0 := by + intro hn + exact x.ne_zero (by simpa [hn] using hnd.symm) + have hd : (d : S) ≠ 0 := by + simpa only [mem_nonZeroDivisors_iff_ne_zero] using d.property + have hdeg := FractionalIdeal.weightedDegree_principal_mk' + (R := S) (K := K) (finiteIdealWeight k K) x n d hnd + have hnormn := finite_factorDegree_eq_relNorm k K (Ideal.span {n}) + (Ideal.span_singleton_eq_bot.not.mpr hn) + have hnormd := finite_factorDegree_eq_relNorm k K (Ideal.span {(d : S)}) + (Ideal.span_singleton_eq_bot.not.mpr hd) + let pn : k[X] := Algebra.intNorm k[X] S n + let pd : k[X] := Algebra.intNorm k[X] S (d : S) + have hpn : pn ≠ 0 := by + dsimp only [pn] + rw [Algebra.intNorm_eq_norm] + simpa only [ne_eq, Algebra.norm_eq_zero_iff] using hn + have hpd : pd ≠ 0 := by + dsimp only [pd] + rw [Algebra.intNorm_eq_norm] + simpa only [ne_eq, Algebra.norm_eq_zero_iff] using hd + rw [Ideal.relNorm_singleton, polynomial_factorDegree_span k pn hpn] at hnormn + rw [Ideal.relNorm_singleton, polynomial_factorDegree_span k pd hpd] at hnormd + change + (FractionalIdeal.principalDivisor + (R := S) (K := K) (Additive.ofMul x)).sum + (fun v m => m * (placeDegree k K (Sum.inl v) : ℤ)) = _ + have hchart : + (FractionalIdeal.principalDivisor + (R := S) (K := K) (Additive.ofMul x)).sum + (fun v m => m * (placeDegree k K (Sum.inl v) : ℤ)) = + (pn.natDegree : ℤ) - (pd.natDegree : ℤ) := by + rw [← hnormn, ← hnormd] + simpa only [FractionalIdeal.weightedDegree_apply, finiteIdealWeight, + placeDegree_finite_eq_base_mul_inertiaDeg] using! hdeg + have hratio := finite_intNorm_div_eq_norm k K x n d hnd + change algebraMap k[X] k⟮X⟯ pn / algebraMap k[X] k⟮X⟯ pd = + Algebra.norm k⟮X⟯ (x : K) at hratio + have hpn' : algebraMap k[X] k⟮X⟯ pn ≠ 0 := + by simpa using (IsFractionRing.injective k[X] k⟮X⟯).ne hpn + have hpd' : algebraMap k[X] k⟮X⟯ pd ≠ 0 := + by simpa using (IsFractionRing.injective k[X] k⟮X⟯).ne hpd + have hint := congrArg RatFunc.intDegree hratio + rw [RatFunc.intDegree_div hpn' hpd', RatFunc.intDegree_polynomial, + RatFunc.intDegree_polynomial] at hint + exact hchart.trans hint + +omit [IsScalarTower k[X] k⟮X⟯ K] in +/-- The infinite-chart contribution of a principal divisor is the negative degree at infinity of +the field norm. -/ +theorem infinitePrincipalDegree_eq_neg_intDegree_norm (x : Kˣ) : + (FractionalIdeal.principalDivisor + (R := infiniteIntegers k K) (K := K) (Additive.ofMul x)).sum + (fun v n => n * (placeDegree k K (Sum.inr v) : ℤ)) = + -RatFunc.intDegree (Algebra.norm k⟮X⟯ (x : K)) := by + classical + let A := inftyValuationSubring k + let S := infiniteIntegers k K + obtain ⟨n, d, hnd⟩ := IsLocalization.exists_mk'_eq S⁰ (x : K) + have hn : n ≠ 0 := by + intro hn + exact x.ne_zero (by simpa [hn] using hnd.symm) + have hd : (d : S) ≠ 0 := by + simpa only [mem_nonZeroDivisors_iff_ne_zero] using d.property + have hdeg := FractionalIdeal.weightedDegree_principal_mk' + (R := S) (K := K) (infiniteIdealWeight k K) x n d hnd + have hnormn := infinite_factorDegree_eq_relNorm k K (Ideal.span {n}) + (Ideal.span_singleton_eq_bot.not.mpr hn) + have hnormd := infinite_factorDegree_eq_relNorm k K (Ideal.span {(d : S)}) + (Ideal.span_singleton_eq_bot.not.mpr hd) + let qn : A := Algebra.intNorm A S n + let qd : A := Algebra.intNorm A S (d : S) + have hqn : qn ≠ 0 := by + dsimp only [qn] + rw [Algebra.intNorm_eq_norm] + simpa only [ne_eq, Algebra.norm_eq_zero_iff] using hn + have hqd : qd ≠ 0 := by + dsimp only [qd] + rw [Algebra.intNorm_eq_norm] + simpa only [ne_eq, Algebra.norm_eq_zero_iff] using hd + rw [Ideal.relNorm_singleton] at hnormn hnormd + have hbaseqn := infinity_factorDegree_span k qn hqn + have hbaseqd := infinity_factorDegree_span k qd hqd + have hnormnZ := congrArg (fun m : ℕ => (m : ℤ)) hnormn + have hnormdZ := congrArg (fun m : ℕ => (m : ℤ)) hnormd + have hupn : + ((((UniqueFactorizationMonoid.normalizedFactors (Ideal.span {n})).map + (fun P => P.inertiaDeg (inftyValuationSubring k))).sum : ℕ) : ℤ) = + -RatFunc.intDegree (qn : k⟮X⟯) := + hnormnZ.trans hbaseqn + have hupd : + ((((UniqueFactorizationMonoid.normalizedFactors (Ideal.span {(d : S)})).map + (fun P => P.inertiaDeg (inftyValuationSubring k))).sum : ℕ) : ℤ) = + -RatFunc.intDegree (qd : k⟮X⟯) := + hnormdZ.trans hbaseqd + change + (FractionalIdeal.principalDivisor + (R := S) (K := K) (Additive.ofMul x)).sum + (fun v m => m * (placeDegree k K (Sum.inr v) : ℤ)) = _ + have hchart : + (FractionalIdeal.principalDivisor + (R := S) (K := K) (Additive.ofMul x)).sum + (fun v m => m * (placeDegree k K (Sum.inr v) : ℤ)) = + -RatFunc.intDegree (qn : k⟮X⟯) - + (-RatFunc.intDegree (qd : k⟮X⟯)) := by + have hdeg' := hdeg + simp only [FractionalIdeal.weightedDegree_apply, infiniteIdealWeight] at hdeg' + erw [hupn, hupd] at hdeg' + simpa only [placeDegree_infinite_eq_inertiaDeg] using hdeg' + have hratio := infinite_intNorm_div_eq_norm k K x n d hnd + change (qn : k⟮X⟯) / (qd : k⟮X⟯) = Algebra.norm k⟮X⟯ (x : K) at hratio + have hqn' : (qn : k⟮X⟯) ≠ 0 := by simpa using hqn + have hqd' : (qd : k⟮X⟯) ≠ 0 := by simpa using hqd + have hint := congrArg RatFunc.intDegree hratio + rw [RatFunc.intDegree_div hqn' hqd'] at hint + rw [hchart, ← hint] + ring + +/-- The valuation subring at a coordinate place. -/ +noncomputable def placeValuationSubring (v : PlaceA k K) : ValuationSubring K := + (placeValuation k K v).valuationSubring + +/-- The global degree of a divisor. -/ +noncomputable def deg (D : DivisorA k K) : ℤ := + D.sum fun v n => (n : ℤ) * (placeDegree k K v : ℤ) + +/-- Product formula: the global degree of a principal divisor is zero. -/ +theorem deg_principalDivisorA_eq_zero (x : Kˣ) : + deg k K (principalDivisorA k K (Additive.ofMul x)) = 0 := by + let Dfin := FractionalIdeal.principalDivisor + (R := ringOfIntegers k K) (K := K) (Additive.ofMul x) + let Dinf := FractionalIdeal.principalDivisor + (R := infiniteIntegers k K) (K := K) (Additive.ofMul x) + have hdiv : principalDivisorA k K (Additive.ofMul x) = Dfin.sumElim Dinf := by + rw [Finsupp.sumElim_eq_add] + rfl + rw [deg, hdiv, Finsupp.sum_sumElim] + change + Dfin.sum (fun v n => n * (placeDegree k K (Sum.inl v) : ℤ)) + + Dinf.sum (fun v n => n * (placeDegree k K (Sum.inr v) : ℤ)) = 0 + rw [finitePrincipalDegree_eq_intDegree_norm k K x, + infinitePrincipalDegree_eq_neg_intDegree_norm k K x] + exact add_neg_cancel _ + +/-- The support of a divisor. -/ +def support (D : DivisorA k K) : Finset (PlaceA k K) := D.support + +/-- A divisor is effective when all coefficients are nonnegative. -/ +def IsEffective (D : DivisorA k K) : Prop := + ∀ v, 0 ≤ D v + +omit [IsScalarTower k[X] k⟮X⟯ K] [FunctionField k K] [Algebra.IsSeparable k⟮X⟯ K] in +theorem deg_zero : deg k K (0 : DivisorA k K) = 0 := by + simp [deg, placeDegree] + +omit [IsScalarTower k[X] k⟮X⟯ K] [FunctionField k K] [Algebra.IsSeparable k⟮X⟯ K] in +theorem deg_add (D₁ D₂ : DivisorA k K) : + deg k K (D₁ + D₂) = deg k K D₁ + deg k K D₂ := by + classical + simp [deg, Finsupp.sum_add_index, add_mul] + +omit [IsScalarTower k[X] k⟮X⟯ K] [FunctionField k K] [Algebra.IsSeparable k⟮X⟯ K] in +theorem deg_neg (D : DivisorA k K) : deg k K (-D) = -deg k K D := by + classical + simp [deg, Finsupp.sum_neg_index, neg_mul] + +omit [IsScalarTower k[X] k⟮X⟯ K] [FunctionField k K] [Algebra.IsSeparable k⟮X⟯ K] in +theorem deg_sub (D D' : DivisorA k K) : + deg k K (D - D') = deg k K D - deg k K D' := by + simp [deg_add, deg_neg, sub_eq_add_neg] + +omit [IsScalarTower k[X] k⟮X⟯ K] [FunctionField k K] [Algebra.IsSeparable k⟮X⟯ K] in +theorem deg_nsmul {D : DivisorA k K} (n : ℕ) : + deg k K (n • D) = (n : ℤ) * deg k K D := by + induction n with + | zero => simp [deg_zero] + | succ n ih => + rw [succ_nsmul, deg_add, ih] + simp only [Nat.cast_add, Nat.cast_one, one_mul, add_mul, add_comm] + +omit [IsScalarTower k[X] k⟮X⟯ K] [FunctionField k K] [Algebra.IsSeparable k⟮X⟯ K] in +theorem deg_nsmul_effective {D : DivisorA k K} (n : ℕ) (_hD : IsEffective k K D) : + deg k K (n • D) = (n : ℤ) * deg k K D := + deg_nsmul (k := k) (K := K) (D := D) n + +omit [IsScalarTower k[X] k⟮X⟯ K] [FunctionField k K] [Algebra.IsSeparable k⟮X⟯ K] in +/-- Effective divisors have nonnegative degree. -/ +theorem deg_nonneg {D : DivisorA k K} (hD : IsEffective k K D) : + 0 ≤ deg k K D := by + classical + exact Finsupp.sum_nonneg fun v _ => + mul_nonneg (hD v) (Int.natCast_nonneg (placeDegree k K v)) + +/-- An effective divisor of degree zero is the zero divisor. -/ +theorem eq_zero_of_effective_deg_zero {D : DivisorA k K} (hD : IsEffective k K D) + (hdeg : deg k K D = 0) : D = 0 := by + classical + rw [deg, Finsupp.sum] at hdeg + have hall := (Finset.sum_eq_zero_iff_of_nonneg (fun v _ => + mul_nonneg (hD v) (Int.natCast_nonneg (placeDegree k K v)))).1 hdeg + apply Finsupp.ext + intro v + simp only [Finsupp.zero_apply] + by_cases hv : v ∈ D.support + · have hmul := hall v hv + have hplace : (placeDegree k K v : ℤ) ≠ 0 := by + exact_mod_cast (placeDegree_pos k K v).ne' + exact (mul_eq_zero.mp hmul).resolve_right hplace + · simpa only [Finsupp.mem_support_iff, not_not] using hv + +omit [IsScalarTower k[X] k⟮X⟯ K] [FunctionField k K] [Algebra.IsSeparable k⟮X⟯ K] in +theorem deg_single (v : PlaceA k K) (n : ℤ) : + deg k K (Finsupp.single v n) = n * placeDegree k K v := by + simp [deg, Finsupp.sum_single_index] + +omit [IsScalarTower k[X] k⟮X⟯ K] [FunctionField k K] [Algebra.IsSeparable k⟮X⟯ K] in +/-- The degree map is monotone for the pointwise order on divisors. -/ +theorem deg_mono {D D' : DivisorA k K} (h : D ≤ D') : + deg k K D ≤ deg k K D' := by + rw [← sub_nonneg, ← deg_sub] + apply deg_nonneg k K + intro v + exact sub_nonneg.mpr (h v) + +omit [IsScalarTower k[X] k⟮X⟯ K] [FunctionField k K] [Algebra.IsSeparable k⟮X⟯ K] in +/-- A nonpositive divisor has nonpositive degree. -/ +theorem deg_nonpos {D : DivisorA k K} (hD : D ≤ 0) : deg k K D ≤ 0 := by + simpa only [deg_zero] using deg_mono k K hD + +omit [IsScalarTower k[X] k⟮X⟯ K] [FunctionField k K] [Algebra.IsSeparable k⟮X⟯ K] in +theorem le_iff_sub_effective {D D' : DivisorA k K} : + D ≤ D' ↔ IsEffective k K (D' - D) := by + simp only [Finsupp.le_def, IsEffective, Finsupp.sub_apply, sub_nonneg] + +end FunctionField.Chart diff --git a/LeanPool/MarkoffModP/RiemannRoch/Genus/AdeleQuotient.lean b/LeanPool/MarkoffModP/RiemannRoch/Genus/AdeleQuotient.lean new file mode 100644 index 0000000000..5c4eeefb39 --- /dev/null +++ b/LeanPool/MarkoffModP/RiemannRoch/Genus/AdeleQuotient.lean @@ -0,0 +1,186 @@ +/- +Copyright (c) 2026 Guanghao Li. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Guanghao Li +-/ + +module + +public import LeanPool.MarkoffModP.RiemannRoch.AdeleSpace.FilterChain +public import LeanPool.MarkoffModP.RiemannRoch.Genus.Basic +public import Mathlib.Algebra.Order.GroupWithZero.Canonical +public import Mathlib.LinearAlgebra.FiniteDimensional.Basic +public import Mathlib.Algebra.Module.Submodule.Lattice +public import Mathlib.LinearAlgebra.Quotient.Basic +public import Mathlib.RingTheory.Valuation.ValuationSubring + +/-! +# Adele quotient rank and the index of specialty +This file proves Stichtenoth 1.5.4: the rank of `𝒜_K/(A(D)+K̃)` equals the specialty +index `i(D)`. +-/ + +@[expose] public section + +open scoped nonZeroDivisors Polynomial RatFunc WithZero +open Filter + +noncomputable section + +namespace FunctionField.Chart + +variable (k K : Type*) [Field k] [Field K] + +variable [Algebra k K] [Algebra k[X] K] [Algebra k⟮X⟯ K] [IsScalarTower k k[X] K] + [IsScalarTower k[X] k⟮X⟯ K] [_root_.FunctionField k K] + [Algebra.IsSeparable k⟮X⟯ K] + +variable [IsFullConstantField k K] + +/-- The classical decidable equality on coordinate places used for adele surgery. -/ +local instance instDecidableEqPlaceAAdeleQuotient : DecidableEq (PlaceA k K) := Classical.decEq _ + +/-- The top submodule of the adele space (avoids `↥⊤` notation pitfalls). -/ +def topAdeleSubmodule : Submodule k (AdeleSpace k K) := ⊤ + +omit [IsFullConstantField k K] in +/-- Finite set of finite places where an adele component is not integral. -/ +theorem exceptionalFinite (α : AdeleSpace k K) : + {v : PlaceA k K | ¬placeValuation k K v (α.val v) ≤ 1}.Finite := + (Filter.eventually_cofinite.mp α.property).subset (by + intro v hv + change α.val v ∉ placeValuationSubring k K v + simpa [placeValuationSubring, Valuation.mem_valuationSubring_iff] using hv) + +/-- Finset of finite places where an adele component is not integral. -/ +def exceptionalPlaces (α : AdeleSpace k K) : Finset (PlaceA k K) := + (exceptionalFinite k K α).toFinset + +/-- Every adele lies in some filtration piece `A(D)`. -/ +noncomputable def divisorOfAdele (α : AdeleSpace k K) : DivisorA k K := + Finsupp.onFinset (exceptionalPlaces k K α) + (fun v => + if 1 < placeValuation k K v (α.val v) then + WithZero.log (placeValuation k K v (α.val v)) + else 0) + (by + intro v hvne + by_cases hlt : 1 < placeValuation k K v (α.val v) + · dsimp [exceptionalPlaces] + exact (exceptionalFinite k K α).mem_toFinset.mpr (not_le.mpr hlt) + · simp [hlt] at hvne) + +omit [IsFullConstantField k K] in +theorem mem_adeleFilt_divisorOfAdele (α : AdeleSpace k K) : + α ∈ adeleFilt k K (divisorOfAdele k K α) := by + intro v + change placeValuation k K v (α.val v) ≤ WithZero.exp ((divisorOfAdele k K α) v) + change placeValuation k K v (α.val v) ≤ + WithZero.exp (if 1 < placeValuation k K v (α.val v) then + WithZero.log (placeValuation k K v (α.val v)) else 0) + by_cases hlt : 1 < placeValuation k K v (α.val v) + · rw [ite_eq_left hlt, WithZero.exp_log (ne_of_gt (zero_lt_one.trans hlt))] + · simpa only [ite_eq_right hlt, WithZero.exp_zero] using le_of_not_gt hlt + +omit [IsFullConstantField k K] in +theorem exists_adeleFilt_mem (α : AdeleSpace k K) : + ∃ D : DivisorA k K, α ∈ adeleFilt k K D := + ⟨divisorOfAdele k K α, mem_adeleFilt_divisorOfAdele k K α⟩ + +theorem defect_eq_genus_of_ge {D D' : DivisorA k K} (hle : D ≤ D') + (hD : defect k K D = genus k K) : defect k K D' = genus k K := by + have hle' : defect k K D ≤ defect k K D' := defect_mono' (k := k) (K := K) hle + have hgen : defect k K D' ≤ genus k K := defect_le k K D' + omega + +theorem sandwichRank_eq_zero_of_defect_eq {D D' : DivisorA k K} (hle : D ≤ D') + (hD : defect k K D = genus k K) : + sandwichRank k K D D' hle = 0 := by + have hD' : defect k K D' = genus k K := defect_eq_genus_of_ge (k := k) (K := K) hle hD + have hs := sandwich (k := k) (K := K) hle + dsimp only [defect] at hD hD' ⊢ + rw [hs] + omega + +omit [IsFullConstantField k K] in +theorem adeleFilt_add_diagonal_eq_of_sandwich_zero {D D' : DivisorA k K} (hle : D ≤ D') + (h0 : sandwichRank k K D D' hle = 0) : + adeleFilt k K D' + diagonalSubmodule k K = adeleFilt k K D + diagonalSubmodule k K := + sandwichDiagonalSubmodule_eq_of_rank_zero (k := k) (K := K) hle h0 + +theorem adeleSubmodule_top_eq_adeleFilt_add_diagonal {D : DivisorA k K} + (hD : defect k K D = genus k K) : + topAdeleSubmodule k K = adeleFilt k K D + diagonalSubmodule k K := by + apply le_antisymm + · intro α _ + obtain ⟨Dα, hDα⟩ := exists_adeleFilt_mem (k := k) (K := K) α + let D' := D ⊔ Dα + have hD' : defect k K D' = genus k K := + defect_eq_genus_of_ge (k := k) (K := K) (le_sup_left (a := D) (b := Dα)) hD + have h0 := sandwichRank_eq_zero_of_defect_eq (k := k) (K := K) (D := D) (D' := D') + (le_sup_left (a := D) (b := Dα)) hD + have heq := adeleFilt_add_diagonal_eq_of_sandwich_zero (k := k) (K := K) (D := D) (D' := D') + (le_sup_left (a := D) (b := Dα)) h0 + have hmem : α ∈ adeleFilt k K D' + diagonalSubmodule k K := + Submodule.mem_sup_left (adeleFilt_mono (k := k) (K := K) le_sup_right hDα) + rw [heq] at hmem + exact hmem + · exact le_top + +omit [IsFullConstantField k K] in +theorem finrankAdeleQuotient_eq_sandwichRank {D D' : DivisorA k K} (hle : D ≤ D') + (hfull : topAdeleSubmodule k K = adeleFilt k K D' + diagonalSubmodule k K) : + finrankAdeleQuotient k K D = (sandwichRank k K D D' hle).toNat := by + classical + let ssum := adeleFilt k K D + diagonalSubmodule k K + let topMod := topAdeleSubmodule k K + let : AddCommGroup ↥topMod := Submodule.addCommGroup _ + let : Module k ↥topMod := Submodule.module _ + let p := Submodule.comap topMod.subtype ssum + let e : ↥topMod ≃ₗ[k] AdeleSpace k K := + Submodule.topEquiv (R := k) (M := AdeleSpace k K) + have hmap := Submodule.map_comap_subtype (p := topMod) (p' := ssum) + have heq_lm : (e : ↥topMod →ₗ[k] AdeleSpace k K) = topMod.subtype := by + apply LinearMap.ext + rintro ⟨f, _⟩ + apply Subtype.ext + funext v + rfl + have hf : p.map (e : ↥topMod →ₗ[k] AdeleSpace k K) = ssum := by + rw [show p.map (e : ↥topMod →ₗ[k] AdeleSpace k K) = p.map topMod.subtype from by + rw [heq_lm], hmap, inf_eq_right] + exact le_top + dsimp only [finrankAdeleQuotient, sandwichRank, ssum] + rw [← (Submodule.Quotient.equiv p ssum e hf).finrank_eq, hfull.symm] + simp only [topMod, topAdeleSubmodule, ssum, p] + simp + +theorem finrank_adele_quotient (D : DivisorA k K) : + finrankAdeleQuotient k K D = indexOfSpecialty k K D := by + obtain ⟨D₁, hD₁⟩ := exists_defect_eq (k := k) (K := K) + let D' := D ⊔ D₁ + have hle : D ≤ D' := le_sup_left (a := D) (b := D₁) + have hD' : defect k K D' = genus k K := + defect_eq_genus_of_ge (k := k) (K := K) (le_sup_right (a := D) (b := D₁)) hD₁ + have hfull := adeleSubmodule_top_eq_adeleFilt_add_diagonal (k := k) (K := K) hD' + have hsand := sandwich (k := k) (K := K) hle + have hfin := finrankAdeleQuotient_eq_sandwichRank (k := k) (K := K) hle hfull + have hdef : sandwichRank k K D D' hle = defect k K D' - defect k K D := by + dsimp only [defect] + rw [hsand] + omega + have hidx : (indexOfSpecialty k K D : ℤ) = genus k K - defect k K D := by + have := indexOfSpecialty_eq (k := k) (K := K) D + dsimp only [defect] at this ⊢ + omega + have hD'gen : defect k K D' = genus k K := hD' + calc finrankAdeleQuotient k K D + _ = (sandwichRank k K D D' hle).toNat := hfin + _ = (genus k K - defect k K D).toNat := by rw [hdef, hD'gen] + _ = indexOfSpecialty k K D := by + rw [← hidx] + simp only [Int.toNat_natCast] + +end FunctionField.Chart + +end diff --git a/LeanPool/MarkoffModP/RiemannRoch/Genus/Basic.lean b/LeanPool/MarkoffModP/RiemannRoch/Genus/Basic.lean new file mode 100644 index 0000000000..8a2e3b9d22 --- /dev/null +++ b/LeanPool/MarkoffModP/RiemannRoch/Genus/Basic.lean @@ -0,0 +1,353 @@ +/- +Copyright (c) 2026 Guanghao Li. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Guanghao Li +-/ + +module + +public import LeanPool.MarkoffModP.RiemannRoch.AdeleSpace.Basic +public import LeanPool.MarkoffModP.RiemannRoch.Genus.Polar +public import LeanPool.MarkoffModP.RiemannRoch.Genus.Ramification +public import Mathlib.Data.Int.LeastGreatest +public import Mathlib.FieldTheory.RatFunc.Basic +public import Mathlib.LinearAlgebra.Basis.Basic + +/-! +# Genus, Riemann inequality, and the index of specialty + +This file defines the genus of a function field and the specialty index `i(D)`. + +## Main definitions + +* `FunctionField.defect`: `deg D + 1 − ℓ(D)`. +* `FunctionField.genus`: the maximal defect. +* `FunctionField.indexOfSpecialty`: `ℓ(D) − (deg D + 1 − g)`. + +## Main results + +* `FunctionField.riemann_ineq` +* `FunctionField.finrank_adele_quotient` +* `FunctionField.genus_ratFunc` +* `FunctionField.deg_polarX_eq_finrank` +-/ + +@[expose] public section + +open scoped nonZeroDivisors Polynomial RatFunc WithZero + +noncomputable section + +namespace FunctionField.Chart + +variable (k K : Type*) [Field k] [Field K] + +variable [Algebra k K] [Algebra k[X] K] [Algebra k⟮X⟯ K] [IsScalarTower k k[X] K] + [IsScalarTower k[X] k⟮X⟯ K] [_root_.FunctionField k K] + [Algebra.IsSeparable k⟮X⟯ K] + +variable [IsFullConstantField k K] + +/-- The classical decidable equality on `k(X)` used by the coordinate places. -/ +local instance instDecidableEqRatFuncGenus : DecidableEq k⟮X⟯ := Classical.decEq _ + +/-- The defect `deg D + 1 − ℓ(D)`. -/ +noncomputable def defect (D : DivisorA k K) : ℤ := + deg k K D + 1 - ell k K D + +/-- Stichtenoth 1.4.11 for the chart variable `X_K` (equality; ≤ half proved in `Polar.lean`). -/ +theorem deg_polarX_eq_finrank : + deg k K (polarDivisor k K (XK k K)) = Module.finrank k⟮X⟯ K := by + exact le_antisymm (deg_polarX_le_finrank (k := k) (K := K)) + (finrank_le_deg_polarX (k := k) (K := K)) + +section RiemannFamily + +omit [IsFullConstantField k K] in +/-- Monotonicity of the defect along divisor domination. -/ +theorem defect_mono' {D D' : DivisorA k K} (h : D ≤ D') : + defect k K D ≤ defect k K D' := by + dsimp only [defect] + have := defect_mono (k := k) (K := K) h + omega + +omit [IsFullConstantField k K] in +/-- Defect is unchanged by adding a principal divisor. -/ +theorem defect_add_principal (D : DivisorA k K) (x : Kˣ) : + defect k K (D + principalDivisorA k K (Additive.ofMul x)) = defect k K D := by + dsimp only [defect] + rw [deg_add, deg_principalDivisor_eq_zero (k := k) (K := K) x, ell_add_principal, add_zero] + +omit [Algebra k K] [IsScalarTower k k[X] K] [IsFullConstantField k K] in +/-- From membership in `L(D₁ - D₀)`, the pole divisor of `f` moves `D₀` below `D₁ + (f)`. -/ +theorem le_add_principal_of_memRRspace {D₀ D₁ : DivisorA k K} {f : K} (hf : f ≠ 0) + (hmem : memRRspace k K (D₁ - D₀) f) : + D₀ ≤ D₁ + principalDivisorA k K (Additive.ofMul (Units.mk0 f hf)) := by + rw [le_iff_sub_effective] + intro v + dsimp only [Finsupp.add_apply, Finsupp.sub_apply] + have hv := hmem v + have hxval := placeValuation_eq_exp_neg_principalDivisor k K (Additive.ofMul (Units.mk0 f hf)) v + change placeValuation k K v f ≤ WithZero.exp ((D₁ - D₀) v) at hv + change placeValuation k K v f = + WithZero.exp (-(principalDivisorA k K (Additive.ofMul (Units.mk0 f hf)) v)) at hxval + rw [hxval] at hv + have hexp := WithZero.exp_le_exp.mp hv + have hsubv : (D₁ - D₀) v = D₁ v - D₀ v := rfl + have hexp' : + -(principalDivisorA k K (Additive.ofMul (Units.mk0 f hf)) v) ≤ D₁ v - D₀ v := by + simpa [hsubv] using hexp + linarith + +omit [IsFullConstantField k K] in +/-- `ℓ(D + E) − deg E ≤ ℓ(D)` for effective `E`. -/ +theorem ell_sub_effective_sub_ge {D E : DivisorA k K} (hE : IsEffective k K E) : + (ell k K (D + E) : ℤ) - deg k K E ≤ ell k K D := by + have hle : D ≤ D + E := by + intro v + simp only [Finsupp.add_apply] + linarith [hE v] + have hsum := finrankRRspaceDiff_add_ell (k := k) (K := K) hle + have hq := finrankRRspaceDiff_add_effective_le (k := k) (K := K) D E hE + have hdeg : 0 ≤ deg k K E := deg_nonneg (k := k) (K := K) hE + have htoNat : ((deg k K E).toNat : ℤ) = deg k K E := Int.toNat_of_nonneg hdeg + have hqZ : (finrankRRspaceDiff k K D (D + E) : ℤ) ≤ deg k K E := by + rw [← htoNat] + exact_mod_cast hq + have hsum' : (finrankRRspaceDiff k K D (D + E) : ℤ) + ell k K D = ell k K (D + E) := by + exact_mod_cast hsum + omega + +omit [IsFullConstantField k K] in +/-- Every defect is bounded by `c₀` once the pole family has defect `≤ c₀` and grows in +rank. -/ +theorem defect_le_of_family (B C : DivisorA k K) (c₀ : ℤ) + (hmono : ∀ r : ℕ, defect k K (C + r • B) ≤ c₀) + (hgrow : ∀ m : ℤ, ∃ r : ℕ, m ≤ ell k K (C + r • B)) : + ∀ D : DivisorA k K, defect k K D ≤ c₀ := by + intro D + let Dpos := D ⊔ (0 : DivisorA k K) + have hDle : D ≤ Dpos := le_sup_left (a := D) (b := 0) + have hDposeff : IsEffective k K Dpos := fun v => le_max_right (D v) 0 + obtain ⟨r, hr⟩ := hgrow (deg k K Dpos + 1) + let Dr := C + r • B + have hsub := ell_sub_effective_sub_ge (k := k) (K := K) (D := Dr - Dpos) (E := Dpos) hDposeff + rw [sub_add_cancel] at hsub + have hellpos : 0 < ell k K (Dr - Dpos) := by + linarith + obtain ⟨f, hfne⟩ := (Module.finrank_pos_iff_exists_ne_zero (R := k)).1 hellpos + let fK : K := f.val + have hfKne : fK ≠ 0 := fun h => hfne (Subtype.ext h) + have hmem : memRRspace k K (Dr - Dpos) fK := f.property + have hDposle : Dpos ≤ Dr + principalDivisorA k K (Additive.ofMul (Units.mk0 fK hfKne)) := + le_add_principal_of_memRRspace (k := k) (K := K) hfKne hmem + have hDle' : D ≤ Dr + principalDivisorA k K (Additive.ofMul (Units.mk0 fK hfKne)) := + le_trans hDle hDposle + calc + defect k K D ≤ + defect k K (Dr + principalDivisorA k K (Additive.ofMul (Units.mk0 fK hfKne))) := + defect_mono' (k := k) (K := K) hDle' + _ = defect k K Dr := defect_add_principal (k := k) (K := K) Dr _ + _ ≤ c₀ := hmono r + +end RiemannFamily + +/-- Along the chart pole family, every defect is at most `deg C + 1 − n`. -/ +theorem defect_le_chart_family (D : DivisorA k K) : + defect k K D ≤ + deg k K (basisPoleBound k K (Module.finBasis k⟮X⟯ K)) + 1 - + Module.finrank k⟮X⟯ K := by + let b := Module.finBasis k⟮X⟯ K + let n := Module.finrank k⟮X⟯ K + let C := basisPoleBound k K b + let B := polarDivisor k K (XK k K) + let c₀ := deg k K C + 1 - n + have hmono : ∀ r : ℕ, defect k K (C + r • B) ≤ c₀ := by + intro r + have hdeg : deg k K (C + r • B) = deg k K C + (r : ℤ) * deg k K B := by + rw [add_comm, ← nsmul_eq_mul, deg_add, deg_nsmul, nsmul_eq_mul, add_comm] + have hell := ell_family_ge (k := k) (K := K) (n := n) (r := r) b + have hBdeg : deg k K B = (n : ℤ) := deg_polarX_eq_finrank (k := k) (K := K) + have hcast : (n * (r + 1) : ℤ) ≤ ell k K (C + r • B) := Nat.cast_le.mpr hell + dsimp only [defect] + rw [hdeg, hBdeg] + linarith + have hn : 0 < n := Module.finrank_pos + have hgrow : ∀ m : ℤ, ∃ r : ℕ, m ≤ ell k K (C + r • B) := by + intro m + by_cases hm : m ≤ 0 + · refine ⟨0, ?_⟩ + have h0le : (0 : DivisorA k K) ≤ C + 0 • B := fun v => + show 0 ≤ (C + 0 • B) v by + simpa [Finsupp.add_apply, Finsupp.nsmul_apply] using + basisPoleBound_nonneg (k := k) (K := K) b v + have hmono0 : (ell k K (0 : DivisorA k K) : ℤ) ≤ ell k K (C + 0 • B) := by + exact_mod_cast Submodule.finrank_mono (RRspace_mono (k := k) (K := K) h0le) + rw [ell_zero (k := k) (K := K)] at hmono0 + linarith + · have hmpos : 0 < m := by omega + let mnat := Int.toNat m + have hmNat : (mnat : ℤ) = m := Int.toNat_of_nonneg (le_of_lt hmpos) + refine ⟨mnat, ?_⟩ + have hge := ell_family_ge (k := k) (K := K) (n := n) (r := mnat) b + have hcast : (n * (mnat + 1) : ℤ) ≤ ell k K (C + mnat • B) := Nat.cast_le.mpr hge + have hbound : m ≤ (n * (mnat + 1) : ℤ) := by + rw [← hmNat] + have hn1 : (1 : ℤ) ≤ n := by exact_mod_cast hn + nlinarith [show (0 : ℤ) < m from hmpos] + linarith + exact defect_le_of_family (k := k) (K := K) B C c₀ hmono hgrow D + +/-- Riemann's bounded-defect theorem: the integer defects have a nonnegative maximum. -/ +theorem exists_max_defect : + ∃ g : ℕ, (∀ D : DivisorA k K, defect k K D ≤ (g : ℤ)) ∧ + ∃ D : DivisorA k K, defect k K D = (g : ℤ) := by + let b := Module.finBasis k⟮X⟯ K + let n := Module.finrank k⟮X⟯ K + let C := basisPoleBound k K b + let c₀ := deg k K C + 1 - n + have hbound : ∀ D : DivisorA k K, defect k K D ≤ c₀ := + fun D => defect_le_chart_family (k := k) (K := K) D + have hzero : defect k K (0 : DivisorA k K) = 0 := by + dsimp only [defect] + rw [deg_zero (k := k) (K := K), ell_zero (k := k) (K := K)] + omega + have hInh : ∃ z : ℤ, ∃ D : DivisorA k K, defect k K D = z := ⟨0, 0, hzero⟩ + have hBdd : ∃ b : ℤ, ∀ z : ℤ, (∃ D : DivisorA k K, defect k K D = z) → z ≤ b := by + refine ⟨c₀, ?_⟩ + intro z ⟨D, hD⟩ + simpa [hD] using hbound D + obtain ⟨g', hg', hgmax⟩ := Int.exists_greatest_of_bdd hBdd hInh + have hg'nn : 0 ≤ g' := hgmax 0 ⟨0, hzero⟩ + refine ⟨g'.toNat, ?_, ?_⟩ + · intro D + have hle := hgmax (defect k K D) ⟨D, rfl⟩ + calc defect k K D ≤ g' := hle + _ = (g'.toNat : ℤ) := (Int.toNat_of_nonneg hg'nn).symm + · obtain ⟨D, hD⟩ := hg' + refine ⟨D, ?_⟩ + rw [Int.toNat_of_nonneg hg'nn] + exact hD + +/-- The genus of the function field `K/k`. -/ +noncomputable def genus : ℕ := + Classical.choose (exists_max_defect k K) + +theorem riemann_ineq (D : DivisorA k K) : + (ell k K D : ℤ) ≥ deg k K D + 1 - (genus k K : ℤ) := by + have h := (Classical.choose_spec (exists_max_defect k K)).1 D + simp only [defect, genus] at h ⊢ + omega + +theorem defect_le (D : DivisorA k K) : defect k K D ≤ genus k K := by + have h := riemann_ineq k K D + simp only [defect] + omega + +theorem exists_defect_eq : ∃ D : DivisorA k K, defect k K D = genus k K := by + simpa only [genus] using (Classical.choose_spec (exists_max_defect k K)).2 + +/-- Riemann's inequality along a growing pole family: the genus is at most `c₀`. -/ +theorem genus_le_of_family (B C : DivisorA k K) (c₀ : ℤ) + (hmono : ∀ r : ℕ, defect k K (C + r • B) ≤ c₀) + (hgrow : ∀ m : ℤ, ∃ r : ℕ, m ≤ ell k K (C + r • B)) : + (genus k K : ℤ) ≤ c₀ := by + have hbound := defect_le_of_family (k := k) (K := K) B C c₀ hmono hgrow + obtain ⟨D, hD⟩ := exists_defect_eq (k := k) (K := K) + simpa [hD] using hbound D + +/-- The index of specialty `i(D) = ℓ(D) − (deg D + 1 − g)`. -/ +noncomputable def indexOfSpecialty (D : DivisorA k K) : ℕ := + (ell k K D - (deg k K D + 1 - (genus k K : ℤ))).toNat + +theorem indexOfSpecialty_eq (D : DivisorA k K) : + (indexOfSpecialty k K D : ℤ) = ell k K D - (deg k K D + 1 - (genus k K : ℤ)) := by + have h := riemann_ineq k K D + rw [indexOfSpecialty, Int.toNat_of_nonneg] + omega + +/-- `finrank k (A_K ⧸ (A(D) + K̃))`. -/ +noncomputable def finrankAdeleQuotient (D : DivisorA k K) : ℕ := + Module.finrank k <| + (AdeleSpace k K) ⧸ (adeleFilt k K D + diagonalSubmodule k K) + +section PolarDivisor + +omit [IsFullConstantField k K] in +theorem polar_deg_pos {x : K} (hx : ¬IsAlgebraic k x) : + 0 < deg k K (polarDivisor k K x) := by + by_cases hx0 : x = 0 + · subst hx0 + exact absurd isAlgebraic_zero hx + · exact polarDivisor_pos k K hx0 hx + +end PolarDivisor + +section RatFunc + +/-- The genus of the rational function field `RatFunc k` is zero. -/ +theorem genus_ratFunc : genus k (RatFunc k) = 0 := by + let K := k⟮X⟯ + have hn : Module.finrank k⟮X⟯ K = 1 := Module.finrank_self k⟮X⟯ + let hb : Module.Basis (Fin 1) k⟮X⟯ K := Module.Basis.singleton (Fin 1) k⟮X⟯ + let B := polarDivisor k K (XK k K) + let C := (0 : DivisorA k K) + have hCeq : basisPoleBound k K hb = C := by + have hpol : polarDivisor k K (1 : K) = 0 := + polarDivisor_eq_zero_of_algebraic (k := k) (K := K) isAlgebraic_one + ext v + simp only [basisPoleBound, C, Finsupp.zero_apply] + rw [Finset.sum_fin_eq_sum_range, Finset.sum_range_one] + dsimp [hb] + simp only [Module.Basis.singleton_apply, hpol] + rfl + have hmono : ∀ r : ℕ, defect k K (C + r • B) ≤ 0 := by + intro r + dsimp only [defect] + have hdeg : deg k K (C + r • B) = (r : ℤ) * deg k K B := by + rw [zero_add, deg_nsmul] + have hell := ell_family_ge (k := k) (K := K) (n := 1) (r := r) hb + have hell' : ((r + 1 : ℕ) : ℤ) ≤ (ell k K (C + r • B) : ℤ) := by + have hellNat : r + 1 ≤ ell k K (C + r • B) := by + simpa [hCeq, one_mul, B] using hell + exact_mod_cast hellNat + norm_num [Nat.cast_add, Nat.cast_one] at hell' + have hBdeg : deg k K B = 1 := by + rw [deg_polarX_eq_finrank (k := k) (K := K)] + exact_mod_cast hn + rw [hdeg, hBdeg] + linarith + have hgrow : ∀ m : ℤ, ∃ r : ℕ, m ≤ ell k K (C + r • B) := by + intro m + by_cases hm : m ≤ 0 + · refine ⟨0, ?_⟩ + have h0le : (0 : DivisorA k K) ≤ C + 0 • B := fun v => by simp [C] + have hmono0 : (ell k K (0 : DivisorA k K) : ℤ) ≤ ell k K (C + 0 • B) := by + exact_mod_cast Submodule.finrank_mono (RRspace_mono (k := k) (K := K) h0le) + rw [ell_zero (k := k) (K := K)] at hmono0 + linarith + · have hmpos : 0 < m := by omega + let mnat := Int.toNat m + have hmNat : (mnat : ℤ) = m := Int.toNat_of_nonneg (le_of_lt hmpos) + refine ⟨mnat, ?_⟩ + have hge := ell_family_ge (k := k) (K := K) (n := 1) (r := mnat) hb + have hcast : ((mnat + 1 : ℕ) : ℤ) ≤ (ell k K (C + mnat • B) : ℤ) := by + have hgeNat : mnat + 1 ≤ ell k K (C + mnat • B) := by + simpa [hCeq, one_mul, B] using hge + exact_mod_cast hgeNat + norm_num [Nat.cast_add, Nat.cast_one] at hcast + linarith + have hle : (genus k K : ℤ) ≤ 0 := + genus_le_of_family (k := k) (K := K) B C 0 hmono hgrow + have hge : 0 ≤ (genus k K : ℤ) := by + have := defect_le (k := k) (K := K) (0 : DivisorA k K) + dsimp [defect] at this + rw [deg_zero (k := k) (K := K), ell_zero (k := k) (K := K)] at this + exact this + linarith + +end RatFunc + +end FunctionField.Chart + +end diff --git a/LeanPool/MarkoffModP/RiemannRoch/Genus/Polar.lean b/LeanPool/MarkoffModP/RiemannRoch/Genus/Polar.lean new file mode 100644 index 0000000000..8b82863f1f --- /dev/null +++ b/LeanPool/MarkoffModP/RiemannRoch/Genus/Polar.lean @@ -0,0 +1,746 @@ +/- +Copyright (c) 2026 Guanghao Li. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Guanghao Li +-/ + +module + +public import LeanPool.MarkoffModP.RiemannRoch.RRspace.Basic +public import Mathlib.FieldTheory.IntermediateField.Adjoin.Basic +public import Mathlib.FieldTheory.RatFunc.Basic +public import Mathlib.RingTheory.Algebraic.Basic +public import Mathlib.LinearAlgebra.Basis.Basic +public import Mathlib.LinearAlgebra.Dimension.Constructions +public import Mathlib.Algebra.Polynomial.AlgebraMap +public import Mathlib.Algebra.Polynomial.Degree.Operations +public import Mathlib.Algebra.Polynomial.Degree.Support +public import Mathlib.FieldTheory.RatFunc.AsPolynomial +public import Mathlib.RingTheory.Adjoin.Polynomial.Bivariate +public import Mathlib.RingTheory.Localization.Integral + +/-! +# Pole divisors and Stichtenoth 1.4.11 +This file develops the pole divisor `(x)_∞` and the key degree identity: +`deg (polarDivisor x) = finrank k(X) K` for transcendental `x`. +-/ + +@[expose] public section + +open scoped nonZeroDivisors Polynomial RatFunc WithZero + +open Polynomial BigOperators Submodule IntermediateField + +noncomputable section + +namespace FunctionField.Chart + +section TranscendentalPowers + +variable (k L : Type*) [Field k] [Field L] [Algebra k L] + +/-- Powers `x^j` with `j ≤ r` are `k`-linearly independent when `x` is transcendental. -/ +theorem linearIndependent_fin_pow_of_transcendental {x : L} (hx : Transcendental k x) (r : ℕ) : + LinearIndependent k fun j : Fin (r + 1) => x ^ (j : ℕ) := by + rw [Fintype.linearIndependent_iff] + intro g hg j + let p : k[X] := ∑ i : Fin (r + 1), C (g i) * X ^ (i : ℕ) + have hzero : aeval x p = 0 := by + have hsum : aeval x p = ∑ i : Fin (r + 1), g i • x ^ (i : ℕ) := by + simp only [p, map_sum, map_mul, aeval_C] + congr 1 + ext i + rw [aeval_X_pow, Algebra.smul_def, mul_comm] + rw [hsum, hg] + have hp0 : p = 0 := (transcendental_iff.mp hx) p hzero + have hcoeffj : g j = 0 := by + have hpgj : g j = p.coeff (j : ℕ) := by + classical + dsimp only [p] + rw [finsetSum_coeff, Finset.sum_eq_single j] + · rw [coeff_C_mul_X_pow, ite_eq_left rfl] + · intro b _ ne + rw [coeff_C_mul_X_pow] + split_ifs with h + · exact absurd h (Fin.val_ne_of_ne ne.symm) + · rfl + · simp + rw [hpgj, hp0, coeff_zero] + exact hcoeffj + +end TranscendentalPowers + +variable (k K : Type*) [Field k] [Field K] + +variable [Algebra k K] [Algebra k[X] K] [Algebra k⟮X⟯ K] [IsScalarTower k k[X] K] + [IsScalarTower k[X] k⟮X⟯ K] [_root_.FunctionField k K] + [Algebra.IsSeparable k⟮X⟯ K] + +variable [IsFullConstantField k K] + +/-- Decidable equality on coordinate places for polar divisor proofs. -/ +local instance instDecidableEqPlaceAPolar : DecidableEq (PlaceA k K) := Classical.decEq _ +/-- The classical decidable equality on `k(X)` used by the coordinate places. -/ +local instance instDecidableEqRatFuncPolar : DecidableEq k⟮X⟯ := Classical.decEq _ + +section PolarDivisor + +/-- The pole divisor `(x)_∞` of a nonzero function. -/ +noncomputable def polarDivisor (x : K) : DivisorA k K := + by + classical + exact if hx : x = 0 then 0 + else (-principalDivisorA k K (Additive.ofMul (Units.mk0 x hx))) ⊔ 0 + +omit [Algebra k K] [IsScalarTower k k[X] K] [IsFullConstantField k K] in +theorem polarDivisor_zero : polarDivisor k K (0 : K) = 0 := by + simp [polarDivisor] + +omit [Algebra k K] [IsScalarTower k k[X] K] [IsFullConstantField k K] in +theorem polarDivisor_nonneg (x : K) : 0 ≤ polarDivisor k K x := by + unfold polarDivisor + split_ifs with hx + · simp + · exact le_sup_right + +theorem polarDivisor_eq_zero_of_algebraic {x : K} (hx : IsAlgebraic k x) : + polarDivisor k K x = 0 := by + by_cases hx0 : x = 0 + · simp [polarDivisor, hx0] + · obtain ⟨c, hc⟩ := IsFullConstantField.algebraic_mem (k := k) (K := K) x hx + have hc0 : c ≠ 0 := fun hc0 => hx0 (hc.trans (by rw [hc0, map_zero])) + have hdiv : + principalDivisorA k K (Additive.ofMul (Units.mk0 x hx0)) = 0 := by + have hmap : Units.mk0 x hx0 = Units.map (algebraMap k K) (Units.mk0 c hc0) := by + ext + exact hc + rw [hmap, principalDivisorA_algebraMap k K (Units.mk0 c hc0)] + ext v + unfold polarDivisor + simp only [dite_eq_right hx0, hdiv, neg_zero, Finsupp.sup_apply, max_self] + +omit [IsFullConstantField k K] in +theorem exists_placeValuation_gt_one_of_not_algebraic {x : K} (_hx : x ≠ 0) + (hnt : ¬IsAlgebraic k x) : + ∃ v : PlaceA k K, 1 < placeValuation k K v x := by + by_cases h : ∃ v : PlaceA k K, 1 < placeValuation k K v x + · exact h + · push Not at h + exact absurd (isAlgebraic_of_placeValuation_le_one k K x h) hnt + +omit [IsFullConstantField k K] in +theorem polarDivisor_pos {x : K} (hx : x ≠ 0) (hnt : ¬IsAlgebraic k x) : + 0 < deg k K (polarDivisor k K x) := by + obtain ⟨v, hvgt⟩ := exists_placeValuation_gt_one_of_not_algebraic k K hx hnt + have hvpos : 0 < placeDegree k K v := placeDegree_pos k K v + have hord : 0 < (polarDivisor k K x) v := by + unfold polarDivisor + split_ifs with hx0 + · exact absurd hx0 hx + · have hvval := placeValuation_eq_exp_neg_principalDivisor k K + (Additive.ofMul (Units.mk0 x hx)) v + change 1 < placeValuation k K v x at hvgt + change placeValuation k K v x = + WithZero.exp (-(principalDivisorA k K (Additive.ofMul (Units.mk0 x hx)) v)) at hvval + rw [hvval] at hvgt + let t := -(principalDivisorA k K (Additive.ofMul (Units.mk0 x hx)) v) + have hexp1 : 1 < WithZero.exp t := hvgt + have ht : 0 < t := by + have hexpne : WithZero.exp t ≠ 0 := WithZero.exp_pos.ne' + have hlog : WithZero.log 1 < WithZero.log (WithZero.exp t) := + (WithZero.log_lt_log one_ne_zero hexpne).2 hexp1 + rw [WithZero.log_one, WithZero.log_exp] at hlog + exact hlog + rw [Finsupp.sup_apply] + exact lt_sup_iff.2 (Or.inl ht) + have hsingle : Finsupp.single v (polarDivisor k K x v) ≤ polarDivisor k K x := by + intro w + by_cases hw : w = v + · subst hw + simp only [Finsupp.single_apply, ite_eq_left] + exact le_rfl + · rw [Finsupp.single_apply, ite_eq_right (Ne.symm hw)] + exact polarDivisor_nonneg k K x w + have hle : (placeDegree k K v : ℤ) * (polarDivisor k K x v) ≤ + deg k K (polarDivisor k K x) := by + rw [← mul_comm (polarDivisor k K x v : ℤ), ← deg_single k K v (polarDivisor k K x v)] + exact deg_mono k K hsingle + have hdeg : 0 < (placeDegree k K v : ℤ) * (polarDivisor k K x v) := by + exact mul_pos (mod_cast hvpos) (mod_cast hord) + exact lt_of_lt_of_le hdeg hle + +omit [Algebra k[X] K] [Algebra k⟮X⟯ K] [IsScalarTower k k[X] K] [IsScalarTower k[X] k⟮X⟯ K] + [_root_.FunctionField k K] [Algebra.IsSeparable k⟮X⟯ K] [IsFullConstantField k K] in +/-- `¬IsAlgebraic` is equivalent to `Transcendental` over a field. -/ +theorem not_isAlgebraic_iff_transcendental (x : K) : + ¬IsAlgebraic k x ↔ Transcendental k x := + Iff.rfl + +/-- If `n(r + 1) ≤ dr + c` for all natural `r` and `0 < d`, then `n ≤ d`. +Used in the `finrank ≤ deg B` half of Stichtenoth 1.4.11. -/ +theorem le_of_forall_nat_mul_le {n d c : ℕ} (_hd : 0 < d) + (h : ∀ r : ℕ, n * (r + 1) ≤ d * r + c) : n ≤ d := by + by_contra hn + have hn' : d < n := lt_of_not_ge hn + have hnd : 0 < n - d := tsub_pos_of_lt hn' + have step : ∀ r : ℕ, (n - d) * r + n ≤ c := by + intro r + have hr := h r + have hsuc : n * (r + 1) = n * r + n := Nat.mul_succ n r + have hn_eq : d + (n - d) = n := by rw [Nat.add_comm, Nat.sub_add_cancel (Nat.le_of_lt hn')] + have hsplit : n * r = d * r + (n - d) * r := by + conv_lhs => arg 1; rw [← hn_eq] + exact add_mul d (n - d) r + rw [hsuc, hsplit] at hr + have hr' : (n - d) * r + n ≤ c := by omega + exact hr' + have _hnc : n ≤ c := by simpa [Nat.mul_zero, Nat.zero_add] using step 0 + have bound : ∀ r : ℕ, (n - d) * r ≤ c - n := by + intro r + have := step r + omega + set q := (c - n) / (n - d) + have hq_lt : c - n < (q + 1) * (n - d) := by + have hmod := Nat.mod_lt (c - n) hnd + calc c - n + = (n - d) * q + (c - n) % (n - d) := (Nat.div_add_mod (c - n) (n - d)).symm + _ = q * (n - d) + (c - n) % (n - d) := by rw [Nat.mul_comm] + _ < q * (n - d) + (n - d) := by gcongr + _ = (q + 1) * (n - d) := by ring_nf + have hcontra := bound (q + 1) + rw [Nat.mul_comm] at hcontra + exact lt_irrefl _ (Nat.lt_of_le_of_lt hcontra hq_lt) + +omit [Algebra k K] [IsScalarTower k k[X] K] [IsFullConstantField k K] in +theorem memRRspace_polarDivisor_of_ne_zero {x : K} (hxne : x ≠ 0) : + memRRspace k K (polarDivisor k K x) x := by + intro v + unfold polarDivisor + split_ifs with hx0 + · exact absurd hx0 hxne + · have hvval := placeValuation_eq_exp_neg_principalDivisor k K + (Additive.ofMul (Units.mk0 x hx0)) v + change placeValuation k K v x = + WithZero.exp (-(principalDivisorA k K (Additive.ofMul (Units.mk0 x hx0)) v)) at hvval + rw [hvval, Finsupp.sup_apply] + exact WithZero.exp_le_exp.mpr (le_max_left _ 0) + +omit [Algebra k K] [IsScalarTower k k[X] K] [IsFullConstantField k K] in +theorem memRRspace_smul_polar {x : K} (hxne : x ≠ 0) (n : ℕ) : + memRRspace k K (n • polarDivisor k K x) (x ^ n) := + memRRspace.pow_mem (k := k) (K := K) (D := polarDivisor k K x) (f := x) + (memRRspace_polarDivisor_of_ne_zero k K hxne) n + +omit [Algebra k K] [IsScalarTower k k[X] K] [IsScalarTower k[X] k⟮X⟯ K] + [_root_.FunctionField k K] [Algebra.IsSeparable k⟮X⟯ K] [IsFullConstantField k K] in +theorem nsmul_le_nsmul_polar {D : DivisorA k K} (hD : 0 ≤ D) {j r : ℕ} (hjr : j ≤ r) : + j • D ≤ r • D := by + intro v + change (j : ℤ) * D v ≤ (r : ℤ) * D v + exact mul_le_mul_of_nonneg_right (Nat.cast_le.mpr hjr) (hD v) + +/-- A uniform pole bound for a finite family of functions. -/ +noncomputable def basisPoleBound {ι : Type*} [Fintype ι] (f : ι → K) : DivisorA k K := + (Finset.univ : Finset ι).sum fun i => polarDivisor k K (f i) + +omit [Algebra k K] [IsScalarTower k k[X] K] [IsFullConstantField k K] in +theorem polarDivisor_le_basisPoleBound {ι : Type*} [Fintype ι] [DecidableEq ι] + (f : ι → K) (i : ι) : + polarDivisor k K (f i) ≤ basisPoleBound k K f := by + classical + simp only [basisPoleBound] + rw [← Finset.add_sum_erase _ _ (Finset.mem_univ i)] + exact le_add_of_nonneg_right (Finset.sum_nonneg fun j _ => polarDivisor_nonneg k K (f j)) + +omit [Algebra k K] [IsScalarTower k k[X] K] [IsFullConstantField k K] in +theorem basisPoleBound_nonneg {ι : Type*} [Fintype ι] (f : ι → K) : + 0 ≤ basisPoleBound k K f := by + intro v + change 0 ≤ (basisPoleBound k K f) v + simp only [basisPoleBound, Finsupp.coe_finsetSum, Finset.sum_apply] + exact Finset.sum_nonneg fun i _ => polarDivisor_nonneg k K (f i) v + +omit [Algebra k K] [IsScalarTower k k[X] K] [IsFullConstantField k K] in +theorem memRRspace_basisPoleBound {ι : Type*} [Fintype ι] [DecidableEq ι] + (f : ι → K) (i : ι) : + memRRspace k K (basisPoleBound k K f) (f i) := by + by_cases hi : f i = 0 + · rw [hi] + exact memRRspace.zero_mem (k := k) (K := K) (basisPoleBound k K f) + · exact (memRRspace.memRRspace_mono (k := k) (K := K) (polarDivisor_le_basisPoleBound k K f i)) + (memRRspace_polarDivisor_of_ne_zero k K hi) + +omit [Algebra k K] [IsScalarTower k k[X] K] [IsFullConstantField k K] in +theorem memRRspace_basis_smul_x_pow {ι : Type*} [Fintype ι] [DecidableEq ι] + (f : ι → K) (x : K) + (hxne : x ≠ 0) (r : ℕ) (i : ι) (j : ℕ) (hj : j ≤ r) : + memRRspace k K (basisPoleBound k K f + r • polarDivisor k K x) (f i * x ^ j) := + memRRspace.mul_mem (k := k) (K := K) + (memRRspace_basisPoleBound k K f i) + ((memRRspace.memRRspace_mono (k := k) (K := K) + (nsmul_le_nsmul_polar (D := polarDivisor k K x) (hD := polarDivisor_nonneg k K x) + (hjr := hj))) + (memRRspace_smul_polar k K hxne j)) + +section ChartVariable + +/-- Scalar tower `k → k⟮X⟯ → K` for chart-variable arguments. -/ +local instance instIsScalarTowerChart : IsScalarTower k k⟮X⟯ K := + IsScalarTower.of_algebraMap_eq fun c => by + rw [IsScalarTower.algebraMap_apply k k[X] K, + IsScalarTower.algebraMap_apply k[X] k⟮X⟯ K, + ← IsScalarTower.algebraMap_apply k k[X] k⟮X⟯] + +/-- The chart variable `X_K` in `K`. -/ +noncomputable def XK : K := algebraMap k⟮X⟯ K (RatFunc.X : k⟮X⟯) + +omit [_root_.FunctionField k K] [Algebra.IsSeparable k⟮X⟯ K] [IsFullConstantField k K] in +theorem transcendental_XK : Transcendental k (XK k K) := + (transcendental_algebraMap_iff (algebraMap k⟮X⟯ K).injective).2 RatFunc.transcendental_X + +omit [_root_.FunctionField k K] [Algebra.IsSeparable k⟮X⟯ K] [IsFullConstantField k K] in +theorem not_algebraic_XK : ¬IsAlgebraic k (XK k K) := + transcendental_XK k K + +omit [_root_.FunctionField k K] [Algebra.IsSeparable k⟮X⟯ K] [IsFullConstantField k K] in +theorem XK_ne_zero : XK k K ≠ 0 := fun hx0 => + (not_algebraic_XK k K) (hx0 ▸ isAlgebraic_zero) + +omit [_root_.FunctionField k K] [Algebra.IsSeparable k⟮X⟯ K] [IsFullConstantField k K] in +/-- Powers `X_K^j` with `j ≤ r` are `k`-linearly independent. -/ +theorem linearIndependent_fin_pow_XK (r : ℕ) : + LinearIndependent k fun j : Fin (r + 1) => (XK k K) ^ (j : ℕ) := + linearIndependent_fin_pow_of_transcendental (k := k) (L := K) (transcendental_XK k K) r + +omit [_root_.FunctionField k K] [Algebra.IsSeparable k⟮X⟯ K] [IsFullConstantField k K] in +/-- The family `{b i · X_K^j}` is `k`-linearly independent over a `k⟮X⟯`-basis `b`. -/ +theorem linearIndependent_basis_smul_XK_pow {n r : ℕ} + (b : Module.Basis (Fin n) k⟮X⟯ K) : + LinearIndependent k fun p : Fin n × Fin (r + 1) => + (b p.1 : K) * (XK k K) ^ (p.2 : ℕ) := by + rw [Fintype.linearIndependent_iff] + intro g hg + let s : Fin n → k⟮X⟯ := fun i => + ∑ j : Fin (r + 1), g (i, j) • RatFunc.X ^ (j : ℕ) + have hsingle : ∀ i, algebraMap k⟮X⟯ K (s i) * (b i : K) = + ∑ j : Fin (r + 1), g (i, j) • ((b i : K) * (XK k K) ^ (j : ℕ)) := by + intro i + dsimp only [s, XK] + rw [map_sum, Finset.sum_mul] + refine Finset.sum_congr rfl ?_ + intro j _ + simp only [Algebra.smul_def, map_mul, map_pow, mul_assoc, mul_comm (b i : K), + IsScalarTower.algebraMap_apply k k⟮X⟯ K (g (i, j))] + have hcombo : ∑ i : Fin n, algebraMap k⟮X⟯ K (s i) * (b i : K) = 0 := by + rw [Finset.sum_congr rfl fun i _ => hsingle i, ← Finset.sum_product'] + exact hg + have hcombo' : ∑ i : Fin n, s i • (b i : K) = 0 := by + simpa only [Algebra.smul_def] using hcombo + have hs : ∀ i, s i = 0 := + (Fintype.linearIndependent_iff.mp b.linearIndependent) s hcombo' + intro p + have hs' := hs p.1 + have hlin := linearIndependent_fin_pow_of_transcendental (k := k) (L := k⟮X⟯) + RatFunc.transcendental_X r + rw [Fintype.linearIndependent_iff] at hlin + exact hlin (fun j => g (p.1, j)) (by dsimp only [s] at hs'; exact hs') p.2 + +omit [IsFullConstantField k K] in +/-- Growth along the pole family: `n(r+1) ≤ ℓ(C + r•B)`. -/ +theorem ell_family_ge {n r : ℕ} (b : Module.Basis (Fin n) k⟮X⟯ K) : + n * (r + 1) ≤ ell k K (basisPoleBound k K b + r • polarDivisor k K (XK k K)) := by + let C := basisPoleBound k K b + let B := polarDivisor k K (XK k K) + let x := XK k K + have hx0 : x ≠ 0 := XK_ne_zero k K + have hDnn : 0 ≤ C + r • B := add_nonneg (basisPoleBound_nonneg k K b) fun v => + mul_nonneg (Nat.cast_nonneg r) (polarDivisor_nonneg k K x v) + let v : Fin n × Fin (r + 1) → K := fun p => (b p.1 : K) * x ^ (p.2 : ℕ) + have hmem : ∀ p, v p ∈ RRspace k K (C + r • B) := by + intro p + rw [mem_RRspace_iff] + exact memRRspace_basis_smul_x_pow (k := k) (K := K) (f := b) x hx0 r p.1 (p.2 : ℕ) + (Nat.le_of_lt_succ (Fin.is_lt p.2)) + have hlin : LinearIndependent k v := + linearIndependent_basis_smul_XK_pow (k := k) (K := K) b + have hsubset : span k (Set.range v) ≤ RRspace k K (C + r • B) := by + refine span_le.mpr ?_ + rintro _ ⟨p, rfl⟩ + exact hmem p + have hcard : n * (r + 1) ≤ Module.finrank k (span k (Set.range v)) := by + have heq_card := finrank_span_eq_card (R := k) (M := K) hlin + simp [heq_card, Fintype.card_prod, Fintype.card_fin] + have hle : Module.finrank k (span k (Set.range v)) ≤ ell k K (C + r • B) := + Submodule.finrank_mono hsubset + exact Nat.le_trans hcard hle + +/-- Stichtenoth 1.4.11 counting half for the chart variable: `[K : k⟮X⟯] ≤ deg (X_K)_∞`. -/ +theorem finrank_le_deg_polarX : + Module.finrank k⟮X⟯ K ≤ deg k K (polarDivisor k K (XK k K)) := by + let n := Module.finrank k⟮X⟯ K + let b := Module.finBasis k⟮X⟯ K + let C := basisPoleBound k K b + let B := polarDivisor k K (XK k K) + have hx : ¬IsAlgebraic k (XK k K) := not_algebraic_XK k K + have hx0 : XK k K ≠ 0 := XK_ne_zero k K + have hBpos : 0 < deg k K B := polarDivisor_pos k K hx0 hx + have hBnn : 0 ≤ B := polarDivisor_nonneg k K (XK k K) + have hBeff : IsEffective k K B := hBnn + have hdegB0 := deg_nonneg k K hBeff + have hdpos : 0 < (deg k K B).toNat := by + rw [← Int.toNat_of_nonneg hdegB0] at hBpos + exact Int.ofNat_lt.mp hBpos + have hmain : n ≤ (deg k K B).toNat := + le_of_forall_nat_mul_le (d := (deg k K B).toNat) (c := (deg k K C).toNat + 1) hdpos fun r => by + let D := C + r • B + have hDnn : 0 ≤ D := add_nonneg (basisPoleBound_nonneg k K b) fun v => + mul_nonneg (Nat.cast_nonneg r) (hBnn v) + have hDeff : IsEffective k K D := hDnn + have hCeff : IsEffective k K C := basisPoleBound_nonneg k K b + have hell : (ell k K D : ℤ) ≤ deg k K D + 1 := + ell_le_nonneg (k := k) (K := K) hDnn + have hdeg : deg k K D = deg k K C + (r : ℤ) * deg k K B := by + rw [add_comm, ← nsmul_eq_mul, deg_add, deg_nsmul, nsmul_eq_mul, add_comm] + have hell_nat : n * (r + 1) ≤ ell k K D := + ell_family_ge (k := k) (K := K) (n := n) (r := r) b + have hbound : (n * (r + 1) : ℤ) ≤ deg k K D + 1 := + (Nat.cast_le.mpr hell_nat).trans hell + have hC0 := deg_nonneg k K hCeff + have htoC : ((deg k K C).toNat : ℤ) = deg k K C := Int.toNat_of_nonneg hC0 + have htoB : ((deg k K B).toNat : ℤ) = deg k K B := Int.toNat_of_nonneg hdegB0 + have hsum : + deg k K D + 1 = (deg k K B).toNat * r + ((deg k K C).toNat + 1) := by + rw [hdeg, htoC, htoB] + ring + have hnat_z : + (n * (r + 1) : ℤ) ≤ (deg k K B).toNat * r + ((deg k K C).toNat + 1) := by + rw [← hsum] + exact hbound + exact_mod_cast hnat_z + have hdegB := deg_nonneg k K hBeff + rw [← Int.toNat_of_nonneg hdegB] + exact_mod_cast hmain + +end ChartVariable + +section Auxiliary + +/-- The rational function field `k(x) ⊆ K` generated by a transcendental element. -/ +noncomputable def rationalSubfield (x : K) : IntermediateField k K := + IntermediateField.adjoin k {x} + +omit [Algebra k[X] K] [Algebra k⟮X⟯ K] [IsScalarTower k k[X] K] [IsScalarTower k[X] k⟮X⟯ K] + [_root_.FunctionField k K] [Algebra.IsSeparable k⟮X⟯ K] [IsFullConstantField k K] in +/-- The family `{b i * x^j}` is `k`-linearly independent over a `k(x)`-basis `b`. -/ +theorem linearIndependent_basis_smul_x_pow {n r : ℕ} {x : K} (hx : Transcendental k x) + (b : Module.Basis (Fin n) (rationalSubfield k K x) K) : + LinearIndependent k fun p : Fin n × Fin (r + 1) => + (b p.1 : K) * x ^ (p.2 : ℕ) := by + rw [Fintype.linearIndependent_iff] + intro g hg + let F := rationalSubfield k K x + have hxF : x ∈ F := IntermediateField.mem_adjoin_of_mem k (Set.mem_singleton x) + let s : Fin n → F := fun i => + ∑ j : Fin (r + 1), g (i, j) • ⟨x ^ (j : ℕ), by + convert F.pow_mem hxF (Int.ofNat j) using 1 + exact (zpow_natCast x j).symm⟩ + have hsingle : ∀ i, s i • (b i : K) = + ∑ j : Fin (r + 1), g (i, j) • ((b i : K) * x ^ (j : ℕ)) := by + intro i + simp only [s, Algebra.smul_def, map_sum] + rw [Finset.sum_mul] + congr 1 + ext j + simp [mul_assoc, mul_comm, mul_left_comm] + have hcombo : ∑ i : Fin n, s i • (b i : K) = 0 := by + rw [Finset.sum_congr rfl fun i _ => hsingle i, ← Finset.sum_product'] + exact hg + have hs : ∀ i, s i = 0 := (Fintype.linearIndependent_iff.mp b.linearIndependent) s hcombo + intro p + have hs' := hs p.1 + have hz : ∑ j : Fin (r + 1), g (p.1, j) • x ^ (j : ℕ) = 0 := by + simpa [s] using congrArg Subtype.val hs' + have hlin := linearIndependent_fin_pow_of_transcendental (k := k) (L := K) hx r + rw [Fintype.linearIndependent_iff] at hlin + exact hlin (fun j => g (p.1, j)) hz p.2 + +omit [_root_.FunctionField k K] [Algebra.IsSeparable k⟮X⟯ K] [IsFullConstantField k K] in +/-- The structure map `k[X] → K` is evaluation of polynomials at the chart variable `X_K`. -/ +theorem algebraMap_polynomial_eq_aeval_XK (p : k[X]) : + algebraMap k[X] K p = aeval (XK k K) p := by + have h : IsScalarTower.toAlgHom k k[X] K = aeval (XK k K) := by + refine Polynomial.algHom_ext ?_ + rw [IsScalarTower.toAlgHom_apply, aeval_X, + IsScalarTower.algebraMap_apply k[X] k⟮X⟯ K, RatFunc.algebraMap_X] + rfl + calc algebraMap k[X] K p = IsScalarTower.toAlgHom k k[X] K p := rfl + _ = aeval (XK k K) p := by rw [h] + +omit [_root_.FunctionField k K] [Algebra.IsSeparable k⟮X⟯ K] [IsFullConstantField k K] in +/-- The structure map `k⟮X⟯ → K` sends a rational function to the quotient of the +evaluations of its numerator and denominator at `X_K`. -/ +theorem algebraMap_ratFunc_eq_div (c : k⟮X⟯) : + algebraMap k⟮X⟯ K c = aeval (XK k K) c.num / aeval (XK k K) c.denom := by + conv_lhs => rw [← RatFunc.num_div_denom c] + rw [map_div₀, ← IsScalarTower.algebraMap_apply k[X] k⟮X⟯ K, + ← IsScalarTower.algebraMap_apply k[X] k⟮X⟯ K, + algebraMap_polynomial_eq_aeval_XK, algebraMap_polynomial_eq_aeval_XK] + +omit [Algebra k[X] K] [IsScalarTower k k[X] K] [IsScalarTower k[X] k⟮X⟯ K] + [_root_.FunctionField k K] [Algebra.IsSeparable k⟮X⟯ K] [IsFullConstantField k K] in +/-- Coercion of `aeval` at the adjoined generator of `k(X_K)`. -/ +theorem coe_aeval_adjoinSimple_gen_XK (p : k[X]) : + ((aeval (AdjoinSimple.gen k (XK k K)) p : IntermediateField.adjoin k {XK k K}) : K) + = aeval (XK k K) p := by + have hgen : (IntermediateField.adjoin k {XK k K}).val (AdjoinSimple.gen k (XK k K)) = XK k K := + IntermediateField.AdjoinSimple.algebraMap_gen k (XK k K) + calc ((aeval (AdjoinSimple.gen k (XK k K)) p : IntermediateField.adjoin k {XK k K}) : K) + = (IntermediateField.adjoin k {XK k K}).val + (aeval (AdjoinSimple.gen k (XK k K)) p) := rfl + _ = aeval ((IntermediateField.adjoin k {XK k K}).val (AdjoinSimple.gen k (XK k K))) p := + (Polynomial.aeval_algHom_apply _ _ _).symm + _ = aeval (XK k K) p := by rw [hgen] + +omit [_root_.FunctionField k K] [Algebra.IsSeparable k⟮X⟯ K] [IsFullConstantField k K] in +/-- The canonical `k`-embedding `k⟮X⟯ ≃ₐ k(X_K) ⊆ K` agrees with the structure map. -/ +theorem coe_ratFuncAlgEquiv_XK (c : k⟮X⟯) : + ((RatFunc.algEquivOfTranscendental (XK k K) (transcendental_XK k K) c : + IntermediateField.adjoin k {XK k K}) : K) + = algebraMap k⟮X⟯ K c := by + conv_lhs => rw [← RatFunc.num_div_denom c] + rw [map_div₀, RatFunc.algEquivOfTranscendental_algebraMap, + RatFunc.algEquivOfTranscendental_algebraMap, IntermediateField.coe_div, + coe_aeval_adjoinSimple_gen_XK, coe_aeval_adjoinSimple_gen_XK, + algebraMap_ratFunc_eq_div] + +/-! ### Target 2: finrank bridge -/ + +omit [_root_.FunctionField k K] [Algebra.IsSeparable k⟮X⟯ K] [IsFullConstantField k K] in +theorem finrank_eq_finrank_rationalSubfield_XK : + Module.finrank k⟮X⟯ K = + Module.finrank (rationalSubfield k K (algebraMap k⟮X⟯ K (RatFunc.X : k⟮X⟯))) K := by + refine Algebra.finrank_eq_of_equiv_equiv + (RatFunc.algEquivOfTranscendental (XK k K) (transcendental_XK k K)).toRingEquiv + (RingEquiv.refl K) ?_ + ext c + change algebraMap (IntermediateField.adjoin k {XK k K}) K + (RatFunc.algEquivOfTranscendental (XK k K) (transcendental_XK k K) c) + = algebraMap k⟮X⟯ K c + rw [IntermediateField.algebraMap_apply] + exact coe_ratFuncAlgEquiv_XK k K c + +/-! ### Target 1: finite dimensionality over `k(x)` -/ + +omit [_root_.FunctionField k K] [IsFullConstantField k K] in +/-- Every element of `K` is algebraic over the polynomial subalgebra `k[X_K]`. -/ +theorem isAlgebraic_adjoin_XK (z : K) : + IsAlgebraic (Algebra.adjoin k {XK k K}) z := by + have h1 : IsAlgebraic k⟮X⟯ z := Algebra.IsAlgebraic.isAlgebraic z + have h2 : IsAlgebraic k[X] z := (IsFractionRing.isAlgebraic_iff k[X] k⟮X⟯ K).mpr h1 + obtain ⟨p, hp0, hpz⟩ := h2 + set e := Polynomial.algEquivOfTranscendental k (XK k K) (transcendental_XK k K) with he + have hcomp : ((Algebra.adjoin k {XK k K}).val.comp e.toAlgHom : k[X] →ₐ[k] K) + = IsScalarTower.toAlgHom k k[X] K := by + refine Polynomial.algHom_ext ?_ + rw [AlgHom.comp_apply] + have hex : e.toAlgHom X = e X := rfl + rw [hex, he, Polynomial.algEquivOfTranscendental_apply_X, + IsScalarTower.toAlgHom_apply, IsScalarTower.algebraMap_apply k[X] k⟮X⟯ K, + RatFunc.algebraMap_X] + rfl + refine ⟨p.map (e : k[X] →+* Algebra.adjoin k {XK k K}), ?_, ?_⟩ + · exact (Polynomial.map_ne_zero_iff e.injective).mpr hp0 + · rw [aeval_def, Polynomial.eval₂_map] + have hring : ((algebraMap (Algebra.adjoin k {XK k K}) K).comp + (e : k[X] →+* Algebra.adjoin k {XK k K})) = algebraMap k[X] K := by + have := congrArg AlgHom.toRingHom hcomp + exact this + rw [hring, ← aeval_def] + exact hpz + +omit [_root_.FunctionField k K] [IsFullConstantField k K] in +/-- Exchange: if `x` is transcendental over `k`, then `X_K` is algebraic over `k[x]`. -/ +theorem isAlgebraic_adjoin_x_XK {x : K} (hx : Transcendental k x) : + IsAlgebraic (Algebra.adjoin k {x}) (XK k K) := by + have h := IsAlgebraic.adjoin_singleton (R := k) (A := K) (B := K) + (transcendental_XK k K) hx (isAlgebraic_adjoin_XK k K x) + simpa using h + +omit [_root_.FunctionField k K] [IsFullConstantField k K] in +/-- `X_K` is algebraic over the rational subfield `k(x)`. -/ +theorem isAlgebraic_rationalSubfield_XK {x : K} (hx : Transcendental k x) : + IsAlgebraic (rationalSubfield k K x) (XK k K) := by + have hle : Algebra.adjoin k {x} ≤ (rationalSubfield k K x).toSubalgebra := by + refine Algebra.adjoin_le ?_ + intro y hy + rw [Set.mem_singleton_iff] at hy + subst hy + exact IntermediateField.subset_adjoin k {y} rfl + exact (isAlgebraic_adjoin_x_XK k K hx).tower_top_of_subalgebra_le hle + +omit [IsFullConstantField k K] in +/-- A function field is finite over the rational subfield generated by a transcendental element. -/ +theorem finiteDimensional_rationalSubfield {x : K} (hx : Transcendental k x) : + FiniteDimensional (rationalSubfield k K x) K := by + set F := rationalSubfield k K x with hF + set t := XK k K with ht + have htF : IsIntegral F t := (isAlgebraic_rationalSubfield_XK k K hx).isIntegral + have hFN : FiniteDimensional F (IntermediateField.adjoin F {t}) := + IntermediateField.adjoin.finiteDimensional htF + set N := IntermediateField.adjoin F {t} with hN + -- every polynomial evaluation at t lies in N + have haev : ∀ p : k[X], aeval t p ∈ N := by + intro p + have h1 : aeval t (p.map (algebraMap k F)) = aeval t p := + Polynomial.aeval_map_algebraMap F t p + rw [← h1] + have h2 : aeval t (p.map (algebraMap k F)) ∈ Algebra.adjoin F ({t} : Set K) := by + rw [Algebra.adjoin_singleton_eq_range_aeval] + exact ⟨p.map (algebraMap k F), rfl⟩ + exact IntermediateField.algebra_adjoin_le_adjoin F {t} h2 + -- the image of k⟮X⟯ inside K lies in N + have hE : ∀ c : k⟮X⟯, algebraMap k⟮X⟯ K c ∈ N := by + intro c + rw [algebraMap_ratFunc_eq_div] + exact div_mem (haev c.num) (haev c.denom) + -- the subalgebra k[t] is contained in N + have hsub : ∀ z : K, z ∈ Algebra.adjoin k ({t} : Set K) → z ∈ N := by + intro z hz + rw [Algebra.adjoin_singleton_eq_range_aeval] at hz + obtain ⟨p, rfl⟩ := hz + exact haev p + -- the inclusion ring hom k[t] →+* N + let χ : Algebra.adjoin k ({t} : Set K) →+* N := + { toFun := fun a => ⟨a.1, hsub a.1 a.2⟩ + map_one' := rfl + map_mul' := fun _ _ => rfl + map_zero' := rfl + map_add' := fun _ _ => rfl } + have hχinj : Function.Injective χ := by + intro a b hab + have h : (a : K) = (b : K) := congrArg (fun z : N => (z : K)) hab + exact Subtype.ext h + -- basis of K over k⟮X⟯ + set b := Module.finBasis k⟮X⟯ K with hb + -- each basis vector is integral over N + have hbN : ∀ i, IsIntegral N (b i) := by + intro i + refine IsAlgebraic.isIntegral ?_ + obtain ⟨p, hp0, hpz⟩ := isAlgebraic_adjoin_XK k K (b i) + refine ⟨p.map χ, (Polynomial.map_ne_zero_iff hχinj).mpr hp0, ?_⟩ + rw [aeval_def, Polynomial.eval₂_map] + have hring : (algebraMap N K).comp χ + = algebraMap (Algebra.adjoin k ({t} : Set K)) K := RingHom.ext fun a => rfl + rw [hring, ← aeval_def] + exact hpz + -- K is generated over N by the basis vectors + have htop : IntermediateField.adjoin N (Set.range ⇑b) = ⊤ := by + rw [eq_top_iff] + rintro z - + have hz := b.sum_repr z + rw [← hz] + refine sum_mem fun i _ => ?_ + rw [Algebra.smul_def] + refine mul_mem ?_ (IntermediateField.subset_adjoin N _ ⟨i, rfl⟩) + have hmem := hE (b.repr z i) + have := IntermediateField.algebraMap_mem (IntermediateField.adjoin N (Set.range ⇑b)) + (⟨algebraMap k⟮X⟯ K (b.repr z i), hmem⟩ : N) + rwa [IntermediateField.algebraMap_apply] at this + have hfin : Finite (Set.range ⇑b) := (Set.finite_range ⇑b).to_subtype + have hNtop : FiniteDimensional N (IntermediateField.adjoin N (Set.range ⇑b)) := + IntermediateField.finiteDimensional_adjoin fun z hz => by + obtain ⟨i, rfl⟩ := hz + exact hbN i + have hNK : FiniteDimensional N K := by + rw [htop] at hNtop + exact (IntermediateField.topEquiv (F := N) (E := K)).toLinearEquiv.finiteDimensional + exact Module.Finite.trans N K + + +/-- Stichtenoth 1.4.11 (≤) for general transcendental `x`. -/ +theorem finrankAdjoin_le_deg_polar {x : K} (hx : ¬IsAlgebraic k x) : + Module.finrank (rationalSubfield k K x) K ≤ deg k K (polarDivisor k K x) := by + have hxT : Transcendental k x := hx + by_cases hx0 : x = 0 + · subst hx0 + exact absurd isAlgebraic_zero hx + have := finiteDimensional_rationalSubfield (k := k) (K := K) hxT + let F := rationalSubfield k K x + let n := Module.finrank F K + let b := Module.finBasis F K + let C := basisPoleBound k K b + let B := polarDivisor k K x + have hBpos : 0 < deg k K B := polarDivisor_pos k K hx0 hx + have hBnn : 0 ≤ B := polarDivisor_nonneg k K x + have hBeff : IsEffective k K B := polarDivisor_nonneg k K x + have hdegB0 := deg_nonneg k K hBeff + have hdpos : 0 < (deg k K B).toNat := by + rw [← Int.toNat_of_nonneg hdegB0] at hBpos + exact Int.ofNat_lt.mp hBpos + have hmain : n ≤ (deg k K B).toNat := + le_of_forall_nat_mul_le (d := (deg k K B).toNat) (c := (deg k K C).toNat + 1) hdpos fun r => by + let D := C + r • B + have hDnn : 0 ≤ D := add_nonneg (basisPoleBound_nonneg k K b) fun v => + mul_nonneg (Nat.cast_nonneg r) (hBnn v) + have hDeff : IsEffective k K D := hDnn + have hCeff : IsEffective k K C := basisPoleBound_nonneg k K b + let v : Fin n × Fin (r + 1) → K := fun p => (b p.1 : K) * x ^ (p.2 : ℕ) + have hmem : ∀ p, v p ∈ RRspace k K D := by + intro p + rw [mem_RRspace_iff] + exact memRRspace_basis_smul_x_pow (k := k) (K := K) (f := b) x hx0 r p.1 (p.2 : ℕ) + (Nat.le_of_lt_succ (Fin.is_lt p.2)) + have hlin : LinearIndependent k v := + linearIndependent_basis_smul_x_pow (k := k) (K := K) hxT b + have hsubset : span k (Set.range v) ≤ RRspace k K D := by + refine span_le.mpr ?_ + rintro _ ⟨p, rfl⟩ + exact hmem p + have hcard : + n * (r + 1) ≤ Module.finrank k (span k (Set.range v)) := by + have heq_card := finrank_span_eq_card (R := k) (M := K) hlin + simp [heq_card, Fintype.card_prod, Fintype.card_fin] + have hle : Module.finrank k (span k (Set.range v)) ≤ ell k K D := + Submodule.finrank_mono hsubset + have hell : (ell k K D : ℤ) ≤ deg k K D + 1 := + ell_le_nonneg (k := k) (K := K) hDnn + have hdeg : deg k K D = deg k K C + (r : ℤ) * deg k K B := by + rw [add_comm, ← nsmul_eq_mul, deg_add, deg_nsmul, nsmul_eq_mul, add_comm] + have hell_nat : n * (r + 1) ≤ ell k K D := Nat.le_trans hcard hle + have hbound : (n * (r + 1) : ℤ) ≤ deg k K D + 1 := + (Nat.cast_le.mpr hell_nat).trans hell + have hC0 := deg_nonneg k K hCeff + have htoC : ((deg k K C).toNat : ℤ) = deg k K C := Int.toNat_of_nonneg hC0 + have htoB : ((deg k K B).toNat : ℤ) = deg k K B := Int.toNat_of_nonneg hdegB0 + have hsum : + deg k K D + 1 = (deg k K B).toNat * r + ((deg k K C).toNat + 1) := by + rw [hdeg, htoC, htoB] + ring + have hnat_z : + (n * (r + 1) : ℤ) ≤ (deg k K B).toNat * r + ((deg k K C).toNat + 1) := by + rw [← hsum] + exact hbound + exact_mod_cast hnat_z + have hdegB := deg_nonneg k K hBeff + rw [← Int.toNat_of_nonneg hdegB] + exact_mod_cast hmain + +/-- Coordinate-base specialization via the adjoin bridge. -/ +theorem deg_polar_le_finrank {x : K} (hx : ¬IsAlgebraic k x) + (hxgen : x = algebraMap k⟮X⟯ K (RatFunc.X : k⟮X⟯)) : + Module.finrank k⟮X⟯ K ≤ deg k K (polarDivisor k K x) := by + rw [hxgen] at hx ⊢ + have h := finrankAdjoin_le_deg_polar (k := k) (K := K) hx + have hfin : + Module.finrank k⟮X⟯ K = + Module.finrank (rationalSubfield k K (algebraMap k⟮X⟯ K (RatFunc.X : k⟮X⟯))) K := + finrank_eq_finrank_rationalSubfield_XK k K + exact hfin ▸ h + +end Auxiliary + +end PolarDivisor + +end FunctionField.Chart + +end diff --git a/LeanPool/MarkoffModP/RiemannRoch/Genus/Ramification.lean b/LeanPool/MarkoffModP/RiemannRoch/Genus/Ramification.lean new file mode 100644 index 0000000000..ab3902dbe3 --- /dev/null +++ b/LeanPool/MarkoffModP/RiemannRoch/Genus/Ramification.lean @@ -0,0 +1,404 @@ +/- +Copyright (c) 2026 Guanghao Li. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Guanghao Li +-/ + +module + +public import LeanPool.MarkoffModP.RiemannRoch.Genus.Polar +public import Mathlib.RingTheory.RamificationInertia.Basic +public import Mathlib.LinearAlgebra.Dimension.Localization +public import Mathlib.RingTheory.DedekindDomain.Ideal.Lemmas +public import Mathlib.RingTheory.Valuation.Discrete.Basic +public import Mathlib.RingTheory.IntegralClosure.Algebra.Basic +public import Mathlib.Algebra.Group.TypeTags.Basic + +/-! +# Ramification half of Stichtenoth 1.4.11 +This file proves `deg (X_K)_∞ ≤ [K : k(X)]` via the fundamental identity of ramification +index and inertia degree. +-/ + +@[expose] public section + +open scoped nonZeroDivisors Polynomial RatFunc WithZero Additive + +open Polynomial BigOperators Submodule IntermediateField Ideal FunctionField + +noncomputable section + +namespace FunctionField.Chart + +private theorem ramificationSum_eq_fractionField_finrank + (R S K L : Type*) [CommRing R] [IsDomain R] [CommRing S] + [IsDedekindDomain S] [Field K] [Field L] + [Algebra R S] [Module.Finite R S] [Module.Flat R S] [Module.IsTorsionFree R S] + [Algebra R K] [Algebra S L] [Algebra R L] [Algebra K L] + [IsScalarTower R K L] [IsScalarTower R S L] + [IsFractionRing R K] [IsFractionRing S L] + (p : Ideal R) [p.IsMaximal] (hp : p ≠ ⊥) : + (∑ q ∈ IsDedekindDomain.primesOverFinset p S, + p.ramificationIdx' q * q.inertiaDeg R) = Module.finrank K L := by + classical + rw [Finset.sum_subtype _ (fun q => IsDedekindDomain.mem_primesOverFinset_iff hp S)] + calc + (∑ q : p.primesOver S, p.ramificationIdx' q.1 * q.1.inertiaDeg R) = + ∑ q : p.primesOver S, q.1.ramificationIdx R * q.1.inertiaDeg R := by + apply Finset.sum_congr rfl + intro q _ + let : q.1.IsPrime := q.2.1 + let : q.1.LiesOver p := q.2.2 + rw [Ideal.ramificationIdx'_eq_ramificationIdx p q.1 hp] + _ = Module.finrank R S := Ideal.sum_ramification_inertia_eq_finrank p S + _ = Module.finrank K L := (IsFractionRing.finrank_eq R K S L).symm + + +variable (k K : Type*) [Field k] [Field K] + +variable [Algebra k K] [Algebra k[X] K] [Algebra k⟮X⟯ K] [IsScalarTower k k[X] K] + [IsScalarTower k[X] k⟮X⟯ K] [_root_.FunctionField k K] + [Algebra.IsSeparable k⟮X⟯ K] + +variable [IsFullConstantField k K] + +/-- Decidable equality on coordinate places for ramification proofs. -/ +local instance instDecidableEqPlaceARam : DecidableEq (PlaceA k K) := Classical.decEq _ +/-- The classical decidable equality on `k(X)` used by the coordinate places. -/ +local instance instDecidableEqRatFuncRam : DecidableEq k⟮X⟯ := Classical.decEq _ + +/-- The uniformizer `t = X⁻¹` in `k(X)`. -/ +noncomputable def tRatFunc : k⟮X⟯ := 1 / RatFunc.X + +/-- `t` as an element of the valuation subring at infinity. -/ +noncomputable def tA : inftyValuationSubring k := + ⟨tRatFunc k, by + rw [Valuation.mem_valuationSubring_iff] + dsimp [tRatFunc] + rw [RatFunc.inftyValuation.X_inv k] + exact WithZero.exp_le_exp.mpr (show (-1 : ℤ) ≤ 0 by omega)⟩ + +@[simp] +theorem tRatFunc_coe : (tA k : k⟮X⟯) = tRatFunc k := rfl + +omit [Algebra k K] [Algebra k[X] K] [IsScalarTower k k[X] K] [IsScalarTower k[X] k⟮X⟯ K] + [_root_.FunctionField k K] [Algebra.IsSeparable k⟮X⟯ K] [IsFullConstantField k K] in +theorem maximalIdeal_infty_eq_span_t : + IsLocalRing.maximalIdeal (inftyValuationSubring k) = + Ideal.span {(tA k : inftyValuationSubring k)} := by + let v := RatFunc.inftyValuation k + have hπval : v (tRatFunc k) = WithZero.exp (-1 : ℤ) := RatFunc.inftyValuation.X_inv k + have hgen : (↑(Valuation.IsRankOneDiscrete.generator v) : WithZero (Multiplicative ℤ)) = + WithZero.exp (-1 : ℤ) := by + have h := Valuation.IsRankOneDiscrete.generator_eq_exp_neg_one_of_mem_range + (v := v) (show WithZero.exp (-1 : ℤ) ∈ Set.range v from ⟨tRatFunc k, hπval⟩) + exact congrArg Units.val h + have hπ : v.IsUniformizer (tA k : k⟮X⟯) := by + rw [Valuation.IsUniformizer.iff, tRatFunc_coe k, hgen] + exact hπval + exact Valuation.IsUniformizer.is_generator hπ + +local notation "inftyRing" => inftyValuationSubring k +local notation "inftyInts" => infiniteIntegers k K +local notation "maxIdealInfty" => IsLocalRing.maximalIdeal (inftyValuationSubring k) + +/-- Ramification index of the infinite place above `k(X)`. -/ +noncomputable def ramIdxInfty (P : Ideal (infiniteIntegers k K)) : ℕ := + Ideal.ramificationIdx' + (IsLocalRing.maximalIdeal (inftyValuationSubring k)) P + +/-- Its image `t_K` in the function field. -/ +noncomputable def tK : K := algebraMap k⟮X⟯ K (tRatFunc k) + +omit [Algebra k K] [Algebra k[X] K] [IsScalarTower k k[X] K] [IsScalarTower k[X] k⟮X⟯ K] + [_root_.FunctionField k K] [Algebra.IsSeparable k⟮X⟯ K] [IsFullConstantField k K] in +theorem map_maximalIdeal_infty : + Ideal.map (algebraMap inftyRing inftyInts) maxIdealInfty = + Ideal.span {algebraMap inftyRing inftyInts (tA k)} := by + rw [maximalIdeal_infty_eq_span_t k, Ideal.map_span, Set.image_singleton] + +omit [Algebra k K] [Algebra k[X] K] [IsScalarTower k k[X] K] [IsScalarTower k[X] k⟮X⟯ K] + [_root_.FunctionField k K] [Algebra.IsSeparable k⟮X⟯ K] [IsFullConstantField k K] in +theorem XK_mul_tK : XK k K * tK k K = 1 := by + dsimp only [XK, tK, tRatFunc] + rw [← map_mul (algebraMap k⟮X⟯ K), div_eq_mul_inv, one_mul, + mul_inv_cancel₀ RatFunc.X_ne_zero, map_one] + +omit [Algebra k K] [IsScalarTower k k[X] K] [_root_.FunctionField k K] + [Algebra.IsSeparable k⟮X⟯ K] [IsFullConstantField k K] in +theorem XK_mem_ringOfIntegers : + ∃ a : ringOfIntegers k K, (a : K) = XK k K := by + have hx : (algebraMap k[X] K (Polynomial.X : k[X])) ∈ ringOfIntegers k K := + (mem_integralClosure_iff (R := k[X]) (A := K)).2 + (isIntegral_algebraMap (x := (Polynomial.X : k[X]))) + refine ⟨⟨algebraMap k[X] K (Polynomial.X : k[X]), hx⟩, ?_⟩ + dsimp [XK] + rw [IsScalarTower.algebraMap_apply k[X] k⟮X⟯ K, RatFunc.algebraMap_X] + +omit [Algebra k K] [Algebra k⟮X⟯ K] [IsScalarTower k k[X] K] [IsScalarTower k[X] k⟮X⟯ K] + [_root_.FunctionField k K] [Algebra.IsSeparable k⟮X⟯ K] [IsFullConstantField k K] in +theorem ringOfIntegers_coe_ne_zero {a : ringOfIntegers k K} (ha : a ≠ 0) : (a : K) ≠ 0 := + fun h => ha ((Subtype.ext_iff).mpr h) + +omit [Algebra k K] [IsScalarTower k k[X] K] [IsFullConstantField k K] in +theorem principalDivisorA_nonneg_at_finite_of_mem_ringOfIntegers {a : ringOfIntegers k K} + (ha : a ≠ 0) (w : IsDedekindDomain.HeightOneSpectrum (ringOfIntegers k K)) : + 0 ≤ principalDivisorA k K + (Additive.ofMul (Units.mk0 (a : K) (ringOfIntegers_coe_ne_zero k K ha))) (Sum.inl w) := by + rw [principalDivisorA_apply_finite, FractionalIdeal.principalDivisor_apply] + have hle := w.valuation_le_one (K := K) a + have hval := FractionalIdeal.valuation_eq_exp_neg_count (R := ringOfIntegers k K) (K := K) w + (Units.mk0 (a : K) (ringOfIntegers_coe_ne_zero k K ha)) + have hcount : + FractionalIdeal.principalDivisor (R := ringOfIntegers k K) (K := K) + (Additive.ofMul (Units.mk0 (a : K) (ringOfIntegers_coe_ne_zero k K ha))) w = + FractionalIdeal.count K w + (FractionalIdeal.spanSingleton (ringOfIntegers k K)⁰ + (Units.mk0 (a : K) (ringOfIntegers_coe_ne_zero k K ha))) := by + rfl + have hnonneg : + 0 ≤ FractionalIdeal.count K w + (FractionalIdeal.spanSingleton (ringOfIntegers k K)⁰ + (Units.mk0 (a : K) (ringOfIntegers_coe_ne_zero k K ha))) := by + let count := + FractionalIdeal.count K w + (FractionalIdeal.spanSingleton (ringOfIntegers k K)⁰ + (Units.mk0 (a : K) (ringOfIntegers_coe_ne_zero k K ha))) + have hle' : -count ≤ 0 := + WithZero.exp_le_exp.mp (by rw [← hval, WithZero.exp_zero]; exact hle) + exact neg_nonpos.mp hle' + simpa [hcount] using hnonneg + +omit [IsFullConstantField k K] in +theorem polarDivisor_XK_zero_at_finite + (w : IsDedekindDomain.HeightOneSpectrum (ringOfIntegers k K)) : + polarDivisor k K (XK k K) (Sum.inl w) = 0 := by + have hx0 : XK k K ≠ 0 := XK_ne_zero k K + obtain ⟨a, ha⟩ := XK_mem_ringOfIntegers k K + have ha0 : a ≠ 0 := fun ha0 => hx0 (by simpa [ha] using congrArg Subtype.val ha0) + have hprincipal : + 0 ≤ principalDivisorA k K (Additive.ofMul (Units.mk0 (XK k K) hx0)) (Sum.inl w) := by + simpa [ha] using + principalDivisorA_nonneg_at_finite_of_mem_ringOfIntegers (k := k) (K := K) ha0 w + unfold polarDivisor + simp only [dite_eq_right hx0, Finsupp.sup_apply] + exact max_eq_right (neg_nonpos.mpr hprincipal) + +omit [Algebra k K] [Algebra k[X] K] [IsScalarTower k k[X] K] [IsScalarTower k[X] k⟮X⟯ K] + [_root_.FunctionField k K] [Algebra.IsSeparable k⟮X⟯ K] [IsFullConstantField k K] in +theorem tK_ne_zero : tK k K ≠ 0 := by + dsimp [tK, tRatFunc] + intro h + rw [← map_zero (algebraMap k⟮X⟯ K)] at h + exact one_div_ne_zero RatFunc.X_ne_zero <| + (RingHom.injective (algebraMap k⟮X⟯ K)).eq_iff.mp h + +omit [Algebra k K] [IsScalarTower k k[X] K] [IsFullConstantField k K] in +theorem principalDivisorA_tK_at_infinite + (v : IsDedekindDomain.HeightOneSpectrum (infiniteIntegers k K)) : + principalDivisorA k K (Additive.ofMul (Units.mk0 (tK k K) (tK_ne_zero k K))) (Sum.inr v) = + (ramIdxInfty k K v.asIdeal : ℤ) := by + rw [principalDivisorA_apply_infinite] + let A := inftyValuationSubring k + let S := infiniteIntegers k K + let tS : S := algebraMap A S (tA k) + have htK : tK k K = algebraMap A K (tA k) := by + dsimp [tK, tA, tRatFunc] + rfl + have hspan : + FractionalIdeal.spanSingleton S⁰ (tK k K) = + (Ideal.span {tS} : FractionalIdeal S⁰ K) := by + rw [htK, IsScalarTower.algebraMap_apply A S K, ← FractionalIdeal.coeIdeal_span_singleton] + have htS : tS ≠ 0 := by + intro h + have hz : tK k K = 0 := by + dsimp [tS] at h + rw [htK, IsScalarTower.algebraMap_apply A S K, h, map_zero] + exact tK_ne_zero k K hz + let p := IsLocalRing.maximalIdeal A + have hinj := ValuationSubring.integralClosure_algebraMap_injective + (v := RatFunc.inftyValuation k) (L := K) + have hpne : p ≠ ⊥ := + Ring.ne_bot_of_isMaximal_of_not_isField (IsLocalRing.maximalIdeal.isMaximal A) + (IsDiscreteValuationRing.not_isField A) + have hmap : Ideal.map (algebraMap A S) p ≠ ⊥ := by + rintro hbot + exact hpne ((Ideal.map_eq_bot_iff_of_injective hinj).mp hbot) + have hcount : + FractionalIdeal.principalDivisor (R := S) (K := K) + (Additive.ofMul (Units.mk0 (tK k K) (tK_ne_zero k K))) v = + (UniqueFactorizationMonoid.normalizedFactors (Ideal.map (algebraMap A S) p)).count + v.asIdeal := by + rw [FractionalIdeal.principalDivisor_apply, toMul_ofMul, Units.val_mk0, hspan, + FractionalIdeal.count_coe (K := K) v (Ideal.span_singleton_eq_bot.not.mpr htS), + ← map_maximalIdeal_infty k] + rw [Ideal.count_associates_factors_eq hmap v.isPrime v.ne_bot] + rw [hcount, ← IsDedekindDomain.ramificationIdx'_eq_normalizedFactors_count hmap v.isPrime + v.ne_bot, ramIdxInfty] + +omit [IsFullConstantField k K] in +theorem principalDivisorA_XK_at_infinite + (v : IsDedekindDomain.HeightOneSpectrum (infiniteIntegers k K)) : + principalDivisorA k K (Additive.ofMul (Units.mk0 (XK k K) (XK_ne_zero k K))) (Sum.inr v) = + -(ramIdxInfty k K v.asIdeal : ℤ) := by + have hx0 : XK k K ≠ 0 := XK_ne_zero k K + have ht0 : tK k K ≠ 0 := tK_ne_zero k K + let hunit : Kˣ := Units.mk0 (XK k K * tK k K) (by rw [XK_mul_tK k K]; exact one_ne_zero) + have hmul : hunit = Units.mk0 (XK k K) hx0 * Units.mk0 (tK k K) ht0 := by + apply Units.ext + simp [hunit, Units.val_mul, Units.val_mk0, XK_mul_tK k K] + have hprod : + principalDivisorA k K (Additive.ofMul hunit) = + principalDivisorA k K (Additive.ofMul (Units.mk0 (XK k K) hx0)) + + principalDivisorA k K (Additive.ofMul (Units.mk0 (tK k K) ht0)) := by + rw [show Additive.ofMul hunit = + Additive.ofMul (Units.mk0 (XK k K) hx0 * Units.mk0 (tK k K) ht0) from congr_arg _ hmul, + ofMul_mul, (principalDivisorA k K).map_add] + have hone : principalDivisorA k K (Additive.ofMul hunit) = 0 := by + ext w + simp only [Finsupp.zero_apply] + have hv := placeValuation_eq_exp_neg_principalDivisor k K (Additive.ofMul hunit) w + have hval' : placeValuation k K w ↑(Additive.toMul (Additive.ofMul hunit)) = 1 := by + rw [toMul_ofMul, show (↑hunit : K) = 1 by simp [hunit, XK_mul_tK k K]] + rcases w with w | w <;> simp [placeValuation] + have hexp : + WithZero.exp (-((principalDivisorA k K) (Additive.ofMul hunit)) w) = WithZero.exp 0 := + (hv.symm.trans hval').trans WithZero.exp_zero.symm + exact neg_eq_zero.mp (WithZero.exp_injective hexp) + have hzero : + principalDivisorA k K (Additive.ofMul (Units.mk0 (XK k K) hx0)) (Sum.inr v) + + principalDivisorA k K (Additive.ofMul (Units.mk0 (tK k K) ht0)) (Sum.inr v) = 0 := by + have := congrArg (fun D => D (Sum.inr v)) hone + rwa [hprod] at this + rw [principalDivisorA_tK_at_infinite k K v] at hzero + linarith + +omit [Algebra k K] [Algebra k[X] K] [IsScalarTower k k[X] K] [IsScalarTower k[X] k⟮X⟯ K] + [IsFullConstantField k K] in +theorem ramificationIdx_pos_over_infty + (v : IsDedekindDomain.HeightOneSpectrum (infiniteIntegers k K)) : + 0 < ramIdxInfty k K v.asIdeal := by + let A := inftyValuationSubring k + let p := IsLocalRing.maximalIdeal A + have hpne : p ≠ ⊥ := + Ring.ne_bot_of_isMaximal_of_not_isField (IsLocalRing.maximalIdeal.isMaximal A) + (IsDiscreteValuationRing.not_isField A) + have hPp : v.asIdeal.LiesOver p := ⟨(IsLocalRing.eq_maximalIdeal inferInstance).symm⟩ + exact Nat.cast_pos.mpr <| + Nat.pos_iff_ne_zero.mpr <| + IsDedekindDomain.ramificationIdx'_ne_zero_of_liesOver (S := infiniteIntegers k K) + v.asIdeal hpne + +omit [IsFullConstantField k K] in +theorem polarDivisor_XK_at_infinite + (v : IsDedekindDomain.HeightOneSpectrum (infiniteIntegers k K)) : + polarDivisor k K (XK k K) (Sum.inr v) = ramIdxInfty k K v.asIdeal := by + have hx0 : XK k K ≠ 0 := XK_ne_zero k K + have hprincipal := principalDivisorA_XK_at_infinite (k := k) (K := K) v + have hpos : 0 < (ramIdxInfty k K v.asIdeal : ℤ) := + Nat.cast_pos.mpr (ramificationIdx_pos_over_infty (k := k) (K := K) v) + have hneg : + (-principalDivisorA k K (Additive.ofMul (Units.mk0 (XK k K) hx0))) (Sum.inr v) = + (ramIdxInfty k K v.asIdeal : ℤ) := by + simpa using congrArg Neg.neg hprincipal + unfold polarDivisor + simp only [dite_eq_right hx0, Finsupp.sup_apply, hneg] + exact max_eq_left (le_of_lt hpos) + +/-- The height-one ideal above `∞` corresponding to an infinite place. -/ +noncomputable def inftyIdealOfPlace (v : PlaceA k K) : Ideal (infiniteIntegers k K) := + match v with + | Sum.inr w => w.asIdeal + | Sum.inl _ => ⊥ + +omit [IsFullConstantField k K] in +theorem deg_polarDivisor_XK_eq_primesOverFinset_sum : + deg k K (polarDivisor k K (XK k K)) = + ∑ P ∈ IsDedekindDomain.primesOverFinset + (IsLocalRing.maximalIdeal (inftyValuationSubring k)) (infiniteIntegers k K), + (ramIdxInfty k K P : ℤ) * + (P.inertiaDeg (inftyValuationSubring k) : ℤ) := by + classical + rw [deg, Finsupp.sum] + let A := inftyValuationSubring k + let S := infiniteIntegers k K + let p := IsLocalRing.maximalIdeal A + let D := polarDivisor k K (XK k K) + have hp : p ≠ ⊥ := + Ring.ne_bot_of_isMaximal_of_not_isField (IsLocalRing.maximalIdeal.isMaximal A) + (IsDiscreteValuationRing.not_isField A) + let pred : PlaceA k K → Prop := fun v => match v with | Sum.inr _ => true | _ => false + let g : PlaceA k K → ℤ := fun v => (D v : ℤ) * (placeDegree k K v : ℤ) + have hsum_filter : + D.support.sum g = + (D.support.filter pred).sum g := + Eq.symm <| + Finset.sum_subset (Finset.filter_subset pred D.support) fun v hv hv' => by + rcases v with v | v + · rw [polarDivisor_XK_zero_at_finite, zero_mul] + · exfalso + simp only [Finset.mem_filter, pred] at hv' + exact hv' ⟨hv, by simp⟩ + rw [hsum_filter] + apply Finset.sum_bij (fun v _ => inftyIdealOfPlace (k := k) (K := K) v) + · intro v hv + simp only [Finset.mem_filter, pred] at hv + obtain ⟨_, hright⟩ := hv + rcases v with v | w + · cases hright + · rw [IsDedekindDomain.mem_primesOverFinset_iff hp] + have hpw : p = w.asIdeal.under A := + (IsLocalRing.eq_maximalIdeal (Ideal.IsMaximal.under A w.asIdeal)).symm + exact ⟨w.isPrime, ⟨hpw⟩⟩ + · intro v₁ hv₁ v₂ hv₂ h + simp only [Finset.mem_filter, pred] at hv₁ hv₂ ⊢ + match v₁ with + | Sum.inl _ => simp at hv₁ + | Sum.inr w₁ => + match v₂ with + | Sum.inl _ => simp at hv₂ + | Sum.inr w₂ => + simp only [inftyIdealOfPlace] at h + exact congrArg Sum.inr (IsDedekindDomain.HeightOneSpectrum.ext h) + · intro P hP + have hmem := (IsDedekindDomain.mem_primesOverFinset_iff hp (P := P)).mp hP + have hprime : P.IsPrime := hmem.1 + have hbot : P ≠ ⊥ := Ideal.ne_bot_of_mem_primesOver hp hmem + let w : IsDedekindDomain.HeightOneSpectrum S := ⟨P, hprime, hbot⟩ + refine ⟨Sum.inr w, ?_, rfl⟩ + · simp only [Finset.mem_filter, pred, Finsupp.mem_support_iff] + refine And.intro ?_ (by simp) + rw [polarDivisor_XK_at_infinite] + norm_cast + exact (ramificationIdx_pos_over_infty k K w).ne' + · intro v hv + simp only [Finset.mem_filter, pred, inftyIdealOfPlace] at hv ⊢ + rcases v with v | v + · simp at hv + · rw [polarDivisor_XK_at_infinite k K v, ramIdxInfty, + placeDegree_infinite_eq_inertiaDeg] + +omit [IsFullConstantField k K] in +/-- Stichtenoth 1.4.11 ramification half for the chart variable: `deg (X_K)_∞ ≤ [K : k(X)]`. -/ +theorem deg_polarX_le_finrank : + deg k K (polarDivisor k K (XK k K)) ≤ Module.finrank k⟮X⟯ K := by + rw [deg_polarDivisor_XK_eq_primesOverFinset_sum k K] + let A := inftyValuationSubring k + let S := infiniteIntegers k K + let p := IsLocalRing.maximalIdeal A + have hp : p ≠ ⊥ := + Ring.ne_bot_of_isMaximal_of_not_isField (IsLocalRing.maximalIdeal.isMaximal A) + (IsDiscreteValuationRing.not_isField A) + let : p.IsMaximal := IsLocalRing.maximalIdeal.isMaximal A + have hsum := ramificationSum_eq_fractionField_finrank A S k⟮X⟯ K p hp + have heq : + (∑ P ∈ IsDedekindDomain.primesOverFinset p S, + (ramIdxInfty k K P : ℤ) * (P.inertiaDeg A : ℤ)) = + Module.finrank k⟮X⟯ K := by + dsimp [ramIdxInfty] + exact_mod_cast hsum + exact le_of_eq heq + +end FunctionField.Chart + +end diff --git a/LeanPool/MarkoffModP/RiemannRoch/LinearKneser.lean b/LeanPool/MarkoffModP/RiemannRoch/LinearKneser.lean new file mode 100644 index 0000000000..40e3ea535a --- /dev/null +++ b/LeanPool/MarkoffModP/RiemannRoch/LinearKneser.lean @@ -0,0 +1,229 @@ +/- +Copyright (c) 2026 Guanghao Li. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Guanghao Li +-/ + +module + +public import LeanPool.MarkoffModP.RiemannRoch.Basic +public import Mathlib.Algebra.Algebra.Operations +public import Mathlib.LinearAlgebra.FiniteDimensional.Lemmas +public import Mathlib.RingTheory.Finiteness.Subalgebra +public import Mathlib.RingTheory.IntegralClosure.Algebra.Basic + +/-! +# A linear Cauchy–Davenport bound over a full constant field + +This file proves the specialization of the Hou–Leung–Xiang linear Kneser theorem needed for +Clifford's theorem. If every element of `K` algebraic over `k` is constant, then nonzero finite +dimensional `k`-subspaces `A, B ⊆ K` satisfy + +`finrank A + finrank B ≤ finrank (A * B) + 1`. + +The proof is the Dyson e-transform induction from Hou–Leung–Xiang. The full-constant-field +hypothesis makes the stabilizer-field step direct and avoids a separate finite/infinite base-field +split. +-/ + +@[expose] public section + +open scoped Pointwise + +namespace FunctionField + +variable (k K : Type*) [Field k] [Field K] [Algebra k K] + [IsFullConstantField k K] + +/-- If a finite-dimensional subspace `A` containing `1` has dimension bigger than one, some +nonzero `e ∈ B` makes the Dyson intersection `A ∩ B e⁻¹` proper. -/ +theorem exists_dyson_step (A B : Submodule k K) + [FiniteDimensional k A] [FiniteDimensional k B] + (hA1 : (1 : K) ∈ A) (hB1 : (1 : K) ∈ B) (hAdim : 1 < Module.finrank k A) : + ∃ e : K, e ∈ B ∧ e ≠ 0 ∧ + A ⊓ Submodule.comap (LinearMap.mulRight k e) B ≠ A := by + by_contra! h + have hstable : ∀ a ∈ A, ∀ b ∈ B, a * b ∈ B := by + intro a ha b hb + by_cases hb0 : b = 0 + · subst b + simp + · have heq := h b hb hb0 + have hamem : a ∈ A ⊓ Submodule.comap (LinearMap.mulRight k b) B := heq.symm ▸ ha + exact hamem.2 + have hBne : B ≠ ⊥ := by + rw [Submodule.ne_bot_iff] + exact ⟨1, hB1, one_ne_zero⟩ + have hBfg : B.FG := (Submodule.fg_top B).mp Module.Finite.fg_top + have hAle : A ≤ (1 : Submodule k K) := by + intro a ha + have haint : IsIntegral k a := isIntegral_of_smul_mem_submodule B hBne hBfg a (by + intro b hb + simpa only [smul_eq_mul] using hstable a ha b hb) + obtain ⟨c, hc⟩ := IsFullConstantField.algebraic_mem (k := k) (K := K) a haint.isAlgebraic + rw [Submodule.one_eq_span, Submodule.mem_span_singleton] + refine ⟨c, ?_⟩ + simpa only [Algebra.smul_def, mul_one] using hc.symm + have hAeq : A = 1 := le_antisymm hAle (Submodule.one_le.mpr hA1) + have hdim : Module.finrank k A = 1 := by + rw [hAeq, Submodule.one_eq_span, finrank_span_singleton one_ne_zero] + omega + +/-- One Dyson e-transform preserves the sum of dimensions, strictly decreases the first +subspace, and does not enlarge the product space. -/ +theorem dyson_step (A B : Submodule k K) + [FiniteDimensional k A] [FiniteDimensional k B] + (hA1 : (1 : K) ∈ A) (hB1 : (1 : K) ∈ B) (hAdim : 1 < Module.finrank k A) : + ∃ A' B' : Submodule k K, + (1 : K) ∈ A' ∧ (1 : K) ∈ B' ∧ A' < A ∧ + A'.FG ∧ B'.FG ∧ + Module.finrank k A' + Module.finrank k B' = + Module.finrank k A + Module.finrank k B ∧ A' * B' ≤ A * B := by + obtain ⟨e, heB, he0, hproper⟩ := exists_dyson_step k K A B hA1 hB1 hAdim + let u : Kˣ := Units.mk0 e he0 + let ε : K ≃ₗ[k] K := u.mulRightLinearEquiv k + let A' := A ⊓ Submodule.comap (ε : K →ₗ[k] K) B + let B' := Submodule.map (ε : K →ₗ[k] K) A ⊔ B + refine ⟨A', B', ?_, ?_, ?_, ?_, ?_, ?_, ?_⟩ + · refine ⟨hA1, ?_⟩ + change ε 1 ∈ B + simpa [ε, u] using heB + · exact (show B ≤ Submodule.map (ε : K →ₗ[k] K) A ⊔ B from le_sup_right) hB1 + · exact lt_of_le_of_ne inf_le_left hproper + · exact (Submodule.fg_top A').mp Module.Finite.fg_top + · have hAfg : A.FG := (Submodule.fg_top A).mp Module.Finite.fg_top + have hBfg : B.FG := (Submodule.fg_top B).mp Module.Finite.fg_top + exact (hAfg.map (ε : K →ₗ[k] K)).sup hBfg + · have hmapA' : Submodule.map (ε : K →ₗ[k] K) A' = + Submodule.map (ε : K →ₗ[k] K) A ⊓ B := by + ext x + simp only [A', Submodule.mem_map_equiv, Submodule.mem_inf, Submodule.mem_comap, + LinearEquiv.coe_coe] + rw [ε.apply_symm_apply] + have hfinA' : Module.finrank k A' = + Module.finrank k ↑(Submodule.map (ε : K →ₗ[k] K) A ⊓ B) := by + rw [← hmapA', LinearEquiv.finrank_map_eq] + have hdim := Submodule.finrank_sup_add_finrank_inf_eq + (Submodule.map (ε : K →ₗ[k] K) A) B + have hfinA := LinearEquiv.finrank_map_eq ε A + have hdim' : Module.finrank k B' + + Module.finrank k ↑(Submodule.map (ε : K →ₗ[k] K) A ⊓ B) = + Module.finrank k ↑(Submodule.map (ε : K →ₗ[k] K) A) + + Module.finrank k B := by + simpa only [B'] using hdim + omega + · dsimp only [B'] + rw [Submodule.mul_sup] + apply sup_le + · apply Submodule.mul_le.mpr + intro a ha b hb + rw [Submodule.mem_map] at hb + obtain ⟨b₀, hb₀, rfl⟩ := hb + have hae : a * e ∈ B := ha.2 + have hmem := Submodule.mul_mem_mul hb₀ hae + change a * ε b₀ ∈ A * B + rw [show a * ε b₀ = b₀ * (a * e) by simp [ε, u]; ring] + exact hmem + · apply Submodule.mul_le.mpr + intro a ha b hb + change a ∈ A ⊓ Submodule.comap (ε : K →ₗ[k] K) B at ha + exact Submodule.mul_mem_mul ha.1 hb + +/-- The normalized linear Cauchy–Davenport bound, for subspaces containing `1`. -/ +theorem normalized_mul_finrank (A B : Submodule k K) + [FiniteDimensional k A] [FiniteDimensional k B] + (hA1 : (1 : K) ∈ A) (hB1 : (1 : K) ∈ B) : + Module.finrank k A + Module.finrank k B ≤ Module.finrank k (A * B) + 1 := by + generalize hn : Module.finrank k A = n + induction n using Nat.strong_induction_on generalizing A B with + | h n ih => + have hnpos : 0 < n := by + rw [← hn, Module.finrank_pos_iff] + exact ⟨⟨1, hA1⟩, 0, by simp⟩ + by_cases hn1 : n = 1 + · have hAeq : A = 1 := by + have hle : (1 : Submodule k K) ≤ A := Submodule.one_le.mpr hA1 + exact (Submodule.eq_of_le_of_finrank_eq hle (by + rw [Submodule.one_eq_span, finrank_span_singleton one_ne_zero, hn, hn1])).symm + subst A + rw [hn1] + change 1 + Module.finrank k B ≤ + Module.finrank k ↑((1 : Submodule k K) • B) + 1 + rw [Submodule.one_smul] + omega + · have hngt : 1 < n := by omega + have hAdim : 1 < Module.finrank k A := hn.symm ▸ hngt + obtain ⟨A', B', hA'1, hB'1, hA'lt, hA'fg, hB'fg, hdim, hprod⟩ := + dyson_step k K A B hA1 hB1 hAdim + let : FiniteDimensional k A' := Module.Finite.of_fg hA'fg + let : FiniteDimensional k B' := Module.Finite.of_fg hB'fg + have hsmall : Module.finrank k A' < n := by + rw [← hn] + exact Submodule.finrank_lt_finrank_of_lt hA'lt + have hih := ih (Module.finrank k A') hsmall A' B' hA'1 hB'1 rfl + have hAfg : A.FG := (Submodule.fg_top A).mp Module.Finite.fg_top + have hBfg : B.FG := (Submodule.fg_top B).mp Module.Finite.fg_top + let : FiniteDimensional k (A * B) := Module.Finite.of_fg (hAfg.mul hBfg) + have hmono : Module.finrank k (A' * B') ≤ Module.finrank k (A * B) := + Submodule.finrank_mono hprod + omega + +/-- **Linear Cauchy–Davenport over a full constant field.** Nonzero finite-dimensional +subspaces of `K` have product dimension at least the sum of their dimensions minus one. -/ +theorem mul_finrank (A B : Submodule k K) + [FiniteDimensional k A] [FiniteDimensional k B] + (hA : A ≠ ⊥) (hB : B ≠ ⊥) : + Module.finrank k A + Module.finrank k B ≤ Module.finrank k (A * B) + 1 := by + rw [Submodule.ne_bot_iff] at hA hB + obtain ⟨a, haA, ha0⟩ := hA + obtain ⟨b, hbB, hb0⟩ := hB + let ua : Kˣ := Units.mk0 a ha0 + let ub : Kˣ := Units.mk0 b hb0 + let εa : K ≃ₗ[k] K := (ua⁻¹).mulLeftLinearEquiv k K + let εb : K ≃ₗ[k] K := (ub⁻¹).mulLeftLinearEquiv k K + let εab : K ≃ₗ[k] K := (ua * ub).mulLeftLinearEquiv k K + let A' := Submodule.map (εa : K →ₗ[k] K) A + let B' := Submodule.map (εb : K →ₗ[k] K) B + have hA'1 : (1 : K) ∈ A' := by + apply Submodule.mem_map.mpr + refine ⟨a, haA, ?_⟩ + change ((ua⁻¹ : Kˣ) : K) * a = 1 + exact inv_mul_cancel₀ ha0 + have hB'1 : (1 : K) ∈ B' := by + apply Submodule.mem_map.mpr + refine ⟨b, hbB, ?_⟩ + change ((ub⁻¹ : Kˣ) : K) * b = 1 + exact inv_mul_cancel₀ hb0 + have hAfin : A'.FG := by + have hAfg : A.FG := (Submodule.fg_top A).mp Module.Finite.fg_top + exact hAfg.map (εa : K →ₗ[k] K) + have hBfin : B'.FG := by + have hBfg : B.FG := (Submodule.fg_top B).mp Module.Finite.fg_top + exact hBfg.map (εb : K →ₗ[k] K) + let : FiniteDimensional k A' := Module.Finite.of_fg hAfin + let : FiniteDimensional k B' := Module.Finite.of_fg hBfin + have hnorm := normalized_mul_finrank k K A' B' hA'1 hB'1 + have hprod : A' * B' ≤ Submodule.comap (εab : K →ₗ[k] K) (A * B) := by + apply Submodule.mul_le.mpr + intro x hx y hy + obtain ⟨x₀, hx₀, rfl⟩ := Submodule.mem_map.mp hx + obtain ⟨y₀, hy₀, rfl⟩ := Submodule.mem_map.mp hy + change ((ua * ub : Kˣ) : K) * + ((((ua⁻¹ : Kˣ) : K) * x₀) * (((ub⁻¹ : Kˣ) : K) * y₀)) ∈ A * B + have hm := Submodule.mul_mem_mul hx₀ hy₀ + simpa [mul_assoc, mul_left_comm, mul_comm] using hm + have hmap : Submodule.map (εab : K →ₗ[k] K) (A' * B') ≤ A * B := + (Submodule.map_le_iff_le_comap).mpr hprod + have hAfg : A.FG := (Submodule.fg_top A).mp Module.Finite.fg_top + have hBfg : B.FG := (Submodule.fg_top B).mp Module.Finite.fg_top + let : FiniteDimensional k (A * B) := Module.Finite.of_fg (hAfg.mul hBfg) + have hmono : Module.finrank k (A' * B') ≤ Module.finrank k (A * B) := by + rw [← LinearEquiv.finrank_map_eq εab (A' * B')] + exact Submodule.finrank_mono hmap + have hfinA : Module.finrank k A' = Module.finrank k A := by + exact LinearEquiv.finrank_map_eq εa A + have hfinB : Module.finrank k B' = Module.finrank k B := by + exact LinearEquiv.finrank_map_eq εb B + omega + +end FunctionField diff --git a/LeanPool/MarkoffModP/RiemannRoch/LocalResidue.lean b/LeanPool/MarkoffModP/RiemannRoch/LocalResidue.lean new file mode 100644 index 0000000000..30f148b4da --- /dev/null +++ b/LeanPool/MarkoffModP/RiemannRoch/LocalResidue.lean @@ -0,0 +1,110 @@ +/- +Copyright (c) 2026 Guanghao Li. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Guanghao Li +-/ + +module + +public import LeanPool.MarkoffModP.RiemannRoch.Basic +public import Mathlib.RingTheory.DedekindDomain.AdicValuation +public import Mathlib.RingTheory.LocalRing.ResidueField.Ideal +public import Mathlib.RingTheory.Localization.Basic + +/-! Local residue maps for height-one primes of Dedekind domains. -/ + +@[expose] public section + +open scoped nonZeroDivisors WithZero + +noncomputable section + +open IsDedekindDomain + +namespace IsDedekindDomain.HeightOneSpectrum + +variable {R K : Type*} [CommRing R] [IsDedekindDomain R] [Field K] + [Algebra R K] [IsFractionRing R K] + +/-- The residue map from the valuation ring at a height-one prime. -/ +noncomputable def residueHom (v : HeightOneSpectrum R) : + valuationSubringAtPrime K v →+* v.asIdeal.ResidueField := + IsLocalization.lift (S := valuationSubringAtPrime K v) + (g := algebraMap R v.asIdeal.ResidueField) + fun y : v.asIdeal.primeCompl => isUnit_iff_ne_zero.mpr <| by + rw [ne_eq, Ideal.algebraMap_residueField_eq_zero] + exact Ideal.mem_primeCompl_iff.mp y.property + +/-- An element has zero residue exactly when its valuation is strictly less than one. -/ +theorem residueHom_eq_zero_iff (v : HeightOneSpectrum R) + (z : valuationSubringAtPrime K v) : + residueHom (K := K) v z = 0 ↔ v.valuation K (z : K) < 1 := by + obtain ⟨n, d, hnd⟩ := IsLocalization.exists_mk'_eq v.asIdeal.primeCompl z + rw [← hnd, residueHom, IsLocalization.lift_mk'] + simp only [mul_eq_zero, Units.ne_zero, or_false] + rw [Ideal.algebraMap_residueField_eq_zero] + rw [← valuation_lt_one_iff_mem (K := K) v] + rw [show (↑(IsLocalization.mk' (valuationSubringAtPrime K v) n d) : K) = + algebraMap R K n / algebraMap R K d by + have hd0 : (d : R) ≠ 0 := by + intro hd + exact (Ideal.mem_primeCompl_iff.mp d.property) (hd ▸ v.asIdeal.zero_mem) + have hdK : algebraMap R K (d : R) ≠ 0 := by + simpa using (FaithfulSMul.algebraMap_injective R K).ne hd0 + apply (eq_div_iff hdK).2 + have h := congrArg (fun y : valuationSubringAtPrime K v => (y : K)) + (IsLocalization.mk'_spec (valuationSubringAtPrime K v) n d) + change (↑(IsLocalization.mk' (valuationSubringAtPrime K v) n d) : K) * + algebraMap R K d = algebraMap R K n at h + exact h] + rw [(v.valuation K).map_div] + have hvd : v.valuation K (algebraMap R K d) = 1 := + (valuation_eq_one_iff_notMem (K := K) (v := v)).2 + (Ideal.mem_primeCompl_iff.mp d.property) + rw [hvd, div_one] + +/-- The localization at a height-one prime is algebra-equivalent to its valuation subring. -/ +noncomputable def localizationAlgEquiv (v : HeightOneSpectrum R) : + Localization.AtPrime v.asIdeal ≃ₐ[R] valuationSubringAtPrime K v := + IsLocalization.algEquiv v.asIdeal.primeCompl (Localization.AtPrime v.asIdeal) + (valuationSubringAtPrime K v) + +/-- `residueHom` on a localized fraction agrees with the quotient map. -/ +theorem residueHom_mk' (v : HeightOneSpectrum R) (n : R) (d : v.asIdeal.primeCompl) : + residueHom (K := K) v (IsLocalization.mk' (valuationSubringAtPrime K v) n d) = + algebraMap R v.asIdeal.ResidueField n * + (algebraMap R v.asIdeal.ResidueField (d : R))⁻¹ := by + dsimp [residueHom] + simp [IsLocalization.lift_mk', IsUnit.coe_liftRight] + +/-- `residueHom` on a localized fraction agrees with the residue map on `AtPrime`. -/ +theorem residueHom_mk'_residue (v : HeightOneSpectrum R) (n : R) (d : v.asIdeal.primeCompl) : + residueHom (K := K) v (IsLocalization.mk' (valuationSubringAtPrime K v) n d) = + IsLocalRing.residue (Localization.AtPrime v.asIdeal) + (IsLocalization.mk' (Localization.AtPrime v.asIdeal) n d) := by + have hd0 : algebraMap R v.asIdeal.ResidueField (d : R) ≠ 0 := + Ideal.algebraMap_residueField_eq_zero.not.mpr (Ideal.mem_primeCompl_iff.mp d.property) + have hdunit : IsUnit (algebraMap R v.asIdeal.ResidueField (d : R)) := + isUnit_iff_ne_zero.mpr hd0 + rw [residueHom_mk', IsLocalRing.residue_def] + have h := congrArg (IsLocalRing.residue (Localization.AtPrime v.asIdeal)) + (IsLocalization.mk'_spec (S := Localization.AtPrime v.asIdeal) n d) + simp only [map_mul, IsLocalRing.residue_def] at h + field_simp [hdunit] + change IsLocalRing.residue (Localization.AtPrime v.asIdeal) + (IsLocalization.mk' (Localization.AtPrime v.asIdeal) n d) * + algebraMap R v.asIdeal.ResidueField (d : R) = + algebraMap R v.asIdeal.ResidueField n at h + rw [mul_comm] at h + exact h.symm + +/-- `residueHom` agrees with the residue map on the localization model. -/ +theorem residueHom_apply_localizationAlgEquiv (v : HeightOneSpectrum R) + (x : Localization.AtPrime v.asIdeal) : + residueHom (K := K) v (localizationAlgEquiv (K := K) v x) = + IsLocalRing.residue (Localization.AtPrime v.asIdeal) x := by + obtain ⟨n, d, hx⟩ := IsLocalization.exists_mk'_eq v.asIdeal.primeCompl x + rw [← hx] + simp [localizationAlgEquiv, residueHom_mk'_residue] + +end IsDedekindDomain.HeightOneSpectrum diff --git a/LeanPool/MarkoffModP/RiemannRoch/Place.lean b/LeanPool/MarkoffModP/RiemannRoch/Place.lean new file mode 100644 index 0000000000..18e40cad1d --- /dev/null +++ b/LeanPool/MarkoffModP/RiemannRoch/Place.lean @@ -0,0 +1,626 @@ +/- +Copyright (c) 2026 Guanghao Li. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Guanghao Li +-/ + +module + +public import LeanPool.MarkoffModP.RiemannRoch.Divisor +public import LeanPool.MarkoffModP.RiemannRoch.SeparableRelNorm +public import Mathlib.NumberTheory.FunctionField +public import Mathlib.RingTheory.Jacobson.Ring +public import Mathlib.RingTheory.LocalRing.ResidueField.Basic +public import Mathlib.RingTheory.Valuation.AlgebraInstances +public import Mathlib.RingTheory.Valuation.Discrete.Basic +public import Mathlib.RingTheory.Valuation.Discrete.RankOne +public import Mathlib.RingTheory.Valuation.IsTrivialOn +public import Mathlib.GroupTheory.ArchimedeanDensely + +/-! +# Coordinate places of a function field + +This file gives the coordinate presentation of the places of a finite separable extension of +`k(X)`. Finite places are the height-one primes of the integral closure of `k[X]`; infinite +places are the height-one primes of the integral closure of the valuation subring at infinity. + +## Main definitions + +* `FunctionField.inftyValuationSubring`: the valuation subring at infinity of `k(X)`. +* `FunctionField.infiniteIntegers`: its integral closure in a function field `K`. +* `FunctionField.PlaceA`: the sum of the finite and infinite height-one spectra. +* `FunctionField.placeValuation`: the valuation of a coordinate place. +* `FunctionField.DivisorA`: divisors in the coordinate presentation. +* `FunctionField.principalDivisorA`: the principal divisor on both coordinate charts. +-/ + +@[expose] public section + +open scoped nonZeroDivisors Polynomial RatFunc WithZero + +noncomputable section + +namespace FractionalIdeal + +variable {R K : Type*} [CommRing R] [IsDedekindDomain R] [Field K] + [Algebra R K] [IsFractionRing R K] + +/-- The multiplicative adic valuation of a nonzero element is the exponential of the negative +coefficient of its principal fractional ideal. -/ +theorem valuation_eq_exp_neg_count (v : IsDedekindDomain.HeightOneSpectrum R) (x : Kˣ) : + v.valuation K (x : K) = + WithZero.exp (-count K v (spanSingleton R⁰ (x : K))) := by + let n : R := Classical.choose (IsLocalization.exists_mk'_eq R⁰ (x : K)) + let d : R⁰ := Classical.choose + (Classical.choose_spec (IsLocalization.exists_mk'_eq R⁰ (x : K))) + have hx : IsLocalization.mk' K n d = (x : K) := + Classical.choose_spec + (Classical.choose_spec (IsLocalization.exists_mk'_eq R⁰ (x : K))) + have hn : n ≠ 0 := by + intro hn + rw [hn, IsLocalization.mk'_zero] at hx + exact x.ne_zero hx.symm + have hI : spanSingleton R⁰ (x : K) = + spanSingleton R⁰ (algebraMap R K (d : R))⁻¹ * + (Ideal.span {n} : Ideal R) := by + rw [← hx, IsFractionRing.mk'_eq_div, div_eq_mul_inv, + coeIdeal_span_singleton, spanSingleton_mul_spanSingleton, mul_comm] + conv_lhs => + rw [← hx, v.valuation_of_mk', v.intValuation_if_neg hn, + v.intValuation_if_neg (nonZeroDivisors.ne_zero d.property)] + rw [count_well_defined K v (spanSingleton_ne_zero_iff.mpr x.ne_zero) hI, + ← WithZero.exp_sub] + congr 1 + ring + +end FractionalIdeal + +namespace RatFunc + +variable {k : Type*} [Field k] + +/-- A rational function regular at infinity has a unique constant residue: after subtracting +the ratio of the leading coefficients of its numerator and denominator, its degree at infinity +is strictly negative (unless the difference is zero). -/ +theorem exists_sub_C_intDegree_neg (z : k⟮X⟯) (hzdeg : z.intDegree ≤ 0) : + ∃ c : k, z - C c = 0 ∨ (z - C c).intDegree < 0 := by + by_cases hz : z = 0 + · exact ⟨0, by simp [hz]⟩ + by_cases hneg : z.intDegree < 0 + · exact ⟨0, Or.inr (by simpa using hneg)⟩ + have hzdeg0 : z.intDegree = 0 := by omega + let c : k := z.num.leadingCoeff / z.denom.leadingCoeff + let p : k[X] := z.num - Polynomial.C c * z.denom + have hrepr : z - C c = + algebraMap k[X] k⟮X⟯ p / algebraMap k[X] k⟮X⟯ z.denom := by + conv_lhs => lhs; rw [← z.num_div_denom] + rw [← RatFunc.algebraMap_C] + simp only [p, map_sub, map_mul] + apply (eq_div_iff (RatFunc.algebraMap_ne_zero z.denom_ne_zero)).2 + rw [sub_mul, div_mul_cancel₀ _ (RatFunc.algebraMap_ne_zero z.denom_ne_zero)] + by_cases hp : p = 0 + · exact ⟨c, Or.inl (by rw [hrepr, hp, map_zero, zero_div])⟩ + refine ⟨c, Or.inr ?_⟩ + have hnumdeg : z.num.natDegree = z.denom.natDegree := by + simp only [RatFunc.intDegree] at hzdeg0 + omega + have hnum0 : z.num ≠ 0 := RatFunc.num_ne_zero hz + have hden0 : z.denom ≠ 0 := z.denom_ne_zero + have hlcnum : z.num.leadingCoeff ≠ 0 := Polynomial.leadingCoeff_ne_zero.mpr hnum0 + have hlcden : z.denom.leadingCoeff ≠ 0 := Polynomial.leadingCoeff_ne_zero.mpr hden0 + have hc : c ≠ 0 := div_ne_zero hlcnum hlcden + have hCmul0 : Polynomial.C c * z.denom ≠ 0 := + mul_ne_zero (Polynomial.C_ne_zero.mpr hc) hden0 + have hdegree : z.num.degree = (Polynomial.C c * z.denom).degree := by + rw [Polynomial.degree_eq_natDegree hnum0, Polynomial.degree_mul, + Polynomial.degree_C hc, zero_add, Polynomial.degree_eq_natDegree hden0, hnumdeg] + have hlc : z.num.leadingCoeff = + (Polynomial.C c * z.denom).leadingCoeff := by + rw [Polynomial.leadingCoeff_mul, Polynomial.leadingCoeff_C] + dsimp only [c] + field_simp + have hpdeg : p.degree < z.num.degree := by + simpa only [p] using Polynomial.degree_sub_lt_left hdegree hnum0 hlc + have hpnat : p.natDegree < z.denom.natDegree := by + rw [Polynomial.natDegree_lt_iff_degree_lt hp] + rw [← hnumdeg] + simpa [Polynomial.degree_eq_natDegree hnum0] using hpdeg + rw [hrepr, RatFunc.intDegree_div] + · simp only [RatFunc.intDegree_polynomial] + omega + · exact RatFunc.algebraMap_ne_zero hp + · exact RatFunc.algebraMap_ne_zero hden0 + +end RatFunc + +namespace FunctionField + +variable (k K : Type*) [Field k] [Field K] + +open MonoidWithZeroHom + +/-- The ordered multiplicative group with zero `ℤᵐ⁰` has no nontrivial ordered monoid +automorphisms. -/ +private noncomputable def withZeroMulIntLogAddEquiv + (e : ℤᵐ⁰ ≃*o ℤᵐ⁰) : ℤ ≃+ ℤ := by + let f : ℤ →+ ℤ := + { toFun := fun z => WithZero.log (e (WithZero.exp z)) + map_zero' := by simp + map_add' := by + intro x y + rw [WithZero.exp_add, map_mul] + rw [WithZero.log_mul] + · simp + · simp } + refine AddEquiv.ofBijective f ?_ + constructor + · intro x y h + apply WithZero.exp_injective + apply e.injective + simpa [f] using congrArg WithZero.exp h + · intro y + refine ⟨WithZero.log (e.symm (WithZero.exp y)), ?_⟩ + dsimp [f] + rw [WithZero.exp_log] + · simp + · simp + +/-- A normalized discrete rank-one value group has a unique order-preserving normalization. -/ +theorem orderMonoidIso_withZeroMulInt_eq_refl (e : ℤᵐ⁰ ≃*o ℤᵐ⁰) : + e = OrderMonoidIso.refl ℤᵐ⁰ := by + have hmono : Monotone (withZeroMulIntLogAddEquiv e) := by + intro x y hxy + dsimp [withZeroMulIntLogAddEquiv] + change WithZero.log (e (WithZero.exp x)) ≤ + WithZero.log (e (WithZero.exp y)) + apply WithZero.exp_le_exp.mp + rw [WithZero.exp_log, WithZero.exp_log] + · exact e.toOrderIso.monotone (WithZero.exp_le_exp.mpr hxy) + · simp + · simp + rcases Int.addEquiv_eq_refl_or_neg (withZeroMulIntLogAddEquiv e) with h | h + · ext x + by_cases hx : x = 0 + · simp [hx] + · rw [← WithZero.exp_log hx] + have ht := DFunLike.congr_fun h (WithZero.log x) + change WithZero.log (e (WithZero.exp (WithZero.log x))) = WithZero.log x at ht + simpa using congrArg WithZero.exp ht + · have hle := hmono (show (0 : ℤ) ≤ 1 by omega) + rw [h] at hle + norm_num at hle + +/-- Any two order-preserving normalizations of the same value group are equal. -/ +theorem orderMonoidIso_withZeroMulInt_unique {G : Type*} + [LinearOrderedCommGroupWithZero G] (e f : G ≃*o ℤᵐ⁰) : e = f := by + have h := orderMonoidIso_withZeroMulInt_eq_refl (e.symm.trans f) + ext x + have hx := DFunLike.congr_fun h (e x) + simpa using hx.symm + +/-- A coordinate-free place of `K/k`: a nontrivial valuation subring of `K` containing the +constant field, together with the proposition that its value group admits the discrete rank-one +normalization. The normalization is stored only through `Nonempty`, so a place is determined by +its valuation subring rather than by a choice of uniformizer. -/ +structure Place [Algebra k K] where + /-- The valuation subring underlying the place. -/ + toValuationSubring : ValuationSubring K + /-- A place is nontrivial. -/ + ne_top : toValuationSubring ≠ ⊤ + /-- Constants are integral at every place. -/ + triv_on_k : ∀ c : k, algebraMap k K c ∈ toValuationSubring + /-- The value group is discrete of rank one, expressed without choosing a normalization. -/ + isDiscrete : Nonempty + (ValueGroup₀ (.ofClass toValuationSubring.valuation) ≃*o ℤᵐ⁰) + +namespace Place + +variable {k K : Type*} [Field k] [Field K] [Algebra k K] + +/-- Two places are equal when their valuation subrings are equal. -/ +@[ext] +theorem ext {v w : Place k K} + (h : v.toValuationSubring = w.toValuationSubring) : v = w := by + cases v + cases w + cases h + rfl + +/-- Places inherit the membership coercion of their valuation subrings. -/ +instance : SetLike (Place k K) K where + coe v := v.toValuationSubring + coe_injective := by + intro v w h + exact ext (SetLike.coe_injective h) + +@[simp] +theorem mem_toValuationSubring (v : Place k K) (x : K) : + x ∈ v.toValuationSubring ↔ x ∈ v := Iff.rfl + +/-- A normalization of the value group of a coordinate-free place. -/ +noncomputable def normalization (v : Place k K) : + ValueGroup₀ (.ofClass v.toValuationSubring.valuation) ≃*o ℤᵐ⁰ := + Classical.choice v.isDiscrete + +/-- The normalized `ℤᵐ⁰`-valued valuation associated to a coordinate-free place. -/ +noncomputable def valuation (v : Place k K) : Valuation K ℤᵐ⁰ := + v.toValuationSubring.valuation.restrict.map + v.normalization.toMonoidWithZeroHom v.normalization.toOrderIso.monotone + +/-- The normalized valuation is equivalent to the canonical valuation of the valuation +subring. -/ +theorem valuation_isEquiv_canonical (v : Place k K) : + v.valuation.IsEquiv v.toValuationSubring.valuation := by + exact (Valuation.isEquiv_map_self_of_strictMono + v.normalization.toMonoidWithZeroHom v.normalization.strictMono).trans + v.toValuationSubring.valuation.isEquiv_restrict.symm + +/-- Recovering the valuation subring from the normalized valuation gives the original place. -/ +@[simp] +theorem valuationSubring_valuation (v : Place k K) : + v.valuation.valuationSubring = v.toValuationSubring := by + exact (Valuation.isEquiv_iff_valuationSubring _ _).mp + v.valuation_isEquiv_canonical |>.trans + v.toValuationSubring.valuationSubring_valuation + +/-- The normalized valuation of a place is trivial on the constant field. -/ +instance valuation_isTrivialOn (v : Place k K) : v.valuation.IsTrivialOn k where + eq_one c hc := by + let w := v.toValuationSubring.valuation + have hc_le : w (algebraMap k K c) ≤ 1 := by + rw [v.toValuationSubring.valuation_le_one_iff] + exact v.triv_on_k c + have hc_inv_le : w (algebraMap k K c⁻¹) ≤ 1 := by + rw [v.toValuationSubring.valuation_le_one_iff] + exact v.triv_on_k c⁻¹ + have hmap_ne : w (algebraMap k K c) ≠ 0 := by simp [hc] + have hmap_pos : 0 < w (algebraMap k K c) := zero_lt_iff.mpr hmap_ne + have hinv_le : (w (algebraMap k K c))⁻¹ ≤ 1 := by + simpa only [map_inv₀, map_inv] using hc_inv_le + have hw : w (algebraMap k K c) = 1 := + le_antisymm hc_le ((inv_le_one₀ hmap_pos).1 hinv_le) + exact v.valuation_isEquiv_canonical.eq_one_iff_eq_one.mpr hw + +/-- The normalized valuation of a place is nontrivial. -/ +instance valuation_isNontrivial (v : Place k K) : v.valuation.IsNontrivial := by + have hcanonical : v.toValuationSubring.valuation.IsNontrivial := by + by_contra h + exact v.ne_top (v.toValuationSubring.eq_top_iff.mpr h) + exact Valuation.isNontrivial_of_isEquiv + v.valuation_isEquiv_canonical.symm hcanonical + +/-- The valuation ring itself, viewed as a `k`-algebra. -/ +instance algebraValuationSubring (v : Place k K) : Algebra k v.toValuationSubring := + (algebraMap k K).codRestrict v.toValuationSubring (fun c ↦ v.triv_on_k c) |>.toAlgebra + +/-- The residue field of a coordinate-free place. -/ +abbrev residueField (v : Place k K) := + IsLocalRing.ResidueField v.toValuationSubring + +/-- The intrinsic degree of a place is the dimension of its residue field over `k`. -/ +noncomputable def degree (v : Place k K) : ℕ := + Module.finrank k v.residueField + +end Place + +-- Coordinate-chart infrastructure; the intrinsic API is `FunctionField.Place`. +namespace Chart + +/-- The classical decidable equality used to define the valuation at infinity. -/ +local instance instDecidableEqRatFuncRiemannRoch : DecidableEq k⟮X⟯ := Classical.decEq _ + +/-- The valuation subring at infinity of the rational function field `k(X)`. -/ +abbrev inftyValuationSubring := (RatFunc.inftyValuation k).valuationSubring + +namespace inftyValuationSubring + +instance : IsDedekindDomain (inftyValuationSubring k) := by infer_instance + +instance : Algebra k (inftyValuationSubring k) := + (RatFunc.C.codRestrict (inftyValuationSubring k) fun c => by + rw [Valuation.mem_valuationSubring_iff] + by_cases hc : c = 0 + · simp [hc] + · exact (RatFunc.inftyValuation.C k hc).le).toAlgebra + +local notation "ᵐ∞" => IsLocalRing.maximalIdeal (inftyValuationSubring k) + +/-- The residue field at infinity. -/ +local instance : Field (inftyValuationSubring k ⧸ ᵐ∞) := Ideal.Quotient.field ᵐ∞ + +/-- The residue map at infinity is onto the constant field. -/ +theorem residue_algebraMap_surjective : + Function.Surjective (algebraMap k (inftyValuationSubring k ⧸ ᵐ∞)) := by + intro q + obtain ⟨a, rfl⟩ := Ideal.Quotient.mk_surjective q + let z : k⟮X⟯ := (a : k⟮X⟯) + have hzdeg : z.intDegree ≤ 0 := by + by_cases hz : z = 0 + · simp [hz] + have ha := a.property + rw [Valuation.mem_valuationSubring_iff] at ha + change RatFunc.inftyValuation k z ≤ 1 at ha + have hv : RatFunc.inftyValuation k z = WithZero.exp z.intDegree := + RatFunc.inftyValuation_of_nonzero k hz + rw [hv] at ha + exact WithZero.exp_le_exp.mp (by simpa only [WithZero.exp_zero] using ha) + obtain ⟨c, hc | hc⟩ := RatFunc.exists_sub_C_intDegree_neg z hzdeg + · refine ⟨c, ?_⟩ + apply (Ideal.Quotient.mk_eq_mk_iff_sub_mem _ _).2 + have hzero : algebraMap k (inftyValuationSubring k) c - a = 0 := by + apply Subtype.ext + change RatFunc.C c - z = 0 + rw [show RatFunc.C c - z = -(z - RatFunc.C c) by ring, hc, neg_zero] + rw [hzero] + exact ᵐ∞.zero_mem + · refine ⟨c, ?_⟩ + apply (Ideal.Quotient.mk_eq_mk_iff_sub_mem _ _).2 + have hne : z - RatFunc.C c ≠ 0 := by + intro h + rw [h, RatFunc.intDegree_zero] at hc + omega + have hpos : a - algebraMap k (inftyValuationSubring k) c ∈ ᵐ∞ := by + rw [Valuation.mem_maximalIdeal_iff] + change RatFunc.inftyValuation k (z - RatFunc.C c) < 1 + have hv : RatFunc.inftyValuation k (z - RatFunc.C c) = + WithZero.exp (z - RatFunc.C c).intDegree := + RatFunc.inftyValuation_of_nonzero k hne + rw [hv] + exact WithZero.exp_lt_exp.mpr hc + simpa only [neg_sub] using ᵐ∞.neg_mem hpos + +/-- The residue field of the valuation ring at infinity is canonically the constant field. -/ +noncomputable def residueAlgEquiv : + k ≃ₐ[k] (inftyValuationSubring k ⧸ ᵐ∞) := + AlgEquiv.ofBijective (Algebra.ofId k (inftyValuationSubring k ⧸ ᵐ∞)) + ⟨(Algebra.ofId k (inftyValuationSubring k ⧸ ᵐ∞)).injective, + residue_algebraMap_surjective k⟩ + +instance finiteDimensionalResidueField : + FiniteDimensional k (inftyValuationSubring k ⧸ ᵐ∞) := + (residueAlgEquiv k).toLinearEquiv.finiteDimensional + +@[simp] +theorem finrank_residueField : + Module.finrank k (inftyValuationSubring k ⧸ ᵐ∞) = 1 := by + rw [← (residueAlgEquiv k).toLinearEquiv.finrank_eq] + exact Module.finrank_self k + +end inftyValuationSubring + +variable [Algebra k[X] K] [Algebra k⟮X⟯ K] + [IsScalarTower k[X] k⟮X⟯ K] [FunctionField k K] + [Algebra.IsSeparable k⟮X⟯ K] + +/-- The integral closure in `K` of the valuation subring at infinity of `k(X)`. -/ +abbrev infiniteIntegers := integralClosure (inftyValuationSubring k) K + +namespace infiniteIntegers + +instance isTorsionFreeOverInfinityRing : + Module.IsTorsionFree (inftyValuationSubring k) (infiniteIntegers k K) := + IsIntegralClosure.isTorsionFree (inftyValuationSubring k) K + +instance : IsFractionRing (infiniteIntegers k K) K := + IsIntegralClosure.isFractionRing_of_finite_extension + (inftyValuationSubring k) k⟮X⟯ K (infiniteIntegers k K) + +instance : IsDedekindDomain (infiniteIntegers k K) := + integralClosure.isDedekindDomain (inftyValuationSubring k) k⟮X⟯ K + +instance : Module.Finite (inftyValuationSubring k) (infiniteIntegers k K) := + IsIntegralClosure.finite (inftyValuationSubring k) k⟮X⟯ K (infiniteIntegers k K) + +instance : Algebra k (infiniteIntegers k K) := + ((algebraMap (inftyValuationSubring k) (infiniteIntegers k K)).comp + (algebraMap k (inftyValuationSubring k))).toAlgebra + +instance : IsScalarTower k (inftyValuationSubring k) (infiniteIntegers k K) := + IsScalarTower.of_algebraMap_eq (R := k) (S := inftyValuationSubring k) + (A := infiniteIntegers k K) fun _ => rfl + +end infiniteIntegers + +namespace ringOfIntegers + +instance isTorsionFreeOverPolynomial : + Module.IsTorsionFree k[X] (ringOfIntegers k K) := by + let : FaithfulSMul k[X] K := + (faithfulSMul_iff_algebraMap_injective k[X] K).2 + (FunctionField.algebraMap_injective k K) + exact IsIntegralClosure.isTorsionFree k[X] K + +instance algebraOverConstants : Algebra k (ringOfIntegers k K) := + ((algebraMap k[X] (ringOfIntegers k K)).comp (algebraMap k k[X])).toAlgebra + +instance isScalarTowerConstants : IsScalarTower k k[X] (ringOfIntegers k K) := + IsScalarTower.of_algebraMap_eq fun _ => rfl + +instance finiteTypeOverConstants : Algebra.FiniteType k (ringOfIntegers k K) := + Algebra.FiniteType.trans (S := k[X]) inferInstance inferInstance + +instance moduleFiniteOverPolynomial : Module.Finite k[X] (ringOfIntegers k K) := + IsIntegralClosure.finite k[X] k⟮X⟯ K (ringOfIntegers k K) + +end ringOfIntegers + +/-- Coordinate places of `K`: finite places on the `k[X]` chart and places above infinity. -/ +abbrev PlaceA := + IsDedekindDomain.HeightOneSpectrum (ringOfIntegers k K) ⊕ + IsDedekindDomain.HeightOneSpectrum (infiniteIntegers k K) + +/-- The discrete valuation associated to a coordinate place. -/ +def placeValuation : PlaceA k K → Valuation K ℤᵐ⁰ + | Sum.inl v => v.valuation K + | Sum.inr v => v.valuation K + +/-- Divisors on `K` in the two-chart coordinate presentation. -/ +abbrev DivisorA := PlaceA k K →₀ ℤ + +namespace PlaceA + +/-- The residue field at a finite coordinate place is finite-dimensional over the constant +field. -/ +instance finiteDimensionalResidueFieldFinite + (v : IsDedekindDomain.HeightOneSpectrum (ringOfIntegers k K)) : + FiniteDimensional k (ringOfIntegers k K ⧸ v.asIdeal) := by + let : Field (ringOfIntegers k K ⧸ v.asIdeal) := Ideal.Quotient.field v.asIdeal + exact finite_of_finite_type_of_isJacobsonRing k _ + +/-- The residue field at an infinite coordinate place is finite-dimensional over the constant +field. -/ +instance finiteDimensionalResidueFieldInfinite + (v : IsDedekindDomain.HeightOneSpectrum (infiniteIntegers k K)) : + FiniteDimensional k (infiniteIntegers k K ⧸ v.asIdeal) := by + let A := inftyValuationSubring k + let S := infiniteIntegers k K + let p : Ideal A := v.asIdeal.under A + let : v.asIdeal.IsMaximal := v.isPrime.isMaximal v.ne_bot + let : p.IsMaximal := Ideal.IsMaximal.under A v.asIdeal + let : v.asIdeal.LiesOver p := ⟨rfl⟩ + let : Field (A ⧸ p) := Ideal.Quotient.field p + let : Field (S ⧸ v.asIdeal) := Ideal.Quotient.field v.asIdeal + let : Algebra (A ⧸ p) (S ⧸ v.asIdeal) := + Ideal.Quotient.algebraQuotientOfLEComap (Ideal.over_def v.asIdeal p).ge + have hp : p = IsLocalRing.maximalIdeal A := IsLocalRing.eq_maximalIdeal inferInstance + let : FiniteDimensional k (A ⧸ p) := by + rw [hp] + exact inftyValuationSubring.finiteDimensionalResidueField k + let : FiniteDimensional (A ⧸ p) (S ⧸ v.asIdeal) := inferInstance + let : IsScalarTower k (A ⧸ p) (S ⧸ v.asIdeal) := + IsScalarTower.of_algebraMap_eq fun _ => rfl + exact FiniteDimensional.trans k (A ⧸ p) (S ⧸ v.asIdeal) + +/-- The degree of a finite coordinate place over the constant field. -/ +noncomputable def finiteDegree + (v : IsDedekindDomain.HeightOneSpectrum (ringOfIntegers k K)) : ℕ := + Module.finrank k (ringOfIntegers k K ⧸ v.asIdeal) + +end PlaceA + +/-- The principal divisor of a nonzero function, combining its finite and infinite parts. -/ +noncomputable def principalDivisorA : Additive Kˣ →+ DivisorA k K := + (Finsupp.mapDomain.addMonoidHom Sum.inl).comp + (FractionalIdeal.principalDivisor (R := ringOfIntegers k K) (K := K)) + + (Finsupp.mapDomain.addMonoidHom Sum.inr).comp + (FractionalIdeal.principalDivisor (R := infiniteIntegers k K) (K := K)) + +@[simp] +theorem principalDivisorA_apply_finite (x : Additive Kˣ) + (v : IsDedekindDomain.HeightOneSpectrum (ringOfIntegers k K)) : + principalDivisorA k K x (Sum.inl v) = + FractionalIdeal.principalDivisor (R := ringOfIntegers k K) (K := K) x v := by + simp only [principalDivisorA, AddMonoidHom.add_apply, AddMonoidHom.coe_comp, + Function.comp_apply] + change Finsupp.mapDomain Sum.inl + (FractionalIdeal.principalDivisor (R := ringOfIntegers k K) (K := K) x) (Sum.inl v) + + Finsupp.mapDomain Sum.inr + (FractionalIdeal.principalDivisor (R := infiniteIntegers k K) (K := K) x) + (Sum.inl v) = _ + rw [Finsupp.mapDomain_apply_of_injective Sum.inl_injective] + rw [Finsupp.mapDomain_of_notMem_range] + · simp + · rintro ⟨w, h⟩ + cases h + +@[simp] +theorem principalDivisorA_apply_infinite (x : Additive Kˣ) + (v : IsDedekindDomain.HeightOneSpectrum (infiniteIntegers k K)) : + principalDivisorA k K x (Sum.inr v) = + FractionalIdeal.principalDivisor (R := infiniteIntegers k K) (K := K) x v := by + simp only [principalDivisorA, AddMonoidHom.add_apply, AddMonoidHom.coe_comp, + Function.comp_apply] + change Finsupp.mapDomain Sum.inl + (FractionalIdeal.principalDivisor (R := ringOfIntegers k K) (K := K) x) (Sum.inr v) + + Finsupp.mapDomain Sum.inr + (FractionalIdeal.principalDivisor (R := infiniteIntegers k K) (K := K) x) + (Sum.inr v) = _ + rw [Finsupp.mapDomain_apply_of_injective Sum.inr_injective] + rw [Finsupp.mapDomain_of_notMem_range] + · simp + · rintro ⟨w, h⟩ + cases h + +/-- A principal-divisor coefficient is the negative logarithm of the corresponding valuation. -/ +theorem placeValuation_eq_exp_neg_principalDivisor (x : Additive Kˣ) (v : PlaceA k K) : + placeValuation k K v (x.toMul : K) = + WithZero.exp (-(principalDivisorA k K x v)) := by + rcases v with v | v + · rw [principalDivisorA_apply_finite, FractionalIdeal.principalDivisor_apply] + exact FractionalIdeal.valuation_eq_exp_neg_count v x.toMul + · rw [principalDivisorA_apply_infinite, FractionalIdeal.principalDivisor_apply] + exact FractionalIdeal.valuation_eq_exp_neg_count v x.toMul + +section ConstantField + +variable [Algebra k K] [IsScalarTower k k[X] K] + +instance ringOfIntegers.isScalarTowerConstantsFractions : + IsScalarTower k (ringOfIntegers k K) K := + IsScalarTower.of_algebraMap_eq fun c => by + rw [IsScalarTower.algebraMap_apply k k[X] K, + IsScalarTower.algebraMap_apply k[X] (ringOfIntegers k K) K, + ← IsScalarTower.algebraMap_apply k k[X] (ringOfIntegers k K)] + +instance infiniteIntegers.isScalarTowerConstantsFractions : + IsScalarTower k (infiniteIntegers k K) K := + IsScalarTower.of_algebraMap_eq fun c => by + have h₁ : algebraMap k (infiniteIntegers k K) c = + algebraMap (inftyValuationSubring k) (infiniteIntegers k K) + (algebraMap k (inftyValuationSubring k) c) := rfl + have h₂ : algebraMap (inftyValuationSubring k) k⟮X⟯ + (algebraMap k (inftyValuationSubring k) c) = RatFunc.C c := rfl + rw [h₁, ← IsScalarTower.algebraMap_apply (inftyValuationSubring k) (infiniteIntegers k K) K, + IsScalarTower.algebraMap_apply (inftyValuationSubring k) k⟮X⟯ K, h₂, + IsScalarTower.algebraMap_apply k k[X] K, + IsScalarTower.algebraMap_apply k[X] k⟮X⟯ K, Polynomial.algebraMap_eq, + RatFunc.algebraMap_C] + +/-- Constants have valuation at most one at every coordinate place. -/ +theorem placeValuation_algebraMap_le_one (v : PlaceA k K) (c : k) : + placeValuation k K v (algebraMap k K c) ≤ 1 := by + obtain w | w := v + · change w.valuation K (algebraMap k K c) ≤ 1 + rw [IsScalarTower.algebraMap_apply k (ringOfIntegers k K) K] + exact w.valuation_le_one _ + · change w.valuation K (algebraMap k K c) ≤ 1 + rw [IsScalarTower.algebraMap_apply k (infiniteIntegers k K) K] + exact w.valuation_le_one _ + +/-- A nonzero constant has trivial valuation at every coordinate place. -/ +theorem placeValuation_algebraMap_eq_one (v : PlaceA k K) (c : kˣ) : + placeValuation k K v (algebraMap k K (c : k)) = 1 := by + have hc_le := placeValuation_algebraMap_le_one k K v (c : k) + have hc_inv_le := placeValuation_algebraMap_le_one k K v ((c⁻¹ : kˣ) : k) + have hmap_ne : placeValuation k K v (algebraMap k K (c : k)) ≠ 0 := by + rw [map_ne_zero] + exact (map_ne_zero (algebraMap k K)).2 c.ne_zero + have hmap_pos : 0 < placeValuation k K v (algebraMap k K (c : k)) := + WithZero.pos_iff_ne_zero.2 hmap_ne + have hinv_le : (placeValuation k K v (algebraMap k K (c : k)))⁻¹ ≤ 1 := by + simpa using hc_inv_le + exact le_antisymm hc_le ((inv_le_one₀ hmap_pos).1 hinv_le) + +/-- Multiplying by a nonzero constant does not change a principal divisor. -/ +@[simp] +theorem principalDivisorA_algebraMap (c : kˣ) : + principalDivisorA k K + (Additive.ofMul (Units.map (algebraMap k K) c)) = 0 := by + ext v + simp only [Finsupp.zero_apply] + have hv := placeValuation_eq_exp_neg_principalDivisor k K + (Additive.ofMul (Units.map (algebraMap k K) c)) v + change placeValuation k K v (algebraMap k K (c : k)) = _ at hv + rw [placeValuation_algebraMap_eq_one k K v c] at hv + have hexp : WithZero.exp (0 : ℤ) = + WithZero.exp + (-(principalDivisorA k K + (Additive.ofMul (Units.map (algebraMap k K) c)) v)) := by + simpa using hv + exact neg_eq_zero.mp (WithZero.exp_injective hexp.symm) + +end ConstantField + +end Chart + +end FunctionField diff --git a/LeanPool/MarkoffModP/RiemannRoch/PlaceEquiv.lean b/LeanPool/MarkoffModP/RiemannRoch/PlaceEquiv.lean new file mode 100644 index 0000000000..a52ddbebb4 --- /dev/null +++ b/LeanPool/MarkoffModP/RiemannRoch/PlaceEquiv.lean @@ -0,0 +1,467 @@ +/- +Copyright (c) 2026 Guanghao Li. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Guanghao Li +-/ + +module + +public import LeanPool.MarkoffModP.RiemannRoch.Place +import Mathlib.NumberTheory.RatFunc.Ostrowski +import Mathlib.NumberTheory.RamificationInertia.Valuation +import Mathlib.RingTheory.Valuation.Discrete.RankOne +import Mathlib.RingTheory.Valuation.Discrete.IsDiscreteValuationRing +import Mathlib.RingTheory.Valuation.LocalSubring + +/-! +# Coordinate-free places and the two-chart presentation + +This file proves that the intrinsic valuation-subring places of a one-dimensional function field +are equivalent to the finite/infinite two-chart presentation. The proof restricts a place to +`k(X)`, applies Ostrowski's theorem, and recovers the unique height-one centre in the appropriate +integral closure. + +## Main definitions + +* `FunctionField.Place.ofChart`: regard a coordinate place as an intrinsic place. +* `FunctionField.Place.toChart`: recover a coordinate chart from an intrinsic place. +* `FunctionField.chartToPlace`: the equivalence between the two presentations. +* `FunctionField.placeValuation_isEquiv`: compatibility of normalized valuations. +-/ + +@[expose] public section + +open scoped nonZeroDivisors Polynomial RatFunc WithZero + +noncomputable section + +namespace FunctionField + +open MonoidWithZeroHom +open Chart + +variable (k K : Type*) [Field k] [Field K] + [Algebra k K] [Algebra k[X] K] [Algebra k⟮X⟯ K] + [IsScalarTower k k[X] K] [IsScalarTower k[X] k⟮X⟯ K] [FunctionField k K] + [Algebra.IsSeparable k⟮X⟯ K] + +/-- Classical decidable equality for the rational function field used by Ostrowski. -/ +local instance instDecidableEqRatFuncPlaceEquiv : DecidableEq k⟮X⟯ := Classical.decEq _ + +/-- A coordinate place, regarded as an intrinsic valuation subring. -/ +noncomputable def Place.ofChart (w : PlaceA k K) : Place k K := by + let q := placeValuation k K w + let V := q.valuationSubring + have hqdisc : q.IsRankOneDiscrete := by + rcases w with w | w <;> dsimp [q, placeValuation] <;> infer_instance + have hqnontrivial : q.IsNontrivial := by + rcases w with w | w <;> dsimp [q, placeValuation] <;> infer_instance + refine + { toValuationSubring := V + ne_top := by + change q.valuationSubring ≠ ⊤ + intro htop + exact (Valuation.valuationSubring_eq_top_iff q).mp htop hqnontrivial + triv_on_k := fun c => by + rw [Valuation.mem_valuationSubring_iff] + exact placeValuation_algebraMap_le_one k K w c + isDiscrete := ?_ } + let : q.IsRankOneDiscrete := hqdisc + let h := Valuation.isEquiv_valuation_valuationSubring q + exact ⟨h.orderMonoidIso.symm.trans + (Valuation.IsRankOneDiscrete.valueGroup₀_equiv_withZeroMulInt q)⟩ + +@[simp] +theorem Place.ofChart_toValuationSubring (w : PlaceA k K) : + (Place.ofChart k K w).toValuationSubring = + (placeValuation k K w).valuationSubring := rfl + +theorem Place.ofChart_valuation_isEquiv (w : PlaceA k K) : + (placeValuation k K w).IsEquiv (Place.ofChart k K w).valuation := by + rw [Valuation.isEquiv_iff_valuationSubring, + Place.valuationSubring_valuation, Place.ofChart_toValuationSubring] + +/-- The normalized intrinsic valuation attached to a coordinate place is exactly its coordinate +valuation. This strengthens equivalence by using uniqueness of the ordered `ℤᵐ⁰` +normalization. -/ +theorem Place.ofChart_valuation_eq (w : PlaceA k K) : + (Place.ofChart k K w).valuation = placeValuation k K w := by + let q := placeValuation k K w + let V := q.valuationSubring + have hqdisc : q.IsRankOneDiscrete := by + rcases w with w | w <;> dsimp [q, placeValuation] <;> infer_instance + let : q.IsRankOneDiscrete := hqdisc + let h := Valuation.isEquiv_valuation_valuationSubring q + let e : ValueGroup₀ (.ofClass V.valuation) ≃*o ℤᵐ⁰ := + h.orderMonoidIso.symm.trans + (Valuation.IsRankOneDiscrete.valueGroup₀_equiv_withZeroMulInt q) + have hnorm : (Place.ofChart k K w).normalization = e := + orderMonoidIso_withZeroMulInt_unique _ _ + ext x + change (Place.ofChart k K w).normalization + (V.valuation.restrict x) = q x + rw [hnorm] + change (Valuation.IsRankOneDiscrete.valueGroup₀_equiv_withZeroMulInt q) + (h.orderMonoidIso.symm (V.valuation.restrict x)) = q x + rw [show h.orderMonoidIso.symm (V.valuation.restrict x) = q.restrict x by + change h.orderMonoidIso.symm + (q.valuationSubring.valuation.restrict x) = q.restrict x + exact h.orderMonoidIso.symm_apply_eq.mpr (h.orderMonoidIso_spec x).symm] + exact Valuation.IsRankOneDiscrete.valueGroup₀_equiv_withZeroMulInt_restrict_apply_of_surjective + (by + rcases w with w | w + · exact w.valuation_surjective K + · exact w.valuation_surjective K) x + +omit [Algebra k K] [IsScalarTower k k[X] K] in +theorem Place.finite_X_le_one + (w : IsDedekindDomain.HeightOneSpectrum (ringOfIntegers k K)) : + w.valuation K (algebraMap k⟮X⟯ K RatFunc.X) ≤ 1 := by + let r : ringOfIntegers k K := algebraMap k[X] (ringOfIntegers k K) Polynomial.X + have hr := w.valuation_le_one (K := K) r + have hr_eq : (r : K) = algebraMap k⟮X⟯ K RatFunc.X := by + calc + (r : K) = algebraMap (ringOfIntegers k K) K r := rfl + _ = algebraMap k[X] K Polynomial.X := by + simpa only [r] using + (IsScalarTower.algebraMap_apply k[X] (ringOfIntegers k K) K Polynomial.X).symm + _ = algebraMap k⟮X⟯ K RatFunc.X := by + rw [IsScalarTower.algebraMap_apply k[X] k⟮X⟯ K, RatFunc.algebraMap_X] + rw [← hr_eq] + exact hr + +namespace Place + +variable {R L : Type*} [CommRing R] [IsDedekindDomain R] [Field L] + [Algebra R L] [IsFractionRing R L] + +/-- The centre in a Dedekind model of a valuation subring containing that model. -/ +noncomputable def centerIdeal (V : ValuationSubring L) + (hR : ∀ r : R, algebraMap R L r ∈ V) : Ideal R := + (IsLocalRing.maximalIdeal V).comap + ((algebraMap R L).codRestrict V hR) + +instance centerIdeal_isPrime (V : ValuationSubring L) + (hR : ∀ r : R, algebraMap R L r ∈ V) : (centerIdeal V hR).IsPrime := + (IsLocalRing.maximalIdeal V).comap_isPrime _ + +/-- A nonzero centre is a height-one prime of a Dedekind model. -/ +noncomputable def center (V : ValuationSubring L) + (hR : ∀ r : R, algebraMap R L r ∈ V) (hne : centerIdeal V hR ≠ ⊥) : + IsDedekindDomain.HeightOneSpectrum R where + asIdeal := centerIdeal V hR + isPrime := inferInstance + ne_bot := hne + +theorem valuationSubringAtPrime_center (V : ValuationSubring L) (hV : V ≠ ⊤) + (hR : ∀ r : R, algebraMap R L r ∈ V) (hne : centerIdeal V hR ≠ ⊥) : + IsDedekindDomain.HeightOneSpectrum.valuationSubringAtPrime L (center V hR hne) = V := by + let w := center V hR hne + let A := IsDedekindDomain.HeightOneSpectrum.valuationSubringAtPrime L w + have hle : A ≤ V := by + rintro x hx + have hvx : w.valuation L x ≤ 1 := by + rw [← Valuation.mem_valuationSubring_iff, + ← IsDedekindDomain.HeightOneSpectrum.valuationSubringAtPrime_eq_valuationSubring] + exact hx + obtain ⟨a, s, hxs⟩ := w.exists_primeCompl_mul_eq_of_integer x hvx + have hs_not_center : (s : R) ∉ centerIdeal V hR := by + change (s : R) ∉ w.asIdeal + exact s.property + have hs_inv_mem : (algebraMap R L s)⁻¹ ∈ V := by + have hs_not_max : + ((⟨algebraMap R L s, hR s⟩ : V) ∉ IsLocalRing.maximalIdeal V) := by + exact hs_not_center + have hs_unit : IsUnit (⟨algebraMap R L s, hR s⟩ : V) := by + simpa [IsLocalRing.mem_maximalIdeal] using hs_not_max + obtain ⟨u, hu⟩ := hs_unit + have hinv_mem : (algebraMap R L s)⁻¹ ∈ V := by + have huval : ((u : V) : L) = algebraMap R L s := by + exact congrArg Subtype.val hu + have huinv : (((u⁻¹ : Vˣ) : V) : L) = (algebraMap R L s)⁻¹ := by + have hmV : ((u⁻¹ : Vˣ) : V) * (u : V) = 1 := by simp + have hmL := congrArg (fun z : V => (z : L)) hmV + change (((u⁻¹ : Vˣ) : V) : L) * ((u : V) : L) = 1 at hmL + rw [huval] at hmL + exact eq_inv_of_mul_eq_one_left hmL + rw [← huinv] + exact (u⁻¹ : Vˣ).val.property + exact hinv_mem + have hs_ne : algebraMap R L s ≠ 0 := by + have hsR : (s : R) ≠ 0 := by + intro hs0 + exact s.property (hs0 ▸ w.asIdeal.zero_mem) + intro hs0 + apply hsR + apply FaithfulSMul.algebraMap_injective R L + simpa using hs0 + have hx_eq : x = algebraMap R L a * (algebraMap R L s)⁻¹ := by + apply (eq_mul_inv_iff_mul_eq₀ hs_ne).2 + exact hxs + rw [hx_eq] + exact V.mul_mem _ _ (hR a) hs_inv_mem + exact ValuationSubring.eq_of_le_of_ne_top A hle hV + +end Place + +namespace Place + +local instance instTowerConstantsRatFunc : IsScalarTower k k⟮X⟯ K := + IsScalarTower.of_algebraMap_eq fun c => by + exact (IsScalarTower.algebraMap_apply k k[X] K c).trans + (IsScalarTower.algebraMap_apply k[X] k⟮X⟯ K (algebraMap k k[X] c)) + +/-- The restriction of an intrinsic place to the rational function subfield. -/ +noncomputable def restrict (v : Place k K) : Valuation k⟮X⟯ ℤᵐ⁰ := + v.valuation.comap (algebraMap k⟮X⟯ K) + +instance restrict_isTrivialOn (v : Place k K) : (restrict k K v).IsTrivialOn k where + eq_one c hc := by + change v.valuation + (algebraMap k⟮X⟯ K (algebraMap k k⟮X⟯ c)) = 1 + rw [← IsScalarTower.algebraMap_apply k k⟮X⟯ K] + exact Valuation.IsTrivialOn.eq_one c hc + +omit [Algebra k[X] K] [IsScalarTower k k[X] K] [IsScalarTower k[X] k⟮X⟯ K] + [FunctionField k K] in +theorem restrict_isNontrivial (v : Place k K) : + (restrict k K v).IsNontrivial := by + let q := restrict k K v + by_contra hq + let : v.valuation.IsTrivialOn k⟮X⟯ := + { eq_one := fun a ha => by + change q a = 1 + by_contra hne + apply hq + refine ⟨a, ?_, hne⟩ + simp [restrict, ha] } + obtain ⟨y, hy0, hy1⟩ := + (inferInstance : v.valuation.IsNontrivial).exists_val_nontrivial + have hy : y ≠ 0 := v.valuation.ne_zero_iff.mp hy0 + exact (Valuation.transcendental_of_ne_one k⟮X⟯ y hy hy1) + (Algebra.IsAlgebraic.isAlgebraic y) + +omit [FunctionField k K] in +theorem restrict_classification (v : Place k K) : + Xor ((restrict k K v).IsEquiv (RatFunc.inftyValuation k)) + (∃! u : IsDedekindDomain.HeightOneSpectrum k[X], + (restrict k K v).IsEquiv (u.valuation k⟮X⟯)) := by + let q := restrict k K v + let : q.IsNontrivial := restrict_isNontrivial k K v + let : q.IsRankOneDiscrete := Valuation.IsRankOneDiscrete.mk' q + exact RatFunc.valuation_isEquiv_infty_or_adic (v := q) + +omit [IsScalarTower k k[X] K] [FunctionField k K] [Algebra.IsSeparable k⟮X⟯ K] in +theorem finiteRing_le (v : Place k K) + (u : IsDedekindDomain.HeightOneSpectrum k[X]) + (h : (restrict k K v).IsEquiv (u.valuation k⟮X⟯)) : + ∀ r : ringOfIntegers k K, algebraMap (ringOfIntegers k K) K r ∈ + v.toValuationSubring := by + have hpoly : ∀ p : k[X], algebraMap k[X] K p ∈ v.toValuationSubring := by + intro p + rw [← v.valuationSubring_valuation, Valuation.mem_valuationSubring_iff] + rw [IsScalarTower.algebraMap_apply k[X] k⟮X⟯ K] + exact h.le_one_iff_le_one.mpr (u.valuation_le_one p) + let : IsIntegrallyClosedIn v.toValuationSubring.toSubring K := + Subring.isIntegrallyClosedIn_iff.mpr fun {_x} hx => + LocalSubring.mem_of_isMax_of_isIntegral + v.toValuationSubring.isMax_toLocalSubring hx + have hle : (ringOfIntegers k K).toSubring ≤ v.toValuationSubring.toSubring := + (Subring.integralClosure_le_iff).mpr hpoly + exact fun r => hle r.property + +omit [IsScalarTower k k[X] K] in +theorem finiteCenter_ne (v : Place k K) + (u : IsDedekindDomain.HeightOneSpectrum k[X]) + (h : (restrict k K v).IsEquiv (u.valuation k⟮X⟯)) : + centerIdeal v.toValuationSubring (finiteRing_le k K v u h) ≠ ⊥ := by + obtain ⟨a, ha_mem, ha_ne⟩ := Submodule.exists_mem_ne_zero_of_ne_bot u.ne_bot + let r : ringOfIntegers k K := algebraMap k[X] (ringOfIntegers k K) a + have hr_ne : r ≠ 0 := by + intro hr + apply ha_ne + apply FaithfulSMul.algebraMap_injective k[X] (ringOfIntegers k K) + simpa [r] using hr + intro hbot + have hr_center : r ∈ + centerIdeal v.toValuationSubring (finiteRing_le k K v u h) := by + change (⟨algebraMap (ringOfIntegers k K) K r, + finiteRing_le k K v u h r⟩ : v.toValuationSubring) ∈ + IsLocalRing.maximalIdeal v.toValuationSubring + rw [v.toValuationSubring.valuation_lt_one_iff] + have hnorm : v.valuation (algebraMap (ringOfIntegers k K) K r) < 1 := by + rw [show algebraMap (ringOfIntegers k K) K r = algebraMap k[X] K a by + simpa only [r] using + (IsScalarTower.algebraMap_apply k[X] (ringOfIntegers k K) K a).symm, + IsScalarTower.algebraMap_apply k[X] k⟮X⟯ K] + exact h.lt_one_iff_lt_one.mpr + ((u.valuation_lt_one_iff_mem a).mpr ha_mem) + simpa only [map_one] using + v.valuation_isEquiv_canonical.lt_one_iff_lt_one.mp hnorm + rw [hbot] at hr_center + exact hr_ne (Ideal.mem_bot.mp hr_center) + +omit [Algebra k[X] K] [IsScalarTower k k[X] K] [IsScalarTower k[X] k⟮X⟯ K] + [FunctionField k K] [Algebra.IsSeparable k⟮X⟯ K] in +theorem infiniteRing_le (v : Place k K) + (h : (restrict k K v).IsEquiv (RatFunc.inftyValuation k)) : + ∀ r : infiniteIntegers k K, algebraMap (infiniteIntegers k K) K r ∈ + v.toValuationSubring := by + have hbase : ∀ a : inftyValuationSubring k, + algebraMap (inftyValuationSubring k) K a ∈ v.toValuationSubring := by + intro a + rw [← v.valuationSubring_valuation, Valuation.mem_valuationSubring_iff] + rw [IsScalarTower.algebraMap_apply (inftyValuationSubring k) k⟮X⟯ K] + exact h.le_one_iff_le_one.mpr a.property + let : IsIntegrallyClosedIn v.toValuationSubring.toSubring K := + Subring.isIntegrallyClosedIn_iff.mpr fun {_x} hx => + LocalSubring.mem_of_isMax_of_isIntegral + v.toValuationSubring.isMax_toLocalSubring hx + have hle : (infiniteIntegers k K).toSubring ≤ v.toValuationSubring.toSubring := + (Subring.integralClosure_le_iff).mpr hbase + exact fun r => hle r.property + +omit [Algebra k[X] K] [IsScalarTower k k[X] K] [IsScalarTower k[X] k⟮X⟯ K] in +theorem infiniteCenter_ne (v : Place k K) + (h : (restrict k K v).IsEquiv (RatFunc.inftyValuation k)) : + centerIdeal v.toValuationSubring (infiniteRing_le k K v h) ≠ ⊥ := by + let A := inftyValuationSubring k + let u := IsDiscreteValuationRing.maximalIdeal A + obtain ⟨a, ha_mem, ha_ne⟩ := Submodule.exists_mem_ne_zero_of_ne_bot u.ne_bot + let r : infiniteIntegers k K := algebraMap A (infiniteIntegers k K) a + have hr_ne : r ≠ 0 := by + intro hr + apply ha_ne + apply FaithfulSMul.algebraMap_injective A (infiniteIntegers k K) + simpa [r] using hr + intro hbot + have hr_center : r ∈ + centerIdeal v.toValuationSubring (infiniteRing_le k K v h) := by + change (⟨algebraMap (infiniteIntegers k K) K r, + infiniteRing_le k K v h r⟩ : v.toValuationSubring) ∈ + IsLocalRing.maximalIdeal v.toValuationSubring + rw [v.toValuationSubring.valuation_lt_one_iff] + have hnorm : v.valuation (algebraMap (infiniteIntegers k K) K r) < 1 := by + rw [show algebraMap (infiniteIntegers k K) K r = algebraMap A K a by + simpa only [r] using + (IsScalarTower.algebraMap_apply A (infiniteIntegers k K) K a).symm, + IsScalarTower.algebraMap_apply A k⟮X⟯ K] + exact h.lt_one_iff_lt_one.mpr + ((Valuation.mem_maximalIdeal_iff (v := RatFunc.inftyValuation k)).mp ha_mem) + simpa only [map_one] using + v.valuation_isEquiv_canonical.lt_one_iff_lt_one.mp hnorm + rw [hbot] at hr_center + exact hr_ne (Ideal.mem_bot.mp hr_center) + +omit [Algebra k K] [Algebra k[X] K] [IsScalarTower k k[X] K] + [IsScalarTower k[X] k⟮X⟯ K] in +theorem infinite_X_gt_one + (w : IsDedekindDomain.HeightOneSpectrum (infiniteIntegers k K)) : + 1 < w.valuation K (algebraMap k⟮X⟯ K RatFunc.X) := by + let A := inftyValuationSubring k + let u := IsDiscreteValuationRing.maximalIdeal A + have hund : w.asIdeal.under A = u.asIdeal := by + exact IsLocalRing.eq_maximalIdeal inferInstance + let : w.asIdeal.LiesOver u.asIdeal := ⟨hund.symm⟩ + have hbase : (u.valuation k⟮X⟯).IsEquiv (RatFunc.inftyValuation k) := by + rw [Valuation.isEquiv_iff_valuationSubring] + apply ValuationSubring.toSubring_injective + have hmap : Subring.map (algebraMap A k⟮X⟯) ⊤ = A.toSubring := by + ext x + constructor + · rintro ⟨a, _, rfl⟩ + exact a.property + · intro hx + exact ⟨⟨x, hx⟩, Set.mem_univ _, rfl⟩ + exact (IsDiscreteValuationRing.map_algebraMap_eq_valuationSubring + (A := A) (K := k⟮X⟯)).symm.trans hmap + have hbaseX : 1 < u.valuation k⟮X⟯ RatFunc.X := + hbase.one_lt_iff_one_lt.mpr (by simp [← WithZero.exp_zero]) + have he : Ideal.ramificationIdx' u.asIdeal w.asIdeal ≠ 0 := + Ideal.IsDedekindDomain.ramificationIdx'_ne_zero_of_liesOver + w.asIdeal u.ne_bot + have hpow : 1 < (u.valuation k⟮X⟯ RatFunc.X) ^ + Ideal.ramificationIdx' u.asIdeal w.asIdeal := by + exact one_lt_pow₀ hbaseX he + rw [u.valuation_liesOver K w RatFunc.X] at hpow + exact hpow + +theorem ofChart_injective : Function.Injective (Place.ofChart k K) := by + intro w₁ w₂ hw + have hsub := congrArg Place.toValuationSubring hw + simp only [Place.ofChart_toValuationSubring] at hsub + rcases w₁ with w₁ | w₁ <;> rcases w₂ with w₂ | w₂ + · congr 1 + exact IsDedekindDomain.HeightOneSpectrum.eq_of_valuation_isEquiv_valuation + ((Valuation.isEquiv_iff_valuationSubring _ _).mpr hsub) + · have hequiv : (w₁.valuation K).IsEquiv (w₂.valuation K) := + (Valuation.isEquiv_iff_valuationSubring _ _).mpr hsub + have hle := hequiv.le_one_iff_le_one.mp (finite_X_le_one k K w₁) + exact (not_le_of_gt (infinite_X_gt_one k K w₂) hle).elim + · have hequiv : (w₂.valuation K).IsEquiv (w₁.valuation K) := + (Valuation.isEquiv_iff_valuationSubring _ _).mpr hsub.symm + have hle := hequiv.le_one_iff_le_one.mp (finite_X_le_one k K w₂) + exact (not_le_of_gt (infinite_X_gt_one k K w₁) hle).elim + · congr 1 + exact IsDedekindDomain.HeightOneSpectrum.eq_of_valuation_isEquiv_valuation + ((Valuation.isEquiv_iff_valuationSubring _ _).mpr hsub) + +/-- Every intrinsic place occurs on one of the two coordinate charts. -/ +theorem exists_chart (v : Place k K) : + ∃ w : PlaceA k K, Place.ofChart k K w = v := by + rcases restrict_classification k K v with h | h + · let w := center v.toValuationSubring + (infiniteRing_le k K v h.1) (infiniteCenter_ne k K v h.1) + refine ⟨Sum.inr w, Place.ext ?_⟩ + rw [Place.ofChart_toValuationSubring] + change (w.valuation K).valuationSubring = _ + rw [← IsDedekindDomain.HeightOneSpectrum.valuationSubringAtPrime_eq_valuationSubring] + exact valuationSubringAtPrime_center v.toValuationSubring v.ne_top + (infiniteRing_le k K v h.1) (infiniteCenter_ne k K v h.1) + · let u := h.1.choose + have hu := h.1.choose_spec.1 + let w := center v.toValuationSubring + (finiteRing_le k K v u hu) (finiteCenter_ne k K v u hu) + refine ⟨Sum.inl w, Place.ext ?_⟩ + rw [Place.ofChart_toValuationSubring] + change (w.valuation K).valuationSubring = _ + rw [← IsDedekindDomain.HeightOneSpectrum.valuationSubringAtPrime_eq_valuationSubring] + exact valuationSubringAtPrime_center v.toValuationSubring v.ne_top + (finiteRing_le k K v u hu) (finiteCenter_ne k K v u hu) + +/-- Recover a coordinate chart containing an intrinsic place. -/ +noncomputable def toChart (v : Place k K) : PlaceA k K := + Classical.choose (exists_chart k K v) + +theorem ofChart_toChart (v : Place k K) : + Place.ofChart k K (toChart k K v) = v := + Classical.choose_spec (exists_chart k K v) + +/-- Coordinate places and intrinsic places are equivalent. -/ +noncomputable def chartToPlaceCore : PlaceA k K ≃ Place k K where + toFun := Place.ofChart k K + invFun := toChart k K + left_inv w := ofChart_injective k K (ofChart_toChart k K (Place.ofChart k K w)) + right_inv := ofChart_toChart k K + +end Place + +/-- The equivalence from the two-chart construction to coordinate-free places. -/ +noncomputable abbrev chartToPlace : PlaceA k K ≃ Place k K := + Place.chartToPlaceCore k K + +@[simp] +theorem chartToPlace_apply (w : PlaceA k K) : + chartToPlace k K w = Place.ofChart k K w := rfl + +/-- The coordinate valuation and the normalized intrinsic valuation define the same place. -/ +theorem placeValuation_isEquiv (w : PlaceA k K) : + (placeValuation k K w).IsEquiv (chartToPlace k K w).valuation := + Place.ofChart_valuation_isEquiv k K w + +/-- Compatibility of the chart and intrinsic normalized valuations. -/ +theorem placeValuation_eq (w : PlaceA k K) : + (chartToPlace k K w).valuation = placeValuation k K w := + Place.ofChart_valuation_eq k K w + +end FunctionField diff --git a/LeanPool/MarkoffModP/RiemannRoch/RRspace/Basic.lean b/LeanPool/MarkoffModP/RiemannRoch/RRspace/Basic.lean new file mode 100644 index 0000000000..c4e55935b7 --- /dev/null +++ b/LeanPool/MarkoffModP/RiemannRoch/RRspace/Basic.lean @@ -0,0 +1,942 @@ +/- +Copyright (c) 2026 Guanghao Li. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Guanghao Li +-/ + +module + +public import LeanPool.MarkoffModP.RiemannRoch.Basic +public import LeanPool.MarkoffModP.RiemannRoch.LocalResidue +public import Mathlib.Algebra.Order.GroupWithZero.Canonical +public import Mathlib.Algebra.Polynomial.Eval.Subring +public import Mathlib.FieldTheory.Minpoly.IsIntegrallyClosed +public import Mathlib.RingTheory.DedekindDomain.AdicValuation +public import Mathlib.RingTheory.LocalRing.ResidueField.Ideal +public import Mathlib.RingTheory.Polynomial.Tower + +/-! +# Riemann–Roch spaces `L(D)` + +This file defines the Riemann–Roch space of a divisor on a function field and its dimension +`ℓ(D)`. +-/ + +@[expose] public section + +open scoped nonZeroDivisors Polynomial RatFunc WithZero + +noncomputable section + +namespace FunctionField.Chart + +lemma exp_neg_mul_lt_one_iff_le (x : ℤᵐ⁰) (n : ℤ) : + WithZero.exp (-n) * x < 1 ↔ x ≤ WithZero.exp (n - 1) := by + by_cases hx : x = 0 + · simp [hx] + rw [← WithZero.log_lt_log (mul_ne_zero WithZero.exp_ne_zero hx) one_ne_zero] + rw [WithZero.log_mul WithZero.exp_ne_zero hx, WithZero.log_exp, WithZero.log_one] + rw [← WithZero.log_le_iff_le_exp hx] + omega + +variable (k K : Type*) [Field k] [Field K] + +variable [Algebra k K] [Algebra k[X] K] [Algebra k⟮X⟯ K] [IsScalarTower k k[X] K] + [IsScalarTower k[X] k⟮X⟯ K] [FunctionField k K] + [Algebra.IsSeparable k⟮X⟯ K] + +/-- The classical decidable equality on `k(X)` used by the coordinate places. -/ +local instance instDecidableEqRatFuncRRspace : DecidableEq k⟮X⟯ := Classical.decEq _ + +omit [Algebra k K] [IsScalarTower k k[X] K] in +theorem nonempty_placeA : Nonempty (PlaceA k K) := by + let P : Ideal k[X] := Ideal.span {Polynomial.X} + let : P.IsMaximal := + PrincipalIdealRing.isMaximal_of_irreducible Polynomial.irreducible_X + obtain ⟨Q, hQprime, hQunder⟩ := + P.exists_ideal_over_prime_of_isIntegral_of_isDomain + (S := ringOfIntegers k K) (by simp) + have hQ0 : Q ≠ ⊥ := by + intro hQ + have hP : P = ⊥ := by simpa [hQ] using hQunder.symm + have hX : Polynomial.X ∈ P := Ideal.subset_span (Set.mem_singleton _) + rw [hP, Ideal.mem_bot] at hX + exact Polynomial.X_ne_zero hX + exact ⟨Sum.inl ⟨Q, hQprime, hQ0⟩⟩ + +/-- A function belongs to the Riemann–Roch space of `D` when its valuation at every place `v` +is at most `WithZero.exp (D v)`, i.e. `ord_v f ≥ -D v` in additive notation. The zero function +belongs trivially since its valuation is `0`. -/ +def memRRspace (D : DivisorA k K) (f : K) : Prop := + ∀ v, placeValuation k K v f ≤ WithZero.exp (D v) + +namespace memRRspace + +variable {D : DivisorA k K} + +omit [Algebra k K] [IsScalarTower k k[X] K] in +theorem zero_mem (D : DivisorA k K) : memRRspace k K D 0 := fun v => by + rw [map_zero] + exact zero_le + +omit [Algebra k K] [IsScalarTower k k[X] K] in +theorem add_mem {f g : K} (hf : memRRspace k K D f) (hg : memRRspace k K D g) : + memRRspace k K D (f + g) := fun v => + le_trans (Valuation.map_add _ f g) (max_le (hf v) (hg v)) + +theorem smul_mem (c : k) {f : K} (hf : memRRspace k K D f) : + memRRspace k K D (c • f) := fun v => by + rw [Algebra.smul_def, map_mul] + calc placeValuation k K v (algebraMap k K c) * placeValuation k K v f + ≤ 1 * WithZero.exp (D v) := + mul_le_mul' (placeValuation_algebraMap_le_one k K v c) (hf v) + _ = WithZero.exp (D v) := one_mul _ + +omit [Algebra k K] [IsScalarTower k k[X] K] in +theorem one_mem : memRRspace k K 0 1 := fun v => by + rw [Valuation.map_one (placeValuation k K v)] + change (1 : WithZero (Multiplicative ℤ)) ≤ WithZero.exp ((0 : DivisorA k K) v) + rw [Finsupp.zero_apply, ← WithZero.exp_zero] + +omit [Algebra k K] [IsScalarTower k k[X] K] in +theorem mul_mem {D E : DivisorA k K} {f g : K} (hf : memRRspace k K D f) + (hg : memRRspace k K E g) : + memRRspace k K (D + E) (f * g) := fun v => by + rw [Valuation.map_mul (placeValuation k K v), Finsupp.add_apply] + calc placeValuation k K v f * placeValuation k K v g + ≤ WithZero.exp (D v) * WithZero.exp (E v) := mul_le_mul' (hf v) (hg v) + _ = WithZero.exp (D v + E v) := by rw [← WithZero.exp_add] + +omit [Algebra k K] [IsScalarTower k k[X] K] in +theorem memRRspace_mono {D E : DivisorA k K} (h : D ≤ E) {f : K} (hf : memRRspace k K D f) : + memRRspace k K E f := fun v => + (hf v).trans (WithZero.exp_le_exp.mpr (h v)) + +omit [Algebra k K] [IsScalarTower k k[X] K] in +theorem pow_mem {D : DivisorA k K} {f : K} (hf : memRRspace k K D f) : + ∀ n : ℕ, memRRspace k K (n • D) (f ^ n) := by + intro n + induction n with + | zero => + simpa using one_mem (k := k) (K := K) + | succ n ih => + rw [succ_nsmul, pow_succ] + exact mul_mem (k := k) (K := K) ih hf + +end memRRspace + +/-- The Riemann–Roch space `L(D)`. -/ +def RRspace (D : DivisorA k K) : Submodule k K where + carrier := {f | memRRspace k K D f} + zero_mem' := memRRspace.zero_mem (k := k) (K := K) D + add_mem' hf hg := memRRspace.add_mem (k := k) (K := K) hf hg + smul_mem' c _ hf := memRRspace.smul_mem (k := k) (K := K) c hf + +/-- The dimension `ℓ(D)`. -/ +noncomputable def ell (D : DivisorA k K) : ℕ := + Module.finrank k (RRspace k K D) + +@[simp] +theorem mem_RRspace_iff (D : DivisorA k K) (f : K) : + f ∈ RRspace k K D ↔ memRRspace k K D f := by + simp [RRspace] + +theorem RRspace_mono {D D' : DivisorA k K} (h : D ≤ D') : + RRspace k K D ≤ RRspace k K D' := by + intro f hf + rw [mem_RRspace_iff] at hf ⊢ + exact fun v => (hf v).trans (WithZero.exp_le_exp.mpr (h v)) + +/-- Multiplication by a nonzero function identifies `L(D + (x))` with `L(D)`. -/ +noncomputable def RRspaceAddPrincipalEquiv (D : DivisorA k K) (x : Kˣ) : + RRspace k K (D + principalDivisorA k K (Additive.ofMul x)) ≃ₗ[k] + RRspace k K D where + toFun f := ⟨(x : K) * f.val, by + intro v + change placeValuation k K v ((x : K) * f.val) ≤ WithZero.exp (D v) + rw [map_mul] + have hxval := placeValuation_eq_exp_neg_principalDivisor k K (Additive.ofMul x) v + change placeValuation k K v (x : K) = + WithZero.exp (-(principalDivisorA k K (Additive.ofMul x) v)) at hxval + rw [hxval] + have hf := f.property v + rw [Finsupp.add_apply, WithZero.exp_add] at hf + calc + WithZero.exp (-(principalDivisorA k K (Additive.ofMul x) v)) * + placeValuation k K v f.val ≤ + WithZero.exp (-(principalDivisorA k K (Additive.ofMul x) v)) * + (WithZero.exp (D v) * + WithZero.exp (principalDivisorA k K (Additive.ofMul x) v)) := + mul_le_mul_right hf _ + _ = WithZero.exp (D v) := by + rw [← WithZero.exp_add, ← WithZero.exp_add] + congr 1 + ring⟩ + invFun f := ⟨((x⁻¹ : Kˣ) : K) * f.val, by + intro v + change placeValuation k K v (((x⁻¹ : Kˣ) : K) * f.val) ≤ + WithZero.exp ((D + principalDivisorA k K (Additive.ofMul x)) v) + rw [map_mul] + have hxinv := placeValuation_eq_exp_neg_principalDivisor k K + (Additive.ofMul (x⁻¹ : Kˣ)) v + have hxinv' : placeValuation k K v ((x⁻¹ : Kˣ) : K) = + WithZero.exp (principalDivisorA k K (Additive.ofMul x) v) := by + change placeValuation k K v ((x⁻¹ : Kˣ) : K) = _ at hxinv ⊢ + simpa using hxinv + rw [hxinv', Finsupp.add_apply, WithZero.exp_add] + calc + WithZero.exp (principalDivisorA k K (Additive.ofMul x) v) * + placeValuation k K v f.val ≤ + WithZero.exp (principalDivisorA k K (Additive.ofMul x) v) * + WithZero.exp (D v) := mul_le_mul_right (f.property v) _ + _ = WithZero.exp (D v) * + WithZero.exp (principalDivisorA k K (Additive.ofMul x) v) := mul_comm _ _⟩ + left_inv f := Subtype.ext (by + change ((x⁻¹ : Kˣ) : K) * ((x : K) * f.val) = f.val + rw [← mul_assoc, Units.inv_mul, one_mul]) + right_inv f := Subtype.ext (by + change (x : K) * (((x⁻¹ : Kˣ) : K) * f.val) = f.val + rw [← mul_assoc, Units.mul_inv, one_mul]) + map_add' f g := by + apply Subtype.ext + exact mul_add (x : K) f.val g.val + map_smul' c f := by + apply Subtype.ext + change (x : K) * (c • f.val) = c • ((x : K) * f.val) + simp only [Algebra.smul_def] + ring + +/-- Riemann–Roch dimensions are invariant under adding a principal divisor. -/ +theorem ell_add_principal (D : DivisorA k K) (x : Kˣ) : + ell k K (D + principalDivisorA k K (Additive.ofMul x)) = ell k K D := by + exact (RRspaceAddPrincipalEquiv k K D x).finrank_eq + +/-- The rank of the quotient `L(D') / L(D)` (with intersection semantics when unordered). -/ +noncomputable def finrankRRspaceDiff (D D' : DivisorA k K) : ℕ := by + letI : AddCommGroup (RRspace k K D') := Submodule.addCommGroup _ + letI : Module k (RRspace k K D') := Submodule.module _ + exact Module.finrank k <| + (RRspace k K D') ⧸ + Submodule.comap (RRspace k K D').subtype (RRspace k K D) + +/-- One-step local residue map at a finite coordinate place. -/ +noncomputable def finiteLocalResidueMap (D : DivisorA k K) + (v : IsDedekindDomain.HeightOneSpectrum (ringOfIntegers k K)) : + RRspace k K (D + Finsupp.single (Sum.inl v) 1) →ₗ[k] v.asIdeal.ResidueField := by + let A := IsDedekindDomain.HeightOneSpectrum.valuationSubringAtPrime K v + letI : Algebra k A := + ((algebraMap (ringOfIntegers k K) A).comp + (algebraMap k (ringOfIntegers k K))).toAlgebra + letI : IsScalarTower k (ringOfIntegers k K) A := + IsScalarTower.of_algebraMap_eq fun _ => rfl + let π : K := Classical.choose (v.valuation_exists_uniformizer K) + let n : ℤ := D (Sum.inl v) + 1 + let toA : RRspace k K (D + Finsupp.single (Sum.inl v) 1) → A := fun f => + ⟨π ^ n * (f : K), by + change π ^ n * (f : K) ∈ + IsDedekindDomain.HeightOneSpectrum.valuationSubringAtPrime K v + rw [IsDedekindDomain.HeightOneSpectrum.valuationSubringAtPrime_eq_valuationSubring, + Valuation.mem_valuationSubring_iff] + have hπpow : v.valuation K (π ^ n) = WithZero.exp (-1) ^ n := by + rw [map_zpow₀, Classical.choose_spec (v.valuation_exists_uniformizer K)] + rw [map_mul, hπpow] + have hf : v.valuation K (f : K) ≤ WithZero.exp n := by + simpa [placeValuation, n] using f.property (Sum.inl v) + calc + WithZero.exp (-1) ^ n * v.valuation K (f : K) + ≤ WithZero.exp (-1) ^ n * WithZero.exp n := mul_le_mul_right hf _ + _ = 1 := by + rw [← WithZero.exp_zsmul, ← WithZero.exp_add] + convert WithZero.exp_zero + simp⟩ + exact + { toFun := fun f => + IsDedekindDomain.HeightOneSpectrum.residueHom (K := K) v (toA f) + map_add' := fun f g => by + rw [← map_add] + congr 1 + apply Subtype.ext + simp [toA, mul_add] + map_smul' := fun c f => by + have hz : toA (c • f) = algebraMap k A c * toA f := by + apply Subtype.ext + simp only [toA, Submodule.coe_smul_of_tower, Algebra.smul_def] + change π ^ n * (algebraMap k K c * (f : K)) = + (↑(algebraMap k A c) : K) * (π ^ n * (f : K)) + have hcA : (↑(algebraMap k A c) : K) = algebraMap k K c := by + calc + (↑(algebraMap k A c) : K) = + ↑(algebraMap (ringOfIntegers k K) A + (algebraMap k (ringOfIntegers k K) c)) := by + rw [IsScalarTower.algebraMap_apply k (ringOfIntegers k K) A] + _ = algebraMap (ringOfIntegers k K) K + (algebraMap k (ringOfIntegers k K) c) := rfl + _ = algebraMap k K c := + (IsScalarTower.algebraMap_apply k (ringOfIntegers k K) K c).symm + rw [hcA] + ring + rw [hz, map_mul] + rw [Algebra.smul_def] + congr 1 + rw [IsScalarTower.algebraMap_apply k (ringOfIntegers k K) A] + rw [IsDedekindDomain.HeightOneSpectrum.residueHom, IsLocalization.lift_eq] + exact (IsScalarTower.algebraMap_apply k (ringOfIntegers k K) + v.asIdeal.ResidueField c).symm } + +theorem finiteLocalResidueMap_ker (D : DivisorA k K) + (v : IsDedekindDomain.HeightOneSpectrum (ringOfIntegers k K)) : + (finiteLocalResidueMap k K D v).ker = + Submodule.comap (RRspace k K (D + Finsupp.single (Sum.inl v) 1)).subtype + (RRspace k K D) := by + ext f + simp only [LinearMap.mem_ker, Submodule.mem_comap, Submodule.coe_subtype, + mem_RRspace_iff] + change IsDedekindDomain.HeightOneSpectrum.residueHom (K := K) v + ⟨(Classical.choose (v.valuation_exists_uniformizer K)) ^ + (D (Sum.inl v) + 1) * (f : K), _⟩ = 0 ↔ + ∀ w, placeValuation k K w (f : K) ≤ WithZero.exp (D w) + rw [IsDedekindDomain.HeightOneSpectrum.residueHom_eq_zero_iff] + have hπ := Classical.choose_spec (v.valuation_exists_uniformizer K) + rw [map_mul, map_zpow₀, hπ] + rw [← WithZero.exp_zsmul] + have hnsmul : (D (Sum.inl v) + 1) • (-1 : ℤ) = -(D (Sum.inl v) + 1) := by + simp + rw [hnsmul] + have hlocal : WithZero.exp (-(D (Sum.inl v) + 1)) * v.valuation K (f : K) < 1 ↔ + v.valuation K (f : K) ≤ WithZero.exp (D (Sum.inl v)) := by + simpa using exp_neg_mul_lt_one_iff_le + (v.valuation K (f : K)) (D (Sum.inl v) + 1) + rw [hlocal] + constructor + · intro hv w + by_cases hw : w = Sum.inl v + · subst w + exact hv + · have hf := f.property w + simpa [placeValuation, hw] using hf + · intro hf + simpa [placeValuation] using hf (Sum.inl v) + +theorem finrankRRspaceDiff_single_finite_le (D : DivisorA k K) + (v : IsDedekindDomain.HeightOneSpectrum (ringOfIntegers k K)) : + finrankRRspaceDiff k K D (D + Finsupp.single (Sum.inl v) 1) ≤ + placeDegree k K (Sum.inl v) := by + let f := finiteLocalResidueMap k K D v + let e : (ringOfIntegers k K ⧸ v.asIdeal) ≃ₗ[k] v.asIdeal.ResidueField := + LinearEquiv.ofBijective + ((Algebra.linearMap (ringOfIntegers k K ⧸ v.asIdeal) + v.asIdeal.ResidueField).restrictScalars k) + (Ideal.bijective_algebraMap_quotient_residueField v.asIdeal) + let : FiniteDimensional k v.asIdeal.ResidueField := e.finiteDimensional + have hker := finiteLocalResidueMap_ker k K D v + rw [finrankRRspaceDiff, ← hker, f.quotKerEquivRange.finrank_eq] + calc + Module.finrank k f.range ≤ Module.finrank k v.asIdeal.ResidueField := + f.range.finrank_le + _ = Module.finrank k (ringOfIntegers k K ⧸ v.asIdeal) := by + exact e.finrank_eq.symm + _ = placeDegree k K (Sum.inl v) := rfl + +/-- One-step local residue map at an infinite coordinate place. -/ +noncomputable def infiniteLocalResidueMap (D : DivisorA k K) + (v : IsDedekindDomain.HeightOneSpectrum (infiniteIntegers k K)) : + RRspace k K (D + Finsupp.single (Sum.inr v) 1) →ₗ[k] v.asIdeal.ResidueField := by + let A := IsDedekindDomain.HeightOneSpectrum.valuationSubringAtPrime K v + letI : Algebra k A := + ((algebraMap (infiniteIntegers k K) A).comp + (algebraMap k (infiniteIntegers k K))).toAlgebra + letI : IsScalarTower k (infiniteIntegers k K) A := + IsScalarTower.of_algebraMap_eq fun _ => rfl + let π : K := Classical.choose (v.valuation_exists_uniformizer K) + let n : ℤ := D (Sum.inr v) + 1 + let toA : RRspace k K (D + Finsupp.single (Sum.inr v) 1) → A := fun f => + ⟨π ^ n * (f : K), by + change π ^ n * (f : K) ∈ + IsDedekindDomain.HeightOneSpectrum.valuationSubringAtPrime K v + rw [IsDedekindDomain.HeightOneSpectrum.valuationSubringAtPrime_eq_valuationSubring, + Valuation.mem_valuationSubring_iff] + have hπpow : v.valuation K (π ^ n) = WithZero.exp (-1) ^ n := by + rw [map_zpow₀, Classical.choose_spec (v.valuation_exists_uniformizer K)] + rw [map_mul, hπpow] + have hf : v.valuation K (f : K) ≤ WithZero.exp n := by + simpa [placeValuation, n] using f.property (Sum.inr v) + calc + WithZero.exp (-1) ^ n * v.valuation K (f : K) + ≤ WithZero.exp (-1) ^ n * WithZero.exp n := mul_le_mul_right hf _ + _ = 1 := by + rw [← WithZero.exp_zsmul, ← WithZero.exp_add] + convert WithZero.exp_zero + simp⟩ + exact + { toFun := fun f => + IsDedekindDomain.HeightOneSpectrum.residueHom (K := K) v (toA f) + map_add' := fun f g => by + rw [← map_add] + congr 1 + apply Subtype.ext + simp [toA, mul_add] + map_smul' := fun c f => by + have hz : toA (c • f) = algebraMap k A c * toA f := by + apply Subtype.ext + simp only [toA, Submodule.coe_smul_of_tower, Algebra.smul_def] + change π ^ n * (algebraMap k K c * (f : K)) = + (↑(algebraMap k A c) : K) * (π ^ n * (f : K)) + have hcA : (↑(algebraMap k A c) : K) = algebraMap k K c := by + calc + (↑(algebraMap k A c) : K) = + ↑(algebraMap (infiniteIntegers k K) A + (algebraMap k (infiniteIntegers k K) c)) := by + rw [IsScalarTower.algebraMap_apply k (infiniteIntegers k K) A] + _ = algebraMap (infiniteIntegers k K) K + (algebraMap k (infiniteIntegers k K) c) := rfl + _ = algebraMap k K c := + (IsScalarTower.algebraMap_apply k (infiniteIntegers k K) K c).symm + rw [hcA] + ring + rw [hz, map_mul] + rw [Algebra.smul_def] + congr 1 + rw [IsScalarTower.algebraMap_apply k (infiniteIntegers k K) A] + rw [IsDedekindDomain.HeightOneSpectrum.residueHom, IsLocalization.lift_eq] + exact (IsScalarTower.algebraMap_apply k (infiniteIntegers k K) + v.asIdeal.ResidueField c).symm } + +theorem infiniteLocalResidueMap_ker (D : DivisorA k K) + (v : IsDedekindDomain.HeightOneSpectrum (infiniteIntegers k K)) : + (infiniteLocalResidueMap k K D v).ker = + Submodule.comap (RRspace k K (D + Finsupp.single (Sum.inr v) 1)).subtype + (RRspace k K D) := by + ext f + simp only [LinearMap.mem_ker, Submodule.mem_comap, Submodule.coe_subtype, + mem_RRspace_iff] + change IsDedekindDomain.HeightOneSpectrum.residueHom (K := K) v + ⟨(Classical.choose (v.valuation_exists_uniformizer K)) ^ + (D (Sum.inr v) + 1) * (f : K), _⟩ = 0 ↔ + ∀ w, placeValuation k K w (f : K) ≤ WithZero.exp (D w) + rw [IsDedekindDomain.HeightOneSpectrum.residueHom_eq_zero_iff] + have hπ := Classical.choose_spec (v.valuation_exists_uniformizer K) + rw [map_mul, map_zpow₀, hπ] + rw [← WithZero.exp_zsmul] + have hnsmul : (D (Sum.inr v) + 1) • (-1 : ℤ) = -(D (Sum.inr v) + 1) := by + simp + rw [hnsmul] + have hlocal : WithZero.exp (-(D (Sum.inr v) + 1)) * v.valuation K (f : K) < 1 ↔ + v.valuation K (f : K) ≤ WithZero.exp (D (Sum.inr v)) := by + simpa using exp_neg_mul_lt_one_iff_le + (v.valuation K (f : K)) (D (Sum.inr v) + 1) + rw [hlocal] + constructor + · intro hv w + by_cases hw : w = Sum.inr v + · subst w + exact hv + · have hf := f.property w + simpa [placeValuation, hw] using hf + · intro hf + simpa [placeValuation] using hf (Sum.inr v) + +theorem finrankRRspaceDiff_single_infinite_le (D : DivisorA k K) + (v : IsDedekindDomain.HeightOneSpectrum (infiniteIntegers k K)) : + finrankRRspaceDiff k K D (D + Finsupp.single (Sum.inr v) 1) ≤ + placeDegree k K (Sum.inr v) := by + let f := infiniteLocalResidueMap k K D v + let e : (infiniteIntegers k K ⧸ v.asIdeal) ≃ₗ[k] v.asIdeal.ResidueField := + LinearEquiv.ofBijective + ((Algebra.linearMap (infiniteIntegers k K ⧸ v.asIdeal) + v.asIdeal.ResidueField).restrictScalars k) + (Ideal.bijective_algebraMap_quotient_residueField v.asIdeal) + let : FiniteDimensional k v.asIdeal.ResidueField := e.finiteDimensional + have hker := infiniteLocalResidueMap_ker k K D v + rw [finrankRRspaceDiff, ← hker, f.quotKerEquivRange.finrank_eq] + calc + Module.finrank k f.range ≤ Module.finrank k v.asIdeal.ResidueField := + f.range.finrank_le + _ = Module.finrank k (infiniteIntegers k K ⧸ v.asIdeal) := by + exact e.finrank_eq.symm + _ = placeDegree k K (Sum.inr v) := rfl + +theorem finiteDimensional_add_single_one (D : DivisorA k K) (v : PlaceA k K) + [FiniteDimensional k (RRspace k K D)] : + FiniteDimensional k (RRspace k K (D + Finsupp.single v 1)) := by + classical + have hle : RRspace k K D ≤ RRspace k K (D + Finsupp.single v 1) := by + apply RRspace_mono k K + intro w + simp only [Finsupp.add_apply] + exact le_add_of_nonneg_right (by + simp only [Finsupp.single_apply] + split <;> omega) + let p := Submodule.comap (RRspace k K (D + Finsupp.single v 1)).subtype + (RRspace k K D) + let : Module.Finite k p := + Module.Finite.equiv (Submodule.comapSubtypeEquivOfLe hle).symm + rcases v with v | v + · let f := finiteLocalResidueMap k K D v + let e : (ringOfIntegers k K ⧸ v.asIdeal) ≃ₗ[k] v.asIdeal.ResidueField := + LinearEquiv.ofBijective + ((Algebra.linearMap (ringOfIntegers k K ⧸ v.asIdeal) + v.asIdeal.ResidueField).restrictScalars k) + (Ideal.bijective_algebraMap_quotient_residueField v.asIdeal) + let : FiniteDimensional k v.asIdeal.ResidueField := e.finiteDimensional + let : Module.Finite k f.range := inferInstance + have hqker : Module.Finite k + (RRspace k K (D + Finsupp.single (Sum.inl v) 1) ⧸ f.ker) := + Module.Finite.equiv f.quotKerEquivRange.symm + have hqp : Module.Finite k + (RRspace k K (D + Finsupp.single (Sum.inl v) 1) ⧸ p) := by + exact Module.Finite.equiv (Submodule.quotEquivOfEq f.ker p + (finiteLocalResidueMap_ker k K D v)) + exact Module.Finite.of_submodule_quotient p + · let f := infiniteLocalResidueMap k K D v + let e : (infiniteIntegers k K ⧸ v.asIdeal) ≃ₗ[k] v.asIdeal.ResidueField := + LinearEquiv.ofBijective + ((Algebra.linearMap (infiniteIntegers k K ⧸ v.asIdeal) + v.asIdeal.ResidueField).restrictScalars k) + (Ideal.bijective_algebraMap_quotient_residueField v.asIdeal) + let : FiniteDimensional k v.asIdeal.ResidueField := e.finiteDimensional + let : Module.Finite k f.range := inferInstance + have hqker : Module.Finite k + (RRspace k K (D + Finsupp.single (Sum.inr v) 1) ⧸ f.ker) := + Module.Finite.equiv f.quotKerEquivRange.symm + have hqp : Module.Finite k + (RRspace k K (D + Finsupp.single (Sum.inr v) 1) ⧸ p) := by + exact Module.Finite.equiv (Submodule.quotEquivOfEq f.ker p + (infiniteLocalResidueMap_ker k K D v)) + exact Module.Finite.of_submodule_quotient p + +theorem finiteDimensional_add_single_nat (D : DivisorA k K) (v : PlaceA k K) + (n : ℕ) [FiniteDimensional k (RRspace k K D)] : + FiniteDimensional k (RRspace k K (D + Finsupp.single v (n : ℤ))) := by + induction n with + | zero => + have heq : D + Finsupp.single v ((0 : ℕ) : ℤ) = D := by simp + rw [heq] + infer_instance + | succ n ih => + let : FiniteDimensional k + (RRspace k K (D + Finsupp.single v (n : ℤ))) := ih + have hfin := finiteDimensional_add_single_one k K + (D + Finsupp.single v (n : ℤ)) v + have heq : D + Finsupp.single v ((n + 1 : ℕ) : ℤ) = + (D + Finsupp.single v (n : ℤ)) + Finsupp.single v 1 := by + classical + ext w + simp only [Finsupp.add_apply, Finsupp.single_apply] + split <;> omega + rw [heq] + exact hfin + +theorem finrankRRspaceDiff_add_finrank_of_finite {D D' : DivisorA k K} + (h : D ≤ D') [FiniteDimensional k (RRspace k K D')] : + finrankRRspaceDiff k K D D' + Module.finrank k (RRspace k K D) = + Module.finrank k (RRspace k K D') := by + let : AddCommGroup (RRspace k K D') := Submodule.addCommGroup _ + let : Module k (RRspace k K D') := Submodule.module _ + rw [finrankRRspaceDiff, + ← (Submodule.comapSubtypeEquivOfLe (RRspace_mono k K h)).finrank_eq] + exact Submodule.finrank_quotient_add_finrank _ + +theorem finrankRRspaceDiff_single_one_le (D : DivisorA k K) (v : PlaceA k K) : + finrankRRspaceDiff k K D (D + Finsupp.single v 1) ≤ placeDegree k K v := by + rcases v with v | v + · exact finrankRRspaceDiff_single_finite_le k K D v + · exact finrankRRspaceDiff_single_infinite_le k K D v + +theorem finrankRRspaceDiff_single_nat_le (D : DivisorA k K) (v : PlaceA k K) + (n : ℕ) [FiniteDimensional k (RRspace k K D)] : + finrankRRspaceDiff k K D (D + Finsupp.single v (n : ℤ)) ≤ + n * placeDegree k K v := by + induction n with + | zero => + simp only [Nat.cast_zero, Finsupp.single_zero, add_zero, zero_mul] + rw [finrankRRspaceDiff] + have hp : Submodule.comap (RRspace k K D).subtype (RRspace k K D) = ⊤ := by + ext f + simp + rw [hp] + have h := Submodule.finrank_quotient_add_finrank + (⊤ : Submodule k (RRspace k K D)) + simp only [finrank_top] at h + omega + | succ n ih => + let M := D + Finsupp.single v (n : ℤ) + let N := M + Finsupp.single v 1 + let : FiniteDimensional k (RRspace k K M) := + finiteDimensional_add_single_nat k K D v n + let : FiniteDimensional k (RRspace k K N) := + finiteDimensional_add_single_one k K M v + have hDM : D ≤ M := by + intro w + dsimp only [M] + simp only [Finsupp.add_apply] + exact le_add_of_nonneg_right (by + classical + simp only [Finsupp.single_apply] + split <;> omega) + have hMN : M ≤ N := by + intro w + dsimp only [N] + simp only [Finsupp.add_apply] + exact le_add_of_nonneg_right (by + classical + simp only [Finsupp.single_apply] + split <;> omega) + have hDN : D ≤ N := hDM.trans hMN + have hsumDM := finrankRRspaceDiff_add_finrank_of_finite k K hDM + have hsumMN := finrankRRspaceDiff_add_finrank_of_finite k K hMN + have hsumDN := finrankRRspaceDiff_add_finrank_of_finite k K hDN + have hstep := finrankRRspaceDiff_single_one_le k K M v + change finrankRRspaceDiff k K D M ≤ n * placeDegree k K v at ih + change finrankRRspaceDiff k K M N ≤ placeDegree k K v at hstep + have htotal : finrankRRspaceDiff k K D N ≤ + n * placeDegree k K v + placeDegree k K v := by omega + have heq : D + Finsupp.single v ((n + 1 : ℕ) : ℤ) = N := by + classical + ext w + simp only [N, M, Finsupp.add_apply, Finsupp.single_apply] + split <;> omega + rw [heq] + simpa [Nat.succ_mul] using htotal + +theorem finiteDimensional_add_effective (D E : DivisorA k K) + (hE : IsEffective k K E) [FiniteDimensional k (RRspace k K D)] : + FiniteDimensional k (RRspace k K (D + E)) := by + classical + induction E using Finsupp.induction generalizing D with + | zero => + rw [add_zero] + infer_instance + | single_add a b f ha hb ih => + have hfa : f a = 0 := Finsupp.notMem_support_iff.mp ha + have hff : IsEffective k K f := by + intro w + by_cases hw : w = a + · subst w + rw [hfa] + · have hwE := hE w + simpa [Finsupp.single_apply, hw] using hwE + have hb0 : 0 ≤ b := by + have haE := hE a + simpa [Finsupp.single_apply, hfa] using haE + let : FiniteDimensional k (RRspace k K (D + f)) := ih D hff + have hsingle := finiteDimensional_add_single_nat k K (D + f) a b.toNat + have hbcast : (b.toNat : ℤ) = b := Int.toNat_of_nonneg hb0 + have heq : D + (Finsupp.single a b + f) = + (D + f) + Finsupp.single a (b.toNat : ℤ) := by + rw [hbcast] + abel + rw [heq] + exact hsingle + +theorem finrankRRspaceDiff_add_effective_le (D E : DivisorA k K) + (hE : IsEffective k K E) [FiniteDimensional k (RRspace k K D)] : + finrankRRspaceDiff k K D (D + E) ≤ (deg k K E).toNat := by + classical + induction E using Finsupp.induction generalizing D with + | zero => + rw [add_zero, finrankRRspaceDiff] + have hp : Submodule.comap (RRspace k K D).subtype (RRspace k K D) = ⊤ := by + ext f + simp + rw [hp, deg_zero] + have h := Submodule.finrank_quotient_add_finrank + (⊤ : Submodule k (RRspace k K D)) + simp only [finrank_top] at h + omega + | single_add a b f ha hb ih => + have hfa : f a = 0 := Finsupp.notMem_support_iff.mp ha + have hff : IsEffective k K f := by + intro w + by_cases hw : w = a + · subst w + rw [hfa] + · have hwE := hE w + simpa [Finsupp.single_apply, hw] using hwE + have hb0 : 0 ≤ b := by + have haE := hE a + simpa [Finsupp.single_apply, hfa] using haE + let M := D + f + let N := M + Finsupp.single a (b.toNat : ℤ) + let : FiniteDimensional k (RRspace k K M) := + finiteDimensional_add_effective k K D f hff + let : FiniteDimensional k (RRspace k K N) := + finiteDimensional_add_single_nat k K M a b.toNat + have hDM : D ≤ M := by + intro w + dsimp only [M] + simp only [Finsupp.add_apply] + exact le_add_of_nonneg_right (hff w) + have hMN : M ≤ N := by + intro w + dsimp only [N] + simp only [Finsupp.add_apply] + exact le_add_of_nonneg_right (by + simp only [Finsupp.single_apply] + split <;> omega) + have hDN : D ≤ N := hDM.trans hMN + have hsumDM := finrankRRspaceDiff_add_finrank_of_finite k K hDM + have hsumMN := finrankRRspaceDiff_add_finrank_of_finite k K hMN + have hsumDN := finrankRRspaceDiff_add_finrank_of_finite k K hDN + have hfirst := ih D hff + change finrankRRspaceDiff k K D M ≤ (deg k K f).toNat at hfirst + have hsecond := finrankRRspaceDiff_single_nat_le k K M a b.toNat + change finrankRRspaceDiff k K M N ≤ b.toNat * placeDegree k K a at hsecond + have hbcast : (b.toNat : ℤ) = b := Int.toNat_of_nonneg hb0 + have hdegf : 0 ≤ deg k K f := deg_nonneg k K hff + have hdegE : deg k K (Finsupp.single a b + f) = + b * (placeDegree k K a : ℤ) + deg k K f := by + rw [deg_add] + simp [deg] + have hdegE0 : 0 ≤ deg k K (Finsupp.single a b + f) := deg_nonneg k K hE + have hdegNat : (deg k K (Finsupp.single a b + f)).toNat = + b.toNat * placeDegree k K a + (deg k K f).toNat := by + have hfcast : ((deg k K f).toNat : ℤ) = deg k K f := + Int.toNat_of_nonneg hdegf + have hEcast : ((deg k K (Finsupp.single a b + f)).toNat : ℤ) = + deg k K (Finsupp.single a b + f) := Int.toNat_of_nonneg hdegE0 + apply Int.ofNat_injective + change ((deg k K (Finsupp.single a b + f)).toNat : ℤ) = + ((b.toNat * placeDegree k K a + (deg k K f).toNat : ℕ) : ℤ) + rw [hEcast, Nat.cast_add, Nat.cast_mul, hbcast, hfcast] + exact hdegE + have htotal : finrankRRspaceDiff k K D N ≤ + (deg k K (Finsupp.single a b + f)).toNat := by omega + have heq : D + (Finsupp.single a b + f) = N := by + dsimp only [N, M] + rw [hbcast] + abel + rw [heq] + exact htotal + +omit [Algebra k K] [IsScalarTower k k[X] K] in +theorem deg_principalDivisor_eq_zero (x : Kˣ) : + deg k K (principalDivisorA k K (Additive.ofMul x)) = 0 := by + exact deg_principalDivisorA_eq_zero k K x + +theorem RRspace_neg_deg {D : DivisorA k K} (h : deg k K D < 0) : + RRspace k K D = ⊥ := by + apply le_antisymm + · intro f hf + rw [Submodule.mem_bot] + by_contra hf0 + let x : Kˣ := Units.mk0 f hf0 + have hdiv : -D ≤ principalDivisorA k K (Additive.ofMul x) := by + intro v + have hv := hf v + have hxval := placeValuation_eq_exp_neg_principalDivisor k K (Additive.ofMul x) v + change placeValuation k K v f ≤ WithZero.exp (D v) at hv + change placeValuation k K v f = + WithZero.exp (-(principalDivisorA k K (Additive.ofMul x) v)) at hxval + rw [hxval] at hv + have hexp := WithZero.exp_le_exp.mp hv + simp only [Finsupp.neg_apply] + omega + have hdeg := deg_mono k K hdiv + rw [deg_neg, deg_principalDivisor_eq_zero k K x] at hdeg + omega + · exact bot_le + +theorem RRspace_neg_deg_ell {D : DivisorA k K} (h : deg k K D < 0) : ell k K D = 0 := by + change Module.finrank k (RRspace k K D) = 0 + rw [RRspace_neg_deg k K h] + exact finrank_bot k K + +theorem finiteDimensional_RRspace_aux (D : DivisorA k K) : + FiniteDimensional k (RRspace k K D) := by + classical + let v : PlaceA k K := Classical.choice (nonempty_placeA k K) + let n : ℕ := (deg k K D).toNat + 1 + let D₀ : DivisorA k K := D - Finsupp.single v (n : ℤ) + have hdegSingle : deg k K (Finsupp.single v (n : ℤ)) = + (n : ℤ) * placeDegree k K v := by + simp [deg] + have hnpos : 0 < (n : ℤ) := by + dsimp only [n] + omega + have hvpos : 0 < (placeDegree k K v : ℤ) := by + exact_mod_cast placeDegree_pos k K v + have hdegDle : deg k K D < (n : ℤ) * placeDegree k K v := by + by_cases hdeg0 : 0 ≤ deg k K D + · have hcast : ((deg k K D).toNat : ℤ) = deg k K D := + Int.toNat_of_nonneg hdeg0 + have hdlt : deg k K D < (n : ℤ) := by + dsimp only [n] + push_cast + omega + have hnle : (n : ℤ) ≤ (n : ℤ) * placeDegree k K v := by + have hvone : (1 : ℤ) ≤ placeDegree k K v := by omega + simpa only [mul_one] using mul_le_mul_of_nonneg_left hvone hnpos.le + exact hdlt.trans_le hnle + · have hprod : 0 < (n : ℤ) * placeDegree k K v := + mul_pos hnpos hvpos + omega + have hD₀neg : deg k K D₀ < 0 := by + dsimp only [D₀] + rw [deg_sub, hdegSingle] + omega + have hbot := RRspace_neg_deg k K hD₀neg + let : FiniteDimensional k (RRspace k K D₀) := by + rw [hbot] + infer_instance + have hfin := finiteDimensional_add_single_nat k K D₀ v n + have heq : D₀ + Finsupp.single v (n : ℤ) = D := by + dsimp only [D₀] + abel + rw [heq] at hfin + exact hfin + +/-- The local residue-field estimate for an increment of Riemann–Roch spaces. -/ +theorem finrank_RRspace_quotient_le {D D' : DivisorA k K} (h : D ≤ D') : + finrankRRspaceDiff k K D D' ≤ (deg k K (D' - D)).toNat := by + let : FiniteDimensional k (RRspace k K D) := finiteDimensional_RRspace_aux k K D + have hE : IsEffective k K (D' - D) := (le_iff_sub_effective k K).mp h + have hrank := finrankRRspaceDiff_add_effective_le k K D (D' - D) hE + have heq : D + (D' - D) = D' := by abel + rw [heq] at hrank + exact hrank + +/-- A function integral at every coordinate place is algebraic over the constant field. -/ +theorem isAlgebraic_of_placeValuation_le_one (f : K) + (hf : ∀ v : PlaceA k K, placeValuation k K v f ≤ 1) : IsAlgebraic k f := by + by_cases hf0 : f = 0 + · subst f + exact isAlgebraic_zero + have hfin := IsDedekindDomain.HeightOneSpectrum.mem_integers_of_valuation_le_one + (R := ringOfIntegers k K) K f (fun v => hf (Sum.inl v)) + have hinf := IsDedekindDomain.HeightOneSpectrum.mem_integers_of_valuation_le_one + (R := infiniteIntegers k K) K f (fun v => hf (Sum.inr v)) + obtain ⟨a, ha⟩ := hfin + obtain ⟨b, hb⟩ := hinf + let p : k[X][X] := minpoly k[X] a + let q : (inftyValuationSubring k)[X] := minpoly (inftyValuationSubring k) b + have hpmap : minpoly k⟮X⟯ f = p.map (algebraMap k[X] k⟮X⟯) := by + rw [← ha] + exact minpoly.isIntegrallyClosed_eq_field_fractions k⟮X⟯ K + (Algebra.IsIntegral.isIntegral a) + have hqmap : minpoly k⟮X⟯ f = + q.map (algebraMap (inftyValuationSubring k) k⟮X⟯) := by + rw [← hb] + exact minpoly.isIntegrallyClosed_eq_field_fractions k⟮X⟯ K + (Algebra.IsIntegral.isIntegral b) + have hpcoeff : ∀ i, p.coeff i ∈ Set.range (Polynomial.C : k →+* k[X]) := by + intro i + let c := p.coeff i + have hcval : RatFunc.inftyValuation k (algebraMap k[X] k⟮X⟯ c) ≤ 1 := by + have hc : algebraMap k[X] k⟮X⟯ c = + algebraMap (inftyValuationSubring k) k⟮X⟯ (q.coeff i) := by + have hc' := congrArg (fun r : k⟮X⟯[X] => r.coeff i) (hpmap.symm.trans hqmap) + simpa [p, q, c] using hc' + rw [hc] + exact (q.coeff i).property + by_cases hc0 : c = 0 + · refine ⟨0, ?_⟩ + change Polynomial.C 0 = c + simp [hc0] + have hdeg : c.natDegree = 0 := by + rw [RatFunc.inftyValuation_apply, RatFunc.inftyValuation.polynomial (F := k) hc0, + ← WithZero.exp_zero, WithZero.exp_le_exp] at hcval + omega + exact ⟨c.coeff 0, (Polynomial.eq_C_of_natDegree_eq_zero hdeg).symm⟩ + have hprange : p ∈ (Polynomial.mapRingHom (Polynomial.C : k →+* k[X])).range := by + rw [Polynomial.mem_map_range] + exact hpcoeff + obtain ⟨P, hP⟩ := hprange + have hP0 : P ≠ 0 := by + intro hP0 + rw [hP0, map_zero] at hP + have hpmonic : p.Monic := minpoly.monic (Algebra.IsIntegral.isIntegral a) + exact hpmonic.ne_zero hP.symm + refine ⟨P, hP0, ?_⟩ + have hroot : Polynomial.aeval a p = 0 := minpoly.aeval _ _ + rw [← hP] at hroot + change Polynomial.aeval a (P.map (Polynomial.C : k →+* k[X])) = 0 at hroot + calc + Polynomial.aeval f P = Polynomial.aeval f + (P.map (Polynomial.C : k →+* k[X])) := by + symm + exact Polynomial.aeval_map_algebraMap k[X] f P + _ = algebraMap (ringOfIntegers k K) K + (Polynomial.aeval a (P.map (Polynomial.C : k →+* k[X]))) := by + rw [← ha] + symm + simp + _ = 0 := by rw [hroot, map_zero] + +theorem ell_zero [IsFullConstantField k K] : ell k K (0 : DivisorA k K) = 1 := by + let φ : k →ₗ[k] RRspace k K (0 : DivisorA k K) := + { toFun := fun c => ⟨algebraMap k K c, by + intro v + simpa using placeValuation_algebraMap_le_one k K v c⟩ + map_add' := fun x y => Subtype.ext (map_add (algebraMap k K) x y) + map_smul' := fun c x => Subtype.ext (by simp [Algebra.smul_def]) } + have hφ : Function.Bijective φ := by + constructor + · intro c d hcd + apply (algebraMap k K).injective + exact congrArg Subtype.val hcd + · intro f + have hfalg : IsAlgebraic k (f : K) := by + apply isAlgebraic_of_placeValuation_le_one k K f + intro v + simpa [memRRspace] using f.property v + obtain ⟨c, hc⟩ := IsFullConstantField.algebraic_mem + (k := k) (K := K) (f : K) hfalg + refine ⟨c, Subtype.ext ?_⟩ + exact hc.symm + let e : k ≃ₗ[k] RRspace k K (0 : DivisorA k K) := LinearEquiv.ofBijective φ hφ + change Module.finrank k (RRspace k K (0 : DivisorA k K)) = 1 + rw [← e.finrank_eq] + exact Module.finrank_self k + +instance finiteDimensional_RRspace (D : DivisorA k K) : + FiniteDimensional k (RRspace k K D) := by + exact finiteDimensional_RRspace_aux k K D + +/-- Rank-nullity for an inclusion of Riemann–Roch spaces. -/ +theorem finrankRRspaceDiff_add_ell {D D' : DivisorA k K} (h : D ≤ D') : + finrankRRspaceDiff k K D D' + ell k K D = ell k K D' := by + let : AddCommGroup (RRspace k K D') := Submodule.addCommGroup _ + let : Module k (RRspace k K D') := Submodule.module _ + rw [finrankRRspaceDiff, ell, ell, + ← (Submodule.comapSubtypeEquivOfLe (RRspace_mono k K h)).finrank_eq] + exact Submodule.finrank_quotient_add_finrank _ + +theorem ell_le [IsFullConstantField k K] (D : DivisorA k K) : + (ell k K D : ℤ) ≤ deg k K (D ⊔ 0) + 1 := by + let E := D ⊔ 0 + have h0E : (0 : DivisorA k K) ≤ E := le_sup_right + have hDE : D ≤ E := le_sup_left + have hdegE : 0 ≤ deg k K E := deg_nonneg k K h0E + have hq := finrank_RRspace_quotient_le k K h0E + have hsum := finrankRRspaceDiff_add_ell k K h0E + have hmono : ell k K D ≤ ell k K E := by + exact Submodule.finrank_mono (RRspace_mono k K hDE) + rw [ell_zero k K] at hsum + have htoNat : ((deg k K E).toNat : ℤ) = deg k K E := Int.toNat_of_nonneg hdegE + have hqZ : (finrankRRspaceDiff k K 0 E : ℤ) ≤ + ((deg k K (E - 0)).toNat : ℤ) := by exact_mod_cast hq + simp only [sub_zero] at hqZ + rw [htoNat] at hqZ + change (ell k K D : ℤ) ≤ deg k K E + 1 + omega + +theorem ell_le_nonneg [IsFullConstantField k K] {D : DivisorA k K} (hD : 0 ≤ D) : + (ell k K D : ℤ) ≤ deg k K D + 1 := by + simpa [sup_eq_left.mpr hD] using ell_le k K D + +theorem defect_mono {D D' : DivisorA k K} (h : D ≤ D') : + deg k K D - ell k K D ≤ deg k K D' - ell k K D' := by + have hdeg : 0 ≤ deg k K (D' - D) := + deg_nonneg k K ((le_iff_sub_effective k K).mp h) + have hq := finrank_RRspace_quotient_le k K h + have hsum := finrankRRspaceDiff_add_ell k K h + have htoNat : ((deg k K (D' - D)).toNat : ℤ) = deg k K (D' - D) := + Int.toNat_of_nonneg hdeg + have hqZ : (finrankRRspaceDiff k K D D' : ℤ) ≤ + ((deg k K (D' - D)).toNat : ℤ) := by exact_mod_cast hq + rw [deg_sub] at htoNat + rw [deg_sub] at hqZ + rw [htoNat] at hqZ + omega + +end FunctionField.Chart diff --git a/LeanPool/MarkoffModP/RiemannRoch/RiemannRochTheorem/Basic.lean b/LeanPool/MarkoffModP/RiemannRoch/RiemannRochTheorem/Basic.lean new file mode 100644 index 0000000000..83c24ec92a --- /dev/null +++ b/LeanPool/MarkoffModP/RiemannRoch/RiemannRochTheorem/Basic.lean @@ -0,0 +1,38 @@ +/- +Copyright (c) 2026 Guanghao Li. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Guanghao Li +-/ + +module + +public import LeanPool.MarkoffModP.RiemannRoch.WeilDifferential + +/-! +# The Riemann–Roch theorem +This is pure packaging of the duality theorem together with the definition of the index of +specialty. +-/ + +@[expose] public section + +open scoped nonZeroDivisors Polynomial RatFunc WithZero + +namespace FunctionField.Chart + +variable (k K : Type*) [Field k] [Field K] + +variable [Algebra k K] [Algebra k[X] K] [Algebra k⟮X⟯ K] [IsScalarTower k k[X] K] + [IsScalarTower k[X] k⟮X⟯ K] [_root_.FunctionField k K] + [Algebra.IsSeparable k⟮X⟯ K] [IsFullConstantField k K] + +/-- **Riemann–Roch** (Stichtenoth Thm. 1.5.15): for a canonical divisor `W`, + +`ℓ(D) = deg D + 1 − g + ℓ(W − D)`. -/ +theorem riemann_roch {W : DivisorA k K} (hW : IsCanonical k K W) (D : DivisorA k K) : + (ell k K D : ℤ) = deg k K D + 1 - (genus k K : ℤ) + ell k K (W - D) := by + have hi := indexOfSpecialty_eq k K D + have hdual := indexOfSpecialty_eq_ell_sub k K hW D + omega + +end FunctionField.Chart diff --git a/LeanPool/MarkoffModP/RiemannRoch/RiemannRochTheorem/Corollaries.lean b/LeanPool/MarkoffModP/RiemannRoch/RiemannRochTheorem/Corollaries.lean new file mode 100644 index 0000000000..7e5183c9e9 --- /dev/null +++ b/LeanPool/MarkoffModP/RiemannRoch/RiemannRochTheorem/Corollaries.lean @@ -0,0 +1,515 @@ +/- +Copyright (c) 2026 Guanghao Li. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Guanghao Li +-/ + +module + +public import LeanPool.MarkoffModP.RiemannRoch.RiemannRochTheorem.Basic +public import LeanPool.MarkoffModP.RiemannRoch.LinearKneser + +import Mathlib.Algebra.Module.Submodule.Union + +/-! +# Corollaries of Riemann–Roch +Standard consequences of the main theorem, including C5 (Clifford) and C6 (existence of +non-special divisors). +-/ + +@[expose] public section + +open scoped nonZeroDivisors Polynomial RatFunc WithZero + +namespace FunctionField.Chart + +variable (k K : Type*) [Field k] [Field K] + +variable [Algebra k K] [Algebra k[X] K] [Algebra k⟮X⟯ K] [IsScalarTower k k[X] K] + [IsScalarTower k[X] k⟮X⟯ K] [_root_.FunctionField k K] + [Algebra.IsSeparable k⟮X⟯ K] [IsFullConstantField k K] + +section Canonical + +variable {W : DivisorA k K} (hW : IsCanonical k K W) + +include hW + +/-- **C1**: for a canonical divisor, `ℓ(W) = g`. -/ +theorem ell_canonical : ell k K W = genus k K := by + have hRR := riemann_roch k K hW (0 : DivisorA k K) + rw [ell_zero k K, deg_zero, zero_add, sub_zero] at hRR + omega + +/-- **C2**: `deg W = 2g − 2`. -/ +theorem deg_canonical : deg k K W = 2 * (genus k K : ℤ) - 2 := by + have hRR := riemann_roch k K hW W + rw [sub_self, ell_zero k K, ell_canonical k K hW] at hRR + omega + +/-- **C3**: if `deg D ≥ 2g − 1` then `ℓ(D) = deg D + 1 − g`. -/ +theorem ell_eq_of_deg_ge (D : DivisorA k K) (hdeg : deg k K D ≥ 2 * (genus k K : ℤ) - 1) : + (ell k K D : ℤ) = deg k K D + 1 - (genus k K : ℤ) := by + have hcanonical := deg_canonical k K hW + have hneg : deg k K (W - D) < 0 := by + rw [deg_sub, hcanonical] + omega + have hell := RRspace_neg_deg_ell k K hneg + rw [riemann_roch k K hW D, hell, Int.ofNat_zero, add_zero] + +/-- **C4**: index-of-specialty language matches `ℓ(W − D)`. -/ +theorem indexOfSpecialty_eq_ell (D : DivisorA k K) : + (indexOfSpecialty k K D : ℤ) = ell k K (W - D) := by + exact indexOfSpecialty_eq_ell_sub k K hW D + +end Canonical + +/-- The specialty index vanishes in degree at least `2g - 1`. -/ +theorem indexOfSpecialty_eq_zero_of_large_deg (D : DivisorA k K) + (hdeg : deg k K D ≥ 2 * (genus k K : ℤ) - 1) : + indexOfSpecialty k K D = 0 := by + obtain ⟨W, hW⟩ := exists_isCanonical k K + have hell := ell_eq_of_deg_ge k K hW D hdeg + have hi := indexOfSpecialty_eq k K D + omega + +/-- The specialty index vanishes above a uniform degree bound. -/ +theorem indexOfSpecialty_eq_zero_of_le_deg : + ∃ c : ℤ, ∀ D : DivisorA k K, c ≤ deg k K D → indexOfSpecialty k K D = 0 := by + exact ⟨2 * (genus k K : ℤ) - 1, fun D hD => + indexOfSpecialty_eq_zero_of_large_deg k K D hD⟩ + +omit [IsFullConstantField k K] in +/-- A positive-dimensional Riemann–Roch space supplies an effective representative of the +divisor's linear-equivalence class. -/ +theorem exists_effective_add_principal_of_ell_pos (D : DivisorA k K) + (hD : 0 < ell k K D) : + ∃ x : Kˣ, IsEffective k K + (D + principalDivisorA k K (Additive.ofMul x)) := by + let : FiniteDimensional k (RRspace k K D) := finiteDimensional_RRspace_aux k K D + obtain ⟨f, hf⟩ := (Module.finrank_pos_iff_exists_ne_zero (R := k) + (M := RRspace k K D)).mp hD + have hfval : (f : K) ≠ 0 := by + intro h + apply hf + exact Subtype.ext h + let x : Kˣ := Units.mk0 (f : K) hfval + refine ⟨x, ?_⟩ + have hle : (0 : DivisorA k K) ≤ + D + principalDivisorA k K (Additive.ofMul x) := + le_add_principal_of_memRRspace (k := k) (K := K) + (D₀ := (0 : DivisorA k K)) (D₁ := D) hfval + (by simpa only [sub_zero] using + ((mem_RRspace_iff k K D (f : K)).mp f.property)) + exact hle + +omit [IsFullConstantField k K] in +/-- Riemann–Roch spaces preserve infima of divisors. -/ +theorem RRspace_inf (D E : DivisorA k K) : + RRspace k K (D ⊓ E) = RRspace k K D ⊓ RRspace k K E := by + ext f + simp only [Submodule.mem_inf, mem_RRspace_iff] + constructor + · intro hf + exact ⟨memRRspace.memRRspace_mono (k := k) (K := K) inf_le_left hf, + memRRspace.memRRspace_mono (k := k) (K := K) inf_le_right hf⟩ + · rintro ⟨hD, hE⟩ v + change placeValuation k K v f ≤ WithZero.exp ((D ⊓ E) v) + rw [Finsupp.inf_apply] + by_cases h : D v ≤ E v + · rw [inf_eq_left.mpr h] + exact hD v + · rw [inf_eq_right.mpr (le_of_not_ge h)] + exact hE v + +omit [IsFullConstantField k K] in +/-- The sum of two Riemann–Roch spaces lies in the space of the supremum divisor. -/ +theorem RRspace_sup_le (D E : DivisorA k K) : + RRspace k K D ⊔ RRspace k K E ≤ RRspace k K (D ⊔ E) := by + rw [sup_le_iff] + exact ⟨RRspace_mono k K le_sup_left, RRspace_mono k K le_sup_right⟩ + +omit [IsFullConstantField k K] in +/-- Riemann–Roch dimension is submodular on the divisor lattice. -/ +theorem ell_submodular (D E : DivisorA k K) : + ell k K D + ell k K E ≤ ell k K (D ⊔ E) + ell k K (D ⊓ E) := by + let : FiniteDimensional k (RRspace k K D) := finiteDimensional_RRspace_aux k K D + let : FiniteDimensional k (RRspace k K E) := finiteDimensional_RRspace_aux k K E + have hsup : Module.finrank k ↑(RRspace k K D ⊔ RRspace k K E) ≤ + Module.finrank k (RRspace k K (D ⊔ E)) := + Submodule.finrank_mono (RRspace_sup_le k K D E) + have hdim := Submodule.finrank_sup_add_finrank_inf_eq + (RRspace k K D) (RRspace k K E) + rw [← RRspace_inf k K D E] at hdim + dsimp only [ell] + omega + +omit [IsFullConstantField k K] in +/-- Every positive-dimensional complete linear system has a representative minimal under +removing one copy of any place. -/ +theorem exists_minimal_RRspace (A : DivisorA k K) (hA : 0 < ell k K A) : + ∃ D₀ : DivisorA k K, D₀ ≤ A ∧ RRspace k K D₀ = RRspace k K A ∧ + ∀ v : PlaceA k K, ell k K (D₀ - Finsupp.single v 1) < ell k K D₀ := by + let S : Set ℕ := {n | ∃ D : DivisorA k K, + D ≤ A ∧ RRspace k K D = RRspace k K A ∧ deg k K D = (n : ℤ)} + have hdegA : 0 ≤ deg k K A := by + obtain ⟨x, hx⟩ := exists_effective_add_principal_of_ell_pos k K A hA + have hdeg := deg_nonneg k K hx + rw [deg_add, deg_principalDivisor_eq_zero k K x, add_zero] at hdeg + exact hdeg + have hS : S.Nonempty := by + refine ⟨(deg k K A).toNat, A, le_rfl, rfl, ?_⟩ + exact (Int.toNat_of_nonneg hdegA).symm + obtain ⟨D₀, hD₀A, hspace, hdegD₀⟩ := Nat.sInf_mem hS + refine ⟨D₀, hD₀A, hspace, fun v => ?_⟩ + have hle : D₀ - Finsupp.single v 1 ≤ D₀ := by + intro w + simp only [Finsupp.sub_apply] + exact sub_le_self _ (Finsupp.single_nonneg.mpr (by omega) w) + have hell_le : ell k K (D₀ - Finsupp.single v 1) ≤ ell k K D₀ := + Submodule.finrank_mono (RRspace_mono k K hle) + rw [lt_iff_le_and_ne] + refine ⟨hell_le, ?_⟩ + intro hell_eq + have : FiniteDimensional k (RRspace k K D₀) := finiteDimensional_RRspace_aux k K D₀ + have hspace_sub : RRspace k K (D₀ - Finsupp.single v 1) = RRspace k K D₀ := + Submodule.eq_of_le_of_finrank_eq (RRspace_mono k K hle) hell_eq + have hdegsub_nonneg : 0 ≤ deg k K (D₀ - Finsupp.single v 1) := by + have hpos : 0 < ell k K (D₀ - Finsupp.single v 1) := by + rw [hell_eq] + dsimp only [ell] at hA ⊢ + rw [hspace] + exact hA + obtain ⟨x, hx⟩ := exists_effective_add_principal_of_ell_pos k K _ hpos + have hdeg := deg_nonneg k K hx + rw [deg_add, deg_principalDivisor_eq_zero k K x, add_zero] at hdeg + exact hdeg + let m := (deg k K (D₀ - Finsupp.single v 1)).toNat + have hmcast : (m : ℤ) = deg k K (D₀ - Finsupp.single v 1) := + Int.toNat_of_nonneg hdegsub_nonneg + have hmS : m ∈ S := by + refine ⟨D₀ - Finsupp.single v 1, hle.trans hD₀A, ?_, hmcast.symm⟩ + exact hspace_sub.trans hspace + have hmin := Nat.sInf_le hmS + have hdegdrop : deg k K (D₀ - Finsupp.single v 1) < deg k K D₀ := by + rw [deg_sub, deg_single] + have hv := placeDegree_pos k K v + omega + rw [hdegD₀, ← hmcast] at hdegdrop + exact (not_lt_of_ge hmin) (by exact_mod_cast hdegdrop) + +omit [IsFullConstantField k K] in +/-- Over an infinite constant field, finitely many one-place drops from a minimal complete +linear system can be avoided simultaneously. -/ +theorem exists_RRspace_avoiding [Infinite k] (D₀ : DivisorA k K) + (s : Finset (PlaceA k K)) + (hdrop : ∀ v ∈ s, ell k K (D₀ - Finsupp.single v 1) < ell k K D₀) : + ∃ z : RRspace k K D₀, ∀ v ∈ s, + (z : K) ∉ RRspace k K (D₀ - Finsupp.single v 1) := by + let p : {v // v ∈ s} → Submodule k (RRspace k K D₀) := fun v => + Submodule.comap (RRspace k K D₀).subtype + (RRspace k K (D₀ - Finsupp.single v.1 1)) + have hp : ∀ v, p v ≠ ⊤ := by + intro v hv + have hrev : RRspace k K D₀ ≤ RRspace k K (D₀ - Finsupp.single v.1 1) := + Submodule.comap_subtype_eq_top.mp hv + have hle : D₀ - Finsupp.single v.1 1 ≤ D₀ := by + intro w + simp only [Finsupp.sub_apply] + exact sub_le_self _ (Finsupp.single_nonneg.mpr (by omega) w) + have heq : RRspace k K (D₀ - Finsupp.single v.1 1) = RRspace k K D₀ := + le_antisymm (RRspace_mono k K hle) hrev + have hell : ell k K (D₀ - Finsupp.single v.1 1) = ell k K D₀ := by + dsimp only [ell] + rw [heq] + exact (ne_of_lt (hdrop v.1 v.2)) hell + obtain ⟨z, hz⟩ := Submodule.exists_forall_notMem_of_forall_ne_top p hp + refine ⟨z, fun v hv hmem => ?_⟩ + exact hz ⟨v, hv⟩ (by + simpa only [p, Submodule.mem_comap, Submodule.coe_subtype] using hmem) + +omit [Algebra k K] [IsScalarTower k k[X] K] [IsFullConstantField k K] in +/-- Membership of a nonzero function in `L(D)` expressed coefficientwise through its principal +divisor. -/ +theorem memRRspace_iff_neg_principalDivisor_le {D : DivisorA k K} {f : K} + (hf : f ≠ 0) : + memRRspace k K D f ↔ ∀ v, -(principalDivisorA k K + (Additive.ofMul (Units.mk0 f hf)) v) ≤ D v := by + constructor + · intro h v + have hv := h v + have hval := placeValuation_eq_exp_neg_principalDivisor k K + (Additive.ofMul (Units.mk0 f hf)) v + change placeValuation k K v f ≤ WithZero.exp (D v) at hv + change placeValuation k K v f = WithZero.exp + (-(principalDivisorA k K (Additive.ofMul (Units.mk0 f hf)) v)) at hval + rw [hval] at hv + exact WithZero.exp_le_exp.mp hv + · intro h v + have hval := placeValuation_eq_exp_neg_principalDivisor k K + (Additive.ofMul (Units.mk0 f hf)) v + change placeValuation k K v f ≤ WithZero.exp (D v) + change placeValuation k K v f = WithZero.exp + (-(principalDivisorA k K (Additive.ofMul (Units.mk0 f hf)) v)) at hval + rw [hval] + exact WithZero.exp_le_exp.mpr (h v) + +/-- If multiplication by a section that is exact at every place in `supp B` creates no new +poles, the other factor is constant. -/ +theorem eq_algebraMap_of_mul_mem {D₀ B : DivisorA k K} (hB0 : B ≠ 0) {z x : K} + (hz : memRRspace k K D₀ z) + (havoid : ∀ v ∈ B.support, z ∉ RRspace k K (D₀ - Finsupp.single v 1)) + (hx : memRRspace k K B x) (hmul : memRRspace k K D₀ (x * z)) : + ∃ c : k, x = algebraMap k K c := by + have hsupp : B.support.Nonempty := Finsupp.support_nonempty_iff.mpr hB0 + obtain ⟨v₀, hv₀⟩ := hsupp + have hz0 : z ≠ 0 := by + intro hz0 + subst z + exact havoid v₀ hv₀ (memRRspace.zero_mem (k := k) (K := K) _) + by_cases hx0 : x = 0 + · exact ⟨0, by simp [hx0]⟩ + have hxz0 : x * z ≠ 0 := mul_ne_zero hx0 hz0 + let ux : Kˣ := Units.mk0 x hx0 + let uz : Kˣ := Units.mk0 z hz0 + let uxz : Kˣ := Units.mk0 (x * z) hxz0 + have hxdiv := (memRRspace_iff_neg_principalDivisor_le k K hx0).mp hx + have hzdiv := (memRRspace_iff_neg_principalDivisor_le k K hz0).mp hz + have hmuldiv := (memRRspace_iff_neg_principalDivisor_le k K hxz0).mp hmul + change ∀ v, -(principalDivisorA k K (Additive.ofMul ux) v) ≤ B v at hxdiv + change ∀ v, -(principalDivisorA k K (Additive.ofMul uz) v) ≤ D₀ v at hzdiv + change ∀ v, -(principalDivisorA k K (Additive.ofMul uxz) v) ≤ D₀ v at hmuldiv + have hvalx : ∀ v : PlaceA k K, placeValuation k K v x ≤ 1 := by + intro v + have hdivx : 0 ≤ principalDivisorA k K (Additive.ofMul ux) v := by + by_cases hv : v ∈ B.support + · have hzexact : -(principalDivisorA k K (Additive.ofMul uz) v) = D₀ v := by + have hle := hzdiv v + have hnle : ¬ -(principalDivisorA k K (Additive.ofMul uz) v) ≤ D₀ v - 1 := by + intro hsmall + apply havoid v hv + rw [mem_RRspace_iff] + apply (memRRspace_iff_neg_principalDivisor_le k K hz0).mpr + intro w + by_cases hw : w = v + · subst w + simpa using hsmall + · simpa [Finsupp.single_apply, hw] using hzdiv w + omega + have hdivmul : principalDivisorA k K (Additive.ofMul uxz) v = + principalDivisorA k K (Additive.ofMul ux) v + + principalDivisorA k K (Additive.ofMul uz) v := by + have hu : uxz = ux * uz := by + apply Units.ext + rfl + rw [hu, ofMul_mul, (principalDivisorA k K).map_add, Finsupp.add_apply] + have hp := hmuldiv v + rw [hdivmul] at hp + omega + · have hBv : B v = 0 := Finsupp.notMem_support_iff.mp hv + have hp := hxdiv v + rw [hBv] at hp + omega + have hval := placeValuation_eq_exp_neg_principalDivisor k K + (Additive.ofMul ux) v + change placeValuation k K v x = WithZero.exp + (-(principalDivisorA k K (Additive.ofMul ux) v)) at hval + rw [hval, ← WithZero.exp_zero] + exact WithZero.exp_le_exp.mpr (by omega) + exact IsFullConstantField.algebraic_mem (k := k) (K := K) x + (isAlgebraic_of_placeValuation_le_one k K x hvalx) + +/-- Stichtenoth's key Clifford inequality for an effective nonzero second divisor and a first +divisor minimal under one-place drops. -/ +theorem ell_add_ell_le_of_effective_minimal [Infinite k] + (D₀ B : DivisorA k K) (hB : IsEffective k K B) (hB0 : B ≠ 0) + (hdrop : ∀ v ∈ B.support, + ell k K (D₀ - Finsupp.single v 1) < ell k K D₀) : + ell k K D₀ + ell k K B ≤ 1 + ell k K (D₀ + B) := by + obtain ⟨z, hzavoid⟩ := exists_RRspace_avoiding k K D₀ B.support hdrop + let T := RRspace k K (D₀ + B) + let P : Submodule k T := Submodule.comap T.subtype (RRspace k K D₀) + let mulZ : RRspace k K B →ₗ[k] T := { + toFun x := ⟨(x : K) * (z : K), by + rw [mem_RRspace_iff] + simpa only [add_comm] using memRRspace.mul_mem (k := k) (K := K) + ((mem_RRspace_iff k K B (x : K)).mp x.property) + ((mem_RRspace_iff k K D₀ (z : K)).mp z.property)⟩ + map_add' x y := Subtype.ext (add_mul (x : K) (y : K) (z : K)) + map_smul' c x := Subtype.ext (by + simp only [Submodule.coe_smul_of_tower, RingHom.id_apply, Algebra.smul_def] + ring) } + let φ : RRspace k K B →ₗ[k] T ⧸ P := P.mkQ.comp mulZ + have hone_mem : memRRspace k K B (1 : K) := + memRRspace.memRRspace_mono (k := k) (K := K) (show (0 : DivisorA k K) ≤ B from hB) + (memRRspace.one_mem (k := k) (K := K)) + let oneB : RRspace k K B := ⟨1, hone_mem⟩ + have hker_le : φ.ker ≤ k ∙ oneB := by + intro x hxker + have hq : P.mkQ (mulZ x) = 0 := by + exact hxker + have hp : mulZ x ∈ P := Submodule.Quotient.mk_eq_zero P |>.mp hq + have hmul : memRRspace k K D₀ ((x : K) * (z : K)) := by + exact hp + obtain ⟨c, hc⟩ := eq_algebraMap_of_mul_mem k K hB0 + ((mem_RRspace_iff k K D₀ (z : K)).mp z.property) hzavoid + ((mem_RRspace_iff k K B (x : K)).mp x.property) hmul + have hxeq : x = c • oneB := by + apply Subtype.ext + simp only [Submodule.coe_smul_of_tower, oneB, Algebra.smul_def] + rw [hc, mul_one] + rw [hxeq] + exact Submodule.smul_mem _ c (Submodule.mem_span_singleton_self oneB) + have hker_ge : k ∙ oneB ≤ φ.ker := by + rw [Submodule.span_singleton_le_iff_mem] + rw [LinearMap.mem_ker] + change P.mkQ (mulZ oneB) = 0 + apply (Submodule.Quotient.mk_eq_zero P).mpr + change (1 : K) * (z : K) ∈ RRspace k K D₀ + simpa only [one_mul] using z.property + have hker : φ.ker = k ∙ oneB := le_antisymm hker_le hker_ge + have honeB : oneB ≠ 0 := by + intro h + have hc := congr_arg (fun q : RRspace k K B => (q : K)) h + change (1 : K) = 0 at hc + exact one_ne_zero hc + have hfinKer : Module.finrank k φ.ker = 1 := by + rw [hker, finrank_span_singleton honeB] + have hDle : RRspace k K D₀ ≤ T := by + exact RRspace_mono k K (show D₀ ≤ D₀ + B by + intro v + simp only [Finsupp.add_apply] + linarith [hB v]) + have hmapP : P.map T.subtype = RRspace k K D₀ := by + dsimp only [P] + rw [Submodule.map_comap_subtype, inf_eq_right.mpr hDle] + have hfinP : Module.finrank k P = ell k K D₀ := by + rw [← Submodule.finrank_map_subtype_eq T P, hmapP] + rfl + let : FiniteDimensional k (RRspace k K B) := finiteDimensional_RRspace_aux k K B + let : FiniteDimensional k T := finiteDimensional_RRspace_aux k K (D₀ + B) + have hranknull := φ.finrank_range_add_finrank_ker + have hrange : Module.finrank k φ.range ≤ Module.finrank k (T ⧸ P) := by + simpa only [finrank_top] using + Submodule.finrank_mono (show φ.range ≤ (⊤ : Submodule k (T ⧸ P)) from le_top) + have hquot := P.finrank_quotient_add_finrank + dsimp only [ell] at hfinP + rw [hfinKer] at hranknull + rw [hfinP] at hquot + dsimp only [ell] at ⊢ + change Module.finrank k (RRspace k K D₀) + Module.finrank k (RRspace k K B) ≤ + 1 + Module.finrank k T + omega + +/-- Stichtenoth Lemma 1.6.14 over an infinite full constant field. -/ +theorem ell_add_ell_le_infinite [Infinite k] + (A B : DivisorA k K) (hA : 0 < ell k K A) (hB : 0 < ell k K B) : + ell k K A + ell k K B ≤ 1 + ell k K (A + B) := by + obtain ⟨x, hxeff⟩ := exists_effective_add_principal_of_ell_pos k K A hA + obtain ⟨y, hyeff⟩ := exists_effective_add_principal_of_ell_pos k K B hB + let A₀ := A + principalDivisorA k K (Additive.ofMul x) + let B₀ := B + principalDivisorA k K (Additive.ofMul y) + have hellA₀ : ell k K A₀ = ell k K A := ell_add_principal k K A x + have hellB₀ : ell k K B₀ = ell k K B := ell_add_principal k K B y + have hA₀pos : 0 < ell k K A₀ := hellA₀.symm ▸ hA + obtain ⟨D₀, hD₀le, hspace, hdrop⟩ := exists_minimal_RRspace k K A₀ hA₀pos + have hellD₀ : ell k K D₀ = ell k K A₀ := by + dsimp only [ell] + rw [hspace] + have hle : D₀ + B₀ ≤ A₀ + B₀ := by + intro v + simp only [Finsupp.add_apply] + linarith [hD₀le v] + have hell_mono : ell k K (D₀ + B₀) ≤ ell k K (A₀ + B₀) := + Submodule.finrank_mono (RRspace_mono k K hle) + have hsum : A₀ + B₀ = (A + B) + + principalDivisorA k K (Additive.ofMul (x * y)) := by + dsimp only [A₀, B₀] + rw [ofMul_mul, (principalDivisorA k K).map_add] + abel + have hellsum : ell k K (A₀ + B₀) = ell k K (A + B) := by + rw [hsum, ell_add_principal] + by_cases hB₀0 : B₀ = 0 + · have hellB₀one : ell k K B₀ = 1 := by + rw [hB₀0, ell_zero k K] + have hellsum0 : ell k K A₀ = ell k K (A + B) := by + simpa only [hB₀0, add_zero] using hellsum + rw [← hellA₀, ← hellB₀, hellB₀one, ← hellsum0] + omega + · have hkey := ell_add_ell_le_of_effective_minimal k K D₀ B₀ hyeff hB₀0 + (fun v _ => hdrop v) + rw [← hellA₀, ← hellB₀, ← hellsum] + omega + +/-- Stichtenoth Lemma 1.6.14 over an arbitrary full constant field. This is the +Riemann–Roch-space specialization of `mul_finrank`. -/ +theorem ell_add_ell_le (A B : DivisorA k K) (hA : 0 < ell k K A) + (hB : 0 < ell k K B) : + ell k K A + ell k K B ≤ 1 + ell k K (A + B) := by + let : FiniteDimensional k (RRspace k K A) := finiteDimensional_RRspace_aux k K A + let : FiniteDimensional k (RRspace k K B) := finiteDimensional_RRspace_aux k K B + have hAne : RRspace k K A ≠ ⊥ := by + intro hzero + dsimp only [ell] at hA + rw [hzero, finrank_bot] at hA + omega + have hBne : RRspace k K B ≠ ⊥ := by + intro hzero + dsimp only [ell] at hB + rw [hzero, finrank_bot] at hB + omega + have hAfg : (RRspace k K A).FG := + (Submodule.fg_top (RRspace k K A)).mp Module.Finite.fg_top + have hBfg : (RRspace k K B).FG := + (Submodule.fg_top (RRspace k K B)).mp Module.Finite.fg_top + let : FiniteDimensional k (RRspace k K A * RRspace k K B) := + Module.Finite.of_fg (hAfg.mul hBfg) + have hproduct := mul_finrank k K (RRspace k K A) (RRspace k K B) hAne hBne + have hmul : RRspace k K A * RRspace k K B ≤ RRspace k K (A + B) := by + apply Submodule.mul_le.mpr + intro x hx y hy + rw [mem_RRspace_iff] at hx hy ⊢ + exact memRRspace.mul_mem (k := k) (K := K) hx hy + have hmono : Module.finrank k (RRspace k K A * RRspace k K B) ≤ + Module.finrank k (RRspace k K (A + B)) := + Submodule.finrank_mono hmul + dsimp only [ell] + omega + +/-- The core Clifford inequality: with `W` canonical, whenever both `ℓ(D)` and `ℓ(W − D)` are +positive, `2(ℓ(D) − 1) ≤ deg D`. The textbook degree bounds +`0 ≤ deg D ≤ 2g − 2` are **not** required — positivity of both dimensions, the linear +product bound, and Riemann–Roch suffice. -/ +theorem clifford_of_ell_pos {W : DivisorA k K} (hW : IsCanonical k K W) (D : DivisorA k K) + (hℓD : 0 < ell k K D) (hℓW : 0 < ell k K (W - D)) : + 2 * ((ell k K D : ℤ) - 1) ≤ deg k K D := by + have hkey := ell_add_ell_le k K D (W - D) hℓD hℓW + have hsum : D + (W - D) = W := by abel + rw [hsum, ell_canonical k K hW] at hkey + have hRR := riemann_roch k K hW D + omega + +/-- **C5** (Clifford): if `0 ≤ deg D ≤ 2g − 2` and both `ℓ(D)` and `ℓ(W − D)` are +positive, then `2(ℓ(D) − 1) ≤ deg D`. This is the conventional textbook statement; the degree +hypotheses are kept for fidelity but are not needed for the inequality (see +`clifford_of_ell_pos`). -/ +theorem clifford {W : DivisorA k K} (hW : IsCanonical k K W) (D : DivisorA k K) + (_hdeg₀ : 0 ≤ deg k K D) (_hdeg₁ : deg k K D ≤ 2 * (genus k K : ℤ) - 2) + (hℓD : 0 < ell k K D) (hℓW : 0 < ell k K (W - D)) : + 2 * ((ell k K D : ℤ) - 1) ≤ deg k K D := + clifford_of_ell_pos k K hW D hℓD hℓW + +/-- **C6** (field-independent form): a divisor attaining the maximal defect is nonspecial. +The stronger assertion that one can choose an effective divisor of degree `g` requires +additional hypotheses on the constant field and is not valid over every field. -/ +theorem exists_nonspecial_divisor : + ∃ D : DivisorA k K, indexOfSpecialty k K D = 0 := by + obtain ⟨D, hD⟩ := exists_defect_eq k K + refine ⟨D, ?_⟩ + have hi := indexOfSpecialty_eq k K D + simp only [defect] at hD + omega + +end FunctionField.Chart + +end diff --git a/LeanPool/MarkoffModP/RiemannRoch/SeparableRelNorm.lean b/LeanPool/MarkoffModP/RiemannRoch/SeparableRelNorm.lean new file mode 100644 index 0000000000..9aabd67be3 --- /dev/null +++ b/LeanPool/MarkoffModP/RiemannRoch/SeparableRelNorm.lean @@ -0,0 +1,185 @@ +/- +Copyright (c) 2026 Guanghao Li. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Guanghao Li +-/ + +module + +public import Mathlib.RingTheory.Ideal.Norm.RelNorm +public import Mathlib.FieldTheory.SeparableClosure + +/-! +# Relative norms in finite separable extensions + +Mathlib's theorem `Ideal.relNorm_eq_pow_of_isMaximal` assumes that the fraction field of the +base Dedekind domain is perfect. For function fields the needed hypothesis is instead already +available in its sharp form: the particular fraction-field extension is separable. This file +records that variant, using the same normal-closure argument as the Mathlib theorem. +-/ + +@[expose] public section + +open Module +open UniqueFactorizationMonoid +open scoped nonZeroDivisors + +namespace Ideal + + +variable {R S : Type*} [CommRing R] [CommRing S] + [IsDedekindDomain R] [IsDedekindDomain S] + [Algebra R S] [Module.Finite R S] [IsTorsionFree R S] + +/-- The relative norm of a maximal ideal in a finite separable extension is the corresponding +prime below, raised to the inertia degree. This is the separable-extension variant of +`Ideal.relNorm_eq_pow_of_isMaximal`. -/ +theorem relNorm_eq_pow_of_isMaximal_of_isSeparable + [@Algebra.IsSeparable (FractionRing R) (FractionRing S) _ _ + (FractionRing.liftAlgebra R (FractionRing S))] + (P : Ideal S) (p : Ideal R) [P.LiesOver p] [P.IsMaximal] [p.IsMaximal] : + relNorm R P = p ^ P.inertiaDeg R := by + let K := FractionRing R + let L := FractionRing S + let : Algebra K L := FractionRing.liftAlgebra R L + let E := IntermediateField.normalClosure K L (AlgebraicClosure L) + let : Algebra S E := ((algebraMap L E).comp (algebraMap S L)).toAlgebra + let : IsScalarTower S L E := IsScalarTower.of_algebraMap_eq' rfl + let T : Type _ := integralClosure S E + let : Algebra S T := inferInstance + let : Algebra T E := inferInstance + let : IsScalarTower S T E := inferInstance + let : Algebra R T := ((algebraMap S T).comp (algebraMap R S)).toAlgebra + let : IsScalarTower R S T := IsScalarTower.of_algebraMap_eq' rfl + let : Algebra R E := ((algebraMap S E).comp (algebraMap R S)).toAlgebra + let : IsScalarTower R S E := IsScalarTower.of_algebraMap_eq' rfl + let : IsScalarTower R T E := IsScalarTower.to₁₃₄ R S T E + let : FaithfulSMul R E := (faithfulSMul_iff_algebraMap_injective R E).2 <| by + rw [IsScalarTower.algebraMap_eq R S E] + exact (algebraMap L E).injective.comp (IsFractionRing.injective S L) |>.comp + (FaithfulSMul.algebraMap_injective R S) + let : IsScalarTower R S L := inferInstance + let : FaithfulSMul R L := inferInstance + let : IsScalarTower R L E := IsScalarTower.to₁₃₄ R S L E + let : IsScalarTower R K L := FractionRing.isScalarTower_liftAlgebra R L + let : IsScalarTower R K E := IsScalarTower.to₁₂₄ R K L E + let : IsIntegralClosure T S E := integralClosure.isIntegralClosure S E + let : FaithfulSMul S T := (faithfulSMul_iff_algebraMap_injective S T).2 <| by + intro x y hxy + apply (algebraMap L E).injective.comp (IsFractionRing.injective S L) + exact congrArg (fun z : T => (algebraMap T E) z) hxy + let : FaithfulSMul R T := (faithfulSMul_iff_algebraMap_injective R T).2 <| by + rw [IsScalarTower.algebraMap_eq R S T] + exact (FaithfulSMul.algebraMap_injective S T).comp + (FaithfulSMul.algebraMap_injective R S) + let : FiniteDimensional K E := + normalClosure.is_finiteDimensional K L (AlgebraicClosure L) + let : Algebra.IsSeparable K E := by + rw [← le_separableClosure_iff] + apply normalClosure_le_iff.mpr + intro i + have : Algebra.IsSeparable K i.fieldRange := + AlgEquiv.Algebra.isSeparable (AlgEquiv.ofInjectiveField i) + exact le_separableClosure K (AlgebraicClosure L) i.fieldRange + let : Algebra.IsSeparable L E := + Algebra.isSeparable_tower_top_of_isSeparable K L E + let : FiniteDimensional L E := Module.Finite.right K L E + let : IsFractionRing T E := + IsIntegralClosure.isFractionRing_of_finite_extension S L E T + let : Module.Finite S T := IsIntegralClosure.finite S L E T + let : Module.Finite R T := Module.Finite.trans S T + let : IsDedekindDomain T := integralClosure.isDedekindDomain S L E + have : IsTorsionFree S T := FaithfulSMul.to_isTorsionFree S T + let : IsGalois K E := { + to_isSeparable := inferInstance + to_normal := normalClosure.normal K L (AlgebraicClosure L) } + let algT : Algebra T (FractionRing T) := inferInstance + let : Algebra T (FractionRing T) := algT + let : Algebra R (FractionRing T) := inferInstance + let : Algebra S (FractionRing T) := inferInstance + let : FaithfulSMul R (FractionRing T) := inferInstance + let : FaithfulSMul S (FractionRing T) := inferInstance + let : Algebra K (FractionRing T) := FractionRing.liftAlgebra R (FractionRing T) + let : Algebra L (FractionRing T) := FractionRing.liftAlgebra S (FractionRing T) + let : IsScalarTower R K (FractionRing T) := + FractionRing.isScalarTower_liftAlgebra R (FractionRing T) + let : IsScalarTower S L (FractionRing T) := + FractionRing.isScalarTower_liftAlgebra S (FractionRing T) + let : IsGalois K (FractionRing T) := by + refine IsGalois.of_equiv_equiv (F := K) (E := E) + (f := (FractionRing.algEquiv R K).symm.toRingEquiv) + (g := (FractionRing.algEquiv T E).symm.toRingEquiv) ?_ + ext + simpa using! IsFractionRing.algEquiv_commutes (FractionRing.algEquiv R K).symm + (FractionRing.algEquiv T E).symm _ + obtain ⟨Q, hQ₁, hQ₂⟩ : ∃ Q : Ideal T, Q.IsMaximal ∧ Q.LiesOver P := + exists_maximal_ideal_liesOver_of_isIntegral P + let : Q.IsMaximal := hQ₁ + let : Q.LiesOver P := hQ₂ + let : Q.LiesOver p := LiesOver.trans Q P p + have h := relNorm_eq_pow_of_isPrime_isGalois Q p + let : IsGalois (FractionRing S) (FractionRing T) := + IsGalois.tower_top_of_isGalois (FractionRing R) (FractionRing S) (FractionRing T) + rwa [← relNorm_relNorm R S, relNorm_eq_pow_of_isPrime_isGalois Q P, map_pow, + inertiaDeg_tower (R := R) P Q, pow_mul, + pow_left_inj (inertiaDeg_pos Q S).ne'] at h + +/-- Relative norm preserves the weighted sum of prime factors, with each prime upstairs weighted +by its inertia degree over the prime below. -/ +theorem sum_normalizedFactors_relNorm_of_isSeparable + [@Algebra.IsSeparable (FractionRing R) (FractionRing S) _ _ + (FractionRing.liftAlgebra R (FractionRing S))] + (I : Ideal S) (hI : I ≠ ⊥) (w : Ideal R → ℕ) : + ((normalizedFactors (relNorm R I)).map w).sum = + ((normalizedFactors I).map fun P => + P.inertiaDeg R * w (P.under R)).sum := by + classical + let : Algebra (FractionRing R) (FractionRing S) := + FractionRing.liftAlgebra R (FractionRing S) + have aux : ∀ s : Multiset (Ideal S), (∀ P ∈ s, Prime P) → + ((normalizedFactors (relNorm R s.prod)).map w).sum = + (s.map fun P => P.inertiaDeg R * w (P.under R)).sum := by + intro s hs + induction s using Multiset.induction_on with + | empty => + rw [Multiset.prod_zero, map_one] + simp only [normalizedFactors_one, Multiset.map_zero, Multiset.sum_zero] + | @cons P s ih => + have hP : Prime P := hs P (Multiset.mem_cons_self P s) + have hs' : ∀ Q ∈ s, Prime Q := fun Q hQ => hs Q (Multiset.mem_cons_of_mem hQ) + have hP0 : P ≠ ⊥ := hP.ne_zero + have hs0 : s.prod ≠ ⊥ := Multiset.prod_ne_zero fun h => + (hs' ⊥ h).ne_zero rfl + let p : Ideal R := P.under R + let : P.IsMaximal := (Ideal.isPrime_of_prime hP).isMaximal hP0 + let : p.IsMaximal := Ideal.IsMaximal.under R P + let : P.LiesOver p := ⟨rfl⟩ + have hp0 : p ≠ ⊥ := by + intro hp + have : P.LiesOver (⊥ : Ideal R) := hp ▸ (inferInstance : P.LiesOver p) + exact hP0 (Ideal.eq_bot_of_liesOver_bot R P) + have hnorm : relNorm R P = p ^ P.inertiaDeg R := + relNorm_eq_pow_of_isMaximal_of_isSeparable P p + have hnormP0 : relNorm R P ≠ ⊥ := (relNorm_eq_bot_iff.not.mpr hP0) + have hnorms0 : relNorm R s.prod ≠ ⊥ := + relNorm_eq_bot_iff.not.mpr hs0 + rw [Multiset.prod_cons, map_mul, normalizedFactors_mul hnormP0 hnorms0, + Multiset.map_add, Multiset.sum_add, hnorm, normalizedFactors_pow, + UniqueFactorizationMonoid.normalizedFactors_irreducible + (Ideal.prime_of_isPrime hp0 + (inferInstance : p.IsMaximal).isPrime).irreducible, + normalize_eq, Multiset.nsmul_singleton] + simp [ih hs', p] + let s := normalizedFactors I + have hsprod : s.prod = I := prod_normalizedFactors_eq_self hI + calc + ((normalizedFactors (relNorm R I)).map w).sum = + ((normalizedFactors (relNorm R s.prod)).map w).sum := by rw [hsprod] + _ = (s.map fun P => P.inertiaDeg R * w (P.under R)).sum := by + apply aux s + intro P hP + exact UniqueFactorizationMonoid.prime_of_normalized_factor P hP + _ = ((normalizedFactors I).map fun P => + P.inertiaDeg R * w (P.under R)).sum := rfl + +end Ideal diff --git a/LeanPool/MarkoffModP/RiemannRoch/WeilDifferential.lean b/LeanPool/MarkoffModP/RiemannRoch/WeilDifferential.lean new file mode 100644 index 0000000000..e79220f368 --- /dev/null +++ b/LeanPool/MarkoffModP/RiemannRoch/WeilDifferential.lean @@ -0,0 +1,9 @@ +/- +Copyright (c) 2026 Guanghao Li. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Guanghao Li +-/ + +module + +public import LeanPool.MarkoffModP.RiemannRoch.WeilDifferential.Basic diff --git a/LeanPool/MarkoffModP/RiemannRoch/WeilDifferential/Basic.lean b/LeanPool/MarkoffModP/RiemannRoch/WeilDifferential/Basic.lean new file mode 100644 index 0000000000..50c0e51cf0 --- /dev/null +++ b/LeanPool/MarkoffModP/RiemannRoch/WeilDifferential/Basic.lean @@ -0,0 +1,847 @@ +/- +Copyright (c) 2026 Guanghao Li. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Guanghao Li +-/ + +module + +public import LeanPool.MarkoffModP.RiemannRoch.Genus.Basic +public import LeanPool.MarkoffModP.RiemannRoch.Genus.AdeleQuotient +public import Mathlib.LinearAlgebra.Dual.Lemmas + +/-! +# Weil differentials and the duality theorem +This file defines Weil differentials, the canonical divisor class, and the duality theorem +that identifies `L(W − D)` with `Ω(D)`. + +## Main definitions + +* `FunctionField.WeilDifferential` +* `FunctionField.WeilDifferential.differentialSpace` +* `FunctionField.WeilDifferential.divOmega` +* `FunctionField.IsCanonical` + +## Main results + +* `FunctionField.WeilDifferential.finrank_weilDifferential_eq_one` +* `FunctionField.isCanonical_unique_up_to_principal` +* `FunctionField.duality` +-/ + +@[expose] public section + +open scoped nonZeroDivisors Polynomial RatFunc WithZero + +noncomputable section + +namespace FunctionField.Chart + +variable (k K : Type*) [Field k] [Field K] + +variable [Algebra k K] [Algebra k[X] K] [Algebra k⟮X⟯ K] [IsScalarTower k k[X] K] + [IsScalarTower k[X] k⟮X⟯ K] [_root_.FunctionField k K] + [Algebra.IsSeparable k⟮X⟯ K] + +variable [IsFullConstantField k K] + +/-- The classical decidable equality on `k(X)` used by the coordinate places. -/ +local instance instDecidableEqRatFuncWeil : DecidableEq k⟮X⟯ := Classical.decEq _ + +attribute [local instance] adeleFiltAddCommGroup adeleFiltModule + +/-- The `k`- and `K`-scalar actions on the adele space are compatible. -/ +instance instIsScalarTowerAdeleSpace : IsScalarTower k K (AdeleSpace k K) := + ⟨fun c x a => Subtype.ext <| funext fun v => by + change (c • x) * a.val v = c • (x * a.val v) + rw [Algebra.smul_def, Algebra.smul_def, mul_assoc]⟩ + +omit [IsFullConstantField k K] in +/-- The sandwich quotient `A(D') ⧸ (A(D) + K̃) ⊓ A(D')` is finite-dimensional. -/ +theorem finite_adeleFilt_sub_quotient {D D' : DivisorA k K} (hle : D ≤ D') : + Module.Finite k ((adeleFilt k K D') ⧸ + Submodule.comap (adeleFilt k K D').subtype + (adeleFilt k K D + diagonalSubmodule k K)) := by + have hE : IsEffective k K (D' - D) := (le_iff_sub_effective k K).mp hle + have hdiv : D + (D' - D) = D' := by abel + have : Module.Finite k ((adeleFilt k K D') ⧸ + Submodule.comap (adeleFilt k K D').subtype (adeleFilt k K D)) := + finiteAdeleFiltDiff_quotient_add_eq k K (M := D) hdiv.symm hE + exact Module.Finite.equiv (Submodule.quotientQuotientEquivQuotient + (Submodule.comap (adeleFilt k K D').subtype (adeleFilt k K D)) + (Submodule.comap (adeleFilt k K D').subtype + (adeleFilt k K D + diagonalSubmodule k K)) + (Submodule.comap_mono (by + rw [Submodule.add_eq_sup] + exact le_sup_left))) + +/-- The adele class space `𝒜_K ⧸ (A(D) + K̃)` is finite-dimensional over `k`. -/ +instance finiteDimensional_adeleQuotient (D : DivisorA k K) : + FiniteDimensional k + ((AdeleSpace k K) ⧸ (adeleFilt k K D + diagonalSubmodule k K)) := by + obtain ⟨D₁, hD₁⟩ := exists_defect_eq (k := k) (K := K) + have hle : D ≤ D ⊔ D₁ := le_sup_left + have hfull : topAdeleSubmodule k K = + adeleFilt k K (D ⊔ D₁) + diagonalSubmodule k K := + adeleSubmodule_top_eq_adeleFilt_add_diagonal (k := k) (K := K) + (defect_eq_genus_of_ge (k := k) (K := K) le_sup_right hD₁) + have := finite_adeleFilt_sub_quotient (k := k) (K := K) hle + have hker : Submodule.comap (adeleFilt k K (D ⊔ D₁)).subtype + (adeleFilt k K D + diagonalSubmodule k K) ≤ + LinearMap.ker (((adeleFilt k K D + diagonalSubmodule k K).mkQ).comp + (adeleFilt k K (D ⊔ D₁)).subtype) := by + intro x hx + rw [LinearMap.mem_ker, LinearMap.comp_apply, Submodule.subtype_apply, + Submodule.mkQ_apply] + exact (Submodule.Quotient.mk_eq_zero _).mpr hx + refine Module.Finite.of_surjective (Submodule.liftQ _ _ hker) ?_ + intro y + obtain ⟨x, rfl⟩ := + Submodule.mkQ_surjective (adeleFilt k K D + diagonalSubmodule k K) y + have hx : x ∈ adeleFilt k K (D ⊔ D₁) + diagonalSubmodule k K := by + have hxtop : x ∈ topAdeleSubmodule k K := Submodule.mem_top + rwa [hfull] at hxtop + rcases Submodule.mem_sup.mp hx with ⟨a, ha, b, hb, rfl⟩ + refine ⟨Submodule.Quotient.mk ⟨a, ha⟩, ?_⟩ + rw [Submodule.liftQ_apply] + change (adeleFilt k K D + diagonalSubmodule k K).mkQ a = + (adeleFilt k K D + diagonalSubmodule k K).mkQ (a + b) + have hb0 : (adeleFilt k K D + diagonalSubmodule k K).mkQ b = 0 := by + rw [Submodule.mkQ_apply] + exact (Submodule.Quotient.mk_eq_zero _).mpr (Submodule.mem_sup_right hb) + rw [map_add, hb0, add_zero] + +omit [Algebra k K] [IsScalarTower k k[X] K] [IsFullConstantField k K] in +/-- If `D ≤ D'` and `deg D' ≤ deg D`, the divisors are equal. -/ +theorem eq_of_le_of_deg_le {D D' : DivisorA k K} (h : D ≤ D') + (hdeg : deg k K D' ≤ deg k K D) : D = D' := by + have hE : IsEffective k K (D' - D) := (le_iff_sub_effective k K).mp h + have hdeg0 : deg k K (D' - D) = 0 := by + have hge : 0 ≤ deg k K (D' - D) := deg_nonneg k K hE + rw [deg_sub] at hge ⊢ + omega + have hzero : D' - D = 0 := eq_zero_of_effective_deg_zero k K hE hdeg0 + exact (sub_eq_zero.mp hzero).symm + +/-- A Weil differential: a k-linear functional on adeles vanishing on some `A(D)+K̃`. -/ +structure WeilDifferential where + /-- The underlying `k`-linear functional on adeles. -/ + toFun : AdeleSpace k K →ₗ[k] k + /-- The functional vanishes on `A(D) + K̃` for some divisor `D`. -/ + vanishes_on : ∃ D : DivisorA k K, + ∀ α ∈ adeleFilt k K D + diagonalSubmodule k K, toFun α = 0 + +namespace WeilDifferential + +variable {k K} + +/-- A Weil differential is nonzero. -/ +def IsNonzero (ω : WeilDifferential k K) : Prop := ω.toFun ≠ 0 + +/-- The space `Ω(D)` of k-linear functionals vanishing on `A(D)+K̃`. -/ +def differentialSpace (D : DivisorA k K) : Submodule k (AdeleSpace k K →ₗ[k] k) where + carrier := {φ | ∀ a ∈ adeleFilt k K D + diagonalSubmodule k K, φ a = 0} + zero_mem' := by simp + add_mem' {f g} hf hg := by + intro a ha + simp [hf a ha, hg a ha] + smul_mem' c f hf := by + intro a ha + simp [hf a ha] + +theorem finrank_differentialSpace (D : DivisorA k K) : + Module.finrank k (differentialSpace D) = indexOfSpecialty k K D := by + let S := adeleFilt k K D + diagonalSubmodule k K + have homega : differentialSpace D = S.dualAnnihilator := by + ext φ + rw [Submodule.mem_dualAnnihilator] + change (∀ a ∈ adeleFilt k K D + diagonalSubmodule k K, φ a = 0) ↔ _ + rfl + rw [homega, ← S.dualQuotEquivDualAnnihilator.finrank_eq, Subspace.dual_finrank_eq] + exact finrank_adele_quotient k K D + +theorem exists_nontrivial_omega : + ∃ D : DivisorA k K, differentialSpace D ≠ ⊥ := by + let : IsScalarTower k k⟮X⟯ K := + IsScalarTower.of_algebraMap_eq fun c => by + rw [IsScalarTower.algebraMap_apply k k[X] K, + IsScalarTower.algebraMap_apply k[X] k⟮X⟯ K, + ← IsScalarTower.algebraMap_apply k k[X] k⟮X⟯] + let x : K := algebraMap k⟮X⟯ K (RatFunc.X : k⟮X⟯) + have hx : ¬IsAlgebraic k x := by + exact (transcendental_algebraMap_iff (algebraMap k⟮X⟯ K).injective).2 + RatFunc.transcendental_X + let E : DivisorA k K := polarDivisor k K x + let D : DivisorA k K := -(E + E) + have hE : 0 < deg k K E := polar_deg_pos k K hx + have hD : deg k K D < 0 := by + simp only [D, deg_neg, deg_add] + omega + have hℓ : ell k K D = 0 := RRspace_neg_deg_ell k K hD + have hi := indexOfSpecialty_eq k K D + have hindex : 0 < indexOfSpecialty k K D := by + have hg : 0 ≤ (genus k K : ℤ) := Int.natCast_nonneg _ + have hdegD : deg k K D = -(deg k K E + deg k K E) := by + simp only [D, deg_neg, deg_add] + rw [hℓ, hdegD] at hi + exact_mod_cast (show (0 : ℤ) < (indexOfSpecialty k K D : ℤ) by omega) + refine ⟨D, fun hbot => ?_⟩ + have hfin : 0 < Module.finrank k (differentialSpace D) := by + rw [finrank_differentialSpace] + exact hindex + rw [hbot, finrank_bot] at hfin + omega + +omit [IsFullConstantField k K] in +/-- Multiplication by a unit sends `A(D + (x)) + K̃` into `A(D) + K̃`. -/ +theorem mul_mem_adeleFilt_add_diagonal (x : Kˣ) (D : DivisorA k K) + {a : AdeleSpace k K} + (ha : a ∈ adeleFilt k K (D + principalDivisorA k K (Additive.ofMul x)) + + diagonalSubmodule k K) : + (x : K) • a ∈ adeleFilt k K D + diagonalSubmodule k K := by + rw [Submodule.add_eq_sup] at ha ⊢ + rcases Submodule.mem_sup.mp ha with ⟨a₁, ha₁, a₂, ha₂, rfl⟩ + refine Submodule.mem_sup.mpr ⟨(x : K) • a₁, ?_, (x : K) • a₂, ?_, + (smul_add (x : K) a₁ a₂).symm⟩ + · intro v + change placeValuation k K v ((x : K) * a₁.val v) ≤ WithZero.exp (D v) + rw [map_mul] + have hxval := placeValuation_eq_exp_neg_principalDivisor k K (Additive.ofMul x) v + change placeValuation k K v (x : K) = + WithZero.exp (-(principalDivisorA k K (Additive.ofMul x) v)) at hxval + rw [hxval] + have hv := ha₁ v + rw [Finsupp.add_apply, WithZero.exp_add] at hv + calc + WithZero.exp (-(principalDivisorA k K (Additive.ofMul x) v)) * + placeValuation k K v (a₁.val v) ≤ + WithZero.exp (-(principalDivisorA k K (Additive.ofMul x) v)) * + (WithZero.exp (D v) * + WithZero.exp (principalDivisorA k K (Additive.ofMul x) v)) := + mul_le_mul_right hv _ + _ = WithZero.exp (D v) := by + rw [← WithZero.exp_add, ← WithZero.exp_add] + congr 1 + ring + · rcases ha₂ with ⟨f, rfl⟩ + exact ⟨(x : K) * f, by ext v; rfl⟩ + +/-- Scalar multiplication of a Weil differential by `x ∈ K`. -/ +noncomputable def smulWeil (x : K) (ω : WeilDifferential k K) : WeilDifferential k K := by + by_cases hx : x = 0 + · exact ⟨0, ⟨0, by simp⟩⟩ + let xu : Kˣ := Units.mk0 x hx + refine ⟨ω.toFun.comp (mulAdeleLinear k K x), ?_⟩ + obtain ⟨D, hD⟩ := ω.vanishes_on + refine ⟨D + principalDivisorA k K (Additive.ofMul xu), fun a ha => hD _ ?_⟩ + change x • a ∈ adeleFilt k K D + diagonalSubmodule k K + simpa only [xu, Units.val_mk0] using + mul_mem_adeleFilt_add_diagonal (k := k) (K := K) xu D ha + +omit [IsFullConstantField k K] in +@[simp] +theorem smulWeil_toFun_apply (x : K) (ω : WeilDifferential k K) (a : AdeleSpace k K) : + (smulWeil x ω).toFun a = ω.toFun (x • a) := by + by_cases hx : x = 0 + · simp [smulWeil, hx] + · simp only [smulWeil, hx, ↓reduceDIte, LinearMap.comp_apply] + congr 1 + +instance : Zero (WeilDifferential k K) := ⟨⟨0, ⟨0, by simp⟩⟩⟩ + +instance : Add (WeilDifferential k K) where + add ω η := ⟨ω.toFun + η.toFun, by + obtain ⟨Dω, hω⟩ := ω.vanishes_on + obtain ⟨Dη, hη⟩ := η.vanishes_on + refine ⟨Dω ⊓ Dη, fun a ha => ?_⟩ + have hleft : adeleFilt k K (Dω ⊓ Dη) + diagonalSubmodule k K ≤ + adeleFilt k K Dω + diagonalSubmodule k K := by + simpa only [Submodule.add_eq_sup] using + sup_le_sup (adeleFilt_mono k K inf_le_left) le_rfl + have hright : adeleFilt k K (Dω ⊓ Dη) + diagonalSubmodule k K ≤ + adeleFilt k K Dη + diagonalSubmodule k K := by + simpa only [Submodule.add_eq_sup] using + sup_le_sup (adeleFilt_mono k K inf_le_right) le_rfl + simp [hω a (hleft ha), hη a (hright ha)]⟩ + +omit [IsFullConstantField k K] in +@[ext] +theorem ext {ω η : WeilDifferential k K} (h : ω.toFun = η.toFun) : ω = η := by + cases ω + cases η + cases h + rfl + +instance : Neg (WeilDifferential k K) where + neg ω := ⟨-ω.toFun, by + obtain ⟨D, hD⟩ := ω.vanishes_on + exact ⟨D, fun a ha => by simp [hD a ha]⟩⟩ + +instance : AddCommGroup (WeilDifferential k K) where + add_assoc _ _ _ := ext (add_assoc _ _ _) + zero_add _ := ext (zero_add _) + add_zero _ := ext (add_zero _) + add_comm _ _ := ext (add_comm _ _) + nsmul := nsmulRec + nsmul_zero _ := ext rfl + nsmul_succ _ _ := ext rfl + neg := Neg.neg + neg_add_cancel ω := ext (neg_add_cancel ω.toFun) + sub := fun ω η => ω + -η + sub_eq_add_neg _ _ := rfl + zsmul := zsmulRec + +noncomputable instance : SMul K (WeilDifferential k K) := ⟨smulWeil⟩ + +noncomputable instance : Module K (WeilDifferential k K) := + Module.ofMinimalAxioms + (fun x ω η => by + apply ext + ext a + change (smulWeil x (ω + η)).toFun a = + ((smulWeil x ω).toFun + (smulWeil x η).toFun) a + rw [smulWeil_toFun_apply] + change (ω.toFun + η.toFun) (x • a) = + (smulWeil x ω).toFun a + (smulWeil x η).toFun a + rw [LinearMap.add_apply, smulWeil_toFun_apply, smulWeil_toFun_apply]) + (fun x y ω => by + apply ext + ext a + change (smulWeil (x + y) ω).toFun a = + ((smulWeil x ω).toFun + (smulWeil y ω).toFun) a + rw [smulWeil_toFun_apply] + change ω.toFun ((x + y) • a) = + (smulWeil x ω).toFun a + (smulWeil y ω).toFun a + rw [smulWeil_toFun_apply, smulWeil_toFun_apply, add_smul, map_add]) + (fun x y ω => by + apply ext + ext a + change (smulWeil (x * y) ω).toFun a = (smulWeil x (smulWeil y ω)).toFun a + rw [smulWeil_toFun_apply, smulWeil_toFun_apply, smulWeil_toFun_apply] + rw [← mul_smul, mul_comm x y]) + (fun ω => by + apply ext + ext a + change (smulWeil 1 ω).toFun a = ω.toFun a + rw [smulWeil_toFun_apply, one_smul]) + +omit [IsFullConstantField k K] in +theorem smulWeil_algebraMap (c : k) (ω : WeilDifferential k K) (a : AdeleSpace k K) : + (smulWeil (algebraMap k K c) ω).toFun a = c • ω.toFun a := by + rw [smulWeil_toFun_apply, algebraMap_smul, map_smul] + +omit [IsFullConstantField k K] in +theorem smulWeil_eq_zero_iff (x : K) (hx : x ≠ 0) (ω : WeilDifferential k K) : + smulWeil x ω = 0 ↔ ω = 0 := by + constructor + · intro hxω + calc ω = (1 : K) • ω := (one_smul K ω).symm + _ = (x⁻¹ * x) • ω := by rw [inv_mul_cancel₀ hx] + _ = x⁻¹ • (x • ω) := mul_smul x⁻¹ x ω + _ = x⁻¹ • (smulWeil x ω) := rfl + _ = x⁻¹ • (0 : WeilDifferential k K) := by rw [hxω] + _ = 0 := smul_zero x⁻¹ + · intro hω + subst hω + change x • (0 : WeilDifferential k K) = 0 + exact smul_zero x + +omit [IsFullConstantField k K] in +/-- `Ω(D)` is the dual annihilator of `A(D) + K̃`. -/ +theorem differentialSpace_eq_dualAnnihilator (D : DivisorA k K) : + differentialSpace (k := k) (K := K) D = + (adeleFilt k K D + diagonalSubmodule k K).dualAnnihilator := by + ext φ + rw [Submodule.mem_dualAnnihilator] + change (∀ a ∈ adeleFilt k K D + diagonalSubmodule k K, φ a = 0) ↔ _ + rfl + +instance instFiniteDimensionalDifferentialSpace (D : DivisorA k K) : + FiniteDimensional k (differentialSpace (k := k) (K := K) D) := by + rw [differentialSpace_eq_dualAnnihilator D] + exact Module.Finite.equiv + (Submodule.dualQuotEquivDualAnnihilator + (adeleFilt k K D + diagonalSubmodule k K)) + +/-- Divisors `D` for which `ω` vanishes on `A(D)+K̃`. -/ +def vanishingDivisors (ω : WeilDifferential k K) : Set (DivisorA k K) := + {D | ∀ α ∈ adeleFilt k K D + diagonalSubmodule k K, ω.toFun α = 0} + +omit [IsFullConstantField k K] in +/-- `vanishingDivisors` is downward closed. -/ +theorem mem_vanishingDivisors_of_le {ω : WeilDifferential k K} {D D' : DivisorA k K} + (hle : D' ≤ D) (hD : D ∈ vanishingDivisors ω) : D' ∈ vanishingDivisors ω := by + intro α hα + apply hD + have hsub : adeleFilt k K D' + diagonalSubmodule k K ≤ + adeleFilt k K D + diagonalSubmodule k K := by + simpa only [Submodule.add_eq_sup] using + sup_le_sup (adeleFilt_mono k K hle) (le_refl (diagonalSubmodule k K)) + exact hsub hα + +omit [IsFullConstantField k K] in +/-- Underlying functional of a sum of differentials. -/ +theorem add_toFun (ω η : WeilDifferential k K) : + (ω + η).toFun = ω.toFun + η.toFun := rfl + +omit [IsFullConstantField k K] in +/-- If `ω` vanishes on `A(D₀)+K̃` and `f ∈ L(E)`, then `f•ω` vanishes on +`A(D₀−E)+K̃`. -/ +theorem smulWeil_toFun_mem_differentialSpace (ω : WeilDifferential k K) {D₀ : DivisorA k K} + (h : D₀ ∈ vanishingDivisors ω) {E : DivisorA k K} (f : RRspace k K E) : + (smulWeil (f : K) ω).toFun ∈ differentialSpace (k := k) (K := K) (D₀ - E) := by + have hvan : ∀ α ∈ adeleFilt k K D₀ + diagonalSubmodule k K, ω.toFun α = 0 := h + change ∀ a ∈ adeleFilt k K (D₀ - E) + diagonalSubmodule k K, + (smulWeil (f : K) ω).toFun a = 0 + intro a ha + rw [smulWeil_toFun_apply] + by_cases hf : (f : K) = 0 + · rw [hf, zero_smul, map_zero] + · have hmemE : memRRspace k K (D₀ - (D₀ - E)) (f : K) := by + rw [sub_sub_cancel] + exact (mem_RRspace_iff k K E (f : K)).mp f.property + have hdivle : D₀ - E ≤ D₀ + + principalDivisorA k K (Additive.ofMul (Units.mk0 (f : K) hf)) := + le_add_principal_of_memRRspace (k := k) (K := K) (D₀ := D₀ - E) (D₁ := D₀) + hf hmemE + have hle : adeleFilt k K (D₀ - E) + diagonalSubmodule k K ≤ + adeleFilt k K (D₀ + principalDivisorA k K + (Additive.ofMul (Units.mk0 (f : K) hf))) + diagonalSubmodule k K := by + simpa only [Submodule.add_eq_sup] using + sup_le_sup (adeleFilt_mono k K hdivle) (le_refl (diagonalSubmodule k K)) + have hsm := mul_mem_adeleFilt_add_diagonal (k := k) (K := K) + (Units.mk0 (f : K) hf) D₀ (hle ha) + rw [Units.val_mk0] at hsm + exact hvan _ hsm + +/-- For `D₀ ∈ M_ω`, multiplication into `ω` maps `L(E)` into `Ω(D₀ − E)`. -/ +noncomputable def smulIntoOmega (ω : WeilDifferential k K) {D₀ : DivisorA k K} + (h : D₀ ∈ vanishingDivisors ω) (E : DivisorA k K) : + RRspace k K E →ₗ[k] differentialSpace (k := k) (K := K) (D₀ - E) where + toFun f := ⟨(smulWeil (f : K) ω).toFun, smulWeil_toFun_mem_differentialSpace ω h f⟩ + map_add' f g := by + apply Subtype.ext + apply LinearMap.ext + intro a + change (smulWeil ((f : K) + (g : K)) ω).toFun a = + (smulWeil (f : K) ω).toFun a + (smulWeil (g : K) ω).toFun a + rw [smulWeil_toFun_apply, smulWeil_toFun_apply, smulWeil_toFun_apply, add_smul, + map_add] + map_smul' c f := by + apply Subtype.ext + apply LinearMap.ext + intro a + change (smulWeil (c • (f : K)) ω).toFun a = c • (smulWeil (f : K) ω).toFun a + rw [smulWeil_toFun_apply, smulWeil_toFun_apply, Algebra.smul_def, mul_smul, + algebraMap_smul, map_smul] + +omit [IsFullConstantField k K] in +@[simp] +theorem smulIntoOmega_coe (ω : WeilDifferential k K) {D₀ : DivisorA k K} + (h : D₀ ∈ vanishingDivisors ω) (E : DivisorA k K) (f : RRspace k K E) : + (smulIntoOmega ω h E f : AdeleSpace k K →ₗ[k] k) = (smulWeil (f : K) ω).toFun := + rfl + +omit [IsFullConstantField k K] in +theorem smulIntoOmega_injective (ω : WeilDifferential k K) {D₀ : DivisorA k K} + (h : D₀ ∈ vanishingDivisors ω) (E : DivisorA k K) (hω : ω.toFun ≠ 0) : + Function.Injective (smulIntoOmega ω h E) := by + intro f g hfg + by_contra hne + have hd0 : smulIntoOmega ω h E (f - g) = 0 := by + rw [map_sub, hfg, sub_self] + have hval : ((f - g : RRspace k K E) : K) ≠ 0 := by + intro h0 + exact hne (sub_eq_zero.mp (Subtype.ext h0)) + have htoFun : (smulWeil ((f - g : RRspace k K E) : K) ω).toFun = 0 := + congrArg Subtype.val hd0 + have hzero : smulWeil ((f - g : RRspace k K E) : K) ω = 0 := ext htoFun + have hω0 : ω = 0 := (smulWeil_eq_zero_iff _ hval ω).mp hzero + apply hω + rw [hω0] + rfl + +/-- **S2**: the space of Weil differentials is one-dimensional over `K`. -/ +theorem finrank_weilDifferential_eq_one : + Module.finrank K (WeilDifferential k K) = 1 := by + obtain ⟨D₀', hD₀'⟩ := exists_nontrivial_omega (k := k) (K := K) + obtain ⟨φ, hφ, hφ0⟩ := Submodule.exists_mem_ne_zero_of_ne_bot hD₀' + set ω₀ : WeilDifferential k K := ⟨φ, ⟨D₀', hφ⟩⟩ with hω₀def + have hω₀ne : ω₀ ≠ 0 := by + intro h + apply hφ0 + have hval : ω₀.toFun = φ := rfl + rw [← hval, h]; rfl + refine (finrank_eq_one_iff_of_nonzero' ω₀ hω₀ne).mpr ?_ + intro ω + by_contra hspan + push Not at hspan + -- Independence: `f•ω₀ + g•ω = 0 → f = 0 ∧ g = 0`. + have hindep : ∀ f g : K, f • ω₀ + g • ω = 0 → f = 0 ∧ g = 0 := by + intro f g hfg + by_cases hg : g = 0 + · subst hg + rw [zero_smul, add_zero] at hfg + refine ⟨?_, rfl⟩ + by_contra hf + exact hω₀ne ((smulWeil_eq_zero_iff f hf ω₀).mp hfg) + · exfalso + apply hspan (g⁻¹ * (-f)) + have hgω : g • ω = (-f) • ω₀ := by + have hneg : g • ω = -(f • ω₀) := by + rw [eq_neg_iff_add_eq_zero, add_comm]; exact hfg + rw [hneg, neg_smul] + have hω : ω = (g⁻¹ * (-f)) • ω₀ := by + rw [mul_smul, ← hgω, ← mul_smul, inv_mul_cancel₀ hg, one_smul] + exact hω.symm + -- Common vanishing divisor `D₀`. + obtain ⟨D₁, hD₁⟩ := ω₀.vanishes_on + obtain ⟨D₂, hD₂⟩ := ω.vanishes_on + set D₀ : DivisorA k K := D₁ ⊓ D₂ with hD₀def + have h₀ : D₀ ∈ vanishingDivisors ω₀ := + mem_vanishingDivisors_of_le inf_le_left hD₁ + have h₂ : D₀ ∈ vanishingDivisors ω := + mem_vanishingDivisors_of_le inf_le_right hD₂ + -- Pole family. + set B : DivisorA k K := polarDivisor k K (XK k K) with hBdef + have hBpos : 0 < deg k K B := polar_deg_pos k K (not_algebraic_XK k K) + have hb1 : 1 ≤ deg k K B := hBpos + -- The counting bound at level `n`: `2 ℓ(nB) ≤ i(D₀ − nB)`. + have hcount : ∀ n : ℕ, + 2 * (ell k K (n • B) : ℤ) ≤ indexOfSpecialty k K (D₀ - n • B) := by + intro n + set E : DivisorA k K := n • B with hEdef + have hinj : Function.Injective + (LinearMap.coprod (smulIntoOmega ω₀ h₀ E) (smulIntoOmega ω h₂ E)) := by + intro x y hxy + have hd : (LinearMap.coprod (smulIntoOmega ω₀ h₀ E) + (smulIntoOmega ω h₂ E)) (x - y) = 0 := by + rw [map_sub, hxy, sub_self] + rw [LinearMap.coprod_apply] at hd + have hcoe : (smulWeil (((x - y).1 : RRspace k K E) : K) ω₀).toFun + + (smulWeil (((x - y).2 : RRspace k K E) : K) ω).toFun = 0 := by + have h1 := congrArg Subtype.val hd + simpa only [Submodule.coe_add, smulIntoOmega_coe, Submodule.coe_zero] using h1 + have hsum : ((((x - y).1 : RRspace k K E) : K) • ω₀ + + (((x - y).2 : RRspace k K E) : K) • ω).toFun = 0 := by + rw [add_toFun]; exact hcoe + have hzero : (((x - y).1 : RRspace k K E) : K) • ω₀ + + (((x - y).2 : RRspace k K E) : K) • ω = 0 := ext hsum + obtain ⟨hf0, hg0⟩ := hindep _ _ hzero + have hxy0 : x - y = 0 := Prod.ext (Subtype.ext hf0) (Subtype.ext hg0) + exact sub_eq_zero.mp hxy0 + have hfrle : Module.finrank k (RRspace k K E × RRspace k K E) ≤ + Module.finrank k (differentialSpace (k := k) (K := K) (D₀ - E)) := + LinearMap.finrank_le_finrank_of_injective hinj + rw [Module.finrank_prod, finrank_differentialSpace] at hfrle + have hLfr : Module.finrank k (RRspace k K E) = ell k K E := rfl + rw [hLfr] at hfrle + omega + -- Choose `n` large enough to contradict the bound. + set M : ℤ := max (deg k K D₀) (3 * (genus k K : ℤ) - 3 - deg k K D₀) with hMdef + set n : ℕ := M.toNat + 1 with hndef + have hn_ge : (n : ℤ) ≥ M + 1 := by + have hself := Int.self_le_toNat M + push_cast [hndef] + omega + have hn_d0 : (n : ℤ) > deg k K D₀ := by + have hle : deg k K D₀ ≤ M := le_max_left _ _ + omega + have hn_g : (n : ℤ) > 3 * (genus k K : ℤ) - 3 - deg k K D₀ := by + have hle : 3 * (genus k K : ℤ) - 3 - deg k K D₀ ≤ M := le_max_right _ _ + omega + have hnb_ge : (n : ℤ) * deg k K B ≥ (n : ℤ) := by + have hn0 : (0 : ℤ) ≤ (n : ℤ) := Int.natCast_nonneg n + nlinarith [hb1, hn0] + have hdegsub : deg k K (D₀ - n • B) = deg k K D₀ - (n : ℤ) * deg k K B := by + rw [deg_sub, deg_nsmul] + have hdeg_neg : deg k K (D₀ - n • B) < 0 := by + rw [hdegsub]; omega + have hℓ0 : ell k K (D₀ - n • B) = 0 := RRspace_neg_deg_ell k K hdeg_neg + have hi := indexOfSpecialty_eq (k := k) (K := K) (D₀ - n • B) + rw [hℓ0, hdegsub] at hi + have hrr := riemann_ineq (k := k) (K := K) (n • B) + rw [deg_nsmul] at hrr + have hc := hcount n + omega + +omit [IsFullConstantField k K] in +/-- Vanishing divisors translate by the principal divisor under scalar multiplication. -/ +theorem add_principal_mem_vanishingDivisors_smul_iff (x : Kˣ) + (ω : WeilDifferential k K) (D : DivisorA k K) : + D + principalDivisorA k K (Additive.ofMul x) ∈ + vanishingDivisors ((x : K) • ω) ↔ + D ∈ vanishingDivisors ω := by + constructor + · intro h a ha + let P := principalDivisorA k K (Additive.ofMul x) + have hsource : + (D + P) + principalDivisorA k K (Additive.ofMul (x⁻¹ : Kˣ)) = D := by + have hinv : Additive.ofMul (x⁻¹ : Kˣ) = -(Additive.ofMul x) := rfl + rw [hinv, map_neg] + abel + have haSource : a ∈ adeleFilt k K + ((D + P) + principalDivisorA k K (Additive.ofMul (x⁻¹ : Kˣ))) + + diagonalSubmodule k K := by + simpa only [hsource] using ha + have ha' := mul_mem_adeleFilt_add_diagonal (k := k) (K := K) + (x⁻¹ : Kˣ) (D + P) haSource + have hz := h (((x⁻¹ : Kˣ) : K) • a) ha' + change (smulWeil (x : K) ω).toFun (((x⁻¹ : Kˣ) : K) • a) = 0 at hz + rw [smulWeil_toFun_apply] at hz + simpa [mul_smul] using hz + · intro h a ha + change (smulWeil (x : K) ω).toFun a = 0 + rw [smulWeil_toFun_apply] + exact h _ (mul_mem_adeleFilt_add_diagonal (k := k) (K := K) x D ha) + +omit [IsFullConstantField k K] in +/-- Directedness of the vanishing set: it is closed under `⊔`. -/ +theorem sup_mem_vanishingDivisors {ω : WeilDifferential k K} {D₁ D₂ : DivisorA k K} + (hD₁ : D₁ ∈ vanishingDivisors ω) (hD₂ : D₂ ∈ vanishingDivisors ω) : + D₁ ⊔ D₂ ∈ vanishingDivisors ω := by + intro α hα + rw [Submodule.add_eq_sup, adeleFilt_sup_eq_add, ← Submodule.add_eq_sup] at hα + rw [Submodule.add_eq_sup] at hα + rcases Submodule.mem_sup.mp hα with ⟨a, ha, d, hd, rfl⟩ + rw [Submodule.add_eq_sup] at ha + rcases Submodule.mem_sup.mp ha with ⟨a₁, ha₁, a₂, ha₂, rfl⟩ + have hsplit : a₁ + a₂ + d = (a₁ + d) + a₂ := by abel + rw [hsplit, map_add] + have h1 : ω.toFun (a₁ + d) = 0 := by + apply hD₁ + rw [Submodule.add_eq_sup] + exact Submodule.add_mem_sup ha₁ hd + have h2 : ω.toFun a₂ = 0 := by + apply hD₂ + rw [Submodule.add_eq_sup] + exact Submodule.mem_sup_left ha₂ + rw [h1, h2, add_zero] + +/-- Degree bound (duality-free): a vanishing divisor of a nonzero `ω` has degree `≤ 2g − 1`. -/ +theorem deg_le_of_mem_vanishingDivisors {ω : WeilDifferential k K} (hω : ω.toFun ≠ 0) + {D : DivisorA k K} (hD : D ∈ vanishingDivisors ω) : + deg k K D ≤ 2 * (genus k K : ℤ) - 1 := by + have hinj : Function.Injective (smulIntoOmega ω hD D) := + smulIntoOmega_injective ω hD D hω + have hle : Module.finrank k (RRspace k K D) ≤ + Module.finrank k (differentialSpace (k := k) (K := K) (D - D)) := + LinearMap.finrank_le_finrank_of_injective hinj + have hDD : D - D = (0 : DivisorA k K) := sub_self D + have hΩ : Module.finrank k (differentialSpace (k := k) (K := K) (D - D)) = genus k K := by + rw [hDD, finrank_differentialSpace] + have hidx := indexOfSpecialty_eq (k := k) (K := K) (0 : DivisorA k K) + rw [ell_zero (k := k) (K := K), deg_zero (k := k) (K := K)] at hidx + omega + have hℓg : (ell k K D : ℤ) ≤ (genus k K : ℤ) := by + have hnat : ell k K D ≤ genus k K := by + rw [show ell k K D = Module.finrank k (RRspace k K D) from rfl, ← hΩ] + exact hle + exact_mod_cast hnat + have hRR := riemann_ineq (k := k) (K := K) D + omega + +theorem exists_max_vanishingDivisor {ω : WeilDifferential k K} (hω : IsNonzero ω) : + ∃! W : DivisorA k K, W ∈ vanishingDivisors ω ∧ + ∀ D ∈ vanishingDivisors ω, D ≤ W := by + have hω' : ω.toFun ≠ 0 := hω + set P : ℤ → Prop := fun z => ∃ D ∈ vanishingDivisors ω, deg k K D = z with hP + have hInh : ∃ z, P z := by + obtain ⟨D₀, hD₀⟩ := ω.vanishes_on + exact ⟨deg k K D₀, D₀, hD₀, rfl⟩ + have hBdd : ∃ b : ℤ, ∀ z, P z → z ≤ b := by + refine ⟨2 * (genus k K : ℤ) - 1, ?_⟩ + rintro z ⟨D, hD, rfl⟩ + exact deg_le_of_mem_vanishingDivisors hω' hD + obtain ⟨ub, ⟨W, hWmem, hWdeg⟩, hubmax⟩ := Int.exists_greatest_of_bdd hBdd hInh + have hmaxdiv : ∀ D ∈ vanishingDivisors ω, D ≤ W := by + intro D hD + have hsup : D ⊔ W ∈ vanishingDivisors ω := sup_mem_vanishingDivisors hD hWmem + have hdegle : deg k K (D ⊔ W) ≤ ub := hubmax _ ⟨D ⊔ W, hsup, rfl⟩ + have hWle : W ≤ D ⊔ W := le_sup_right + have hdegW : deg k K (D ⊔ W) ≤ deg k K W := by rw [hWdeg]; exact hdegle + have heq : W = D ⊔ W := eq_of_le_of_deg_le k K hWle hdegW + rw [heq]; exact le_sup_left + refine ⟨W, ⟨hWmem, hmaxdiv⟩, ?_⟩ + rintro W' ⟨hW'mem, hW'max⟩ + exact le_antisymm (hmaxdiv W' hW'mem) (hW'max W hWmem) + +/-- The divisor of a nonzero Weil differential. -/ +noncomputable def divOmega (ω : WeilDifferential k K) (hω : IsNonzero ω) : DivisorA k K := + Classical.choose (exists_max_vanishingDivisor (k := k) (K := K) hω) + +theorem divOmega_smul (x : Kˣ) (ω : WeilDifferential k K) (hω : IsNonzero ω) + (hxω : IsNonzero ((x : K) • ω)) : + WeilDifferential.divOmega ((x : K) • ω) hxω = + WeilDifferential.divOmega ω hω + principalDivisorA k K (Additive.ofMul x) := by + let W := WeilDifferential.divOmega ω hω + let P := principalDivisorA k K (Additive.ofMul x) + have hmax : W ∈ vanishingDivisors ω ∧ + ∀ D ∈ vanishingDivisors ω, D ≤ W := by + simpa only [W, divOmega] using + (Classical.choose_spec (exists_max_vanishingDivisor (k := k) (K := K) hω)).1 + have htarget : W + P ∈ vanishingDivisors ((x : K) • ω) ∧ + ∀ E ∈ vanishingDivisors ((x : K) • ω), E ≤ W + P := by + constructor + · exact (add_principal_mem_vanishingDivisors_smul_iff + (k := k) (K := K) x ω W).2 hmax.1 + · intro E hE + have htranslate : (E - P) + P = E := by abel + have hE' : E - P ∈ vanishingDivisors ω := by + apply (add_principal_mem_vanishingDivisors_smul_iff + (k := k) (K := K) x ω (E - P)).1 + simpa only [P, htranslate] using hE + have hle := hmax.2 (E - P) hE' + intro v + have hv := hle v + simp only [Finsupp.sub_apply, Finsupp.add_apply] at hv ⊢ + omega + let hex := exists_max_vanishingDivisor (k := k) (K := K) hxω + have hchosen : WeilDifferential.divOmega ((x : K) • ω) hxω ∈ + vanishingDivisors ((x : K) • ω) ∧ + ∀ D ∈ vanishingDivisors ((x : K) • ω), + D ≤ WeilDifferential.divOmega ((x : K) • ω) hxω := by + simpa only [divOmega, hex] using (Classical.choose_spec hex).1 + exact hex.unique hchosen htarget + +end WeilDifferential + +/-- A divisor is canonical when it is the divisor of a nonzero Weil differential. -/ +def IsCanonical (W : DivisorA k K) : Prop := + ∃ (ω : WeilDifferential k K) (hω : WeilDifferential.IsNonzero ω), + WeilDifferential.divOmega ω hω = W + +/-- A function field admits a canonical divisor. -/ +theorem exists_isCanonical : ∃ W : DivisorA k K, IsCanonical k K W := by + obtain ⟨D, hD⟩ := WeilDifferential.exists_nontrivial_omega (k := k) (K := K) + obtain ⟨φ, hφ, hφ0⟩ := Submodule.exists_mem_ne_zero_of_ne_bot hD + let ω : WeilDifferential k K := ⟨φ, ⟨D, hφ⟩⟩ + have hω : WeilDifferential.IsNonzero ω := hφ0 + exact ⟨WeilDifferential.divOmega ω hω, ω, hω, rfl⟩ + +theorem isCanonical_unique_up_to_principal {W₁ W₂ : DivisorA k K} + (h₁ : IsCanonical k K W₁) (h₂ : IsCanonical k K W₂) : + ∃ f : Kˣ, W₁ - W₂ = principalDivisorA k K (Additive.ofMul f) := by + rcases h₁ with ⟨ω₁, hω₁, rfl⟩ + rcases h₂ with ⟨ω₂, hω₂, rfl⟩ + have hω₁0 : ω₁ ≠ 0 := by + intro h + apply hω₁ + rw [h] + rfl + have hω₂0 : ω₂ ≠ 0 := by + intro h + apply hω₂ + rw [h] + rfl + obtain ⟨c, hc⟩ := exists_smul_eq_of_finrank_eq_one (K := K) + (WeilDifferential.finrank_weilDifferential_eq_one (k := k) (K := K)) hω₂0 ω₁ + have hc0 : c ≠ 0 := by + intro h + subst c + apply hω₁0 + simpa only [zero_smul] using hc.symm + let f : Kˣ := Units.mk0 c hc0 + have hcf : (f : K) • ω₂ = ω₁ := by + simpa only [f, Units.val_mk0] using hc + have hnontrivial : WeilDifferential.IsNonzero ((f : K) • ω₂) := by + exact hcf.symm ▸ hω₁ + refine ⟨f, ?_⟩ + have hdiv := WeilDifferential.divOmega_smul (k := k) (K := K) f ω₂ hω₂ hnontrivial + calc + WeilDifferential.divOmega ω₁ hω₁ - WeilDifferential.divOmega ω₂ hω₂ = + WeilDifferential.divOmega ((f : K) • ω₂) hnontrivial - + WeilDifferential.divOmega ω₂ hω₂ := by + congr 2 + exact hcf.symm + _ = principalDivisorA k K (Additive.ofMul f) := by rw [hdiv]; abel + +open WeilDifferential in +theorem duality {W : DivisorA k K} (hW : IsCanonical k K W) (D : DivisorA k K) : + ell k K (W - D) = indexOfSpecialty k K D := by + obtain ⟨ω₀, hω₀, hdivW⟩ := hW + have hω₀' : ω₀.toFun ≠ 0 := hω₀ + have hω₀ne : ω₀ ≠ 0 := fun h => hω₀ (by rw [h]; rfl) + -- `W` is the maximum vanishing divisor of `ω₀`. + have hWspec : W ∈ vanishingDivisors ω₀ ∧ + ∀ D' ∈ vanishingDivisors ω₀, D' ≤ W := by + have h := (Classical.choose_spec + (WeilDifferential.exists_max_vanishingDivisor (k := k) (K := K) hω₀)).1 + have he : Classical.choose + (WeilDifferential.exists_max_vanishingDivisor (k := k) (K := K) hω₀) = W := hdivW + rw [he] at h + exact h + obtain ⟨hWmem, hWmax⟩ := hWspec + have hWD : W - (W - D) = D := sub_sub_cancel W D + -- The multiplication map `μ : L(W − D) → Ω(W − (W − D))`. + set μ := smulIntoOmega ω₀ hWmem (W - D) with hμdef + have hμinj : Function.Injective μ := smulIntoOmega_injective ω₀ hWmem (W - D) hω₀' + have hμsurj : Function.Surjective μ := by + intro ψ + set φ : AdeleSpace k K →ₗ[k] k := (ψ : AdeleSpace k K →ₗ[k] k) with hφdef + by_cases hψ0 : φ = 0 + · exact ⟨0, by rw [map_zero]; exact (Subtype.ext hψ0).symm⟩ + · -- Package `ψ` as a nonzero differential vanishing on `A(D)+K̃`. + have hψmem : ∀ α ∈ adeleFilt k K D + diagonalSubmodule k K, φ α = 0 := by + have hp : ∀ α ∈ adeleFilt k K (W - (W - D)) + diagonalSubmodule k K, φ α = 0 := + ψ.property + rw [hWD] at hp + exact hp + set η : WeilDifferential k K := ⟨φ, ⟨D, hψmem⟩⟩ with hηdef + have hηnt : η.toFun ≠ 0 := hψ0 + obtain ⟨c, hc⟩ := exists_smul_eq_of_finrank_eq_one (K := K) + (WeilDifferential.finrank_weilDifferential_eq_one (k := k) (K := K)) hω₀ne η + have hc0 : c ≠ 0 := by + intro h + subst h + apply hηnt + have hη0 : η = 0 := by rw [← hc, zero_smul] + rw [hη0]; rfl + set cu : Kˣ := Units.mk0 c hc0 with hcudef + set P : DivisorA k K := principalDivisorA k K (Additive.ofMul cu) with hPdef + -- `D ∈ M_{c•ω₀}` translates to `D − P ∈ M_ω₀`. + have hDmem : D ∈ vanishingDivisors ((cu : K) • ω₀) := by + have hcω : (cu : K) • ω₀ = η := by + rw [Units.val_mk0]; exact hc + rw [hcω] + intro α hα + exact hψmem α hα + have hDPmem : D - P ∈ vanishingDivisors ω₀ := by + apply (add_principal_mem_vanishingDivisors_smul_iff (k := k) (K := K) cu ω₀ (D - P)).1 + have hsub : (D - P) + P = D := by rw [hPdef]; abel + rw [hsub]; exact hDmem + have hDPle : D - P ≤ W := hWmax (D - P) hDPmem + -- Hence `c ∈ L(W − D)`. + have hcmem : memRRspace k K (W - D) c := by + intro v + have hval := placeValuation_eq_exp_neg_principalDivisor k K (Additive.ofMul cu) v + change placeValuation k K v c ≤ WithZero.exp ((W - D) v) + have hcv : placeValuation k K v c = + WithZero.exp (-(P v)) := by + rw [hPdef] + have hcuc : (cu : K) = c := by simp [hcudef] + rw [← hcuc]; exact hval + rw [hcv] + apply WithZero.exp_le_exp.mpr + have hlev := hDPle v + simp only [Finsupp.sub_apply] at hlev ⊢ + omega + refine ⟨⟨c, (mem_RRspace_iff k K (W - D) c).mpr hcmem⟩, ?_⟩ + apply Subtype.ext + rw [hμdef, smulIntoOmega_coe] + change ((c : K) • ω₀).toFun = φ + rw [hc] + -- Conclude via the induced equivalence. + have hfr : Module.finrank k (RRspace k K (W - D)) = + Module.finrank k (differentialSpace (k := k) (K := K) (W - (W - D))) := + (LinearEquiv.ofBijective μ ⟨hμinj, hμsurj⟩).finrank_eq + change Module.finrank k (RRspace k K (W - D)) = indexOfSpecialty k K D + rw [hfr, hWD, finrank_differentialSpace] + +theorem indexOfSpecialty_eq_ell_sub {W : DivisorA k K} (hW : IsCanonical k K W) (D : DivisorA k K) : + (indexOfSpecialty k K D : ℤ) = ell k K (W - D) := by + exact_mod_cast (duality k K hW D).symm + +end FunctionField.Chart + +end diff --git a/LeanPool/projects.yml b/LeanPool/projects.yml index 5d174fc0b3..330f4883c8 100644 --- a/LeanPool/projects.yml +++ b/LeanPool/projects.yml @@ -10563,3 +10563,31 @@ projects: - 20E05 - 68Q45 - 03B35 + - slug: markoff-modp + title: Markoff mod p + summary: Lean 4 formalization of strong approximation for the Markoff surface modulo + sufficiently large primes. The primary source is Bourgain-Gamburd-Sarnak. + branch: number theory + entry_module: LeanPool.MarkoffModP + authors: + - Yuma Mizuno + - Guanghao Li + source: + url: https://github.com/yuma-mizuno/markoff-modp + github_repo: yuma-mizuno/markoff-modp + commit: ac1099fc96b0f1cf6e6099c74a24b783691c21aa + license: Apache-2.0 + status: verified + provenance: AI + main_declarations: + - BGS.Markoff.reduction_surjective_of_explicitBound + main_results: + - declaration: BGS.Markoff.reduction_surjective_of_explicitBound + informal: For primes exceeding the explicit bound, reduction of integral Markoff + points to the Markoff surface modulo p is surjective as specified by the theorem. + tags: + - markoff-equation + - strong-approximation + - finite-fields + msc: + - 11D25